master..bd3968e · typeable/postgresql-simple

git.iko.soy/typeable/postgresql-simple

63 files changed+2008−6352

unifiedsplit

.ghcinew file+2

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

1+:set -isrc

2+:set Wall

.github/workflows/haskell-ci.ymldeleted−256

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

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

2−#

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

4−#

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

6−#

7−# haskell-ci regenerate

8−#

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

10−#

11−# version: 0.17.20231110

12−#

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

14−#

15−name: Haskell-CI

16−on:

17− push:

18− branches:

19− - master

20− pull_request:

21− branches:

22− - master

23−jobs:

24− linux:

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

26− runs-on: ubuntu-20.04

27− timeout-minutes:

28− 60

29− container:

30− image: buildpack-deps:bionic

31− services:

32− postgres:

33− image: postgres:14

34− env:

35− POSTGRES_PASSWORD: postgres

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

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

38− strategy:

39− matrix:

40− include:

41− - compiler: ghc-9.8.1

42− compilerKind: ghc

43− compilerVersion: 9.8.1

44− setup-method: ghcup

45− allow-failure: false

46− - compiler: ghc-9.6.3

47− compilerKind: ghc

48− compilerVersion: 9.6.3

49− setup-method: ghcup

50− allow-failure: false

51− - compiler: ghc-9.4.8

52− compilerKind: ghc

53− compilerVersion: 9.4.8

54− setup-method: ghcup

55− allow-failure: false

56− - compiler: ghc-9.2.8

57− compilerKind: ghc

58− compilerVersion: 9.2.8

59− setup-method: ghcup

60− allow-failure: false

61− - compiler: ghc-9.0.2

62− compilerKind: ghc

63− compilerVersion: 9.0.2

64− setup-method: ghcup

65− allow-failure: false

66− - compiler: ghc-8.10.7

67− compilerKind: ghc

68− compilerVersion: 8.10.7

69− setup-method: ghcup

70− allow-failure: false

71− - compiler: ghc-8.8.4

72− compilerKind: ghc

73− compilerVersion: 8.8.4

74− setup-method: hvr-ppa

75− allow-failure: false

76− - compiler: ghc-8.6.5

77− compilerKind: ghc

78− compilerVersion: 8.6.5

79− setup-method: hvr-ppa

80− allow-failure: false

81− fail-fast: false

82− steps:

83− - name: apt

84− run: |

85− apt-get update

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

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

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

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

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

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

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

93− else

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

95− apt-get update

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

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

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

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

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

101− fi

102− env:

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

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

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

106− - name: Set PATH and environment variables

107− run: |

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

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

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

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

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

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

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

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

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

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

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

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

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

121− else

122− HC=$HCDIR/bin/$HCKIND

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

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

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

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

127− fi

128−

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

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

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

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

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

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

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

136− env:

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

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

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

140− - name: env

141− run: |

142− env

143− - name: write cabal config

144− run: |

145− mkdir -p $CABAL_DIR

146− cat >> $CABAL_CONFIG <<EOF

147− remote-build-reporting: anonymous

148− write-ghc-environment-files: never

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

150− logs-dir: $CABAL_DIR/logs

151− world-file: $CABAL_DIR/world

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

153− symlink-bindir: $CABAL_DIR/bin

154− installdir: $CABAL_DIR/bin

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

156− store-dir: $CABAL_DIR/store

157− install-dirs user

158− prefix: $CABAL_DIR

159− repository hackage.haskell.org

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

161− EOF

162− cat >> $CABAL_CONFIG <<EOF

163− program-default-options

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

165− EOF

166− cat $CABAL_CONFIG

167− - name: versions

168− run: |

169− $HC --version || true

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

171− $CABAL --version || true

172− - name: update cabal index

173− run: |

174− $CABAL v2-update -v

175− - name: install cabal-plan

176− run: |

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

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

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

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

181− rm -f cabal-plan.xz

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

183− cabal-plan --version

184− - name: checkout

185− uses: actions/checkout@v3

186− with:

187− path: source

188− - name: initial cabal.project for sdist

189− run: |

190− touch cabal.project

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

192− cat cabal.project

193− - name: sdist

194− run: |

195− mkdir -p sdist

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

197− - name: unpack

198− run: |

199− mkdir -p unpacked

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

201− - name: generate cabal.project

202− run: |

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

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

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

206− touch cabal.project

207− touch cabal.project.local

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

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

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

211− cat >> cabal.project <<EOF

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

213− EOF

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

215− cat cabal.project

216− cat cabal.project.local

217− - name: dump install plan

218− run: |

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

220− cabal-plan

221− - name: restore cache

222− uses: actions/cache/restore@v3

223− with:

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

225− path: ~/.cabal/store

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

227− - name: install dependencies

228− run: |

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

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

231− - name: build w/o tests

232− run: |

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

234− - name: build

235− run: |

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

237− - name: tests

238− run: |

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

240− - name: cabal check

241− run: |

242− cd ${PKGDIR_postgresql_simple} || false

243− ${CABAL} -vnormal check

244− - name: haddock

245− run: |

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

247− - name: unconstrained build

248− run: |

249− rm -f cabal.project.local

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

251− - name: save cache

252− uses: actions/cache/save@v3

253− if: always()

254− with:

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

256− path: ~/.cabal/store

.github/workflows/simple.ymldeleted−58

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

1−name: Simple

2−on:

3− push:

4− branches:

5− - master

6− pull_request:

7− branches:

8− - master

9−

10−jobs:

11− native:

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

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

14− strategy:

15− matrix:

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

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

18− fail-fast: false

19− timeout-minutes:

20− 60

21− steps:

22− - name: Set git to use LF

23− run: |

24− git config --global core.autocrlf false

25− git config --global core.eol lf

26−

27− - name: Set up Haskell

28− id: setup-haskell

29− uses: haskell/actions/setup@v2

30− with:

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

32− cabal-version: '3.10.2.0'

33−

34− - name: Set up PostgreSQL

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

36− id: postgres

37− with:

38− username: ci

39− password: sw0rdfish

40− database: test

41−

42− - name: Checkout

43− uses: actions/checkout@v3.0.2

44−

45− - name: Cache

46− uses: actions/cache@v2.1.3

47− with:

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

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

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

51−

52− - name: Build

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

54−

55− - name: Test

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

57− env:

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

.gitignore+1−8

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

77*.o

88\#*\#

99.#*

10−/CHANGELOG.md

11−.cabal-sandbox/

12−.stack-work/

13−cabal.sandbox.config

14−/dist-newstyle

15−.ghc.environment.*

16−cabal.project.local

17−dump-core

10+postgresql-simple-*.tar.gz

CHANGESnew file+365

@@ -0,0 +1,365 @@

1+Version 0.4.2.3 (2014-06-04)

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

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

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

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

8+ documentation about the authentication process.

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

11+

12+Version 0.4.2.2 (2014-05-15)

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

14+

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

16+ foldWithOptions, executeMany, and returning operators.

17+

18+Version 0.4.2.1 (2014-03-27)

19+ * Fixed bug in Values syntax generation

20+

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

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

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

24+ for QualifiedIdentifier.

25+

26+Version 0.4.2.0 (2014-03-22)

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

28+

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

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

31+ major verson bump, but let's pretend 0.4.1.0 didn't happen.

32+

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

34+ and tweaked error messages.

35+

36+Version 0.4.1.0 (2014-03-22)

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

38+ Francesco Mazzoli

39+

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

41+ Tobias Florek. See the new Identifier and QualifiedIdentifier

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

43+

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

45+ more general than executeMany and returning. See the

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

47+

48+Version 0.4.0.2 (2014-01-12)

49+ * Tweaked C preprocessor directive to be more portable

50+

51+ * Tweaked testsuite for compatibility with aeson-0.7

52+

53+Version 0.4.0.1 (2013-12-21)

54+ * Relaxed dependency on aeson to >= 0.6

55+

56+ * Update the documentation of `fromField`

57+

58+Version 0.4.0.0 (2013-12-21)

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

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

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

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

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

64+ See commit 8635f8 for more information.

65+

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

67+

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

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

70+ Thanks to Amit Levy for the report.

71+

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

73+

74+Version 0.3.10.0 (2013-12-17)

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

76+

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

78+

79+Version 0.3.9.1 (2013-10-28)

80+ * Removed dependency on hashable

81+

82+Version 0.3.9.0 (2013-10-27)

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

84+ courtesy of Bas van Dijk.

85+

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

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

88+

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

90+ unwrapper functions, courtesy of Bas van Dijk.

91+

92+Version 0.3.8.0 (2013-10-11)

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

94+

95+ * Added `Notification.getBackendPID`.

96+

97+Version 0.3.7.1 (2013-09-12)

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

99+ courtesy of Michael Snoyman

100+

101+Version 0.3.7.0 (2013-09-11)

102+ * Added `aeson` as a dependency.

103+

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

105+ courtesy of Bas van Dijk.

106+

107+ * Added toJSONField and fromJSONField helper functions for declaring

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

109+ of Bas van Dijk.

110+

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

112+ type.

113+

114+ * Added liftConversion and liftRowParser functions to the Internal

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

116+

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

118+ also exported from the Errors module.

119+

120+ * Various documentation fixes.

121+

122+Version 0.3.6.0 (2013-08-19)

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

124+ Manuel Gómez.

125+

126+ * Removed the remaining internal dependencies on BuiltinTypes from

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

128+

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

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

131+ this change.

132+

133+Version 0.3.5.0 (2013-08-09)

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

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

136+

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

138+ documentation for the LargeObjects module.

139+

140+Version 0.3.4.0 (2013-07-23)

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

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

143+ module.

144+

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

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

147+ the connection's file descriptor from libpq.

148+

149+Version 0.3.3.2 (2013-06-18)

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

151+ the Query type, courtesy of Joey Adams.

152+

153+Version 0.3.3.1 (2013-06-06)

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

155+ polling loop, courtesy of Joey Adams.

156+

157+Version 0.3.3.0 (2013-05-29)

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

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

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

161+ work on these issues.

162+

163+Version 0.3.2.0 (2013-05-20)

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

165+ of Joey Adams

166+

167+Version 0.3.1.2 (2013-04-29)

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

169+

170+Version 0.3.1.1 (2013-04-29)

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

172+ Meier

173+

174+Version 0.3.1.0 (2013-04-26)

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

176+

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

178+

179+ * Improved documentation of the FromField module.

180+

181+Version 0.3.0.1 (2013-03-26)

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

183+ silently failed to render in Haddock.

184+

185+Version 0.3.0.0 (2013-03-25)

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

187+ for his work on this feature.

188+

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

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

191+ replaced the older typename cache, and was neccesary to properly

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

193+ work on this feature.

194+

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

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

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

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

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

200+ that conversion computations run inside.

201+

202+ * Improved the documentation of the FromField module.

203+

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

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

206+ of Leonid Onokhov.

207+

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

209+ to ResultError exceptions, courtesy of Jeff Chu.

210+

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

212+ Database.PostgreSQL.Simple.Transaction module.

213+

214+ * Changed withTransactionModeRetry to accept a predicate of which

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

216+ sometimes manifest themselves as constraint violations. Thanks

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

218+

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

220+

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

222+

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

224+ now stripped out.

225+

226+

227+Version 0.2.4.1 (2012-08-29)

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

229+ pointing this out.

230+

231+Version 0.2.4.0 (2012-08-23)

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

233+ operators, thanks to Joey Adams.

234+

235+Version 0.2.3.0 (2012-08-09)

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

237+

238+Version 0.2.2.0 (2012-07-26)

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

240+

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

242+

243+Version 0.2.1.0 (2012-07-23)

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

245+

246+ * Added a type synonym for FieldParser

247+

248+Version 0.2.0.1 (2012-06-21)

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

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

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

252+

253+Version 0.2: (2012-06-19)

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

255+ broken even though it will still compile.

256+

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

258+

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

260+

261+

262+Version 0.1.4.3: (2012-06-10)

263+ * Fix language extensions for compatibility with GHC 7.0

264+

265+Version 0.1.4.2: (2012-06-10)

266+ * Fix a wayward dependency on Text.

267+

268+Version 0.1.4.1: (2012-06-10)

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

270+

271+Version 0.1.4: (2012-06-10)

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

273+

274+ * Reworked support for the Time types.

275+

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

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

278+

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

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

281+

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

283+ that accomodate PostgreSQL's infinities.

284+

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

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

287+ time package included in GHC.

288+

289+ * Planned breaking changes for 0.2:

290+

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

292+

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

294+

295+

296+Version 0.1.3: (2012-05-30)

297+ * Made ZonedTime an instance of FromField and ToField

298+

299+ * Added getNotificationNonBlocking

300+

301+

302+Version 0.1.2: (2012-05-09)

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

304+ PostgreSQL 8 courtesy of Joey Adams.

305+

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

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

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

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

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

311+

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

313+

314+

315+Version 0.1.1: (2012-05-06)

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

317+ LargeObjects modules

318+

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

320+

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

322+

323+

324+Version 0.1: (2012-05-04)

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

326+

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

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

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

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

331+

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

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

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

335+

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

337+ `Either SomeException` to `Ok`.

338+

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

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

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

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

343+ example comparing the old to the new:

344+

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

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

347+ !a <- convert fa va

348+ !b <- convert fb vb

349+ return (a,b)

350+ convertResults fs vs = convertError fs vs 2

351+

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

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

354+

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

356+

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

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

359+

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

361+

362+ * Removed the `RawResult` type.

363+

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

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

CHANGES.mddeleted−746

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

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

2−

3− * Remove Eq Null instance. (Future `base` may break it, we remove it profilacticly).

4− * Use `postgresql-libpq >=0.10.0.0`. It includes critical fixes,

5− by using `postgresql-simple >=0.7` you won't get older `postgresql-libpq`.

6− * Drop support for GHC prior 8.6

7− * Added a class for `postgresql-simple` exceptions: `SomePostgreSqlException`.

8− This allows to catch all `postgresql-simple` exceptions at once.

9− (c.f. `AsyncException` in `base).

10−

11−### Version 0.6.5.1 (2023-07-09)

12−

13− * Support `aeson-2.2.0.0`

14−

15−### Version 0.6.5 (2022-10-30)

16−

17− * Add `withConnect`

18−

19−### Version 0.6.4 (2021-01-06)

20−

21− * Add foldCopyData helper function

22− Thanks to Sebastián Estrella for the implementation

23− https://github.com/haskellari/postgresql-simple/pull/56

24− * Implement support for postgresql 'interval' type

25− Thanks to Andre Marques Lee for the implementation

26− https://github.com/haskellari/postgresql-simple/pull/60

27− * Depend on `time-compat` to provide uniform `time` related interface.

28−

29−### Version 0.6.3 (2020-11-15)

30−

31− * Add `fromFieldJSONByteString`

32− Thanks to tomjaguarpaw for the implementation

33− https://github.com/haskellari/postgresql-simple/pull/47

34− * Add `attoFieldParser`

35− Thanks to Victor Nawothnig for the implementation

36− https://github.com/haskellari/postgresql-simple/pull/45

37− * Add `Identity` and `Const` instance

38− Thanks to Cary Robbins for the implementation

39− https://github.com/haskellari/postgresql-simple/pull/46

40− * Add `withTransactionModeRetry'`, a variant of `withTransactionModeRetry`

41− for all exception types.

42− Thanks to Elliot Cameron for the implementation

43− https://github.com/haskellari/postgresql-simple/pull/42

44− * Fix spurious aborts when retrying transactions

45− Thanks to Elliot Cameron for the implementation

46− https://github.com/haskellari/postgresql-simple/pull/34

47− * Add `Database.PostgreSQL.Simple.Newtypes` module

48− with `Aeson` newtype.

49− https://github.com/haskellari/postgresql-simple/pull/55

50−

51−### Version 0.6.2 (2019-04-26)

52−

53− * Define `MonadFail Ok`.

54−

55−### Version 0.6.1 (2019-03-04)

56−

57− * Escape double '??' to a literal '?

58− Thanks to Felix Paulusma for the implementation.

59− https://github.com/phadej/postgresql-simple/pull/5

60−

61− * Mention GHC Generics support in the documentation.

62− Thanks to Gabriel Gonzalez for the implementation.

63− https://github.com/phadej/postgresql-simple/pull/6

64−

65− * Better error message for "Query resulted in a command response

66− Thanks to Max Amanshauser for the implementation.

67− https://github.com/phadej/postgresql-simple/pull/7

68−

69− * fromJSONField: Include JSONPath on JSON parse errors

70− Thanks to Simon Hengel for the implementation.

71− https://github.com/phadej/postgresql-simple/pull/2

72−

73− * No TH in implementation

74− https://github.com/phadej/postgresql-simple/pull/4

75−

76−### Version 0.6 (2018-10-16)

77−

78− * *Breaking change*: Use `Only` package's `Only` for a common 1-tuple.

79−

80− Consider a downstream library depending already both on

81− `Only` and `postgresql-simple` package. This library my define

82− a `MyClass` with instances for `Only.Only` and `PostgreSQL.Only`.

83− As now these types are the same, a library would break.

84− Therefore I consider "merging" types a breaking change.

85−

86− There are two ways for adopting this change in that scenario:

87−

88− - Either CPP-guard `PostgreSQL.Only` instance with

89−

90− ```haskell

91− #if !MIN_VERSION_postgresql_simple(0,6,0)

92− instance MyClass (PostgreSQL.Only a) where ...

93− #endif

94− ```

95−

96− - or simply remove it and add `postgresql-simple >=0.6` lower bound,

97− making sure that there's only single `Only`.

98−

99− * Add `ToField` instances for case-insensitive strict and lazy text.

100− Thanks to Max Tagher for the implementation.

101− https://github.com/lpsmith/postgresql-simple/pull/232

102−

103− * Add support to CockroachDB.

104− Thanks to Georte Steel.

105− https://github.com/lpsmith/postgresql-simple/pull/245

106−

107− * Add Generic ConnectInfo instance

108− Thanks to Dmitry Dzhus.

109− https://github.com/lpsmith/postgresql-simple/pull/235

110−

111− * Add `fromFieldRange :: Typeable a => FieldParser a -> FieldParser (PGRange a)`

112− https://github.com/lpsmith/postgresql-simple/pull/221

113−

114− * Add `fromFieldJSONByteString :: FieldParser ByteString`

115− https://github.com/lpsmith/postgresql-simple/pull/222/files

116−

117− * Fix off-by-one error in year builder.

118− Thanks to Nathan Ferris Hunter.

119− https://github.com/lpsmith/postgresql-simple/pull/230

120−

121− * Extend ToRow and FromRow to tuples of size 18

122− Thanks to Bardur Arantsson.

123− https://github.com/lpsmith/postgresql-simple/pull/229

124−

125− * Add `Vector` and `Vector.Unboxed` `query` variants.

126− These are more memory efficient

127− (especially, if you anyway will convert to some vector)

128− https://github.com/phadej/1

129−

130− * Documentation improvements

131− https://github.com/lpsmith/postgresql-simple/pull/227

132− https://github.com/lpsmith/postgresql-simple/pull/236

133−

134−### Version 0.5.4.0 (2018-05-23)

135− * Support GHC-8.4 (Semigroup/Monoid)

136−

137−### Version 0.5.3.0 (2017-05-15)

138− * Refactored some rudimentary cursor handling code out of the

139− implementation of the fold operators, into a new

140− `Database.PostgreSQL.Simple.Cursor` module, thanks to Bardur Arantsson.

141−

142− * Made the `FromField` instance for `Char` compatible with

143− postgresql's `bpchar` type. Thanks to Ivan Lazar Miljenovic for

144− reporting the issue.

145−

146− * Added `Show` and `Eq` instances for `Notification`, thanks to

147− Matvey Aksenov.

148−

149− * Fixed some example code, thanks to Matvey Aksenov.

150−

151− * Fixed a problem with using `conversionError` to throw exceptions

152− of type `SomeException`. Previously, the exception would be

153− wrapped in a second `SomeException` dynamic constructor which

154− would cause normal GHC typecase idioms over `SomeException` to fail.

155−

156−### Version 0.5.2.1 (2016-06-29)

157− * Bumped the lower bound for `base` to 4.6. Thanks to Herbert

158− Valerio Riedel for reporting the issue.

159−

160− * Added an `Eq` instance for `SqlError`, thanks to Chris Allen

161−

162− * Fixed a bug where a all-caps `"NULL"` text value inside a

163− postgresql array would get parsed as the SQL null value. Thanks

164− goes to Edgar Gomes and Silk for finding and fixing this mistake.

165−

166− * Modified `withTransaction` and friends to ignore `IOError`s when

167− attempting to roll back the transaction. This fixes a buggy

168− interaction between `withTransaction` and async exceptions (e.g.

169− `System.Timeout`) on unix platforms. Thanks goes to Erik

170− Hesselink and Silk for providing the test case that exposed this

171− issue.

172−

173− * Added the `testTimeout` regression test for the problem above.

174−

175−### Version 0.5.2.0 (2016-05-25)

176− * Significantly improved the error reporting from

177− `Copy.putCopyData`, thanks to Ben Gamari.

178−

179− * Moved the test suite to use `tasty`, with a big thanks

180− to Ben Gamari.

181−

182− * Added `FromField.optionalField`, and updated the documentation

183− of `FromField.fromJSONField`, as inspired by an email conversation

184− with Ian Wagner.

185−

186− * Updated all links in the haddocks to use https, and added a link

187− to the documentation of `connectPostgreSQL`.

188−

189− * Added a truncated changelog to the source distribution.

190−

191−### Version 0.5.1.3 (2016-04-30)

192− * Implemented the Monad of No Return proposal, future-proofing

193− postgresql-simple against future releases of GHC.

194−

195− * Fixed a rare and usually benign race condition where

196− `getNotification` could end up waiting on a newly reallocated

197− file descriptor index, potentially leading to deadlock if the

198− descriptor does not become readable promptly. This fix only

199− applies to GHC 7.8 or later, as it depends on `threadWaitReadSTM`.

200−

201− * Tweaked the time parsers to accept times of day of the form `hh:mm`,

202− omitting seconds, following changes made to aeson.

203−

204− * Updated the documentation of the `In` type to point out a gotcha

205− when using the SQL fragment `... NOT IN ?` with `In []`. Thanks

206− goes to Simon Michael and Dan Haraj for bringing this issue to

207− my attention.

208−

209−### Version 0.5.1.2 (2015-12-14)

210− * The syntax generated for empty arrays was changed so that

211− postgresql's type inference would work better, thanks to

212− Amit Levy.

213−

214− * Further revision and expansion of the new Time documentation.

215−

216−### Version 0.5.1.1 (2015-12-02)

217− * This is a documentation-only release

218−

219− * The documentation of the `Time` module has been completely

220− rewritten, and is far longer and more informative. It contains

221− a brief overview of civil time, the semantics of postgresql's

222− time types, and their relation to Haskell's time types via

223− postgresql-simple.

224−

225− * The documentation of `connectPostgreSQL` has been modified to

226− mention the effects of environment variables on the connection

227− string parameters.

228−

229− * The documentation of `HStore.Internal` has been unhidden from

230− haddock.

231−

232− * A typo in example code was fixed courtesy of Levi Notik.

233−

234−### Version 0.5.1.0 (2015-10-22)

235− * Optimized the implementation of the streaming operators to avoid

236− creating intermediate lists of rows, thanks to Timo von Holtz.

237−

238− * Added default instances for `ToRow` and `FromRow` that depend on

239− Generics, thanks to Alexey Khudyakov.

240−

241− * Fixed support for bytestring-0.9 and GHC 7.4.

242−

243−### Version 0.5.0.1 (2015-09-21)

244− * Fixed a bug when printing a `ZonedTime` with a negative offset

245− that is not a whole number of hours.

246−

247−### Version 0.5.0.0 (2015-09-19)

248− * Removed the deprecated `BuiltinTypes` module.

249−

250− * Modified the SQL quasiquoter so that it returns a `Query`, not

251− an overloaded string, and so that the `OverloadedStrings` language

252− extension is no longer necessary, thanks to Mike Ledger.

253−

254− * Moved away from `blaze-builder` in favor of `bytestring-builder`. This

255− shouldn't affect very many people, but does reduce the transitive

256− dependencies.

257−

258− * Rewrote the timestamp printers to use the new `Prim`

259− infrastructure in `bytestring-builder`. The new printers should

260− be a fair bit faster.

261−

262− * Added support for exclusion violations to the `ConstraintViolation`

263− type in the Errors module, thanks to João Cristóvão.

264−

265− * Moved away from the `uuid` package in favor of the `uuid-types` package,

266− thanks to Bardur Arantsson. This shouldn't affect anybody, but does

267− reduce the transitive dependencies.

268−

269− * Postgresql-simple now explicitly assumes the UTF8 character encoding

270− for communication between the client and server. All database encodings

271− support UTF8 except for Mule Internal Code, the Multilingual

272− Extensions for Emacs. An exception should be raised upon

273− connecting to a database by the backend if the backend cannot

274− accommodate this requirement.

275−

276− * Added `Eq` and `Typeable` instances for `Connection`.

277−

278− * Added the `foldWith`, `forEachWith`, and `returningWith` families

279− of functions courtesy of Travis Staton.

280−

281− * Support for Ranged types, with thanks to Leonid Onokhov for his

282− contributions.

283−

284− * The `FromField` instance for JSON now allows for top-level values that

285− are not objects or arrays, thanks to Sam Rijs.

286−

287− * The timestamp parsers have been replaced with those now in Aeson.

288− Janne Hellsten adapted the old parsers from postgresql-simple for

289− inclusion in Aeson; Bryan O'Sullivan rewrote those parsers to be

290− faster, with some tweaks contributed by myself. And now to

291− bring the effort full circle, the result has been brought back to

292− postgresql-simple, with some adaptations.

293−

294− * Fixed a bug in the typeinfo system where postgresql's `_record` type

295− was being reported as a basic type and not an array type. Thanks to

296− Nickolay Kolev for helping to expose this issue.

297−

298− * Fixed a bug with the `typeInfo` operator, thanks to Timmy Tofu. In the

299− case of parsing subfields of arrays and composites, it would fetch the

300− `TypeInfo` of the array or composite type and not the subtype.

301−

302−### Version 0.4.10.0 (2015-02-26)

303− * Added a blurb about SSL/TLS in the documentation for connectPostgreSQL

304−

305− * Moved some functions into the Internal module, courtesy of Aleksey

306− Uimanov.

307−

308−### Version 0.4.9.0 (2014-12-27)

309− * Made the fromField method for PGArray available as pgArrayFieldParser,

310− outside of the typeclass courtesy of Tom Ellis.

311−

312− * Fixed a missing OverloadedStrings pragma in the documentation of SqlQQ.

313−

314− * Fixed deprecation warnings, courtesy of Simon Hengel.

315−

316−### Version 0.4.8.0 (2014-11-24)

317− * Added support for postgresql's citext type extension via the

318− case-insensitive package.

319−

320− * Added the function parseHStoreList to the HStore module.

321−

322−### Version 0.4.7.0 (2014-10-27)

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

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

325− contains seconds.

326−

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

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

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

330−

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

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

333− still throw a conversion error.

334−

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

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

337−

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

339−

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

341−

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

343− * Added an instance ToField NominalDiffTime.

344−

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

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

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

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

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

350− for reporting the issue.

351−

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

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

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

355− Dmitry Dzhus for reporting the issue.

356−

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

358−

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

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

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

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

363− patch.

364−

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

366− a documentation typo.

367−

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

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

370− This means we are using threadWaitRead and threadWaitWrite to

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

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

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

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

375−

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

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

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

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

380− isn't perfectly achieved as of yet.

381−

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

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

384−

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

386−

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

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

389− documentation about the authentication process.

390−

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

392−

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

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

395−

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

397− foldWithOptions, executeMany, and returning operators.

398−

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

400− * Fixed bug in Values syntax generation

401−

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

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

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

405− for QualifiedIdentifier.

406−

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

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

409−

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

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

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

413−

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

415− and tweaked error messages.

416−

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

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

419− Francesco Mazzoli

420−

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

422− Tobias Florek. See the new Identifier and QualifiedIdentifier

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

424−

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

426− more general than executeMany and returning. See the

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

428−

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

430− * Tweaked C preprocessor directive to be more portable

431−

432− * Tweaked testsuite for compatibility with aeson-0.7

433−

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

435− * Relaxed dependency on aeson to >= 0.6

436−

437− * Update the documentation of `fromField`

438−

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

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

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

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

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

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

445− See commit 8635f8 for more information.

446−

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

448−

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

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

451− Thanks to Amit Levy for the report.

452−

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

454−

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

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

457−

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

459−

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

461− * Removed dependency on hashable

462−

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

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

465− courtesy of Bas van Dijk.

466−

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

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

469−

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

471− unwrapper functions, courtesy of Bas van Dijk.

472−

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

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

475−

476− * Added `Notification.getBackendPID`.

477−

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

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

480− courtesy of Michael Snoyman

481−

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

483− * Added `aeson` as a dependency.

484−

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

486− courtesy of Bas van Dijk.

487−

488− * Added toJSONField and fromJSONField helper functions for declaring

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

490− of Bas van Dijk.

491−

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

493− type.

494−

495− * Added liftConversion and liftRowParser functions to the Internal

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

497−

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

499− also exported from the Errors module.

500−

501− * Various documentation fixes.

502−

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

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

505− Manuel Gómez.

506−

507− * Removed the remaining internal dependencies on BuiltinTypes from

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

509−

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

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

512− this change.

513−

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

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

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

517−

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

519− documentation for the LargeObjects module.

520−

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

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

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

524− module.

525−

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

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

528− the connection's file descriptor from libpq.

529−

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

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

532− the Query type, courtesy of Joey Adams.

533−

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

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

536− polling loop, courtesy of Joey Adams.

537−

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

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

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

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

542− work on these issues.

543−

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

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

546− of Joey Adams

547−

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

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

550−

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

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

553− Meier

554−

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

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

557−

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

559−

560− * Improved documentation of the FromField module.

561−

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

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

564− silently failed to render in Haddock.

565−

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

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

568− for his work on this feature.

569−

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

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

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

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

574− work on this feature.

575−

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

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

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

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

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

581− that conversion computations run inside.

582−

583− * Improved the documentation of the FromField module.

584−

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

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

587− of Leonid Onokhov.

588−

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

590− to ResultError exceptions, courtesy of Jeff Chu.

591−

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

593− Database.PostgreSQL.Simple.Transaction module.

594−

595− * Changed withTransactionModeRetry to accept a predicate of which

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

597− sometimes manifest themselves as constraint violations. Thanks

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

599−

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

601−

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

603−

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

605− now stripped out.

606−

607−

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

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

610− pointing this out.

611−

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

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

614− operators, thanks to Joey Adams.

615−

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

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

618−

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

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

621−

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

623−

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

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

626−

627− * Added a type synonym for FieldParser

628−

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

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

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

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

633−

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

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

636− broken even though it will still compile.

637−

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

639−

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

641−

642−

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

644− * Fix language extensions for compatibility with GHC 7.0

645−

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

647− * Fix a wayward dependency on Text.

648−

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

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

651−

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

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

654−

655− * Reworked support for the Time types.

656−

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

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

659−

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

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

662−

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

664− that accommodate PostgreSQL's infinities.

665−

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

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

668− time package included in GHC.

669−

670− * Planned breaking changes for 0.2:

671−

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

673−

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

675−

676−

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

678− * Made ZonedTime an instance of FromField and ToField

679−

680− * Added getNotificationNonBlocking

681−

682−

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

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

685− PostgreSQL 8 courtesy of Joey Adams.

686−

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

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

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

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

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

692−

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

694−

695−

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

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

698− LargeObjects modules

699−

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

701−

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

703−

704−

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

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

707−

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

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

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

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

712−

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

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

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

716−

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

718− `Either SomeException` to `Ok`.

719−

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

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

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

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

724− example comparing the old to the new:

725−

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

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

728− !a <- convert fa va

729− !b <- convert fb vb

730− return (a,b)

731− convertResults fs vs = convertError fs vs 2

732−

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

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

735−

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

737−

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

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

740−

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

742−

743− * Removed the `RawResult` type.

744−

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

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

CONTRIBUTING.mddeleted−13

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

1−Patches welcome!

2−

3−- If you are only going to bump bounds:

4− - If it's really **only bounds**, please simply open an issue (so you'll have a URL to refer to). I have a semi-automated process to make revisions, pull requests only disturb it.

5− - If patch includes **source code change** (i.e. I'll need to make a release), and it's a patch to support **newer base/GHC version**:

6− - Amend `tested-with` to include that GHC

7− - Regenerate `.github/workflows/haskell-ci.yml` with `haskell-ci regenerate` (get the latest from [GitHub haskell-ci/haskell-ci](https://github.com/haskell-ci/haskell-ci))

8−

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

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

11−

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

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

CONTRIBUTORS−16

@@ -18,19 +18,3 @@ 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.mddeleted−4

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

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

2−

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

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

bench/Select.hsdeleted−32

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

1−{-# LANGUAGE OverloadedStrings #-}

2−module Main where

3−

4−import Database.PostgreSQL.Simple

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

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

7−

8−import System.Environment (getArgs)

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

10−import qualified Data.Vector.Unboxed as VU

11−

12−main :: IO ()

13−main = do

14− args <- getArgs

15− conn <- connectPostgreSQL ""

16− case args of

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

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

19− print (process result)

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

21− -- dummy column

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

23− print (process' result)

24− _ -> do

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

26− print (process result)

27−

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

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

30−

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

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

cabal.haskell-cideleted−5

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

1−branches: master

2−postgresql: True

3−

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

5−-- osx: 8.4.4

cabal.projectdeleted−4

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

1−packages: .

2−tests: true

3−

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

cabal.project.local.windeleted−4

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

1−constraints: these -assoc

2−

3−package postgresql-libpq

4− flags: -use-pkg-config

postgresql-simple.cabal+94−153

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

1−cabal-version: 1.12

2−name: postgresql-simple

3−version: 0.7.0.0

4−x-revision: 1

5−synopsis: Mid-Level PostgreSQL client library

6−description:

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

1+Name: postgresql-simple

2+Version: 0.4.2.3

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

814

9−license: BSD3

10−license-file: LICENSE

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

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

13−copyright:

15+Cabal-version: >= 1.9.2

1716

18−category: Database

19−build-type: Simple

2017extra-source-files:

21− CHANGES.md

22− CONTRIBUTORS

23− test/results/malformed-input.expected

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

18+ CONTRIBUTORS

2519

26−tested-with:

27− GHC ==8.6.5

28− || ==8.8.4

29− || ==8.10.7

30− || ==9.0.2

31− || ==9.2.8

32− || ==9.4.8

33− || ==9.6.3

34− || ==9.8.1

20+Library

21+ hs-source-dirs: src

22+ Exposed-modules:

23+ Database.PostgreSQL.Simple

24+ Database.PostgreSQL.Simple.Arrays

25+ Database.PostgreSQL.Simple.BuiltinTypes

26+ Database.PostgreSQL.Simple.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

3547

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

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

6753

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

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

9971

100− default-extensions:

101− BangPatterns

102− DoAndIfThenElse

103− OverloadedStrings

104− TypeOperators

105− ViewPatterns

72+ extensions: DoAndIfThenElse, OverloadedStrings, BangPatterns, ViewPatterns

73+ TypeOperators

10674

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

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

10876

10977source-repository head

11078 type: git

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

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

11280

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

81+source-repository this

82+ type: git

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

84+ tag: v0.4.2.3

12585

12686test-suite test

127− default-language: Haskell2010

128− type: exitcode-stdio-1.0

129− hs-source-dirs: test

130− main-is: Main.hs

87+ type: exitcode-stdio-1.0

88+

89+ hs-source-dirs: test

90+ main-is: Main.hs

13191 other-modules:

13292 Common

133− Exception

134− Interval

13593 Notify

13694 Serializable

13795 Time

13896

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

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

14898

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

99+ extensions: NamedFieldPuns

100+ , OverloadedStrings

101+ , Rank2Types

102+ , RecordWildCards

103+ , PatternGuards

104+ , ScopedTypeVariables

166105

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

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

sdist.shdeleted−25

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

1−#!/bin/bash

2−

3−echo "Generating CHANGELOG.md"

4−echo

5−

6−cat <<HEADER > CHANGELOG.md

7−For the full changelog, see

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

9−

10−HEADER

11−

12−perl -ne '$n++ if /^###/; exit if $n==2; print' CHANGES.md >> CHANGELOG.md

13−

14−cat CHANGELOG.md

15−rm -f ./dist/*.tar

16−rm -f ./dist/*.tar.gz

17−cabal sdist

18−cd dist

19−wc *.tar.gz

20−gunzip *.gz

21−wc *.tar

22−zopfli *.tar

23−wc *.tar.gz

24−cd ..

25−rm -f ./dist/*.tar

src/Database/PostgreSQL/Simple.hs+177−157

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

4242 -- ** Modifying multiple rows at once

4343 -- $many

4444

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

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

4646 -- $returning

4747

4848 -- * Extracting results

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

6464 , Only(..)

6565 , (:.)(..)

6666 -- ** Exceptions

67− , SomePostgreSqlException(..)

6867 , SqlError(..)

6968 , PQ.ExecStatus(..)

70− , FormatError(..)

71− , QueryError(..)

72− , ResultError(..)

69+ , FormatError(fmtMessage, fmtQuery, fmtParams)

70+ , QueryError(qeMessage, qeQuery)

71+ , ResultError(errSQLType, errHaskellType, errMessage)

7372 -- * Connection management

7473 , Base.connectPostgreSQL

7574 , Base.close

7675 , Base.connect

77− , Base.withConnect

7876 , Base.ConnectInfo(..)

7977 , Base.defaultConnectInfo

8078 , Base.postgreSQLConnectionString

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

9593 , forEach

9694 , forEach_

9795 , 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

10696 -- * Statements that do not return results

10797 , execute

10898 , execute_

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

120110 , formatQuery

121111 ) where

122112

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

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

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)

125118import Control.Exception as E

119+import Control.Monad (foldM)

126120import Data.ByteString (ByteString)

127121import Data.Int (Int64)

128122import Data.List (intersperse)

129123import Data.Monoid (mconcat)

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

131−import Database.PostgreSQL.Simple.Cursor

124+import Data.Typeable (Typeable)

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

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

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

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

128+import Database.PostgreSQL.Simple.Ok

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

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

136131import Database.PostgreSQL.Simple.Types

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

138133import Database.PostgreSQL.Simple.Internal as Base

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

140134import Database.PostgreSQL.Simple.Transaction

135+import Database.PostgreSQL.Simple.TypeInfo

141136import qualified Database.PostgreSQL.LibPQ as PQ

142137import qualified Data.ByteString.Char8 as B

143−

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

144153

145154-- | Format a query string.

146155--

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

177186 case parseTemplate template of

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

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

180− return . toByteString . mconcat $ byteString before :

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

182− [byteString after]

189+ return . toByteString . mconcat $ fromByteString before :

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

191+ [fromByteString after]

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

184193

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

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

277286

278287 skipSpace = B.dropWhile isSpace_ascii

279288

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

280309

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

282−buildQuery conn q template xs =

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

284− where split s =

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

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

287− let (h,t) = breakOnSingleQuestionMark s

288− in byteString h

289− : if B.null t

290− then []

291− else split (B.tail t)

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

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

293324 zipParams [t] [] = t

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

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

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

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

296327 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

306328

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

308330-- expected to return results.

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

340362-- @

341363-- executeMany c [sql|

342364-- UPDATE sometable

343−-- SET y = upd.y

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

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

345367-- WHERE sometable.x = upd.x

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

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

347369-- @

348370

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

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

365387--

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

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

368−returning = returningWith fromRow

369−

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

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

372−returningWith _ _ _ [] = return []

373−returningWith parser conn q qs = do

390+returning _ _ [] = return []

391+returning conn q qs = do

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

375− finishQueryWith parser conn q result

393+ finishQuery conn q result

376394

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

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

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

447465 -> IO a

448466fold = foldWithOptions defaultFoldOptions

449467

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−

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

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

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

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

492499 -> a

493500 -> (a -> row -> IO a)

494501 -> IO a

495−foldWithOptions opts = foldWithOptionsAndParser opts fromRow

496−

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

498−foldWithOptionsAndParser :: (ToRow params)

499− => FoldOptions

500− -> RowParser row

501− -> Connection

502− -> Query

503− -> params

504− -> a

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

506− -> IO a

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

502+foldWithOptions opts conn template qs a f = do

508503 q <- formatQuery conn template qs

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

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

510505

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

512507fold_ :: (FromRow r) =>

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

517512 -> IO a

518513fold_ = foldWithOptions_ defaultFoldOptions

519514

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

528515

529516foldWithOptions_ :: (FromRow r) =>

530517 FoldOptions

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

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

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

535522 -> IO a

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

537−

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

539−foldWithOptionsAndParser_ :: FoldOptions

540− -> RowParser r

541− -> Connection

542− -> Query -- ^ Query.

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

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

545− -> IO a

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

547−

548−doFold :: FoldOptions

549− -> RowParser row

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

524+

525+

526+doFold :: ( FromRow row )

527+ => FoldOptions

550528 -> Connection

551529 -> Query

552530 -> Query

553531 -> a

554532 -> (a -> row -> IO a)

555533 -> IO a

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

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

557535 stat <- withConnection conn PQ.transactionStatus

558536 case stat of

559537 PQ.TransIdle -> withTransactionMode transactionMode conn go

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

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

572550 -- Not sure what this means.

573551 where

574− declare =

575− declareCursor conn q

576− fetch cursor a =

577− foldForwardWithParser cursor parser chunkSize f a

578−

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

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

581− \r -> case r of

582− Left x -> return x

583− Right x -> loop x

584− in loop a0

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

585574

586575-- FIXME: choose the Automatic chunkSize more intelligently

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

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

600589 -> q -- ^ Query parameters.

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

602591 -> IO ()

603−forEach = forEachWith fromRow

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

604593{-# INLINE forEach #-}

605594

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−

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

618596forEach_ :: (FromRow r) =>

619597 Connection

620598 -> Query -- ^ Query template.

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

622600 -> IO ()

623−forEach_ = forEachWith_ fromRow

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

624602{-# INLINE forEach_ #-}

625603

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−

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)

634673

635674-- $use

636675--

@@ -658,11 +697,10 @@ forEachWith_ parser conn template = foldWith_ parser conn template () . const

658697-- >

659698-- > import Database.PostgreSQL.Simple

660699-- >

661−-- > hello :: IO Int

700+-- > hello :: IO [Only Int]

662701-- > hello = do

663702-- > conn <- connectPostgreSQL ""

664−-- > [Only i] <- query_ conn "select 2 + 2"

665−-- > return i

703+-- > query_ conn "select 2 + 2"

666704--

667705-- A 'Query' value does not represent the actual query that will be

668706-- executed, but is a template for constructing the final query.

@@ -723,26 +761,11 @@ forEachWith_ parser conn template = foldWith_ parser conn template () . const

723761-- The same kind of problem can arise with string literals if you have

724762-- the @OverloadedStrings@ language extension enabled. Again, just

725763-- use an explicit type signature if this happens.

726−--

727−-- Finally, remember that the compiler must be able to infer the type

728−-- of a query's /results/ as well as its parameters. We might like

729−-- the following example to work:

730−--

731−-- > print =<< query_ conn "select 2 + 2"

732−--

733−-- Unfortunately, while a quick glance tells us that the result type

734−-- should be a single row containing a single numeric column, the

735−-- compiler has no way to infer what the types are. We can easily fix

736−-- this by providing an explicit type annotation:

737−--

738−-- > xs <- query_ conn "select 2 + 2"

739−-- > print (xs :: [Only Int])

740764

741765-- $only_param

742766--

743767-- Haskell lacks a single-element tuple type, so if you have just one

744−-- value you want substituted into a query or a single-column result,

745−-- what should you do?

768+-- value you want substituted into a query, what should you do?

746769--

747770-- The obvious approach would appear to be something like this:

748771--

@@ -757,9 +780,6 @@ forEachWith_ parser conn template = foldWith_ parser conn template () . const

757780--

758781-- > execute conn "insert into users (first_name) values (?)"

759782-- > ["Nuala"]

760−--

761−-- A row of /n/ query results is represented using an /n/-tuple, so

762−-- you should use 'Only' to represent a single-column result.

763783

764784-- $in

765785--

@@ -902,7 +922,7 @@ forEachWith_ parser conn template = foldWith_ parser conn template () . const

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

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

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

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

925+-- represent a @SMALLINT@, so it is considered compatble with those types.

906926--

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

908928-- 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.ByteString.Char8

20+import Data.Attoparsec.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.hsnew file+420

@@ -0,0 +1,420 @@

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

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+ deriving (Eq, Ord, Enum, Bounded, Read, Show, Typeable)

78+

79+builtin2oid :: BuiltinType -> PQ.Oid

80+builtin2oid typ = PQ.Oid $ case typ of

81+ Bool -> 16

82+ ByteA -> 17

83+ Char -> 18

84+ Name -> 19

85+ Int8 -> 20

86+ Int2 -> 21

87+ Int4 -> 23

88+ RegProc -> 24

89+ Text -> 25

90+ Oid -> 26

91+ Tid -> 27

92+ Xid -> 28

93+ Cid -> 29

94+ Xml -> 142

95+ Point -> 600

96+ LSeg -> 601

97+ Path -> 602

98+ Box -> 603

99+ Polygon -> 604

100+ Line -> 628

101+ Cidr -> 650

102+ Float4 -> 700

103+ Float8 -> 701

104+ AbsTime -> 702

105+ RelTime -> 703

106+ TInterval -> 704

107+ Unknown -> 705

108+ Circle -> 718

109+ Money -> 790

110+ MacAddr -> 829

111+ Inet -> 869

112+ BpChar -> 1042

113+ VarChar -> 1043

114+ Date -> 1082

115+ Time -> 1083

116+ Timestamp -> 1114

117+ TimestampTZ -> 1184

118+ Interval -> 1186

119+ TimeTZ -> 1266

120+ Bit -> 1560

121+ VarBit -> 1562

122+ Numeric -> 1700

123+ RefCursor -> 1790

124+ Record -> 2249

125+ Void -> 2278

126+ UUID -> 2950

127+ JSON -> 114

128+

129+oid2builtin :: PQ.Oid -> Maybe BuiltinType

130+oid2builtin (PQ.Oid x) = case x of

131+ 16 -> Just Bool

132+ 17 -> Just ByteA

133+ 18 -> Just Char

134+ 19 -> Just Name

135+ 20 -> Just Int8

136+ 21 -> Just Int2

137+ 23 -> Just Int4

138+ 24 -> Just RegProc

139+ 25 -> Just Text

140+ 26 -> Just Oid

141+ 27 -> Just Tid

142+ 28 -> Just Xid

143+ 29 -> Just Cid

144+ 142 -> Just Xml

145+ 600 -> Just Point

146+ 601 -> Just LSeg

147+ 602 -> Just Path

148+ 603 -> Just Box

149+ 604 -> Just Polygon

150+ 628 -> Just Line

151+ 650 -> Just Cidr

152+ 700 -> Just Float4

153+ 701 -> Just Float8

154+ 702 -> Just AbsTime

155+ 703 -> Just RelTime

156+ 704 -> Just TInterval

157+ 705 -> Just Unknown

158+ 718 -> Just Circle

159+ 790 -> Just Money

160+ 829 -> Just MacAddr

161+ 869 -> Just Inet

162+ 1042 -> Just BpChar

163+ 1043 -> Just VarChar

164+ 1082 -> Just Date

165+ 1083 -> Just Time

166+ 1114 -> Just Timestamp

167+ 1184 -> Just TimestampTZ

168+ 1186 -> Just Interval

169+ 1266 -> Just TimeTZ

170+ 1560 -> Just Bit

171+ 1562 -> Just VarBit

172+ 1700 -> Just Numeric

173+ 1790 -> Just RefCursor

174+ 2249 -> Just Record

175+ 2278 -> Just Void

176+ 2950 -> Just UUID

177+ 114 -> Just JSON

178+ _ -> Nothing

179+

180+builtin2typname :: BuiltinType -> ByteString

181+builtin2typname typ = case typ of

182+ Bool -> bool

183+ ByteA -> bytea

184+ Char -> char

185+ Name -> name

186+ Int8 -> int8

187+ Int2 -> int2

188+ Int4 -> int4

189+ RegProc -> regproc

190+ Text -> text

191+ Oid -> oid

192+ Tid -> tid

193+ Xid -> xid

194+ Cid -> cid

195+ Xml -> xml

196+ Point -> point

197+ LSeg -> lseg

198+ Path -> path

199+ Box -> box

200+ Polygon -> polygon

201+ Line -> line

202+ Cidr -> cidr

203+ Float4 -> float4

204+ Float8 -> float8

205+ AbsTime -> abstime

206+ RelTime -> reltime

207+ TInterval -> tinterval

208+ Unknown -> unknown

209+ Circle -> circle

210+ Money -> money

211+ MacAddr -> macaddr

212+ Inet -> inet

213+ BpChar -> bpchar

214+ VarChar -> varchar

215+ Date -> date

216+ Time -> time

217+ Timestamp -> timestamp

218+ TimestampTZ -> timestamptz

219+ Interval -> interval

220+ TimeTZ -> timetz

221+ Bit -> bit

222+ VarBit -> varbit

223+ Numeric -> numeric

224+ RefCursor -> refcursor

225+ Record -> record

226+ Void -> void

227+ UUID -> uuid

228+ JSON -> json

229+

230+oid2typname :: PQ.Oid -> Maybe ByteString

231+oid2typname (PQ.Oid x) = case x of

232+ 16 -> Just bool

233+ 17 -> Just bytea

234+ 18 -> Just char

235+ 19 -> Just name

236+ 20 -> Just int8

237+ 21 -> Just int2

238+ 23 -> Just int4

239+ 24 -> Just regproc

240+ 25 -> Just text

241+ 26 -> Just oid

242+ 27 -> Just tid

243+ 28 -> Just xid

244+ 29 -> Just cid

245+ 142 -> Just xml

246+ 600 -> Just point

247+ 601 -> Just lseg

248+ 602 -> Just path

249+ 603 -> Just box

250+ 604 -> Just polygon

251+ 628 -> Just line

252+ 650 -> Just cidr

253+ 700 -> Just float4

254+ 701 -> Just float8

255+ 702 -> Just abstime

256+ 703 -> Just reltime

257+ 704 -> Just tinterval

258+ 705 -> Just unknown

259+ 718 -> Just circle

260+ 790 -> Just money

261+ 829 -> Just macaddr

262+ 869 -> Just inet

263+ 1042 -> Just bpchar

264+ 1043 -> Just varchar

265+ 1082 -> Just date

266+ 1083 -> Just time

267+ 1114 -> Just timestamp

268+ 1184 -> Just timestamptz

269+ 1186 -> Just interval

270+ 1266 -> Just timetz

271+ 1560 -> Just bit

272+ 1562 -> Just varbit

273+ 1700 -> Just numeric

274+ 1790 -> Just refcursor

275+ 2249 -> Just record

276+ 2278 -> Just void

277+ 2950 -> Just uuid

278+ 114 -> Just json

279+ _ -> Nothing

280+

281+bool :: ByteString

282+bool = "bool"

283+

284+bytea :: ByteString

285+bytea = "bytea"

286+

287+char :: ByteString

288+char = "char"

289+

290+name :: ByteString

291+name = "name"

292+

293+int8 :: ByteString

294+int8 = "int8"

295+

296+int2 :: ByteString

297+int2 = "int2"

298+

299+int4 :: ByteString

300+int4 = "int4"

301+

302+regproc :: ByteString

303+regproc = "regproc"

304+

305+text :: ByteString

306+text = "text"

307+

308+oid :: ByteString

309+oid = "oid"

310+

311+tid :: ByteString

312+tid = "tid"

313+

314+xid :: ByteString

315+xid = "xid"

316+

317+cid :: ByteString

318+cid = "cid"

319+

320+xml :: ByteString

321+xml = "xml"

322+

323+point :: ByteString

324+point = "point"

325+

326+lseg :: ByteString

327+lseg = "lseg"

328+

329+path :: ByteString

330+path = "path"

331+

332+box :: ByteString

333+box = "box"

334+

335+polygon :: ByteString

336+polygon = "polygon"

337+

338+line :: ByteString

339+line = "line"

340+

341+cidr :: ByteString

342+cidr = "cidr"

343+

344+float4 :: ByteString

345+float4 = "float4"

346+

347+float8 :: ByteString

348+float8 = "float8"

349+

350+abstime :: ByteString

351+abstime = "abstime"

352+

353+reltime :: ByteString

354+reltime = "reltime"

355+

356+tinterval :: ByteString

357+tinterval = "tinterval"

358+

359+unknown :: ByteString

360+unknown = "unknown"

361+

362+circle :: ByteString

363+circle = "circle"

364+

365+money :: ByteString

366+money = "money"

367+

368+macaddr :: ByteString

369+macaddr = "macaddr"

370+

371+inet :: ByteString

372+inet = "inet"

373+

374+bpchar :: ByteString

375+bpchar = "bpchar"

376+

377+varchar :: ByteString

378+varchar = "varchar"

379+

380+date :: ByteString

381+date = "date"

382+

383+time :: ByteString

384+time = "time"

385+

386+timestamp :: ByteString

387+timestamp = "timestamp"

388+

389+timestamptz :: ByteString

390+timestamptz = "timestamptz"

391+

392+interval :: ByteString

393+interval = "interval"

394+

395+timetz :: ByteString

396+timetz = "timetz"

397+

398+bit :: ByteString

399+bit = "bit"

400+

401+varbit :: ByteString

402+varbit = "varbit"

403+

404+numeric :: ByteString

405+numeric = "numeric"

406+

407+refcursor :: ByteString

408+refcursor = "refcursor"

409+

410+record :: ByteString

411+record = "record"

412+

413+void :: ByteString

414+void = "void"

415+

416+uuid :: ByteString

417+uuid = "uuid"

418+

419+json :: ByteString

420+json = "json"

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

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

55 ( mask

66 , (<>)

77 , unsafeDupablePerformIO

8− , toByteString

9− , scientificBuilder

10− , toPico

11− , fromPico

128 ) where

139

1410import qualified Control.Exception as E

15−import Data.ByteString (ByteString)

16−import Data.ByteString.Lazy (toStrict)

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

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

11+import Data.Monoid

12+

13+#if __GLASGOW_HASKELL__ >= 702

1914import System.IO.Unsafe (unsafeDupablePerformIO)

20−import Data.Fixed (Pico)

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

15+#elif __GLASGOW_HASKELL__ >= 611

16+import GHC.IO (unsafeDupablePerformIO)

17+#else

18+import GHC.IOBase (unsafeDupablePerformIO)

19+#endif

20+

2221

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

2423--

@@ -28,14 +27,19 @@ import Data.Fixed (Fixed(MkFixed))

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

2928-- don't need that polymorphism.

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

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

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

32+#else

33+mask io = do

34+ b <- E.blocked

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

36+#endif

3237{-# INLINE mask #-}

3338

34−toByteString :: Builder -> ByteString

35−toByteString x = toStrict (toLazyByteString x)

36−

37−toPico :: Integer -> Pico

38−toPico = MkFixed

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

40+infixr 6 <>

3941

40−fromPico :: Pico -> Integer

41−fromPico (MkFixed i) = i

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

43+(<>) = mappend

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

45+#endif

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

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

99-- Stability: experimental

1010--

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

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

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

1313-- more information.

1414--

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

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

3232 ( copy

3333 , copy_

3434 , CopyOutResult(..)

35− , foldCopyData

3635 , getCopyData

3736 , putCopyData

3837 , putCopyEnd

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

4948import qualified Database.PostgreSQL.LibPQ as PQ

5049import Database.PostgreSQL.Simple

5150import Database.PostgreSQL.Simple.Types

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

51+import Database.PostgreSQL.Simple.Internal

5352

5453

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

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

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

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

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

5958

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

6160copy conn template qs = do

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

7675doCopy funcName conn template q = do

7776 result <- exec conn q

7877 status <- PQ.resultStatus result

79− let errMsg msg = throwIO $ QueryError

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

78+ let err = throwIO $ QueryError

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

8180 template

82− let err = errMsg $ show status

8381 case status of

8482 PQ.EmptyQuery -> err

8583 PQ.CommandOk -> err

8684 PQ.TuplesOk -> err

8785 PQ.CopyOut -> return ()

8886 PQ.CopyIn -> return ()

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

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

9187 PQ.BadResponse -> throwResultError funcName result status

9288 PQ.NonfatalError -> throwResultError funcName result status

9389 PQ.FatalError -> throwResultError funcName result status

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

10197 deriving (Eq, Typeable, Show)

10298

10399

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−

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

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

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

@@ -214,7 +186,6 @@ putCopyEnd conn = withConnection conn $ \pqconn -> do

214186putCopyError :: Connection -> B.ByteString -> IO ()

215187putCopyError conn err = withConnection conn $ \pqconn -> do

216188 doCopyIn funcName (\c -> PQ.putCopyEnd c (Just err)) pqconn

217− consumeResults pqconn

218189 where

219190 funcName = "Database.PostgreSQL.Simple.Copy.putCopyError"

220191

@@ -249,21 +220,10 @@ getCopyCommandTag :: B.ByteString -> PQ.Connection -> IO Int64

249220getCopyCommandTag funcName pqconn = do

250221 result <- maybe (fail errCmdStatus) return =<< PQ.getResult pqconn

251222 cmdStat <- maybe (fail errCmdStatus) return =<< PQ.cmdStatus result

252− consumeResults pqconn

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

254224 case P.parseOnly rowCount cmdStat of

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

256− fail $ errCmdStatusFmt

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

225+ Left _ -> fail errCmdStatusFmt

258226 Right n -> return $! n

259227 where

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

261229 errCmdStatusFmt = B.unpack funcName ++ ": failed to parse command status"

262−

263−

264−consumeResults :: PQ.Connection -> IO ()

265−consumeResults pqconn = do

266− mres <- PQ.getResult pqconn

267− case mres of

268− Nothing -> return ()

269− Just _ -> consumeResults pqconn

src/Database/PostgreSQL/Simple/Cursor.hsdeleted−98

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

1−{-# LANGUAGE OverloadedStrings #-}

2−

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

4−-- |

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

8−-- License: BSD3

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

10−--

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

12−

13−module Database.PostgreSQL.Simple.Cursor

14− (

15− -- * Types

16− Cursor

17− -- * Cursor management

18− , declareCursor

19− , closeCursor

20− -- * Folding over rows from a cursor

21− , foldForward

22− , foldForwardWithParser

23− ) where

24−

25−import Data.ByteString.Builder (intDec)

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

27−import Control.Exception as E

28−import Control.Monad (unless, void)

29−import Data.Monoid (mconcat)

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

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

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

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

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

35−import Database.PostgreSQL.Simple.Transaction

36−import qualified Database.PostgreSQL.LibPQ as PQ

37−

38−-- | Cursor within a transaction.

39−data Cursor = Cursor !Query !Connection

40−

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

42−-- unique name for the given connection.

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

44−declareCursor conn q = do

45− name <- newTempName conn

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

47− return $ Cursor name conn

48−

49−-- | Close the given cursor.

50−closeCursor :: Cursor -> IO ()

51−closeCursor (Cursor name conn) =

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

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

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

55− unless (isFailedTransactionError ex) $ throwIO ex

56−

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

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

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

60−-- 'Right' value is returned.

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

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

63− let q = "FETCH FORWARD "

64− <> (toByteString $ intDec chunkSize)

65− <> " FROM "

66− <> fromQuery name

67− result <- exec conn q

68− status <- PQ.resultStatus result

69− case status of

70− PQ.TuplesOk -> do

71− nrows <- PQ.ntuples result

72− ncols <- PQ.nfields result

73− if nrows > 0

74− then do

75− let inner a row = do

76− x <- getRowWith parser row ncols conn result

77− f a x

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

79− else

80− return $ Left a0

81− _ -> throwResultError "foldForwardWithParser" result status

82−

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

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

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

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

87−foldForward cursor = foldForwardWithParser cursor fromRow

88−

89−

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

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

92− where

93− loop x !n

94− | n > hi = return x

95− | otherwise = do

96− x' <- f x n

97− loop x' (n+1)

98−{-# INLINE foldM' #-}

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

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

2525 )

2626 where

2727

28+import Control.Applicative

2829import Control.Exception as E

2930

30−import Data.Attoparsec.ByteString.Char8

31+import Data.Attoparsec.Char8

3132import Data.ByteString (ByteString)

3233import Data.Typeable

3334

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

5455 -- ^ Name of violated constraint

5556 | CheckViolation ByteString ByteString

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

57− | ExclusionViolation ByteString

58− -- ^ Name of the exclusion violation constraint

5958 deriving (Show, Eq, Ord, Typeable)

6059

6160-- Default instance should be enough

62−instance Exception ConstraintViolation where

63− toException = postgresqlExceptionToException

64− fromException = postgresqlExceptionFromException

61+instance Exception ConstraintViolation

6562

6663

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

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

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

6966--

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

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

7168-- > where

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

73−-- > handler _ = ...

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

70+-- > catcher _ = ...

7471constraintViolation :: SqlError -> Maybe ConstraintViolation

7572constraintViolation e =

7673 case sqlState e of

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

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

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

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

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

8278 _ -> Nothing

8379 where msg = sqlErrorMsg e

8480

8581

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

8783--

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

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

8985-- > where

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

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

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

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

9288--

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

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

9591

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

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

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

9894--

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

10096-- > where

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

125121------------------------------------------------------------------------

126122-- Error predicates

127123--

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

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

129125

130126isSerializationError :: SqlError -> Bool

131127isSerializationError = isSqlState "40001"

src/Database/PostgreSQL/Simple/FromField.hs+98−216

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

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

22{-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-}

33{-# LANGUAGE PatternGuards, ScopedTypeVariables #-}

4−{-# LANGUAGE RecordWildCards #-}

5−{-# LANGUAGE PolyKinds #-}

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

76{- |

87Module: Database.PostgreSQL.Simple.FromField

@@ -28,20 +27,13 @@ Note that the 'Float' and 'Double' instances use attoparsec's 'double'

2827conversion routine, which sacrifices some accuracy for speed. If you

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

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

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

32−achieved simply by

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

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

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

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

31+acheived simply by

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

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

34+If this is unacceptable, you may find

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

3736

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

39−is likely somewhat faster than converting through the 'Rational' type,

40−the 'Scientific' type has no way to represent @NaN@ and @±Infinity@ values.

41−Thus, if you need precision conversion of regular floating point values

42−and the possibility of receiving these special values from the backend,

43−stick with 'Rational'.

44−

4537Because 'FromField' is a typeclass, one may provide conversions to

4638additional Haskell types without modifying postgresql-simple. This is

4739particularly useful for supporting PostgreSQL types that postgresql-simple

@@ -106,28 +98,24 @@ module Database.PostgreSQL.Simple.FromField

10698 , typeOid

10799 , PQ.Oid(..)

108100 , PQ.Format(..)

109− , pgArrayFieldParser

110− , attoFieldParser

111101

112− , optionalField

113102 , fromJSONField

114− , fromFieldJSONByteString

115103 ) where

116104

117105#include "MachDeps.h"

118106

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

107+import Control.Applicative

108+ ( Applicative, (<|>), (<$>), pure )

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

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

110+import Control.Exception (Exception)

122111import qualified Data.Aeson as JSON

123−import Data.Attoparsec.ByteString.Char8 hiding (Result)

112+import Data.Attoparsec.Char8 hiding (Result)

124113import Data.ByteString (ByteString)

125114import qualified Data.ByteString.Char8 as B

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

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

128116import Data.IORef (IORef, newIORef)

129117import Data.Ratio (Ratio)

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

118+import Data.Time ( UTCTime, ZonedTime, LocalTime, Day, TimeOfDay )

131119import Data.Typeable (Typeable, typeOf)

132120import Data.Vector (Vector)

133121import Data.Vector.Mutable (IOVector)

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

138126import Database.PostgreSQL.Simple.Types

139127import Database.PostgreSQL.Simple.TypeInfo as TI

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

129+import Database.PostgreSQL.Simple.TypeInfo.Macro as TI

141130import Database.PostgreSQL.Simple.Time

142131import Database.PostgreSQL.Simple.Arrays as Arrays

143132import qualified Database.PostgreSQL.LibPQ as PQ

@@ -147,14 +136,9 @@ import qualified Data.ByteString.Lazy as LB

147136import qualified Data.Text as ST

148137import qualified Data.Text.Encoding as ST

149138import qualified Data.Text.Lazy as LT

150−import Data.CaseInsensitive (CI)

151−import qualified Data.CaseInsensitive as CI

152−import Data.UUID.Types (UUID)

153−import qualified Data.UUID.Types as UUID

139+import Data.UUID (UUID)

140+import qualified Data.UUID as UUID

154141import Data.Scientific (Scientific)

155−import GHC.Real (infinity, notANumber)

156−

157−import qualified Data.Aeson.Types as JSON

158142

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

160144-- value fails.

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

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

183167 deriving (Eq, Show, Typeable)

184168

185−instance Exception ResultError where

186− toException = postgresqlExceptionToException

187− fromException = postgresqlExceptionFromException

169+instance Exception ResultError

188170

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

190172left = conversionError

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

225207

226208typeInfo :: Field -> Conversion TypeInfo

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

228− Ok <$> (getTypeInfo conn typeOid)

210+ Ok <$> (getTypeInfo conn =<< PQ.ftype result column)

229211

230212typeInfoByOid :: PQ.Oid -> Conversion TypeInfo

231213typeInfoByOid oid = Conversion $ \conn -> do

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

250232 then Nothing

251233 else Just x

252234

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

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

236+-- off the associated table column. Numbering starts from 0. Analogous

237+-- to libpq's @PQftablecol@.

258238

259239tableColumn :: Field -> Int

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

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

270250-- | void

271251instance FromField () where

272252 fromField f _bs

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

253+ | typeOid f /= $(inlineTypoid TI.void) = returnError Incompatible f ""

274254 | otherwise = pure ()

275255

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−

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

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

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

285259-- behavior.

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

287− fromField = optionalField fromField

288−

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

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

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

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

293−

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

295−optionalField p f mv =

296− case mv of

297− Nothing -> pure Nothing

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

299−{-# INLINE optionalField #-}

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

261+ fromField _ Nothing = pure Nothing

262+ fromField f bs = Just <$> fromField f bs

300263

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

302265instance FromField Null where

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

306269-- | bool

307270instance FromField Bool where

308271 fromField f bs

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

272+ | typeOid f /= $(inlineTypoid TI.bool) = returnError Incompatible f ""

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

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

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

313276 | otherwise = returnError ConversionFailed f ""

314277

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

278+-- | \"char\"

316279instance FromField Char where

317− fromField f bs0 =

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

319− then case bs0 of

280+ fromField f bs =

281+ if typeOid f /= $(inlineTypoid TI.char)

282+ then returnError Incompatible f ""

283+ else case bs of

320284 Nothing -> returnError UnexpectedNull f ""

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

322286 then returnError ConversionFailed f "length not 1"

323287 else return $! (B.head bs)

324− else returnError Incompatible f ""

325288

326289-- | int2

327290instance FromField Int16 where

328− fromField = attoFieldParser ok16 $ signed decimal

291+ fromField = atto ok16 $ signed decimal

329292

330293-- | int2, int4

331294instance FromField Int32 where

332− fromField = attoFieldParser ok32 $ signed decimal

295+ fromField = atto ok32 $ signed decimal

333296

334297#if WORD_SIZE_IN_BITS < 64

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

@@ -339,64 +302,50 @@ instance FromField Int32 where

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

340303#endif

341304instance FromField Int where

342− fromField = attoFieldParser okInt $ signed decimal

305+ fromField = atto okInt $ signed decimal

343306

344307-- | int2, int4, int8

345308instance FromField Int64 where

346− fromField = attoFieldParser ok64 $ signed decimal

309+ fromField = atto ok64 $ signed decimal

347310

348311-- | int2, int4, int8

349312instance FromField Integer where

350− fromField = attoFieldParser ok64 $ signed decimal

313+ fromField = atto ok64 $ signed decimal

351314

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

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

354317instance FromField Float where

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

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

318+ fromField = atto ok (realToFrac <$> double)

319+ where ok = $(mkCompats [TI.float4,TI.int2])

357320

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

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

360323instance FromField Double where

361− fromField = attoFieldParser ok pg_double

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

324+ fromField = atto ok double

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

363326

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

327+-- | int2, int4, float4, float8, numeric

365328instance FromField (Ratio Integer) where

366− fromField = attoFieldParser ok pg_rational

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

329+ fromField = atto ok rational

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

368331

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

332+-- | int2, int4, float4, float8, numeric

370333instance FromField Scientific where

371− fromField = attoFieldParser ok rational

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

334+ fromField = atto ok rational

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

373336

374337unBinary :: Binary t -> t

375338unBinary (Binary x) = x

376339

377−pg_double :: Parser Double

378−pg_double

379− = (string "NaN" *> pure ( 0 / 0))

380− <|> (string "Infinity" *> pure ( 1 / 0))

381− <|> (string "-Infinity" *> pure (-1 / 0))

382− <|> double

383−

384−pg_rational :: Parser Rational

385−pg_rational

386− = (string "NaN" *> pure notANumber )

387− <|> (string "Infinity" *> pure infinity )

388− <|> (string "-Infinity" *> pure (-infinity))

389− <|> rational

390−

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

392341instance FromField SB.ByteString where

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

342+ fromField f dat = if typeOid f == $(inlineTypoid TI.bytea)

394343 then unBinary <$> fromField f dat

395344 else doFromField f okText' pure dat

396345

397346-- | oid

398347instance FromField PQ.Oid where

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

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

400349

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

402351instance FromField LB.ByteString where

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

404353

405354unescapeBytea :: Field -> SB.ByteString

406355 -> Conversion (Binary SB.ByteString)

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

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

408357 Nothing -> returnError ConversionFailed f "unescapeBytea failed"

409358 Just str -> pure (Binary str)

410359

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

427376instance FromField LT.Text where

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

429378

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−

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

453380instance FromField [Char] where

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

455382

456383-- | timestamptz

457384instance FromField UTCTime where

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

385+ fromField = ff $(inlineTypoid TI.timestamptz) "UTCTime" parseUTCTime

459386

460387-- | timestamptz

461388instance FromField ZonedTime where

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

389+ fromField = ff $(inlineTypoid TI.timestamptz) "ZonedTime" parseZonedTime

463390

464391-- | timestamp

465392instance FromField LocalTime where

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

393+ fromField = ff $(inlineTypoid TI.timestamp) "LocalTime" parseLocalTime

467394

468395-- | date

469396instance FromField Day where

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

397+ fromField = ff $(inlineTypoid TI.date) "Day" parseDay

471398

472399-- | time

473400instance FromField TimeOfDay where

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

401+ fromField = ff $(inlineTypoid TI.time) "TimeOfDay" parseTimeOfDay

475402

476403-- | timestamptz

477404instance FromField UTCTimestamp where

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

405+ fromField = ff $(inlineTypoid TI.timestamptz) "UTCTimestamp" parseUTCTimestamp

479406

480407-- | timestamptz

481408instance FromField ZonedTimestamp where

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

409+ fromField = ff $(inlineTypoid TI.timestamptz) "ZonedTimestamp" parseZonedTimestamp

483410

484411-- | timestamp

485412instance FromField LocalTimestamp where

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

413+ fromField = ff $(inlineTypoid TI.timestamp) "LocalTimestamp" parseLocalTimestamp

487414

488415-- | date

489416instance FromField Date where

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

491−

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

493−--

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

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

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

497−--

498−instance FromField CalendarDiffTime where

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

417+ fromField = ff $(inlineTypoid TI.date) "Date" parseDate

500418

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

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

503−ff compatOid hsType parseBS f mstr =

421+ff compatOid hsType parse f mstr =

504422 if typeOid f /= compatOid

505423 then err Incompatible ""

506424 else case mstr of

507425 Nothing -> err UnexpectedNull ""

508− Just str -> case parseBS str of

426+ Just str -> case parse str of

509427 Left msg -> err ConversionFailed msg

510428 Right val -> return val

511429 where

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

527445

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

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

530− fromField = pgArrayFieldParser fromField

531−

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

533−pgArrayFieldParser fieldParser f mdat = do

448+ fromField f mdat = do

534449 info <- typeInfo f

535450 case info of

536451 TI.Array{} ->

537452 case mdat of

538453 Nothing -> returnError UnexpectedNull f ""

539454 Just dat -> do

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

455+ case parseOnly (fromArray info f) dat of

541456 Left err -> returnError ConversionFailed f err

542457 Right conv -> PGArray <$> conv

543458 _ -> returnError Incompatible f ""

544459

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

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

460+fromArray :: (FromField a)

461+ => TypeInfo -> Field -> Parser (Conversion [a])

462+fromArray typeInfo f = sequence . (parseIt <$>) <$> array delim

547463 where

548− delim = typdelim (typelem typInfo)

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

464+ delim = typdelim (typelem typeInfo)

465+ fElem = f{ typeOid = typoid (typelem typeInfo) }

550466

551467 parseIt item =

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

468+ fromField f' $ if item' == "NULL" then Nothing else Just item'

553469 where

554470 item' = fmt delim item

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

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

564480-- | uuid

565481instance FromField UUID where

566482 fromField f mbs =

567− if typeOid f /= TI.uuidOid

483+ if typeOid f /= $(inlineTypoid TI.uuid)

568484 then returnError Incompatible f ""

569485 else case mbs of

570486 Nothing -> returnError UnexpectedNull f ""

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

573489 Nothing -> returnError ConversionFailed f "Invalid UUID"

574490 Just uuid -> pure uuid

575491

576−-- | json, jsonb

492+-- | json

577493instance FromField JSON.Value where

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

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

580− Left err -> returnError ConversionFailed f err

581− Right val -> pure val

582−

583−-- | Return the JSON ByteString directly

584−--

585−-- @since 0.6.3

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

587−fromFieldJSONByteString f mbs =

588− if typeOid f /= TI.jsonOid && typeOid f /= TI.jsonbOid

494+ fromField f mbs =

495+ if typeOid f /= $(inlineTypoid TI.json)

589496 then returnError Incompatible f ""

590497 else case mbs of

591498 Nothing -> returnError UnexpectedNull f ""

592− Just bs -> pure bs

499+ Just bs ->

500+#if MIN_VERSION_aeson(0,6,3)

501+ case JSON.eitherDecodeStrict' bs of

502+#elif MIN_VERSION_bytestring(0,10,0)

503+ case JSON.eitherDecode' $ LB.fromStrict bs of

504+#else

505+ case JSON.eitherDecode' $ LB.fromChunks [bs] of

506+#endif

507+ Left err -> returnError ConversionFailed f err

508+ Right val -> pure val

593509

594510-- | Parse a field to a JSON 'JSON.Value' and convert that into a

595−-- Haskell value using the 'JSON.FromJSON' instance.

511+-- Haskell value using 'JSON.fromJSON'.

596512--

597513-- This can be used as the default implementation for the 'fromField'

598514-- method for Haskell types that have a JSON representation in

@@ -600,23 +516,14 @@ fromFieldJSONByteString f mbs =

600516--

601517-- The 'Typeable' constraint is required to show more informative

602518-- 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@

613519fromJSONField :: (JSON.FromJSON a, Typeable a) => FieldParser a

614520fromJSONField f mbBs = do

615521 value <- fromField f mbBs

616− case JSON.ifromJSON value of

617− JSON.IError path err -> returnError ConversionFailed f $

618− "JSON decoding error: " ++ (JSON.formatError path err)

619− JSON.ISuccess x -> pure x

522+ case JSON.fromJSON value of

523+ JSON.Error err -> returnError ConversionFailed f $

524+ "JSON decoding error: " ++ err

525+ JSON.Success x -> pure x

526+

620527

621528-- | Compatible with the same set of types as @a@. Note that

622529-- modifying the 'IORef' does not have any effects outside

@@ -633,33 +540,20 @@ instance FromField a => FromField (MVar a) where

633540type Compat = PQ.Oid -> Bool

634541

635542okText, okText', okBinary, ok16, ok32, ok64, okInt :: Compat

636−okText = eq TI.nameOid \/ eq TI.textOid \/ eq TI.charOid

637− \/ eq TI.bpcharOid \/ eq TI.varcharOid

638−okText' = eq TI.nameOid \/ eq TI.textOid \/ eq TI.charOid

639− \/ eq TI.bpcharOid \/ eq TI.varcharOid \/ eq TI.unknownOid

640−okBinary = eq TI.byteaOid

641−ok16 = eq TI.int2Oid

642−ok32 = eq TI.int2Oid \/ eq TI.int4Oid

643−ok64 = eq TI.int2Oid \/ eq TI.int4Oid \/ eq TI.int8Oid

543+okText = $( mkCompats [ TI.name, TI.text, TI.char,

544+ TI.bpchar, TI.varchar ] )

545+okText' = $( mkCompats [ TI.name, TI.text, TI.char,

546+ TI.bpchar, TI.varchar, TI.unknown ] )

547+okBinary = (== $( inlineTypoid TI.bytea ))

548+ok16 = (== $( inlineTypoid TI.int2 ))

549+ok32 = $( mkCompats [TI.int2,TI.int4] )

550+ok64 = $( mkCompats [TI.int2,TI.int4,TI.int8] )

644551#if WORD_SIZE_IN_BITS < 64

645552okInt = ok32

646553#else

647554okInt = ok64

648555#endif

649556

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−

663557doFromField :: forall a . (Typeable a)

664558 => Field -> Compat -> (ByteString -> Conversion a)

665559 -> Maybe ByteString -> Conversion a

@@ -684,22 +578,10 @@ returnError mkErr f msg = do

684578 (show (typeOf (undefined :: a)))

685579 msg

686580

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

581+atto :: forall a. (Typeable a)

582+ => Compat -> Parser a -> Field -> Maybe ByteString

583+ -> Conversion a

584+atto types p0 f dat = doFromField f types (go p0) dat

703585 where

704586 go :: Parser a -> ByteString -> Conversion a

705587 go p s =

src/Database/PostgreSQL/Simple/FromRow.hs+6−239

@@ -1,6 +1,4 @@

1−{-# LANGUAGE FlexibleContexts #-}

2−{-# LANGUAGE RecordWildCards, FlexibleInstances, DefaultSignatures #-}

3−

1+{-# LANGUAGE RecordWildCards, FlexibleInstances #-}

53------------------------------------------------------------------------------

64-- |

@@ -29,7 +27,7 @@ module Database.PostgreSQL.Simple.FromRow

2927 ) where

3028

3129import Prelude hiding (null)

32−import Control.Applicative (Applicative(..), (<$>), (<|>), (*>), liftA2)

30+import Control.Applicative (Applicative(..), (<$>), (<|>), (*>))

3331import Control.Monad (replicateM, replicateM_)

3432import Control.Monad.Trans.State.Strict

3533import Control.Monad.Trans.Reader

@@ -47,17 +45,13 @@ import Database.PostgreSQL.Simple.Ok

4745import Database.PostgreSQL.Simple.Types ((:.)(..), Null)

4846import Database.PostgreSQL.Simple.TypeInfo

4947

50−import GHC.Generics

51−

52−

5348-- | A collection type that can be converted from a sequence of fields.

5449-- Instances are provided for tuples up to 10 elements and lists of any length.

5550--

5651-- Note that instances can be defined outside of postgresql-simple, which is

5752-- often useful. For example, here's an instance for a user-defined pair:

5853--

59−-- @

60−-- data User = User { name :: String, fileQuota :: Int }

54+-- @data User = User { name :: String, fileQuota :: Int }

6155--

6256-- instance 'FromRow' User where

6357-- fromRow = User \<$\> 'field' \<*\> 'field'

@@ -67,32 +61,13 @@ import GHC.Generics

6761-- in a single row of the query result. Otherwise, a 'ConversionFailed'

6862-- exception will be thrown.

6963--

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

64+-- Note that 'field' evaluates it's result to WHNF, so the caveats listed in

8865-- mysql-simple and very early versions of postgresql-simple no longer apply.

8966-- Instead, look at the caveats associated with user-defined implementations

9067-- of 'fromField'.

9168

9269class FromRow a where

9370 fromRow :: RowParser a

94− default fromRow :: (Generic a, GFromRow (Rep a)) => RowParser a

95− fromRow = to <$> gfromRow

9671

9772getvalue :: PQ.Result -> PQ.Row -> PQ.Column -> Maybe ByteString

9873getvalue result row col = unsafeDupablePerformIO (PQ.getvalue' result row col)

@@ -131,8 +106,8 @@ fieldWith fieldP = RP $ do

131106 else do

132107 let !result = rowresult

133108 !typeOid = unsafeDupablePerformIO (PQ.ftype result column)

134− !field' = Field{..}

135− lift (lift (fieldP field' (getvalue result row column)))

109+ !field = Field{..}

110+ lift (lift (fieldP field (getvalue result row column)))

136111

137112field :: FromField a => RowParser a

138113field = fieldWith fromField

@@ -255,196 +230,6 @@ instance (FromField a, FromField b, FromField c, FromField d, FromField e,

255230 null *> null *> null *> null *> null *> pure Nothing)

256231 <|> (Just <$> fromRow)

257232

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−

448233instance FromField a => FromRow [a] where

449234 fromRow = do

450235 n <- numFieldsRemaining

@@ -467,21 +252,3 @@ instance FromField a => FromRow (Maybe (Vector a)) where

467252

468253instance (FromRow a, FromRow b) => FromRow (a :. b) where

469254 fromRow = (:.) <$> fromRow <*> fromRow

470−

471−

472−

473−-- Type class for default implementation of FromRow using generics

474−class GFromRow f where

475− gfromRow :: RowParser (f p)

476−

477−instance GFromRow f => GFromRow (M1 c i f) where

478− gfromRow = M1 <$> gfromRow

479−

480−instance (GFromRow f, GFromRow g) => GFromRow (f :*: g) where

481− gfromRow = liftA2 (:*:) gfromRow gfromRow

482−

483−instance (FromField a) => GFromRow (K1 R a) where

484− gfromRow = K1 <$> field

485−

486−instance GFromRow U1 where

487− gfromRow = pure U1

src/Database/PostgreSQL/Simple/HStore.hs+2−3

@@ -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 <https://www.postgresql.org/docs/9.5/static/hstore.html> for more

11+-- See <http://www.postgresql.org/docs/9.2/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−-- <https://www.postgresql.org/docs/9.5/static/contrib.html> for more

18+-- <http://www.postgresql.org/docs/9.2/static/contrib.html> for more

1919-- information.

2020--

2121------------------------------------------------------------------------------

@@ -28,7 +28,6 @@ module Database.PostgreSQL.Simple.HStore

2828 , toBuilder

2929 , toLazyByteString

3030 , hstore

31− , parseHStoreList

3231 , ToHStoreText(..)

3332 , HStoreText

3433 ) where

src/Database/PostgreSQL/Simple/HStore/Implementation.hs+21−27

@@ -15,13 +15,17 @@

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)

1821import qualified Data.Attoparsec.ByteString as P

1922import qualified Data.Attoparsec.ByteString.Char8 as P (isSpace_w8)

2023import qualified Data.ByteString as BS

21−import Data.ByteString.Builder (Builder, byteString, char8)

22−import qualified Data.ByteString.Builder as BU

2324import Data.ByteString.Internal (c2w, w2c)

2425import 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

2529import Data.Map(Map)

2630import qualified Data.Map as Map

2731import Data.Text(Text)

@@ -31,7 +35,6 @@ import Data.Text.Encoding.Error(UnicodeException)

3135import qualified Data.Text.Lazy as TL

3236import Data.Typeable

3337import Data.Monoid(Monoid(..))

34−import Data.Semigroup

3538import Database.PostgreSQL.Simple.FromField

3639import Database.PostgreSQL.Simple.ToField

3740

@@ -50,28 +53,26 @@ instance ToHStore HStoreBuilder where

5053toBuilder :: HStoreBuilder -> Builder

5154toBuilder x = case x of

5255 Empty -> mempty

53− Comma c -> c

56+ Comma x -> x

5457

5558toLazyByteString :: HStoreBuilder -> BL.ByteString

5659toLazyByteString x = case x of

5760 Empty -> BL.empty

58− Comma c -> BU.toLazyByteString c

59−

60−instance Semigroup HStoreBuilder where

61− Empty <> x = x

62− Comma a <> x

63− = Comma (a `mappend` case x of

64− Empty -> mempty

65− Comma b -> char8 ',' `mappend` b)

61+ Comma x -> Blaze.toLazyByteString x

6662

6763instance Monoid HStoreBuilder where

6864 mempty = Empty

65+ mappend Empty x = x

66+ mappend (Comma a) x

67+ = Comma (a `mappend` case x of

68+ Empty -> mempty

69+ Comma b -> fromChar ',' `mappend` b)

6970

7071class ToHStoreText a where

7172 toHStoreText :: a -> HStoreText

7273

7374-- | Represents escape text, ready to be the key or value to a hstore value

74−newtype HStoreText = HStoreText Builder deriving (Typeable, Semigroup, Monoid)

75+newtype HStoreText = HStoreText Builder deriving (Typeable, Monoid)

7576

7677instance ToHStoreText HStoreText where

7778 toHStoreText = id

@@ -94,24 +95,24 @@ escapeAppend :: BS.ByteString -> Builder -> Builder

9495escapeAppend = loop

9596 where

9697 loop (BS.break quoteNeeded -> (a,b)) rest

97− = byteString a `mappend`

98+ = copyByteString a `mappend`

9899 case BS.uncons b of

99100 Nothing -> rest

100101 Just (c,d) -> quoteChar c `mappend` loop d rest

101102

102103 quoteNeeded c = c == c2w '\"' || c == c2w '\\'

103104 quoteChar c

104− | c == c2w '\"' = byteString "\\\""

105− | otherwise = byteString "\\\\"

105+ | c == c2w '\"' = copyByteString "\\\""

106+ | otherwise = copyByteString "\\\\"

106107

107108hstore :: (ToHStoreText a, ToHStoreText b) => a -> b -> HStoreBuilder

108109hstore (toHStoreText -> (HStoreText key)) (toHStoreText -> (HStoreText val)) =

109− Comma (char8 '"' `mappend` key `mappend` byteString "\"=>\""

110− `mappend` val `mappend` char8 '"')

110+ Comma (fromChar '"' `mappend` key `mappend` copyByteString "\"=>\""

111+ `mappend` val `mappend` fromChar '"')

111112

112113instance ToField HStoreBuilder where

113114 toField Empty = toField (BS.empty)

114− toField (Comma x) = toField (BU.toLazyByteString x)

115+ toField (Comma x) = toField (Blaze.toLazyByteString x)

115116

116117newtype HStoreList = HStoreList {fromHStoreList :: [(Text,Text)]} deriving (Typeable, Show)

117118

@@ -144,7 +145,7 @@ newtype HStoreMap = HStoreMap {fromHStoreMap :: Map Text Text} deriving (Eq, Or

144145

145146instance ToHStore HStoreMap where

146147 toHStore (HStoreMap xs) = Map.foldrWithKey f mempty xs

147− where f k v xs' = hstore k v `mappend` xs'

148+ where f k v xs = hstore k v `mappend` xs

148149

149150instance ToField HStoreMap where

150151 toField xs = toField (toHStore xs)

@@ -153,13 +154,6 @@ instance FromField HStoreMap where

153154 fromField f mdat = convert <$> fromField f mdat

154155 where convert (HStoreList xs) = HStoreMap (Map.fromList xs)

155156

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−

163157parseHStore :: P.Parser (Either UnicodeException HStoreList)

164158parseHStore = do

165159 kvs <- P.sepBy' (skipWhiteSpace *> parseHStoreKeyVal)

src/Database/PostgreSQL/Simple/HStore/Internal.hs+2

@@ -1,3 +1,5 @@

1+{-# OPTIONS_HADDOCK hide #-}

13------------------------------------------------------------------------------

24-- |

35-- Module: Database.PostgreSQL.Simple.HStore.Internal

src/Database/PostgreSQL/Simple/Internal.hs+33−261

@@ -1,13 +1,12 @@

1−{-# LANGUAGE CPP, BangPatterns, DoAndIfThenElse, RecordWildCards #-}

2−{-# LANGUAGE DeriveDataTypeable, DeriveGeneric #-}

3−{-# LANGUAGE GeneralizedNewtypeDeriving #-}

4−{-# LANGUAGE ExistentialQuantification #-}

5−{-# LANGUAGE InstanceSigs #-}

1+{-# LANGUAGE BangPatterns #-}

2+{-# LANGUAGE DeriveDataTypeable #-}

3+{-# LANGUAGE GeneralizedNewtypeDeriving #-}

4+{-# LANGUAGE RecordWildCards #-}

76------------------------------------------------------------------------------

87-- |

98-- Module: Database.PostgreSQL.Simple.Internal

1110-- License: BSD3

1211-- Maintainer: Leon P Smith <leon@melding-monads.com>

1312-- Stability: experimental

@@ -28,35 +27,25 @@ import Control.Exception

2827import Control.Concurrent.MVar

2928import Control.Monad(MonadPlus(..))

3029import Data.ByteString(ByteString)

31−import qualified Data.ByteString as B

3230import qualified Data.ByteString.Char8 as B8

33−import Data.ByteString.Builder ( Builder, byteString )

3431import Data.Char (ord)

3532import Data.Int (Int64)

3633import qualified Data.IntMap as IntMap

3734import Data.IORef

3835import Data.Maybe(fromMaybe)

3936import Data.String

40−import qualified Data.Text as T

41−import qualified Data.Text.Encoding as TE

4237import Data.Typeable

4338import Data.Word

4439import Database.PostgreSQL.LibPQ(Oid(..))

4540import qualified Database.PostgreSQL.LibPQ as PQ

4641import Database.PostgreSQL.LibPQ(ExecStatus(..))

47−import Database.PostgreSQL.Simple.Compat ( toByteString )

4842import Database.PostgreSQL.Simple.Ok

49−import Database.PostgreSQL.Simple.ToField (Action(..), inQuotes)

5043import Database.PostgreSQL.Simple.Types (Query(..))

5144import Database.PostgreSQL.Simple.TypeInfo.Types(TypeInfo)

5245import Control.Monad.Trans.State.Strict

5346import Control.Monad.Trans.Reader

5447import Control.Monad.Trans.Class

55−import GHC.Generics

5648import GHC.IO.Exception

57−#if !defined(mingw32_HOST_OS)

58−import Control.Concurrent(threadWaitRead, threadWaitWrite)

59−#endif

6049

6150-- | A Field represents metadata about a particular field

6251--

@@ -78,29 +67,7 @@ data Connection = Connection {

7867 connectionHandle :: {-# UNPACK #-} !(MVar PQ.Connection)

7968 , connectionObjects :: {-# UNPACK #-} !(MVar TypeInfoCache)

8069 , connectionTempNameCounter :: {-# UNPACK #-} !(IORef Int64)

81− } deriving (Typeable)

82−

83−instance Eq Connection where

84− x == y = connectionHandle x == connectionHandle y

85−

86−-- | Superclass for postgresql exceptions

87−data SomePostgreSqlException = forall e. Exception e => SomePostgreSqlException e

88− deriving Typeable

89−

90−postgresqlExceptionToException :: Exception e => e -> SomeException

91−postgresqlExceptionToException = toException . SomePostgreSqlException

92−

93−postgresqlExceptionFromException :: Exception e => SomeException -> Maybe e

94−postgresqlExceptionFromException x = do

95− SomePostgreSqlException a <- fromException x

96− cast a

97−

98−instance Show SomePostgreSqlException where

99− showsPrec :: Int -> SomePostgreSqlException -> ShowS

100− showsPrec p (SomePostgreSqlException e) = showsPrec p e

101−

102−instance Exception SomePostgreSqlException where

103− displayException (SomePostgreSqlException e) = displayException e

70+ }

10471

10572data SqlError = SqlError {

10673 sqlState :: ByteString

@@ -108,15 +75,12 @@ data SqlError = SqlError {

10875 , sqlErrorMsg :: ByteString

10976 , sqlErrorDetail :: ByteString

11077 , sqlErrorHint :: ByteString

111− } deriving (Eq, Show, Typeable)

78+ } deriving (Show, Typeable)

11279

11380fatalError :: ByteString -> SqlError

11481fatalError msg = SqlError "" FatalError msg "" ""

11582

116−instance Exception SqlError where

117− toException = postgresqlExceptionToException

118− fromException = postgresqlExceptionFromException

119−

83+instance Exception SqlError

12084

12185-- | Exception thrown if 'query' is used to perform an @INSERT@-like

12286-- operation, or 'execute' is used to perform a @SELECT@-like operation.

@@ -125,22 +89,7 @@ data QueryError = QueryError {

12589 , qeQuery :: Query

12690 } deriving (Eq, Show, Typeable)

12791

128−instance Exception QueryError where

129− toException = postgresqlExceptionToException

130− fromException = postgresqlExceptionFromException

131−

132−-- | Exception thrown if a 'Query' could not be formatted correctly.

133−-- This may occur if the number of \'@?@\' characters in the query

134−-- string does not match the number of parameters provided.

135−data FormatError = FormatError {

136− fmtMessage :: String

137− , fmtQuery :: Query

138− , fmtParams :: [ByteString]

139− } deriving (Eq, Show, Typeable)

140−

141−instance Exception FormatError where

142− toException = postgresqlExceptionToException

143− fromException = postgresqlExceptionFromException

92+instance Exception QueryError

14493

14594data ConnectInfo = ConnectInfo {

14695 connectHost :: String

@@ -148,7 +97,7 @@ data ConnectInfo = ConnectInfo {

14897 , connectUser :: String

14998 , connectPassword :: String

15099 , connectDatabase :: String

151− } deriving (Generic,Eq,Read,Show,Typeable)

100+ } deriving (Eq,Read,Show,Typeable)

152101

153102-- | Default information for setting up a connection.

154103--

@@ -182,20 +131,10 @@ defaultConnectInfo = ConnectInfo {

182131connect :: ConnectInfo -> IO Connection

183132connect = connectPostgreSQL . postgreSQLConnectionString

184133

185−-- | Memory bracket around 'connect' and 'close'.

186−--

187−-- @since 0.6.5

188−withConnect :: ConnectInfo -> (Connection -> IO c) -> IO c

189−withConnect connInfo = bracket (connect connInfo) close

190−

191134-- | Attempt to make a connection based on a libpq connection string.

192−-- See <https://www.postgresql.org/docs/9.5/static/libpq-connect.html#LIBPQ-CONNSTRING>

193−-- for more information. Also note that environment variables also affect

194−-- parameters not provided, parameters provided as the empty string, and a

195−-- few other things; see

196−-- <https://www.postgresql.org/docs/9.5/static/libpq-envars.html>

197−-- for details. Here is an example with some of the most commonly used

198−-- parameters:

135+-- See <http://www.postgresql.org/docs/9.3/static/libpq-connect.html>

136+-- for more information. Here is an example with some

137+-- of the most commonly used parameters:

199138--

200139-- > host='db.somedomain.com' port=5432 ...

201140--

@@ -223,9 +162,8 @@ withConnect connInfo = bracket (connect connInfo) close

223162--

224163-- Omitting @password@ will default to an appropriate password found

225164-- in the @pgpass@ file, or no password at all if a matching line is

226−-- not found. The path of the @pgpass@ file may be specified by setting

227−-- the @PGPASSFILE@ environment variable. See

228−-- <https://www.postgresql.org/docs/9.5/static/libpq-pgpass.html> for

165+-- not found. See

166+-- <http://www.postgresql.org/docs/9.3/static/libpq-pgpass.html> for

229167-- more information regarding this file.

230168--

231169-- As all parameters are optional and the defaults are sensible, the

@@ -243,24 +181,12 @@ withConnect connInfo = bracket (connect connInfo) close

243181-- or production machines, or you will need to use a @pgpass@ file

244182-- with the @password@ or @md5@ authentication methods.

245183--

246−-- See <https://www.postgresql.org/docs/9.5/static/client-authentication.html>

184+-- See <http://www.postgresql.org/docs/9.3/static/client-authentication.html>

247185-- 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.

260186

261187connectPostgreSQL :: ByteString -> IO Connection

262188connectPostgreSQL connstr = do

263− conn <- connectdb connstr

189+ conn <- PQ.connectdb connstr

264190 stat <- PQ.status conn

265191 case stat of

266192 PQ.ConnectionOk -> do

@@ -270,45 +196,15 @@ connectPostgreSQL connstr = do

270196 let wconn = Connection{..}

271197 version <- PQ.serverVersion conn

272198 let settings

273− | version < 80200 = "SET datestyle TO ISO;SET client_encoding TO UTF8"

274− | otherwise = "SET datestyle TO ISO;SET client_encoding TO UTF8;SET standard_conforming_strings TO on"

199+ | version < 80200 = "SET datestyle TO ISO"

200+ | otherwise = "SET standard_conforming_strings TO on;\

201+ \SET datestyle TO ISO"

275202 _ <- execute_ wconn settings

276203 return wconn

277204 _ -> do

278205 msg <- maybe "connectPostgreSQL error" id <$> PQ.errorMessage conn

279206 throwIO $ fatalError msg

280207

281−connectdb :: ByteString -> IO PQ.Connection

282−#if defined(mingw32_HOST_OS)

283−connectdb = PQ.connectdb

284−#else

285−connectdb conninfo = do

286− conn <- PQ.connectStart conninfo

287− loop conn

288− where

289− funcName = "Database.PostgreSQL.Simple.connectPostgreSQL"

290− loop conn = do

291− status <- PQ.connectPoll conn

292− case status of

293− PQ.PollingFailed -> throwLibPQError conn "connection failed"

294− PQ.PollingReading -> do

295− mfd <- PQ.socket conn

296− case mfd of

297− Nothing -> throwIO $! fdError funcName

298− Just fd -> do

299− threadWaitRead fd

300− loop conn

301− PQ.PollingWriting -> do

302− mfd <- PQ.socket conn

303− case mfd of

304− Nothing -> throwIO $! fdError funcName

305− Just fd -> do

306− threadWaitWrite fd

307− loop conn

308− PQ.PollingOk -> return conn

309−

310−#endif

311−

312208-- | Turns a 'ConnectInfo' data structure into a libpq connection string.

313209

314210postgreSQLConnectionString :: ConnectInfo -> ByteString

@@ -323,7 +219,7 @@ postgreSQLConnectionString connectInfo = fromString connstr

323219

324220 str name field

325221 | null value = id

326− | otherwise = showString name . addQuotes value . space

222+ | otherwise = showString name . quote value . space

327223 where value = field connectInfo

328224

329225 num name field

@@ -331,7 +227,7 @@ postgreSQLConnectionString connectInfo = fromString connstr

331227 | otherwise = showString name . shows value . space

332228 where value = field connectInfo

333229

334− addQuotes s rest = '\'' : foldr delta ('\'' : rest) s

230+ quote str rest = '\'' : foldr delta ('\'' : rest) str

335231 where

336232 delta c cs = case c of

337233 '\\' -> '\\' : '\\' : cs

@@ -350,53 +246,15 @@ oid2int (Oid x) = fromIntegral x

350246exec :: Connection

351247 -> ByteString

352248 -> IO PQ.Result

353−#if defined(mingw32_HOST_OS)

354249exec conn sql =

355250 withConnection conn $ \h -> do

356251 mres <- PQ.exec h sql

357252 case mres of

358− Nothing -> throwLibPQError h "PQexec returned no results"

359− Just res -> return res

360−#else

361−exec conn sql =

362− withConnection conn $ \h -> do

363− success <- PQ.sendQuery h sql

364− if success

365− then awaitResult h Nothing

366− else throwLibPQError h "PQsendQuery failed"

367− where

368− awaitResult h mres = do

369− mfd <- PQ.socket h

370− case mfd of

371− Nothing -> throwIO $! fdError "Database.PostgreSQL.Simple.Internal.exec"

372− Just fd -> do

373− threadWaitRead fd

374− _ <- PQ.consumeInput h -- FIXME?

375− getResult h mres

376−

377− getResult h mres = do

378− isBusy <- PQ.isBusy h

379− if isBusy

380− then awaitResult h mres

381− else do

382− mres' <- PQ.getResult h

383− case mres' of

384− Nothing -> case mres of

385− Nothing -> throwLibPQError h "PQgetResult returned no results"

386− Just res -> return res

387− Just res -> do

388− status <- PQ.resultStatus res

389− case status of

390− -- FIXME: handle PQ.CopyBoth and PQ.SingleTuple

391− PQ.EmptyQuery -> getResult h mres'

392− PQ.CommandOk -> getResult h mres'

393− PQ.TuplesOk -> getResult h mres'

394− PQ.CopyOut -> return res

395− PQ.CopyIn -> return res

396− PQ.BadResponse -> getResult h mres'

397− PQ.NonfatalError -> getResult h mres'

398− PQ.FatalError -> getResult h mres'

399−#endif

253+ Nothing -> do

254+ msg <- maybe "execute error" id <$> PQ.errorMessage h

255+ throwIO $ fatalError msg

256+ Just res -> do

257+ return res

400258

401259-- | A version of 'execute' that does not perform query substitution.

402260execute_ :: Connection -> Query -> IO Int64

@@ -408,7 +266,6 @@ finishExecute :: Connection -> Query -> PQ.Result -> IO Int64

408266finishExecute _conn q result = do

409267 status <- PQ.resultStatus result

410268 case status of

411− -- FIXME: handle PQ.CopyBoth and PQ.SingleTuple

412269 PQ.EmptyQuery -> throwIO $ QueryError "execute: Empty query" q

413270 PQ.CommandOk -> do

414271 ncols <- PQ.nfields result

@@ -419,7 +276,7 @@ finishExecute _conn q result = do

419276 nstr <- PQ.cmdTuples result

420277 return $ case nstr of

421278 Nothing -> 0 -- is this appropriate?

422− Just str -> mkInteger str

279+ Just str -> toInteger str

423280 PQ.TuplesOk -> do

424281 ncols <- PQ.nfields result

425282 throwIO $ QueryError ("execute resulted in " ++ show ncols ++

@@ -432,7 +289,7 @@ finishExecute _conn q result = do

432289 PQ.NonfatalError -> throwResultError "execute" result status

433290 PQ.FatalError -> throwResultError "execute" result status

434291 where

435− mkInteger str = B8.foldl' delta 0 str

292+ toInteger str = B8.foldl' delta 0 str

436293 where

437294 delta acc c =

438295 if '0' <= c && c <= '9'

@@ -447,8 +304,8 @@ throwResultError _ result status = do

447304 PQ.resultErrorField result PQ.DiagMessageDetail

448305 hint <- fromMaybe "" <$>

449306 PQ.resultErrorField result PQ.DiagMessageHint

450− state' <- maybe "" id <$> PQ.resultErrorField result PQ.DiagSqlstate

451− throwIO $ SqlError { sqlState = state'

307+ state <- maybe "" id <$> PQ.resultErrorField result PQ.DiagSqlstate

308+ throwIO $ SqlError { sqlState = state

452309 , sqlExecStatus = status

453310 , sqlErrorMsg = errormsg

454311 , sqlErrorDetail = detail

@@ -517,6 +374,7 @@ instance Alternative Conversion where

517374 Errors _ -> (oka <|>) <$> runConversion mb conn

518375

519376instance Monad Conversion where

377+ return a = Conversion $ \_conn -> return (return a)

520378 m >>= f = Conversion $ \conn -> do

521379 oka <- runConversion m conn

522380 case oka of

@@ -531,7 +389,7 @@ conversionMap :: (Ok a -> Ok b) -> Conversion a -> Conversion b

531389conversionMap f m = Conversion $ \conn -> f <$> runConversion m conn

532390

533391conversionError :: Exception err => err -> Conversion a

534−conversionError err = Conversion $ \_ -> return (Errors [toException err])

392+conversionError err = Conversion $ \_ -> return (Errors [SomeException err])

535393

536394newTempName :: Connection -> IO Query

537395newTempName Connection{..} = do

@@ -549,89 +407,3 @@ fdError funcName = IOError {

549407 ioe_errno = Nothing,

550408 ioe_filename = Nothing

551409 }

552−

553−

554−libPQError :: ByteString -> IOError

555−libPQError desc = IOError {

556− ioe_handle = Nothing,

557− ioe_type = OtherError,

558− ioe_location = "libpq",

559− ioe_description = B8.unpack desc,

560− ioe_errno = Nothing,

561− ioe_filename = Nothing

562− }

563−

564−throwLibPQError :: PQ.Connection -> ByteString -> IO a

565−throwLibPQError conn default_desc = do

566− msg <- maybe default_desc id <$> PQ.errorMessage conn

567− throwIO $! libPQError msg

568−

569−

570−fmtError :: String -> Query -> [Action] -> a

571−fmtError msg q xs = throw FormatError {

572− fmtMessage = msg

573− , fmtQuery = q

574− , fmtParams = map twiddle xs

575− }

576− where twiddle (Plain b) = toByteString b

577− twiddle (Escape s) = s

578− twiddle (EscapeByteA s) = s

579− twiddle (EscapeIdentifier s) = s

580− twiddle (Many ys) = B.concat (map twiddle ys)

581−

582−fmtErrorBs :: Query -> [Action] -> ByteString -> a

583−fmtErrorBs q xs msg = fmtError (T.unpack $ TE.decodeUtf8 msg) q xs

584−

585−-- | Quote bytestring or throw 'FormatError'

586−quote :: Query -> [Action] -> Either ByteString ByteString -> Builder

587−quote q xs = either (fmtErrorBs q xs) (inQuotes . byteString)

588−

589−buildAction :: Connection -- ^ Connection for string escaping

590− -> Query -- ^ Query for message error

591− -> [Action] -- ^ List of parameters for message error

592− -> Action -- ^ Action to build

593− -> IO Builder

594−buildAction _ _ _ (Plain b) = pure b

595−buildAction conn q xs (Escape s) = quote q xs <$> escapeStringConn conn s

596−buildAction conn q xs (EscapeByteA s) = quote q xs <$> escapeByteaConn conn s

597−buildAction conn q xs (EscapeIdentifier s) =

598− either (fmtErrorBs q xs) byteString <$> escapeIdentifier conn s

599−buildAction conn q xs (Many ys) =

600− mconcat <$> mapM (buildAction conn q xs) ys

601−

602−checkError :: PQ.Connection -> Maybe a -> IO (Either ByteString a)

603−checkError _ (Just x) = return $ Right x

604−checkError c Nothing = Left . maybe "" id <$> PQ.errorMessage c

605−

606−escapeWrap :: (PQ.Connection -> ByteString -> IO (Maybe ByteString))

607− -> Connection

608− -> ByteString

609− -> IO (Either ByteString ByteString)

610−escapeWrap f conn s =

611− withConnection conn $ \c ->

612− f c s >>= checkError c

613−

614−escapeStringConn :: Connection -> ByteString -> IO (Either ByteString ByteString)

615−escapeStringConn = escapeWrap PQ.escapeStringConn

616−

617−escapeIdentifier :: Connection -> ByteString -> IO (Either ByteString ByteString)

618−escapeIdentifier = escapeWrap PQ.escapeIdentifier

619−

620−escapeByteaConn :: Connection -> ByteString -> IO (Either ByteString ByteString)

621−escapeByteaConn = escapeWrap PQ.escapeByteaConn

622−

623−breakOnSingleQuestionMark :: ByteString -> (ByteString, ByteString)

624−breakOnSingleQuestionMark b = go (B8.empty, b)

625− where go (x,bs) = (x `B8.append` x',bs')

626− -- seperate from first QM

627− where tup@(noQ, restWithQ) = B8.break (=='?') bs

628− -- if end of query, just return

629− -- else check for second QM in 'go2'

630− (x', bs') = maybe tup go2 $

631− -- drop found QM and peek at next char

632− B8.uncons restWithQ >>= B8.uncons . snd

633− -- another QM after the first means:

634− -- take literal QM and keep going.

635− go2 ('?', t2) = go (noQ `B8.snoc` '?',t2)

636− -- Anything else means

637− go2 _ = tup

src/Database/PostgreSQL/Simple/Internal/PQResultUtils.hsdeleted−123

@@ -1,123 +0,0 @@

1−{-# LANGUAGE CPP #-}

2−

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−-- <https://www.postgresql.org/docs/9.5/static/largeobjects.html> for more

10+-- <http://www.postgresql.org/docs/9.1/static/largeobjects.html> for more

1111-- information.

1212--

1313-- Note that Large Object File Descriptors are only valid within a single

1414-- database transaction, so if you are interested in using anything beyond

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.hsdeleted−49

@@ -1,49 +0,0 @@

1−{-# LANGUAGE DeriveFunctor #-}

2−{-# LANGUAGE DeriveDataTypeable #-}

3−-- | Module with newtypes suitable to usage with @DerivingVia@ or standalone.

4−--

5−-- The newtypes are named after packages they wrap.

6−module Database.PostgreSQL.Simple.Newtypes (

7− Aeson (..), getAeson,

8−) where

9−

10−import Data.Typeable (Typeable)

11−import Database.PostgreSQL.Simple.ToField (ToField (..))

12−import Database.PostgreSQL.Simple.FromField (FromField (..), fromJSONField)

13−

14−import qualified Data.Aeson as Aeson

15−

16−-------------------------------------------------------------------------------

17−-- aeson

18−-------------------------------------------------------------------------------

19−

20−-- | A newtype wrapper with 'ToField' and 'FromField' instances

21−-- based on 'Aeson.ToJSON' and 'Aeson.FromJSON' type classes from @aeson@.

22−--

23−-- Example using @DerivingVia@:

24−--

25−-- @

26−-- data Foo = Foo Int String

27−-- deriving stock (Eq, Show, Generic) -- GHC built int

28−-- deriving anyclass ('Aeson.FromJSON', 'Aeson.ToJSON') -- Derived using GHC Generics

29−-- deriving ('ToField', 'FromField') via 'Aeson' Foo -- DerivingVia

30−-- @

31−--

32−-- Example using 'Aeson' newtype directly, for more ad-hoc queries

33−--

34−-- @

35−-- execute conn "INSERT INTO tbl (fld) VALUES (?)" (Only ('Aeson' x))

36−-- @

37−--

38−-- @since 0.6.3

39−newtype Aeson a = Aeson a

40− deriving (Eq, Show, Read, Typeable, Functor)

41−

42−getAeson :: Aeson a -> a

43−getAeson (Aeson a) = a

44−

45−instance Aeson.ToJSON a => ToField (Aeson a) where

46− toField = toField . Aeson.encode . getAeson

47−

48−instance (Aeson.FromJSON a, Typeable a) => FromField (Aeson a) where

49− fromField f bs = fmap Aeson (fromJSONField f bs)

src/Database/PostgreSQL/Simple/Notification.hs+32−62

@@ -5,8 +5,7 @@

55-----------------------------------------------------------------------------

66-- |

77-- Module : Database.PostgreSQL.Simple.Notification

109-- License : BSD3

1110--

1211-- Maintainer : leon@melding-monads.com

@@ -14,7 +13,7 @@

1413--

1514-- Support for receiving asynchronous notifications via PostgreSQL's

1615-- Listen/Notify mechanism. See

17−-- <https://www.postgresql.org/docs/9.5/static/sql-notify.html> for more

16+-- <http://www.postgresql.org/docs/9.1/static/sql-notify.html> for more

1817-- information.

1918--

2019-- Note that on Windows, @getNotification@ currently uses a polling loop

@@ -25,7 +24,7 @@

2524-- Notifications do not create any extra work for the backend, and are

2625-- likely cheaper on the client side as well.

2726--

28−-- <https://hackage.haskell.org/trac/ghc/ticket/7353>

27+-- <http://hackage.haskell.org/trac/ghc/ticket/7353>

2928--

3029-----------------------------------------------------------------------------

3130

@@ -36,27 +35,19 @@ module Database.PostgreSQL.Simple.Notification

3635 , getBackendPID

3736 ) where

3837

39−import Control.Monad ( join, void )

40−import Control.Exception ( throwIO, catch )

38+import Control.Concurrent

39+import Control.Monad ( when )

40+import Control.Exception ( throwIO )

4141import qualified Data.ByteString as B

42−import qualified Data.ByteString.Char8 as B8

4342import Database.PostgreSQL.Simple.Internal

4443import qualified Database.PostgreSQL.LibPQ as PQ

4544import 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

5445

5546data Notification = Notification

56− { notificationPid :: {-# UNPACK #-} !CPid

57− , notificationChannel :: {-# UNPACK #-} !B.ByteString

58− , notificationData :: {-# UNPACK #-} !B.ByteString

59− } deriving (Show, Eq)

47+ { notificationPid :: !CPid

48+ , notificationChannel :: !B.ByteString

49+ , notificationData :: !B.ByteString

50+ }

6051

6152convertNotice :: PQ.Notify -> Notification

6253convertNotice PQ.Notify{..}

@@ -66,56 +57,35 @@ convertNotice PQ.Notify{..}

6657

6758-- | Returns a single notification. If no notifications are available,

6859-- '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.

7360

7461getNotification :: Connection -> IO Notification

75−getNotification conn = join $ withConnection conn fetch

62+getNotification conn = loop False

7663 where

7764 funcName = "Database.PostgreSQL.Simple.Notification.getNotification"

78−

79− fetch c = do

80− mmsg <- PQ.notifies c

81− case mmsg of

82− Just msg -> return (return $! convertNotice msg)

83− Nothing -> do

84− mfd <- PQ.socket c

85− case mfd of

86− Nothing -> return (throwIO $! fdError funcName)

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

8778#if defined(mingw32_HOST_OS)

88− -- threadWaitRead doesn't work for sockets on Windows, so just

89− -- poll for input every second (PQconsumeInput is non-blocking).

90− --

91− -- We could call select(), but FFI calls can't be interrupted

92− -- with async exceptions, whereas threadDelay can.

93− Just _fd -> do

94− return (threadDelay 1000000 >> loop)

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

9585#else

96− -- This case fixes the race condition above. By registering

97− -- our interest in the descriptor before we drop the lock,

98− -- there is no opportunity for the descriptor index to be

99− -- reallocated on us.

100− --

101− -- (That is, assuming there isn't concurrently executing

102− -- code that manipulates the descriptor without holding

103− -- the lock... but such a major bug is likely to exhibit

104− -- itself in an at least somewhat more dramatic fashion.)

105− Just fd -> do

106− (waitRead, _) <- threadWaitReadSTM fd

107− return $ do

108− atomically waitRead `catch` (throwIO . setIOErrorLocation)

109− loop

86+ Left fd -> threadWaitRead fd >> loop True

11087#endif

111−

112− loop = join $ withConnection conn $ \c -> do

113− void $ PQ.consumeInput c

114− fetch c

115−

116− setIOErrorLocation :: IOError -> IOError

117− setIOErrorLocation err = err { ioe_location = B8.unpack funcName }

118−

88+ Right msg -> return $! convertNotice msg

11989

12090-- | Non-blocking variant of 'getNotification'. Returns a single notification,

12191-- if available. If no notifications are available, returns 'Nothing'.

src/Database/PostgreSQL/Simple/Ok.hs+4−10

@@ -1,11 +1,10 @@

11{-# LANGUAGE DeriveDataTypeable #-}

22{-# LANGUAGE DeriveFunctor #-}

3−{-# LANGUAGE CPP #-}

54------------------------------------------------------------------------------

65-- |

76-- Module : Database.PostgreSQL.Simple.Ok

98-- License : BSD3

109--

1110-- Maintainer : leon@melding-monads.com

@@ -21,7 +20,7 @@

2120-- commonly-used type and typeclass included in @base@.

2221--

2322-- Extending the failure case to a list of 'SomeException's enables a

24−-- more sensible 'Alternative' instance definitions: '<|>' concatenates

23+-- more sensible 'Alternative' instance definitions: '<|>' concatinates

2524-- the list of exceptions when both cases fail, and 'empty' is defined as

2625-- 'Errors []'. Though '<|>' one could pick one of two exceptions, and

2726-- throw away the other, and have 'empty' provide a generic exception,

@@ -37,8 +36,6 @@ import Control.Exception

3736import Control.Monad(MonadPlus(..))

3837import Data.Typeable

3938

40−import qualified Control.Monad.Fail as Fail

41−

4239-- FIXME: [SomeException] should probably be something else, maybe

4340-- a difference list (or a tree?)

4441

@@ -72,14 +69,11 @@ instance MonadPlus Ok where

7269 mplus = (<|>)

7370

7471instance Monad Ok where

72+ return = Ok

73+

7574 Errors es >>= _ = Errors es

7675 Ok a >>= f = f a

7776

78−#if !(MIN_VERSION_base(4,13,0))

79− fail = Fail.fail

80−#endif

81−

82−instance Fail.MonadFail Ok where

8377 fail str = Errors [SomeException (ErrorCall str)]

8478

8579-- | a way to reify a list of exceptions into a single exception

src/Database/PostgreSQL/Simple/Range.hsdeleted−317

@@ -1,317 +0,0 @@

1−{-# LANGUAGE DeriveDataTypeable #-}

2−{-# LANGUAGE DeriveFunctor #-}

3−{-# LANGUAGE OverloadedStrings #-}

4−{-# LANGUAGE FlexibleInstances #-}

5−

6−------------------------------------------------------------------------------

7−-- |

8−-- Module: Database.PostgreSQL.Simple.Range

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+14−17

@@ -1,9 +1,3 @@

1−{-# LANGUAGE CPP #-}

2−#if __GLASGOW_HASKELL__ >= 800

3−{-# LANGUAGE TemplateHaskellQuotes #-}

4−#else

5−{-# LANGUAGE TemplateHaskell #-}

6−#endif

71------------------------------------------------------------------------------

82-- |

93-- Module: Database.PostgreSQL.Simple.SqlQQ

@@ -15,11 +9,10 @@

159------------------------------------------------------------------------------

1610

1711module Database.PostgreSQL.Simple.SqlQQ (sql) where

18−import Database.PostgreSQL.Simple.Types (Query)

12+

1913import Language.Haskell.TH

2014import Language.Haskell.TH.Quote

2115import Data.Char

22−import Data.String

2316

2417-- | 'sql' is a quasiquoter that eases the syntactic burden

2518-- of writing big sql statements in Haskell source code. For example:

@@ -34,10 +27,10 @@ import Data.String

3427-- > LIMIT 100 |]

3528-- > (beginTime,endTime,string)

3629--

37−-- This quasiquoter returns a literal string expression of type 'Query',

38−-- and attempts to minimize whitespace; otherwise the above query would

39−-- consist of approximately half whitespace when sent to the database

40−-- backend. It also recognizes and strips out standard sql comments "--".

30+-- This quasiquoter attempts to mimimize whitespace; otherwise the

31+-- above query would consist of approximately half whitespace when sent

32+-- to the database backend. It also recognizes and strips out standard

33+-- sql comments "--".

4134--

4235-- The implementation of the whitespace reducer is currently incomplete.

4336-- Thus it can mess up your syntax in cases where whitespace should be

@@ -57,14 +50,17 @@ import Data.String

5750

5851sql :: QuasiQuoter

5952sql = QuasiQuoter

60− { quotePat = error "Database.PostgreSQL.Simple.SqlQQ.sql: quasiquoter used in pattern context"

61− , quoteType = error "Database.PostgreSQL.Simple.SqlQQ.sql: quasiquoter used in type context"

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"

6257 , quoteExp = sqlExp

63− , quoteDec = error "Database.PostgreSQL.Simple.SqlQQ.sql: quasiquoter used in declaration context"

58+ , quoteDec = error "Database.PostgreSQL.Simple.SqlQQ.sql:\

59+ \ quasiquoter used in declaration context"

6460 }

6561

6662sqlExp :: String -> Q Exp

67−sqlExp = appE [| fromString :: String -> Query |] . stringE . minimizeSpace

63+sqlExp = stringE . minimizeSpace

6864

6965minimizeSpace :: String -> String

7066minimizeSpace = drop 1 . reduceSpace

@@ -87,4 +83,5 @@ minimizeSpace = drop 1 . reduceSpace

8783 instring ('\'':'\'':xs) = '\'':'\'': instring xs

8884 instring ('\'':xs) = '\'': insql xs

8985 instring (x:xs) = x : instring xs

90− instring [] = error "Database.PostgreSQL.Simple.SqlQQ.sql: string literal not terminated"

86+ instring [] = error "Database.PostgreSQL.Simple.SqlQQ.sql:\

87+ \ string literal not terminated"

src/Database/PostgreSQL/Simple/Time.hs+50−216

@@ -1,216 +1,53 @@

1−{- |

2−Module: Database.PostgreSQL.Simple.Time

4−License: BSD3

5−Maintainer: Leon P Smith <leon@melding-monads.com>

6−Stability: experimental

7−

8−This module provides time types that supports positive and negative

9−infinity, as well as some functions for converting to and from strings.

10−

11−Also, this module also contains commentary regarding postgresql's timestamp

12−types, civil timekeeping in general, and how it relates to

13−postgresql-simple. You can read more about PostgreSQL's date and time types

14−at <https://www.postgresql.org/docs/9.5/static/datatype-datetime.html>,

15−and the IANA time zone database at <https://en.wikipedia.org/wiki/Tz_database>.

16−

17−Stack Overflow also has some excellent commentary on time, if it is a

18−wiki page or a highly upvoted question and answer. If the answer regarding

19−time has not received about a hundred upvotes at least, then the answer is

20−almost invariably completely and painfully wrong, even if it's the chosen

21−answer or the most highly upvoted answer to a question.

22−

23−PostgreSQL's @timestamp with time zone@ (hereafter, @timestamptz@) can be

24−converted to Haskell's 'Data.Time.UTCTime' and 'Data.Time.ZonedTime' types,

25−because values of these types represent a self-contained, unambiguous point

26−in time. PostgreSQL's @timestamp without time zone@ (hereafter, @timestamp@)

27−can be converted to Haskell's 'Data.Time.LocalTime', because values of these

28−types are ambiguous by themselves, and require context to disambiguate.

29−

30−While this behavior may be superficially counterintuitive because the

31−names might suggest otherwise, this behavior is correct. In fact,

32−the \"timezone\" language in both the postgresql and haskell types would

33−be better read as \"offset (from UTC)\", thus we have postgresql's

34−\"timestamp with offset\" corresponding to Haskell's \"time with the

35−offset \'zero\'\" and Haskell's \"time with an offset (that might be

36−nonzero)\". Similarly, postgresql's \"timestamp without an offset\"

37−corresponds to Haskell's \"local time (without an offset)\".

38−

39−It's important to distinguish between an offset, a standard time, and

40−a time zone. An offset is simply a difference of a local time from UTC,

41−such as @+00@, @-05@, or @+05:30@. A standard time specifies an offset

42−(which may vary throughout the year, due to daylight savings) that a

43−region follows, such as Universal Coordinated Time (UTC), Eastern Standard

44−Time\/Eastern Daylight Time (EST\/EDT), or India Standard Time (IST).

45−And a time zone, much like a standard time, is a function from

46−timestamps to offsets.

47−

48−A time zone is different from a standard time because different regions

49−inside a standard time can be governed by different civil authorities with

50−different laws and thus have different histories of civil time. An IANA

51−time zone is any region of the world that has had the same history of

52−civil time since @1970-01-01 00:00+00@.

53−

54−For example, as of today, both @America\/New_York@ and

55−@America\/Indiana\/Indianapolis@ are on the EST\/EDT time standard, but

56−Indiana used to be on Central Standard Time until 1942, and did not observe

57−daylight savings time (EST only) until 2006. Thus, the choice between

58−these two time zones still matters if you are dealing with timestamps

59−prior to 2006, and could become relevant again if (most of) Indiana

60−moves back to Central Time. (Of course, if the Central to Eastern switch

61−was the only difference, then these two time zones would be the same in

62−IANA's eyes, due to their cutoff date of 1970-01-01.)

63−

64−Getting back to practicalities, PostgreSQL's @timestamptz@ type does not

65−actually store an offset; rather, it uses the offset provided to calculate

66−UTC, and stores the timestamp as UTC. If an offset is not provided, the

67−given timestamp is assumed to be a local time for whatever the @timezone@

68−variable is set to, and the IANA TZ database is consulted to calculate an

69−offset from UTC for the time in question.

70−

71−Note that while most (local timestamp, time zone) pairs correspond to exactly

72−one UTC timestamp, some correspond to two UTC timestamps, while others

73−correspond to none at all. The ambiguous case occurs when the civil time

74−is rolled back, making a calendar day longer than 24 hours. In this case,

75−PostgreSQL silently chooses the second, later possibility. The inconsistent

76−case occurs when the civil time is moved forward, making a calendar day less

77−than 24 hours. In this case, PostgreSQL silently assumes the local time

78−was read off a clock that had not been moved forward at the prescribed time,

79−and moves the clock forward for you. Thus, converting from local time

80−to UTC need not be monotonic, if these inconsistent cases are allowed.

81−

82−When retrieving a @timestamptz@, the backend looks at the @time zone@

83−connection variable and then consults the IANA TZ database to calculate

84−an offset for the timestamp in the given time zone.

85−

86−Note that while some of the information contained in the IANA TZ database

87−is a bit of a standardized fiction, the conversion from UTC time to a

88−(local time, offset) pair in a particular time zone is always unambiguous,

89−and the result can always be unambiguously converted back to UTC. Thus,

90−postgresql-simple can interpret such a result as a 'Data.Time.ZonedTime',

91−or use the offset to convert back to 'Data.Time.UTCTime'.

92−

93−By contrast, the @timestamp@ type ignores any offsets provided to it,

94−and never sends back an offset. Thus, postgresql-simple equates this

95−with 'Data.Time.LocalTime', which has no concept of an offset. One can

96−convert between @timestamptz@ and @timestamp@ using the @AT TIME ZONE@

97−operator, whose semantics also demonstrates that @timestamptz@ is

98−'Data.Time.UTCTime' whereas @timestamp@ is 'Data.Time.LocalTime'.

99−

100−PostgreSQL's @timezone@ is a per-connection variable that by default is

101−initialized to @\'localtime\'@, which normally corresponds to the server's

102−time zone. However, this default can be modified on the server side for an

103−entire cluster, or on a per-user or per-database basis. Moreover, a client

104−can modify their instance of the variable at any time, and can apply that

105−change to the remaining duration of the connection, the current transaction,

106−or the execution context of a server-side function. In addition, upon

107−connection initialization, the libpq client checks for the existence of

108−the @PGTZ@ environment variable, and if it exists, modifies @timezone@

109−accordingly.

110−

111−With a few caveats, postgresql-simple is designed so that you can both send

112−and receive timestamps with the server and get a correct result, no matter

113−what the @timezone@ setting is. But it is important to understand the caveats:

114−

115−1. The correctness of server-side computations can depend on the @timezone@

116− setting. Examples include adding an @interval@ to a @timestamptz@, or

117− type casting between @timestamp@ and @timestamptz@, or applying

118− the @DATE@ function to a @timestamptz@.

119−

120−2. The (localtime, offset) pair contained in a 'Data.Time.ZonedTime' result

121− will depend on the @timezone@ setting, although the result will always

122− represent the same instant in time regardless of the time zone.

123−

124−3. Sending a 'Data.Time.LocalTime' and interpreting it as a @timestamptz@

125− can be useful, as it will be converted to UTC via the tz database,

126− but correctness will depend on the @timezone@ setting. You may prefer

127− to use an explicit @AT TIME ZONE@ conversion instead, which would avoid

128− this contextual dependence.

129−

130−Furthermore, although these following points don't involve the @timezone@

131−setting, they are related to the last point above:

132−

133−1. Sending a 'Data.Time.UTCTime' and interpreting it as a @timestamp@ can

134− be useful. In practice, the most common context used to disambiguate

135− @timestamp@ is that it represents UTC, and this coding technique will

136− work as expected in this situation.

137−

138−2. Sending a 'Data.Time.ZonedTime' and interpreting it as a @timestamp@ is

139− almost always the wrong thing to do, as the offset will be ignored and

140− discarded. This is likely to lead to inconsistencies in the database,

141− and may lead to partial data loss.

142−

143−When dealing with local timestamps that refer to the future, it is often

144−useful to store it as a local time in a @timestamp@ column and store the

145−time zone in a second column. One reason to do this is so that you can

146−convert to UTC on the fly as needed, and be protected against future changes

147−to the TZ database due to changes in local time standards. In any case,

148−'Data.Time.ZonedTime' is not suitable for this application, because despite

149−its name, it represents an offset and not a time zone. Time zones can change;

150−offsets do not. In reality, we can't convert a local timestamp that occurs

151−sufficiently far in the future to UTC, because we don't know how to do it yet.

152−

153−There are a few limitations and caveats that one might need to be aware

154−of with the current implementation when dealing with older timestamps:

155−

156−For sufficiently old timestamps in almost all time zones, the IANA TZ

157−database specifies offsets from UTC that is not an integral number of

158−minutes. This corresponds to local mean time; that is, astronomical

159−time in the city that defines the time zone. Different time zones moved

160−away from local mean time to a standard time at different points in

161−history, so \"sufficiently old\" depends on the time zone in question.

162−

163−Thus, when retrieving a @timestamptz@ postgresql will in some cases

164−provide seconds in the offset. For example:

165−

166−@

167−$ psql

168−psql (9.4.5)

169−Type \"help\" for help.

170−

171−lpsmith=> SET timezone TO \'America/New_York\';

172−SET

173−lpsmith=> VALUES (\'1883-11-18 16:59:59+00\'::timestamptz),

174− (\'1883-11-18 17:00:00+00\'::timestamptz);

175− column1

176−------------------------------

177− 1883-11-18 12:03:57-04:56:02

178− 1883-11-18 12:00:00-05

179−(2 rows)

180−@

181−

182−Both of these timestamps can be parsed as a 'Data.Time.UTCTime' type,

183−however 'Data.Time.ZonedTime' will fail on the former timestamp.

184−Because 'Data.Time.ZonedTime' assumes that offsets are an integer number

185−of minutes, there isn't an particularly good solution here.

186−

187−PostgreSQL, like most software, uses the proleptic Gregorian calendar

188−for its date calculations, extending the Gregorian calendar backwards

189−in time before its introduction and pretending that the Julian calendar

190−does not exist. For most purposes, the adoption of the Gregorian calendar

191−ranges from @1582-10-15@ to @1923-03-01@, depending on location and

192−sometimes even political allegiances within a single location.

193−

194−Timestamps BCE are not supported. For example, PostgreSQL

195−will emit \"@0045-01-01 BC@\" for the first proleptic Gregorian day of

196−the year the Roman Empire adopted the Julian Calendar, but

197−postgresql-simple does not (yet?) have the ability to either parse or

198−generate this syntax. Unfortunately this syntax isn't convenient to

199−print or especially parse.

200−

201−Also, postgresql itself cannot parse or print dates before @4714-11-24 BC@,

202−which is the Julian date on the proleptic Gregorian Calendar. Although

203−postgresql's timestamp types are perfectly capable of representing timestamps

204−nearly 300,000 years in the past, using this would require postgresql-simple

205−and other client programs to support binary parameters and results.

206−

207−Dealing with years BCE is also complicated slightly by the fact that

208−Haskell's time library has a year \"0000\", which is a convention often

209−used by astronomers, while postgresql adopts the more historically

210−accurate convention that there is no year zero, but rather \"1 BCE\"

211−was immediately followed by \"1 CE\".

212−

213−-}

1+------------------------------------------------------------------------------

2+-- |

3+-- Module: Database.PostgreSQL.Simple.Time

5+-- License: BSD3

6+-- Maintainer: Leon P Smith <leon@melding-monads.com>

7+-- Stability: experimental

8+--

9+-- Time types that supports positive and negative infinity. Also includes

10+-- new time parsers and printers with better performance than GHC's time

11+-- package.

12+--

13+-- The parsers only understand the specific variant of ISO 8601 that

14+-- PostgreSQL emits, and the printers attempt to duplicate this syntax.

15+-- Thus the @datestyle@ parameter for the connection must be set to @ISO@.

16+--

17+-- These parsers and printers likely have problems and shortcomings. Some

18+-- that I know of:

19+--

20+-- 1 @TimestampTZ@s before a timezone-dependent point in time cannot be

21+-- parsed, because the parsers can only handle timezone offsets of a

22+-- integer number of minutes. However, PostgreSQL will include seconds

23+-- in the offset, depending on the historical time standards for the city

24+-- identifying the time zone.

25+--

26+-- This boundary point often marks an event of some interest. In the US

27+-- for example, @timestamptz@s before @1883-Nov-18 12:00:00@ local time

28+-- cannot be parsed. This is the moment Standard Railway Time went live.

29+-- Concretely, PostgreSQL will emit @1883-11-18 12:03:57-04:56:02@

30+-- instead of @1883-11-18 11:59:59-05@ when the @timezone@ parameter

31+-- for the connection is set to @America/New_York@.

32+--

33+-- 2. Dates and times surrounding @1582-Feb-24@, the date the Gregorian

34+-- Calendar was introduced, should be investigated for conversion errors.

35+--

36+-- 3. Points in time Before Christ are not also not supported. For example,

37+-- PostgreSQL will emit @0045-01-01 BC@ for a value of a @date@ type.

38+-- This is the year that the Julian Calendar was adopted.

39+--

40+-- However, it should be noted that the old parsers also had issues 1 and 3.

41+-- Also, the new parsers now correctly handle time zones that include minutes

42+-- in their offset. Most notably, this includes all of India and parts of

43+-- Canada and Australia.

44+--

45+-- PostgreSQL uses the zoneinfo database for its time zone information.

46+-- You can read more about PostgreSQL's date and time types at

47+-- <http://www.postgresql.org/docs/9.1/static/datatype-datetime.html>,

48+-- and zoneinfo at <http://en.wikipedia.org/wiki/Tz_database>.

49+--

50+------------------------------------------------------------------------------

21451

21552module Database.PostgreSQL.Simple.Time

21653 ( Unbounded(..)

@@ -227,7 +64,6 @@ module Database.PostgreSQL.Simple.Time

22764 , parseUTCTimestamp

22865 , parseZonedTimestamp

22966 , parseLocalTimestamp

230− , parseCalendarDiffTime

23167 , dayToBuilder

23268 , utcTimeToBuilder

23369 , zonedTimeToBuilder

@@ -239,8 +75,6 @@ module Database.PostgreSQL.Simple.Time

23975 , zonedTimestampToBuilder

24076 , localTimestampToBuilder

24177 , unboundedToBuilder

242− , nominalDiffTimeToBuilder

243− , calendarDiffTimeToBuilder

24478 ) where

24579

24680import Database.PostgreSQL.Simple.Time.Implementation

src/Database/PostgreSQL/Simple/Time/Implementation.hs+157−51

@@ -1,44 +1,51 @@

11------------------------------------------------------------------------------

22-- |

33-- Module: Database.PostgreSQL.Simple.Time.Implementation

55-- License: BSD3

66-- Maintainer: Leon P Smith <leon@melding-monads.com>

77-- Stability: experimental

88--

99------------------------------------------------------------------------------

1010

11−{-# LANGUAGE DeriveDataTypeable, DeriveFunctor #-}

11+{-# LANGUAGE DeriveDataTypeable #-}

1212

1313module Database.PostgreSQL.Simple.Time.Implementation where

1414

15−import Prelude hiding (take)

16−import Data.ByteString.Builder(Builder, byteString)

17−import Data.ByteString.Builder.Prim(primBounded)

15+import Prelude hiding (take, (++))

16+import Blaze.ByteString.Builder(Builder, fromByteString)

17+import Blaze.ByteString.Builder.Char8(fromChar)

18+import Blaze.Text.Int(integral)

1819import Control.Arrow((***))

1920import Control.Applicative

21+import Control.Monad(when)

22+import Data.Bits((.&.))

2023import qualified Data.ByteString as B

21−import Data.Time.Compat (LocalTime, UTCTime, ZonedTime, Day, TimeOfDay, TimeZone, NominalDiffTime, utc)

22−import Data.Time.LocalTime.Compat (CalendarDiffTime)

24+import Data.ByteString.Internal (c2w, w2c)

25+import Data.Time hiding (getTimeZone, getZonedTime)

2326import Data.Typeable

24−import Data.Maybe (fromMaybe)

25−import qualified Data.Attoparsec.ByteString.Char8 as A

26−import Database.PostgreSQL.Simple.Compat ((<>))

27−import qualified Database.PostgreSQL.Simple.Time.Internal.Parser as TP

28−import qualified Database.PostgreSQL.Simple.Time.Internal.Printer as TPP

27+import Data.Word(Word8)

28+import qualified Data.Attoparsec.Char8 as A

29+import Data.Monoid(Monoid(..))

30+import Data.Fixed (Pico)

31+import Unsafe.Coerce

32+

33+(++) :: Monoid a => a -> a -> a

34+(++) = mappend

35+infixr 5 ++

2936

3037data Unbounded a

3138 = NegInfinity

3239 | Finite !a

3340 | PosInfinity

34− deriving (Eq, Ord, Typeable, Functor)

41+ deriving (Eq, Ord, Typeable)

3542

3643instance Show a => Show (Unbounded a) where

3744 showsPrec prec x rest

3845 = case x of

39− NegInfinity -> "-infinity" <> rest

46+ NegInfinity -> "-infinity" ++ rest

4047 Finite time -> showsPrec prec time rest

41− PosInfinity -> "infinity" <> rest

48+ PosInfinity -> "infinity" ++ rest

4249

4350instance Read a => Read (Unbounded a) where

4451 readsPrec prec = readParen False $ \str -> case str of

@@ -78,9 +85,6 @@ parseLocalTimestamp = A.parseOnly (getLocalTimestamp <* A.endOfInput)

7885parseDate :: B.ByteString -> Either String Date

7986parseDate = A.parseOnly (getDate <* A.endOfInput)

8087

81−parseCalendarDiffTime :: B.ByteString -> Either String CalendarDiffTime

82−parseCalendarDiffTime = A.parseOnly (getCalendarDiffTime <* A.endOfInput)

83−

8488getUnbounded :: A.Parser a -> A.Parser (Unbounded a)

8589getUnbounded getFinite

8690 = (pure NegInfinity <* A.string "-infinity")

@@ -88,74 +92,130 @@ getUnbounded getFinite

8892 <|> (Finite <$> getFinite)

8993

9094getDay :: A.Parser Day

91−getDay = TP.day

95+getDay = do

96+ yearStr <- A.takeWhile A.isDigit

97+ when (B.length yearStr < 4) (fail "year must consist of at least 4 digits")

98+

99+ let !year = toNum yearStr

100+ _ <- A.char '-'

101+ month <- digits "month"

102+ _ <- A.char '-'

103+ day <- digits "day"

104+

105+ case fromGregorianValid year month day of

106+ Nothing -> fail "invalid date"

107+ Just x -> return $! x

92108

93109getDate :: A.Parser Date

94110getDate = getUnbounded getDay

95111

112+decimal :: Fractional a => B.ByteString -> a

113+decimal str = toNum str / 10^(B.length str)

114+{-# INLINE decimal #-}

115+

96116getTimeOfDay :: A.Parser TimeOfDay

97−getTimeOfDay = TP.timeOfDay

117+getTimeOfDay = do

118+ hour <- digits "hours"

119+ _ <- A.char ':'

120+ minute <- digits "minutes"

121+ _ <- A.char ':'

122+ second <- digits "seconds"

123+ subsec <- (A.char '.' *> (decimal <$> A.takeWhile1 A.isDigit)) <|> return 0

124+

125+ let !picos' = second + subsec

126+

127+ case makeTimeOfDayValid hour minute picos' of

128+ Nothing -> fail "invalid time of day"

129+ Just x -> return $! x

98130

99131getLocalTime :: A.Parser LocalTime

100−getLocalTime = TP.localTime

132+getLocalTime = LocalTime <$> getDay <*> (A.char ' ' *> getTimeOfDay)

101133

102134getLocalTimestamp :: A.Parser LocalTimestamp

103135getLocalTimestamp = getUnbounded getLocalTime

104136

105137getTimeZone :: A.Parser TimeZone

106−getTimeZone = fromMaybe utc <$> TP.timeZone

107−

108−type TimeZoneHMS = (Int,Int,Int)

109−

110−getTimeZoneHMS :: A.Parser TimeZoneHMS

111−getTimeZoneHMS = munge <$> TP.timeZoneHMS

112− where

113− munge Nothing = (0,0,0)

114− munge (Just (TP.UTCOffsetHMS h m s)) = (h,m,s)

115−

116−localToUTCTimeOfDayHMS :: TimeZoneHMS -> TimeOfDay -> (Integer, TimeOfDay)

117−localToUTCTimeOfDayHMS (dh, dm, ds) tod =

118− TP.localToUTCTimeOfDayHMS (TP.UTCOffsetHMS dh dm ds) tod

138+getTimeZone = do

139+ sign <- A.satisfy (\c -> c == '+' || c == '-')

140+ hours <- digits "timezone"

141+ mins <- (A.char ':' *> digits "timezone minutes") <|> pure 0

142+ let !absset = 60 * hours + mins

143+ !offset = if sign == '+' then absset else -absset

144+ return $! minutesToTimeZone offset

119145

120146getZonedTime :: A.Parser ZonedTime

121−getZonedTime = TP.zonedTime

147+getZonedTime = ZonedTime <$> getLocalTime <*> getTimeZone

122148

123149getZonedTimestamp :: A.Parser ZonedTimestamp

124150getZonedTimestamp = getUnbounded getZonedTime

125151

126152getUTCTime :: A.Parser UTCTime

127−getUTCTime = TP.utcTime

153+getUTCTime = do

154+ day <- getDay

155+ _ <- A.char ' '

156+ time <- getTimeOfDay

157+ zone <- getTimeZone

158+ let (!dayDelta,!time') = localToUTCTimeOfDay zone time

159+ let !day' = addDays dayDelta day

160+ let !time'' = timeOfDayToTime time'

161+ return (UTCTime day' time'')

128162

129163getUTCTimestamp :: A.Parser UTCTimestamp

130164getUTCTimestamp = getUnbounded getUTCTime

131165

132−getCalendarDiffTime :: A.Parser CalendarDiffTime

133−getCalendarDiffTime = TP.calendarDiffTime

166+toNum :: Num n => B.ByteString -> n

167+toNum = B.foldl' (\a c -> 10*a + digit c) 0

168+{-# INLINE toNum #-}

169+

170+digit :: Num n => Word8 -> n

171+digit c = fromIntegral (c .&. 0x0f)

172+{-# INLINE digit #-}

173+

174+digits :: Num n => String -> A.Parser n

175+digits msg = do

176+ x <- A.anyChar

177+ y <- A.anyChar

178+ if A.isDigit x && A.isDigit y

179+ then return $! (10 * digit (c2w x) + digit (c2w y))

180+ else fail (msg ++ " is not 2 digits")

181+{-# INLINE digits #-}

134182

135183dayToBuilder :: Day -> Builder

136−dayToBuilder = primBounded TPP.day

184+dayToBuilder (toGregorian -> (y,m,d)) = do

185+ pad4 y ++ fromChar '-' ++ pad2 m ++ fromChar '-' ++ pad2 d

137186

138187timeOfDayToBuilder :: TimeOfDay -> Builder

139−timeOfDayToBuilder = primBounded TPP.timeOfDay

188+timeOfDayToBuilder (TimeOfDay h m s) = do

189+ pad2 h ++ fromChar ':' ++ pad2 m ++ fromChar ':' ++ showSeconds s

140190

141191timeZoneToBuilder :: TimeZone -> Builder

142−timeZoneToBuilder = primBounded TPP.timeZone

192+timeZoneToBuilder tz

193+ | m == 0 = sign h ++ pad2 (abs h)

194+ | otherwise = sign h ++ pad2 (abs h) ++ fromChar ':' ++ pad2 (abs m)

195+ where

196+ (h,m) = timeZoneMinutes tz `quotRem` 60

197+ sign h | h >= 0 = fromChar '+'

198+ | otherwise = fromChar '-'

143199

144200utcTimeToBuilder :: UTCTime -> Builder

145−utcTimeToBuilder = primBounded TPP.utcTime

201+utcTimeToBuilder (UTCTime day time) =

202+ dayToBuilder day ++ fromChar ' '

203+ ++ timeOfDayToBuilder (timeToTimeOfDay time) ++ fromByteString "+00"

146204

147205zonedTimeToBuilder :: ZonedTime -> Builder

148−zonedTimeToBuilder = primBounded TPP.zonedTime

206+zonedTimeToBuilder (ZonedTime localTime tz) =

207+ localTimeToBuilder localTime ++ timeZoneToBuilder tz

149208

150209localTimeToBuilder :: LocalTime -> Builder

151−localTimeToBuilder = primBounded TPP.localTime

210+localTimeToBuilder (LocalTime day tod) =

211+ dayToBuilder day ++ fromChar ' ' ++ timeOfDayToBuilder tod

152212

153213unboundedToBuilder :: (a -> Builder) -> (Unbounded a -> Builder)

154214unboundedToBuilder finiteToBuilder unbounded

155215 = case unbounded of

156− NegInfinity -> byteString "-infinity"

216+ NegInfinity -> fromByteString "-infinity"

157217 Finite a -> finiteToBuilder a

158− PosInfinity -> byteString "infinity"

218+ PosInfinity -> fromByteString "infinity"

159219

160220utcTimestampToBuilder :: UTCTimestamp -> Builder

161221utcTimestampToBuilder = unboundedToBuilder utcTimeToBuilder

@@ -169,8 +229,54 @@ localTimestampToBuilder = unboundedToBuilder localTimeToBuilder

169229dateToBuilder :: Date -> Builder

170230dateToBuilder = unboundedToBuilder dayToBuilder

171231

172−nominalDiffTimeToBuilder :: NominalDiffTime -> Builder

173−nominalDiffTimeToBuilder = TPP.nominalDiffTime

174−

175−calendarDiffTimeToBuilder :: CalendarDiffTime -> Builder

176−calendarDiffTimeToBuilder = TPP.calendarDiffTime

232+showSeconds :: Pico -> Builder

233+showSeconds xyz

234+ | yz == 0 = pad2 x

235+ | z == 0 = pad2 x ++ fromChar '.' ++ showD6 y

236+ | otherwise = pad2 x ++ fromChar '.' ++ pad6 y ++ showD6 z

237+ where

238+ -- A kludge to work around the fact that Data.Fixed isn't very fast and

239+ -- doesn't give me access to the MkFixed constructor.

240+ (x_,yz) = (unsafeCoerce xyz :: Integer) `quotRem` 1000000000000

241+ x = fromIntegral x_ :: Int

242+ (fromIntegral -> y, fromIntegral -> z) = yz `quotRem` 1000000

243+

244+pad6 :: Int -> Builder

245+pad6 xy = let (x,y) = xy `quotRem` 1000

246+ in pad3 x ++ pad3 y

247+

248+showD6 :: Int -> Builder

249+showD6 xy = case xy `quotRem` 1000 of

250+ (x,0) -> showD3 x

251+ (x,y) -> pad3 x ++ showD3 y

252+

253+pad3 :: Int -> Builder

254+pad3 abc = let (ab,c) = abc `quotRem` 10

255+ (a,b) = ab `quotRem` 10

256+ in p a ++ p b ++ p c

257+

258+showD3 :: Int -> Builder

259+showD3 abc = case abc `quotRem` 100 of

260+ (a, 0) -> p a

261+ (a,bc) -> case bc `quotRem` 10 of

262+ (b,0) -> p a ++ p b

263+ (b,c) -> p a ++ p b ++ p c

264+

265+-- | p assumes its input is in the range [0..9]

266+p :: Integral n => n -> Builder

267+p n = fromChar (w2c (fromIntegral (n + 48)))

268+{-# INLINE p #-}

269+

270+-- | pad2 assumes its input is in the range [0..99]

271+pad2 :: Integral n => n -> Builder

272+pad2 n = let (a,b) = n `quotRem` 10 in p a ++ p b

273+{-# INLINE pad2 #-}

274+

275+-- | pad4 assumes its input is positive

276+pad4 :: (Integral n, Show n) => n -> Builder

277+pad4 abcd | abcd >= 10000 = integral abcd

278+ | otherwise = p a ++ p b ++ p c ++ p d

279+ where (ab,cd) = abcd `quotRem` 100

280+ (a,b) = ab `quotRem` 10

281+ (c,d) = cd `quotRem` 10

282+{-# INLINE pad4 #-}

src/Database/PostgreSQL/Simple/Time/Internal.hs−3

@@ -19,9 +19,6 @@ module Database.PostgreSQL.Simple.Time.Internal

1919 , getZonedTimestamp

2020 , getUTCTime

2121 , getUTCTimestamp

22− , TimeZoneHMS

23− , getTimeZoneHMS

24− , localToUTCTimeOfDayHMS

2522 ) where

2623

2724import Database.PostgreSQL.Simple.Time.Implementation

src/Database/PostgreSQL/Simple/Time/Internal/Parser.hsdeleted−204

@@ -1,204 +0,0 @@

1−{-# LANGUAGE BangPatterns, ScopedTypeVariables #-}

2−

3−-- |

4−-- Module: Database.PostgreSQL.Simple.Time.Internal.Parser

7−-- License: BSD3

8−-- Maintainer: Leon P Smith <leon@melding-monads.com>

9−-- Stability: experimental

10−--

11−-- Parsers for parsing dates and times.

12−

13−module Database.PostgreSQL.Simple.Time.Internal.Parser

14− (

15− day

16− , localTime

17− , timeOfDay

18− , timeZone

19− , UTCOffsetHMS(..)

20− , timeZoneHMS

21− , localToUTCTimeOfDayHMS

22− , utcTime

23− , zonedTime

24− , calendarDiffTime

25− ) where

26−

27−import Control.Applicative ((<$>), (<*>), (<*), (*>))

28−import Database.PostgreSQL.Simple.Compat (toPico)

29−import Data.Attoparsec.ByteString.Char8 as A

30−import Data.Bits ((.&.))

31−import Data.ByteString (ByteString)

32−import Data.Char (ord)

33−import Data.Fixed (Pico)

34−import Data.Int (Int64)

35−import Data.Maybe (fromMaybe)

36−import Data.Time.Calendar.Compat (Day, fromGregorianValid, addDays)

37−import Data.Time.Clock.Compat (UTCTime(..))

38−import Data.Time.Format.ISO8601.Compat (iso8601ParseM)

39−import Data.Time.LocalTime.Compat (CalendarDiffTime)

40−import qualified Data.ByteString.Char8 as B8

41−import qualified Data.Time.LocalTime.Compat as Local

42−

43−-- | Parse a date of the form @YYYY-MM-DD@.

44−day :: Parser Day

45−day = do

46− y <- decimal <* char '-'

47− m <- twoDigits <* char '-'

48− d <- twoDigits

49− maybe (fail "invalid date") return (fromGregorianValid y m d)

50−

51−-- | Parse a two-digit integer (e.g. day of month, hour).

52−twoDigits :: Parser Int

53−twoDigits = do

54− a <- digit

55− b <- digit

56− let c2d c = ord c .&. 15

57− return $! c2d a * 10 + c2d b

58−

59−-- | Parse a time of the form @HH:MM[:SS[.SSS]]@.

60−timeOfDay :: Parser Local.TimeOfDay

61−timeOfDay = do

62− h <- twoDigits <* char ':'

63− m <- twoDigits

64− mc <- peekChar

65− s <- case mc of

66− Just ':' -> anyChar *> seconds

67− _ -> return 0

68− if h < 24 && m < 60 && s <= 60

69− then return (Local.TimeOfDay h m s)

70− else fail "invalid time"

71−

72−-- | Parse a count of seconds, with the integer part being two digits

73−-- long.

74−seconds :: Parser Pico

75−seconds = do

76− real <- twoDigits

77− mc <- peekChar

78− case mc of

79− Just '.' -> do

80− t <- anyChar *> takeWhile1 isDigit

81− return $! parsePicos (fromIntegral real) t

82− _ -> return $! fromIntegral real

83− where

84− parsePicos :: Int64 -> B8.ByteString -> Pico

85− parsePicos a0 t = toPico (fromIntegral (t' * 10^n))

86− where n = max 0 (12 - B8.length t)

87− t' = B8.foldl' (\a c -> 10 * a + fromIntegral (ord c .&. 15)) a0

88− (B8.take 12 t)

89−

90−-- | Parse a time zone, and return 'Nothing' if the offset from UTC is

91−-- zero. (This makes some speedups possible.)

92−timeZone :: Parser (Maybe Local.TimeZone)

93−timeZone = do

94− ch <- satisfy $ \c -> c == '+' || c == '-' || c == 'Z'

95− if ch == 'Z'

96− then return Nothing

97− else do

98− h <- twoDigits

99− mm <- peekChar

100− m <- case mm of

101− Just ':' -> anyChar *> twoDigits

102− _ -> return 0

103− let off | ch == '-' = negate off0

104− | otherwise = off0

105− off0 = h * 60 + m

106− case undefined of

107− _ | off == 0 ->

108− return Nothing

109− | h > 23 || m > 59 ->

110− fail "invalid time zone offset"

111− | otherwise ->

112− let !tz = Local.minutesToTimeZone off

113− in return (Just tz)

114−

115−data UTCOffsetHMS = UTCOffsetHMS {-# UNPACK #-} !Int {-# UNPACK #-} !Int {-# UNPACK #-} !Int

116−

117−-- | Parse a time zone, and return 'Nothing' if the offset from UTC is

118−-- zero. (This makes some speedups possible.)

119−timeZoneHMS :: Parser (Maybe UTCOffsetHMS)

120−timeZoneHMS = do

121− ch <- satisfy $ \c -> c == '+' || c == '-' || c == 'Z'

122− if ch == 'Z'

123− then return Nothing

124− else do

125− h <- twoDigits

126− m <- maybeTwoDigits

127− s <- maybeTwoDigits

128− case undefined of

129− _ | h == 0 && m == 0 && s == 0 ->

130− return Nothing

131− | h > 23 || m >= 60 || s >= 60 ->

132− fail "invalid time zone offset"

133− | otherwise ->

134− if ch == '+'

135− then let !tz = UTCOffsetHMS h m s

136− in return (Just tz)

137− else let !tz = UTCOffsetHMS (-h) (-m) (-s)

138− in return (Just tz)

139− where

140− maybeTwoDigits = do

141− ch <- peekChar

142− case ch of

143− Just ':' -> anyChar *> twoDigits

144− _ -> return 0

145−

146−localToUTCTimeOfDayHMS :: UTCOffsetHMS -> Local.TimeOfDay -> (Integer, Local.TimeOfDay)

147−localToUTCTimeOfDayHMS (UTCOffsetHMS dh dm ds) (Local.TimeOfDay h m s) =

148− (\ !a !b -> (a,b)) dday (Local.TimeOfDay h'' m'' s'')

149− where

150− s' = s - fromIntegral ds

151− (!s'', m')

152− | s' < 0 = (s' + 60, m - dm - 1)

153− | s' >= 60 = (s' - 60, m - dm + 1)

154− | otherwise = (s' , m - dm )

155− (!m'', h')

156− | m' < 0 = (m' + 60, h - dh - 1)

157− | m' >= 60 = (m' - 60, h - dh + 1)

158− | otherwise = (m' , h - dh )

159− (!h'', dday)

160− | h' < 0 = (h' + 24, -1)

161− | h' >= 24 = (h' - 24, 1)

162− | otherwise = (h' , 0)

163−

164−

165−-- | Parse a date and time, of the form @YYYY-MM-DD HH:MM:SS@.

166−-- The space may be replaced with a @T@. The number of seconds may be

167−-- followed by a fractional component.

168−localTime :: Parser Local.LocalTime

169−localTime = Local.LocalTime <$> day <* daySep <*> timeOfDay

170− where daySep = satisfy (\c -> c == ' ' || c == 'T')

171−

172−-- | Behaves as 'zonedTime', but converts any time zone offset into a

173−-- UTC time.

174−utcTime :: Parser UTCTime

175−utcTime = do

176− (Local.LocalTime d t) <- localTime

177− mtz <- timeZoneHMS

178− case mtz of

179− Nothing -> let !tt = Local.timeOfDayToTime t

180− in return (UTCTime d tt)

181− Just tz -> let !(dd,t') = localToUTCTimeOfDayHMS tz t

182− !d' = addDays dd d

183− !tt = Local.timeOfDayToTime t'

184− in return (UTCTime d' tt)

185−

186−-- | Parse a date with time zone info. Acceptable formats:

187−--

188−-- @YYYY-MM-DD HH:MM:SS Z@

189−--

190−-- The first space may instead be a @T@, and the second space is

191−-- optional. The @Z@ represents UTC. The @Z@ may be replaced with a

192−-- time zone offset of the form @+0000@ or @-08:00@, where the first

193−-- two digits are hours, the @:@ is optional and the second two digits

194−-- (also optional) are minutes.

195−zonedTime :: Parser Local.ZonedTime

196−zonedTime = Local.ZonedTime <$> localTime <*> (fromMaybe utc <$> timeZone)

197−

198−utc :: Local.TimeZone

199−utc = Local.TimeZone 0 False ""

200−

201−calendarDiffTime :: Parser CalendarDiffTime

202−calendarDiffTime = do

203− contents <- takeByteString

204− iso8601ParseM $ B8.unpack contents

src/Database/PostgreSQL/Simple/Time/Internal/Printer.hsdeleted−135

@@ -1,135 +0,0 @@

1−{-# LANGUAGE BangPatterns, ViewPatterns #-}

2−

3−------------------------------------------------------------------------------

4−-- Module: Database.PostgreSQL.Simple.Time.Internal.Printer

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+54−89

@@ -1,6 +1,5 @@

11{-# LANGUAGE CPP, DeriveDataTypeable, DeriveFunctor #-}

22{-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-}

3−{-# LANGUAGE PolyKinds #-}

54------------------------------------------------------------------------------

65-- |

@@ -23,44 +22,38 @@ module Database.PostgreSQL.Simple.ToField

2322 , inQuotes

2423 ) where

2524

26−import Control.Applicative (Const(Const))

25+import Blaze.ByteString.Builder (Builder, fromByteString, toByteString)

26+import Blaze.ByteString.Builder.Char8 (fromChar)

27+import Blaze.Text (integral, double, float)

2728import qualified Data.Aeson as JSON

28−import Data.ByteString (ByteString)

29−import Data.ByteString.Builder

30− ( Builder, byteString, char8, stringUtf8

31− , intDec, int8Dec, int16Dec, int32Dec, int64Dec, integerDec

32− , wordDec, word8Dec, word16Dec, word32Dec, word64Dec

33− , floatDec, doubleDec

34− )

35−import Data.Functor.Identity (Identity(Identity))

29+import Data.ByteString (ByteString)

3630import Data.Int (Int8, Int16, Int32, Int64)

3731import Data.List (intersperse)

3832import Data.Monoid (mappend)

39−import Data.Time.Compat (Day, TimeOfDay, LocalTime, UTCTime, ZonedTime, NominalDiffTime)

40−import Data.Time.LocalTime.Compat (CalendarDiffTime)

33+import Data.Time (Day, TimeOfDay, LocalTime, UTCTime, ZonedTime)

4134import Data.Typeable (Typeable)

4235import Data.Word (Word, Word8, Word16, Word32, Word64)

4336import {-# SOURCE #-} Database.PostgreSQL.Simple.ToRow

4437import Database.PostgreSQL.Simple.Types

45−import Database.PostgreSQL.Simple.Compat (toByteString)

46−

38+import qualified Blaze.ByteString.Builder.Char.Utf8 as Utf8

4739import qualified Data.ByteString as SB

4840import qualified Data.ByteString.Lazy as LB

49−import Data.CaseInsensitive (CI)

50−import qualified Data.CaseInsensitive as CI

5141import qualified Data.Text as ST

5242import qualified Data.Text.Encoding as ST

5343import qualified Data.Text.Lazy as LT

5444import qualified Data.Text.Lazy.Builder as LT

55−import Data.UUID.Types (UUID)

56−import qualified Data.UUID.Types as UUID

45+import Data.UUID (UUID)

46+import qualified Data.UUID as UUID

5747import Data.Vector (Vector)

5848import qualified Data.Vector as V

5949import qualified Database.PostgreSQL.LibPQ as PQ

6050import Database.PostgreSQL.Simple.Time

6151import Data.Scientific (Scientific)

52+#if MIN_VERSION_scientific(0,3,0)

6253import Data.Text.Lazy.Builder.Scientific (scientificBuilder)

63−import Foreign.C.Types (CUInt(..))

54+#else

55+import Data.Scientific (scientificBuilder)

56+#endif

6457

6558-- | How to render an element when substituting it into a query.

6659data Action =

@@ -100,98 +93,90 @@ instance ToField Action where

10093 toField a = a

10194 {-# INLINE toField #-}

10295

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−

11196instance (ToField a) => ToField (Maybe a) where

11297 toField Nothing = renderNull

11398 toField (Just a) = toField a

11499 {-# INLINE toField #-}

115100

116101instance (ToField a) => ToField (In [a]) where

117− toField (In []) = Plain $ byteString "(null)"

102+ toField (In []) = Plain $ fromByteString "(null)"

118103 toField (In xs) = Many $

119− Plain (char8 '(') :

120− (intersperse (Plain (char8 ',')) . map toField $ xs) ++

121− [Plain (char8 ')')]

104+ Plain (fromChar '(') :

105+ (intersperse (Plain (fromChar ',')) . map toField $ xs) ++

106+ [Plain (fromChar ')')]

122107

123108renderNull :: Action

124−renderNull = Plain (byteString "null")

109+renderNull = Plain (fromByteString "null")

125110

126111instance ToField Null where

127112 toField _ = renderNull

128113 {-# INLINE toField #-}

129114

130115instance ToField Default where

131− toField _ = Plain (byteString "default")

116+ toField _ = Plain (fromByteString "default")

132117 {-# INLINE toField #-}

133118

134119instance ToField Bool where

135− toField True = Plain (byteString "true")

136− toField False = Plain (byteString "false")

120+ toField True = Plain (fromByteString "true")

121+ toField False = Plain (fromByteString "false")

137122 {-# INLINE toField #-}

138123

139124instance ToField Int8 where

140− toField = Plain . int8Dec

125+ toField = Plain . integral

141126 {-# INLINE toField #-}

142127

143128instance ToField Int16 where

144− toField = Plain . int16Dec

129+ toField = Plain . integral

145130 {-# INLINE toField #-}

146131

147132instance ToField Int32 where

148− toField = Plain . int32Dec

133+ toField = Plain . integral

149134 {-# INLINE toField #-}

150135

151136instance ToField Int where

152− toField = Plain . intDec

137+ toField = Plain . integral

153138 {-# INLINE toField #-}

154139

155140instance ToField Int64 where

156− toField = Plain . int64Dec

141+ toField = Plain . integral

157142 {-# INLINE toField #-}

158143

159144instance ToField Integer where

160− toField = Plain . integerDec

145+ toField = Plain . integral

161146 {-# INLINE toField #-}

162147

163148instance ToField Word8 where

164− toField = Plain . word8Dec

149+ toField = Plain . integral

165150 {-# INLINE toField #-}

166151

167152instance ToField Word16 where

168− toField = Plain . word16Dec

153+ toField = Plain . integral

169154 {-# INLINE toField #-}

170155

171156instance ToField Word32 where

172− toField = Plain . word32Dec

157+ toField = Plain . integral

173158 {-# INLINE toField #-}

174159

175160instance ToField Word where

176− toField = Plain . wordDec

161+ toField = Plain . integral

177162 {-# INLINE toField #-}

178163

179164instance ToField Word64 where

180− toField = Plain . word64Dec

165+ toField = Plain . integral

181166 {-# INLINE toField #-}

182167

183168instance ToField PQ.Oid where

184− toField = Plain . \(PQ.Oid (CUInt x)) -> word32Dec x

169+ toField = Plain . integral . \(PQ.Oid x) -> x

185170 {-# INLINE toField #-}

186171

187172instance ToField Float where

188− toField v | isNaN v || isInfinite v = Plain (inQuotes (floatDec v))

189− | otherwise = Plain (floatDec v)

173+ toField v | isNaN v || isInfinite v = Plain (inQuotes (float v))

174+ | otherwise = Plain (float v)

190175 {-# INLINE toField #-}

191176

192177instance ToField Double where

193− toField v | isNaN v || isInfinite v = Plain (inQuotes (doubleDec v))

194− | otherwise = Plain (doubleDec v)

178+ toField v | isNaN v || isInfinite v = Plain (inQuotes (double v))

179+ | otherwise = Plain (double v)

195180 {-# INLINE toField #-}

196181

197182instance ToField Scientific where

@@ -213,7 +198,7 @@ instance ToField Identifier where

213198instance ToField QualifiedIdentifier where

214199 toField (QualifiedIdentifier (Just s) t) =

215200 Many [ EscapeIdentifier (ST.encodeUtf8 s)

216− , Plain (char8 '.')

201+ , Plain (fromChar '.')

217202 , EscapeIdentifier (ST.encodeUtf8 t)

218203 ]

219204 toField (QualifiedIdentifier Nothing t) =

@@ -233,23 +218,13 @@ instance ToField ST.Text where

233218 {-# INLINE toField #-}

234219

235220instance ToField [Char] where

236− toField = Escape . toByteString . stringUtf8

221+ toField = Escape . toByteString . Utf8.fromString

237222 {-# INLINE toField #-}

238223

239224instance ToField LT.Text where

240225 toField = toField . LT.toStrict

241226 {-# INLINE toField #-}

242227

243−-- | citext

244−instance ToField (CI ST.Text) where

245− toField = toField . CI.original

246− {-# INLINE toField #-}

247−

248−-- | citext

249−instance ToField (CI LT.Text) where

250− toField = toField . LT.toStrict . CI.original

251− {-# INLINE toField #-}

252−

253228instance ToField UTCTime where

254229 toField = Plain . inQuotes . utcTimeToBuilder

255230 {-# INLINE toField #-}

@@ -286,51 +261,41 @@ instance ToField Date where

286261 toField = Plain . inQuotes . dateToBuilder

287262 {-# INLINE toField #-}

288263

289−instance ToField NominalDiffTime where

290− toField = Plain . inQuotes . nominalDiffTimeToBuilder

291− {-# INLINE toField #-}

292−

293−instance ToField CalendarDiffTime where

294− toField = Plain . inQuotes . calendarDiffTimeToBuilder

295− {-# INLINE toField #-}

296−

297264instance (ToField a) => ToField (PGArray a) where

298− toField pgArray =

299− case fromPGArray pgArray of

300− [] -> Plain (byteString "'{}'")

301− xs -> Many $

302− Plain (byteString "ARRAY[") :

303− (intersperse (Plain (char8 ',')) . map toField $ xs) ++

304− [Plain (char8 ']')]

305− -- Because the ARRAY[...] input syntax is being used, it is possible

306− -- that the use of type-specific separator characters is unnecessary.

265+ toField xs = Many $

266+ Plain (fromByteString "ARRAY[") :

267+ (intersperse (Plain (fromChar ',')) . map toField $ fromPGArray xs) ++

268+ [Plain (fromChar ']')]

269+ -- Because the ARRAY[...] input syntax is being used, it is possible

270+ -- that the use of type-specific separator characters is unnecessary.

307271

308272instance (ToField a) => ToField (Vector a) where

309273 toField = toField . PGArray . V.toList

310274

311275instance ToField UUID where

312− toField = Plain . inQuotes . byteString . UUID.toASCIIBytes

276+ toField = Plain . inQuotes . fromByteString . UUID.toASCIIBytes

313277

314278instance ToField JSON.Value where

315279 toField = toField . JSON.encode

316280

317−-- | Convert a Haskell value to JSON using 'JSON.toEncoding'.

281+-- | Convert a Haskell value to a JSON 'JSON.Value' using

282+-- 'JSON.toJSON' and convert that to a field using 'toField'.

318283--

319284-- This can be used as the default implementation for the 'toField'

320285-- method for Haskell types that have a JSON representation in

321286-- PostgreSQL.

322287toJSONField :: JSON.ToJSON a => a -> Action

323−toJSONField = toField . JSON.encode

288+toJSONField = toField . JSON.toJSON

324289

325290-- | Surround a string with single-quote characters: \"@'@\"

326291--

327292-- This function /does not/ perform any other escaping.

328293inQuotes :: Builder -> Builder

329294inQuotes b = quote `mappend` b `mappend` quote

330− where quote = char8 '\''

295+ where quote = Utf8.fromChar '\''

331296

332297interleaveFoldr :: (a -> [b] -> [b]) -> b -> [b] -> [a] -> [b]

333−interleaveFoldr f b bs' as = foldr (\a bs -> b : f a bs) bs' as

298+interleaveFoldr f b bs as = foldr (\a bs -> b : f a bs) bs as

334299{-# INLINE interleaveFoldr #-}

335300

336301instance ToRow a => ToField (Values a) where

@@ -348,8 +313,8 @@ instance ToRow a => ToField (Values a) where

348313 funcname = "Database.PostgreSQL.Simple.toField :: Values a -> Action"

349314 norows = funcname ++ " either values or types must be non-empty"

350315 emptyrow = funcname ++ " each row must contain at least one column"

351− lit = Plain . byteString

352− litC = Plain . char8

316+ lit = Plain . fromByteString

317+ litC = Plain . fromChar

353318 values x = Many (lit "(VALUES ": x)

354319

355320 typedField :: (Action, QualifiedIdentifier) -> [Action] -> [Action]

@@ -377,8 +342,8 @@ instance ToRow a => ToField (Values a) where

377342

378343 typedRows :: ToRow a => [a] -> [QualifiedIdentifier] -> [Action] -> [Action]

379344 typedRows [] _ _ = error funcname

380− typedRows (val:vals) typs rest =

381− typedRow (toRow val) typs (multiRows vals rest)

345+ typedRows (val:vals) types rest =

346+ typedRow (toRow val) types (multiRows vals rest)

382347

383348 untypedRows :: ToRow a => [a] -> [Action] -> [Action]

384349 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 Data.ByteString.Builder(Builder)

4+import Blaze.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+1−128

@@ -1,4 +1,3 @@

1−{-# LANGUAGE DefaultSignatures, FlexibleInstances, FlexibleContexts #-}

21------------------------------------------------------------------------------

32-- |

43-- Module: Database.PostgreSQL.Simple.ToRow

@@ -23,33 +22,14 @@ module Database.PostgreSQL.Simple.ToRow

2322

2423import Database.PostgreSQL.Simple.ToField (Action(..), ToField(..))

2524import Database.PostgreSQL.Simple.Types (Only(..), (:.)(..))

26−import GHC.Generics

2725

2826-- | A collection type that can be turned into a list of rendering

2927-- 'Action's.

3028--

31−-- Instances should use the 'toField' method of the 'ToField' class

29+-- Instances should use the 'render' method of the 'Param' class

3230-- 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.

4931class ToRow a where

5032 toRow :: a -> [Action]

51− default toRow :: (Generic a, GToRow (Rep a)) => a -> [Action]

52− toRow = gtoRow . from

5333 -- ^ ToField a collection of values.

5434

5535instance ToRow () where

@@ -105,115 +85,8 @@ instance (ToField a, ToField b, ToField c, ToField d, ToField e, ToField f,

10585 [toField a, toField b, toField c, toField d, toField e, toField f,

10686 toField g, toField h, toField i, toField j]

10787

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−

19888instance (ToField a) => ToRow [a] where

19989 toRow = map toField

20090

20191instance (ToRow a, ToRow b) => ToRow (a :. b) where

20292 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+1−10

@@ -1,18 +1,9 @@

1−{-# LANGUAGE DefaultSignatures, FlexibleInstances, FlexibleContexts #-}

2−module Database.PostgreSQL.Simple.ToRow (

3− ToRow(..)

4− ) where

1+module Database.PostgreSQL.Simple.ToRow where

63import Database.PostgreSQL.Simple.Types

74import {-# SOURCE #-} Database.PostgreSQL.Simple.ToField

8−import GHC.Generics

106class ToRow a where

117 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]

178

189instance ToField a => ToRow (Only a)

src/Database/PostgreSQL/Simple/Transaction.hs+17−35

@@ -1,14 +1,4 @@

1−{-# LANGUAGE RecordWildCards, ScopedTypeVariables #-}

2−

3−------------------------------------------------------------------------------

4−-- |

5−-- Module: Database.PostgreSQL.Simple.Transaction

8−-- License: BSD3

9−-- Maintainer: Leon P Smith <leon@melding-monads.com>

10−--

11−------------------------------------------------------------------------------

1+{-# LANGUAGE RecordWildCards #-}

122

133module Database.PostgreSQL.Simple.Transaction

144 (

@@ -17,7 +7,6 @@ module Database.PostgreSQL.Simple.Transaction

177 , withTransactionLevel

188 , withTransactionMode

199 , withTransactionModeRetry

20− , withTransactionModeRetry'

2110 , withTransactionSerializable

2211 , TransactionMode(..)

2312 , IsolationLevel(..)

@@ -56,7 +45,7 @@ import Database.PostgreSQL.Simple.Compat (mask, (<>))

5645

5746-- | Of the four isolation levels defined by the SQL standard,

5847-- these are the three levels distinguished by PostgreSQL as of version 9.0.

59−-- See <https://www.postgresql.org/docs/9.5/static/transaction-iso.html>

48+-- See <http://www.postgresql.org/docs/9.1/static/transaction-iso.html>

6049-- for more information. Note that prior to PostgreSQL 9.0, 'RepeatableRead'

6150-- was equivalent to 'Serializable'.

6251

@@ -143,48 +132,41 @@ withTransactionMode :: TransactionMode -> Connection -> IO a -> IO a

143132withTransactionMode mode conn act =

144133 mask $ \restore -> do

145134 beginMode mode conn

146− r <- restore act `E.onException` rollback_ conn

135+ r <- restore act `E.onException` rollback conn

147136 commit conn

148137 return r

149138

150−-- | 'withTransactionModeRetry'' but with the exception type pinned to 'SqlError'.

151−withTransactionModeRetry :: TransactionMode -> (SqlError -> Bool) -> Connection -> IO a -> IO a

152−withTransactionModeRetry = withTransactionModeRetry'

153−

154139-- | Like 'withTransactionMode', but also takes a custom callback to

155−-- determine if a transaction should be retried if an exception occurs.

156−-- If the callback returns 'True', then the transaction will be retried.

157−-- If the callback returns 'False', or an exception other than an @e@

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'

158143-- occurs then the transaction will be rolled back and the exception rethrown.

159144--

160145-- This is used to implement 'withTransactionSerializable'.

161−withTransactionModeRetry' :: forall a e. E.Exception e => TransactionMode -> (e -> Bool) -> Connection -> IO a -> IO a

162−withTransactionModeRetry' mode shouldRetry conn act =

146+withTransactionModeRetry :: TransactionMode -> (SqlError -> Bool) -> Connection -> IO a -> IO a

147+withTransactionModeRetry mode shouldRetry conn act =

163148 mask $ \restore ->

164149 retryLoop $ E.try $ do

165− a <- restore act `E.onException` rollback_ conn

150+ a <- restore act

166151 commit conn

167152 return a

168153 where

169− retryLoop :: IO (Either e a) -> IO a

154+ retryLoop :: IO (Either E.SomeException a) -> IO a

170155 retryLoop act' = do

171156 beginMode mode conn

172157 r <- act'

173158 case r of

174− Left e ->

175− case shouldRetry e of

176− True -> retryLoop act'

177− False -> E.throwIO e

159+ Left e -> do

160+ rollback conn

161+ case fmap shouldRetry (E.fromException e) of

162+ Just True -> retryLoop act'

163+ _ -> E.throwIO e

178164 Right a ->

179165 return a

180166

181167-- | Rollback a transaction.

182168rollback :: Connection -> IO ()

183−rollback conn = execute_ conn "ROLLBACK" >> return ()

184−

185−-- | Rollback a transaction, ignoring any @IOErrors@

186−rollback_ :: Connection -> IO ()

187−rollback_ conn = rollback conn `E.catch` \(_ :: IOError) -> return ()

169+rollback conn = execute_ conn "ABORT" >> return ()

188170

189171-- | Commit a transaction.

190172commit :: Connection -> IO ()

@@ -221,7 +203,7 @@ beginMode mode conn = do

221203-- be used inside of a transaction, and provides a sort of

222204-- \"nested transaction\".

223205--

224−-- See <https://www.postgresql.org/docs/9.5/static/sql-savepoint.html>

206+-- See <http://www.postgresql.org/docs/current/static/sql-savepoint.html>

225207withSavepoint :: Connection -> IO a -> IO a

226208withSavepoint conn body =

227209 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+3−9

@@ -1,9 +1,4 @@

1−{-# LANGUAGE CPP #-}

2−#if __GLASGOW_HASKELL__ >= 800

3−{-# LANGUAGE TemplateHaskellQuotes #-}

4−#else

51{-# LANGUAGE TemplateHaskell #-}

6−#endif

83------------------------------------------------------------------------------

94-- |

@@ -27,12 +22,11 @@ import Database.PostgreSQL.Simple.TypeInfo.Static

2722import Database.PostgreSQL.Simple.Types (Oid(..))

2823import Language.Haskell.TH

2924

25+

3026-- | Returns an expression that has type @'Oid' -> 'Bool'@, true if the

3127-- oid is equal to any one of the 'typoid's of the given 'TypeInfo's.

3228mkCompats :: [TypeInfo] -> ExpQ

33−mkCompats tys = do

34− x <- newName "x"

35− lamE [conP 'Oid [varP x]] $ caseE (varE x) (map alt tys ++ [catchAll])

29+mkCompats tys = [| \(Oid x) -> $(caseE [| x |] (map alt tys ++ [catchAll])) |]

3630 where

3731 alt :: TypeInfo -> MatchQ

3832 alt ty = match (inlineTypoidP ty) (normalB [| True |]) []

@@ -44,7 +38,7 @@ mkCompats tys = do

4438-- Returns an expression of type 'Oid'. Useful because GHC tends

4539-- not to fold constants.

4640inlineTypoid :: TypeInfo -> ExpQ

47−inlineTypoid ty = conE 'Oid `appE` litE (getTypoid ty)

41+inlineTypoid ty = [| Oid $(litE (getTypoid ty)) |]

4842

4943inlineTypoidP :: TypeInfo -> PatQ

5044inlineTypoidP ty = litP (getTypoid ty)

src/Database/PostgreSQL/Simple/TypeInfo/Static.hs+73−1377

@@ -19,233 +19,52 @@ module Database.PostgreSQL.Simple.TypeInfo.Static

1919 ( TypeInfo(..)

2020 , staticTypeInfo

2121 , bool

22− , boolOid

2322 , bytea

24− , byteaOid

2523 , char

26− , charOid

2724 , name

28− , nameOid

2925 , int8

30− , int8Oid

3126 , int2

32− , int2Oid

3327 , int4

34− , int4Oid

3528 , regproc

36− , regprocOid

3729 , text

38− , textOid

3930 , oid

40− , oidOid

4131 , tid

42− , tidOid

4332 , xid

44− , xidOid

4533 , cid

46− , cidOid

4734 , xml

48− , xmlOid

4935 , point

50− , pointOid

5136 , lseg

52− , lsegOid

5337 , path

54− , pathOid

5538 , box

56− , boxOid

5739 , polygon

58− , polygonOid

5940 , line

60− , lineOid

6141 , cidr

62− , cidrOid

6342 , float4

64− , float4Oid

6543 , float8

66− , float8Oid

44+ , abstime

45+ , reltime

46+ , tinterval

6747 , unknown

68− , unknownOid

6948 , circle

70− , circleOid

7149 , money

72− , moneyOid

7350 , macaddr

74− , macaddrOid

7551 , inet

76− , inetOid

7752 , bpchar

78− , bpcharOid

7953 , varchar

80− , varcharOid

8154 , date

82− , dateOid

8355 , time

84− , timeOid

8556 , timestamp

86− , timestampOid

8757 , timestamptz

88− , timestamptzOid

8958 , interval

90− , intervalOid

9159 , timetz

92− , timetzOid

9360 , bit

94− , bitOid

9561 , varbit

96− , varbitOid

9762 , numeric

98− , numericOid

9963 , refcursor

100− , refcursorOid

10164 , record

102− , recordOid

10365 , 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

11766 , uuid

118− , uuidOid

11967 , json

120− , jsonOid

121− , jsonb

122− , jsonbOid

123− , int2vector

124− , int2vectorOid

125− , oidvector

126− , oidvectorOid

127− , array_xml

128− , array_xmlOid

129− , array_json

130− , array_jsonOid

131− , array_line

132− , array_lineOid

133− , array_cidr

134− , array_cidrOid

135− , array_circle

136− , array_circleOid

137− , array_money

138− , array_moneyOid

139− , array_bool

140− , array_boolOid

141− , array_bytea

142− , array_byteaOid

143− , array_char

144− , array_charOid

145− , array_name

146− , array_nameOid

147− , array_int2

148− , array_int2Oid

149− , array_int2vector

150− , array_int2vectorOid

151− , array_int4

152− , array_int4Oid

153− , array_regproc

154− , array_regprocOid

155− , array_text

156− , array_textOid

157− , array_tid

158− , array_tidOid

159− , array_xid

160− , array_xidOid

161− , array_cid

162− , array_cidOid

163− , array_oidvector

164− , array_oidvectorOid

165− , array_bpchar

166− , array_bpcharOid

167− , array_varchar

168− , array_varcharOid

169− , array_int8

170− , array_int8Oid

171− , array_point

172− , array_pointOid

173− , array_lseg

174− , array_lsegOid

175− , array_path

176− , array_pathOid

177− , array_box

178− , array_boxOid

179− , array_float4

180− , array_float4Oid

181− , array_float8

182− , array_float8Oid

183− , array_polygon

184− , array_polygonOid

185− , array_oid

186− , array_oidOid

187− , array_macaddr

188− , array_macaddrOid

189− , array_inet

190− , array_inetOid

191− , array_timestamp

192− , array_timestampOid

193− , array_date

194− , array_dateOid

195− , array_time

196− , array_timeOid

197− , array_timestamptz

198− , array_timestamptzOid

199− , array_interval

200− , array_intervalOid

201− , array_numeric

202− , array_numericOid

203− , array_timetz

204− , array_timetzOid

205− , array_bit

206− , array_bitOid

207− , array_varbit

208− , array_varbitOid

209− , array_refcursor

210− , array_refcursorOid

211− , array_regprocedure

212− , array_regprocedureOid

213− , array_regoper

214− , array_regoperOid

215− , array_regoperator

216− , array_regoperatorOid

217− , array_regclass

218− , array_regclassOid

219− , array_regtype

220− , array_regtypeOid

221− , array_uuid

222− , array_uuidOid

223− , array_jsonb

224− , array_jsonbOid

225− , int4range

226− , int4rangeOid

227− , _int4range

228− , _int4rangeOid

229− , numrange

230− , numrangeOid

231− , _numrange

232− , _numrangeOid

233− , tsrange

234− , tsrangeOid

235− , _tsrange

236− , _tsrangeOid

237− , tstzrange

238− , tstzrangeOid

239− , _tstzrange

240− , _tstzrangeOid

241− , daterange

242− , daterangeOid

243− , _daterange

244− , _daterangeOid

245− , int8range

246− , int8rangeOid

247− , _int8range

248− , _int8rangeOid

24968 ) where

25069

25170import Database.PostgreSQL.LibPQ (Oid(..))

@@ -276,6 +95,9 @@ staticTypeInfo (Oid x) = case x of

27695 650 -> Just cidr

27796 700 -> Just float4

27897 701 -> Just float8

98+ 702 -> Just abstime

99+ 703 -> Just reltime

100+ 704 -> Just tinterval

279101 705 -> Just unknown

280102 718 -> Just circle

281103 790 -> Just money

@@ -295,1508 +117,382 @@ staticTypeInfo (Oid x) = case x of

295117 1790 -> Just refcursor

296118 2249 -> Just record

297119 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

304120 2950 -> Just uuid

305121 114 -> Just json

306− 3802 -> Just jsonb

307− 22 -> Just int2vector

308− 30 -> Just oidvector

309− 143 -> Just array_xml

310− 199 -> Just array_json

311− 629 -> Just array_line

312− 651 -> Just array_cidr

313− 719 -> Just array_circle

314− 791 -> Just array_money

315− 1000 -> Just array_bool

316− 1001 -> Just array_bytea

317− 1002 -> Just array_char

318− 1003 -> Just array_name

319− 1005 -> Just array_int2

320− 1006 -> Just array_int2vector

321− 1007 -> Just array_int4

322− 1008 -> Just array_regproc

323− 1009 -> Just array_text

324− 1010 -> Just array_tid

325− 1011 -> Just array_xid

326− 1012 -> Just array_cid

327− 1013 -> Just array_oidvector

328− 1014 -> Just array_bpchar

329− 1015 -> Just array_varchar

330− 1016 -> Just array_int8

331− 1017 -> Just array_point

332− 1018 -> Just array_lseg

333− 1019 -> Just array_path

334− 1020 -> Just array_box

335− 1021 -> Just array_float4

336− 1022 -> Just array_float8

337− 1027 -> Just array_polygon

338− 1028 -> Just array_oid

339− 1040 -> Just array_macaddr

340− 1041 -> Just array_inet

341− 1115 -> Just array_timestamp

342− 1182 -> Just array_date

343− 1183 -> Just array_time

344− 1185 -> Just array_timestamptz

345− 1187 -> Just array_interval

346− 1231 -> Just array_numeric

347− 1270 -> Just array_timetz

348− 1561 -> Just array_bit

349− 1563 -> Just array_varbit

350− 2201 -> Just array_refcursor

351− 2207 -> Just array_regprocedure

352− 2208 -> Just array_regoper

353− 2209 -> Just array_regoperator

354− 2210 -> Just array_regclass

355− 2211 -> Just array_regtype

356− 2951 -> Just array_uuid

357− 3807 -> Just array_jsonb

358− 3904 -> Just int4range

359− 3905 -> Just _int4range

360− 3906 -> Just numrange

361− 3907 -> Just _numrange

362− 3908 -> Just tsrange

363− 3909 -> Just _tsrange

364− 3910 -> Just tstzrange

365− 3911 -> Just _tstzrange

366− 3912 -> Just daterange

367− 3913 -> Just _daterange

368− 3926 -> Just int8range

369− 3927 -> Just _int8range

370122 _ -> Nothing

371123

372124bool :: TypeInfo

373125bool = Basic {

374− typoid = boolOid,

126+ typoid = Oid 16,

375127 typcategory = 'B',

376128 typdelim = ',',

377129 typname = "bool"

378130 }

379131

380−boolOid :: Oid

381−boolOid = Oid 16

382−{-# INLINE boolOid #-}

383−

384132bytea :: TypeInfo

385133bytea = Basic {

386− typoid = byteaOid,

134+ typoid = Oid 17,

387135 typcategory = 'U',

388136 typdelim = ',',

389137 typname = "bytea"

390138 }

391139

392−byteaOid :: Oid

393−byteaOid = Oid 17

394−{-# INLINE byteaOid #-}

395−

396140char :: TypeInfo

397141char = Basic {

398− typoid = charOid,

142+ typoid = Oid 18,

399143 typcategory = 'S',

400144 typdelim = ',',

401145 typname = "char"

402146 }

403147

404−charOid :: Oid

405−charOid = Oid 18

406−{-# INLINE charOid #-}

407−

408148name :: TypeInfo

409149name = Basic {

410− typoid = nameOid,

150+ typoid = Oid 19,

411151 typcategory = 'S',

412152 typdelim = ',',

413153 typname = "name"

414154 }

415155

416−nameOid :: Oid

417−nameOid = Oid 19

418−{-# INLINE nameOid #-}

419−

420156int8 :: TypeInfo

421157int8 = Basic {

422− typoid = int8Oid,

158+ typoid = Oid 20,

423159 typcategory = 'N',

424160 typdelim = ',',

425161 typname = "int8"

426162 }

427163

428−int8Oid :: Oid

429−int8Oid = Oid 20

430−{-# INLINE int8Oid #-}

431−

432164int2 :: TypeInfo

433165int2 = Basic {

434− typoid = int2Oid,

166+ typoid = Oid 21,

435167 typcategory = 'N',

436168 typdelim = ',',

437169 typname = "int2"

438170 }

439171

440−int2Oid :: Oid

441−int2Oid = Oid 21

442−{-# INLINE int2Oid #-}

443−

444172int4 :: TypeInfo

445173int4 = Basic {

446− typoid = int4Oid,

174+ typoid = Oid 23,

447175 typcategory = 'N',

448176 typdelim = ',',

449177 typname = "int4"

450178 }

451179

452−int4Oid :: Oid

453−int4Oid = Oid 23

454−{-# INLINE int4Oid #-}

455−

456180regproc :: TypeInfo

457181regproc = Basic {

458− typoid = regprocOid,

182+ typoid = Oid 24,

459183 typcategory = 'N',

460184 typdelim = ',',

461185 typname = "regproc"

462186 }

463187

464−regprocOid :: Oid

465−regprocOid = Oid 24

466−{-# INLINE regprocOid #-}

467−

468188text :: TypeInfo

469189text = Basic {

470− typoid = textOid,

190+ typoid = Oid 25,

471191 typcategory = 'S',

472192 typdelim = ',',

473193 typname = "text"

474194 }

475195

476−textOid :: Oid

477−textOid = Oid 25

478−{-# INLINE textOid #-}

479−

480196oid :: TypeInfo

481197oid = Basic {

482− typoid = oidOid,

198+ typoid = Oid 26,

483199 typcategory = 'N',

484200 typdelim = ',',

485201 typname = "oid"

486202 }

487203

488−oidOid :: Oid

489−oidOid = Oid 26

490−{-# INLINE oidOid #-}

491−

492204tid :: TypeInfo

493205tid = Basic {

494− typoid = tidOid,

206+ typoid = Oid 27,

495207 typcategory = 'U',

496208 typdelim = ',',

497209 typname = "tid"

498210 }

499211

500−tidOid :: Oid

501−tidOid = Oid 27

502−{-# INLINE tidOid #-}

503−

504212xid :: TypeInfo

505213xid = Basic {

506− typoid = xidOid,

214+ typoid = Oid 28,

507215 typcategory = 'U',

508216 typdelim = ',',

509217 typname = "xid"

510218 }

511219

512−xidOid :: Oid

513−xidOid = Oid 28

514−{-# INLINE xidOid #-}

515−

516220cid :: TypeInfo

517221cid = Basic {

518− typoid = cidOid,

222+ typoid = Oid 29,

519223 typcategory = 'U',

520224 typdelim = ',',

521225 typname = "cid"

522226 }

523227

524−cidOid :: Oid

525−cidOid = Oid 29

526−{-# INLINE cidOid #-}

527−

528228xml :: TypeInfo

529229xml = Basic {

530− typoid = xmlOid,

230+ typoid = Oid 142,

531231 typcategory = 'U',

532232 typdelim = ',',

533233 typname = "xml"

534234 }

535235

536−xmlOid :: Oid

537−xmlOid = Oid 142

538−{-# INLINE xmlOid #-}

539−

540236point :: TypeInfo

541237point = Basic {

542− typoid = pointOid,

238+ typoid = Oid 600,

543239 typcategory = 'G',

544240 typdelim = ',',

545241 typname = "point"

546242 }

547243

548−pointOid :: Oid

549−pointOid = Oid 600

550−{-# INLINE pointOid #-}

551−

552244lseg :: TypeInfo

553245lseg = Basic {

554− typoid = lsegOid,

246+ typoid = Oid 601,

555247 typcategory = 'G',

556248 typdelim = ',',

557249 typname = "lseg"

558250 }

559251

560−lsegOid :: Oid

561−lsegOid = Oid 601

562−{-# INLINE lsegOid #-}

563−

564252path :: TypeInfo

565253path = Basic {

566− typoid = pathOid,

254+ typoid = Oid 602,

567255 typcategory = 'G',

568256 typdelim = ',',

569257 typname = "path"

570258 }

571259

572−pathOid :: Oid

573−pathOid = Oid 602

574−{-# INLINE pathOid #-}

575−

576260box :: TypeInfo

577261box = Basic {

578− typoid = boxOid,

262+ typoid = Oid 603,

579263 typcategory = 'G',

580264 typdelim = ';',

581265 typname = "box"

582266 }

583267

584−boxOid :: Oid

585−boxOid = Oid 603

586−{-# INLINE boxOid #-}

587−

588268polygon :: TypeInfo

589269polygon = Basic {

590− typoid = polygonOid,

270+ typoid = Oid 604,

591271 typcategory = 'G',

592272 typdelim = ',',

593273 typname = "polygon"

594274 }

595275

596−polygonOid :: Oid

597−polygonOid = Oid 604

598−{-# INLINE polygonOid #-}

599−

600276line :: TypeInfo

601277line = Basic {

602− typoid = lineOid,

278+ typoid = Oid 628,

603279 typcategory = 'G',

604280 typdelim = ',',

605281 typname = "line"

606282 }

607283

608−lineOid :: Oid

609−lineOid = Oid 628

610−{-# INLINE lineOid #-}

611−

612284cidr :: TypeInfo

613285cidr = Basic {

614− typoid = cidrOid,

286+ typoid = Oid 650,

615287 typcategory = 'I',

616288 typdelim = ',',

617289 typname = "cidr"

618290 }

619291

620−cidrOid :: Oid

621−cidrOid = Oid 650

622−{-# INLINE cidrOid #-}

623−

624292float4 :: TypeInfo

625293float4 = Basic {

626− typoid = float4Oid,

294+ typoid = Oid 700,

627295 typcategory = 'N',

628296 typdelim = ',',

629297 typname = "float4"

630298 }

631299

632−float4Oid :: Oid

633−float4Oid = Oid 700

634−{-# INLINE float4Oid #-}

635−

636300float8 :: TypeInfo

637301float8 = Basic {

638− typoid = float8Oid,

302+ typoid = Oid 701,

639303 typcategory = 'N',

640304 typdelim = ',',

641305 typname = "float8"

642306 }

643307

644−float8Oid :: Oid

645−float8Oid = Oid 701

646−{-# INLINE float8Oid #-}

308+abstime :: TypeInfo

309+abstime = Basic {

310+ typoid = Oid 702,

311+ typcategory = 'D',

312+ typdelim = ',',

313+ typname = "abstime"

314+ }

315+

316+reltime :: TypeInfo

317+reltime = Basic {

318+ typoid = Oid 703,

319+ typcategory = 'T',

320+ typdelim = ',',

321+ typname = "reltime"

322+ }

323+

324+tinterval :: TypeInfo

325+tinterval = Basic {

326+ typoid = Oid 704,

327+ typcategory = 'T',

328+ typdelim = ',',

329+ typname = "tinterval"

330+ }

647331

648332unknown :: TypeInfo

649333unknown = Basic {

650− typoid = unknownOid,

334+ typoid = Oid 705,

651335 typcategory = 'X',

652336 typdelim = ',',

653337 typname = "unknown"

654338 }

655339

656−unknownOid :: Oid

657−unknownOid = Oid 705

658−{-# INLINE unknownOid #-}

659−

660340circle :: TypeInfo

661341circle = Basic {

662− typoid = circleOid,

342+ typoid = Oid 718,

663343 typcategory = 'G',

664344 typdelim = ',',

665345 typname = "circle"

666346 }

667347

668−circleOid :: Oid

669−circleOid = Oid 718

670−{-# INLINE circleOid #-}

671−

672348money :: TypeInfo

673349money = Basic {

674− typoid = moneyOid,

350+ typoid = Oid 790,

675351 typcategory = 'N',

676352 typdelim = ',',

677353 typname = "money"

678354 }

679355

680−moneyOid :: Oid

681−moneyOid = Oid 790

682−{-# INLINE moneyOid #-}

683−

684356macaddr :: TypeInfo

685357macaddr = Basic {

686− typoid = macaddrOid,

358+ typoid = Oid 829,

687359 typcategory = 'U',

688360 typdelim = ',',

689361 typname = "macaddr"

690362 }

691363

692−macaddrOid :: Oid

693−macaddrOid = Oid 829

694−{-# INLINE macaddrOid #-}

695−

696364inet :: TypeInfo

697365inet = Basic {

698− typoid = inetOid,

366+ typoid = Oid 869,

699367 typcategory = 'I',

700368 typdelim = ',',

701369 typname = "inet"

702370 }

703371

704−inetOid :: Oid

705−inetOid = Oid 869

706−{-# INLINE inetOid #-}

707−

708372bpchar :: TypeInfo

709373bpchar = Basic {

710− typoid = bpcharOid,

374+ typoid = Oid 1042,

711375 typcategory = 'S',

712376 typdelim = ',',

713377 typname = "bpchar"

714378 }

715379

716−bpcharOid :: Oid

717−bpcharOid = Oid 1042

718−{-# INLINE bpcharOid #-}

719−

720380varchar :: TypeInfo

721381varchar = Basic {

722− typoid = varcharOid,

382+ typoid = Oid 1043,

723383 typcategory = 'S',

724384 typdelim = ',',

725385 typname = "varchar"

726386 }

727387

728−varcharOid :: Oid

729−varcharOid = Oid 1043

730−{-# INLINE varcharOid #-}

731−

732388date :: TypeInfo

733389date = Basic {

734− typoid = dateOid,

390+ typoid = Oid 1082,

735391 typcategory = 'D',

736392 typdelim = ',',

737393 typname = "date"

738394 }

739395

740−dateOid :: Oid

741−dateOid = Oid 1082

742−{-# INLINE dateOid #-}

743−

744396time :: TypeInfo

745397time = Basic {

746− typoid = timeOid,

398+ typoid = Oid 1083,

747399 typcategory = 'D',

748400 typdelim = ',',

749401 typname = "time"

750402 }

751403

752−timeOid :: Oid

753−timeOid = Oid 1083

754−{-# INLINE timeOid #-}

755−

756404timestamp :: TypeInfo

757405timestamp = Basic {

758− typoid = timestampOid,

406+ typoid = Oid 1114,

759407 typcategory = 'D',

760408 typdelim = ',',

761409 typname = "timestamp"

762410 }

763411

764−timestampOid :: Oid

765−timestampOid = Oid 1114

766−{-# INLINE timestampOid #-}

767−

768412timestamptz :: TypeInfo

769413timestamptz = Basic {

770− typoid = timestamptzOid,

414+ typoid = Oid 1184,

771415 typcategory = 'D',

772416 typdelim = ',',

773417 typname = "timestamptz"

774418 }

775419

776−timestamptzOid :: Oid

777−timestamptzOid = Oid 1184

778−{-# INLINE timestamptzOid #-}

779−

780420interval :: TypeInfo

781421interval = Basic {

782− typoid = intervalOid,

422+ typoid = Oid 1186,

783423 typcategory = 'T',

784424 typdelim = ',',

785425 typname = "interval"

786426 }

787427

788−intervalOid :: Oid

789−intervalOid = Oid 1186

790−{-# INLINE intervalOid #-}

791−

792428timetz :: TypeInfo

793429timetz = Basic {

794− typoid = timetzOid,

430+ typoid = Oid 1266,

795431 typcategory = 'D',

796432 typdelim = ',',

797433 typname = "timetz"

798434 }

799435

800−timetzOid :: Oid

801−timetzOid = Oid 1266

802−{-# INLINE timetzOid #-}

803−

804436bit :: TypeInfo

805437bit = Basic {

806− typoid = bitOid,

438+ typoid = Oid 1560,

807439 typcategory = 'V',

808440 typdelim = ',',

809441 typname = "bit"

810442 }

811443

812−bitOid :: Oid

813−bitOid = Oid 1560

814−{-# INLINE bitOid #-}

815−

816444varbit :: TypeInfo

817445varbit = Basic {

818− typoid = varbitOid,

446+ typoid = Oid 1562,

819447 typcategory = 'V',

820448 typdelim = ',',

821449 typname = "varbit"

822450 }

823451

824−varbitOid :: Oid

825−varbitOid = Oid 1562

826−{-# INLINE varbitOid #-}

827−

828452numeric :: TypeInfo

829453numeric = Basic {

830− typoid = numericOid,

454+ typoid = Oid 1700,

831455 typcategory = 'N',

832456 typdelim = ',',

833457 typname = "numeric"

834458 }

835459

836−numericOid :: Oid

837−numericOid = Oid 1700

838−{-# INLINE numericOid #-}

839−

840460refcursor :: TypeInfo

841461refcursor = Basic {

842− typoid = refcursorOid,

462+ typoid = Oid 1790,

843463 typcategory = 'U',

844464 typdelim = ',',

845465 typname = "refcursor"

846466 }

847467

848−refcursorOid :: Oid

849−refcursorOid = Oid 1790

850−{-# INLINE refcursorOid #-}

851−

852468record :: TypeInfo

853469record = Basic {

854− typoid = recordOid,

470+ typoid = Oid 2249,

855471 typcategory = 'P',

856472 typdelim = ',',

857473 typname = "record"

858474 }

859475

860−recordOid :: Oid

861−recordOid = Oid 2249

862−{-# INLINE recordOid #-}

863−

864476void :: TypeInfo

865477void = Basic {

866− typoid = voidOid,

478+ typoid = Oid 2278,

867479 typcategory = 'P',

868480 typdelim = ',',

869481 typname = "void"

870482 }

871483

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−

949484uuid :: TypeInfo

950485uuid = Basic {

951− typoid = uuidOid,

486+ typoid = Oid 2950,

952487 typcategory = 'U',

953488 typdelim = ',',

954489 typname = "uuid"

955490 }

956491

957−uuidOid :: Oid

958−uuidOid = Oid 2950

959−{-# INLINE uuidOid #-}

960−

961492json :: TypeInfo

962493json = Basic {

963− typoid = jsonOid,

494+ typoid = Oid 114,

964495 typcategory = 'U',

965496 typdelim = ',',

966497 typname = "json"

967498 }

968−

969−jsonOid :: Oid

970−jsonOid = Oid 114

971−{-# INLINE jsonOid #-}

972−

973−jsonb :: TypeInfo

974−jsonb = Basic {

975− typoid = jsonbOid,

976− typcategory = 'U',

977− typdelim = ',',

978− typname = "jsonb"

979− }

980−

981−jsonbOid :: Oid

982−jsonbOid = Oid 3802

983−{-# INLINE jsonbOid #-}

984−

985−int2vector :: TypeInfo

986−int2vector = Array {

987− typoid = int2vectorOid,

988− typcategory = 'A',

989− typdelim = ',',

990− typname = "int2vector",

991− typelem = int2

992− }

993−

994−int2vectorOid :: Oid

995−int2vectorOid = Oid 22

996−{-# INLINE int2vectorOid #-}

997−

998−oidvector :: TypeInfo

999−oidvector = Array {

1000− typoid = oidvectorOid,

1001− typcategory = 'A',

1002− typdelim = ',',

1003− typname = "oidvector",

1004− typelem = oid

1005− }

1006−

1007−oidvectorOid :: Oid

1008−oidvectorOid = Oid 30

1009−{-# INLINE oidvectorOid #-}

1010−

1011−array_xml :: TypeInfo

1012−array_xml = Array {

1013− typoid = array_xmlOid,

1014− typcategory = 'A',

1015− typdelim = ',',

1016− typname = "_xml",

1017− typelem = xml

1018− }

1019−

1020−array_xmlOid :: Oid

1021−array_xmlOid = Oid 143

1022−{-# INLINE array_xmlOid #-}

1023−

1024−array_json :: TypeInfo

1025−array_json = Array {

1026− typoid = array_jsonOid,

1027− typcategory = 'A',

1028− typdelim = ',',

1029− typname = "_json",

1030− typelem = json

1031− }

1032−

1033−array_jsonOid :: Oid

1034−array_jsonOid = Oid 199

1035−{-# INLINE array_jsonOid #-}

1036−

1037−array_line :: TypeInfo

1038−array_line = Array {

1039− typoid = array_lineOid,

1040− typcategory = 'A',

1041− typdelim = ',',

1042− typname = "_line",

1043− typelem = line

1044− }

1045−

1046−array_lineOid :: Oid

1047−array_lineOid = Oid 629

1048−{-# INLINE array_lineOid #-}

1049−

1050−array_cidr :: TypeInfo

1051−array_cidr = Array {

1052− typoid = array_cidrOid,

1053− typcategory = 'A',

1054− typdelim = ',',

1055− typname = "_cidr",

1056− typelem = cidr

1057− }

1058−

1059−array_cidrOid :: Oid

1060−array_cidrOid = Oid 651

1061−{-# INLINE array_cidrOid #-}

1062−

1063−array_circle :: TypeInfo

1064−array_circle = Array {

1065− typoid = array_circleOid,

1066− typcategory = 'A',

1067− typdelim = ',',

1068− typname = "_circle",

1069− typelem = circle

1070− }

1071−

1072−array_circleOid :: Oid

1073−array_circleOid = Oid 719

1074−{-# INLINE array_circleOid #-}

1075−

1076−array_money :: TypeInfo

1077−array_money = Array {

1078− typoid = array_moneyOid,

1079− typcategory = 'A',

1080− typdelim = ',',

1081− typname = "_money",

1082− typelem = money

1083− }

1084−

1085−array_moneyOid :: Oid

1086−array_moneyOid = Oid 791

1087−{-# INLINE array_moneyOid #-}

1088−

1089−array_bool :: TypeInfo

1090−array_bool = Array {

1091− typoid = array_boolOid,

1092− typcategory = 'A',

1093− typdelim = ',',

1094− typname = "_bool",

1095− typelem = bool

1096− }

1097−

1098−array_boolOid :: Oid

1099−array_boolOid = Oid 1000

1100−{-# INLINE array_boolOid #-}

1101−

1102−array_bytea :: TypeInfo

1103−array_bytea = Array {

1104− typoid = array_byteaOid,

1105− typcategory = 'A',

1106− typdelim = ',',

1107− typname = "_bytea",

1108− typelem = bytea

1109− }

1110−

1111−array_byteaOid :: Oid

1112−array_byteaOid = Oid 1001

1113−{-# INLINE array_byteaOid #-}

1114−

1115−array_char :: TypeInfo

1116−array_char = Array {

1117− typoid = array_charOid,

1118− typcategory = 'A',

1119− typdelim = ',',

1120− typname = "_char",

1121− typelem = char

1122− }

1123−

1124−array_charOid :: Oid

1125−array_charOid = Oid 1002

1126−{-# INLINE array_charOid #-}

1127−

1128−array_name :: TypeInfo

1129−array_name = Array {

1130− typoid = array_nameOid,

1131− typcategory = 'A',

1132− typdelim = ',',

1133− typname = "_name",

1134− typelem = name

1135− }

1136−

1137−array_nameOid :: Oid

1138−array_nameOid = Oid 1003

1139−{-# INLINE array_nameOid #-}

1140−

1141−array_int2 :: TypeInfo

1142−array_int2 = Array {

1143− typoid = array_int2Oid,

1144− typcategory = 'A',

1145− typdelim = ',',

1146− typname = "_int2",

1147− typelem = int2

1148− }

1149−

1150−array_int2Oid :: Oid

1151−array_int2Oid = Oid 1005

1152−{-# INLINE array_int2Oid #-}

1153−

1154−array_int2vector :: TypeInfo

1155−array_int2vector = Array {

1156− typoid = array_int2vectorOid,

1157− typcategory = 'A',

1158− typdelim = ',',

1159− typname = "_int2vector",

1160− typelem = int2vector

1161− }

1162−

1163−array_int2vectorOid :: Oid

1164−array_int2vectorOid = Oid 1006

1165−{-# INLINE array_int2vectorOid #-}

1166−

1167−array_int4 :: TypeInfo

1168−array_int4 = Array {

1169− typoid = array_int4Oid,

1170− typcategory = 'A',

1171− typdelim = ',',

1172− typname = "_int4",

1173− typelem = int4

1174− }

1175−

1176−array_int4Oid :: Oid

1177−array_int4Oid = Oid 1007

1178−{-# INLINE array_int4Oid #-}

1179−

1180−array_regproc :: TypeInfo

1181−array_regproc = Array {

1182− typoid = array_regprocOid,

1183− typcategory = 'A',

1184− typdelim = ',',

1185− typname = "_regproc",

1186− typelem = regproc

1187− }

1188−

1189−array_regprocOid :: Oid

1190−array_regprocOid = Oid 1008

1191−{-# INLINE array_regprocOid #-}

1192−

1193−array_text :: TypeInfo

1194−array_text = Array {

1195− typoid = array_textOid,

1196− typcategory = 'A',

1197− typdelim = ',',

1198− typname = "_text",

1199− typelem = text

1200− }

1201−

1202−array_textOid :: Oid

1203−array_textOid = Oid 1009

1204−{-# INLINE array_textOid #-}

1205−

1206−array_tid :: TypeInfo

1207−array_tid = Array {

1208− typoid = array_tidOid,

1209− typcategory = 'A',

1210− typdelim = ',',

1211− typname = "_tid",

1212− typelem = tid

1213− }

1214−

1215−array_tidOid :: Oid

1216−array_tidOid = Oid 1010

1217−{-# INLINE array_tidOid #-}

1218−

1219−array_xid :: TypeInfo

1220−array_xid = Array {

1221− typoid = array_xidOid,

1222− typcategory = 'A',

1223− typdelim = ',',

1224− typname = "_xid",

1225− typelem = xid

1226− }

1227−

1228−array_xidOid :: Oid

1229−array_xidOid = Oid 1011

1230−{-# INLINE array_xidOid #-}

1231−

1232−array_cid :: TypeInfo

1233−array_cid = Array {

1234− typoid = array_cidOid,

1235− typcategory = 'A',

1236− typdelim = ',',

1237− typname = "_cid",

1238− typelem = cid

1239− }

1240−

1241−array_cidOid :: Oid

1242−array_cidOid = Oid 1012

1243−{-# INLINE array_cidOid #-}

1244−

1245−array_oidvector :: TypeInfo

1246−array_oidvector = Array {

1247− typoid = array_oidvectorOid,

1248− typcategory = 'A',

1249− typdelim = ',',

1250− typname = "_oidvector",

1251− typelem = oidvector

1252− }

1253−

1254−array_oidvectorOid :: Oid

1255−array_oidvectorOid = Oid 1013

1256−{-# INLINE array_oidvectorOid #-}

1257−

1258−array_bpchar :: TypeInfo

1259−array_bpchar = Array {

1260− typoid = array_bpcharOid,

1261− typcategory = 'A',

1262− typdelim = ',',

1263− typname = "_bpchar",

1264− typelem = bpchar

1265− }

1266−

1267−array_bpcharOid :: Oid

1268−array_bpcharOid = Oid 1014

1269−{-# INLINE array_bpcharOid #-}

1270−

1271−array_varchar :: TypeInfo

1272−array_varchar = Array {

1273− typoid = array_varcharOid,

1274− typcategory = 'A',

1275− typdelim = ',',

1276− typname = "_varchar",

1277− typelem = varchar

1278− }

1279−

1280−array_varcharOid :: Oid

1281−array_varcharOid = Oid 1015

1282−{-# INLINE array_varcharOid #-}

1283−

1284−array_int8 :: TypeInfo

1285−array_int8 = Array {

1286− typoid = array_int8Oid,

1287− typcategory = 'A',

1288− typdelim = ',',

1289− typname = "_int8",

1290− typelem = int8

1291− }

1292−

1293−array_int8Oid :: Oid

1294−array_int8Oid = Oid 1016

1295−{-# INLINE array_int8Oid #-}

1296−

1297−array_point :: TypeInfo

1298−array_point = Array {

1299− typoid = array_pointOid,

1300− typcategory = 'A',

1301− typdelim = ',',

1302− typname = "_point",

1303− typelem = point

1304− }

1305−

1306−array_pointOid :: Oid

1307−array_pointOid = Oid 1017

1308−{-# INLINE array_pointOid #-}

1309−

1310−array_lseg :: TypeInfo

1311−array_lseg = Array {

1312− typoid = array_lsegOid,

1313− typcategory = 'A',

1314− typdelim = ',',

1315− typname = "_lseg",

1316− typelem = lseg

1317− }

1318−

1319−array_lsegOid :: Oid

1320−array_lsegOid = Oid 1018

1321−{-# INLINE array_lsegOid #-}

1322−

1323−array_path :: TypeInfo

1324−array_path = Array {

1325− typoid = array_pathOid,

1326− typcategory = 'A',

1327− typdelim = ',',

1328− typname = "_path",

1329− typelem = path

1330− }

1331−

1332−array_pathOid :: Oid

1333−array_pathOid = Oid 1019

1334−{-# INLINE array_pathOid #-}

1335−

1336−array_box :: TypeInfo

1337−array_box = Array {

1338− typoid = array_boxOid,

1339− typcategory = 'A',

1340− typdelim = ';',

1341− typname = "_box",

1342− typelem = box

1343− }

1344−

1345−array_boxOid :: Oid

1346−array_boxOid = Oid 1020

1347−{-# INLINE array_boxOid #-}

1348−

1349−array_float4 :: TypeInfo

1350−array_float4 = Array {

1351− typoid = array_float4Oid,

1352− typcategory = 'A',

1353− typdelim = ',',

1354− typname = "_float4",

1355− typelem = float4

1356− }

1357−

1358−array_float4Oid :: Oid

1359−array_float4Oid = Oid 1021

1360−{-# INLINE array_float4Oid #-}

1361−

1362−array_float8 :: TypeInfo

1363−array_float8 = Array {

1364− typoid = array_float8Oid,

1365− typcategory = 'A',

1366− typdelim = ',',

1367− typname = "_float8",

1368− typelem = float8

1369− }

1370−

1371−array_float8Oid :: Oid

1372−array_float8Oid = Oid 1022

1373−{-# INLINE array_float8Oid #-}

1374−

1375−array_polygon :: TypeInfo

1376−array_polygon = Array {

1377− typoid = array_polygonOid,

1378− typcategory = 'A',

1379− typdelim = ',',

1380− typname = "_polygon",

1381− typelem = polygon

1382− }

1383−

1384−array_polygonOid :: Oid

1385−array_polygonOid = Oid 1027

1386−{-# INLINE array_polygonOid #-}

1387−

1388−array_oid :: TypeInfo

1389−array_oid = Array {

1390− typoid = array_oidOid,

1391− typcategory = 'A',

1392− typdelim = ',',

1393− typname = "_oid",

1394− typelem = oid

1395− }

1396−

1397−array_oidOid :: Oid

1398−array_oidOid = Oid 1028

1399−{-# INLINE array_oidOid #-}

1400−

1401−array_macaddr :: TypeInfo

1402−array_macaddr = Array {

1403− typoid = array_macaddrOid,

1404− typcategory = 'A',

1405− typdelim = ',',

1406− typname = "_macaddr",

1407− typelem = macaddr

1408− }

1409−

1410−array_macaddrOid :: Oid

1411−array_macaddrOid = Oid 1040

1412−{-# INLINE array_macaddrOid #-}

1413−

1414−array_inet :: TypeInfo

1415−array_inet = Array {

1416− typoid = array_inetOid,

1417− typcategory = 'A',

1418− typdelim = ',',

1419− typname = "_inet",

1420− typelem = inet

1421− }

1422−

1423−array_inetOid :: Oid

1424−array_inetOid = Oid 1041

1425−{-# INLINE array_inetOid #-}

1426−

1427−array_timestamp :: TypeInfo

1428−array_timestamp = Array {

1429− typoid = array_timestampOid,

1430− typcategory = 'A',

1431− typdelim = ',',

1432− typname = "_timestamp",

1433− typelem = timestamp

1434− }

1435−

1436−array_timestampOid :: Oid

1437−array_timestampOid = Oid 1115

1438−{-# INLINE array_timestampOid #-}

1439−

1440−array_date :: TypeInfo

1441−array_date = Array {

1442− typoid = array_dateOid,

1443− typcategory = 'A',

1444− typdelim = ',',

1445− typname = "_date",

1446− typelem = date

1447− }

1448−

1449−array_dateOid :: Oid

1450−array_dateOid = Oid 1182

1451−{-# INLINE array_dateOid #-}

1452−

1453−array_time :: TypeInfo

1454−array_time = Array {

1455− typoid = array_timeOid,

1456− typcategory = 'A',

1457− typdelim = ',',

1458− typname = "_time",

1459− typelem = time

1460− }

1461−

1462−array_timeOid :: Oid

1463−array_timeOid = Oid 1183

1464−{-# INLINE array_timeOid #-}

1465−

1466−array_timestamptz :: TypeInfo

1467−array_timestamptz = Array {

1468− typoid = array_timestamptzOid,

1469− typcategory = 'A',

1470− typdelim = ',',

1471− typname = "_timestamptz",

1472− typelem = timestamptz

1473− }

1474−

1475−array_timestamptzOid :: Oid

1476−array_timestamptzOid = Oid 1185

1477−{-# INLINE array_timestamptzOid #-}

1478−

1479−array_interval :: TypeInfo

1480−array_interval = Array {

1481− typoid = array_intervalOid,

1482− typcategory = 'A',

1483− typdelim = ',',

1484− typname = "_interval",

1485− typelem = interval

1486− }

1487−

1488−array_intervalOid :: Oid

1489−array_intervalOid = Oid 1187

1490−{-# INLINE array_intervalOid #-}

1491−

1492−array_numeric :: TypeInfo

1493−array_numeric = Array {

1494− typoid = array_numericOid,

1495− typcategory = 'A',

1496− typdelim = ',',

1497− typname = "_numeric",

1498− typelem = numeric

1499− }

1500−

1501−array_numericOid :: Oid

1502−array_numericOid = Oid 1231

1503−{-# INLINE array_numericOid #-}

1504−

1505−array_timetz :: TypeInfo

1506−array_timetz = Array {

1507− typoid = array_timetzOid,

1508− typcategory = 'A',

1509− typdelim = ',',

1510− typname = "_timetz",

1511− typelem = timetz

1512− }

1513−

1514−array_timetzOid :: Oid

1515−array_timetzOid = Oid 1270

1516−{-# INLINE array_timetzOid #-}

1517−

1518−array_bit :: TypeInfo

1519−array_bit = Array {

1520− typoid = array_bitOid,

1521− typcategory = 'A',

1522− typdelim = ',',

1523− typname = "_bit",

1524− typelem = bit

1525− }

1526−

1527−array_bitOid :: Oid

1528−array_bitOid = Oid 1561

1529−{-# INLINE array_bitOid #-}

1530−

1531−array_varbit :: TypeInfo

1532−array_varbit = Array {

1533− typoid = array_varbitOid,

1534− typcategory = 'A',

1535− typdelim = ',',

1536− typname = "_varbit",

1537− typelem = varbit

1538− }

1539−

1540−array_varbitOid :: Oid

1541−array_varbitOid = Oid 1563

1542−{-# INLINE array_varbitOid #-}

1543−

1544−array_refcursor :: TypeInfo

1545−array_refcursor = Array {

1546− typoid = array_refcursorOid,

1547− typcategory = 'A',

1548− typdelim = ',',

1549− typname = "_refcursor",

1550− typelem = refcursor

1551− }

1552−

1553−array_refcursorOid :: Oid

1554−array_refcursorOid = Oid 2201

1555−{-# INLINE array_refcursorOid #-}

1556−

1557−array_regprocedure :: TypeInfo

1558−array_regprocedure = Array {

1559− typoid = array_regprocedureOid,

1560− typcategory = 'A',

1561− typdelim = ',',

1562− typname = "_regprocedure",

1563− typelem = regprocedure

1564− }

1565−

1566−array_regprocedureOid :: Oid

1567−array_regprocedureOid = Oid 2207

1568−{-# INLINE array_regprocedureOid #-}

1569−

1570−array_regoper :: TypeInfo

1571−array_regoper = Array {

1572− typoid = array_regoperOid,

1573− typcategory = 'A',

1574− typdelim = ',',

1575− typname = "_regoper",

1576− typelem = regoper

1577− }

1578−

1579−array_regoperOid :: Oid

1580−array_regoperOid = Oid 2208

1581−{-# INLINE array_regoperOid #-}

1582−

1583−array_regoperator :: TypeInfo

1584−array_regoperator = Array {

1585− typoid = array_regoperatorOid,

1586− typcategory = 'A',

1587− typdelim = ',',

1588− typname = "_regoperator",

1589− typelem = regoperator

1590− }

1591−

1592−array_regoperatorOid :: Oid

1593−array_regoperatorOid = Oid 2209

1594−{-# INLINE array_regoperatorOid #-}

1595−

1596−array_regclass :: TypeInfo

1597−array_regclass = Array {

1598− typoid = array_regclassOid,

1599− typcategory = 'A',

1600− typdelim = ',',

1601− typname = "_regclass",

1602− typelem = regclass

1603− }

1604−

1605−array_regclassOid :: Oid

1606−array_regclassOid = Oid 2210

1607−{-# INLINE array_regclassOid #-}

1608−

1609−array_regtype :: TypeInfo

1610−array_regtype = Array {

1611− typoid = array_regtypeOid,

1612− typcategory = 'A',

1613− typdelim = ',',

1614− typname = "_regtype",

1615− typelem = regtype

1616− }

1617−

1618−array_regtypeOid :: Oid

1619−array_regtypeOid = Oid 2211

1620−{-# INLINE array_regtypeOid #-}

1621−

1622−array_uuid :: TypeInfo

1623−array_uuid = Array {

1624− typoid = array_uuidOid,

1625− typcategory = 'A',

1626− typdelim = ',',

1627− typname = "_uuid",

1628− typelem = uuid

1629− }

1630−

1631−array_uuidOid :: Oid

1632−array_uuidOid = Oid 2951

1633−{-# INLINE array_uuidOid #-}

1634−

1635−array_jsonb :: TypeInfo

1636−array_jsonb = Array {

1637− typoid = array_jsonbOid,

1638− typcategory = 'A',

1639− typdelim = ',',

1640− typname = "_jsonb",

1641− typelem = jsonb

1642− }

1643−

1644−array_jsonbOid :: Oid

1645−array_jsonbOid = Oid 3807

1646−{-# INLINE array_jsonbOid #-}

1647−

1648−int4range :: TypeInfo

1649−int4range = Range {

1650− typoid = int4rangeOid,

1651− typcategory = 'R',

1652− typdelim = ',',

1653− typname = "int4range",

1654− rngsubtype = int4

1655− }

1656−

1657−int4rangeOid :: Oid

1658−int4rangeOid = Oid 3904

1659−{-# INLINE int4rangeOid #-}

1660−

1661−_int4range :: TypeInfo

1662−_int4range = Array {

1663− typoid = _int4rangeOid,

1664− typcategory = 'A',

1665− typdelim = ',',

1666− typname = "_int4range",

1667− typelem = int4range

1668− }

1669−

1670−_int4rangeOid :: Oid

1671−_int4rangeOid = Oid 3905

1672−{-# INLINE _int4rangeOid #-}

1673−

1674−numrange :: TypeInfo

1675−numrange = Range {

1676− typoid = numrangeOid,

1677− typcategory = 'R',

1678− typdelim = ',',

1679− typname = "numrange",

1680− rngsubtype = numeric

1681− }

1682−

1683−numrangeOid :: Oid

1684−numrangeOid = Oid 3906

1685−{-# INLINE numrangeOid #-}

1686−

1687−_numrange :: TypeInfo

1688−_numrange = Array {

1689− typoid = _numrangeOid,

1690− typcategory = 'A',

1691− typdelim = ',',

1692− typname = "_numrange",

1693− typelem = numrange

1694− }

1695−

1696−_numrangeOid :: Oid

1697−_numrangeOid = Oid 3907

1698−{-# INLINE _numrangeOid #-}

1699−

1700−tsrange :: TypeInfo

1701−tsrange = Range {

1702− typoid = tsrangeOid,

1703− typcategory = 'R',

1704− typdelim = ',',

1705− typname = "tsrange",

1706− rngsubtype = timestamp

1707− }

1708−

1709−tsrangeOid :: Oid

1710−tsrangeOid = Oid 3908

1711−{-# INLINE tsrangeOid #-}

1712−

1713−_tsrange :: TypeInfo

1714−_tsrange = Array {

1715− typoid = _tsrangeOid,

1716− typcategory = 'A',

1717− typdelim = ',',

1718− typname = "_tsrange",

1719− typelem = tsrange

1720− }

1721−

1722−_tsrangeOid :: Oid

1723−_tsrangeOid = Oid 3909

1724−{-# INLINE _tsrangeOid #-}

1725−

1726−tstzrange :: TypeInfo

1727−tstzrange = Range {

1728− typoid = tstzrangeOid,

1729− typcategory = 'R',

1730− typdelim = ',',

1731− typname = "tstzrange",

1732− rngsubtype = timestamptz

1733− }

1734−

1735−tstzrangeOid :: Oid

1736−tstzrangeOid = Oid 3910

1737−{-# INLINE tstzrangeOid #-}

1738−

1739−_tstzrange :: TypeInfo

1740−_tstzrange = Array {

1741− typoid = _tstzrangeOid,

1742− typcategory = 'A',

1743− typdelim = ',',

1744− typname = "_tstzrange",

1745− typelem = tstzrange

1746− }

1747−

1748−_tstzrangeOid :: Oid

1749−_tstzrangeOid = Oid 3911

1750−{-# INLINE _tstzrangeOid #-}

1751−

1752−daterange :: TypeInfo

1753−daterange = Range {

1754− typoid = daterangeOid,

1755− typcategory = 'R',

1756− typdelim = ',',

1757− typname = "daterange",

1758− rngsubtype = date

1759− }

1760−

1761−daterangeOid :: Oid

1762−daterangeOid = Oid 3912

1763−{-# INLINE daterangeOid #-}

1764−

1765−_daterange :: TypeInfo

1766−_daterange = Array {

1767− typoid = _daterangeOid,

1768− typcategory = 'A',

1769− typdelim = ',',

1770− typname = "_daterange",

1771− typelem = daterange

1772− }

1773−

1774−_daterangeOid :: Oid

1775−_daterangeOid = Oid 3913

1776−{-# INLINE _daterangeOid #-}

1777−

1778−int8range :: TypeInfo

1779−int8range = Range {

1780− typoid = int8rangeOid,

1781− typcategory = 'R',

1782− typdelim = ',',

1783− typname = "int8range",

1784− rngsubtype = int8

1785− }

1786−

1787−int8rangeOid :: Oid

1788−int8rangeOid = Oid 3926

1789−{-# INLINE int8rangeOid #-}

1790−

1791−_int8range :: TypeInfo

1792−_int8range = Array {

1793− typoid = _int8rangeOid,

1794− typcategory = 'A',

1795− typdelim = ',',

1796− typname = "_int8range",

1797− typelem = int8range

1798− }

1799−

1800−_int8rangeOid :: Oid

1801−_int8rangeOid = Oid 3927

1802−{-# INLINE _int8rangeOid #-}

src/Database/PostgreSQL/Simple/Types.hs+33−57

@@ -1,4 +1,4 @@

1−{-# LANGUAGE CPP, DeriveDataTypeable, DeriveFunctor, GeneralizedNewtypeDeriving #-}

1+{-# LANGUAGE DeriveDataTypeable, DeriveFunctor, GeneralizedNewtypeDeriving #-}

33------------------------------------------------------------------------------

44-- |

@@ -30,26 +30,27 @@ module Database.PostgreSQL.Simple.Types

3030 , Values(..)

3131 ) where

3232

33+import Blaze.ByteString.Builder (toByteString)

3334import Control.Arrow (first)

3435import Data.ByteString (ByteString)

3536import Data.Hashable (Hashable(hashWithSalt))

36−import Data.Foldable (toList)

3737import Data.Monoid (Monoid(..))

38−import Data.Semigroup

3938import Data.String (IsString(..))

4039import Data.Typeable (Typeable)

41−import Data.ByteString.Builder ( stringUtf8 )

40+import qualified Blaze.ByteString.Builder.Char.Utf8 as Utf8

4241import qualified Data.ByteString as B

4342import Data.Text (Text)

4443import qualified Data.Text as T

45−import Data.Tuple.Only (Only(..))

4644import Database.PostgreSQL.LibPQ (Oid(..))

47−import Database.PostgreSQL.Simple.Compat (toByteString)

4845

4946-- | A placeholder for the SQL @NULL@ value.

5047data Null = Null

5148 deriving (Read, Show, Typeable)

5249

50+instance Eq Null where

51+ _ == _ = False

52+ _ /= _ = False

53+

5354-- | A placeholder for the PostgreSQL @DEFAULT@ value.

5455data Default = Default

5556 deriving (Read, Show, Typeable)

@@ -84,61 +85,38 @@ instance Read Query where

8485 readsPrec i = fmap (first Query) . readsPrec i

8586

8687instance IsString Query where

87− fromString = Query . toByteString . stringUtf8

88−

89−instance Semigroup Query where

90− Query a <> Query b = Query (B.append a b)

91− {-# INLINE (<>) #-}

92− sconcat xs = Query (B.concat $ map fromQuery $ toList xs)

88+ fromString = Query . toByteString . Utf8.fromString

9389

9490instance Monoid Query where

9591 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))

9695

97−-- | Wrap a list of values for use in an @IN@ clause. Replaces a

98−-- single \"@?@\" character with a parenthesized list of rendered

99−-- values.

100−--

101−-- Example:

102−--

103−-- > query c "select * from whatever where id in ?" (Only (In [3,4,5]))

96+-- | A single-value \"collection\".

10497--

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.

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.

110100--

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:

101+-- Parameter example:

114102--

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.

103+-- @query c \"select x from scores where x > ?\" ('Only' (42::Int))@

120104--

121−-- > query c "select * from whatever where id not in ?"

122−-- > (Only (Values ["int4"] [] :: Values (Only Int)))

105+-- Result example:

123106--

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)

112+

113+-- | Wrap a list of values for use in an @IN@ clause. Replaces a

114+-- single \"@?@\" character with a parenthesized list of rendered

115+-- values.

124116--

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]))

117+-- Example:

134118--

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−

119+-- > query c "select * from whatever where id in ?" (Only (In [3,4,5]))

142120newtype In a = In a

143121 deriving (Eq, Ord, Read, Show, Typeable, Functor)

144122

@@ -201,9 +179,8 @@ infixr 3 :.

201179newtype Savepoint = Savepoint Query

202180 deriving (Eq, Ord, Show, Read, Typeable)

203181

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

182+-- | Represents a @VALUES@ table literal, usable as an alternative

183+-- to @executeMany@ and @returning@. The main advantage is that

207184-- you can parametrize more than just a single @VALUES@ expression.

208185-- For example, here's a query to insert a thing into one table

209186-- and some attributes of that thing into another, returning the

@@ -216,7 +193,7 @@ newtype Savepoint = Savepoint Query

216193-- > ), new_attributes AS (

217194-- > INSERT INTO thing_attributes

218195-- > SELECT new_thing.id, attrs.*

219−-- > FROM new_thing JOIN ? attrs ON TRUE

196+-- > FROM new_thing JOIN ? attrs

220197-- > ) SELECT * FROM new_thing

221198-- > |] ("foo", Values [ "int4", "text" ]

222199-- > [ ( 1 , "hello" )

@@ -242,8 +219,7 @@ newtype Savepoint = Savepoint Query

242219-- is turned into a properly quoted identifier, the type name is case

243220-- sensitive and must be as it appears in the @pg_type@ table. Thus,

244221-- you must write @timestamptz@ instead of @timestamp with time zone@,

245−-- @int4@ instead of @integer@ or @serial@, @_int8@ instead of @bigint[]@,

246−-- etcetera.

222+-- @int4@ instead of @integer@, @_int8@ instead of @bigint[]@, etcetera.

247223--

248224-- You may omit the type names, however, if you do so the list

249225-- of values must be non-empty, and postgresql must be able to infer

@@ -252,7 +228,7 @@ newtype Savepoint = Savepoint Query

252228-- without issuing the query. In the second case, the postgres server

253229-- will return an error which will be turned into a @SqlError@ exception.

254230--

255−-- See <https://www.postgresql.org/docs/9.5/static/sql-values.html> for

231+-- See <http://www.postgresql.org/docs/9.3/static/sql-values.html> for

256232-- more information.

257233data Values a = Values [QualifiedIdentifier] [a]

258234 deriving (Eq, Ord, Show, Read, Typeable)

src/Database/PostgreSQL/Simple/Vector.hsdeleted−45

@@ -1,45 +0,0 @@

1−-- | 'query' variants returning 'V.Vector'.

2−module Database.PostgreSQL.Simple.Vector where

3−

4−import Database.PostgreSQL.Simple (Connection, formatQuery, formatMany)

5−import Database.PostgreSQL.Simple.FromRow (FromRow(..))

6−import Database.PostgreSQL.Simple.ToRow (ToRow(..))

7−import Database.PostgreSQL.Simple.Internal (RowParser, exec)

8−import Database.PostgreSQL.Simple.Internal.PQResultUtils

9−import Database.PostgreSQL.Simple.Types ( Query (..) )

10−

11−import qualified Data.Vector as V

12−

13−-- | Perform a @SELECT@ or other SQL query that is expected to return

14−-- results. All results are retrieved and converted before this

15−-- function returns.

16−query :: (ToRow q, FromRow r) => Connection -> Query -> q -> IO (V.Vector r)

17−query = queryWith fromRow

18−

19−-- | A version of 'query' that does not perform query substitution.

20−query_ :: (FromRow r) => Connection -> Query -> IO (V.Vector r)

21−query_ = queryWith_ fromRow

22−

23−-- | A version of 'query' taking parser as argument

24−queryWith :: ToRow q => RowParser r -> Connection -> Query -> q -> IO (V.Vector r)

25−queryWith parser conn template qs = do

26− result <- exec conn =<< formatQuery conn template qs

27− finishQueryWithV parser conn template result

28−

29−-- | A version of 'query_' taking parser as argument

30−queryWith_ :: RowParser r -> Connection -> Query -> IO (V.Vector r)

31−queryWith_ parser conn q@(Query que) = do

32− result <- exec conn que

33− finishQueryWithV parser conn q result

34−

35−-- | Execute @INSERT ... RETURNING@, @UPDATE ... RETURNING@, or other SQL

36−-- query that accepts multi-row input and is expected to return results.

37−returning :: (ToRow q, FromRow r) => Connection -> Query -> [q] -> IO (V.Vector r)

38−returning = returningWith fromRow

39−

40−-- | A version of 'returning' taking parser as argument

41−returningWith :: (ToRow q) => RowParser r -> Connection -> Query -> [q] -> IO (V.Vector r)

42−returningWith _ _ _ [] = return V.empty

43−returningWith parser conn q qs = do

44− result <- exec conn =<< formatMany conn q qs

45− finishQueryWithV parser conn q result

src/Database/PostgreSQL/Simple/Vector/Unboxed.hsdeleted−44

@@ -1,44 +0,0 @@

1−module Database.PostgreSQL.Simple.Vector.Unboxed where

2−

3−import Database.PostgreSQL.Simple (Connection, formatQuery, formatMany)

4−import Database.PostgreSQL.Simple.FromRow (FromRow(..))

5−import Database.PostgreSQL.Simple.ToRow (ToRow(..))

6−import Database.PostgreSQL.Simple.Internal (RowParser, exec)

7−import Database.PostgreSQL.Simple.Internal.PQResultUtils

8−import Database.PostgreSQL.Simple.Types ( Query (..) )

9−

10−import qualified Data.Vector.Unboxed as VU

11−

12−-- | Perform a @SELECT@ or other SQL query that is expected to return

13−-- results. All results are retrieved and converted before this

14−-- function returns.

15−query :: (ToRow q, FromRow r, VU.Unbox r) => Connection -> Query -> q -> IO (VU.Vector r)

16−query = queryWith fromRow

17−

18−-- | A version of 'query' that does not perform query substitution.

19−query_ :: (FromRow r, VU.Unbox r) => Connection -> Query -> IO (VU.Vector r)

20−query_ = queryWith_ fromRow

21−

22−-- | A version of 'query' taking parser as argument

23−queryWith :: (ToRow q, VU.Unbox r) => RowParser r -> Connection -> Query -> q -> IO (VU.Vector r)

24−queryWith parser conn template qs = do

25− result <- exec conn =<< formatQuery conn template qs

26− finishQueryWithVU parser conn template result

27−

28−-- | A version of 'query_' taking parser as argument

29−queryWith_ :: VU.Unbox r => RowParser r -> Connection -> Query -> IO (VU.Vector r)

30−queryWith_ parser conn q@(Query que) = do

31− result <- exec conn que

32− finishQueryWithVU parser conn q result

33−

34−-- | Execute @INSERT ... RETURNING@, @UPDATE ... RETURNING@, or other SQL

35−-- query that accepts multi-row input and is expected to return results.

36−returning :: (ToRow q, FromRow r, VU.Unbox r) => Connection -> Query -> [q] -> IO (VU.Vector r)

37−returning = returningWith fromRow

38−

39−-- | A version of 'returning' taking parser as argument

40−returningWith :: (ToRow q, VU.Unbox r) => RowParser r -> Connection -> Query -> [q] -> IO (VU.Vector r)

41−returningWith _ _ _ [] = return VU.empty

42−returningWith parser conn q qs = do

43− result <- exec conn =<< formatMany conn q qs

44− finishQueryWithVU parser conn q result

test/Common.hs+2−2

@@ -1,6 +1,6 @@

11module Common (

22 module Database.PostgreSQL.Simple,

3− module Test.Tasty.HUnit,

3+ module Test.HUnit,

44 TestEnv(..),

55 md5,

66) where

@@ -8,7 +8,7 @@ module Common (

88import Data.ByteString (ByteString)

99import Data.Text (Text)

1010import Database.PostgreSQL.Simple

11−import Test.Tasty.HUnit

11+import Test.HUnit

1212

1313import qualified Crypto.Hash.MD5 as MD5

1414import qualified Data.ByteString.Base16 as Base16

test/Exception.hsdeleted−70

@@ -1,70 +0,0 @@

1−{-# LANGUAGE CPP #-}

2−{-# LANGUAGE OverloadedStrings #-}

3−{-# LANGUAGE ScopedTypeVariables #-}

4−

5−module Exception (testExceptions) where

6−

7−import Database.PostgreSQL.Simple

8−import Test.Tasty.HUnit (Assertion, assertBool)

9−import Common (TestEnv)

10−import Control.Exception (Exception (..), SomeException)

11−import Data.Maybe (isJust)

12−import Data.Either (isLeft)

13−import Control.Exception (throwIO, try)

14−

15−testExceptions :: TestEnv -> Assertion

16−testExceptions _ = do

17− let sqlError = SqlError

18− { sqlState = ""

19− , sqlExecStatus = FatalError

20− , sqlErrorMsg = ""

21− , sqlErrorDetail = ""

22− , sqlErrorHint = ""

23− }

24− let sqlEx :: SomeException = toException sqlError

25− assertBool "SqlError is SomePostgreSqlException" $ isJust (fromException sqlEx :: Maybe SomePostgreSqlException)

26− assertBool "SqlError is SqlError" $ isJust (fromException sqlEx :: Maybe SqlError)

27− eSqlError :: Either SqlError () <- try $ throwIO sqlEx

28− assertBool "Can catch SqlError" $ isLeft eSqlError

29− eSqlPostgreSqlEx :: Either SomePostgreSqlException () <- try $ throwIO sqlEx

30− assertBool "Can catch SomePostgreSqlException from SqlError" $ isLeft eSqlPostgreSqlEx

31−

32− let formatError = FormatError

33− { fmtMessage = ""

34− , fmtQuery = ""

35− , fmtParams = []

36− }

37− let formatEx :: SomeException = toException formatError

38− assertBool "FormatError is SomePostgreSqlException" $ isJust (fromException formatEx :: Maybe SomePostgreSqlException)

39− assertBool "FormatError is FormatError" $ isJust (fromException formatEx :: Maybe FormatError)

40− eFormatError :: Either FormatError () <- try $ throwIO formatEx

41− assertBool "Can catch FormatError" $ isLeft eFormatError

42− eFormatPostreSqlEx :: Either SomePostgreSqlException () <- try $ throwIO formatEx

43− assertBool "Can catch SomePostgreSqlException from FormatError" $ isLeft eFormatPostreSqlEx

44−

45− let queryError = QueryError

46− { qeMessage = ""

47− , qeQuery = ""

48− }

49− let queryEx :: SomeException = toException queryError

50− assertBool "QueryError is SomePostgreSqlException" $ isJust (fromException queryEx :: Maybe SomePostgreSqlException)

51− assertBool "QueryError is QueryError" $ isJust (fromException queryEx :: Maybe QueryError)

52− eQueryError :: Either QueryError () <- try $ throwIO queryEx

53− assertBool "Can catch QueryError" $ isLeft eQueryError

54− eQueryPostgreSqlEx :: Either SomePostgreSqlException () <- try $ throwIO queryEx

55− assertBool "Can catch SomePostgreSqlException from QueryError" $ isLeft eQueryPostgreSqlEx

56−

57− let resultError = Incompatible

58− { errSQLType = ""

59− , errSQLTableOid = Nothing

60− , errSQLField = ""

61− , errHaskellType = ""

62− , errMessage = ""

63− }

64− let resultEx :: SomeException = toException resultError

65− assertBool "ResultError is SomePostgreSqlException" $ isJust (fromException resultEx :: Maybe SomePostgreSqlException)

66− assertBool "ResultError is ResultError" $ isJust (fromException resultEx :: Maybe ResultError)

67− eResultEx :: Either ResultError () <- try $ throwIO resultEx

68− assertBool "Can catch ResultError" $ isLeft eResultEx

69− eResultPostgreSqlEx :: Either SomePostgreSqlException () <- try $ throwIO resultEx

70− assertBool "Can catch SomePostgreSqlException from ResultError" $ isLeft eResultPostgreSqlEx

test/Inspection.hsdeleted−79

@@ -1,79 +0,0 @@

1−{-# LANGUAGE CPP #-}

2−{-# LANGUAGE TemplateHaskell #-}

3−{-# OPTIONS_GHC -dsuppress-idinfo -dsuppress-coercions -dsuppress-type-applications -dsuppress-module-prefixes -dsuppress-type-signatures #-}

4−-- {-# OPTIONS_GHC -dsuppress-uniques #-}

5−{-# OPTIONS_GHC -fplugin=Test.Inspection.Plugin #-}

6−module Main where

7−

8−import Test.Inspection

9−import Test.Tasty

10−import Test.Tasty.HUnit

11−

12−import qualified Database.PostgreSQL.LibPQ as PQ

13−import Database.PostgreSQL.Simple.FromField

14−import Database.PostgreSQL.Simple.TypeInfo as TI

15−import Database.PostgreSQL.Simple.TypeInfo.Macro

16−import qualified Database.PostgreSQL.Simple.TypeInfo.Static as TI

17−

18−-------------------------------------------------------------------------------

19−-- Inspection tests

20−-------------------------------------------------------------------------------

21−

22−-- # doesn't work :(

23−#define TH_MKCOMPATS3(a,b,c) $(mkCompats [TI.a,TI.b,TI.c])

24−#define IN_MKCOMPATS3(a,b,c) (eq TI.a \/ eq TI.b \/ eq TI.c)

25−

26−#define TH_INLINETYPOID(n) eq $(inlineTypoid TI.n)

27−#define IN_INLINETYPOID(n) eq TI.n

28−

29−-- eta-expansion is required

30−lhs01, rhs01 :: PQ.Oid -> Bool

31−lhs01 = TH_MKCOMPATS3(name,text,char)

32−rhs01 = IN_MKCOMPATS3(nameOid,textOid,charOid)

33−

34−lhs02, rhs02 :: PQ.Oid -> Bool

35−lhs02 = TH_INLINETYPOID(name)

36−rhs02 = IN_INLINETYPOID(nameOid)

37−

38−eq :: PQ.Oid -> PQ.Oid -> Bool

39−eq = (==)

40−{-# INLINE eq #-}

41−

42−infixr 2 \/

43−(\/) :: (PQ.Oid -> Bool)

44− -> (PQ.Oid -> Bool)

45− -> (PQ.Oid -> Bool)

46−f \/ g = \x -> f x || g x

47−{-# INLINE (\/) #-}

48−

49−inspectionTests :: TestTree

50−inspectionTests = testGroup "inspection"

51− [ testCase "mkCompats" $

52− assertSuccess $(inspectTest $ 'lhs01 === 'rhs01)

53−

54− -- byteaOid isn't inlined?

55− , testCase "inlineTypoid" $

56−#if __GLASGOW_HASKELL__ >= 808

57− assertSuccess

58−#else

59− assertFailure'

60−#endif

61− $(inspectTest $ 'lhs02 ==- 'rhs02)

62− ]

63−

64−assertSuccess :: Result -> IO ()

65−assertSuccess (Success _) = return ()

66−assertSuccess (Failure err) = assertFailure err

67−

68−assertFailure' :: Result -> IO ()

69−assertFailure' (Success err) = assertFailure err

70−assertFailure' (Failure _) = return ()

71−

72−-------------------------------------------------------------------------------

73−-- Main

74−-------------------------------------------------------------------------------

75−

76−main :: IO ()

77−main = defaultMain $ testGroup "tests"

78− [ inspectionTests

79− ]

test/Interval.hsdeleted−176

@@ -1,176 +0,0 @@

1−{-# LANGUAGE QuasiQuotes #-}

2−

3−{-

4−

5−Testing strategies:

6−

7−fromString . toString == id ** Todo?

8−

9−toString . fromString == almost id ** Todo?

10−

11−postgresql -> haskell -> postgresql * Done

12−

13−haskell -> postgresql -> haskell ** Todo?

14−

15−But still, what we really want to establish is that the two values

16−correspond; for example, a conversion that consistently added hour

17−when printed to a string and subtracted an hour when parsed from string

18−would still pass these tests.

19−

20−

21−Right now, we are checking that 1400+ timestamps in the range of 1860 to

22−2060 round trip from postgresql to haskell and back in 5 different timezones.

23−In addition to UTC, the four timezones were selected so that 2 have a positive

24−offset, and 2 have a negative offset, and that 2 have an offset of a

25−whole number of hours, while the other two do not.

26−

27−It may be worth adding a few more timezones to ensure better test coverage.

28−

29−We are checking a handful of selected timestamps to ensure we hit

30−various corner-cases in the code, in addition to 1400 timestamps randomly

31−generated with granularity of seconds down to microseconds in powers of ten.

32−

33−-}

34−

35−module Interval (testInterval) where

36−

37−import Common

38−import Control.Monad(forM_, replicateM_)

39−import Data.Time.Compat

40−import Data.Time.LocalTime.Compat (CalendarDiffTime(..))

41−import Data.ByteString(ByteString)

42−import Database.PostgreSQL.Simple.SqlQQ

43−

44−data IntervalTestCase = IntervalTestCase

45− { label :: String

46− , inputMonths :: Integer

47− , inputSeconds :: NominalDiffTime

48− , asText :: String

49− }

50− deriving (Eq, Show)

51−

52−testInterval :: TestEnv -> Assertion

53−testInterval env@TestEnv{..} = do

54−

55− initializeTable env

56−

57− let milliseconds = 0.001

58− seconds = 1

59− minutes = 60 * seconds

60− hours = 60 * minutes

61− days = 24 * hours

62− weeks = 7 * days

63− months = 1

64− years = 12 * months

65−

66− mapM (checkRoundTrip env)

67− [ IntervalTestCase

68− { label = "zero"

69− , inputMonths = 0

70− , inputSeconds = 0

71− , asText = "PT0"

72− }

73− , IntervalTestCase

74− { label = "1 year"

75− , inputMonths = 1 * years

76− , inputSeconds = 0

77− , asText = "P1Y"

78− }

79− , IntervalTestCase

80− { label = "2 months"

81− , inputMonths = 2 * months

82− , inputSeconds = 0

83− , asText = "P2M"

84− }

85− , IntervalTestCase

86− { label = "3 weeks"

87− , inputMonths = 0

88− , inputSeconds = 3 * weeks

89− , asText = "P3W"

90− }

91− , IntervalTestCase

92− { label = "4 days"

93− , inputMonths = 0

94− , inputSeconds = 4 * days

95− , asText = "P4D"

96− }

97− , IntervalTestCase

98− { label = "5 hours"

99− , inputMonths = 0

100− , inputSeconds = 5 * hours

101− , asText = "PT5H"

102− }

103− , IntervalTestCase

104− { label = "6 minutes"

105− , inputMonths = 0

106− , inputSeconds = 6 * minutes

107− , asText = "PT6M"

108− }

109− , IntervalTestCase

110− { label = "7 seconds"

111− , inputMonths = 0

112− , inputSeconds = 7 * seconds

113− , asText = "PT7S"

114− }

115− , IntervalTestCase

116− { label = "8 milliseconds"

117− , inputMonths = 0

118− , inputSeconds = 8 * milliseconds

119− , asText = "PT0.008S"

120− }

121− , IntervalTestCase

122− { label = "combination of intervals (day-size or bigger)"

123− , inputMonths = 2 * years + 4 * months

124− , inputSeconds = 3 * weeks + 5 * days

125− , asText = "P2Y4M3W5D"

126− }

127− , IntervalTestCase

128− { label = "combination of intervals (smaller than day-size)"

129− , inputMonths = 0

130− , inputSeconds = 18 * hours + 56 * minutes + 23 * seconds + 563 * milliseconds

131− , asText = "PT18H56M23.563S"

132− }

133− , IntervalTestCase

134− { label = "full combination of intervals"

135− , inputMonths = 2 * years + 4 * months

136− , inputSeconds = 3 * weeks + 5 * days + 18 * hours + 56 * minutes + 23 * seconds + 563 * milliseconds

137− , asText = "P2Y4M3W5DT18H56M23.563S"

138− }

139− ]

140−

141− return ()

142−

143−initializeTable :: TestEnv -> IO ()

144−initializeTable TestEnv{..} = withTransaction conn $ do

145− execute_ conn

146− [sql| CREATE TEMPORARY TABLE testinterval

147− ( id serial, sample interval, PRIMARY KEY(id) ) |]

148−

149− return ()

150−

151−checkRoundTrip :: TestEnv -> IntervalTestCase -> IO ()

152−checkRoundTrip TestEnv{..} IntervalTestCase{..} = do

153−

154− let input = CalendarDiffTime

155− { ctMonths = inputMonths

156− , ctTime = inputSeconds

157− }

158−

159− [(returnedId :: Int, output :: CalendarDiffTime)] <- query conn [sql|

160− INSERT INTO testinterval (sample)

161− VALUES (?)

162− RETURNING id, sample

163− |] (Only input)

164−

165− assertBool ("CalendarDiffTime did not round-trip from Haskell to SQL and back (" ++ label ++ ")") $

166− output == input

167−

168− [(Only isExpectedIso)] <- query conn [sql|

169− SELECT sample = (?)::interval

170− FROM testinterval

171− WHERE id = ?

172− |] (asText, returnedId)

173−

174− assertBool ("CalendarDiffTime inserted did not match ISO8601 equivalent \"" ++ asText ++ "\". (" ++ label ++ ")")

175− isExpectedIso

176−

test/Main.hs+52−381

@@ -1,95 +1,50 @@

1−{-# LANGUAGE CPP #-}

2−{-# LANGUAGE DeriveGeneric #-}

31{-# LANGUAGE DeriveDataTypeable #-}

42{-# LANGUAGE DoAndIfThenElse #-}

53{-# LANGUAGE ScopedTypeVariables #-}

6−#if __GLASGOW_HASKELL__ >= 806

7−{-# LANGUAGE DerivingStrategies #-}

8−{-# LANGUAGE DerivingVia #-}

9−{-# LANGUAGE DeriveAnyClass #-}

10−#endif

11−module Main (main) where

12−

134import Common

14−import Database.PostgreSQL.Simple.Copy

15−import Database.PostgreSQL.Simple.ToField (ToField)

165import Database.PostgreSQL.Simple.FromField (FromField)

6+import Database.PostgreSQL.Simple.Types(Query(..),Values(..))

177import Database.PostgreSQL.Simple.HStore

18−import Database.PostgreSQL.Simple.Newtypes

19−import Database.PostgreSQL.Simple.Internal (breakOnSingleQuestionMark)

20−import Database.PostgreSQL.Simple.Types(Query(..),Values(..), PGArray(..))

218import qualified Database.PostgreSQL.Simple.Transaction as ST

22−

239import Control.Applicative

2410import Control.Exception as E

2511import Control.Monad

26−import Data.Char

27−import Data.Foldable (toList)

28−import Data.List (concat, sort)

12+import Data.ByteString (ByteString)

2913import Data.IORef

30−import Data.Monoid ((<>))

31−import Data.String (fromString)

3214import Data.Typeable

33−import GHC.Generics (Generic)

34−

35−import Data.Aeson

36−import Data.ByteString (ByteString)

3715import 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

4216import Data.Map (Map)

17+import Data.List (sort)

4318import qualified Data.Map as Map

4419import Data.Text(Text)

4520import qualified Data.Text.Encoding as T

21+import System.Exit (exitFailure)

22+import System.IO

4623import qualified Data.Vector as V

47−import System.FilePath

48−import System.Timeout(timeout)

49−import Data.Time.Compat (getCurrentTime, diffUTCTime)

50−import System.Environment (getEnvironment)

24+import Data.Aeson

5125

52−import Test.Tasty

53−import Test.Tasty.Golden

5426import Notify

5527import Serializable

5628import Time

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

29+

30+tests :: [TestEnv -> Test]

31+tests =

32+ [ TestLabel "Bytea" . testBytea

33+ , TestLabel "ExecuteMany" . testExecuteMany

34+ , TestLabel "Fold" . testFold

35+ , TestLabel "Notify" . testNotify

36+ , TestLabel "Serializable" . testSerializable

37+ , TestLabel "Time" . testTime

38+ , TestLabel "Array" . testArray

39+ , TestLabel "HStore" . testHStore

40+ , TestLabel "JSON" . testJSON

41+ , TestLabel "Savepoint" . testSavepoint

42+ , TestLabel "Unicode" . testUnicode

43+ , TestLabel "Values" . testValues

8944 ]

9045

91−testBytea :: TestEnv -> TestTree

92−testBytea TestEnv{..} = testGroup "Bytea"

46+testBytea :: TestEnv -> Test

47+testBytea TestEnv{..} = TestList

9348 [ testStr "empty" []

9449 , testStr "\"hello\"" $ map (fromIntegral . fromEnum) ("hello" :: String)

9550 , testStr "ascending" [0..255]

@@ -98,7 +53,7 @@ testBytea TestEnv{..} = testGroup "Bytea"

9853 , testStr "descending, doubled up" $ doubleUp [255,254..0]

9954 ]

10055 where

101− testStr label bytes = testCase label $ do

56+ testStr label bytes = TestLabel label $ TestCase $ do

10257 let bs = B.pack bytes

10358

10459 [Only h] <- query conn "SELECT md5(?::bytea)" [Binary bs]

@@ -109,8 +64,8 @@ testBytea TestEnv{..} = testGroup "Bytea"

10964

11065 doubleUp = concatMap (\x -> [x, x])

11166

112−testExecuteMany :: TestEnv -> Assertion

113−testExecuteMany TestEnv{..} = do

67+testExecuteMany :: TestEnv -> Test

68+testExecuteMany TestEnv{..} = TestCase $ do

11469 execute_ conn "CREATE TEMPORARY TABLE tmp_executeMany (i INT, t TEXT, b BYTEA)"

11570

11671 let rows :: [(Int, String, Binary ByteString)]

@@ -127,8 +82,8 @@ testExecuteMany TestEnv{..} = do

12782

12883 return ()

12984

130−testFold :: TestEnv -> Assertion

131−testFold TestEnv{..} = do

85+testFold :: TestEnv -> Test

86+testFold TestEnv{..} = TestCase $ do

13287 xs <- fold_ conn "SELECT generate_series(1,10000)"

13388 [] $ \xs (Only x) -> return (x:xs)

13489 reverse xs @?= ([1..10000] :: [Int])

@@ -139,7 +94,7 @@ testFold TestEnv{..} = do

13994 xs <- readIORef ref

14095 writeIORef ref $! (a,b):xs

14196 xs <- readIORef ref

142− reverse xs @?= [(a,b) | b <- [1..50], a <- [1..100]]

97+ reverse xs @?= [(a,b) | a <- [1..100], b <- [1..50]]

14398

14499 -- Make sure fold propagates our exception.

145100 ref <- newIORef []

@@ -197,8 +152,8 @@ queryFailure conn q resultType = do

197152 ++ show (typeOf resultType)

198153 ++ " -> " ++ show val)

199154

200−testArray :: TestEnv -> Assertion

201−testArray TestEnv{..} = do

155+testArray :: TestEnv -> Test

156+testArray TestEnv{..} = TestCase $ do

202157 xs <- query_ conn "SELECT '{1,2,3,4}'::_int4"

203158 xs @?= [Only (V.fromList [1,2,3,4 :: Int])]

204159 xs <- query_ conn "SELECT '{{1,2},{3,4}}'::_int4"

@@ -207,17 +162,8 @@ testArray TestEnv{..} = do

207162 queryFailure conn "SELECT '{1,2,3,4}'::_int4" (undefined :: V.Vector Bool)

208163 queryFailure conn "SELECT '{{1,2},{3,4}}'::_int4" (undefined :: V.Vector Int)

209164

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"

165+testHStore :: TestEnv -> Test

166+testHStore TestEnv{..} = TestCase $ do

221167 roundTrip []

222168 roundTrip [("foo","bar"),("bar","baz"),("baz","hello")]

223169 roundTrip [("fo\"o","bar"),("b\\ar","baz"),("baz","\"value\\with\"escapes")]

@@ -228,27 +174,12 @@ testHStore TestEnv{..} = do

228174 m' <- query conn "SELECT ?::hstore" m

229175 [m] @?= m'

230176

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

177+testJSON :: TestEnv -> Test

178+testJSON TestEnv{..} = TestCase $ do

246179 roundTrip (Map.fromList [] :: Map Text Text)

247180 roundTrip (Map.fromList [("foo","bar"),("bar","baz"),("baz","hello")] :: Map Text Text)

248181 roundTrip (Map.fromList [("fo\"o","bar"),("b\\ar","baz"),("baz","\"value\\with\"escapes")] :: Map Text Text)

249182 roundTrip (V.fromList [1,2,3,4,5::Int])

250− roundTrip ("foo" :: Text)

251− roundTrip (42 :: Int)

252183 where

253184 roundTrip :: ToJSON a => a -> Assertion

254185 roundTrip a = do

@@ -256,92 +187,8 @@ testJSON TestEnv{..} = do

256187 js' <- query conn "SELECT ?::json" js

257188 [js] @?= js'

258189

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

190+testSavepoint :: TestEnv -> Test

191+testSavepoint TestEnv{..} = TestCase $ do

345192 True <- expectError ST.isNoActiveTransactionError $

346193 withSavepoint conn $ return ()

347194

@@ -401,8 +248,8 @@ testSavepoint TestEnv{..} = do

401248

402249 return ()

403250

404−testUnicode :: TestEnv -> Assertion

405−testUnicode TestEnv{..} = do

251+testUnicode :: TestEnv -> Test

252+testUnicode TestEnv{..} = TestCase $ do

406253 let q = Query . T.encodeUtf8 -- Handle encoding ourselves to ensure

407254 -- the table gets created correctly.

408255 let messages = map Only ["привет","мир"] :: [Only Text]

@@ -411,8 +258,8 @@ testUnicode TestEnv{..} = do

411258 messages' <- query_ conn "SELECT сообщение FROM ру́сский"

412259 sort messages @?= sort messages'

413260

414−testValues :: TestEnv -> Assertion

415−testValues TestEnv{..} = do

261+testValues :: TestEnv -> Test

262+testValues TestEnv{..} = TestCase $ do

416263 execute_ conn "CREATE TEMPORARY TABLE values_test (x int, y text)"

417264 test (Values ["int4","text"] [])

418265 test (Values ["int4","text"] [(1,"hello")])

@@ -428,154 +275,6 @@ testValues TestEnv{..} = do

428275 vals' <- query_ conn "DELETE FROM values_test RETURNING *"

429276 sort vals @?= sort vals'

430277

431−

432−testCopy :: TestEnv -> Assertion

433−testCopy TestEnv{..} = do

434− execute_ conn "CREATE TEMPORARY TABLE copy_test (x int, y text)"

435− copy_ conn "COPY copy_test FROM STDIN (FORMAT CSV)"

436− mapM_ (putCopyData conn) copyRows

437− putCopyEnd conn

438− copy_ conn "COPY copy_test FROM STDIN (FORMAT CSV)"

439− mapM_ (putCopyData conn) abortRows

440− putCopyError conn "aborted"

441− -- Hmm, does postgres always produce \n as an end-of-line here, or

442− -- are there cases where it will use a \r\n as well?

443− copy_ conn "COPY copy_test TO STDOUT (FORMAT CSV)"

444− rows <- loop []

445− sort rows @?= sort copyRows

446− -- Now, let's just verify that the connection state is back to ready,

447− -- so that we can issue more queries:

448− [Only (x::Int)] <- query_ conn "SELECT 2 + 2"

449− x @?= 4

450− -- foldCopyData

451− copy_ conn "COPY copy_test TO STDOUT (FORMAT CSV)"

452− (acc, count) <- foldCopyData conn

453− (\acc row -> return (row:acc))

454− (\acc count -> return (acc, count))

455− []

456− sort acc @?= sort copyRows

457− count @?= 2

458− where

459− copyRows = ["1,foo\n"

460− ,"2,bar\n"]

461− abortRows = ["3,baz\n"]

462− loop rows = do

463− mrow <- getCopyData conn

464− case mrow of

465− CopyOutDone _ -> return rows

466− CopyOutRow row -> loop (row:rows)

467−

468−testCopyFailures :: TestEnv -> TestTree

469−testCopyFailures env = testGroup "Copy failures"

470− $ map ($ env)

471− [ testCopyUniqueConstraintError

472− , testCopyMalformedError

473− ]

474−

475−goldenTest :: TestName -> IO BL.ByteString -> TestTree

476−goldenTest testName =

477− goldenVsStringDiff testName diff (resultsDir </> fileName<.>"expected")

478− where

479− resultsDir = "test" </> "results"

480− fileName = map normalize testName

481− normalize c | not (isAlpha c) = '-'

482− | otherwise = c

483− diff ref new = ["diff", "-u", ref, new]

484−

485−-- | Test that we provide a sensible error message on failure

486−testCopyUniqueConstraintError :: TestEnv -> TestTree

487−testCopyUniqueConstraintError TestEnv{..} =

488− goldenTest "unique constraint violation"

489− $ handle (\(SomeException exc) -> return $ BL.pack $ show exc) $ do

490− execute_ conn "CREATE TEMPORARY TABLE copy_unique_constraint_error_test (x int PRIMARY KEY, y text)"

491− copy_ conn "COPY copy_unique_constraint_error_test FROM STDIN (FORMAT CSV)"

492− mapM_ (putCopyData conn) copyRows

493− _n <- putCopyEnd conn

494− return BL.empty

495− where

496− copyRows = ["1,foo\n"

497− ,"2,bar\n"

498− ,"1,baz\n"]

499−

500−testCopyMalformedError :: TestEnv -> TestTree

501−testCopyMalformedError TestEnv{..} =

502− goldenTest "malformed input"

503− $ handle (\(SomeException exc) -> return $ BL.pack $ show exc) $ do

504− execute_ conn "CREATE TEMPORARY TABLE copy_malformed_input_error_test (x int PRIMARY KEY, y text)"

505− copy_ conn "COPY copy_unique_constraint_error_test FROM STDIN (FORMAT CSV)"

506− mapM_ (putCopyData conn) copyRows

507− _n <- putCopyEnd conn

508− return BL.empty

509− where

510− copyRows = ["1,foo\n"

511− ,"2,bar\n"

512− ,"z,baz\n"]

513−

514−testTimeout :: TestEnv -> Assertion

515−testTimeout TestEnv{..} =

516− withConn $ \c -> do

517− start_t <- getCurrentTime

518− res <- timeout 200000 $ do

519− withTransaction c $ do

520− query_ c "SELECT pg_sleep(1)" :: IO [Only ()]

521− end_t <- getCurrentTime

522− assertBool "Timeout did not occur" (res == Nothing)

523−#if !defined(mingw32_HOST_OS)

524−-- At the moment, you cannot timely abandon queries with async exceptions on

525−-- Windows.

526− let d = end_t `diffUTCTime` start_t

527− assertBool "Timeout didn't work in a timely fashion" (0.1 < d && d < 0.6)

528−#endif

529−

530−testDouble :: TestEnv -> Assertion

531−testDouble TestEnv{..} = do

532− [Only (x :: Double)] <- query_ conn "SELECT 'NaN'::float8"

533− assertBool "expected NaN" (isNaN x)

534− [Only (x :: Double)] <- query_ conn "SELECT 'Infinity'::float8"

535− x @?= (1 / 0)

536− [Only (x :: Double)] <- query_ conn "SELECT '-Infinity'::float8"

537− x @?= (-1 / 0)

538−

539−

540−testGeneric1 :: TestEnv -> Assertion

541−testGeneric1 TestEnv{..} = do

542− roundTrip conn (Gen1 123)

543− where

544− roundTrip conn x0 = do

545− r <- query conn "SELECT ?::int" (x0 :: Gen1)

546− r @?= [x0]

547−

548−testGeneric2 :: TestEnv -> Assertion

549−testGeneric2 TestEnv{..} = do

550− roundTrip conn (Gen2 123 "asdf")

551− where

552− roundTrip conn x0 = do

553− r <- query conn "SELECT ?::int, ?::text" x0

554− r @?= [x0]

555−

556−testGeneric3 :: TestEnv -> Assertion

557−testGeneric3 TestEnv{..} = do

558− roundTrip conn (Gen3 123 "asdf" True)

559− where

560− roundTrip conn x0 = do

561− r <- query conn "SELECT ?::int, ?::text, ?::bool" x0

562− r @?= [x0]

563−

564−data Gen1 = Gen1 Int

565− deriving (Show,Eq,Generic)

566−instance FromRow Gen1

567−instance ToRow Gen1

568−

569−data Gen2 = Gen2 Int Text

570− deriving (Show,Eq,Generic)

571−instance FromRow Gen2

572−instance ToRow Gen2

573−

574−data Gen3 = Gen3 Int Text Bool

575− deriving (Show,Eq,Generic)

576−instance FromRow Gen3

577−instance ToRow Gen3

578−

579278data TestException

580279 = TestException

581280 deriving (Eq, Show, Typeable)

@@ -593,56 +292,28 @@ isUniqueViolation SqlError{..} = sqlState == "23505"

593292isSyntaxError :: SqlError -> Bool

594293isSyntaxError SqlError{..} = sqlState == "42601"

595294

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− ]

604295------------------------------------------------------------------------

605296

606297-- | Action for connecting to the database that will be used for testing.

607298--

608299-- Note that some tests, such as Notify, use multiple connections, and assume

609300-- that 'testConnect' connects to the same database every time it is called.

610−withTestEnv :: ByteString -> (TestEnv -> IO a) -> IO a

611−withTestEnv connstr cb =

612− withConn $ \conn -> do

613− -- currently required for interval to work.

614− -- we also test that this doesn't interfere with anything else

615− execute_ conn "SET intervalstyle TO 'iso_8601'"

301+testConnect :: IO Connection

302+testConnect = connectPostgreSQL ""

616303

304+withTestEnv :: (TestEnv -> IO a) -> IO a

305+withTestEnv cb =

306+ withConn $ \conn ->

617307 cb TestEnv

618308 { conn = conn

619309 , withConn = withConn

620310 }

621311 where

622− withConn = bracket (connectPostgreSQL connstr) close

312+ withConn = bracket testConnect close

623313

624314main :: IO ()

625−main = withConnstring $ \connstring -> do

626− withTestEnv connstring (defaultMain . tests)

627−

628−withConnstring :: (BS8.ByteString -> IO ()) -> IO ()

629−withConnstring kont = do

630− env <- getEnvironment

631− case lookup "DATABASE_CONNSTRING" env of

632− Just s -> kont (BS8.pack (special s))

633− Nothing -> case lookup "GITHUB_ACTIONS" env of

634− Just "true" -> kont (BS8.pack gha)

635− _ -> putStrLn "Set DATABASE_CONNSTRING environment variable"

636− where

637− -- https://www.appveyor.com/docs/services-databases/

638− special "appveyor" = "dbname='TestDb' user='postgres' password='Password12!'"

639− special "travis" = ""

640− special s = s

641−

642− gha = unwords

643− [ "dbname='postgres'"

644− , "user='postgres'"

645− , "password='postgres'"

646− , "host='postgres'"

647− , "port=5432"

648− ]

315+main = do

316+ mapM_ (`hSetBuffering` LineBuffering) [stdout, stderr]

317+ Counts{cases, tried, errors, failures} <-

318+ withTestEnv $ \env -> runTestTT $ TestList $ map ($ env) tests

319+ when (cases /= tried || errors /= 0 || failures /= 0) $ exitFailure

test/Notify.hs+2−1

@@ -14,8 +14,9 @@ import qualified Data.ByteString as B

1414-- TODO: Test with payload, but only for PostgreSQL >= 9.0

1515-- (when that feature was introduced).

1616

17−testNotify :: TestEnv -> Assertion

17+testNotify :: TestEnv -> Test

1818testNotify TestEnv{..} =

19+ TestCase $

1920 withConn $ \conn2 -> do

2021 execute_ conn "LISTEN foo"

2122 execute_ conn "LISTEN bar"

test/Serializable.hs+2−1

@@ -23,8 +23,9 @@ putCounter conn n = do

2323 1 <- execute conn "UPDATE testSerializableCounter SET n=?" (Only n)

2424 return ()

2525

26−testSerializable :: TestEnv -> Assertion

26+testSerializable :: TestEnv -> Test

2727testSerializable TestEnv{..} =

28+ TestCase $

2829 withConn $ \conn2 -> do

2930 initCounter conn

3031

test/Time.hs+15−63

@@ -17,82 +17,42 @@ correspond; for example, a conversion that consistently added hour

1717when printed to a string and subtracted an hour when parsed from string

1818would still pass these tests.

1919

20−

21−Right now, we are checking that 1400+ timestamps in the range of 1860 to

22−2060 round trip from postgresql to haskell and back in 5 different timezones.

23−In addition to UTC, the four timezones were selected so that 2 have a positive

24−offset, and 2 have a negative offset, and that 2 have an offset of a

25−whole number of hours, while the other two do not.

26−

27−It may be worth adding a few more timezones to ensure better test coverage.

28−

29−We are checking a handful of selected timestamps to ensure we hit

30−various corner-cases in the code, in addition to 1400 timestamps randomly

31−generated with granularity of seconds down to microseconds in powers of ten.

32−

3320-}

3421

3522module Time (testTime) where

3623

3724import Common

3825import Control.Monad(forM_, replicateM_)

39−import Data.Time.Compat

26+import Data.Time

4027import Data.ByteString(ByteString)

4128import Database.PostgreSQL.Simple.SqlQQ

4229

4330numTests :: Int

4431numTests = 200

4532

46−testTime :: TestEnv -> Assertion

47−testTime env@TestEnv{..} = do

33+testTime :: TestEnv -> Test

34+testTime env@TestEnv{..} = TestCase $ do

4835 initializeTable env

4936 execute_ conn "SET timezone TO 'UTC'"

50− checkRoundTrips env "1860-01-01 00:00:00+00"

51− execute_ conn "SET timezone TO 'America/Chicago'" -- -5:00

52− checkRoundTrips env "1883-11-18 12:00:00-06"

53− execute_ conn "SET timezone TO 'Asia/Tokyo'" -- +9:00

54− checkRoundTrips env "1888-01-01 00:00:00+09"

55− execute_ conn "SET timezone TO 'Asia/Kathmandu'" -- +5:45

56− checkRoundTrips env "1919-12-31 23:48:44+05:30"

57− execute_ conn "SET timezone TO 'America/St_Johns'" -- -3:30

58− checkRoundTrips env "1935-03-30 00:00:52-03:30"

37+ checkRoundTrips env

38+ execute_ conn "SET timezone TO 'America/Chicago'"

39+ checkRoundTrips env

40+ execute_ conn "SET timezone TO 'Asia/Tokyo'"

41+ checkRoundTrips env

42+ execute_ conn "SET timezone TO 'Asia/Kathmandu'"

43+ checkRoundTrips env

44+ execute_ conn "SET timezone TO 'America/St_Johns'"

45+ checkRoundTrips env

5946

6047initializeTable :: TestEnv -> IO ()

6148initializeTable TestEnv{..} = withTransaction conn $ do

6249 execute_ conn

6350 [sql| CREATE TEMPORARY TABLE testtime

6451 ( x serial, y timestamptz, PRIMARY KEY(x) ) |]

65−

66− let test :: ByteString -> IO () = \x -> do

67− execute conn [sql|

68− INSERT INTO testtime (y) VALUES (?)

69− |] (Only x)

70− return ()

71− -- America/Chicago

72− test "1883-11-18 11:59:59-05:50:36"

73− test "1883-11-18 12:09:23-05:50:36"

74− test "1883-11-18 12:00:00-06"

75− -- Asia/Tokyo

76− test "1887-12-31 23:59:59+09:18:59"

77− test "1888-01-01 00:18:58+09:18:59"

78− test "1888-01-01 00:00:00+09"

79− -- Asia/Kathmandu

80− test "1919-12-31 23:59:59+05:41:16"

81− test "1919-12-31 23:48:44+05:30"

82− test "1985-12-31 23:59:59+05:30"

83− test "1986-01-01 00:15:00+05:45"

84− -- America/St_Johns

85− test "1935-03-29 23:59:59-03:30:52"

86− test "1935-03-30 00:00:52-03:30"

87−

88− -- While the above special cases are probably a decent start, there

89− -- are probably more that are well worth adding to ensure better

90− -- coverage.

91−

9252 let pop :: ByteString -> Double -> IO () = \x y ->

9353 replicateM_ numTests $ execute conn

9454 [sql| INSERT INTO testtime (y) VALUES

95− ('1860-01-01 00:00:00+00'::timestamptz

55+ ('1936-01-01 00:00:00+00'::timestamptz

9656 + ?::interval * ROUND(RANDOM() * ?)) |] (x,y)

9757 pop "1 microsecond" 6.3113904e15

9858 pop "10 microseconds" 6.3113904e14

@@ -102,18 +62,10 @@ initializeTable TestEnv{..} = withTransaction conn $ do

10262 pop "100 milliseconds" 6.3113904e10

10363 pop "1 second" 6.3113904e9

10464

105−checkRoundTrips :: TestEnv -> ByteString -> IO ()

106−checkRoundTrips TestEnv{..} limit = do

65+checkRoundTrips :: TestEnv -> IO ()

66+checkRoundTrips TestEnv{..} = do

10767 yxs :: [(UTCTime, Int)] <- query_ conn [sql| SELECT y, x FROM testtime |]

10868 forM_ yxs $ \yx -> do

10969 res <- query conn [sql| SELECT y=? FROM testtime WHERE x=? |] yx

11070 assertBool "UTCTime did not round-trip from SQL to Haskell and back" $

11171 res == [Only True]

112−

113− yxs :: [(ZonedTime, Int)] <- query conn [sql|

114− SELECT y, x FROM testtime WHERE y > ?

115− |] (Only limit)

116− forM_ yxs $ \yx -> do

117− res <- query conn [sql| SELECT y=? FROM testtime WHERE x=? |] yx

118− assertBool "ZonedTime did not round-trip from SQL to Haskell and back" $

119− res == [Only True]

test/results/malformed-input.expecteddeleted−4

@@ -1,4 +0,0 @@

1−user error (Database.PostgreSQL.Simple.Copy.putCopyEnd: failed to parse command status

2−Connection error: ERROR: invalid input syntax for type integer: "z"

3−CONTEXT: COPY copy_unique_constraint_error_test, line 3, column x: "z"

4−)

test/results/unique-constraint-violation.expecteddeleted−5

@@ -1,5 +0,0 @@

1−user error (Database.PostgreSQL.Simple.Copy.putCopyEnd: failed to parse command status

2−Connection error: ERROR: duplicate key value violates unique constraint "copy_unique_constraint_error_test_pkey"

3−DETAIL: Key (x)=(1) already exists.

4−CONTEXT: COPY copy_unique_constraint_error_test, line 3

5−)

tools/GenBuiltinTypes.hsnew file+182

@@ -0,0 +1,182 @@

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+|]

89+

90+instance IsString Blaze.Builder where

91+ fromString = Blaze.fromByteString . fromString

92+

93+main = do

94+ conn <- connectPostgreSQL ""

95+ xs <- query conn "SELECT typname::text, oid::int\

96+ \ FROM pg_type\

97+ \ WHERE typname IN ?"

98+ (Only (In (sort (map fst builtins))))

99+ close conn

100+ let oidmap = Map.fromList xs :: Map

101+ L.writeFile "../src/Database/PostgreSQL/Simple/BuiltinTypes.hs"

102+ (Blaze.toLazyByteString (renderFile oidmap builtins))

103+

104+padCons str = fromString (replicate (len - B.length str) ' ')

105+ where

106+ len = maximum (map (B.length . snd) builtins)

107+

108+renderOid oidmap x

109+ = case Map.lookup x oidmap of

110+ Nothing -> error (B.unpack x)

111+ Just (show -> n) -> fromString (replicate (4 - length n) ' ')

112+ ++ fromString n

113+

114+renderOid' oidmap x

115+ = case Map.lookup x oidmap of

116+ Nothing -> error (B.unpack x)

117+ Just (show -> n) -> fromString n

118+ ++ fromString (replicate (4 - length n) ' ')

119+

120+bs = Blaze.fromByteString

121+

122+renderFile :: Map -> [(B.ByteString,B.ByteString)] -> Blaze.Builder

123+renderFile oidmap builtins = ([longstring|

124+{-# LANGUAGE DeriveDataTypeable, OverloadedStrings #-}

125+

126+------------------------------------------------------------------------------

127+-- |

128+-- Module: Database.PostgreSQL.Simple.BuiltinTypes

130+-- License: BSD3

131+-- Maintainer: Leon P Smith <leon@melding-monads.com>

132+-- Stability: experimental

133+--

134+------------------------------------------------------------------------------

135+

136+-- Note that this file is generated by tools/GenBuiltinTypes.hs, and should

137+-- not be edited directly

138+

139+module Database.PostgreSQL.Simple.BuiltinTypes

140+ {-# DEPRECATED "Use TypeInfo instead" #-}

141+ ( BuiltinType (..)

142+ , builtin2oid

143+ , oid2builtin

144+ , builtin2typname

145+ , oid2typname

146+ ) where

147+

148+import Data.Typeable

149+import Data.ByteString (ByteString)

150+import qualified Database.PostgreSQL.LibPQ as PQ

151+

152+data BuiltinType

153+ = |] ++ mconcat (intersperse "\n | " (map (Blaze.fromByteString . snd) builtins)) ++ [longstring|

154+

155+ deriving (Eq, Ord, Enum, Bounded, Read, Show, Typeable)

156+

157+builtin2oid :: BuiltinType -> PQ.Oid

158+builtin2oid typ = PQ.Oid $ case typ of

159+|] ++ mconcat [mconcat [ " ", bs y, padCons y, " -> "

160+ , renderOid oidmap x, "\n" ]

161+ | (x,y) <- builtins ] ++ [longstring|

162+

163+oid2builtin :: PQ.Oid -> Maybe BuiltinType

164+oid2builtin (PQ.Oid x) = case x of

165+|] ++ mconcat [mconcat [ " ", renderOid' oidmap x, " -> Just ", bs y, "\n" ]

166+ | (x,y) <- builtins ] ++ [longstring|

167+ _ -> Nothing

168+

169+builtin2typname :: BuiltinType -> ByteString

170+builtin2typname typ = case typ of

171+|] ++ mconcat [mconcat [ " ", bs y, padCons y, " -> ", bs x, "\n"]

172+ | (x,y) <- builtins] ++ [longstring|

173+

174+oid2typname :: PQ.Oid -> Maybe ByteString

175+oid2typname (PQ.Oid x) = case x of

176+|] ++ mconcat [mconcat [ " ", renderOid' oidmap x, " -> Just ", bs x, "\n" ]

177+ | (x,y) <- builtins ]

178+ ++ " _ -> Nothing\n"

179+ ++ mconcat [mconcat [ "\n"

180+ , bs x, " :: ByteString\n"

181+ , bs x, " = \"", bs x, "\"\n"]

182+ | (x,_y) <- builtins ])

tools/GenTypeInfo.hs+39−170

@@ -21,9 +21,6 @@

2121-- know about. It then constructs a TypeInfo record and stores it in

2222-- a per-connection cache for later use.

2323--

24−-- @

25−-- runghc -itools tools/GenTypeInfo.hs

26−-- @

2724------------------------------------------------------------------------------

2825

2926{-# LANGUAGE OverloadedStrings, QuasiQuotes, ViewPatterns, RecordWildCards #-}

@@ -41,10 +38,12 @@ import Database.PostgreSQL.Simple.FromRow

4138import Database.PostgreSQL.Simple.Ok

4239import Database.PostgreSQL.Simple.Types(Oid(..))

4340import Database.PostgreSQL.Simple.SqlQQ

44−import qualified Data.ByteString.Char8 as B8

41+import qualified Data.ByteString.Char8 as B

4542import Data.ByteString(ByteString)

4643import qualified Data.ByteString.Lazy as L

47−import qualified Data.ByteString.Builder as Blaze

44+import qualified Blaze.ByteString.Builder as Blaze

45+import qualified Blaze.ByteString.Builder.ByteString as Blaze

46+import qualified Blaze.ByteString.Builder.Char8 as Blaze

4847import Data.String

4948import Data.List ( sort, intersperse )

5049import qualified Data.Map as Map

@@ -64,17 +63,16 @@ data TypeInfo = TypeInfo

6463 , typdelim :: Char

6564 , typname :: ByteString

6665 , typelem :: Oid

67− , rngsubtype :: Maybe Oid

6866 }

6967

70−instance FromRow TypeInfo where

71− fromRow = TypeInfo <$> field <*> field <*> field <*> field <*> field <*> field

68+instance FromRow TypeInfo where

69+ fromRow = TypeInfo <$> field <*> field <*> field <*> field <*> field

7270

73−type NameMap = Map.Map B8.ByteString TypeInfo

71+type NameMap = Map.Map B.ByteString TypeInfo

7472

7573type OidMap = Map.Map Oid TypeInfo

7674

77−type TypeName = (B8.ByteString, B8.ByteString)

75+type TypeName = (B.ByteString, B.ByteString)

7876

7977type TypeNames = [TypeName]

8078

@@ -105,6 +103,9 @@ line

105103cidr

106104float4

107105float8

106+abstime

107+reltime

108+tinterval

108109unknown

109110circle

110111money

@@ -124,118 +125,48 @@ numeric

124125refcursor

125126record

126127void

127−_record array_record

128−regprocedure

129−regoper

130−regoperator

131−regclass

132−regtype

133128uuid

134129json

135−jsonb

136−int2vector

137−oidvector

138−_xml array_xml

139−_json array_json

140−_line array_line

141−_cidr array_cidr

142−_circle array_circle

143−_money array_money

144−_bool array_bool

145−_bytea array_bytea

146−_char array_char

147−_name array_name

148−_int2 array_int2

149−_int2vector array_int2vector

150−_int4 array_int4

151−_regproc array_regproc

152−_text array_text

153−_tid array_tid

154−_xid array_xid

155−_cid array_cid

156−_oidvector array_oidvector

157−_bpchar array_bpchar

158−_varchar array_varchar

159−_int8 array_int8

160−_point array_point

161−_lseg array_lseg

162−_path array_path

163−_box array_box

164−_float4 array_float4

165−_float8 array_float8

166−_polygon array_polygon

167−_oid array_oid

168−_macaddr array_macaddr

169−_inet array_inet

170−_timestamp array_timestamp

171−_date array_date

172−_time array_time

173−_timestamptz array_timestamptz

174−_interval array_interval

175−_numeric array_numeric

176−_timetz array_timetz

177−_bit array_bit

178−_varbit array_varbit

179−_refcursor array_refcursor

180−_regprocedure array_regprocedure

181−_regoper array_regoper

182−_regoperator array_regoperator

183−_regclass array_regclass

184−_regtype array_regtype

185−_uuid array_uuid

186−_jsonb array_jsonb

187−int4range

188−_int4range

189−numrange

190−_numrange

191−tsrange

192−_tsrange

193−tstzrange

194−_tstzrange

195−daterange

196−_daterange

197−int8range

198−_int8range

199130|]

200131

132+instance IsString Blaze.Builder where

133+ fromString = Blaze.fromByteString . fromString

134+

201135connectionString = "dbname=postgres"

202136

203137withPostgreSQL = bracket (connectPostgreSQL connectionString) close

204138

205139getTypeInfos :: TypeNames -> IO (OidMap, NameMap)

206140getTypeInfos typnames = withPostgreSQL $ \conn -> do

207− infos <- query conn [sql|

208− WITH types AS

209− (SELECT oid, typcategory, typdelim, typname, typelem

210− FROM pg_type WHERE typname IN ?)

211− SELECT types.*, rngsubtype FROM types LEFT JOIN pg_range ON oid = rngtypid

212− |] (Only (In (sort (map pg typnames))))

141+ infos <- query conn [sql|

142+ SELECT oid, typcategory, typdelim, typname, typelem

143+ FROM pg_type

144+ WHERE typname IN ?

145+ |]

146+ (Only (In (sort (map pg typnames))))

213147 loop conn (oidMap infos) (nameMap infos) infos

214148 where

215149 oidMap = Map.fromList . map (typoid &&& id)

216150 nameMap = Map.fromList . map (typname &&& id)

217151 loop conn oids names infos = do

218− let unknowns = [ x | x <- map typelem infos ++

219− [ x | Just x <- map rngsubtype infos ],

152+ let unknowns = [ x | x <- map typelem infos,

220153 x /= Oid 0,

221154 not (Map.member x oids) ]

222155 case unknowns of

223156 [] -> return (oids, names)

224157 (_:_) -> do

225158 infos' <- query conn [sql|

226− WITH types AS

227− (SELECT oid, typcategory, typdelim, typname, typelem

228− FROM pg_type WHERE oid IN ?)

229− SELECT types.*, rngsubtype

230− FROM types LEFT JOIN pg_range ON oid = rngtypid

231− |] (Only (In (sort unknowns)))

159+ SELECT oid, typcategory, typdelim, typname, typelem

160+ FROM pg_type

161+ WHERE oid IN ?

162+ |] (Only (In (sort unknowns)))

232163 let oids' = oids `Map.union` oidMap infos'

233164 names' = names `Map.union` nameMap infos'

234165 loop conn oids' names' infos'

235166

236167main = do

237168 (oidmap, namemap) <- getTypeInfos typeNames

238− L.writeFile "src/Database/PostgreSQL/Simple/TypeInfo/Static.hs"

169+ L.writeFile "../src/Database/PostgreSQL/Simple/TypeInfo/Static.hs"

239170 (Blaze.toLazyByteString (renderFile oidmap namemap typeNames))

240171

241172

@@ -244,7 +175,7 @@ showOid (Oid n) = show n

244175renderOid :: NameMap -> TypeName -> Blaze.Builder

245176renderOid byName name

246177 = case Map.lookup (pg name) byName of

247− Nothing -> error (B8.unpack (pg name))

178+ Nothing -> error (B.unpack (pg name))

248179 Just (showOid . typoid -> n) -> fromString n

249180 ++ fromString (replicate (4 - length n) ' ')

250181

@@ -255,83 +186,13 @@ renderElem byOid elemOid

255186 Nothing -> error ("oid not found: " ++ show elemOid)

256187 Just x -> "Just " ++ bs (typname x)

257188

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−

328189-- FIXME: add in any names that we need that we didn't specify, (i.e.

329190-- the "unknowns" in getTypeInfos

330191-- and munge them into a valid haskell identifier if needed.

331192getNames :: NameMap -> TypeNames -> TypeNames

332193getNames _ x = x

333194

334−bs = Blaze.byteString

195+bs = Blaze.fromByteString

335196

336197pg = fst

337198

@@ -360,7 +221,6 @@ module Database.PostgreSQL.Simple.TypeInfo.Static

360221 ( TypeInfo(..)

361222 , staticTypeInfo

362223|] ++ concat [ " , " ++ bs (hs name) ++ "\n"

363− ++ " , " ++ bs (hs name) ++ "Oid\n"

364224 | name <- names ] ++ [longstring|

365225 ) where

366226

@@ -376,6 +236,15 @@ staticTypeInfo (Oid x) = case x of

376236 ++ [longstring|

377237 _ -> Nothing

378238|]

379− ++ concat [ renderTypeInfo byOid typeInfo name

239+ ++ concat [concat

240+ [ "\n"

241+ , bs (hs name), " :: TypeInfo\n"

242+ , bs (hs name), " = Basic {\n"

243+ , " typoid = ", fromString (show typoid), ",\n"

244+ , " typcategory = '", Blaze.fromChar typcategory, "',\n"

245+ , " typdelim = '", Blaze.fromChar typdelim, "',\n"

246+ , " typname = \"", bs typname, "\"\n"

247+ , " }\n"

248+ ]

380249 | name <- getNames byName names

381− , let (Just typeInfo) = Map.lookup (pg name) byName])

250+ , let (Just (TypeInfo{..})) = Map.lookup (pg name) byName])