master..8342dcb · typeable/postgresql-simple

git.iko.soy/typeable/postgresql-simple

on 8342dcb help sign in

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

since splitsnapshots

unifiedsplit

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

7*.o

8\#*\#

9.#*

10−/CHANGELOG.md

10+postgresql-simple-*.tar.gz

11−.cabal-sandbox/

12−.stack-work/

13−cabal.sandbox.config

14−/dist-newstyle

15−.ghc.environment.*

16−cabal.project.local

17−dump-core

CHANGESnew file+131

@@ -0,0 +1,131 @@

1+Version 0.2.3.0 (2012-08-09)

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

4+Version 0.2.2.0 (2012-07-26)

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

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

9+Version 0.2.1.0 (2012-07-23)

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

11+

12+ * Added a type synonym for FieldParser

13+

14+Version 0.2.0.1 (2012-06-21)

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

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

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

18+

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

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

21+ broken even though it will still compile.

22+

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

24+

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

26+

27+

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

29+ * Fix language extensions for compatibility with GHC 7.0

30+

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

32+ * Fix a wayward dependency on Text.

33+

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

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

36+

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

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

39+

40+ * Reworked support for the Time types.

41+

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

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

44+

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

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

47+

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

49+ that accomodate PostgreSQL's infinities.

50+

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

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

53+ time package included in GHC.

54+

55+ * Planned breaking changes for 0.2:

56+

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

58+

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

60+

61+

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

63+ * Made ZonedTime an instance of FromField and ToField

64+

65+ * Added getNotificationNonBlocking

66+

67+

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

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

70+ PostgreSQL 8 courtesy of Joey Adams.

71+

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

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

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

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

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

77+

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

79+

80+

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

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

83+ LargeObjects modules

84+

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

86+

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

88+

89+

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

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

92+

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

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

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

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

97+

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

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

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

101+

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

103+ `Either SomeException` to `Ok`.

104+

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

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

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

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

109+ example comparing the old to the new:

110+

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

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

113+ !a <- convert fa va

114+ !b <- convert fb vb

115+ return (a,b)

116+ convertResults fs vs = convertError fs vs 2

117+

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

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

120+

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

122+

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

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

125+

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

127+

128+ * Removed the `RawResult` type.

129+

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

131+ 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−28

@@ -5,32 +5,4 @@ Ozgun Ataman <ozataman@gmail.com>

5Joey Adams <joeyadams3.14159@gmail.com>

6Rekado <rekado@elephly.net>

7Leonid Onokhov <sopvop@gmail.com>

8−Bas van Dijk <v.dijk.bas@gmail.com>

9Jason Dusek <jason.dusek@gmail.com>

8Jason Dusek <jason.dusek@gmail.com>

10−Jeff Chu <jeff@kiteedu.com>

11−Oliver Charles <oliver.g.charles@gmail.com>

12−Simon Meier <iridcode@gmail.com>

13−Alexey Uimanov <s9gf4ult@gmail.com>

14−Doug Beardsley <mightybyte@gmail.com>

15−Manuel Gómez <targen@gmail.com>

16−Michael Snoyman <michael@snoyman.com>

17−Adam Bergmark <adam@edea.se>

18−Tobias Florek <tob@butter.sh>

19−Francesco Mazzoli <francesco.mazzoli@erudify.com>

20−Chris Allen <cma@bitemyapp.com>

21−Simon Hengel <sol@typeful.net>

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

23−Mike Ledger <mike@quasimal.com>

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

25−Bardur Arantsson <bardur@scientician.net>

26−Travis Staton <hello@travisstaton.com>

27−Sam Rijs <srijs@airpost.net>

28−Janne Hellsten <jjhellst@gmail.com>

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

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

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

32−Amit Levy <amit@amitlevy.com>

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

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

35−Erik Hesselink <hesselink@gmail.com>

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

README.mddeleted−4

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

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

2−

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

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

bench/Select.hsdeleted−32

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

1−{-# LANGUAGE OverloadedStrings #-}

2−module Main where

3−

4−import Database.PostgreSQL.Simple

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

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

7−

8−import System.Environment (getArgs)

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

10−import qualified Data.Vector.Unboxed as VU

11−

12−main :: IO ()

13−main = do

14− args <- getArgs

15− conn <- connectPostgreSQL ""

16− case args of

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

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

19− print (process result)

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

21− -- dummy column

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

23− print (process' result)

24− _ -> do

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

26− print (process result)

27−

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

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

30−

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

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

cabal.haskell-cideleted−5

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

1−branches: master

2−postgresql: True

3−

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

5−-- osx: 8.4.4

cabal.projectdeleted−4

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

1−packages: .

2−tests: true

3−

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

cabal.project.local.windeleted−4

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

1−constraints: these -assoc

2−

3−package postgresql-libpq

4− flags: -use-pkg-config

postgresql-simple.cabal+76−153

@@ -1,175 +1,98 @@

1−cabal-version: 1.12

2−name: postgresql-simple

1+Name: postgresql-simple

3−version: 0.7.0.0

2+Version: 0.2.3.0

4−x-revision: 1

5−synopsis: Mid-Level PostgreSQL client library

3+Synopsis: Mid-Level PostgreSQL client library

6−description:

4+Description:

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

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

9−license: BSD3

15+Cabal-version: >= 1.9.2

10−license-file: LICENSE

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

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

13−copyright:

18−category: Database

19−build-type: Simple

20extra-source-files:

17extra-source-files:

21− CHANGES.md

22− CONTRIBUTORS

18+ CONTRIBUTORS

23− test/results/malformed-input.expected

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

26−tested-with:

20+Library

27− GHC ==8.6.5

21+ hs-source-dirs: src

28− || ==8.8.4

22+ Exposed-modules:

29− || ==8.10.7

23+ Database.PostgreSQL.Simple

30− || ==9.0.2

24+ Database.PostgreSQL.Simple.BuiltinTypes

31− || ==9.2.8

25+ Database.PostgreSQL.Simple.FromField

32− || ==9.4.8

26+ Database.PostgreSQL.Simple.FromRow

33− || ==9.6.3

27+ Database.PostgreSQL.Simple.LargeObjects

34− || ==9.8.1

28+ Database.PostgreSQL.Simple.Notification

29+ Database.PostgreSQL.Simple.Ok

30+ Database.PostgreSQL.Simple.SqlQQ

31+ Database.PostgreSQL.Simple.Time

32+ Database.PostgreSQL.Simple.Time.Internal

33+ Database.PostgreSQL.Simple.ToField

34+ Database.PostgreSQL.Simple.ToRow

35+ Database.PostgreSQL.Simple.Types

36+-- Other-modules:

37+ Database.PostgreSQL.Simple.Internal

36−library

37− default-language: Haskell2010

38− hs-source-dirs: src

39− exposed-modules:

39+ Other-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

40+ Database.PostgreSQL.Simple.Compat

55− Database.PostgreSQL.Simple.SqlQQ

56− Database.PostgreSQL.Simple.Time

57− Database.PostgreSQL.Simple.Time.Internal

41+ Database.PostgreSQL.Simple.Time.Implementation

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

68− -- Other-modules:

43+ Build-depends:

69− other-modules:

44+ attoparsec >= 0.8.5.3,

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

45+ base < 5,

46+ blaze-builder,

47+ blaze-textual,

81− , bytestring >=0.10.8.2 && <0.13

48+ bytestring >= 0.9,

82− , containers >=0.6.0.1 && <0.7

49+ containers,

50+ postgresql-libpq >= 0.6.2,

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

51+ template-haskell,

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

52+ text >= 0.11.1,

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

53+ time,

86− , transformers >=0.5.6.2 && <0.7

54+ transformers,

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

55+ vector

100− default-extensions:

101− BangPatterns

102− DoAndIfThenElse

103− OverloadedStrings

57+ extensions: DoAndIfThenElse, OverloadedStrings, BangPatterns, ViewPatterns

104− TypeOperators

58+ TypeOperators

105− ViewPatterns

106

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

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

108

109source-repository head

62source-repository head

110 type: git

63 type: git

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

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

112

113−test-suite inspection

66+source-repository this

114− default-language: Haskell2010

67+ type: git

115− type: exitcode-stdio-1.0

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

116− hs-source-dirs: test

69+ tag: v0.2.3.0

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

125

126test-suite test

71test-suite test

127− default-language: Haskell2010

128− type: exitcode-stdio-1.0

72+ type: exitcode-stdio-1.0

73+

129− hs-source-dirs: test

74+ hs-source-dirs: test

130− main-is: Main.hs

75+ main-is: Main.hs

131 other-modules:

76 other-modules:

132 Common

77 Common

133− Exception

78+ Bytea

134− Interval

79+ ExecuteMany

135 Notify

80 Notify

136 Serializable

81 Serializable

137 Time

82 Time

138

139− ghc-options: -threaded

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

84+ 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

148

149− build-depends:

86+ extensions: NamedFieldPuns

150− aeson

87+ , OverloadedStrings

151− , base

88+ , Rank2Types

152− , base16-bytestring

89+ , RecordWildCards

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

166

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:

91+ build-depends: base

173− base

92+ , base16-bytestring

93+ , bytestring

94+ , cryptohash

95+ , HUnit

174− , postgresql-simple

96+ , postgresql-simple

175− , vector

97+ , text

98+ , time

sdist.shdeleted−25

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

1−#!/bin/bash

2−

3−echo "Generating CHANGELOG.md"

4−echo

5−

6−cat <<HEADER > CHANGELOG.md

7−For the full changelog, see

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

9−

10−HEADER

11−

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

13−

14−cat CHANGELOG.md

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

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

17−cabal sdist

18−cd dist

19−wc *.tar.gz

20−gunzip *.gz

21−wc *.tar

22−zopfli *.tar

23−wc *.tar.gz

24−cd ..

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

src/Database/PostgreSQL/Simple.hs+363−248

@@ -13,6 +13,7 @@

13-- License: BSD3

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

15-- Stability: experimental

16+-- Portability: portable

16--

17--

17-- A mid-level client library for the PostgreSQL database, aimed at ease of

18-- A mid-level client library for the PostgreSQL database, aimed at ease of

18-- use and high performance.

19-- use and high performance.

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

42 -- ** Modifying multiple rows at once

43 -- ** Modifying multiple rows at once

43 -- $many

44 -- $many

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

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

46 -- $returning

47 -- $returning

48 -- * Extracting results

49 -- * Extracting results

@@ -55,7 +56,8 @@ module Database.PostgreSQL.Simple

55 -- $types

56 -- $types

57 -- * Types

58 -- * Types

59+ Base.ConnectInfo(..)

58− Connection

60+ , Connection

59 , Query

61 , Query

60 , ToRow

62 , ToRow

61 , FromRow

63 , FromRow

@@ -64,26 +66,19 @@ module Database.PostgreSQL.Simple

64 , Only(..)

66 , Only(..)

65 , (:.)(..)

67 , (:.)(..)

66 -- ** Exceptions

68 -- ** Exceptions

67− , SomePostgreSqlException(..)

68 , SqlError(..)

69 , SqlError(..)

69− , PQ.ExecStatus(..)

70− , FormatError(..)

70+ , FormatError(fmtMessage, fmtQuery, fmtParams)

71− , QueryError(..)

71+ , QueryError(qeMessage, qeQuery)

72− , ResultError(..)

72+ , ResultError(errSQLType, errHaskellType, errMessage)

73 -- * Connection management

74− , Base.connectPostgreSQL

75− , Base.close

76 , Base.connect

74 , Base.connect

77− , Base.withConnect

75+ , Base.connectPostgreSQL

78− , Base.ConnectInfo(..)

79− , Base.defaultConnectInfo

80 , Base.postgreSQLConnectionString

76 , Base.postgreSQLConnectionString

77+ , Base.defaultConnectInfo

78+ , Base.close

81 -- * Queries that return results

79 -- * Queries that return results

82 , query

80 , query

83 , query_

81 , query_

84− -- ** Queries taking parser as argument

85− , queryWith

86− , queryWith_

87 -- * Queries that stream results

82 -- * Queries that stream results

88 , FoldOptions(..)

83 , FoldOptions(..)

89 , FetchQuantity(..)

84 , FetchQuantity(..)

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

95 , forEach

90 , forEach

96 , forEach_

91 , forEach_

97 , returning

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

106 -- * Statements that do not return results

93 -- * Statements that do not return results

107 , execute

94 , execute

108 , execute_

95 , execute_

@@ -110,9 +97,19 @@ module Database.PostgreSQL.Simple

110-- , Base.insertID

97-- , Base.insertID

111 -- * Transaction handling

98 -- * Transaction handling

112 , withTransaction

99 , withTransaction

113− , withSavepoint

100+ , withTransactionSerializable

101+ , TransactionMode(..)

102+ , IsolationLevel(..)

103+ , ReadWriteMode(..)

104+ , defaultTransactionMode

105+ , defaultIsolationLevel

106+ , defaultReadWriteMode

107+ , withTransactionLevel

108+ , withTransactionMode

114-- , Base.autocommit

109-- , Base.autocommit

115 , begin

110 , begin

111+ , beginLevel

112+ , beginMode

116 , commit

113 , commit

117 , rollback

114 , rollback

118 -- * Helper functions

115 -- * Helper functions

@@ -120,27 +117,49 @@ module Database.PostgreSQL.Simple

120 , formatQuery

117 , formatQuery

121 ) where

118 ) where

122

119

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

120+import Blaze.ByteString.Builder

121+ ( Builder, fromByteString, toByteString )

122+import Blaze.ByteString.Builder.Char8 (fromChar)

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

123+import Control.Applicative ((<$>), pure)

125−import Control.Exception as E

124+import Control.Concurrent.MVar

125+import Control.Exception

126+ ( Exception, onException, throw, throwIO, finally

127+ , try, SomeException, fromException )

128+import Control.Monad (foldM)

126import Data.ByteString (ByteString)

129import Data.ByteString (ByteString)

127import Data.Int (Int64)

130import Data.Int (Int64)

131+import qualified Data.IntMap as IntMap

128import Data.List (intersperse)

132import Data.List (intersperse)

129−import Data.Monoid (mconcat)

133+import Data.Monoid (mappend, mconcat)

134+import Data.Typeable (Typeable)

135+import Database.PostgreSQL.Simple.BuiltinTypes ( oid2typname )

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

136+import Database.PostgreSQL.Simple.Compat ( mask )

131−import Database.PostgreSQL.Simple.Cursor

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

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

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

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

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

139+import Database.PostgreSQL.Simple.Ok

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

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

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

136import Database.PostgreSQL.Simple.Types

142import Database.PostgreSQL.Simple.Types

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

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

138import Database.PostgreSQL.Simple.Internal as Base

144import Database.PostgreSQL.Simple.Internal as Base

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

140−import Database.PostgreSQL.Simple.Transaction

141import qualified Database.PostgreSQL.LibPQ as PQ

145import qualified Database.PostgreSQL.LibPQ as PQ

142import qualified Data.ByteString.Char8 as B

146import qualified Data.ByteString.Char8 as B

143−

147+import qualified Data.Text as T

148+import qualified Data.Text.Encoding as TE

149+import qualified Data.Vector as V

150+import Control.Monad.Trans.Reader

151+import Control.Monad.Trans.State.Strict

152+

153+-- | Exception thrown if a 'Query' could not be formatted correctly.

154+-- This may occur if the number of \'@?@\' characters in the query

155+-- string does not match the number of parameters provided.

156+data FormatError = FormatError {

157+ fmtMessage :: String

158+ , fmtQuery :: Query

159+ , fmtParams :: [ByteString]

160+ } deriving (Eq, Show, Typeable)

161+

162+instance Exception FormatError

144

163

145-- | Format a query string.

164-- | Format a query string.

146--

165--

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

177 case parseTemplate template of

196 case parseTemplate template of

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

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

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

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

180− return . toByteString . mconcat $ byteString before :

199+ return . toByteString . mconcat $ fromByteString before :

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

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

182− [byteString after]

201+ [fromByteString after]

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

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

184

203

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

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

@@ -277,40 +296,43 @@ parseTemplate template =

277

296

278 skipSpace = B.dropWhile isSpace_ascii

297 skipSpace = B.dropWhile isSpace_ascii

279

298

299+escapeStringConn :: Connection -> ByteString -> IO (Either ByteString ByteString)

300+escapeStringConn conn s =

301+ withConnection conn $ \c ->

302+ PQ.escapeStringConn c s >>= checkError c

303+

304+escapeByteaConn :: Connection -> ByteString -> IO (Either ByteString ByteString)

305+escapeByteaConn conn s =

306+ withConnection conn $ \c ->

307+ PQ.escapeByteaConn c s >>= checkError c

308+

309+checkError :: PQ.Connection -> Maybe a -> IO (Either ByteString a)

310+checkError _ (Just x) = return $ Right x

311+checkError c Nothing = Left . maybe "" id <$> PQ.errorMessage c

280

312

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

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

282−buildQuery conn q template xs =

314+buildQuery conn q template xs = zipParams (split template) <$> mapM sub xs

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

315+ where quote = either (\msg -> fmtError (utf8ToString msg) q xs)

284− where split s =

316+ (inQuotes . fromByteString)

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

317+ utf8ToString = T.unpack . TE.decodeUtf8

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

318+ sub (Plain b) = pure b

287− let (h,t) = breakOnSingleQuestionMark s

319+ sub (Escape s) = quote <$> escapeStringConn conn s

288− in byteString h

320+ sub (EscapeByteA s) = quote <$> escapeByteaConn conn s

289− : if B.null t

321+ sub (Many ys) = mconcat <$> mapM sub ys

290− then []

291− else split (B.tail t)

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

323+ where (h,t) = B.break (=='?') s

292− zipParams (t:ts) (p:ps) = t <> p <> zipParams ts ps

324+ zipParams (t:ts) (p:ps) = t `mappend` p `mappend` zipParams ts ps

293 zipParams [t] [] = t

325 zipParams [t] [] = t

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

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

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

327+ " '?' characters, but " ++

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

328 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

306

329

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

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

308-- expected to return results.

331-- expected to return results.

309--

332--

310-- Returns the number of rows affected.

333-- Returns the number of rows affected.

311--

334--

312−-- Throws 'FormatError' if the query could not be formatted correctly, or

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

313−-- a 'SqlError' exception if the backend returns an error.

314execute :: (ToRow q) => Connection -> Query -> q -> IO Int64

336execute :: (ToRow q) => Connection -> Query -> q -> IO Int64

315execute conn template qs = do

337execute conn template qs = do

316 result <- exec conn =<< formatQuery conn template qs

338 result <- exec conn =<< formatQuery conn template qs

@@ -319,33 +341,9 @@ execute conn template qs = do

319-- | Execute a multi-row @INSERT@, @UPDATE@, or other SQL query that is not

341-- | Execute a multi-row @INSERT@, @UPDATE@, or other SQL query that is not

320-- expected to return results.

342-- expected to return results.

321--

343--

322−-- Returns the number of rows affected. If the list of parameters is empty,

344+-- Returns the number of rows affected.

323−-- this function will simply return 0 without issuing the query to the backend.

324−-- If this is not desired, consider using the 'Values' constructor instead.

325−--

326−-- Throws 'FormatError' if the query could not be formatted correctly, or

327−-- a 'SqlError' exception if the backend returns an error.

328−--

329−-- For example, here's a command that inserts two rows into a table

330−-- with two columns:

331−--

332−-- @

333−-- executeMany c [sql|

334−-- INSERT INTO sometable VALUES (?,?)

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

336−-- @

337−--

338−-- Here's an canonical example of a multi-row update command:

339--

345--

340−-- @

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

341−-- executeMany c [sql|

342−-- UPDATE sometable

343−-- SET y = upd.y

344−-- FROM (VALUES (?,?)) as upd(x,y)

345−-- WHERE sometable.x = upd.x

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

347−-- @

348−

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

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

350executeMany _ _ [] = return 0

348executeMany _ _ [] = return 0

351executeMany conn q qs = do

349executeMany conn q qs = do

@@ -359,20 +357,12 @@ executeMany conn q qs = do

359-- in cases where you are only inserting a single row, and do not need

357-- in cases where you are only inserting a single row, and do not need

360-- functionality analogous to 'executeMany'.

358-- functionality analogous to 'executeMany'.

361--

359--

362−-- If the list of parameters is empty, this function will simply return @[]@

363−-- without issuing the query to the backend. If this is not desired,

364−-- consider using the 'Values' constructor instead.

365−--

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

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

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

361returning :: (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 []

362+returning _ _ [] = return []

373−returningWith parser conn q qs = do

363+returning conn q qs = do

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

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

375− finishQueryWith parser conn q result

365+ finishQuery conn q result

376

366

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

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

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

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

@@ -389,27 +379,17 @@ returningWith parser conn q qs = do

389-- using 'execute' instead of 'query').

379-- using 'execute' instead of 'query').

390--

380--

391-- * 'ResultError': result conversion failed.

381-- * 'ResultError': result conversion failed.

392−--

393−-- * 'SqlError': the postgresql backend returned an error, e.g.

394−-- a syntax or type error, or an incorrect table or column name.

395−query :: (ToRow q, FromRow r) => Connection -> Query -> q -> IO [r]

382+query :: (ToRow q, FromRow r)

396−query = queryWith fromRow

383+ => Connection -> Query -> q -> IO [r]

384+query conn template qs = do

385+ result <- exec conn =<< formatQuery conn template qs

386+ finishQuery conn template result

397

387

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

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

399query_ :: (FromRow r) => Connection -> Query -> IO [r]

389query_ :: (FromRow r) => Connection -> Query -> IO [r]

400−query_ = queryWith_ fromRow

401−

402−-- | A version of 'query' taking parser as argument

403−queryWith :: ToRow q => RowParser r -> Connection -> Query -> q -> IO [r]

404−queryWith parser conn template qs = do

405− result <- exec conn =<< formatQuery conn template qs

406− finishQueryWith parser conn template result

407−

408−-- | A version of 'query_' taking parser as argument

409−queryWith_ :: RowParser r -> Connection -> Query -> IO [r]

410−queryWith_ parser conn q@(Query que) = do

390+query_ conn q@(Query que) = do

411 result <- exec conn que

391 result <- exec conn que

412− finishQueryWith parser conn q result

392+ finishQuery conn q result

413

393

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

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

415-- results. Results are streamed incrementally from the server, and

395-- results. Results are streamed incrementally from the server, and

@@ -421,12 +401,6 @@ queryWith_ parser conn q@(Query que) = do

421-- This fold is /not/ strict. The stream consumer is responsible for

401-- This fold is /not/ strict. The stream consumer is responsible for

422-- forcing the evaluation of its result to avoid space leaks.

402-- forcing the evaluation of its result to avoid space leaks.

423--

403--

424−-- This is implemented using a database cursor. As such, this requires

425−-- a transaction. This function will detect whether or not there is a

426−-- transaction in progress, and will create a 'ReadCommitted' 'ReadOnly'

427−-- transaction if needed. The cursor is given a unique temporary name,

428−-- so the consumer may itself call fold.

429−--

430-- Exceptions that may be thrown:

404-- Exceptions that may be thrown:

431--

405--

432-- * 'FormatError': the query string could not be formatted correctly.

406-- * 'FormatError': the query string could not be formatted correctly.

@@ -435,9 +409,7 @@ queryWith_ parser conn q@(Query que) = do

435-- using 'execute' instead of 'query').

409-- using 'execute' instead of 'query').

436--

410--

437-- * 'ResultError': result conversion failed.

411-- * 'ResultError': result conversion failed.

438−--

412+

439−-- * 'SqlError': the postgresql backend returned an error, e.g.

440−-- a syntax or type error, or an incorrect table or column name.

441fold :: ( FromRow row, ToRow params )

413fold :: ( FromRow row, ToRow params )

442 => Connection

414 => Connection

443 -> Query

415 -> Query

@@ -447,20 +419,6 @@ fold :: ( FromRow row, ToRow params )

447 -> IO a

419 -> IO a

448fold = foldWithOptions defaultFoldOptions

420fold = foldWithOptions defaultFoldOptions

449

421

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

451−foldWith :: ( ToRow params )

452− => RowParser row

453− -> Connection

454− -> Query

455− -> params

456− -> a

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

458− -> IO a

459−foldWith = foldWithOptionsAndParser defaultFoldOptions

460−

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

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

463−-- based on e.g. the average size of the rows.

464data FetchQuantity

422data FetchQuantity

465 = Automatic

423 = Automatic

466 | Fixed !Int

424 | Fixed !Int

@@ -471,19 +429,12 @@ data FoldOptions

471 transactionMode :: !TransactionMode

429 transactionMode :: !TransactionMode

472 }

430 }

473

431

474−-- | defaults to 'Automatic', and 'TransactionMode' 'ReadCommitted' 'ReadOnly'

475defaultFoldOptions :: FoldOptions

432defaultFoldOptions :: FoldOptions

476defaultFoldOptions = FoldOptions {

433defaultFoldOptions = FoldOptions {

477 fetchQuantity = Automatic,

434 fetchQuantity = Automatic,

478 transactionMode = TransactionMode ReadCommitted ReadOnly

435 transactionMode = TransactionMode ReadCommitted ReadOnly

479 }

436 }

480

437

481−-- | The same as 'fold', but this provides a bit more control over

482−-- lower-level details. Currently, the number of rows fetched per

483−-- round-trip to the server and the transaction mode may be adjusted

484−-- accordingly. If the connection is already in a transaction,

485−-- then the existing transaction is used and thus the 'transactionMode'

486−-- option is ignored.

487foldWithOptions :: ( FromRow row, ToRow params )

438foldWithOptions :: ( FromRow row, ToRow params )

488 => FoldOptions

439 => FoldOptions

489 -> Connection

440 -> Connection

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

492 -> a

443 -> a

493 -> (a -> row -> IO a)

444 -> (a -> row -> IO a)

494 -> IO a

445 -> IO a

495−foldWithOptions opts = foldWithOptionsAndParser opts fromRow

446+foldWithOptions opts conn template qs a f = do

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

508 q <- formatQuery conn template qs

447 q <- formatQuery conn template qs

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

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

510

449

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

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

512fold_ :: (FromRow r) =>

451fold_ :: (FromRow r) =>

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

517 -> IO a

456 -> IO a

518fold_ = foldWithOptions_ defaultFoldOptions

457fold_ = foldWithOptions_ defaultFoldOptions

519

458

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

528

459

529foldWithOptions_ :: (FromRow r) =>

460foldWithOptions_ :: (FromRow r) =>

530 FoldOptions

461 FoldOptions

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

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

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

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

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

535 -> IO a

466 -> IO a

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

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

537−

468+

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

469+

539−foldWithOptionsAndParser_ :: FoldOptions

470+doFold :: ( FromRow row )

540− -> RowParser r

471+ => FoldOptions

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

550 -> Connection

472 -> Connection

551 -> Query

473 -> Query

552 -> Query

474 -> Query

553 -> a

475 -> a

554 -> (a -> row -> IO a)

476 -> (a -> row -> IO a)

555 -> IO a

477 -> IO a

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

478+doFold FoldOptions{..} conn _template q a f = do

557 stat <- withConnection conn PQ.transactionStatus

479 stat <- withConnection conn PQ.transactionStatus

558 case stat of

480 case stat of

559 PQ.TransIdle -> withTransactionMode transactionMode conn go

481 PQ.TransIdle -> withTransactionMode transactionMode conn go

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

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

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

572 -- Not sure what this means.

494 -- Not sure what this means.

573 where

495 where

574− declare =

496+ go = do

575− declareCursor conn q

497+ -- FIXME: what about name clashes with already-declared cursors?

576− fetch cursor a =

498+ _ <- execute_ conn ("DECLARE fold NO SCROLL CURSOR FOR "

577− foldForwardWithParser cursor parser chunkSize f a

499+ `mappend` q)

578−

500+ loop a `finally` execute_ conn "CLOSE fold"

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

585

501

586-- FIXME: choose the Automatic chunkSize more intelligently

502-- FIXME: choose the Automatic chunkSize more intelligently

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

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

@@ -592,6 +508,9 @@ doFold FoldOptions{..} parser conn _template q a0 f = do

592 chunkSize = case fetchQuantity of

508 chunkSize = case fetchQuantity of

593 Automatic -> 256

509 Automatic -> 256

594 Fixed n -> n

510 Fixed n -> n

511+ loop a = do

512+ rs <- query conn "FETCH FORWARD ? FROM fold" (Only chunkSize)

513+ if null rs then return a else foldM f a rs >>= loop

595

514

596-- | A version of 'fold' that does not transform a state value.

515-- | A version of 'fold' that does not transform a state value.

597forEach :: (ToRow q, FromRow r) =>

516forEach :: (ToRow q, FromRow r) =>

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

600 -> q -- ^ Query parameters.

519 -> q -- ^ Query parameters.

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

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

602 -> IO ()

521 -> IO ()

603−forEach = forEachWith fromRow

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

604{-# INLINE forEach #-}

523{-# INLINE forEach #-}

605

524

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−

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

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

618forEach_ :: (FromRow r) =>

526forEach_ :: (FromRow r) =>

619 Connection

527 Connection

620 -> Query -- ^ Query template.

528 -> Query -- ^ Query template.

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

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

622 -> IO ()

530 -> IO ()

623−forEach_ = forEachWith_ fromRow

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

624{-# INLINE forEach_ #-}

532{-# INLINE forEach_ #-}

625

533

626−forEachWith_ :: RowParser r

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

627− -> Connection

535+forM' lo hi m = loop hi []

628− -> Query

536+ where

629− -> (r -> IO ())

537+ loop !n !as

630− -> IO ()

538+ | n < lo = return as

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

539+ | otherwise = do

632−{-# INLINE forEachWith_ #-}

540+ a <- m n

633−

541+ loop (n-1) (a:as)

542+

543+finishQuery :: (FromRow r) => Connection -> Query -> PQ.Result -> IO [r]

544+finishQuery conn q result = do

545+ status <- PQ.resultStatus result

546+ case status of

547+ PQ.EmptyQuery ->

548+ throwIO $ QueryError "query: Empty query" q

549+ PQ.CommandOk -> do

550+ throwIO $ QueryError "query resulted in a command response" q

551+ PQ.TuplesOk -> do

552+ ncols <- PQ.nfields result

553+ let unCol (PQ.Col x) = fromIntegral x :: Int

554+ typenames <- V.generateM (unCol ncols)

555+ (\(PQ.Col . fromIntegral -> col) -> do

556+ getTypename conn =<< PQ.ftype result col)

557+ nrows <- PQ.ntuples result

558+ ncols <- PQ.nfields result

559+ forM' 0 (nrows-1) $ \row -> do

560+ let rw = Row row typenames result

561+ case runStateT (runReaderT (unRP fromRow) rw) 0 of

562+ Ok (val,col) | col == ncols -> return val

563+ | otherwise -> do

564+ vals <- forM' 0 (ncols-1) $ \c -> do

565+ v <- PQ.getvalue result row c

566+ return ( typenames V.! unCol c

567+ , fmap ellipsis v )

568+ throw (ConversionFailed

569+ (show (unCol ncols) ++ " values: " ++ show vals)

570+ (show (unCol col) ++ " slots in target type")

571+ "mismatch between number of columns to \

572+ \convert and number in target type")

573+ Errors [] -> throwIO $ ConversionFailed "" "" "unknown error"

574+ Errors [x] -> throwIO x

575+ Errors xs -> throwIO $ ManyErrors xs

576+ PQ.CopyOut ->

577+ throwIO $ QueryError "query: COPY TO is not supported" q

578+ PQ.CopyIn ->

579+ throwIO $ QueryError "query: COPY FROM is not supported" q

580+ PQ.BadResponse -> throwResultError "query" result status

581+ PQ.NonfatalError -> throwResultError "query" result status

582+ PQ.FatalError -> throwResultError "query" result status

583+

584+ellipsis :: ByteString -> ByteString

585+ellipsis bs

586+ | B.length bs > 15 = B.take 10 bs `B.append` "[...]"

587+ | otherwise = bs

588+

589+

590+-- | Of the four isolation levels defined by the SQL standard,

591+-- these are the three levels distinguished by PostgreSQL as of version 9.0.

592+-- See <http://www.postgresql.org/docs/9.1/static/transaction-iso.html>

593+-- for more information. Note that prior to PostgreSQL 9.0, 'RepeatableRead'

594+-- was equivalent to 'Serializable'.

595+

596+data IsolationLevel

597+ = DefaultIsolationLevel -- ^ the isolation level will be taken from

598+ -- PostgreSQL's per-connection

599+ -- @default_transaction_isolation@ variable,

600+ -- which is initialized according to the

601+ -- server's config. The default configuration

602+ -- is 'ReadCommitted'.

603+ | ReadCommitted

604+ | RepeatableRead

605+ | Serializable

606+ deriving (Show, Eq, Ord, Enum, Bounded)

607+

608+data ReadWriteMode

609+ = DefaultReadWriteMode -- ^ the read-write mode will be taken from

610+ -- PostgreSQL's per-connection

611+ -- @default_transaction_read_only@ variable,

612+ -- which is initialized according to the

613+ -- server's config. The default configuration

614+ -- is 'ReadWrite'.

615+ | ReadWrite

616+ | ReadOnly

617+ deriving (Show, Eq, Ord, Enum, Bounded)

618+

619+data TransactionMode = TransactionMode {

620+ isolationLevel :: !IsolationLevel,

621+ readWriteMode :: !ReadWriteMode

622+ } deriving (Show, Eq)

623+

624+defaultTransactionMode :: TransactionMode

625+defaultTransactionMode = TransactionMode

626+ defaultIsolationLevel

627+ defaultReadWriteMode

628+

629+defaultIsolationLevel :: IsolationLevel

630+defaultIsolationLevel = DefaultIsolationLevel

631+

632+defaultReadWriteMode :: ReadWriteMode

633+defaultReadWriteMode = DefaultReadWriteMode

634+

635+-- | Execute an action inside a SQL transaction.

636+--

637+-- This function initiates a transaction with a \"@begin

638+-- transaction@\" statement, then executes the supplied action. If

639+-- the action succeeds, the transaction will be completed with

640+-- 'Base.commit' before this function returns.

641+--

642+-- If the action throws /any/ kind of exception (not just a

643+-- PostgreSQL-related exception), the transaction will be rolled back using

644+-- 'rollback', then the exception will be rethrown.

645+withTransaction :: Connection -> IO a -> IO a

646+withTransaction = withTransactionMode defaultTransactionMode

647+

648+-- | Execute an action inside of a 'Serializable' transaction. If a

649+-- serialization failure occurs, roll back the transaction and try again.

650+-- Be warned that this may execute the IO action multiple times.

651+--

652+-- More precisely, if a 'SqlError' arises whose 'sqlState' is @\"40001\"@

653+-- (@serialization_failure@), this will issue a @ROLLBACK@, then try the action

654+-- again. If any other exception arises, this will issue a @ROLLBACK@, but

655+-- will propagate the exception instead of retrying.

656+--

657+-- A 'Serializable' transaction creates the illusion that your program has

658+-- exclusive access to the database. This means that, even in a concurrent

659+-- setting, you can perform queries in sequence without having to worry about

660+-- what might happen between one statement and the next.

661+--

662+-- Think of it as STM, but without @retry@.

663+withTransactionSerializable :: ReadWriteMode -> Connection -> IO a -> IO a

664+withTransactionSerializable readWriteMode conn act =

665+ mask $ \restore ->

666+ retryLoop $ try $ do

667+ a <- restore act

668+ commit conn

669+ return a

670+ where

671+ retryLoop :: IO (Either SomeException a) -> IO a

672+ retryLoop act' = do

673+ beginMode mode conn

674+ r <- act'

675+ case r of

676+ Left e -> do

677+ rollback conn

678+ case fromException e of

679+ Just SqlError{..} | sqlState == serialization_failure

680+ -> retryLoop act'

681+ _ -> throwIO e

682+ Right a ->

683+ return a

684+

685+ mode = TransactionMode

686+ { isolationLevel = Serializable

687+ , readWriteMode

688+ }

689+

690+ -- http://www.postgresql.org/docs/current/static/errcodes-appendix.html

691+ serialization_failure = "40001"

692+

693+-- | Execute an action inside a SQL transaction with a given isolation level.

694+withTransactionLevel :: IsolationLevel -> Connection -> IO a -> IO a

695+withTransactionLevel lvl

696+ = withTransactionMode defaultTransactionMode { isolationLevel = lvl }

697+

698+-- | Execute an action inside a SQL transaction with a given transaction mode.

699+withTransactionMode :: TransactionMode -> Connection -> IO a -> IO a

700+withTransactionMode mode conn act =

701+ mask $ \restore -> do

702+ beginMode mode conn

703+ r <- restore act `onException` rollback conn

704+ commit conn

705+ return r

706+

707+-- | Rollback a transaction.

708+rollback :: Connection -> IO ()

709+rollback conn = execute_ conn "ABORT" >> return ()

710+

711+-- | Commit a transaction.

712+commit :: Connection -> IO ()

713+commit conn = execute_ conn "COMMIT" >> return ()

714+

715+-- | Begin a transaction.

716+begin :: Connection -> IO ()

717+begin = beginMode defaultTransactionMode

718+

719+-- | Begin a transaction with a given isolation level

720+beginLevel :: IsolationLevel -> Connection -> IO ()

721+beginLevel lvl = beginMode defaultTransactionMode { isolationLevel = lvl }

722+

723+-- | Begin a transaction with a given transaction mode

724+beginMode :: TransactionMode -> Connection -> IO ()

725+beginMode mode conn = do

726+ _ <- execute_ conn $! Query (B.concat ["BEGIN", isolevel, readmode])

727+ return ()

728+ where

729+ isolevel = case isolationLevel mode of

730+ DefaultIsolationLevel -> ""

731+ ReadCommitted -> " ISOLATION LEVEL READ COMMITTED"

732+ RepeatableRead -> " ISOLATION LEVEL REPEATABLE READ"

733+ Serializable -> " ISOLATION LEVEL SERIALIZABLE"

734+ readmode = case readWriteMode mode of

735+ DefaultReadWriteMode -> ""

736+ ReadWrite -> " READ WRITE"

737+ ReadOnly -> " READ ONLY"

738+

739+fmtError :: String -> Query -> [Action] -> a

740+fmtError msg q xs = throw FormatError {

741+ fmtMessage = msg

742+ , fmtQuery = q

743+ , fmtParams = map twiddle xs

744+ }

745+ where twiddle (Plain b) = toByteString b

746+ twiddle (Escape s) = s

747+ twiddle (EscapeByteA s) = s

748+ twiddle (Many ys) = B.concat (map twiddle ys)

634

749

635-- $use

750-- $use

636--

751--

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

658-- >

773-- >

659-- > import Database.PostgreSQL.Simple

774-- > import Database.PostgreSQL.Simple

660-- >

775-- >

661−-- > hello :: IO Int

662-- > hello = do

776-- > hello = do

663−-- > conn <- connectPostgreSQL ""

777+-- > conn <- connect defaultConnectInfo

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

778+-- > query conn "select 2 + 2"

665−-- > return i

666--

779--

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

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

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

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

@@ -723,30 +836,15 @@ forEachWith_ parser conn template = foldWith_ parser conn template () . const

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

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

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

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

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

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

740

839

741-- $only_param

840-- $only_param

742--

841--

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

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

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

745−-- what should you do?

746--

844--

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

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

748--

846--

749−-- > instance (ToField a) => ToRow a where

847+-- > instance (Param a) => QueryParam a where

750-- > ...

848-- > ...

751--

849--

752-- Unfortunately, this wreaks havoc with type inference, so we take a

850-- Unfortunately, this wreaks havoc with type inference, so we take a

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

757--

855--

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

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

759-- > ["Nuala"]

857-- > ["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.

763

858

764-- $in

859-- $in

765--

860--

@@ -777,7 +872,7 @@ forEachWith_ parser conn template = foldWith_ parser conn template () . const

777-- Here's an example:

872-- Here's an example:

778--

873--

779-- > query conn "select * from users where first_name in ?" $

874-- > query conn "select * from users where first_name in ?" $

780−-- > Only $ In ["Anna", "Boris", "Carla"]

875+-- > In ["Anna", "Boris", "Carla"]

781--

876--

782-- If your 'In'-wrapped list is empty, the string @\"(null)\"@ will be

877-- If your 'In'-wrapped list is empty, the string @\"(null)\"@ will be

783-- substituted instead, to ensure that your clause remains

878-- substituted instead, to ensure that your clause remains

@@ -805,7 +900,7 @@ forEachWith_ parser conn template = foldWith_ parser conn template () . const

805-- * There must be no other \"@?@\" characters anywhere in your

900-- * There must be no other \"@?@\" characters anywhere in your

806-- template.

901-- template.

807--

902--

808−-- * There must be one or more \"@?@\" in the parentheses.

903+-- * There must one or more \"@?@\" in the parentheses.

809--

904--

810-- * Extra white space is fine.

905-- * Extra white space is fine.

811--

906--

@@ -828,10 +923,9 @@ forEachWith_ parser conn template = foldWith_ parser conn template () . const

828

923

829-- $returning

924-- $returning

830--

925--

831−-- PostgreSQL supports returning values from data manipulation statements

926+-- The 'returning' function is similar to 'executeMany' but is

832−-- such as @INSERT@ and @UPDATE@. You can use these statements by

927+-- intended for use with multi-tuple @INSERT@ or @UPDATE@ statements

833−-- using 'query' instead of 'execute'. For multi-tuple inserts,

928+-- that make use of @RETURNING@.

834−-- use 'returning' instead of 'executeMany'.

835--

929--

836-- For example, were there an auto-incrementing @id@ column and

930-- For example, were there an auto-incrementing @id@ column and

837-- timestamp column @t@ that defaulted to the present time for the

931-- timestamp column @t@ that defaulted to the present time for the

@@ -839,8 +933,7 @@ forEachWith_ parser conn template = foldWith_ parser conn template () . const

839-- sales records and also return their new @id@s and timestamps.

933-- sales records and also return their new @id@s and timestamps.

840--

934--

841-- > let q = "insert into sales (amount, label) values (?,?) returning id, t"

935-- > let q = "insert into sales (amount, label) values (?,?) returning id, t"

842−-- > xs :: [(Int, UTCTime)] <- query conn q (15,"Sawdust")

843−-- > ys :: [(Int, UTCTime)] <- returning conn q [(20,"Chips"),(300,"Wood")]

936+-- > xs :: [(Int, UTCTime)] <- returning conn q [(20,"Chips"),(300,"Wood")]

844

937

845-- $result

938-- $result

846--

939--

@@ -876,7 +969,7 @@ forEachWith_ parser conn template = foldWith_ parser conn template () . const

876--

969--

877-- Although SQL can accommodate @NULL@ as a value for any of these

970-- Although SQL can accommodate @NULL@ as a value for any of these

878-- types, Haskell cannot. If your result contains columns that may be

971-- types, Haskell cannot. If your result contains columns that may be

879−-- @NULL@, be sure that you use 'Maybe' in those positions of your

972+-- @NULL@, be sure that you use 'Maybe' in those positions of of your

880-- tuple.

973-- tuple.

881--

974--

882-- > (Text, Maybe Int, Int)

975-- > (Text, Maybe Int, Int)

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

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

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

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

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

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

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

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

998+-- represent a @SMALLINT@, so it is considered compatble with those types.

906--

999--

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

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

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

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

@@ -916,3 +1009,25 @@ forEachWith_ parser conn template = foldWith_ parser conn template () . const

916-- UTF-8. If you use some other encoding, decoding may fail or give

1009-- UTF-8. If you use some other encoding, decoding may fail or give

917-- wrong results. In such cases, write a @newtype@ wrapper and a

1010-- wrong results. In such cases, write a @newtype@ wrapper and a

918-- custom 'Result' instance to handle your encoding.

1011-- custom 'Result' instance to handle your encoding.

1012+

1013+getTypename :: Connection -> PQ.Oid -> IO ByteString

1014+getTypename conn@Connection{..} oid =

1015+ case oid2typname oid of

1016+ Just name -> return name

1017+ Nothing -> modifyMVar connectionObjects $ \oidmap -> do

1018+ case IntMap.lookup (oid2int oid) oidmap of

1019+ Just name -> return (oidmap, name)

1020+ Nothing -> do

1021+ names <- query conn "SELECT typname FROM pg_type WHERE oid=?"

1022+ (Only oid)

1023+ name <- case names of

1024+ [] -> return $ throw SqlError {

1025+ sqlNativeError = -1,

1026+ sqlErrorMsg = "invalid type oid",

1027+ sqlState = ""

1028+ }

1029+ [Only x] -> return x

1030+ _ -> fail "typename query returned more than one result"

1031+ -- oid is a primary key, so the query should

1032+ -- never return more than one result

1033+ return (IntMap.insert (oid2int oid) name oidmap, name)

src/Database/PostgreSQL/Simple.hs-bootdeleted−23

@@ -1,23 +0,0 @@

1−module Database.PostgreSQL.Simple

2− ( Connection

3− , Query

4− , query

5− , query_

6− , execute

7− , execute_

8− , executeMany

9− ) where

10−

11−import Data.Int(Int64)

12−import Database.PostgreSQL.Simple.Internal

13−import Database.PostgreSQL.Simple.Types

14−import {-# SOURCE #-} Database.PostgreSQL.Simple.FromRow

15−import {-# SOURCE #-} Database.PostgreSQL.Simple.ToRow

16−

17−query :: (ToRow q, FromRow r) => Connection -> Query -> q -> IO [r]

18−

19−query_ :: FromRow r => Connection -> Query -> IO [r]

20−

21−execute :: ToRow q => Connection -> Query -> q -> IO Int64

22−

23−executeMany :: ToRow q => Connection -> Query -> [q] -> IO Int64

src/Database/PostgreSQL/Simple/Arrays.hsdeleted−92

@@ -1,92 +0,0 @@

1−{-# LANGUAGE PatternGuards #-}

2−

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

4−-- |

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

7−-- License: BSD3

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

9−-- Stability: experimental

10−--

11−-- A Postgres array parser and pretty-printer.

12−------------------------------------------------------------------------------

13−

14−module Database.PostgreSQL.Simple.Arrays where

15−

16−import Control.Applicative (Applicative(..), Alternative(..), (<$>))

17−import Data.ByteString.Char8 (ByteString)

18−import qualified Data.ByteString.Char8 as B

19−import Data.Monoid

20−import Data.Attoparsec.ByteString.Char8

21−

22−

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

24−arrayFormat :: Char -> Parser ArrayFormat

25−arrayFormat delim = Array <$> array delim

26− <|> Plain <$> plain delim

27− <|> Quoted <$> quoted

28−

29−data ArrayFormat = Array [ArrayFormat]

30− | Plain ByteString

31− | Quoted ByteString

32− deriving (Eq, Show, Ord)

33−

34−array :: Char -> Parser [ArrayFormat]

35−array delim = char '{' *> option [] (arrays <|> strings) <* char '}'

36− where

37− strings = sepBy1 (Quoted <$> quoted <|> Plain <$> plain delim) (char delim)

38− arrays = sepBy1 (Array <$> array delim) (char ',')

39− -- NB: Arrays seem to always be delimited by commas.

40−

41−-- | Recognizes a quoted string.

42−quoted :: Parser ByteString

43−quoted = char '"' *> option "" contents <* char '"'

44− where

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

46− unQ = takeWhile1 (notInClass "\"\\")

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

48−

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

50−-- not containing the delimiter character.

51−plain :: Char -> Parser ByteString

52−plain delim = takeWhile1 (notInClass (delim:"\"{}"))

53−

54−-- Mutually recursive 'fmt' and 'delimit' separate out value formatting

55−-- from the subtleties of delimiting.

56−

57−-- | Format an array format item, using the delimiter character if the item is

58−-- itself an array.

59−fmt :: Char -> ArrayFormat -> ByteString

60−fmt = fmt' False

61−

62−-- | Format a list of array format items, inserting the appropriate delimiter

63−-- between them. When the items are arrays, they will be delimited with

64−-- commas; otherwise, they are delimited with the passed-in-delimiter.

65−delimit :: Char -> [ArrayFormat] -> ByteString

66−delimit _ [] = ""

67−delimit c [x] = fmt' True c x

68−delimit c (x:y:z) = (fmt' True c x `B.snoc` c') `mappend` delimit c (y:z)

69− where

70− c' | Array _ <- x = ','

71− | otherwise = c

72−

73−-- | Format an array format item, using the delimiter character if the item is

74−-- itself an array, optionally applying quoting rules. Creates copies for

75−-- safety when used in 'FromField' instances.

76−fmt' :: Bool -> Char -> ArrayFormat -> ByteString

77−fmt' quoting c x =

78− case x of

79− Array items -> '{' `B.cons` (delimit c items `B.snoc` '}')

80− Plain bytes -> B.copy bytes

81− Quoted q | quoting -> '"' `B.cons` (esc q `B.snoc` '"')

82− | otherwise -> B.copy q

83− -- NB: The 'snoc' and 'cons' functions always copy.

84−

85−-- | Escape a string according to Postgres double-quoted string format.

86−esc :: ByteString -> ByteString

87−esc = B.concatMap f

88− where

89− f '"' = "\\\""

90− f '\\' = "\\\\"

91− f c = B.singleton c

92− -- TODO: Implement easy performance improvements with unfoldr.

src/Database/PostgreSQL/Simple/BuiltinTypes.hsnew file+411

@@ -0,0 +1,411 @@

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+ ( BuiltinType (..)

18+ , builtin2oid

19+ , oid2builtin

20+ , builtin2typname

21+ , oid2typname

22+ ) where

23+

24+import Data.Typeable

25+import Data.ByteString (ByteString)

26+import qualified Database.PostgreSQL.LibPQ as PQ

27+

28+data BuiltinType

29+ = Bool

30+ | ByteA

31+ | Char

32+ | Name

33+ | Int8

34+ | Int2

35+ | Int4

36+ | RegProc

37+ | Text

38+ | Oid

39+ | Tid

40+ | Xid

41+ | Cid

42+ | Xml

43+ | Point

44+ | LSeg

45+ | Path

46+ | Box

47+ | Polygon

48+ | Line

49+ | Cidr

50+ | Float4

51+ | Float8

52+ | AbsTime

53+ | RelTime

54+ | TInterval

55+ | Unknown

56+ | Circle

57+ | Money

58+ | MacAddr

59+ | Inet

60+ | BpChar

61+ | VarChar

62+ | Date

63+ | Time

64+ | Timestamp

65+ | TimestampTZ

66+ | Interval

67+ | TimeTZ

68+ | Bit

69+ | VarBit

70+ | Numeric

71+ | RefCursor

72+ | Record

73+ | Void

74+ | UUID

75+ deriving (Eq, Ord, Enum, Bounded, Read, Show, Typeable)

76+

77+builtin2oid :: BuiltinType -> PQ.Oid

78+builtin2oid typ = PQ.Oid $ case typ of

79+ Bool -> 16

80+ ByteA -> 17

81+ Char -> 18

82+ Name -> 19

83+ Int8 -> 20

84+ Int2 -> 21

85+ Int4 -> 23

86+ RegProc -> 24

87+ Text -> 25

88+ Oid -> 26

89+ Tid -> 27

90+ Xid -> 28

91+ Cid -> 29

92+ Xml -> 142

93+ Point -> 600

94+ LSeg -> 601

95+ Path -> 602

96+ Box -> 603

97+ Polygon -> 604

98+ Line -> 628

99+ Cidr -> 650

100+ Float4 -> 700

101+ Float8 -> 701

102+ AbsTime -> 702

103+ RelTime -> 703

104+ TInterval -> 704

105+ Unknown -> 705

106+ Circle -> 718

107+ Money -> 790

108+ MacAddr -> 829

109+ Inet -> 869

110+ BpChar -> 1042

111+ VarChar -> 1043

112+ Date -> 1082

113+ Time -> 1083

114+ Timestamp -> 1114

115+ TimestampTZ -> 1184

116+ Interval -> 1186

117+ TimeTZ -> 1266

118+ Bit -> 1560

119+ VarBit -> 1562

120+ Numeric -> 1700

121+ RefCursor -> 1790

122+ Record -> 2249

123+ Void -> 2278

124+ UUID -> 2950

125+

126+oid2builtin :: PQ.Oid -> Maybe BuiltinType

127+oid2builtin (PQ.Oid x) = case x of

128+ 16 -> Just Bool

129+ 17 -> Just ByteA

130+ 18 -> Just Char

131+ 19 -> Just Name

132+ 20 -> Just Int8

133+ 21 -> Just Int2

134+ 23 -> Just Int4

135+ 24 -> Just RegProc

136+ 25 -> Just Text

137+ 26 -> Just Oid

138+ 27 -> Just Tid

139+ 28 -> Just Xid

140+ 29 -> Just Cid

141+ 142 -> Just Xml

142+ 600 -> Just Point

143+ 601 -> Just LSeg

144+ 602 -> Just Path

145+ 603 -> Just Box

146+ 604 -> Just Polygon

147+ 628 -> Just Line

148+ 650 -> Just Cidr

149+ 700 -> Just Float4

150+ 701 -> Just Float8

151+ 702 -> Just AbsTime

152+ 703 -> Just RelTime

153+ 704 -> Just TInterval

154+ 705 -> Just Unknown

155+ 718 -> Just Circle

156+ 790 -> Just Money

157+ 829 -> Just MacAddr

158+ 869 -> Just Inet

159+ 1042 -> Just BpChar

160+ 1043 -> Just VarChar

161+ 1082 -> Just Date

162+ 1083 -> Just Time

163+ 1114 -> Just Timestamp

164+ 1184 -> Just TimestampTZ

165+ 1186 -> Just Interval

166+ 1266 -> Just TimeTZ

167+ 1560 -> Just Bit

168+ 1562 -> Just VarBit

169+ 1700 -> Just Numeric

170+ 1790 -> Just RefCursor

171+ 2249 -> Just Record

172+ 2278 -> Just Void

173+ 2950 -> Just UUID

174+ _ -> Nothing

175+

176+builtin2typname :: BuiltinType -> ByteString

177+builtin2typname typ = case typ of

178+ Bool -> bool

179+ ByteA -> bytea

180+ Char -> char

181+ Name -> name

182+ Int8 -> int8

183+ Int2 -> int2

184+ Int4 -> int4

185+ RegProc -> regproc

186+ Text -> text

187+ Oid -> oid

188+ Tid -> tid

189+ Xid -> xid

190+ Cid -> cid

191+ Xml -> xml

192+ Point -> point

193+ LSeg -> lseg

194+ Path -> path

195+ Box -> box

196+ Polygon -> polygon

197+ Line -> line

198+ Cidr -> cidr

199+ Float4 -> float4

200+ Float8 -> float8

201+ AbsTime -> abstime

202+ RelTime -> reltime

203+ TInterval -> tinterval

204+ Unknown -> unknown

205+ Circle -> circle

206+ Money -> money

207+ MacAddr -> macaddr

208+ Inet -> inet

209+ BpChar -> bpchar

210+ VarChar -> varchar

211+ Date -> date

212+ Time -> time

213+ Timestamp -> timestamp

214+ TimestampTZ -> timestamptz

215+ Interval -> interval

216+ TimeTZ -> timetz

217+ Bit -> bit

218+ VarBit -> varbit

219+ Numeric -> numeric

220+ RefCursor -> refcursor

221+ Record -> record

222+ Void -> void

223+ UUID -> uuid

224+

225+oid2typname :: PQ.Oid -> Maybe ByteString

226+oid2typname (PQ.Oid x) = case x of

227+ 16 -> Just bool

228+ 17 -> Just bytea

229+ 18 -> Just char

230+ 19 -> Just name

231+ 20 -> Just int8

232+ 21 -> Just int2

233+ 23 -> Just int4

234+ 24 -> Just regproc

235+ 25 -> Just text

236+ 26 -> Just oid

237+ 27 -> Just tid

238+ 28 -> Just xid

239+ 29 -> Just cid

240+ 142 -> Just xml

241+ 600 -> Just point

242+ 601 -> Just lseg

243+ 602 -> Just path

244+ 603 -> Just box

245+ 604 -> Just polygon

246+ 628 -> Just line

247+ 650 -> Just cidr

248+ 700 -> Just float4

249+ 701 -> Just float8

250+ 702 -> Just abstime

251+ 703 -> Just reltime

252+ 704 -> Just tinterval

253+ 705 -> Just unknown

254+ 718 -> Just circle

255+ 790 -> Just money

256+ 829 -> Just macaddr

257+ 869 -> Just inet

258+ 1042 -> Just bpchar

259+ 1043 -> Just varchar

260+ 1082 -> Just date

261+ 1083 -> Just time

262+ 1114 -> Just timestamp

263+ 1184 -> Just timestamptz

264+ 1186 -> Just interval

265+ 1266 -> Just timetz

266+ 1560 -> Just bit

267+ 1562 -> Just varbit

268+ 1700 -> Just numeric

269+ 1790 -> Just refcursor

270+ 2249 -> Just record

271+ 2278 -> Just void

272+ 2950 -> Just uuid

273+ _ -> Nothing

274+

275+bool :: ByteString

276+bool = "bool"

277+

278+bytea :: ByteString

279+bytea = "bytea"

280+

281+char :: ByteString

282+char = "char"

283+

284+name :: ByteString

285+name = "name"

286+

287+int8 :: ByteString

288+int8 = "int8"

289+

290+int2 :: ByteString

291+int2 = "int2"

292+

293+int4 :: ByteString

294+int4 = "int4"

295+

296+regproc :: ByteString

297+regproc = "regproc"

298+

299+text :: ByteString

300+text = "text"

301+

302+oid :: ByteString

303+oid = "oid"

304+

305+tid :: ByteString

306+tid = "tid"

307+

308+xid :: ByteString

309+xid = "xid"

310+

311+cid :: ByteString

312+cid = "cid"

313+

314+xml :: ByteString

315+xml = "xml"

316+

317+point :: ByteString

318+point = "point"

319+

320+lseg :: ByteString

321+lseg = "lseg"

322+

323+path :: ByteString

324+path = "path"

325+

326+box :: ByteString

327+box = "box"

328+

329+polygon :: ByteString

330+polygon = "polygon"

331+

332+line :: ByteString

333+line = "line"

334+

335+cidr :: ByteString

336+cidr = "cidr"

337+

338+float4 :: ByteString

339+float4 = "float4"

340+

341+float8 :: ByteString

342+float8 = "float8"

343+

344+abstime :: ByteString

345+abstime = "abstime"

346+

347+reltime :: ByteString

348+reltime = "reltime"

349+

350+tinterval :: ByteString

351+tinterval = "tinterval"

352+

353+unknown :: ByteString

354+unknown = "unknown"

355+

356+circle :: ByteString

357+circle = "circle"

358+

359+money :: ByteString

360+money = "money"

361+

362+macaddr :: ByteString

363+macaddr = "macaddr"

364+

365+inet :: ByteString

366+inet = "inet"

367+

368+bpchar :: ByteString

369+bpchar = "bpchar"

370+

371+varchar :: ByteString

372+varchar = "varchar"

373+

374+date :: ByteString

375+date = "date"

376+

377+time :: ByteString

378+time = "time"

379+

380+timestamp :: ByteString

381+timestamp = "timestamp"

382+

383+timestamptz :: ByteString

384+timestamptz = "timestamptz"

385+

386+interval :: ByteString

387+interval = "interval"

388+

389+timetz :: ByteString

390+timetz = "timetz"

391+

392+bit :: ByteString

393+bit = "bit"

394+

395+varbit :: ByteString

396+varbit = "varbit"

397+

398+numeric :: ByteString

399+numeric = "numeric"

400+

401+refcursor :: ByteString

402+refcursor = "refcursor"

403+

404+record :: ByteString

405+record = "record"

406+

407+void :: ByteString

408+void = "void"

409+

410+uuid :: ByteString

411+uuid = "uuid"

src/Database/PostgreSQL/Simple/Compat.hs+8−24

@@ -1,24 +1,11 @@

1{-# LANGUAGE CPP #-}

2−-- | This is a module of its own, partly because it uses the CPP extension,

2+-- | This is a module of its own, because it uses the CPP extension, which

3−-- which doesn't play well with backslash-broken string literals.

3+-- doesn't play well with the regex string literal in Simple.hs .

4module Database.PostgreSQL.Simple.Compat

5 ( mask

6− , (<>)

7− , unsafeDupablePerformIO

8− , toByteString

9− , scientificBuilder

10− , toPico

11− , fromPico

12 ) where

6 ) where

14import qualified Control.Exception as E

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

19−import System.IO.Unsafe (unsafeDupablePerformIO)

20−import Data.Fixed (Pico)

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

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

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

24--

11--

@@ -28,14 +15,11 @@ import Data.Fixed (Fixed(MkFixed))

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

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

29-- don't need that polymorphism.

16-- don't need that polymorphism.

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

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

18+#if MIN_VERSION_base(4,3,0)

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

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

20+#else

21+mask io = do

22+ b <- E.blocked

23+ E.block $ io $ \m -> if b then m else E.unblock m

24+#endif

32{-# INLINE mask #-}

25{-# INLINE mask #-}

33−

34−toByteString :: Builder -> ByteString

35−toByteString x = toStrict (toLazyByteString x)

36−

37−toPico :: Integer -> Pico

38−toPico = MkFixed

39−

40−fromPico :: Pico -> Integer

41−fromPico (MkFixed i) = i

src/Database/PostgreSQL/Simple/Copy.hsdeleted−269

@@ -1,269 +0,0 @@

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

2−

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

4−-- |

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

7−-- License: BSD3

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

9−-- Stability: experimental

10−--

11−-- mid-level support for COPY IN and COPY OUT. See

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

13−-- more information.

14−--

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

16−-- query as documented in the link above. Then, in the case of a

17−-- @COPY TO STDOUT@ query, call 'getCopyData' repeatedly until it

18−-- returns 'CopyOutDone'. In the case of a @COPY FROM STDIN@

19−-- query, call 'putCopyData' repeatedly and then finish by calling

20−-- either 'putCopyEnd' to proceed or 'putCopyError' to abort.

21−--

22−-- You cannot issue another query on the same connection while a copy

23−-- is ongoing; this will result in an exception. It is harmless to

24−-- concurrently call @getNotification@ on a connection while it is in

25−-- a @CopyIn@ or @CopyOut@ state, however be aware that current versions

26−-- of the PostgreSQL backend will not deliver notifications to a client

27−-- while a transaction is ongoing.

28−--

29−------------------------------------------------------------------------------

30−

31−module Database.PostgreSQL.Simple.Copy

32− ( copy

33− , copy_

34− , CopyOutResult(..)

35− , foldCopyData

36− , getCopyData

37− , putCopyData

38− , putCopyEnd

39− , putCopyError

40− ) where

41−

42−import Control.Applicative

43−import Control.Concurrent

44−import Control.Exception ( throwIO )

45−import qualified Data.Attoparsec.ByteString.Char8 as P

46−import Data.Typeable(Typeable)

47−import Data.Int(Int64)

48−import qualified Data.ByteString.Char8 as B

49−import qualified Database.PostgreSQL.LibPQ as PQ

50−import Database.PostgreSQL.Simple

51−import Database.PostgreSQL.Simple.Types

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

53−

54−

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

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

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

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

59−

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

61−copy conn template qs = do

62− q <- formatQuery conn template qs

63− doCopy "Database.PostgreSQL.Simple.Copy.copy" conn template q

64−

65−

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

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

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

69−-- to call this function. Does not perform parameter subsitution.

70−

71−copy_ :: Connection -> Query -> IO ()

72−copy_ conn (Query q) = do

73− doCopy "Database.PostgreSQL.Simple.Copy.copy_" conn (Query q) q

74−

75−doCopy :: B.ByteString -> Connection -> Query -> B.ByteString -> IO ()

76−doCopy funcName conn template q = do

77− result <- exec conn q

78− status <- PQ.resultStatus result

79− let errMsg msg = throwIO $ QueryError

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

81− template

82− let err = errMsg $ show status

83− case status of

84− PQ.EmptyQuery -> err

85− PQ.CommandOk -> err

86− PQ.TuplesOk -> err

87− PQ.CopyOut -> return ()

88− PQ.CopyIn -> return ()

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

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

91− PQ.BadResponse -> throwResultError funcName result status

92− PQ.NonfatalError -> throwResultError funcName result status

93− PQ.FatalError -> throwResultError funcName result status

94−

95−data CopyOutResult

96− = CopyOutRow !B.ByteString -- ^ Data representing either exactly

97− -- one row of the result, or header

98− -- or footer data depending on format.

99− | CopyOutDone {-# UNPACK #-} !Int64 -- ^ No more rows, and a count of the

100− -- number of rows returned.

101− deriving (Eq, Typeable, Show)

102−

103−

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

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

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

107−--

108−-- __Example__

109−--

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

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

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

113−-- > []

114−

115−foldCopyData

116− :: Connection -- ^ Database connection

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

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

119− -> a -- ^ Initial accumulator

120− -> IO b -- ^ Result

121−foldCopyData conn f g !acc = do

122− result <- getCopyData conn

123− case result of

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

125− CopyOutDone count -> g acc count

126−

127−

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

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

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

131−-- if it returns 'CopyOutDone', then the connection has reverted to the

132−-- ready state.

133−

134−getCopyData :: Connection -> IO CopyOutResult

135−getCopyData conn = withConnection conn loop

136− where

137− funcName = "Database.PostgreSQL.Simple.Copy.getCopyData"

138− loop pqconn = do

139−#if defined(mingw32_HOST_OS)

140− row <- PQ.getCopyData pqconn False

141−#else

142− row <- PQ.getCopyData pqconn True

143−#endif

144− case row of

145− PQ.CopyOutRow rowdata -> return $! CopyOutRow rowdata

146− PQ.CopyOutDone -> CopyOutDone <$> getCopyCommandTag funcName pqconn

147−#if defined(mingw32_HOST_OS)

148− PQ.CopyOutWouldBlock -> do

149− fail (B.unpack funcName ++ ": the impossible happened")

150−#else

151− PQ.CopyOutWouldBlock -> do

152− mfd <- PQ.socket pqconn

153− case mfd of

154− Nothing -> throwIO (fdError funcName)

155− Just fd -> do

156− threadWaitRead fd

157− _ <- PQ.consumeInput pqconn

158− loop pqconn

159−#endif

160− PQ.CopyOutError -> do

161− mmsg <- PQ.errorMessage pqconn

162− throwIO SqlError {

163− sqlState = "",

164− sqlExecStatus = FatalError,

165− sqlErrorMsg = maybe "" id mmsg,

166− sqlErrorDetail = "",

167− sqlErrorHint = funcName

168− }

169−

170−

171−-- | Feed some data to a @COPY FROM STDIN@ query. Note that

172−-- the data does not need to represent a single row, or even an

173−-- integral number of rows. The net result of

174−-- @putCopyData conn a >> putCopyData conn b@

175−-- is the same as @putCopyData conn c@ whenever @c == BS.append a b@.

176−--

177−-- A connection must be in the @CopyIn@ state in order to call this

178−-- function, otherwise a 'SqlError' exception will result. The

179−-- connection remains in the @CopyIn@ state after this function

180−-- is called.

181−

182−putCopyData :: Connection -> B.ByteString -> IO ()

183−putCopyData conn dat = withConnection conn $ \pqconn -> do

184− doCopyIn funcName (\c -> PQ.putCopyData c dat) pqconn

185− where

186− funcName = "Database.PostgreSQL.Simple.Copy.putCopyData"

187−

188−

189−-- | Completes a @COPY FROM STDIN@ query. Returns the number of rows

190−-- processed.

191−--

192−-- A connection must be in the @CopyIn@ state in order to call this

193−-- function, otherwise a 'SqlError' exception will result. The

194−-- connection's state changes back to ready after this function

195−-- is called.

196−

197−putCopyEnd :: Connection -> IO Int64

198−putCopyEnd conn = withConnection conn $ \pqconn -> do

199− doCopyIn funcName (\c -> PQ.putCopyEnd c Nothing) pqconn

200− getCopyCommandTag funcName pqconn

201− where

202− funcName = "Database.PostgreSQL.Simple.Copy.putCopyEnd"

203−

204−

205−-- | Aborts a @COPY FROM STDIN@ query. The string parameter is simply

206−-- an arbitrary error message that may show up in the PostgreSQL

207−-- server's log.

208−--

209−-- A connection must be in the @CopyIn@ state in order to call this

210−-- function, otherwise a 'SqlError' exception will result. The

211−-- connection's state changes back to ready after this function

212−-- is called.

213−

214−putCopyError :: Connection -> B.ByteString -> IO ()

215−putCopyError conn err = withConnection conn $ \pqconn -> do

216− doCopyIn funcName (\c -> PQ.putCopyEnd c (Just err)) pqconn

217− consumeResults pqconn

218− where

219− funcName = "Database.PostgreSQL.Simple.Copy.putCopyError"

220−

221−

222−doCopyIn :: B.ByteString -> (PQ.Connection -> IO PQ.CopyInResult)

223− -> PQ.Connection -> IO ()

224−doCopyIn funcName action = loop

225− where

226− loop pqconn = do

227− stat <- action pqconn

228− case stat of

229− PQ.CopyInOk -> return ()

230− PQ.CopyInError -> do

231− mmsg <- PQ.errorMessage pqconn

232− throwIO SqlError {

233− sqlState = "",

234− sqlExecStatus = FatalError,

235− sqlErrorMsg = maybe "" id mmsg,

236− sqlErrorDetail = "",

237− sqlErrorHint = funcName

238− }

239− PQ.CopyInWouldBlock -> do

240− mfd <- PQ.socket pqconn

241− case mfd of

242− Nothing -> throwIO (fdError funcName)

243− Just fd -> do

244− threadWaitWrite fd

245− loop pqconn

246−{-# INLINE doCopyIn #-}

247−

248−getCopyCommandTag :: B.ByteString -> PQ.Connection -> IO Int64

249−getCopyCommandTag funcName pqconn = do

250− result <- maybe (fail errCmdStatus) return =<< PQ.getResult pqconn

251− cmdStat <- maybe (fail errCmdStatus) return =<< PQ.cmdStatus result

252− consumeResults pqconn

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

254− case P.parseOnly rowCount cmdStat of

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

256− fail $ errCmdStatusFmt

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

258− Right n -> return $! n

259− where

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

261− errCmdStatusFmt = B.unpack funcName ++ ": failed to parse command status"

262−

263−

264−consumeResults :: PQ.Connection -> IO ()

265−consumeResults pqconn = do

266− mres <- PQ.getResult pqconn

267− case mres of

268− Nothing -> return ()

269− Just _ -> consumeResults pqconn

src/Database/PostgreSQL/Simple/Cursor.hsdeleted−98

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

1−{-# LANGUAGE OverloadedStrings #-}

2−

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

4−-- |

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

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.hsdeleted−140

@@ -1,140 +0,0 @@

1−{-# LANGUAGE DeriveDataTypeable #-}

2−{-# LANGUAGE OverloadedStrings #-}

3−{-# LANGUAGE RecordWildCards #-}

4−------------------------------------------------------------------------------

5−-- |

6−-- Module: Database.PostgreSQL.Simple.Errors

8−-- License: BSD3

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

10−-- Stability: experimental

11−--

12−-- | Module for parsing errors from postgresql error messages.

13−-- Currently only parses integrity violation errors (class 23).

14−--

15−-- /Note: Success of parsing may depend on language settings./

16−----------------------------------------------------------

17−module Database.PostgreSQL.Simple.Errors

18− ( ConstraintViolation(..)

19− , constraintViolation

20− , constraintViolationE

21− , catchViolation

22− , isSerializationError

23− , isNoActiveTransactionError

24− , isFailedTransactionError

25− )

26− where

27−

28−import Control.Exception as E

29−

30−import Data.Attoparsec.ByteString.Char8

31−import Data.ByteString (ByteString)

32−import Data.Typeable

33−

34−import Database.PostgreSQL.Simple.Internal

35−

36−-- Examples of parsed error messages

37−--

38−-- `ERROR: new row for relation "users" violates check

39−-- constraint "user_kind_check"`

40−--

41−-- `ERROR: insert or update on table "user_group_map" violates foreign key

42−-- constraint "user_id"`

43−--

44−-- `ERROR: null value in column "login" violates not-null constraint`

45−--

46−-- `ERROR: duplicate key value violates unique constraint "users_login_key"`

47−

48−data ConstraintViolation

49− = NotNullViolation ByteString

50− -- ^ The field is a column name

51− | ForeignKeyViolation ByteString ByteString

52− -- ^ Table name and name of violated constraint

53− | UniqueViolation ByteString

54− -- ^ Name of violated constraint

55− | CheckViolation ByteString ByteString

56− -- ^ Relation name (usually table), constraint name

57− | ExclusionViolation ByteString

58− -- ^ Name of the exclusion violation constraint

59− deriving (Show, Eq, Ord, Typeable)

60−

61−-- Default instance should be enough

62−instance Exception ConstraintViolation where

63− toException = postgresqlExceptionToException

64− fromException = postgresqlExceptionFromException

65−

66−

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

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

69−--

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

71−-- > where

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

73−-- > handler _ = ...

74−constraintViolation :: SqlError -> Maybe ConstraintViolation

75−constraintViolation e =

76− case sqlState e of

77− "23502" -> NotNullViolation <$> parseMaybe parseQ1 msg

78− "23503" -> uncurry ForeignKeyViolation <$> parseMaybe parseQ2 msg

79− "23505" -> UniqueViolation <$> parseMaybe parseQ1 msg

80− "23514" -> uncurry CheckViolation <$> parseMaybe parseQ2 msg

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

82− _ -> Nothing

83− where msg = sqlErrorMsg e

84−

85−

86−-- | Like constraintViolation, but also packs original SqlError.

87−--

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

89−-- > where

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

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

92−--

93−constraintViolationE :: SqlError -> Maybe (SqlError, ConstraintViolation)

94−constraintViolationE e = fmap ((,) e) $ constraintViolation e

95−

96−-- | Catches SqlError, tries to convert to ConstraintViolation, re-throws

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

98−--

99−-- > createUser = catchViolation catcher $ execute conn ...

100−-- > where

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

102−-- > catcher e _ = throwIO e

103−catchViolation :: (SqlError -> ConstraintViolation -> IO a) -> IO a -> IO a

104−catchViolation f m = E.catch m

105− (\e -> maybe (throwIO e) (f e) $ constraintViolation e)

106−

107−-- Parsers just try to extract quoted strings from error messages, number

108−-- of quoted strings depend on error type.

109−scanTillQuote :: Parser ByteString

110−scanTillQuote = scan False go

111− where go True _ = Just False -- escaped character

112− go False '"' = Nothing -- end parse

113− go False '\\' = Just True -- next one is escaped

114− go _ _ = Just False

115−

116−parseQ1 :: Parser ByteString

117−parseQ1 = scanTillQuote *> char '"' *> scanTillQuote <* char '"'

118−

119−parseQ2 :: Parser (ByteString, ByteString)

120−parseQ2 = (,) <$> parseQ1 <*> parseQ1

121−

122−parseMaybe :: Parser a -> ByteString -> Maybe a

123−parseMaybe p b = either (const Nothing) Just $ parseOnly p b

124−

125−------------------------------------------------------------------------

126−-- Error predicates

127−--

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

129−

130−isSerializationError :: SqlError -> Bool

131−isSerializationError = isSqlState "40001"

132−

133−isNoActiveTransactionError :: SqlError -> Bool

134−isNoActiveTransactionError = isSqlState "25P01"

135−

136−isFailedTransactionError :: SqlError -> Bool

137−isFailedTransactionError = isSqlState "25P02"

138−

139−isSqlState :: ByteString -> SqlError -> Bool

140−isSqlState s SqlError{..} = sqlState == s

src/Database/PostgreSQL/Simple/FromField.hs+117−527

@@ -1,104 +1,38 @@

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

2{-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-}

3{-# LANGUAGE PatternGuards, ScopedTypeVariables #-}

4−{-# LANGUAGE RecordWildCards #-}

5−{-# LANGUAGE PolyKinds #-}

6−

7−{- |

8−Module: Database.PostgreSQL.Simple.FromField

11−License: BSD3

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

13−Stability: experimental

14−

15−The 'FromField' typeclass, for converting a single value in a row

16−returned by a SQL query into a more useful Haskell representation.

17−Note that each instance of 'FromField' is documented by a list of

18−compatible postgresql types.

19−

20−A Haskell numeric type is considered to be compatible with all

21−PostgreSQL numeric types that are less accurate than it. For instance,

22−the Haskell 'Double' type is compatible with the PostgreSQL's 32-bit

23−@int@ type because it can represent a @int@ exactly. On the other hand,

24−since a 'Double' might lose precision if representing PostgreSQL's 64-bit

25−@bigint@, the two are /not/ considered compatible.

26−

27−Note that the 'Float' and 'Double' instances use attoparsec's 'double'

28−conversion routine, which sacrifices some accuracy for speed. If you

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

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

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

32−achieved simply by

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

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

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

36−'Database.PostgreSQL.Simple.FromRow.fieldWith' useful.

37−

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

39−is likely somewhat faster than converting through the 'Rational' type,

40−the 'Scientific' type has no way to represent @NaN@ and @±Infinity@ values.

41−Thus, if you need precision conversion of regular floating point values

42−and the possibility of receiving these special values from the backend,

43−stick with 'Rational'.

44−

45−Because 'FromField' is a typeclass, one may provide conversions to

46−additional Haskell types without modifying postgresql-simple. This is

47−particularly useful for supporting PostgreSQL types that postgresql-simple

48−does not support out-of-box. Here's an example of what such an instance

49−might look like for a UUID type that implements the @Read@ class:

50−

51−@

52−import Data.UUID ( UUID )

53−import Database.PostgreSQL.Simple.FromField

54− ( FromField (fromField) , typeOid, returnError, ResultError (..) )

55−import Database.PostgreSQL.Simple.TypeInfo.Static (typoid, uuid)

56−import qualified Data.ByteString.Char8 as B

57−

58−instance FromField UUID where

59− fromField f mdata =

60− if typeOid f /= typoid uuid

61− then returnError Incompatible f \"\"

62− else case B.unpack \`fmap\` mdata of

63− Nothing -> returnError UnexpectedNull f \"\"

64− Just dat ->

65− case [ x | (x,t) <- reads dat, (\"\",\"\") <- lex t ] of

66− [x] -> return x

67− _ -> returnError ConversionFailed f dat

68−@

69−

70−Note that because PostgreSQL's @uuid@ type is built into postgres and is

71−not provided by an extension, the 'typeOid' of @uuid@ does not change and

72−thus we can examine it directly. One could hard-code the type oid, or

73−obtain it by other means, but in this case we simply pull it out of the

74−static table provided by postgresql-simple.

75−

76−On the other hand if the type is provided by an extension, such as

77−@PostGIS@ or @hstore@, then the 'typeOid' is not stable and can vary from

78−database to database. In this case it is recommended that FromField

79−instances use 'typename' instead.

80−

81−-}

5+------------------------------------------------------------------------------

6+-- |

7+-- Module: Database.PostgreSQL.Simple.FromField

10+-- License: BSD3

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

12+-- Stability: experimental

13+-- Portability: portable

14+--

15+-- The 'FromField' typeclass, for converting a single value in a row

16+-- returned by a SQL query into a more useful Haskell representation.

17+--

18+-- A Haskell numeric type is considered to be compatible with all

19+-- PostgreSQL numeric types that are less accurate than it. For instance,

20+-- the Haskell 'Double' type is compatible with the PostgreSQL's 32-bit

21+-- @Int@ type because it can represent a @Int@ exactly. On the other hand,

22+-- since a 'Double' might lose precision if representing a 64-bit @BigInt@,

23+-- the two are /not/ considered compatible.

24+--

25+------------------------------------------------------------------------------

84module Database.PostgreSQL.Simple.FromField

27module Database.PostgreSQL.Simple.FromField

85 (

28 (

86 FromField(..)

29 FromField(..)

87 , FieldParser

30 , FieldParser

88− , Conversion()

89−

90− , runConversion

91− , conversionMap

92− , conversionError

93 , ResultError(..)

31 , ResultError(..)

94 , returnError

32 , returnError

96 , Field

34 , Field

97 , typename

35 , typename

98− , TypeInfo(..)

99− , Attribute(..)

100− , typeInfo

101− , typeInfoByOid

102 , name

36 , name

103 , tableOid

37 , tableOid

104 , tableColumn

38 , tableColumn

@@ -106,74 +40,49 @@ module Database.PostgreSQL.Simple.FromField

106 , typeOid

40 , typeOid

107 , PQ.Oid(..)

41 , PQ.Oid(..)

108 , PQ.Format(..)

42 , PQ.Format(..)

109− , pgArrayFieldParser

110− , attoFieldParser

111−

112− , optionalField

113− , fromJSONField

114− , fromFieldJSONByteString

115 ) where

43 ) where

116

117#include "MachDeps.h"

45#include "MachDeps.h"

118

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

47+import Control.Applicative

120−import Control.Concurrent.MVar (MVar, newMVar)

48+ ( Applicative, (<|>), (<$>), pure )

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

49+import Control.Exception (SomeException(..), Exception)

122−import qualified Data.Aeson as JSON

123−import Data.Attoparsec.ByteString.Char8 hiding (Result)

50+import Data.Attoparsec.Char8 hiding (Result)

51+import Data.Bits ((.&.), (.|.), shiftL)

124import Data.ByteString (ByteString)

52import Data.ByteString (ByteString)

125import qualified Data.ByteString.Char8 as B

53import qualified Data.ByteString.Char8 as B

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

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

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

128−import Data.IORef (IORef, newIORef)

55+import Data.List (foldl')

129import Data.Ratio (Ratio)

56import Data.Ratio (Ratio)

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

57+import Data.Time ( UTCTime, ZonedTime, LocalTime, Day, TimeOfDay )

131import Data.Typeable (Typeable, typeOf)

58import Data.Typeable (Typeable, typeOf)

132−import Data.Vector (Vector)

59+import Data.Word (Word64)

133−import Data.Vector.Mutable (IOVector)

134−import qualified Data.Vector as V

135import Database.PostgreSQL.Simple.Internal

60import Database.PostgreSQL.Simple.Internal

136−import Database.PostgreSQL.Simple.Compat

61+import Database.PostgreSQL.Simple.BuiltinTypes

137import Database.PostgreSQL.Simple.Ok

62import Database.PostgreSQL.Simple.Ok

138−import Database.PostgreSQL.Simple.Types

63+import Database.PostgreSQL.Simple.Types (Binary(..), Null(..))

139−import Database.PostgreSQL.Simple.TypeInfo as TI

140−import qualified Database.PostgreSQL.Simple.TypeInfo.Static as TI

141import Database.PostgreSQL.Simple.Time

64import Database.PostgreSQL.Simple.Time

142−import Database.PostgreSQL.Simple.Arrays as Arrays

143import qualified Database.PostgreSQL.LibPQ as PQ

65import qualified Database.PostgreSQL.LibPQ as PQ

66+import System.IO.Unsafe (unsafePerformIO)

144import qualified Data.ByteString as SB

67import qualified Data.ByteString as SB

145import qualified Data.ByteString.Char8 as B8

68import qualified Data.ByteString.Char8 as B8

146import qualified Data.ByteString.Lazy as LB

69import qualified Data.ByteString.Lazy as LB

147import qualified Data.Text as ST

70import qualified Data.Text as ST

148import qualified Data.Text.Encoding as ST

71import qualified Data.Text.Encoding as ST

149import qualified Data.Text.Lazy as LT

72import qualified Data.Text.Lazy as LT

150−import Data.CaseInsensitive (CI)

151−import qualified Data.CaseInsensitive as CI

152−import Data.UUID.Types (UUID)

153−import qualified Data.UUID.Types as UUID

154−import Data.Scientific (Scientific)

155−import GHC.Real (infinity, notANumber)

156−

157−import qualified Data.Aeson.Types as JSON

158

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

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

160-- value fails.

75-- value fails.

161data ResultError = Incompatible { errSQLType :: String

76data ResultError = Incompatible { errSQLType :: String

162− , errSQLTableOid :: Maybe PQ.Oid

163− , errSQLField :: String

164 , errHaskellType :: String

77 , errHaskellType :: String

165 , errMessage :: String }

78 , errMessage :: String }

166 -- ^ The SQL and Haskell types are not compatible.

79 -- ^ The SQL and Haskell types are not compatible.

167 | UnexpectedNull { errSQLType :: String

80 | UnexpectedNull { errSQLType :: String

168− , errSQLTableOid :: Maybe PQ.Oid

169− , errSQLField :: String

170 , errHaskellType :: String

81 , errHaskellType :: String

171 , errMessage :: String }

82 , errMessage :: String }

172 -- ^ A SQL @NULL@ was encountered when the Haskell

83 -- ^ A SQL @NULL@ was encountered when the Haskell

173 -- type did not permit it.

84 -- type did not permit it.

174 | ConversionFailed { errSQLType :: String

85 | ConversionFailed { errSQLType :: String

175− , errSQLTableOid :: Maybe PQ.Oid

176− , errSQLField :: String

177 , errHaskellType :: String

86 , errHaskellType :: String

178 , errMessage :: String }

87 , errMessage :: String }

179 -- ^ The SQL value could not be parsed, or could not

88 -- ^ The SQL value could not be parsed, or could not

@@ -182,14 +91,12 @@ data ResultError = Incompatible { errSQLType :: String

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

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

183 deriving (Eq, Show, Typeable)

92 deriving (Eq, Show, Typeable)

184

185−instance Exception ResultError where

94+instance Exception ResultError

186− toException = postgresqlExceptionToException

187− fromException = postgresqlExceptionFromException

188

189−left :: Exception a => a -> Conversion b

96+left :: Exception a => a -> Ok b

190−left = conversionError

97+left = Errors . (:[]) . SomeException

191

192−type FieldParser a = Field -> Maybe ByteString -> Conversion a

99+type FieldParser a = Field -> Maybe ByteString -> Ok a

193

100

194-- | A type that may be converted from a SQL type.

101-- | A type that may be converted from a SQL type.

195class FromField a where

102class FromField a where

@@ -200,471 +107,171 @@ class FromField a where

200 -- library instances, this will usually be a single 'ResultError', but

107 -- library instances, this will usually be a single 'ResultError', but

201 -- may be a 'UnicodeException'.

108 -- may be a 'UnicodeException'.

202 --

109 --

203− -- Note that retaining any reference to the 'Field' argument causes

110+ -- Implementations of 'fromField' should not retain any references to

111+ -- the 'Field' nor the 'ByteString' arguments after the result has

112+ -- been evaluated to WHNF. Such a reference causes the entire

204− -- the entire @LibPQ.'PQ.Result'@ to be retained. Thus, implementations

113+ -- @LibPQ.'PQ.Result'@ to be retained.

205− -- of 'fromField' should return results that do not refer to this value

206− -- after the result have been evaluated to WHNF.

207 --

114 --

208− -- Note that as of @postgresql-simple-0.4.0.0@, the 'ByteString' value

115+ -- For example, the instance for 'ByteString' uses 'B.copy' to avoid

209− -- has already been copied out of the @LibPQ.'PQ.Result'@ before it has

116+ -- such a reference, and that using bytestring functions such as 'B.drop'

210− -- been passed to 'fromField'. This is because for short strings, it's

117+ -- and 'B.takeWhile' alone will also trigger this memory leak.

211− -- cheaper to copy the string than to set up a finalizer.

212−

213−-- | Returns the data type name. This is the preferred way of identifying

214−-- types that do not have a stable type oid, such as types provided by

215−-- extensions to PostgreSQL.

216−--

217−-- More concretely, it returns the @typname@ column associated with the

218−-- type oid in the @pg_type@ table. First, postgresql-simple will check

219−-- the built-in, static table. If the type oid is not there,

220−-- postgresql-simple will check a per-connection cache, and then

221−-- finally query the database's meta-schema.

222−

223−typename :: Field -> Conversion ByteString

224−typename field = typname <$> typeInfo field

225−

226−typeInfo :: Field -> Conversion TypeInfo

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

228− Ok <$> (getTypeInfo conn typeOid)

229−

230−typeInfoByOid :: PQ.Oid -> Conversion TypeInfo

231−typeInfoByOid oid = Conversion $ \conn -> do

232− Ok <$> (getTypeInfo conn oid)

233

118

234−-- | Returns the name of the column. This is often determined by a table

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

235−-- definition, but it can be set using an @as@ clause.

120+ fromField _ Nothing = pure Nothing

121+ fromField f bs = Just <$> fromField f bs

236

122

237−name :: Field -> Maybe ByteString

238−name Field{..} = unsafeDupablePerformIO (PQ.fname result column)

239−

240−-- | Returns the name of the object id of the @table@ associated with the

241−-- column, if any. Returns 'Nothing' when there is no such table;

242−-- for example a computed column does not have a table associated with it.

243−-- Analogous to libpq's @PQftable@.

244−

245−tableOid :: Field -> Maybe PQ.Oid

246−tableOid Field{..} = toMaybeOid (unsafeDupablePerformIO (PQ.ftable result column))

247− where

248− toMaybeOid x

249− = if x == PQ.invalidOid

250− then Nothing

251− else Just x

252−

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

258−

259−tableColumn :: Field -> Int

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

261− where

262− fromCol (PQ.Col x) = fromIntegral x

263−

264−-- | This returns whether the data was returned in a binary or textual format.

265−-- Analogous to libpq's @PQfformat@.

266−

267−format :: Field -> PQ.Format

268−format Field{..} = unsafeDupablePerformIO (PQ.fformat result column)

269−

270−-- | void

271−instance FromField () where

272− fromField f _bs

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

274− | otherwise = pure ()

275−

276−instance (FromField a) => FromField (Const a b) where

277− fromField f bs = Const <$> fromField f bs

278−

279−instance (FromField a) => FromField (Identity a) where

280− fromField f bs = Identity <$> fromField f bs

281−

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

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

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

285−-- behavior.

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

287− fromField = optionalField fromField

288−

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

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

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

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

293−

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

295−optionalField p f mv =

296− case mv of

297− Nothing -> pure Nothing

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

299−{-# INLINE optionalField #-}

300−

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

302instance FromField Null where

123instance FromField Null where

303 fromField _ Nothing = pure Null

124 fromField _ Nothing = pure Null

304 fromField f (Just _) = returnError ConversionFailed f "data is not null"

125 fromField f (Just _) = returnError ConversionFailed f "data is not null"

305

126

306−-- | bool

307instance FromField Bool where

127instance FromField Bool where

308 fromField f bs

128 fromField f bs

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

129+ | typeOid f /= builtin2oid Bool = returnError Incompatible f ""

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

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

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

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

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

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

313 | otherwise = returnError ConversionFailed f ""

133 | otherwise = returnError ConversionFailed f ""

314

134

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

316−instance FromField Char where

317− fromField f bs0 =

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

319− then case bs0 of

320− Nothing -> returnError UnexpectedNull f ""

321− Just bs -> if B.length bs /= 1

322− then returnError ConversionFailed f "length not 1"

323− else return $! (B.head bs)

324− else returnError Incompatible f ""

325−

326−-- | int2

327instance FromField Int16 where

135instance FromField Int16 where

328− fromField = attoFieldParser ok16 $ signed decimal

136+ fromField = atto ok16 $ signed decimal

329

137

330−-- | int2, int4

331instance FromField Int32 where

138instance FromField Int32 where

332− fromField = attoFieldParser ok32 $ signed decimal

139+ fromField = atto ok32 $ signed decimal

333

140

334−#if WORD_SIZE_IN_BITS < 64

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

336−-- This library was compiled as 32-bit code.

337−#else

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

339−-- This library was compiled as 64-bit code.

340−#endif

341instance FromField Int where

141instance FromField Int where

342− fromField = attoFieldParser okInt $ signed decimal

142+ fromField = atto okInt $ signed decimal

343

143

344−-- | int2, int4, int8

345instance FromField Int64 where

144instance FromField Int64 where

346− fromField = attoFieldParser ok64 $ signed decimal

145+ fromField = atto ok64 $ signed decimal

347

146

348−-- | int2, int4, int8

349instance FromField Integer where

147instance FromField Integer where

350− fromField = attoFieldParser ok64 $ signed decimal

148+ fromField = atto ok64 $ signed decimal

351

149

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

353−-- better accuracy convert to 'Scientific' or 'Rational' first)

354instance FromField Float where

150instance FromField Float where

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

151+ fromField = atto ok (realToFrac <$> double)

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

152+ where ok = mkCompats [Float4,Int2]

357

153

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

359−-- better accuracy convert to 'Scientific' or 'Rational' first)

360instance FromField Double where

154instance FromField Double where

361− fromField = attoFieldParser ok pg_double

155+ fromField = atto ok double

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

156+ where ok = mkCompats [Float4,Float8,Int2,Int4]

363

157

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

365instance FromField (Ratio Integer) where

158instance FromField (Ratio Integer) where

366− fromField = attoFieldParser ok pg_rational

159+ fromField = atto ok rational

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

160+ where ok = mkCompats [Float4,Float8,Int2,Int4,Numeric]

368−

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

370−instance FromField Scientific where

371− fromField = attoFieldParser ok rational

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

373

161

374unBinary :: Binary t -> t

162unBinary :: Binary t -> t

375unBinary (Binary x) = x

163unBinary (Binary x) = x

376

164

377−pg_double :: Parser Double

378−pg_double

379− = (string "NaN" *> pure ( 0 / 0))

380− <|> (string "Infinity" *> pure ( 1 / 0))

381− <|> (string "-Infinity" *> pure (-1 / 0))

382− <|> double

383−

384−pg_rational :: Parser Rational

385−pg_rational

386− = (string "NaN" *> pure notANumber )

387− <|> (string "Infinity" *> pure infinity )

388− <|> (string "-Infinity" *> pure (-infinity))

389− <|> rational

390−

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

392instance FromField SB.ByteString where

165instance FromField SB.ByteString where

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

166+ fromField f dat = if typeOid f == builtin2oid ByteA

394 then unBinary <$> fromField f dat

167 then unBinary <$> fromField f dat

395− else doFromField f okText' pure dat

168+ else doFromField f okText' (pure . B.copy) dat

396

169

397−-- | oid

398instance FromField PQ.Oid where

170instance FromField PQ.Oid where

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

171+ fromField f dat = PQ.Oid <$> atto (mkCompat Oid) decimal f dat

400

172

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

402instance FromField LB.ByteString where

173instance FromField LB.ByteString where

403 fromField f dat = LB.fromChunks . (:[]) <$> fromField f dat

174 fromField f dat = LB.fromChunks . (:[]) <$> fromField f dat

404

175

405unescapeBytea :: Field -> SB.ByteString

176unescapeBytea :: Field -> SB.ByteString

406− -> Conversion (Binary SB.ByteString)

177+ -> Ok (Binary SB.ByteString)

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

178+unescapeBytea f str = case unsafePerformIO (PQ.unescapeBytea str) of

408 Nothing -> returnError ConversionFailed f "unescapeBytea failed"

179 Nothing -> returnError ConversionFailed f "unescapeBytea failed"

409 Just str -> pure (Binary str)

180 Just str -> pure (Binary str)

410

181

411−-- | bytea

412instance FromField (Binary SB.ByteString) where

182instance FromField (Binary SB.ByteString) where

413 fromField f dat = case format f of

183 fromField f dat = case format f of

414 PQ.Text -> doFromField f okBinary (unescapeBytea f) dat

184 PQ.Text -> doFromField f okBinary (unescapeBytea f) dat

415− PQ.Binary -> doFromField f okBinary (pure . Binary) dat

185+ PQ.Binary -> doFromField f okBinary (pure . Binary . B.copy) dat

416

186

417−-- | bytea

418instance FromField (Binary LB.ByteString) where

187instance FromField (Binary LB.ByteString) where

419 fromField f dat = Binary . LB.fromChunks . (:[]) . unBinary <$> fromField f dat

188 fromField f dat = Binary . LB.fromChunks . (:[]) . unBinary <$> fromField f dat

420

189

421−-- | name, text, \"char\", bpchar, varchar

422instance FromField ST.Text where

190instance FromField ST.Text where

423 fromField f = doFromField f okText $ (either left pure . ST.decodeUtf8')

191 fromField f = doFromField f okText $ (either left pure . ST.decodeUtf8')

424 -- FIXME: check character encoding

192 -- FIXME: check character encoding

425

193

426−-- | name, text, \"char\", bpchar, varchar

427instance FromField LT.Text where

194instance FromField LT.Text where

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

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

429

196

430−-- | citext

431−instance FromField (CI ST.Text) where

432− fromField f mdat = do

433− typ <- typename f

434− if typ /= "citext"

435− then returnError Incompatible f ""

436− else case mdat of

437− Nothing -> returnError UnexpectedNull f ""

438− Just dat -> either left (pure . CI.mk)

439− (ST.decodeUtf8' dat)

440−

441−-- | citext

442−instance FromField (CI LT.Text) where

443− fromField f mdat = do

444− typ <- typename f

445− if typ /= "citext"

446− then returnError Incompatible f ""

447− else case mdat of

448− Nothing -> returnError UnexpectedNull f ""

449− Just dat -> either left (pure . CI.mk . LT.fromStrict)

450− (ST.decodeUtf8' dat)

451−

452−-- | name, text, \"char\", bpchar, varchar

453instance FromField [Char] where

197instance FromField [Char] where

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

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

455

199

456−-- | timestamptz

457instance FromField UTCTime where

200instance FromField UTCTime where

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

201+ fromField = ff TimestampTZ "UTCTime" parseUTCTime

459

202

460−-- | timestamptz

461instance FromField ZonedTime where

203instance FromField ZonedTime where

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

204+ fromField = ff TimestampTZ "ZonedTime" parseZonedTime

463

205

464−-- | timestamp

465instance FromField LocalTime where

206instance FromField LocalTime where

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

207+ fromField = ff Timestamp "LocalTime" parseLocalTime

467

208

468−-- | date

469instance FromField Day where

209instance FromField Day where

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

210+ fromField = ff Date "Day" parseDay

471

211

472−-- | time

473instance FromField TimeOfDay where

212instance FromField TimeOfDay where

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

213+ fromField = ff Time "TimeOfDay" parseTimeOfDay

475

214

476−-- | timestamptz

477instance FromField UTCTimestamp where

215instance FromField UTCTimestamp where

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

216+ fromField = ff TimestampTZ "UTCTimestamp" parseUTCTimestamp

479

217

480−-- | timestamptz

481instance FromField ZonedTimestamp where

218instance FromField ZonedTimestamp where

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

219+ fromField = ff TimestampTZ "ZonedTimestamp" parseZonedTimestamp

483

220

484−-- | timestamp

485instance FromField LocalTimestamp where

221instance FromField LocalTimestamp where

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

222+ fromField = ff Timestamp "LocalTimestamp" parseLocalTimestamp

487

223

488−-- | date

489instance FromField Date where

224instance FromField Date where

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

225+ fromField = ff Date "Date" parseDate

491−

226+

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

500−

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

227+ff :: BuiltinType -> String -> (B8.ByteString -> Either String a)

502− -> Field -> Maybe B8.ByteString -> Conversion a

228+ -> Field -> Maybe B8.ByteString -> Ok a

503−ff compatOid hsType parseBS f mstr =

229+ff pgType hsType parse f mstr

504− if typeOid f /= compatOid

230+ | typeOid f /= builtin2oid pgType

505− then err Incompatible ""

231+ = left (Incompatible (B8.unpack (typename f)) hsType "")

506− else case mstr of

232+ | Nothing <- mstr

507− Nothing -> err UnexpectedNull ""

233+ = left (UnexpectedNull (B8.unpack (typename f)) hsType "")

234+ | Just str <- mstr

508− Just str -> case parseBS str of

235+ = case parse str of

509− Left msg -> err ConversionFailed msg

236+ Left msg -> left (ConversionFailed (B8.unpack (typename f)) hsType msg)

510− Right val -> return val

237+ Right val -> return val

511− where

512− err errC msg = do

513− typnam <- typename f

514− left $ errC (B8.unpack typnam)

515− (tableOid f)

516− (maybe "" B8.unpack (name f))

517− hsType

518− msg

519{-# INLINE ff #-}

238{-# INLINE ff #-}

520

239

521−-- | Compatible with both types. Conversions to type @b@ are

522−-- preferred, the conversion to type @a@ will be tried after

523−-- the 'Right' conversion fails.

524instance (FromField a, FromField b) => FromField (Either a b) where

240instance (FromField a, FromField b) => FromField (Either a b) where

525 fromField f dat = (Right <$> fromField f dat)

241 fromField f dat = (Right <$> fromField f dat)

526 <|> (Left <$> fromField f dat)

242 <|> (Left <$> fromField f dat)

527

243

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

244+newtype Compat = Compat Word64

529−instance (FromField a, Typeable a) => FromField (PGArray a) where

245+

530− fromField = pgArrayFieldParser fromField

246+mkCompats :: [BuiltinType] -> Compat

531−

247+mkCompats = foldl' f (Compat 0) . map mkCompat

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

248+ where f (Compat a) (Compat b) = Compat (a .|. b)

533−pgArrayFieldParser fieldParser f mdat = do

249+

534− info <- typeInfo f

250+mkCompat :: BuiltinType -> Compat

535− case info of

251+mkCompat = Compat . shiftL 1 . fromEnum

536− TI.Array{} ->

252+

537− case mdat of

538− Nothing -> returnError UnexpectedNull f ""

539− Just dat -> do

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

541− Left err -> returnError ConversionFailed f err

542− Right conv -> PGArray <$> conv

543− _ -> returnError Incompatible f ""

544−

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

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

547− where

548− delim = typdelim (typelem typInfo)

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

550−

551− parseIt item =

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

553− where

554− item' = fmt delim item

555− f' | Arrays.Array _ <- item = f

556− | otherwise = fElem

557−

558−instance (FromField a, Typeable a) => FromField (Vector a) where

559− fromField f v = V.fromList . fromPGArray <$> fromField f v

560−

561−instance (FromField a, Typeable a) => FromField (IOVector a) where

562− fromField f v = liftConversion . V.unsafeThaw =<< fromField f v

563−

564−-- | uuid

565−instance FromField UUID where

566− fromField f mbs =

567− if typeOid f /= TI.uuidOid

568− then returnError Incompatible f ""

569− else case mbs of

570− Nothing -> returnError UnexpectedNull f ""

571− Just bs ->

572− case UUID.fromASCIIBytes bs of

573− Nothing -> returnError ConversionFailed f "Invalid UUID"

574− Just uuid -> pure uuid

575−

576−-- | json, jsonb

577−instance FromField JSON.Value where

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

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

580− Left err -> returnError ConversionFailed f err

581− Right val -> pure val

582−

583−-- | Return the JSON ByteString directly

584−--

585−-- @since 0.6.3

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

587−fromFieldJSONByteString f mbs =

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

589− then returnError Incompatible f ""

590− else case mbs of

591− Nothing -> returnError UnexpectedNull f ""

592− Just bs -> pure bs

593−

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

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

596−--

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

598−-- method for Haskell types that have a JSON representation in

599−-- PostgreSQL.

600−--

601−-- The 'Typeable' constraint is required to show more informative

602−-- error messages when parsing fails.

603−--

604−-- Note that @fromJSONField :: FieldParser ('Maybe' Foo)@ will return

605−-- @'Nothing'@ on the json @null@ value, and return an exception on SQL @null@

606−-- value. Alternatively, one could write @'optionalField' fromJSONField@

607−-- that will return @Nothing@ on SQL @null@, and otherwise will call

608−-- @fromJSONField :: FieldParser Foo@ and then return @'Just'@ the

609−-- result value, or return its exception. If one would

610−-- like to return @Nothing@ on both the SQL @null@ and json @null@ values,

611−-- one way to do it would be to write

612−-- @\\f mv -> 'Control.Monad.join' '<$>' optionalField fromJSONField f mv@

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

614−fromJSONField f mbBs = do

615− value <- fromField f mbBs

616− case JSON.ifromJSON value of

617− JSON.IError path err -> returnError ConversionFailed f $

618− "JSON decoding error: " ++ (JSON.formatError path err)

619− JSON.ISuccess x -> pure x

620−

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

622−-- modifying the 'IORef' does not have any effects outside

623−-- the local process on the local machine.

624−instance FromField a => FromField (IORef a) where

625− fromField f v = liftConversion . newIORef =<< fromField f v

626−

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

628−-- modifying the 'MVar' does not have any effects outside

629−-- the local process on the local machine.

630−instance FromField a => FromField (MVar a) where

631− fromField f v = liftConversion . newMVar =<< fromField f v

632−

633−type Compat = PQ.Oid -> Bool

253+compat :: Compat -> Compat -> Bool

254+compat (Compat a) (Compat b) = a .&. b /= 0

634

255

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

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

636−okText = eq TI.nameOid \/ eq TI.textOid \/ eq TI.charOid

257+okText = mkCompats [Name,Text,Char,BpChar,VarChar]

637− \/ eq TI.bpcharOid \/ eq TI.varcharOid

258+okText' = mkCompats [Name,Text,Char,BpChar,VarChar,Unknown]

638−okText' = eq TI.nameOid \/ eq TI.textOid \/ eq TI.charOid

259+okBinary = mkCompats [ByteA]

639− \/ eq TI.bpcharOid \/ eq TI.varcharOid \/ eq TI.unknownOid

260+ok16 = mkCompats [Int2]

640−okBinary = eq TI.byteaOid

261+ok32 = mkCompats [Int2,Int4]

641−ok16 = eq TI.int2Oid

262+ok64 = mkCompats [Int2,Int4,Int8]

642−ok32 = eq TI.int2Oid \/ eq TI.int4Oid

643−ok64 = eq TI.int2Oid \/ eq TI.int4Oid \/ eq TI.int8Oid

644#if WORD_SIZE_IN_BITS < 64

263#if WORD_SIZE_IN_BITS < 64

645okInt = ok32

264okInt = ok32

646#else

265#else

647okInt = ok64

266okInt = ok64

648#endif

267#endif

649

268

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−

663doFromField :: forall a . (Typeable a)

269doFromField :: forall a . (Typeable a)

664− => Field -> Compat -> (ByteString -> Conversion a)

270+ => Field -> Compat -> (ByteString -> Ok a)

665− -> Maybe ByteString -> Conversion a

271+ -> Maybe ByteString -> Ok a

666−doFromField f isCompat cvt (Just bs)

272+doFromField f types cvt (Just bs)

667− | isCompat (typeOid f) = cvt bs

273+ | Just typ <- oid2builtin (typeOid f)

274+ , mkCompat typ `compat` types = cvt bs

668 | otherwise = returnError Incompatible f "types incompatible"

275 | otherwise = returnError Incompatible f "types incompatible"

669doFromField f _ _ _ = returnError UnexpectedNull f ""

276doFromField f _ _ _ = returnError UnexpectedNull f ""

670

277

@@ -674,34 +281,17 @@ doFromField f _ _ _ = returnError UnexpectedNull f ""

674-- exception value and returns it in a 'Left . SomeException'

281-- exception value and returns it in a 'Left . SomeException'

675-- constructor.

282-- constructor.

676returnError :: forall a err . (Typeable a, Exception err)

283returnError :: forall a err . (Typeable a, Exception err)

677− => (String -> Maybe PQ.Oid -> String -> String -> String -> err)

284+ => (String -> String -> String -> err)

678− -> Field -> String -> Conversion a

285+ -> Field -> String -> Ok a

679−returnError mkErr f msg = do

286+returnError mkErr f = left . mkErr (B.unpack (typename f))

680− typnam <- typename f

681− left $ mkErr (B.unpack typnam)

682− (tableOid f)

683− (maybe "" B.unpack (name f))

684− (show (typeOf (undefined :: a)))

287+ (show (typeOf (undefined :: a)))

685− msg

288+

686−

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)

289+atto :: forall a. (Typeable a)

697− => (PQ.Oid -> Bool)

290+ => Compat -> Parser a -> Field -> Maybe ByteString

698− -- ^ Predicate for whether the postgresql type oid is compatible with this parser

291+ -> Ok a

699− -> Parser a

700− -- ^ An attoparsec parser.

701− -> FieldParser a

702−attoFieldParser types p0 f dat = doFromField f types (go p0) dat

292+atto types p0 f dat = doFromField f types (go p0) dat

703 where

293 where

704− go :: Parser a -> ByteString -> Conversion a

294+ go :: Parser a -> ByteString -> Ok a

705 go p s =

295 go p s =

706 case parseOnly p s of

296 case parseOnly p s of

707 Left err -> returnError ConversionFailed f err

297 Left err -> returnError ConversionFailed f err

src/Database/PostgreSQL/Simple/FromField.hs-bootdeleted−11

@@ -1,11 +0,0 @@

1−module Database.PostgreSQL.Simple.FromField where

2−

3−import Data.ByteString(ByteString)

4−import Database.PostgreSQL.Simple.Types

5−

6−class FromField a

7−

8−instance FromField Oid

9−instance FromField Char

10−instance FromField ByteString

11−instance FromField a => FromField (Maybe a)

src/Database/PostgreSQL/Simple/FromRow.hs+31−358

@@ -1,6 +1,4 @@

1−{-# LANGUAGE FlexibleContexts #-}

1+{-# LANGUAGE RecordWildCards #-}

2−{-# LANGUAGE RecordWildCards, FlexibleInstances, DefaultSignatures #-}

3−

5------------------------------------------------------------------------------

3------------------------------------------------------------------------------

6-- |

4-- |

@@ -9,15 +7,13 @@

9-- License: BSD3

7-- License: BSD3

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

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

11-- Stability: experimental

9-- Stability: experimental

10+-- Portability: portable

12--

11--

13-- The 'FromRow' typeclass, for converting a row of results

12-- The 'FromRow' typeclass, for converting a row of results

14-- returned by a SQL query into a more useful Haskell representation.

13-- returned by a SQL query into a more useful Haskell representation.

15--

14--

16-- Predefined instances are provided for tuples containing up to ten

15-- Predefined instances are provided for tuples containing up to ten

17−-- elements. The instances for 'Maybe' types return 'Nothing' if all

16+-- elements.

18−-- the columns that would have been otherwise consumed are null, otherwise

19−-- it attempts a regular conversion.

20−--

21------------------------------------------------------------------------------

17------------------------------------------------------------------------------

23module Database.PostgreSQL.Simple.FromRow

19module Database.PostgreSQL.Simple.FromRow

@@ -28,36 +24,31 @@ module Database.PostgreSQL.Simple.FromRow

28 , numFieldsRemaining

24 , numFieldsRemaining

29 ) where

25 ) where

31−import Prelude hiding (null)

32−import Control.Applicative (Applicative(..), (<$>), (<|>), (*>), liftA2)

27+import Control.Applicative (Applicative(..), (<$>))

28+import Control.Exception (SomeException(..))

33−import Control.Monad (replicateM, replicateM_)

29+import Control.Monad (replicateM)

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

35−import Control.Monad.Trans.Reader

36−import Control.Monad.Trans.Class

37−import Data.ByteString (ByteString)

30+import Data.ByteString (ByteString)

38import qualified Data.ByteString.Char8 as B

31import qualified Data.ByteString.Char8 as B

39−import Data.Vector (Vector)

40−import qualified Data.Vector as V

41−import Database.PostgreSQL.Simple.Types (Only(..))

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

33+import Database.PostgreSQL.Simple.Ok

42import qualified Database.PostgreSQL.LibPQ as PQ

34import qualified Database.PostgreSQL.LibPQ as PQ

43import Database.PostgreSQL.Simple.Internal

35import Database.PostgreSQL.Simple.Internal

44−import Database.PostgreSQL.Simple.Compat

45import Database.PostgreSQL.Simple.FromField

36import Database.PostgreSQL.Simple.FromField

46−import Database.PostgreSQL.Simple.Ok

37+import Database.PostgreSQL.Simple.Types ((:.)(..))

47−import Database.PostgreSQL.Simple.Types ((:.)(..), Null)

48−import Database.PostgreSQL.Simple.TypeInfo

50−import GHC.Generics

39+import Control.Monad.Trans.State.Strict

40+import Control.Monad.Trans.Reader

41+import Control.Monad.Trans.Class

43+import Data.Vector ((!))

53-- | A collection type that can be converted from a sequence of fields.

45-- | A collection type that can be converted from a sequence of fields.

54-- Instances are provided for tuples up to 10 elements and lists of any length.

46-- Instances are provided for tuples up to 10 elements and lists of any length.

55--

47--

56−-- Note that instances can be defined outside of postgresql-simple, which is

48+-- Note that instances can defined outside of postgresql-simple, which is

57-- often useful. For example, here's an instance for a user-defined pair:

49-- often useful. For example, here's an instance for a user-defined pair:

58--

50--

59−-- @

60−-- data User = User { name :: String, fileQuota :: Int }

51+-- @data User = User { name :: String, fileQuota :: Int }

61--

52--

62-- instance 'FromRow' User where

53-- instance 'FromRow' User where

63-- fromRow = User \<$\> 'field' \<*\> 'field'

54-- fromRow = User \<$\> 'field' \<*\> 'field'

@@ -67,72 +58,37 @@ import GHC.Generics

67-- in a single row of the query result. Otherwise, a 'ConversionFailed'

58-- in a single row of the query result. Otherwise, a 'ConversionFailed'

68-- exception will be thrown.

59-- exception will be thrown.

69--

60--

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

61+-- Note that 'field' evaluates it's result to WHNF, so the caveats listed in

88−-- mysql-simple and very early versions of postgresql-simple no longer apply.

62+-- previous versions of postgresql-simple no longer apply. Instead, look

89−-- Instead, look at the caveats associated with user-defined implementations

63+-- at the caveats associated with user-defined implementations of 'fromRow'.

90−-- of 'fromField'.

92class FromRow a where

65class FromRow a where

93 fromRow :: RowParser a

66 fromRow :: RowParser a

94− default fromRow :: (Generic a, GFromRow (Rep a)) => RowParser a

95− fromRow = to <$> gfromRow

96−

97−getvalue :: PQ.Result -> PQ.Row -> PQ.Column -> Maybe ByteString

98−getvalue result row col = unsafeDupablePerformIO (PQ.getvalue' result row col)

99−

100−nfields :: PQ.Result -> PQ.Column

101−nfields result = unsafeDupablePerformIO (PQ.nfields result)

102−

103−getTypeInfoByCol :: Row -> PQ.Column -> Conversion TypeInfo

104−getTypeInfoByCol Row{..} col =

105− Conversion $ \conn -> do

106− oid <- PQ.ftype rowresult col

107− Ok <$> getTypeInfo conn oid

108−

109−getTypenameByCol :: Row -> PQ.Column -> Conversion ByteString

110−getTypenameByCol row col = typname <$> getTypeInfoByCol row col

111

112fieldWith :: FieldParser a -> RowParser a

68fieldWith :: FieldParser a -> RowParser a

113fieldWith fieldP = RP $ do

69fieldWith fieldP = RP $ do

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

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

115− r@Row{..} <- ask

71+ Row{..} <- ask

116 column <- lift get

72 column <- lift get

117 lift (put (column + 1))

73 lift (put (column + 1))

118 let ncols = nfields rowresult

74 let ncols = nfields rowresult

119 if (column >= ncols)

75 if (column >= ncols)

120− then lift $ lift $ do

76+ then do

121− vals <- mapM (getTypenameByCol r) [0..ncols-1]

77+ let vals = map (\c -> ( typenames ! (unCol c)

78+ , fmap ellipsis (getvalue rowresult row c) ))

79+ [0..ncols-1]

122− let err = ConversionFailed

80+ convertError = ConversionFailed

123− (show (unCol ncols) ++ " values: " ++ show (map ellipsis vals))

81+ (show (unCol ncols) ++ " values: " ++ show vals)

124− Nothing

125− ""

126 ("at least " ++ show (unCol column + 1)

82 ("at least " ++ show (unCol column + 1)

127 ++ " slots in target type")

83 ++ " slots in target type")

128 "mismatch between number of columns to \

84 "mismatch between number of columns to \

129 \convert and number in target type"

85 \convert and number in target type"

130− conversionError err

86+ lift (lift (Errors [SomeException convertError]))

131 else do

87 else do

88+ let typename = typenames ! unCol column

132− let !result = rowresult

89+ result = rowresult

133− !typeOid = unsafeDupablePerformIO (PQ.ftype result column)

134− !field' = Field{..}

90+ field = Field{..}

135− lift (lift (fieldP field' (getvalue result row column)))

91+ lift (lift (fieldP field (getvalue result row column)))

136

137field :: FromField a => RowParser a

93field :: FromField a => RowParser a

138field = fieldWith fromField

94field = fieldWith fromField

@@ -148,340 +104,57 @@ numFieldsRemaining = RP $ do

148 column <- lift get

104 column <- lift get

149 return $! (\(PQ.Col x) -> fromIntegral x) (nfields rowresult - column)

105 return $! (\(PQ.Col x) -> fromIntegral x) (nfields rowresult - column)

150

106

151−null :: RowParser Null

152−null = field

153−

154instance (FromField a) => FromRow (Only a) where

107instance (FromField a) => FromRow (Only a) where

155 fromRow = Only <$> field

108 fromRow = Only <$> field

156

109

157−instance (FromField a) => FromRow (Maybe (Only a)) where

158− fromRow = (null *> pure Nothing)

159− <|> (Just <$> fromRow)

160−

161instance (FromField a, FromField b) => FromRow (a,b) where

110instance (FromField a, FromField b) => FromRow (a,b) where

162 fromRow = (,) <$> field <*> field

111 fromRow = (,) <$> field <*> field

163

112

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

165− fromRow = (null *> null *> pure Nothing)

166− <|> (Just <$> fromRow)

167−

168instance (FromField a, FromField b, FromField c) => FromRow (a,b,c) where

113instance (FromField a, FromField b, FromField c) => FromRow (a,b,c) where

169 fromRow = (,,) <$> field <*> field <*> field

114 fromRow = (,,) <$> field <*> field <*> field

170

115

171−instance (FromField a, FromField b, FromField c) => FromRow (Maybe (a,b,c)) where

172− fromRow = (null *> null *> null *> pure Nothing)

173− <|> (Just <$> fromRow)

174−

175instance (FromField a, FromField b, FromField c, FromField d) =>

116instance (FromField a, FromField b, FromField c, FromField d) =>

176 FromRow (a,b,c,d) where

117 FromRow (a,b,c,d) where

177 fromRow = (,,,) <$> field <*> field <*> field <*> field

118 fromRow = (,,,) <$> field <*> field <*> field <*> field

178

119

179−instance (FromField a, FromField b, FromField c, FromField d) =>

180− FromRow (Maybe (a,b,c,d)) where

181− fromRow = (null *> null *> null *> null *> pure Nothing)

182− <|> (Just <$> fromRow)

183−

184instance (FromField a, FromField b, FromField c, FromField d, FromField e) =>

120instance (FromField a, FromField b, FromField c, FromField d, FromField e) =>

185 FromRow (a,b,c,d,e) where

121 FromRow (a,b,c,d,e) where

186 fromRow = (,,,,) <$> field <*> field <*> field <*> field <*> field

122 fromRow = (,,,,) <$> field <*> field <*> field <*> field <*> field

187

123

188−instance (FromField a, FromField b, FromField c, FromField d, FromField e) =>

189− FromRow (Maybe (a,b,c,d,e)) where

190− fromRow = (null *> null *> null *> null *> null *> pure Nothing)

191− <|> (Just <$> fromRow)

192−

193instance (FromField a, FromField b, FromField c, FromField d, FromField e,

124instance (FromField a, FromField b, FromField c, FromField d, FromField e,

194 FromField f) =>

125 FromField f) =>

195 FromRow (a,b,c,d,e,f) where

126 FromRow (a,b,c,d,e,f) where

196 fromRow = (,,,,,) <$> field <*> field <*> field <*> field <*> field

127 fromRow = (,,,,,) <$> field <*> field <*> field <*> field <*> field

197 <*> field

128 <*> field

198

129

199−instance (FromField a, FromField b, FromField c, FromField d, FromField e,

200− FromField f) =>

201− FromRow (Maybe (a,b,c,d,e,f)) where

202− fromRow = (null *> null *> null *> null *> null *>

203− null *> pure Nothing)

204− <|> (Just <$> fromRow)

205−

206instance (FromField a, FromField b, FromField c, FromField d, FromField e,

130instance (FromField a, FromField b, FromField c, FromField d, FromField e,

207 FromField f, FromField g) =>

131 FromField f, FromField g) =>

208 FromRow (a,b,c,d,e,f,g) where

132 FromRow (a,b,c,d,e,f,g) where

209 fromRow = (,,,,,,) <$> field <*> field <*> field <*> field <*> field

133 fromRow = (,,,,,,) <$> field <*> field <*> field <*> field <*> field

210 <*> field <*> field

134 <*> field <*> field

211

135

212−instance (FromField a, FromField b, FromField c, FromField d, FromField e,

213− FromField f, FromField g) =>

214− FromRow (Maybe (a,b,c,d,e,f,g)) where

215− fromRow = (null *> null *> null *> null *> null *>

216− null *> null *> pure Nothing)

217− <|> (Just <$> fromRow)

218−

219instance (FromField a, FromField b, FromField c, FromField d, FromField e,

136instance (FromField a, FromField b, FromField c, FromField d, FromField e,

220 FromField f, FromField g, FromField h) =>

137 FromField f, FromField g, FromField h) =>

221 FromRow (a,b,c,d,e,f,g,h) where

138 FromRow (a,b,c,d,e,f,g,h) where

222 fromRow = (,,,,,,,) <$> field <*> field <*> field <*> field <*> field

139 fromRow = (,,,,,,,) <$> field <*> field <*> field <*> field <*> field

223 <*> field <*> field <*> field

140 <*> field <*> field <*> field

224

141

225−instance (FromField a, FromField b, FromField c, FromField d, FromField e,

226− FromField f, FromField g, FromField h) =>

227− FromRow (Maybe (a,b,c,d,e,f,g,h)) where

228− fromRow = (null *> null *> null *> null *> null *>

229− null *> null *> null *> pure Nothing)

230− <|> (Just <$> fromRow)

231−

232instance (FromField a, FromField b, FromField c, FromField d, FromField e,

142instance (FromField a, FromField b, FromField c, FromField d, FromField e,

233 FromField f, FromField g, FromField h, FromField i) =>

143 FromField f, FromField g, FromField h, FromField i) =>

234 FromRow (a,b,c,d,e,f,g,h,i) where

144 FromRow (a,b,c,d,e,f,g,h,i) where

235 fromRow = (,,,,,,,,) <$> field <*> field <*> field <*> field <*> field

145 fromRow = (,,,,,,,,) <$> field <*> field <*> field <*> field <*> field

236 <*> field <*> field <*> field <*> field

146 <*> field <*> field <*> field <*> field

237

147

238−instance (FromField a, FromField b, FromField c, FromField d, FromField e,

239− FromField f, FromField g, FromField h, FromField i) =>

240− FromRow (Maybe (a,b,c,d,e,f,g,h,i)) where

241− fromRow = (null *> null *> null *> null *> null *>

242− null *> null *> null *> null *> pure Nothing)

243− <|> (Just <$> fromRow)

244−

245instance (FromField a, FromField b, FromField c, FromField d, FromField e,

148instance (FromField a, FromField b, FromField c, FromField d, FromField e,

246 FromField f, FromField g, FromField h, FromField i, FromField j) =>

149 FromField f, FromField g, FromField h, FromField i, FromField j) =>

247 FromRow (a,b,c,d,e,f,g,h,i,j) where

150 FromRow (a,b,c,d,e,f,g,h,i,j) where

248 fromRow = (,,,,,,,,,) <$> field <*> field <*> field <*> field <*> field

151 fromRow = (,,,,,,,,,) <$> field <*> field <*> field <*> field <*> field

249 <*> field <*> field <*> field <*> field <*> field

152 <*> field <*> field <*> field <*> field <*> field

250

153

251−instance (FromField a, FromField b, FromField c, FromField d, FromField e,

252− FromField f, FromField g, FromField h, FromField i, FromField j) =>

253− FromRow (Maybe (a,b,c,d,e,f,g,h,i,j)) where

254− fromRow = (null *> null *> null *> null *> null *>

255− null *> null *> null *> null *> null *> pure Nothing)

256− <|> (Just <$> fromRow)

257−

258−instance (FromField a, FromField b, FromField c, FromField d, FromField e,

259− FromField f, FromField g, FromField h, FromField i, FromField j,

260− FromField k) =>

261− FromRow (a,b,c,d,e,f,g,h,i,j,k) where

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

263− <*> field <*> field <*> field <*> field <*> field

264− <*> field

265−

266−instance (FromField a, FromField b, FromField c, FromField d, FromField e,

267− FromField f, FromField g, FromField h, FromField i, FromField j,

268− FromField k) =>

269− FromRow (Maybe (a,b,c,d,e,f,g,h,i,j,k)) where

270− fromRow = (null *> null *> null *> null *> null *>

271− null *> null *> null *> null *> null *>

272− null *> pure Nothing)

273− <|> (Just <$> fromRow)

274−

275−instance (FromField a, FromField b, FromField c, FromField d, FromField e,

276− FromField f, FromField g, FromField h, FromField i, FromField j,

277− FromField k, FromField l) =>

278− FromRow (a,b,c,d,e,f,g,h,i,j,k,l) where

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

280− <*> field <*> field <*> field <*> field <*> field

281− <*> field <*> field

282−

283−instance (FromField a, FromField b, FromField c, FromField d, FromField e,

284− FromField f, FromField g, FromField h, FromField i, FromField j,

285− FromField k, FromField l) =>

286− FromRow (Maybe (a,b,c,d,e,f,g,h,i,j,k,l)) where

287− fromRow = (null *> null *> null *> null *> null *>

288− null *> null *> null *> null *> null *>

289− null *> null *> pure Nothing)

290− <|> (Just <$> fromRow)

291−

292−instance (FromField a, FromField b, FromField c, FromField d, FromField e,

293− FromField f, FromField g, FromField h, FromField i, FromField j,

294− FromField k, FromField l, FromField m) =>

295− FromRow (a,b,c,d,e,f,g,h,i,j,k,l,m) where

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

297− <*> field <*> field <*> field <*> field <*> field

298− <*> field <*> field <*> field

299−

300−instance (FromField a, FromField b, FromField c, FromField d, FromField e,

301− FromField f, FromField g, FromField h, FromField i, FromField j,

302− FromField k, FromField l, FromField m) =>

303− FromRow (Maybe (a,b,c,d,e,f,g,h,i,j,k,l,m)) where

304− fromRow = (null *> null *> null *> null *> null *>

305− null *> null *> null *> null *> null *>

306− null *> null *> null *> pure Nothing)

307− <|> (Just <$> fromRow)

308−

309−instance (FromField a, FromField b, FromField c, FromField d, FromField e,

310− FromField f, FromField g, FromField h, FromField i, FromField j,

311− FromField k, FromField l, FromField m, FromField n) =>

312− FromRow (a,b,c,d,e,f,g,h,i,j,k,l,m,n) where

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

314− <*> field <*> field <*> field <*> field <*> field

315− <*> field <*> field <*> field <*> field

316−

317−instance (FromField a, FromField b, FromField c, FromField d, FromField e,

318− FromField f, FromField g, FromField h, FromField i, FromField j,

319− FromField k, FromField l, FromField m, FromField n) =>

320− FromRow (Maybe (a,b,c,d,e,f,g,h,i,j,k,l,m,n)) where

321− fromRow = (null *> null *> null *> null *> null *>

322− null *> null *> null *> null *> null *>

323− null *> null *> null *> null *> pure Nothing)

324− <|> (Just <$> fromRow)

325−

326−instance (FromField a, FromField b, FromField c, FromField d, FromField e,

327− FromField f, FromField g, FromField h, FromField i, FromField j,

328− FromField k, FromField l, FromField m, FromField n, FromField o) =>

329− FromRow (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o) where

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

331− <*> field <*> field <*> field <*> field <*> field

332− <*> field <*> field <*> field <*> field <*> field

333−

334−instance (FromField a, FromField b, FromField c, FromField d, FromField e,

335− FromField f, FromField g, FromField h, FromField i, FromField j,

336− FromField k, FromField l, FromField m, FromField n, FromField o) =>

337− FromRow (Maybe (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o)) where

338− fromRow = (null *> null *> null *> null *> null *>

339− null *> null *> null *> null *> null *>

340− null *> null *> null *> null *> null *> pure Nothing)

341− <|> (Just <$> fromRow)

342−

343−instance (FromField a, FromField b, FromField c, FromField d, FromField e,

344− FromField f, FromField g, FromField h, FromField i, FromField j,

345− FromField k, FromField l, FromField m, FromField n, FromField o,

346− FromField p) =>

347− FromRow (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p) where

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

349− <*> field <*> field <*> field <*> field <*> field

350− <*> field <*> field <*> field <*> field <*> field

351− <*> field

352−

353−instance (FromField a, FromField b, FromField c, FromField d, FromField e,

354− FromField f, FromField g, FromField h, FromField i, FromField j,

355− FromField k, FromField l, FromField m, FromField n, FromField o,

356− FromField p) =>

357− FromRow (Maybe (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p)) where

358− fromRow = (null *> null *> null *> null *> null *>

359− null *> null *> null *> null *> null *>

360− null *> null *> null *> null *> null *>

361− null *> pure Nothing)

362− <|> (Just <$> fromRow)

363−

364−instance (FromField a, FromField b, FromField c, FromField d, FromField e,

365− FromField f, FromField g, FromField h, FromField i, FromField j,

366− FromField k, FromField l, FromField m, FromField n, FromField o,

367− FromField p, FromField q) =>

368− FromRow (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q) where

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

370− <*> field <*> field <*> field <*> field <*> field

371− <*> field <*> field <*> field <*> field <*> field

372− <*> field <*> field

373−

374−instance (FromField a, FromField b, FromField c, FromField d, FromField e,

375− FromField f, FromField g, FromField h, FromField i, FromField j,

376− FromField k, FromField l, FromField m, FromField n, FromField o,

377− FromField p, FromField q) =>

378− FromRow (Maybe (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q)) where

379− fromRow = (null *> null *> null *> null *> null *>

380− null *> null *> null *> null *> null *>

381− null *> null *> null *> null *> null *>

382− null *> null *> pure Nothing)

383− <|> (Just <$> fromRow)

384−

385−instance (FromField a, FromField b, FromField c, FromField d, FromField e,

386− FromField f, FromField g, FromField h, FromField i, FromField j,

387− FromField k, FromField l, FromField m, FromField n, FromField o,

388− FromField p, FromField q, FromField r) =>

389− FromRow (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r) where

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

391− <*> field <*> field <*> field <*> field <*> field

392− <*> field <*> field <*> field <*> field <*> field

393− <*> field <*> field <*> field

394−

395−instance (FromField a, FromField b, FromField c, FromField d, FromField e,

396− FromField f, FromField g, FromField h, FromField i, FromField j,

397− FromField k, FromField l, FromField m, FromField n, FromField o,

398− FromField p, FromField q, FromField r) =>

399− FromRow (Maybe (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r)) where

400− fromRow = (null *> null *> null *> null *> null *>

401− null *> null *> null *> null *> null *>

402− null *> null *> null *> null *> null *>

403− null *> null *> null *> pure Nothing)

404− <|> (Just <$> fromRow)

405−

406−instance (FromField a, FromField b, FromField c, FromField d, FromField e,

407− FromField f, FromField g, FromField h, FromField i, FromField j,

408− FromField k, FromField l, FromField m, FromField n, FromField o,

409− FromField p, FromField q, FromField r, FromField s) =>

410− FromRow (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s) where

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

412− <*> field <*> field <*> field <*> field <*> field

413− <*> field <*> field <*> field <*> field <*> field

414− <*> field <*> field <*> field <*> field

415−

416−instance (FromField a, FromField b, FromField c, FromField d, FromField e,

417− FromField f, FromField g, FromField h, FromField i, FromField j,

418− FromField k, FromField l, FromField m, FromField n, FromField o,

419− FromField p, FromField q, FromField r, FromField s) =>

420− FromRow (Maybe (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s)) where

421− fromRow = (null *> null *> null *> null *> null *>

422− null *> null *> null *> null *> null *>

423− null *> null *> null *> null *> null *>

424− null *> null *> null *> null *> pure Nothing)

425− <|> (Just <$> fromRow)

426−

427−instance (FromField a, FromField b, FromField c, FromField d, FromField e,

428− FromField f, FromField g, FromField h, FromField i, FromField j,

429− FromField k, FromField l, FromField m, FromField n, FromField o,

430− FromField p, FromField q, FromField r, FromField s, FromField t) =>

431− FromRow (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t) where

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

433− <*> field <*> field <*> field <*> field <*> field

434− <*> field <*> field <*> field <*> field <*> field

435− <*> field <*> field <*> field <*> field <*> field

436−

437−instance (FromField a, FromField b, FromField c, FromField d, FromField e,

438− FromField f, FromField g, FromField h, FromField i, FromField j,

439− FromField k, FromField l, FromField m, FromField n, FromField o,

440− FromField p, FromField q, FromField r, FromField s, FromField t) =>

441− FromRow (Maybe (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t)) where

442− fromRow = (null *> null *> null *> null *> null *>

443− null *> null *> null *> null *> null *>

444− null *> null *> null *> null *> null *>

445− null *> null *> null *> null *> null *> pure Nothing)

446− <|> (Just <$> fromRow)

447−

448instance FromField a => FromRow [a] where

154instance FromField a => FromRow [a] where

449 fromRow = do

155 fromRow = do

450 n <- numFieldsRemaining

156 n <- numFieldsRemaining

451 replicateM n field

157 replicateM n field

452

158

453−instance FromField a => FromRow (Maybe [a]) where

454− fromRow = do

455− n <- numFieldsRemaining

456− (replicateM_ n null *> pure Nothing) <|> (Just <$> replicateM n field)

457−

458−instance FromField a => FromRow (Vector a) where

459− fromRow = do

460− n <- numFieldsRemaining

461− V.replicateM n field

462−

463−instance FromField a => FromRow (Maybe (Vector a)) where

464− fromRow = do

465− n <- numFieldsRemaining

466− (replicateM_ n null *> pure Nothing) <|> (Just <$> V.replicateM n field)

467−

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

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

469 fromRow = (:.) <$> fromRow <*> fromRow

160 fromRow = (:.) <$> fromRow <*> fromRow

470−

471−

472−

473−-- Type class for default implementation of FromRow using generics

474−class GFromRow f where

475− gfromRow :: RowParser (f p)

476−

477−instance GFromRow f => GFromRow (M1 c i f) where

478− gfromRow = M1 <$> gfromRow

479−

480−instance (GFromRow f, GFromRow g) => GFromRow (f :*: g) where

481− gfromRow = liftA2 (:*:) gfromRow gfromRow

482−

483−instance (FromField a) => GFromRow (K1 R a) where

484− gfromRow = K1 <$> field

485−

486−instance GFromRow U1 where

487− gfromRow = pure U1

src/Database/PostgreSQL/Simple/FromRow.hs-bootdeleted−17

@@ -1,17 +0,0 @@

1−module Database.PostgreSQL.Simple.FromRow where

2−

3−import {-# SOURCE #-} Database.PostgreSQL.Simple.FromField

4−import Database.PostgreSQL.Simple.Types

5−

6−class FromRow a

7−

8−instance (FromField a) => FromRow (Only a)

9−instance (FromField a, FromField b)

10− => FromRow (a,b)

11−instance (FromField a, FromField b, FromField c, FromField d)

12− => FromRow (a,b,c,d)

13−instance (FromField a, FromField b, FromField c, FromField d, FromField e)

14− => FromRow (a,b,c,d,e)

15−instance (FromField a, FromField b, FromField c, FromField d, FromField e

16− ,FromField f)

17− => FromRow (a,b,c,d,e,f)

src/Database/PostgreSQL/Simple/HStore.hsdeleted−36

@@ -1,36 +0,0 @@

1−------------------------------------------------------------------------------

2−-- |

3−-- Module: Database.PostgreSQL.Simple.HStore

5−-- License: BSD3

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

7−-- Stability: experimental

8−--

9−-- Parsers and printers for hstore, a extended type bundled with

10−-- PostgreSQL providing finite maps from text strings to text strings.

11−-- See <https://www.postgresql.org/docs/9.5/static/hstore.html> for more

12−-- information.

13−--

14−-- Note that in order to use this type, a database superuser must

15−-- install it by running a sql script in the share directory. This

16−-- can be done on PostgreSQL 9.1 and later with the command

17−-- @CREATE EXTENSION hstore@. See

18−-- <https://www.postgresql.org/docs/9.5/static/contrib.html> for more

19−-- information.

20−--

21−------------------------------------------------------------------------------

22−

23−module Database.PostgreSQL.Simple.HStore

24− ( HStoreList(..)

25− , HStoreMap(..)

26− , ToHStore(..)

27− , HStoreBuilder

28− , toBuilder

29− , toLazyByteString

30− , hstore

31− , parseHStoreList

32− , ToHStoreText(..)

33− , HStoreText

34− ) where

35−

36−import Database.PostgreSQL.Simple.HStore.Implementation

src/Database/PostgreSQL/Simple/HStore/Implementation.hsdeleted−210

@@ -1,210 +0,0 @@

1−{-# LANGUAGE CPP, ViewPatterns, DeriveDataTypeable, GeneralizedNewtypeDeriving #-}

2−

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

4−-- |

5−-- Module: Database.PostgreSQL.Simple.HStore.Implementation

7−-- License: BSD3

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

9−-- Stability: experimental

10−--

11−-- This code has yet to be profiled and optimized.

12−--

13−------------------------------------------------------------------------------

14−

15−module Database.PostgreSQL.Simple.HStore.Implementation where

16−

17−import Control.Applicative

18−import qualified Data.Attoparsec.ByteString as P

19−import qualified Data.Attoparsec.ByteString.Char8 as P (isSpace_w8)

20−import qualified Data.ByteString as BS

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

22−import qualified Data.ByteString.Builder as BU

23−import Data.ByteString.Internal (c2w, w2c)

24−import qualified Data.ByteString.Lazy as BL

25−import Data.Map(Map)

26−import qualified Data.Map as Map

27−import Data.Text(Text)

28−import qualified Data.Text as TS

29−import qualified Data.Text.Encoding as TS

30−import Data.Text.Encoding.Error(UnicodeException)

31−import qualified Data.Text.Lazy as TL

32−import Data.Typeable

33−import Data.Monoid(Monoid(..))

34−import Data.Semigroup

35−import Database.PostgreSQL.Simple.FromField

36−import Database.PostgreSQL.Simple.ToField

37−

38−class ToHStore a where

39− toHStore :: a -> HStoreBuilder

40−

41−-- | Represents valid hstore syntax.

42−data HStoreBuilder

43− = Empty

44− | Comma !Builder

45− deriving (Typeable)

46−

47−instance ToHStore HStoreBuilder where

48− toHStore = id

49−

50−toBuilder :: HStoreBuilder -> Builder

51−toBuilder x = case x of

52− Empty -> mempty

53− Comma c -> c

54−

55−toLazyByteString :: HStoreBuilder -> BL.ByteString

56−toLazyByteString x = case x of

57− Empty -> BL.empty

58− Comma c -> BU.toLazyByteString c

59−

60−instance Semigroup HStoreBuilder where

61− Empty <> x = x

62− Comma a <> x

63− = Comma (a `mappend` case x of

64− Empty -> mempty

65− Comma b -> char8 ',' `mappend` b)

66−

67−instance Monoid HStoreBuilder where

68− mempty = Empty

69−

70−class ToHStoreText a where

71− toHStoreText :: a -> HStoreText

72−

73−-- | Represents escape text, ready to be the key or value to a hstore value

74−newtype HStoreText = HStoreText Builder deriving (Typeable, Semigroup, Monoid)

75−

76−instance ToHStoreText HStoreText where

77− toHStoreText = id

78−

79−-- | Assumed to be UTF-8 encoded

80−instance ToHStoreText BS.ByteString where

81− toHStoreText str = HStoreText (escapeAppend str mempty)

82−

83−-- | Assumed to be UTF-8 encoded

84−instance ToHStoreText BL.ByteString where

85− toHStoreText = HStoreText . BL.foldrChunks escapeAppend mempty

86−

87−instance ToHStoreText TS.Text where

88− toHStoreText str = HStoreText (escapeAppend (TS.encodeUtf8 str) mempty)

89−

90−instance ToHStoreText TL.Text where

91− toHStoreText = HStoreText . TL.foldrChunks (escapeAppend . TS.encodeUtf8) mempty

92−

93−escapeAppend :: BS.ByteString -> Builder -> Builder

94−escapeAppend = loop

95− where

96− loop (BS.break quoteNeeded -> (a,b)) rest

97− = byteString a `mappend`

98− case BS.uncons b of

99− Nothing -> rest

100− Just (c,d) -> quoteChar c `mappend` loop d rest

101−

102− quoteNeeded c = c == c2w '\"' || c == c2w '\\'

103− quoteChar c

104− | c == c2w '\"' = byteString "\\\""

105− | otherwise = byteString "\\\\"

106−

107−hstore :: (ToHStoreText a, ToHStoreText b) => a -> b -> HStoreBuilder

108−hstore (toHStoreText -> (HStoreText key)) (toHStoreText -> (HStoreText val)) =

109− Comma (char8 '"' `mappend` key `mappend` byteString "\"=>\""

110− `mappend` val `mappend` char8 '"')

111−

112−instance ToField HStoreBuilder where

113− toField Empty = toField (BS.empty)

114− toField (Comma x) = toField (BU.toLazyByteString x)

115−

116−newtype HStoreList = HStoreList {fromHStoreList :: [(Text,Text)]} deriving (Typeable, Show)

117−

118−-- | hstore

119−instance ToHStore HStoreList where

120− toHStore (HStoreList xs) = mconcat (map (uncurry hstore) xs)

121−

122−instance ToField HStoreList where

123− toField xs = toField (toHStore xs)

124−

125−-- | hstore

126−instance FromField HStoreList where

127− fromField f mdat = do

128− typ <- typename f

129− if typ /= "hstore"

130− then returnError Incompatible f ""

131− else case mdat of

132− Nothing -> returnError UnexpectedNull f ""

133− Just dat ->

134− case P.parseOnly (parseHStore <* P.endOfInput) dat of

135− Left err ->

136− returnError ConversionFailed f err

137− Right (Left err) ->

138− returnError ConversionFailed f "unicode exception" <|>

139− conversionError err

140− Right (Right val) ->

141− return val

142−

143−newtype HStoreMap = HStoreMap {fromHStoreMap :: Map Text Text} deriving (Eq, Ord, Typeable, Show)

144−

145−instance ToHStore HStoreMap where

146− toHStore (HStoreMap xs) = Map.foldrWithKey f mempty xs

147− where f k v xs' = hstore k v `mappend` xs'

148−

149−instance ToField HStoreMap where

150− toField xs = toField (toHStore xs)

151−

152−instance FromField HStoreMap where

153− fromField f mdat = convert <$> fromField f mdat

154− where convert (HStoreList xs) = HStoreMap (Map.fromList xs)

155−

156−parseHStoreList :: BS.ByteString -> Either String HStoreList

157−parseHStoreList dat =

158− case P.parseOnly (parseHStore <* P.endOfInput) dat of

159− Left err -> Left (show err)

160− Right (Left err) -> Left (show err)

161− Right (Right val) -> Right val

162−

163−parseHStore :: P.Parser (Either UnicodeException HStoreList)

164−parseHStore = do

165− kvs <- P.sepBy' (skipWhiteSpace *> parseHStoreKeyVal)

166− (skipWhiteSpace *> P.word8 (c2w ','))

167− return $ HStoreList <$> sequence kvs

168−

169−parseHStoreKeyVal :: P.Parser (Either UnicodeException (Text,Text))

170−parseHStoreKeyVal = do

171− mkey <- parseHStoreText

172− case mkey of

173− Left err -> return (Left err)

174− Right key -> do

175− skipWhiteSpace

176− _ <- P.string "=>"

177− skipWhiteSpace

178− mval <- parseHStoreText

179− case mval of

180− Left err -> return (Left err)

181− Right val -> return (Right (key,val))

182−

183−

184−skipWhiteSpace :: P.Parser ()

185−skipWhiteSpace = P.skipWhile P.isSpace_w8

186−

187−parseHStoreText :: P.Parser (Either UnicodeException Text)

188−parseHStoreText = do

189− _ <- P.word8 (c2w '"')

190− mtexts <- parseHStoreTexts id

191− case mtexts of

192− Left err -> return (Left err)

193− Right texts -> do

194− _ <- P.word8 (c2w '"')

195− return (Right (TS.concat texts))

196−

197−parseHStoreTexts :: ([Text] -> [Text])

198− -> P.Parser (Either UnicodeException [Text])

199−parseHStoreTexts acc = do

200− mchunk <- TS.decodeUtf8' <$> P.takeWhile (not . isSpecialChar)

201− case mchunk of

202− Left err -> return (Left err)

203− Right chunk ->

204− (do

205− _ <- P.word8 (c2w '\\')

206− c <- TS.singleton . w2c <$> P.satisfy isSpecialChar

207− parseHStoreTexts (acc . (chunk:) . (c:))

208− ) <|> return (Right (acc [chunk]))

209− where

210− isSpecialChar c = c == c2w '\\' || c == c2w '"'

src/Database/PostgreSQL/Simple/HStore/Internal.hsdeleted−19

@@ -1,19 +0,0 @@

1−------------------------------------------------------------------------------

2−-- |

3−-- Module: Database.PostgreSQL.Simple.HStore.Internal

5−-- License: BSD3

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

7−-- Stability: experimental

8−--

9−------------------------------------------------------------------------------

10−

11−module Database.PostgreSQL.Simple.HStore.Internal

12− ( HStoreBuilder(..)

13− , HStoreText(..)

14− , parseHStore

15− , parseHStoreKeyVal

16− , parseHStoreText

17− ) where

18−

19−import Database.PostgreSQL.Simple.HStore.Implementation

src/Database/PostgreSQL/Simple/Internal.hs+75−397

@@ -1,16 +1,12 @@

1−{-# LANGUAGE CPP, BangPatterns, DoAndIfThenElse, RecordWildCards #-}

2−{-# LANGUAGE DeriveDataTypeable, DeriveGeneric #-}

3−{-# LANGUAGE GeneralizedNewtypeDeriving #-}

1+{-# LANGUAGE RecordWildCards, DeriveDataTypeable, GeneralizedNewtypeDeriving #-}

4−{-# LANGUAGE ExistentialQuantification #-}

5−{-# LANGUAGE InstanceSigs #-}

6−

7------------------------------------------------------------------------------

2------------------------------------------------------------------------------

8-- |

3-- |

9-- Module: Database.PostgreSQL.Simple.Internal

4-- Module: Database.PostgreSQL.Simple.Internal

11-- License: BSD3

6-- License: BSD3

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

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

13-- Stability: experimental

8-- Stability: experimental

9+-- Portability: portable

14--

10--

15-- Internal bits. This interface is less stable and can change at any time.

11-- Internal bits. This interface is less stable and can change at any time.

16-- In particular this means that while the rest of the postgresql-simple

12-- In particular this means that while the rest of the postgresql-simple

@@ -23,40 +19,29 @@

24module Database.PostgreSQL.Simple.Internal where

20module Database.PostgreSQL.Simple.Internal where

22+import Prelude hiding (catch)

23+

26import Control.Applicative

24import Control.Applicative

27import Control.Exception

25import Control.Exception

28import Control.Concurrent.MVar

26import Control.Concurrent.MVar

29−import Control.Monad(MonadPlus(..))

30import Data.ByteString(ByteString)

27import Data.ByteString(ByteString)

31−import qualified Data.ByteString as B

28+import qualified Data.ByteString as B

32import qualified Data.ByteString.Char8 as B8

29import qualified Data.ByteString.Char8 as B8

33−import Data.ByteString.Builder ( Builder, byteString )

34import Data.Char (ord)

30import Data.Char (ord)

35import Data.Int (Int64)

31import Data.Int (Int64)

36import qualified Data.IntMap as IntMap

32import qualified Data.IntMap as IntMap

37−import Data.IORef

38−import Data.Maybe(fromMaybe)

39import Data.String

33import Data.String

40−import qualified Data.Text as T

41−import qualified Data.Text.Encoding as TE

42import Data.Typeable

34import Data.Typeable

43import Data.Word

35import Data.Word

44import Database.PostgreSQL.LibPQ(Oid(..))

36import Database.PostgreSQL.LibPQ(Oid(..))

45import qualified Database.PostgreSQL.LibPQ as PQ

37import qualified Database.PostgreSQL.LibPQ as PQ

46−import Database.PostgreSQL.LibPQ(ExecStatus(..))

38+import Database.PostgreSQL.Simple.BuiltinTypes (BuiltinType)

47−import Database.PostgreSQL.Simple.Compat ( toByteString )

48import Database.PostgreSQL.Simple.Ok

39import Database.PostgreSQL.Simple.Ok

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

50import Database.PostgreSQL.Simple.Types (Query(..))

40import Database.PostgreSQL.Simple.Types (Query(..))

51−import Database.PostgreSQL.Simple.TypeInfo.Types(TypeInfo)

52import Control.Monad.Trans.State.Strict

41import Control.Monad.Trans.State.Strict

53import Control.Monad.Trans.Reader

42import Control.Monad.Trans.Reader

54−import Control.Monad.Trans.Class

43+import qualified Data.Vector as V

55−import GHC.Generics

44+import System.IO.Unsafe (unsafePerformIO)

56−import GHC.IO.Exception

57−#if !defined(mingw32_HOST_OS)

58−import Control.Concurrent(threadWaitRead, threadWaitWrite)

59−#endif

61-- | A Field represents metadata about a particular field

46-- | A Field represents metadata about a particular field

62--

47--

@@ -67,56 +52,44 @@ import Control.Concurrent(threadWaitRead, threadWaitWrite)

67data Field = Field {

52data Field = Field {

68 result :: !PQ.Result

53 result :: !PQ.Result

69 , column :: {-# UNPACK #-} !PQ.Column

54 , column :: {-# UNPACK #-} !PQ.Column

70− , typeOid :: {-# UNPACK #-} !PQ.Oid

55+ , typename :: !ByteString

71− -- ^ This returns the type oid associated with the column. Analogous

72− -- to libpq's @PQftype@.

73 }

56 }

75−type TypeInfoCache = IntMap.IntMap TypeInfo

58+name :: Field -> Maybe ByteString

59+name Field{..} = unsafePerformIO (PQ.fname result column)

77−data Connection = Connection {

61+tableOid :: Field -> PQ.Oid

78− connectionHandle :: {-# UNPACK #-} !(MVar PQ.Connection)

62+tableOid Field{..} = unsafePerformIO (PQ.ftable result column)

79− , connectionObjects :: {-# UNPACK #-} !(MVar TypeInfoCache)

80− , connectionTempNameCounter :: {-# UNPACK #-} !(IORef Int64)

81− } deriving (Typeable)

83−instance Eq Connection where

64+tableColumn :: Field -> Int

84− x == y = connectionHandle x == connectionHandle y

65+tableColumn Field{..} = fromCol (unsafePerformIO (PQ.ftablecol result column))

66+ where

67+ fromCol (PQ.Col x) = fromIntegral x

86−-- | Superclass for postgresql exceptions

87−data SomePostgreSqlException = forall e. Exception e => SomePostgreSqlException e

88− deriving Typeable

90−postgresqlExceptionToException :: Exception e => e -> SomeException

70+format :: Field -> PQ.Format

91−postgresqlExceptionToException = toException . SomePostgreSqlException

71+format Field{..} = unsafePerformIO (PQ.fformat result column)

93−postgresqlExceptionFromException :: Exception e => SomeException -> Maybe e

73+typeOid :: Field -> PQ.Oid

94−postgresqlExceptionFromException x = do

74+typeOid Field{..} = unsafePerformIO (PQ.ftype result column)

95− SomePostgreSqlException a <- fromException x

96− cast a

98−instance Show SomePostgreSqlException where

99− showsPrec :: Int -> SomePostgreSqlException -> ShowS

100− showsPrec p (SomePostgreSqlException e) = showsPrec p e

101

102−instance Exception SomePostgreSqlException where

77+data Connection = Connection {

103− displayException (SomePostgreSqlException e) = displayException e

78+ connectionHandle :: {-# UNPACK #-} !(MVar PQ.Connection)

79+ , connectionObjects :: {-# UNPACK #-} !(MVar (IntMap.IntMap ByteString))

80+ }

81+

82+data SqlType

83+ = Builtin BuiltinType

84+ | Other Oid

104

105data SqlError = SqlError {

86data SqlError = SqlError {

106 sqlState :: ByteString

87 sqlState :: ByteString

107− , sqlExecStatus :: ExecStatus

88+ , sqlNativeError :: Int

108 , sqlErrorMsg :: ByteString

89 , sqlErrorMsg :: ByteString

109− , sqlErrorDetail :: ByteString

110− , sqlErrorHint :: ByteString

111− } deriving (Eq, Show, Typeable)

90+ } deriving (Show, Typeable)

112−

113−fatalError :: ByteString -> SqlError

114−fatalError msg = SqlError "" FatalError msg "" ""

115−

116−instance Exception SqlError where

117− toException = postgresqlExceptionToException

118− fromException = postgresqlExceptionFromException

119

92+instance Exception SqlError

120

121-- | Exception thrown if 'query' is used to perform an @INSERT@-like

94-- | Exception thrown if 'query' is used to perform an @INSERT@-like

122-- operation, or 'execute' is used to perform a @SELECT@-like operation.

95-- operation, or 'execute' is used to perform a @SELECT@-like operation.

@@ -125,22 +98,7 @@ data QueryError = QueryError {

125 , qeQuery :: Query

98 , qeQuery :: Query

126 } deriving (Eq, Show, Typeable)

99 } deriving (Eq, Show, Typeable)

127

100

128−instance Exception QueryError where

101+instance Exception QueryError

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

144

102

145data ConnectInfo = ConnectInfo {

103data ConnectInfo = ConnectInfo {

146 connectHost :: String

104 connectHost :: String

@@ -148,7 +106,7 @@ data ConnectInfo = ConnectInfo {

148 , connectUser :: String

106 , connectUser :: String

149 , connectPassword :: String

107 , connectPassword :: String

150 , connectDatabase :: String

108 , connectDatabase :: String

151− } deriving (Generic,Eq,Read,Show,Typeable)

109+ } deriving (Eq,Read,Show,Typeable)

152

110

153-- | Default information for setting up a connection.

111-- | Default information for setting up a connection.

154--

112--

@@ -182,132 +140,31 @@ defaultConnectInfo = ConnectInfo {

182connect :: ConnectInfo -> IO Connection

140connect :: ConnectInfo -> IO Connection

183connect = connectPostgreSQL . postgreSQLConnectionString

141connect = connectPostgreSQL . postgreSQLConnectionString

184

142

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−

191-- | Attempt to make a connection based on a libpq connection string.

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

144+-- See <http://www.postgresql.org/docs/9.1/static/libpq-connect.html>

193−-- for more information. Also note that environment variables also affect

145+-- for more information.

194−-- parameters not provided, parameters provided as the empty string, and a

195−-- few other things; see

196−-- <https://www.postgresql.org/docs/9.5/static/libpq-envars.html>

197−-- for details. Here is an example with some of the most commonly used

198−-- parameters:

199−--

200−-- > host='db.somedomain.com' port=5432 ...

201−--

202−-- This attempts to connect to @db.somedomain.com:5432@. Omitting the port

203−-- will normally default to 5432.

204−--

205−-- On systems that provide unix domain sockets, omitting the host parameter

206−-- will cause libpq to attempt to connect via unix domain sockets.

207−-- The default filesystem path to the socket is constructed from the

208−-- port number and the @DEFAULT_PGSOCKET_DIR@ constant defined in the

209−-- @pg_config_manual.h@ header file. Connecting via unix sockets tends

210−-- to use the @peer@ authentication method, which is very secure and

211−-- does not require a password.

212−--

213−-- On Windows and other systems without unix domain sockets, omitting

214−-- the host will default to @localhost@.

215−--

216−-- > ... dbname='postgres' user='postgres' password='secret \' \\ pw'

217−--

218−-- This attempts to connect to a database named @postgres@ with

219−-- user @postgres@ and password @secret \' \\ pw@. Backslash

220−-- characters will have to be double-quoted in literal Haskell strings,

221−-- of course. Omitting @dbname@ and @user@ will both default to the

222−-- system username that the client process is running as.

223−--

224−-- Omitting @password@ will default to an appropriate password found

225−-- in the @pgpass@ file, or no password at all if a matching line is

226−-- not found. The path of the @pgpass@ file may be specified by setting

227−-- the @PGPASSFILE@ environment variable. See

228−-- <https://www.postgresql.org/docs/9.5/static/libpq-pgpass.html> for

229−-- more information regarding this file.

230−--

231−-- As all parameters are optional and the defaults are sensible, the

232−-- empty connection string can be useful for development and

233−-- exploratory use, assuming your system is set up appropriately.

234−--

235−-- On Unix, such a setup would typically consist of a local

236−-- postgresql server listening on port 5432, as well as a system user,

237−-- database user, and database sharing a common name, with permissions

238−-- granted to the user on the database.

239−--

240−-- On Windows, in addition you will either need @pg_hba.conf@

241−-- to specify the use of the @trust@ authentication method for

242−-- the connection, which may not be appropriate for multiuser

243−-- or production machines, or you will need to use a @pgpass@ file

244−-- with the @password@ or @md5@ authentication methods.

245−--

246−-- See <https://www.postgresql.org/docs/9.5/static/client-authentication.html>

247−-- for more information regarding the authentication process.

248−--

249−-- SSL/TLS will typically "just work" if your postgresql server supports or

250−-- requires it. However, note that libpq is trivially vulnerable to a MITM

251−-- attack without setting additional SSL connection parameters. In

252−-- particular, @sslmode@ needs to be set to @require@, @verify-ca@, or

253−-- @verify-full@ in order to perform certificate validation. When @sslmode@

254−-- is @require@, then you will also need to specify a @sslrootcert@ file,

255−-- otherwise no validation of the server's identity will be performed.

256−-- Client authentication via certificates is also possible via the

257−-- @sslcert@ and @sslkey@ parameters. See

258−-- <https://www.postgresql.org/docs/9.5/static/libpq-ssl.html>

259−-- for detailed information regarding libpq and SSL.

260

146

261connectPostgreSQL :: ByteString -> IO Connection

147connectPostgreSQL :: ByteString -> IO Connection

262connectPostgreSQL connstr = do

148connectPostgreSQL connstr = do

263− conn <- connectdb connstr

149+ conn <- PQ.connectdb connstr

264 stat <- PQ.status conn

150 stat <- PQ.status conn

265 case stat of

151 case stat of

266 PQ.ConnectionOk -> do

152 PQ.ConnectionOk -> do

267 connectionHandle <- newMVar conn

153 connectionHandle <- newMVar conn

268 connectionObjects <- newMVar (IntMap.empty)

154 connectionObjects <- newMVar (IntMap.empty)

269− connectionTempNameCounter <- newIORef 0

270 let wconn = Connection{..}

155 let wconn = Connection{..}

271 version <- PQ.serverVersion conn

156 version <- PQ.serverVersion conn

272 let settings

157 let settings

273− | version < 80200 = "SET datestyle TO ISO;SET client_encoding TO UTF8"

158+ | version < 80200 = "SET datestyle TO ISO"

274− | otherwise = "SET datestyle TO ISO;SET client_encoding TO UTF8;SET standard_conforming_strings TO on"

159+ | otherwise = "SET standard_conforming_strings TO on;\

160+ \SET datestyle TO ISO"

275 _ <- execute_ wconn settings

161 _ <- execute_ wconn settings

276 return wconn

162 return wconn

277 _ -> do

163 _ -> do

278 msg <- maybe "connectPostgreSQL error" id <$> PQ.errorMessage conn

164 msg <- maybe "connectPostgreSQL error" id <$> PQ.errorMessage conn

279− throwIO $ fatalError msg

165+ throwIO $ SqlError { sqlNativeError = -1 -- FIXME?

280−

166+ , sqlErrorMsg = msg

281−connectdb :: ByteString -> IO PQ.Connection

167+ , sqlState = "" }

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

168

312-- | Turns a 'ConnectInfo' data structure into a libpq connection string.

169-- | Turns a 'ConnectInfo' data structure into a libpq connection string.

313

170

@@ -323,7 +180,7 @@ postgreSQLConnectionString connectInfo = fromString connstr

323

180

324 str name field

181 str name field

325 | null value = id

182 | null value = id

326− | otherwise = showString name . addQuotes value . space

183+ | otherwise = showString name . quote value . space

327 where value = field connectInfo

184 where value = field connectInfo

328

185

329 num name field

186 num name field

@@ -331,7 +188,7 @@ postgreSQLConnectionString connectInfo = fromString connstr

331 | otherwise = showString name . shows value . space

188 | otherwise = showString name . shows value . space

332 where value = field connectInfo

189 where value = field connectInfo

333

190

334− addQuotes s rest = '\'' : foldr delta ('\'' : rest) s

191+ quote str rest = '\'' : foldr delta ('\'' : rest) str

335 where

192 where

336 delta c cs = case c of

193 delta c cs = case c of

337 '\\' -> '\\' : '\\' : cs

194 '\\' -> '\\' : '\\' : cs

@@ -350,53 +207,17 @@ oid2int (Oid x) = fromIntegral x

350exec :: Connection

207exec :: Connection

351 -> ByteString

208 -> ByteString

352 -> IO PQ.Result

209 -> IO PQ.Result

353−#if defined(mingw32_HOST_OS)

354exec conn sql =

210exec conn sql =

355 withConnection conn $ \h -> do

211 withConnection conn $ \h -> do

356 mres <- PQ.exec h sql

212 mres <- PQ.exec h sql

357 case mres of

213 case mres of

358− Nothing -> throwLibPQError h "PQexec returned no results"

214+ Nothing -> do

359− Just res -> return res

215+ msg <- maybe "execute error" id <$> PQ.errorMessage h

360−#else

216+ throwIO $ SqlError { sqlNativeError = -1 -- FIXME?

361−exec conn sql =

217+ , sqlErrorMsg = msg

362− withConnection conn $ \h -> do

218+ , sqlState = "" }

363− success <- PQ.sendQuery h sql

219+ Just res -> do

364− if success

220+ return res

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

400

221

401-- | A version of 'execute' that does not perform query substitution.

222-- | A version of 'execute' that does not perform query substitution.

402execute_ :: Connection -> Query -> IO Int64

223execute_ :: Connection -> Query -> IO Int64

@@ -408,7 +229,6 @@ finishExecute :: Connection -> Query -> PQ.Result -> IO Int64

408finishExecute _conn q result = do

229finishExecute _conn q result = do

409 status <- PQ.resultStatus result

230 status <- PQ.resultStatus result

410 case status of

231 case status of

411− -- FIXME: handle PQ.CopyBoth and PQ.SingleTuple

412 PQ.EmptyQuery -> throwIO $ QueryError "execute: Empty query" q

232 PQ.EmptyQuery -> throwIO $ QueryError "execute: Empty query" q

413 PQ.CommandOk -> do

233 PQ.CommandOk -> do

414 ncols <- PQ.nfields result

234 ncols <- PQ.nfields result

@@ -419,7 +239,7 @@ finishExecute _conn q result = do

419 nstr <- PQ.cmdTuples result

239 nstr <- PQ.cmdTuples result

420 return $ case nstr of

240 return $ case nstr of

421 Nothing -> 0 -- is this appropriate?

241 Nothing -> 0 -- is this appropriate?

422− Just str -> mkInteger str

242+ Just str -> toInteger str

423 PQ.TuplesOk -> do

243 PQ.TuplesOk -> do

424 ncols <- PQ.nfields result

244 ncols <- PQ.nfields result

425 throwIO $ QueryError ("execute resulted in " ++ show ncols ++

245 throwIO $ QueryError ("execute resulted in " ++ show ncols ++

@@ -432,7 +252,7 @@ finishExecute _conn q result = do

432 PQ.NonfatalError -> throwResultError "execute" result status

252 PQ.NonfatalError -> throwResultError "execute" result status

433 PQ.FatalError -> throwResultError "execute" result status

253 PQ.FatalError -> throwResultError "execute" result status

434 where

254 where

435− mkInteger str = B8.foldl' delta 0 str

255+ toInteger str = B8.foldl' delta 0 str

436 where

256 where

437 delta acc c =

257 delta acc c =

438 if '0' <= c && c <= '9'

258 if '0' <= c && c <= '9'

@@ -440,22 +260,21 @@ finishExecute _conn q result = do

440 else error ("finishExecute: not an int: " ++ B8.unpack str)

260 else error ("finishExecute: not an int: " ++ B8.unpack str)

441

261

442throwResultError :: ByteString -> PQ.Result -> PQ.ExecStatus -> IO a

262throwResultError :: ByteString -> PQ.Result -> PQ.ExecStatus -> IO a

443−throwResultError _ result status = do

263+throwResultError context result status = do

444− errormsg <- fromMaybe "" <$>

264+ errormsg <- maybe "" id <$> PQ.resultErrorMessage result

445− PQ.resultErrorField result PQ.DiagMessagePrimary

265+ statusmsg <- PQ.resStatus status

446− detail <- fromMaybe "" <$>

447− PQ.resultErrorField result PQ.DiagMessageDetail

448− hint <- fromMaybe "" <$>

449− PQ.resultErrorField result PQ.DiagMessageHint

450− state' <- maybe "" id <$> PQ.resultErrorField result PQ.DiagSqlstate

266+ state <- maybe "" id <$> PQ.resultErrorField result PQ.DiagSqlstate

451− throwIO $ SqlError { sqlState = state'

267+ throwIO $ SqlError { sqlState = state

452− , sqlExecStatus = status

268+ , sqlNativeError = fromEnum status

453− , sqlErrorMsg = errormsg

269+ , sqlErrorMsg = B.concat [ context, ": ", statusmsg

454− , sqlErrorDetail = detail

270+ , ": ", errormsg ]}

455− , sqlErrorHint = hint }

456

271

457disconnectedError :: SqlError

272disconnectedError :: SqlError

273+disconnectedError = SqlError {

274+ sqlNativeError = -1,

458−disconnectedError = fatalError "connection disconnected"

275+ sqlErrorMsg = "connection disconnected",

276+ sqlState = ""

277+ }

459

278

460-- | Atomically perform an action with the database handle, if there is one.

279-- | Atomically perform an action with the database handle, if there is one.

461withConnection :: Connection -> (PQ.Connection -> IO a) -> IO a

280withConnection :: Connection -> (PQ.Connection -> IO a) -> IO a

@@ -478,160 +297,19 @@ newNullConnection :: IO Connection

478newNullConnection = do

297newNullConnection = do

479 connectionHandle <- newMVar =<< PQ.newNullConnection

298 connectionHandle <- newMVar =<< PQ.newNullConnection

480 connectionObjects <- newMVar IntMap.empty

299 connectionObjects <- newMVar IntMap.empty

481− connectionTempNameCounter <- newIORef 0

482 return Connection{..}

300 return Connection{..}

483

301

484data Row = Row {

302data Row = Row {

485 row :: {-# UNPACK #-} !PQ.Row

303 row :: {-# UNPACK #-} !PQ.Row

304+ , typenames :: !(V.Vector ByteString)

486 , rowresult :: !PQ.Result

305 , rowresult :: !PQ.Result

487 }

306 }

488

307

489−newtype RowParser a = RP { unRP :: ReaderT Row (StateT PQ.Column Conversion) a }

308+newtype RowParser a = RP { unRP :: ReaderT Row (StateT PQ.Column Ok) a }

490 deriving ( Functor, Applicative, Alternative, Monad )

309 deriving ( Functor, Applicative, Alternative, Monad )

491

310

492−liftRowParser :: IO a -> RowParser a

311+getvalue :: PQ.Result -> PQ.Row -> PQ.Column -> Maybe ByteString

493−liftRowParser = RP . lift . lift . liftConversion

312+getvalue result row col = unsafePerformIO (PQ.getvalue result row col)

494−

313+

495−newtype Conversion a = Conversion { runConversion :: Connection -> IO (Ok a) }

314+nfields :: PQ.Result -> PQ.Column

496−

315+nfields result = unsafePerformIO (PQ.nfields result)

497−liftConversion :: IO a -> Conversion a

498−liftConversion m = Conversion (\_ -> Ok <$> m)

499−

500−instance Functor Conversion where

501− fmap f m = Conversion $ \conn -> (fmap . fmap) f (runConversion m conn)

502−

503−instance Applicative Conversion where

504− pure a = Conversion $ \_conn -> pure (pure a)

505− mf <*> ma = Conversion $ \conn -> do

506− okf <- runConversion mf conn

507− case okf of

508− Ok f -> (fmap . fmap) f (runConversion ma conn)

509− Errors errs -> return (Errors errs)

510−

511−instance Alternative Conversion where

512− empty = Conversion $ \_conn -> pure empty

513− ma <|> mb = Conversion $ \conn -> do

514− oka <- runConversion ma conn

515− case oka of

516− Ok _ -> return oka

517− Errors _ -> (oka <|>) <$> runConversion mb conn

518−

519−instance Monad Conversion where

520− m >>= f = Conversion $ \conn -> do

521− oka <- runConversion m conn

522− case oka of

523− Ok a -> runConversion (f a) conn

524− Errors err -> return (Errors err)

525−

526−instance MonadPlus Conversion where

527− mzero = empty

528− mplus = (<|>)

529−

530−conversionMap :: (Ok a -> Ok b) -> Conversion a -> Conversion b

531−conversionMap f m = Conversion $ \conn -> f <$> runConversion m conn

532−

533−conversionError :: Exception err => err -> Conversion a

534−conversionError err = Conversion $ \_ -> return (Errors [toException err])

535−

536−newTempName :: Connection -> IO Query

537−newTempName Connection{..} = do

538− !n <- atomicModifyIORef connectionTempNameCounter

539− (\n -> let !n' = n+1 in (n', n'))

540− return $! Query $ B8.pack $ "temp" ++ show n

541−

542−-- FIXME? What error should getNotification and getCopyData throw?

543−fdError :: ByteString -> IOError

544−fdError funcName = IOError {

545− ioe_handle = Nothing,

546− ioe_type = ResourceVanished,

547− ioe_location = B8.unpack funcName,

548− ioe_description = "failed to fetch file descriptor",

549− ioe_errno = Nothing,

550− ioe_filename = Nothing

551− }

552−

553−

554−libPQError :: ByteString -> IOError

555−libPQError desc = IOError {

556− ioe_handle = Nothing,

557− ioe_type = OtherError,

558− ioe_location = "libpq",

559− ioe_description = B8.unpack desc,

560− ioe_errno = Nothing,

561− ioe_filename = Nothing

562− }

563−

564−throwLibPQError :: PQ.Connection -> ByteString -> IO a

565−throwLibPQError conn default_desc = do

566− msg <- maybe default_desc id <$> PQ.errorMessage conn

567− throwIO $! libPQError msg

568−

569−

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

571−fmtError msg q xs = throw FormatError {

572− fmtMessage = msg

573− , fmtQuery = q

574− , fmtParams = map twiddle xs

575− }

576− where twiddle (Plain b) = toByteString b

577− twiddle (Escape s) = s

578− twiddle (EscapeByteA s) = s

579− twiddle (EscapeIdentifier s) = s

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

581−

582−fmtErrorBs :: Query -> [Action] -> ByteString -> a

583−fmtErrorBs q xs msg = fmtError (T.unpack $ TE.decodeUtf8 msg) q xs

584−

585−-- | Quote bytestring or throw 'FormatError'

586−quote :: Query -> [Action] -> Either ByteString ByteString -> Builder

587−quote q xs = either (fmtErrorBs q xs) (inQuotes . byteString)

588−

589−buildAction :: Connection -- ^ Connection for string escaping

590− -> Query -- ^ Query for message error

591− -> [Action] -- ^ List of parameters for message error

592− -> Action -- ^ Action to build

593− -> IO Builder

594−buildAction _ _ _ (Plain b) = pure b

595−buildAction conn q xs (Escape s) = quote q xs <$> escapeStringConn conn s

596−buildAction conn q xs (EscapeByteA s) = quote q xs <$> escapeByteaConn conn s

597−buildAction conn q xs (EscapeIdentifier s) =

598− either (fmtErrorBs q xs) byteString <$> escapeIdentifier conn s

599−buildAction conn q xs (Many ys) =

600− mconcat <$> mapM (buildAction conn q xs) ys

601−

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

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

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

605−

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

607− -> Connection

608− -> ByteString

609− -> IO (Either ByteString ByteString)

610−escapeWrap f conn s =

611− withConnection conn $ \c ->

612− f c s >>= checkError c

613−

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

615−escapeStringConn = escapeWrap PQ.escapeStringConn

616−

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

618−escapeIdentifier = escapeWrap PQ.escapeIdentifier

619−

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

621−escapeByteaConn = escapeWrap PQ.escapeByteaConn

622−

623−breakOnSingleQuestionMark :: ByteString -> (ByteString, ByteString)

624−breakOnSingleQuestionMark b = go (B8.empty, b)

625− where go (x,bs) = (x `B8.append` x',bs')

626− -- seperate from first QM

627− where tup@(noQ, restWithQ) = B8.break (=='?') bs

628− -- if end of query, just return

629− -- else check for second QM in 'go2'

630− (x', bs') = maybe tup go2 $

631− -- drop found QM and peek at next char

632− B8.uncons restWithQ >>= B8.uncons . snd

633− -- another QM after the first means:

634− -- take literal QM and keep going.

635− go2 ('?', t2) = go (noQ `B8.snoc` '?',t2)

636− -- Anything else means

637− go2 _ = tup

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+6−7

@@ -7,16 +7,13 @@

7-- Maintainer : leon@melding-monads.com

8--

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

11-- information.

12--

13-- Note that Large Object File Descriptors are only valid within a single

14-- database transaction, so if you are interested in using anything beyond

15−-- 'loCreat', 'loCreate', and 'loUnlink', you will need to run the entire

15+-- 'loCreat', 'loImport', 'loExport', and 'loUnlink', you will need to run

16−-- sequence of functions in a transaction. As 'loImport' and 'loExport'

16+-- the entire sequence of functions in a transaction.

17−-- are simply C functions that call 'loCreat', 'loOpen', 'loRead', and

18−-- 'loWrite', and do not perform any transaction handling themselves,

19−-- they also need to be wrapped in an explicit transaction.

20--

17--

21-----------------------------------------------------------------------------

18-----------------------------------------------------------------------------

@@ -54,7 +51,9 @@ liftPQ str conn m = withConnection conn $ \c -> do

54 case res of

51 case res of

55 Nothing -> do

52 Nothing -> do

56 msg <- maybe str id <$> PQ.errorMessage c

53 msg <- maybe str id <$> PQ.errorMessage c

57− throwIO $ fatalError msg

54+ throwIO $ SqlError { sqlNativeError = -1 -- FIXME?

55+ , sqlErrorMsg = msg

56+ , sqlState = "" }

58 Just x -> return x

57 Just x -> return x

60loCreat :: Connection -> IO Oid

59loCreat :: Connection -> IO Oid

src/Database/PostgreSQL/Simple/Newtypes.hsdeleted−49

@@ -1,49 +0,0 @@

1−{-# LANGUAGE DeriveFunctor #-}

2−{-# LANGUAGE DeriveDataTypeable #-}

3−-- | Module with newtypes suitable to usage with @DerivingVia@ or standalone.

4−--

5−-- The newtypes are named after packages they wrap.

6−module Database.PostgreSQL.Simple.Newtypes (

7− Aeson (..), getAeson,

8−) where

9−

10−import Data.Typeable (Typeable)

11−import Database.PostgreSQL.Simple.ToField (ToField (..))

12−import Database.PostgreSQL.Simple.FromField (FromField (..), fromJSONField)

13−

14−import qualified Data.Aeson as Aeson

15−

16−-------------------------------------------------------------------------------

17−-- aeson

18−-------------------------------------------------------------------------------

19−

20−-- | A newtype wrapper with 'ToField' and 'FromField' instances

21−-- based on 'Aeson.ToJSON' and 'Aeson.FromJSON' type classes from @aeson@.

22−--

23−-- Example using @DerivingVia@:

24−--

25−-- @

26−-- data Foo = Foo Int String

27−-- deriving stock (Eq, Show, Generic) -- GHC built int

28−-- deriving anyclass ('Aeson.FromJSON', 'Aeson.ToJSON') -- Derived using GHC Generics

29−-- deriving ('ToField', 'FromField') via 'Aeson' Foo -- DerivingVia

30−-- @

31−--

32−-- Example using 'Aeson' newtype directly, for more ad-hoc queries

33−--

34−-- @

35−-- execute conn "INSERT INTO tbl (fld) VALUES (?)" (Only ('Aeson' x))

36−-- @

37−--

38−-- @since 0.6.3

39−newtype Aeson a = Aeson a

40− deriving (Eq, Show, Read, Typeable, Functor)

41−

42−getAeson :: Aeson a -> a

43−getAeson (Aeson a) = a

44−

45−instance Aeson.ToJSON a => ToField (Aeson a) where

46− toField = toField . Aeson.encode . getAeson

47−

48−instance (Aeson.FromJSON a, Typeable a) => FromField (Aeson a) where

49− fromField f bs = fmap Aeson (fromJSONField f bs)

src/Database/PostgreSQL/Simple/Notification.hs+29−90

@@ -1,12 +1,9 @@

1−{-# LANGUAGE CPP #-}

2−{-# LANGUAGE NamedFieldPuns #-}

3−{-# LANGUAGE RecordWildCards #-}

1+{-# LANGUAGE RecordWildCards, NamedFieldPuns #-}

5-----------------------------------------------------------------------------

3-----------------------------------------------------------------------------

6-- |

4-- |

7-- Module : Database.PostgreSQL.Simple.Notification

5-- Module : Database.PostgreSQL.Simple.Notification

10-- License : BSD3

7-- License : BSD3

11--

8--

12-- Maintainer : leon@melding-monads.com

9-- Maintainer : leon@melding-monads.com

@@ -14,49 +11,33 @@

14--

11--

15-- Support for receiving asynchronous notifications via PostgreSQL's

12-- Support for receiving asynchronous notifications via PostgreSQL's

16-- Listen/Notify mechanism. See

13-- Listen/Notify mechanism. See

17−-- <https://www.postgresql.org/docs/9.5/static/sql-notify.html> for more

14+-- <http://www.postgresql.org/docs/9.1/static/sql-notify.html> for more

18-- information.

15-- information.

19--

16--

20−-- Note that on Windows, @getNotification@ currently uses a polling loop

21−-- of 1 second to check for more notifications, due to some inadequacies

22−-- in GHC's IO implementation and interface on that platform. See GHC

23−-- issue #7353 for more information. While this workaround is less than

24−-- ideal, notifications are still better than polling the database directly.

25−-- Notifications do not create any extra work for the backend, and are

26−-- likely cheaper on the client side as well.

27−--

28−-- <https://hackage.haskell.org/trac/ghc/ticket/7353>

29−--

30-----------------------------------------------------------------------------

17-----------------------------------------------------------------------------

32module Database.PostgreSQL.Simple.Notification

19module Database.PostgreSQL.Simple.Notification

33 ( Notification(..)

20 ( Notification(..)

34 , getNotification

21 , getNotification

35 , getNotificationNonBlocking

22 , getNotificationNonBlocking

36− , getBackendPID

37 ) where

23 ) where

39−import Control.Monad ( join, void )

25+import Control.Concurrent ( threadWaitRead )

40−import Control.Exception ( throwIO, catch )

26+import Control.Monad ( when )

41import qualified Data.ByteString as B

27import qualified Data.ByteString as B

42−import qualified Data.ByteString.Char8 as B8

43import Database.PostgreSQL.Simple.Internal

28import Database.PostgreSQL.Simple.Internal

44import qualified Database.PostgreSQL.LibPQ as PQ

29import qualified Database.PostgreSQL.LibPQ as PQ

45import System.Posix.Types ( CPid )

30import 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

55data Notification = Notification

32data Notification = Notification

56− { notificationPid :: {-# UNPACK #-} !CPid

33+ { notificationPid :: !CPid

57− , notificationChannel :: {-# UNPACK #-} !B.ByteString

34+ , notificationChannel :: !B.ByteString

58− , notificationData :: {-# UNPACK #-} !B.ByteString

35+ , notificationData :: !B.ByteString

59− } deriving (Show, Eq)

36+ }

37+

38+errfd :: String

39+errfd = "Database.PostgreSQL.Simple.Notification.getNotification: \

40+ \failed to fetch file descriptor"

61convertNotice :: PQ.Notify -> Notification

42convertNotice :: PQ.Notify -> Notification

62convertNotice PQ.Notify{..}

43convertNotice PQ.Notify{..}

@@ -66,56 +47,25 @@ convertNotice PQ.Notify{..}

67-- | Returns a single notification. If no notifications are available,

48-- | Returns a single notification. If no notifications are available,

68-- 'getNotification' blocks until one arrives.

49-- '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.

74getNotification :: Connection -> IO Notification

51getNotification :: Connection -> IO Notification

75−getNotification conn = join $ withConnection conn fetch

52+getNotification = loop False

76 where

53 where

77− funcName = "Database.PostgreSQL.Simple.Notification.getNotification"

54+ loop doConsume conn = do

78−

55+ res <- withConnection conn $ \c -> do

79− fetch c = do

56+ when doConsume (PQ.consumeInput c >> return ())

80− mmsg <- PQ.notifies c

57+ mmsg <- PQ.notifies c

81− case mmsg of

58+ case mmsg of

82− Just msg -> return (return $! convertNotice msg)

83− Nothing -> do

59+ Nothing -> do

84− mfd <- PQ.socket c

60+ mfd <- PQ.socket c

85− case mfd of

61+ case mfd of

86− Nothing -> return (throwIO $! fdError funcName)

62+ Nothing -> fail errfd

87−#if defined(mingw32_HOST_OS)

63+ Just fd -> return (Left fd)

88− -- threadWaitRead doesn't work for sockets on Windows, so just

64+ Just msg -> return (Right msg)

89− -- poll for input every second (PQconsumeInput is non-blocking).

65+ -- FIXME? what happens if the connection is closed/reset right here?

90− --

66+ case res of

91− -- We could call select(), but FFI calls can't be interrupted

67+ Left fd -> threadWaitRead fd >> loop True conn

92− -- with async exceptions, whereas threadDelay can.

68+ Right msg -> return $! convertNotice msg

93− Just _fd -> do

94− return (threadDelay 1000000 >> loop)

95−#else

96− -- This case fixes the race condition above. By registering

97− -- our interest in the descriptor before we drop the lock,

98− -- there is no opportunity for the descriptor index to be

99− -- reallocated on us.

100− --

101− -- (That is, assuming there isn't concurrently executing

102− -- code that manipulates the descriptor without holding

103− -- the lock... but such a major bug is likely to exhibit

104− -- itself in an at least somewhat more dramatic fashion.)

105− Just fd -> do

106− (waitRead, _) <- threadWaitReadSTM fd

107− return $ do

108− atomically waitRead `catch` (throwIO . setIOErrorLocation)

109− loop

110−#endif

111−

112− loop = join $ withConnection conn $ \c -> do

113− void $ PQ.consumeInput c

114− fetch c

115−

116− setIOErrorLocation :: IOError -> IOError

117− setIOErrorLocation err = err { ioe_location = B8.unpack funcName }

118−

119

120-- | Non-blocking variant of 'getNotification'. Returns a single notification,

70-- | Non-blocking variant of 'getNotification'. Returns a single notification,

121-- if available. If no notifications are available, returns 'Nothing'.

71-- if available. If no notifications are available, returns 'Nothing'.

@@ -132,14 +82,3 @@ getNotificationNonBlocking conn =

132 case mmsg' of

82 case mmsg' of

133 Just msg -> return $! Just $! convertNotice msg

83 Just msg -> return $! Just $! convertNotice msg

134 Nothing -> return Nothing

84 Nothing -> return Nothing

135−

136−-- | Returns the process 'CPid' of the backend server process

137−-- handling this connection.

138−--

139−-- The backend PID is useful for debugging purposes and for comparison

140−-- to NOTIFY messages (which include the PID of the notifying backend

141−-- process). Note that the PID belongs to a process executing on the

142−-- database server host, not the local host!

143−

144−getBackendPID :: Connection -> IO CPid

145−getBackendPID conn = withConnection conn PQ.backendPID

src/Database/PostgreSQL/Simple/Ok.hs+4−10

@@ -1,11 +1,10 @@

1{-# LANGUAGE DeriveDataTypeable #-}

2{-# LANGUAGE DeriveFunctor #-}

3−{-# LANGUAGE CPP #-}

5------------------------------------------------------------------------------

4------------------------------------------------------------------------------

6-- |

5-- |

7-- Module : Database.PostgreSQL.Simple.Ok

6-- Module : Database.PostgreSQL.Simple.Ok

9-- License : BSD3

8-- License : BSD3

10--

9--

11-- Maintainer : leon@melding-monads.com

10-- Maintainer : leon@melding-monads.com

@@ -21,7 +20,7 @@

21-- commonly-used type and typeclass included in @base@.

20-- commonly-used type and typeclass included in @base@.

22--

21--

23-- Extending the failure case to a list of 'SomeException's enables a

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

25-- the list of exceptions when both cases fail, and 'empty' is defined as

24-- the list of exceptions when both cases fail, and 'empty' is defined as

26-- 'Errors []'. Though '<|>' one could pick one of two exceptions, and

25-- 'Errors []'. Though '<|>' one could pick one of two exceptions, and

27-- throw away the other, and have 'empty' provide a generic exception,

26-- throw away the other, and have 'empty' provide a generic exception,

@@ -37,8 +36,6 @@ import Control.Exception

37import Control.Monad(MonadPlus(..))

36import Control.Monad(MonadPlus(..))

38import Data.Typeable

37import Data.Typeable

40−import qualified Control.Monad.Fail as Fail

41−

42-- FIXME: [SomeException] should probably be something else, maybe

39-- FIXME: [SomeException] should probably be something else, maybe

43-- a difference list (or a tree?)

40-- a difference list (or a tree?)

@@ -72,14 +69,11 @@ instance MonadPlus Ok where

72 mplus = (<|>)

69 mplus = (<|>)

74instance Monad Ok where

71instance Monad Ok where

72+ return = Ok

73+

75 Errors es >>= _ = Errors es

74 Errors es >>= _ = Errors es

76 Ok a >>= f = f a

75 Ok a >>= f = f a

78−#if !(MIN_VERSION_base(4,13,0))

79− fail = Fail.fail

80−#endif

81−

82−instance Fail.MonadFail Ok where

83 fail str = Errors [SomeException (ErrorCall str)]

77 fail str = Errors [SomeException (ErrorCall str)]

85-- | a way to reify a list of exceptions into a single exception

79-- | 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+22−36

@@ -1,9 +1,3 @@

1−{-# LANGUAGE CPP #-}

2−#if __GLASGOW_HASKELL__ >= 800

3−{-# LANGUAGE TemplateHaskellQuotes #-}

4−#else

5−{-# LANGUAGE TemplateHaskell #-}

6−#endif

7------------------------------------------------------------------------------

1------------------------------------------------------------------------------

8-- |

2-- |

9-- Module: Database.PostgreSQL.Simple.SqlQQ

3-- Module: Database.PostgreSQL.Simple.SqlQQ

@@ -15,11 +9,10 @@

15------------------------------------------------------------------------------

9------------------------------------------------------------------------------

17module Database.PostgreSQL.Simple.SqlQQ (sql) where

11module Database.PostgreSQL.Simple.SqlQQ (sql) where

18−import Database.PostgreSQL.Simple.Types (Query)

12+

19import Language.Haskell.TH

13import Language.Haskell.TH

20import Language.Haskell.TH.Quote

14import Language.Haskell.TH.Quote

21import Data.Char

15import Data.Char

22−import Data.String

24-- | 'sql' is a quasiquoter that eases the syntactic burden

17-- | 'sql' is a quasiquoter that eases the syntactic burden

25-- of writing big sql statements in Haskell source code. For example:

18-- of writing big sql statements in Haskell source code. For example:

@@ -34,18 +27,16 @@ import Data.String

34-- > LIMIT 100 |]

27-- > LIMIT 100 |]

35-- > (beginTime,endTime,string)

28-- > (beginTime,endTime,string)

36--

29--

37−-- This quasiquoter returns a literal string expression of type 'Query',

38−-- and attempts to minimize whitespace; otherwise the above query would

30+-- This quasiquoter attempts to mimimize whitespace; otherwise the

39−-- consist of approximately half whitespace when sent to the database

31+-- above query would consist of approximately half whitespace when sent

40−-- backend. It also recognizes and strips out standard sql comments "--".

32+-- to the database backend.

41--

33--

42-- The implementation of the whitespace reducer is currently incomplete.

34-- The implementation of the whitespace reducer is currently incomplete.

43-- Thus it can mess up your syntax in cases where whitespace should be

35-- Thus it can mess up your syntax in cases where whitespace should be

44-- preserved as-is. It does preserve whitespace inside standard SQL string

36-- preserved as-is. It does preserve whitespace inside standard SQL string

45-- literals. But it can get confused by the non-standard PostgreSQL string

37-- literals. But it can get confused by the non-standard PostgreSQL string

46-- literal syntax (which is the default setting in PostgreSQL 8 and below),

38-- literal syntax (which is the default setting in PostgreSQL 8 and below),

47−-- the extended escape string syntax, quoted identifiers, and other similar

39+-- the extended escape string syntax, and other similar constructs.

48−-- constructs.

49--

40--

50-- Of course, this caveat only applies to text written inside the SQL

41-- Of course, this caveat only applies to text written inside the SQL

51-- quasiquoter; whitespace reduction is a compile-time computation and

42-- quasiquoter; whitespace reduction is a compile-time computation and

@@ -57,34 +48,29 @@ import Data.String

58sql :: QuasiQuoter

49sql :: QuasiQuoter

59sql = QuasiQuoter

50sql = QuasiQuoter

60− { quotePat = error "Database.PostgreSQL.Simple.SqlQQ.sql: quasiquoter used in pattern context"

51+ { quotePat = error "Database.PostgreSQL.Simple.SqlQQ.sql:\

52+ \ quasiquoter used in pattern context"

61− , quoteType = error "Database.PostgreSQL.Simple.SqlQQ.sql: quasiquoter used in type context"

53+ , quoteType = error "Database.PostgreSQL.Simple.SqlQQ.sql:\

54+ \ quasiquoter used in type context"

62 , quoteExp = sqlExp

55 , quoteExp = sqlExp

63− , quoteDec = error "Database.PostgreSQL.Simple.SqlQQ.sql: quasiquoter used in declaration context"

56+ , quoteDec = error "Database.PostgreSQL.Simple.SqlQQ.sql:\

57+ \ quasiquoter used in declaration context"

64 }

58 }

66sqlExp :: String -> Q Exp

60sqlExp :: String -> Q Exp

67−sqlExp = appE [| fromString :: String -> Query |] . stringE . minimizeSpace

61+sqlExp = stringE . outstring . dropSpace

68−

69−minimizeSpace :: String -> String

70−minimizeSpace = drop 1 . reduceSpace

71 where

62 where

72− needsReduced [] = False

73− needsReduced ('-':'-':_) = True

74− needsReduced (x:_) = isSpace x

75−

76− reduceSpace xs =

77− case dropWhile isSpace xs of

63+ dropSpace = dropWhile isSpace

78− [] -> []

79− ('-':'-':ys) -> reduceSpace (dropWhile (/= '\n') ys)

80− ys -> ' ' : insql ys

82− insql ('\'':xs) = '\'' : instring xs

65+ outstring ('\'':xs) = '\'' : instring xs

83− insql xs | needsReduced xs = reduceSpace xs

66+ outstring (x:xs) | isSpace x = case dropSpace xs of

84− insql (x:xs) = x : insql xs

67+ [] -> []

85− insql [] = []

68+ ys -> ' ' : outstring ys

69+ | otherwise = x : outstring xs

70+ outstring [] = []

87 instring ('\'':'\'':xs) = '\'':'\'': instring xs

72 instring ('\'':'\'':xs) = '\'':'\'': instring xs

88− instring ('\'':xs) = '\'': insql xs

73+ instring ('\'':xs) = '\'': outstring xs

89 instring (x:xs) = x : instring xs

74 instring (x:xs) = x : instring xs

90− instring [] = error "Database.PostgreSQL.Simple.SqlQQ.sql: string literal not terminated"

75+ instring [] = error "Database.PostgreSQL.Simple.SqlQQ.sql:\

76+ \ string literal not terminated"

src/Database/PostgreSQL/Simple/Time.hs+50−216

@@ -1,216 +1,53 @@

1−{- |

1+------------------------------------------------------------------------------

2+-- |

2−Module: Database.PostgreSQL.Simple.Time

3+-- Module: Database.PostgreSQL.Simple.Time

4−License: BSD3

5+-- License: BSD3

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

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

6−Stability: experimental

7+-- Stability: experimental

7−

8+--

8−This module provides time types that supports positive and negative

9+-- Time types that supports positive and negative infinity. Also includes

9−infinity, as well as some functions for converting to and from strings.

10+-- new time parsers and printers with better performance than GHC's time

10−

11+-- package.

11−Also, this module also contains commentary regarding postgresql's timestamp

12+--

12−types, civil timekeeping in general, and how it relates to

13+-- The parsers only understand the specific variant of ISO 8601 that

13−postgresql-simple. You can read more about PostgreSQL's date and time types

14+-- PostgreSQL emits, and the printers attempt to duplicate this syntax.

14−at <https://www.postgresql.org/docs/9.5/static/datatype-datetime.html>,

15+-- Thus the @datestyle@ parameter for the connection must be set to @ISO@.

15−and the IANA time zone database at <https://en.wikipedia.org/wiki/Tz_database>.

16+--

16−

17+-- These parsers and printers likely have problems and shortcomings. Some

17−Stack Overflow also has some excellent commentary on time, if it is a

18+-- that I know of:

18−wiki page or a highly upvoted question and answer. If the answer regarding

19+--

19−time has not received about a hundred upvotes at least, then the answer is

20+-- 1 @TimestampTZ@s before a timezone-dependent point in time cannot be

20−almost invariably completely and painfully wrong, even if it's the chosen

21+-- parsed, because the parsers can only handle timezone offsets of a

21−answer or the most highly upvoted answer to a question.

22+-- integer number of minutes. However, PostgreSQL will include seconds

22−

23+-- in the offset, depending on the historical time standards for the city

23−PostgreSQL's @timestamp with time zone@ (hereafter, @timestamptz@) can be

24+-- identifying the time zone.

24−converted to Haskell's 'Data.Time.UTCTime' and 'Data.Time.ZonedTime' types,

25+--

25−because values of these types represent a self-contained, unambiguous point

26+-- This boundary point often marks an event of some interest. In the US

26−in time. PostgreSQL's @timestamp without time zone@ (hereafter, @timestamp@)

27+-- for example, @timestamptz@s before @1883-Nov-18 12:00:00@ local time

27−can be converted to Haskell's 'Data.Time.LocalTime', because values of these

28+-- cannot be parsed. This is the moment Standard Railway Time went live.

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

29+-- Concretely, PostgreSQL will emit @1883-11-18 12:03:57-04:56:02@

178− 1883-11-18 12:00:00-05

30+-- instead of @1883-11-18 11:59:59-05@ when the @timezone@ parameter

179−(2 rows)

31+-- for the connection is set to @America/New_York@.

180−@

32+--

181−

33+-- 2. Dates and times surrounding @1582-Feb-24@, the date the Gregorian

182−Both of these timestamps can be parsed as a 'Data.Time.UTCTime' type,

34+-- Calendar was introduced, should be investigated for conversion errors.

183−however 'Data.Time.ZonedTime' will fail on the former timestamp.

35+--

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

36+-- 3. Points in time Before Christ are not also not supported. For example,

195−will emit \"@0045-01-01 BC@\" for the first proleptic Gregorian day of

37+-- PostgreSQL will emit @0045-01-01 BC@ for a value of a @date@ type.

196−the year the Roman Empire adopted the Julian Calendar, but

38+-- This is the year that the Julian Calendar was adopted.

197−postgresql-simple does not (yet?) have the ability to either parse or

39+--

198−generate this syntax. Unfortunately this syntax isn't convenient to

40+-- However, it should be noted that the old parsers also had issues 1 and 3.

199−print or especially parse.

41+-- Also, the new parsers now correctly handle time zones that include minutes

200−

42+-- in their offset. Most notably, this includes all of India and parts of

201−Also, postgresql itself cannot parse or print dates before @4714-11-24 BC@,

43+-- Canada and Australia.

202−which is the Julian date on the proleptic Gregorian Calendar. Although

44+--

203−postgresql's timestamp types are perfectly capable of representing timestamps

45+-- PostgreSQL uses the zoneinfo database for its time zone information.

204−nearly 300,000 years in the past, using this would require postgresql-simple

46+-- You can read more about PostgreSQL's date and time types at

205−and other client programs to support binary parameters and results.

47+-- <http://www.postgresql.org/docs/9.1/static/datatype-datetime.html>,

206−

48+-- and zoneinfo at <http://en.wikipedia.org/wiki/Tz_database>.

207−Dealing with years BCE is also complicated slightly by the fact that

49+--

208−Haskell's time library has a year \"0000\", which is a convention often

50+------------------------------------------------------------------------------

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−-}

214

215module Database.PostgreSQL.Simple.Time

52module Database.PostgreSQL.Simple.Time

216 ( Unbounded(..)

53 ( Unbounded(..)

@@ -227,7 +64,6 @@ module Database.PostgreSQL.Simple.Time

227 , parseUTCTimestamp

64 , parseUTCTimestamp

228 , parseZonedTimestamp

65 , parseZonedTimestamp

229 , parseLocalTimestamp

66 , parseLocalTimestamp

230− , parseCalendarDiffTime

231 , dayToBuilder

67 , dayToBuilder

232 , utcTimeToBuilder

68 , utcTimeToBuilder

233 , zonedTimeToBuilder

69 , zonedTimeToBuilder

@@ -239,8 +75,6 @@ module Database.PostgreSQL.Simple.Time

239 , zonedTimestampToBuilder

75 , zonedTimestampToBuilder

240 , localTimestampToBuilder

76 , localTimestampToBuilder

241 , unboundedToBuilder

77 , unboundedToBuilder

242− , nominalDiffTimeToBuilder

243− , calendarDiffTimeToBuilder

244 ) where

78 ) where

245

246import Database.PostgreSQL.Simple.Time.Implementation

80import Database.PostgreSQL.Simple.Time.Implementation

src/Database/PostgreSQL/Simple/Time/Implementation.hs+157−51

@@ -1,44 +1,51 @@

1------------------------------------------------------------------------------

2-- |

3-- Module: Database.PostgreSQL.Simple.Time.Implementation

5-- License: BSD3

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

7-- Stability: experimental

8--

9------------------------------------------------------------------------------

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

11+{-# LANGUAGE DeriveDataTypeable #-}

13module Database.PostgreSQL.Simple.Time.Implementation where

15−import Prelude hiding (take)

15+import Prelude hiding (take, (++))

16−import Data.ByteString.Builder(Builder, byteString)

16+import Blaze.ByteString.Builder(Builder, fromByteString)

17−import Data.ByteString.Builder.Prim(primBounded)

17+import Blaze.ByteString.Builder.Char8(fromChar)

18+import Blaze.Text.Int(integral)

18import Control.Arrow((***))

19import Control.Arrow((***))

19import Control.Applicative

20import Control.Applicative

21+import Control.Monad(when)

22+import Data.Bits((.&.))

20import qualified Data.ByteString as B

23import qualified Data.ByteString as B

21−import Data.Time.Compat (LocalTime, UTCTime, ZonedTime, Day, TimeOfDay, TimeZone, NominalDiffTime, utc)

24+import Data.ByteString.Internal (c2w, w2c)

22−import Data.Time.LocalTime.Compat (CalendarDiffTime)

25+import Data.Time hiding (getTimeZone, getZonedTime)

23import Data.Typeable

26import Data.Typeable

24−import Data.Maybe (fromMaybe)

27+import Data.Word(Word8)

25−import qualified Data.Attoparsec.ByteString.Char8 as A

28+import qualified Data.Attoparsec.Char8 as A

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

29+import Data.Monoid(Monoid(..))

27−import qualified Database.PostgreSQL.Simple.Time.Internal.Parser as TP

30+import Data.Fixed (Pico)

28−import qualified Database.PostgreSQL.Simple.Time.Internal.Printer as TPP

31+import Unsafe.Coerce

32+

33+(++) :: Monoid a => a -> a -> a

34+(++) = mappend

35+infixr 5 ++

30data Unbounded a

37data Unbounded a

31 = NegInfinity

38 = NegInfinity

32 | Finite !a

39 | Finite !a

33 | PosInfinity

40 | PosInfinity

34− deriving (Eq, Ord, Typeable, Functor)

41+ deriving (Eq, Ord, Typeable)

36instance Show a => Show (Unbounded a) where

43instance Show a => Show (Unbounded a) where

37 showsPrec prec x rest

44 showsPrec prec x rest

38 = case x of

45 = case x of

39− NegInfinity -> "-infinity" <> rest

46+ NegInfinity -> "-infinity" ++ rest

40 Finite time -> showsPrec prec time rest

47 Finite time -> showsPrec prec time rest

41− PosInfinity -> "infinity" <> rest

48+ PosInfinity -> "infinity" ++ rest

43instance Read a => Read (Unbounded a) where

50instance Read a => Read (Unbounded a) where

44 readsPrec prec = readParen False $ \str -> case str of

51 readsPrec prec = readParen False $ \str -> case str of

@@ -78,9 +85,6 @@ parseLocalTimestamp = A.parseOnly (getLocalTimestamp <* A.endOfInput)

78parseDate :: B.ByteString -> Either String Date

85parseDate :: B.ByteString -> Either String Date

79parseDate = A.parseOnly (getDate <* A.endOfInput)

86parseDate = A.parseOnly (getDate <* A.endOfInput)

81−parseCalendarDiffTime :: B.ByteString -> Either String CalendarDiffTime

82−parseCalendarDiffTime = A.parseOnly (getCalendarDiffTime <* A.endOfInput)

83−

84getUnbounded :: A.Parser a -> A.Parser (Unbounded a)

88getUnbounded :: A.Parser a -> A.Parser (Unbounded a)

85getUnbounded getFinite

89getUnbounded getFinite

86 = (pure NegInfinity <* A.string "-infinity")

90 = (pure NegInfinity <* A.string "-infinity")

@@ -88,74 +92,130 @@ getUnbounded getFinite

88 <|> (Finite <$> getFinite)

92 <|> (Finite <$> getFinite)

90getDay :: A.Parser Day

94getDay :: 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

108

93getDate :: A.Parser Date

109getDate :: A.Parser Date

94getDate = getUnbounded getDay

110getDate = getUnbounded getDay

111

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

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

114+{-# INLINE decimal #-}

115+

96getTimeOfDay :: A.Parser TimeOfDay

116getTimeOfDay :: 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

130

99getLocalTime :: A.Parser LocalTime

131getLocalTime :: A.Parser LocalTime

100−getLocalTime = TP.localTime

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

101

133

102getLocalTimestamp :: A.Parser LocalTimestamp

134getLocalTimestamp :: A.Parser LocalTimestamp

103getLocalTimestamp = getUnbounded getLocalTime

135getLocalTimestamp = getUnbounded getLocalTime

104

136

105getTimeZone :: A.Parser TimeZone

137getTimeZone :: A.Parser TimeZone

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

138+getTimeZone = do

107−

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

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

140+ hours <- digits "timezone"

109−

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

110−getTimeZoneHMS :: A.Parser TimeZoneHMS

142+ let !absset = 60 * hours + mins

111−getTimeZoneHMS = munge <$> TP.timeZoneHMS

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

112− where

144+ return $! minutesToTimeZone offset

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

119

145

120getZonedTime :: A.Parser ZonedTime

146getZonedTime :: A.Parser ZonedTime

121−getZonedTime = TP.zonedTime

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

122

148

123getZonedTimestamp :: A.Parser ZonedTimestamp

149getZonedTimestamp :: A.Parser ZonedTimestamp

124getZonedTimestamp = getUnbounded getZonedTime

150getZonedTimestamp = getUnbounded getZonedTime

125

151

126getUTCTime :: A.Parser UTCTime

152getUTCTime :: 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'')

128

162

129getUTCTimestamp :: A.Parser UTCTimestamp

163getUTCTimestamp :: A.Parser UTCTimestamp

130getUTCTimestamp = getUnbounded getUTCTime

164getUTCTimestamp = getUnbounded getUTCTime

131

165

132−getCalendarDiffTime :: A.Parser CalendarDiffTime

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

133−getCalendarDiffTime = TP.calendarDiffTime

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 #-}

134

182

135dayToBuilder :: Day -> Builder

183dayToBuilder :: Day -> Builder

136−dayToBuilder = primBounded TPP.day

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

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

137

186

138timeOfDayToBuilder :: TimeOfDay -> Builder

187timeOfDayToBuilder :: TimeOfDay -> Builder

139−timeOfDayToBuilder = primBounded TPP.timeOfDay

188+timeOfDayToBuilder (TimeOfDay h m s) = do

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

140

190

141timeZoneToBuilder :: TimeZone -> Builder

191timeZoneToBuilder :: 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 '-'

143

199

144utcTimeToBuilder :: UTCTime -> Builder

200utcTimeToBuilder :: UTCTime -> Builder

145−utcTimeToBuilder = primBounded TPP.utcTime

201+utcTimeToBuilder (UTCTime day time) =

202+ dayToBuilder day ++ fromChar ' '

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

146

204

147zonedTimeToBuilder :: ZonedTime -> Builder

205zonedTimeToBuilder :: ZonedTime -> Builder

148−zonedTimeToBuilder = primBounded TPP.zonedTime

206+zonedTimeToBuilder (ZonedTime localTime tz) =

207+ localTimeToBuilder localTime ++ timeZoneToBuilder tz

149

208

150localTimeToBuilder :: LocalTime -> Builder

209localTimeToBuilder :: LocalTime -> Builder

151−localTimeToBuilder = primBounded TPP.localTime

210+localTimeToBuilder (LocalTime day tod) =

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

152

212

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

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

154unboundedToBuilder finiteToBuilder unbounded

214unboundedToBuilder finiteToBuilder unbounded

155 = case unbounded of

215 = case unbounded of

156− NegInfinity -> byteString "-infinity"

216+ NegInfinity -> fromByteString "-infinity"

157 Finite a -> finiteToBuilder a

217 Finite a -> finiteToBuilder a

158− PosInfinity -> byteString "infinity"

218+ PosInfinity -> fromByteString "infinity"

159

219

160utcTimestampToBuilder :: UTCTimestamp -> Builder

220utcTimestampToBuilder :: UTCTimestamp -> Builder

161utcTimestampToBuilder = unboundedToBuilder utcTimeToBuilder

221utcTimestampToBuilder = unboundedToBuilder utcTimeToBuilder

@@ -169,8 +229,54 @@ localTimestampToBuilder = unboundedToBuilder localTimeToBuilder

169dateToBuilder :: Date -> Builder

229dateToBuilder :: Date -> Builder

170dateToBuilder = unboundedToBuilder dayToBuilder

230dateToBuilder = unboundedToBuilder dayToBuilder

171

231

172−nominalDiffTimeToBuilder :: NominalDiffTime -> Builder

232+showSeconds :: Pico -> Builder

173−nominalDiffTimeToBuilder = TPP.nominalDiffTime

233+showSeconds xyz

174−

234+ | yz == 0 = pad2 x

175−calendarDiffTimeToBuilder :: CalendarDiffTime -> Builder

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

176−calendarDiffTimeToBuilder = TPP.calendarDiffTime

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

19 , getZonedTimestamp

20 , getUTCTime

21 , getUTCTimestamp

22− , TimeZoneHMS

23− , getTimeZoneHMS

24− , localToUTCTimeOfDayHMS

25 ) where

22 ) where

27import Database.PostgreSQL.Simple.Time.Implementation

24import 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+38−202

@@ -1,6 +1,5 @@

1−{-# LANGUAGE CPP, DeriveDataTypeable, DeriveFunctor #-}

1+{-# LANGUAGE DeriveDataTypeable, DeriveFunctor #-}

2{-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-}

3−{-# LANGUAGE PolyKinds #-}

5------------------------------------------------------------------------------

4------------------------------------------------------------------------------

6-- |

5-- |

@@ -10,6 +9,7 @@

10-- License: BSD3

9-- License: BSD3

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

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

12-- Stability: experimental

11-- Stability: experimental

12+-- Portability: portable

13--

14-- The 'ToField' typeclass, for rendering a parameter to a SQL query.

15--

@@ -19,48 +19,28 @@ module Database.PostgreSQL.Simple.ToField

19 (

20 Action(..)

21 , ToField(..)

22− , toJSONField

23 , inQuotes

22 , inQuotes

24 ) where

23 ) where

26−import Control.Applicative (Const(Const))

25+import Blaze.ByteString.Builder (Builder, fromByteString, toByteString)

27−import qualified Data.Aeson as JSON

28−import Data.ByteString (ByteString)

26+import Blaze.ByteString.Builder.Char8 (fromChar)

29−import Data.ByteString.Builder

27+import Blaze.Text (integral, double, float)

30− ( Builder, byteString, char8, stringUtf8

28+import Data.ByteString (ByteString)

31− , intDec, int8Dec, int16Dec, int32Dec, int64Dec, integerDec

32− , wordDec, word8Dec, word16Dec, word32Dec, word64Dec

33− , floatDec, doubleDec

34− )

35−import Data.Functor.Identity (Identity(Identity))

36import Data.Int (Int8, Int16, Int32, Int64)

29import Data.Int (Int8, Int16, Int32, Int64)

37import Data.List (intersperse)

30import Data.List (intersperse)

38import Data.Monoid (mappend)

31import Data.Monoid (mappend)

39−import Data.Time.Compat (Day, TimeOfDay, LocalTime, UTCTime, ZonedTime, NominalDiffTime)

32+import Data.Time (Day, TimeOfDay, LocalTime, UTCTime, ZonedTime)

40−import Data.Time.LocalTime.Compat (CalendarDiffTime)

41import Data.Typeable (Typeable)

33import Data.Typeable (Typeable)

42import Data.Word (Word, Word8, Word16, Word32, Word64)

34import Data.Word (Word, Word8, Word16, Word32, Word64)

43−import {-# SOURCE #-} Database.PostgreSQL.Simple.ToRow

44−import Database.PostgreSQL.Simple.Types

35+import Database.PostgreSQL.Simple.Types (Binary(..), In(..), Null)

45−import Database.PostgreSQL.Simple.Compat (toByteString)

36+import qualified Blaze.ByteString.Builder.Char.Utf8 as Utf8

46−

47import qualified Data.ByteString as SB

37import qualified Data.ByteString as SB

48import qualified Data.ByteString.Lazy as LB

38import qualified Data.ByteString.Lazy as LB

49−import Data.CaseInsensitive (CI)

50−import qualified Data.CaseInsensitive as CI

51import qualified Data.Text as ST

39import qualified Data.Text as ST

52import qualified Data.Text.Encoding as ST

40import qualified Data.Text.Encoding as ST

53import qualified Data.Text.Lazy as LT

41import qualified Data.Text.Lazy as LT

54−import qualified Data.Text.Lazy.Builder as LT

55−import Data.UUID.Types (UUID)

56−import qualified Data.UUID.Types as UUID

57−import Data.Vector (Vector)

58−import qualified Data.Vector as V

59import qualified Database.PostgreSQL.LibPQ as PQ

42import qualified Database.PostgreSQL.LibPQ as PQ

60import Database.PostgreSQL.Simple.Time

43import Database.PostgreSQL.Simple.Time

61−import Data.Scientific (Scientific)

62−import Data.Text.Lazy.Builder.Scientific (scientificBuilder)

63−import Foreign.C.Types (CUInt(..))

65-- | How to render an element when substituting it into a query.

45-- | How to render an element when substituting it into a query.

66data Action =

46data Action =

@@ -76,20 +56,15 @@ data Action =

76 | EscapeByteA ByteString

56 | EscapeByteA ByteString

77 -- ^ Escape binary data for use as a @bytea@ literal. Include surrounding

57 -- ^ Escape binary data for use as a @bytea@ literal. Include surrounding

78 -- quotes. This is used by the 'Binary' newtype wrapper.

58 -- quotes. This is used by the 'Binary' newtype wrapper.

79− | EscapeIdentifier ByteString

80− -- ^ Escape before substituting. Use for all sql identifiers like

81− -- table, column names, etc. This is used by the 'Identifier' newtype

82− -- wrapper.

83 | Many [Action]

59 | Many [Action]

84 -- ^ Concatenate a series of rendering actions.

60 -- ^ Concatenate a series of rendering actions.

85 deriving (Typeable)

61 deriving (Typeable)

87instance Show Action where

63instance Show Action where

88− show (Plain b) = "Plain " ++ show (toByteString b)

64+ show (Plain b) = "Plain " ++ show (toByteString b)

89− show (Escape b) = "Escape " ++ show b

65+ show (Escape b) = "Escape " ++ show b

90− show (EscapeByteA b) = "EscapeByteA " ++ show b

66+ show (EscapeByteA b) = "EscapeByteA " ++ show b

91− show (EscapeIdentifier b) = "EscapeIdentifier " ++ show b

92− show (Many b) = "Many " ++ show b

67+ show (Many b) = "Many " ++ show b

94-- | A type that may be used as a single parameter to a SQL query.

69-- | A type that may be used as a single parameter to a SQL query.

95class ToField a where

70class ToField a where

@@ -100,102 +75,86 @@ instance ToField Action where

100 toField a = a

75 toField a = a

101 {-# INLINE toField #-}

76 {-# INLINE toField #-}

102

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−

111instance (ToField a) => ToField (Maybe a) where

78instance (ToField a) => ToField (Maybe a) where

112 toField Nothing = renderNull

79 toField Nothing = renderNull

113 toField (Just a) = toField a

80 toField (Just a) = toField a

114 {-# INLINE toField #-}

81 {-# INLINE toField #-}

115

116instance (ToField a) => ToField (In [a]) where

83instance (ToField a) => ToField (In [a]) where

117− toField (In []) = Plain $ byteString "(null)"

84+ toField (In []) = Plain $ fromByteString "(null)"

118 toField (In xs) = Many $

85 toField (In xs) = Many $

119− Plain (char8 '(') :

86+ Plain (fromChar '(') :

120− (intersperse (Plain (char8 ',')) . map toField $ xs) ++

87+ (intersperse (Plain (fromChar ',')) . map toField $ xs) ++

121− [Plain (char8 ')')]

88+ [Plain (fromChar ')')]

122

123renderNull :: Action

90renderNull :: Action

124−renderNull = Plain (byteString "null")

91+renderNull = Plain (fromByteString "null")

125

126instance ToField Null where

93instance ToField Null where

127 toField _ = renderNull

94 toField _ = renderNull

128 {-# INLINE toField #-}

95 {-# INLINE toField #-}

129

130−instance ToField Default where

131− toField _ = Plain (byteString "default")

132− {-# INLINE toField #-}

133−

134instance ToField Bool where

97instance ToField Bool where

135− toField True = Plain (byteString "true")

98+ toField True = Plain (fromByteString "true")

136− toField False = Plain (byteString "false")

99+ toField False = Plain (fromByteString "false")

137 {-# INLINE toField #-}

100 {-# INLINE toField #-}

138

101

139instance ToField Int8 where

102instance ToField Int8 where

140− toField = Plain . int8Dec

103+ toField = Plain . integral

141 {-# INLINE toField #-}

104 {-# INLINE toField #-}

142

105

143instance ToField Int16 where

106instance ToField Int16 where

144− toField = Plain . int16Dec

107+ toField = Plain . integral

145 {-# INLINE toField #-}

108 {-# INLINE toField #-}

146

109

147instance ToField Int32 where

110instance ToField Int32 where

148− toField = Plain . int32Dec

111+ toField = Plain . integral

149 {-# INLINE toField #-}

112 {-# INLINE toField #-}

150

113

151instance ToField Int where

114instance ToField Int where

152− toField = Plain . intDec

115+ toField = Plain . integral

153 {-# INLINE toField #-}

116 {-# INLINE toField #-}

154

117

155instance ToField Int64 where

118instance ToField Int64 where

156− toField = Plain . int64Dec

119+ toField = Plain . integral

157 {-# INLINE toField #-}

120 {-# INLINE toField #-}

158

121

159instance ToField Integer where

122instance ToField Integer where

160− toField = Plain . integerDec

123+ toField = Plain . integral

161 {-# INLINE toField #-}

124 {-# INLINE toField #-}

162

125

163instance ToField Word8 where

126instance ToField Word8 where

164− toField = Plain . word8Dec

127+ toField = Plain . integral

165 {-# INLINE toField #-}

128 {-# INLINE toField #-}

166

129

167instance ToField Word16 where

130instance ToField Word16 where

168− toField = Plain . word16Dec

131+ toField = Plain . integral

169 {-# INLINE toField #-}

132 {-# INLINE toField #-}

170

133

171instance ToField Word32 where

134instance ToField Word32 where

172− toField = Plain . word32Dec

135+ toField = Plain . integral

173 {-# INLINE toField #-}

136 {-# INLINE toField #-}

174

137

175instance ToField Word where

138instance ToField Word where

176− toField = Plain . wordDec

139+ toField = Plain . integral

177 {-# INLINE toField #-}

140 {-# INLINE toField #-}

178

141

179instance ToField Word64 where

142instance ToField Word64 where

180− toField = Plain . word64Dec

143+ toField = Plain . integral

181 {-# INLINE toField #-}

144 {-# INLINE toField #-}

182

145

183instance ToField PQ.Oid where

146instance ToField PQ.Oid where

184− toField = Plain . \(PQ.Oid (CUInt x)) -> word32Dec x

147+ toField = Plain . integral . \(PQ.Oid x) -> x

185 {-# INLINE toField #-}

148 {-# INLINE toField #-}

186

149

187instance ToField Float where

150instance ToField Float where

188− toField v | isNaN v || isInfinite v = Plain (inQuotes (floatDec v))

151+ toField v | isNaN v || isInfinite v = Plain (inQuotes (float v))

189− | otherwise = Plain (floatDec v)

152+ | otherwise = Plain (float v)

190 {-# INLINE toField #-}

153 {-# INLINE toField #-}

191

154

192instance ToField Double where

155instance ToField Double where

193− toField v | isNaN v || isInfinite v = Plain (inQuotes (doubleDec v))

156+ toField v | isNaN v || isInfinite v = Plain (inQuotes (double v))

194− | otherwise = Plain (doubleDec v)

157+ | otherwise = Plain (double v)

195− {-# INLINE toField #-}

196−

197−instance ToField Scientific where

198− toField x = toField (LT.toLazyText (scientificBuilder x))

199 {-# INLINE toField #-}

158 {-# INLINE toField #-}

200

159

201instance ToField (Binary SB.ByteString) where

160instance ToField (Binary SB.ByteString) where

@@ -206,20 +165,6 @@ instance ToField (Binary LB.ByteString) where

206 toField (Binary bs) = (EscapeByteA . SB.concat . LB.toChunks) bs

165 toField (Binary bs) = (EscapeByteA . SB.concat . LB.toChunks) bs

207 {-# INLINE toField #-}

166 {-# INLINE toField #-}

208

167

209−instance ToField Identifier where

210− toField (Identifier bs) = EscapeIdentifier (ST.encodeUtf8 bs)

211− {-# INLINE toField #-}

212−

213−instance ToField QualifiedIdentifier where

214− toField (QualifiedIdentifier (Just s) t) =

215− Many [ EscapeIdentifier (ST.encodeUtf8 s)

216− , Plain (char8 '.')

217− , EscapeIdentifier (ST.encodeUtf8 t)

218− ]

219− toField (QualifiedIdentifier Nothing t) =

220− EscapeIdentifier (ST.encodeUtf8 t)

221− {-# INLINE toField #-}

222−

223instance ToField SB.ByteString where

168instance ToField SB.ByteString where

224 toField = Escape

169 toField = Escape

225 {-# INLINE toField #-}

170 {-# INLINE toField #-}

@@ -233,23 +178,13 @@ instance ToField ST.Text where

233 {-# INLINE toField #-}

178 {-# INLINE toField #-}

234

179

235instance ToField [Char] where

180instance ToField [Char] where

236− toField = Escape . toByteString . stringUtf8

181+ toField = Escape . toByteString . Utf8.fromString

237 {-# INLINE toField #-}

182 {-# INLINE toField #-}

238

183

239instance ToField LT.Text where

184instance ToField LT.Text where

240 toField = toField . LT.toStrict

185 toField = toField . LT.toStrict

241 {-# INLINE toField #-}

186 {-# INLINE toField #-}

242

187

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−

253instance ToField UTCTime where

188instance ToField UTCTime where

254 toField = Plain . inQuotes . utcTimeToBuilder

189 toField = Plain . inQuotes . utcTimeToBuilder

255 {-# INLINE toField #-}

190 {-# INLINE toField #-}

@@ -286,108 +221,9 @@ instance ToField Date where

286 toField = Plain . inQuotes . dateToBuilder

221 toField = Plain . inQuotes . dateToBuilder

287 {-# INLINE toField #-}

222 {-# INLINE toField #-}

288

223

289−instance ToField NominalDiffTime where

290− toField = Plain . inQuotes . nominalDiffTimeToBuilder

291− {-# INLINE toField #-}

292−

293−instance ToField CalendarDiffTime where

294− toField = Plain . inQuotes . calendarDiffTimeToBuilder

295− {-# INLINE toField #-}

296−

297−instance (ToField a) => ToField (PGArray a) where

298− toField pgArray =

299− case fromPGArray pgArray of

300− [] -> Plain (byteString "'{}'")

301− xs -> Many $

302− Plain (byteString "ARRAY[") :

303− (intersperse (Plain (char8 ',')) . map toField $ xs) ++

304− [Plain (char8 ']')]

305− -- Because the ARRAY[...] input syntax is being used, it is possible

306− -- that the use of type-specific separator characters is unnecessary.

307−

308−instance (ToField a) => ToField (Vector a) where

309− toField = toField . PGArray . V.toList

310−

311−instance ToField UUID where

312− toField = Plain . inQuotes . byteString . UUID.toASCIIBytes

313−

314−instance ToField JSON.Value where

315− toField = toField . JSON.encode

316−

317−-- | Convert a Haskell value to JSON using 'JSON.toEncoding'.

318−--

319−-- This can be used as the default implementation for the 'toField'

320−-- method for Haskell types that have a JSON representation in

321−-- PostgreSQL.

322−toJSONField :: JSON.ToJSON a => a -> Action

323−toJSONField = toField . JSON.encode

324−

325-- | Surround a string with single-quote characters: \"@'@\"

224-- | Surround a string with single-quote characters: \"@'@\"

326--

225--

327-- This function /does not/ perform any other escaping.

226-- This function /does not/ perform any other escaping.

328inQuotes :: Builder -> Builder

227inQuotes :: Builder -> Builder

329inQuotes b = quote `mappend` b `mappend` quote

228inQuotes b = quote `mappend` b `mappend` quote

330− where quote = char8 '\''

229+ where quote = Utf8.fromChar '\''

331−

332−interleaveFoldr :: (a -> [b] -> [b]) -> b -> [b] -> [a] -> [b]

333−interleaveFoldr f b bs' as = foldr (\a bs -> b : f a bs) bs' as

334−{-# INLINE interleaveFoldr #-}

335−

336−instance ToRow a => ToField (Values a) where

337− toField (Values types rows) =

338− case rows of

339− [] -> case types of

340− [] -> error norows

341− (_:_) -> values $ typedRow (repeat (lit "null"))

342− types

343− [lit " LIMIT 0)"]

344− (_:_) -> case types of

345− [] -> values $ untypedRows rows [litC ')']

346− (_:_) -> values $ typedRows rows types [litC ')']

347− where

348− funcname = "Database.PostgreSQL.Simple.toField :: Values a -> Action"

349− norows = funcname ++ " either values or types must be non-empty"

350− emptyrow = funcname ++ " each row must contain at least one column"

351− lit = Plain . byteString

352− litC = Plain . char8

353− values x = Many (lit "(VALUES ": x)

354−

355− typedField :: (Action, QualifiedIdentifier) -> [Action] -> [Action]

356− typedField (val,typ) rest = val : lit "::" : toField typ : rest

357−

358− typedRow :: [Action] -> [QualifiedIdentifier] -> [Action] -> [Action]

359− typedRow (val:vals) (typ:typs) rest =

360− litC '(' :

361− typedField (val,typ) ( interleaveFoldr

362− typedField

363− (litC ',')

364− (litC ')' : rest)

365− (zip vals typs) )

366− typedRow _ _ _ = error emptyrow

367−

368− untypedRow :: [Action] -> [Action] -> [Action]

369− untypedRow (val:vals) rest =

370− litC '(' : val :

371− interleaveFoldr

372− (:)

373− (litC ',')

374− (litC ')' : rest)

375− vals

376− untypedRow _ _ = error emptyrow

377−

378− typedRows :: ToRow a => [a] -> [QualifiedIdentifier] -> [Action] -> [Action]

379− typedRows [] _ _ = error funcname

380− typedRows (val:vals) typs rest =

381− typedRow (toRow val) typs (multiRows vals rest)

382−

383− untypedRows :: ToRow a => [a] -> [Action] -> [Action]

384− untypedRows [] _ = error funcname

385− untypedRows (val:vals) rest =

386− untypedRow (toRow val) (multiRows vals rest)

387−

388− multiRows :: ToRow a => [a] -> [Action] -> [Action]

389− multiRows vals rest = interleaveFoldr

390− (untypedRow . toRow)

391− (litC ',')

392− rest

393− vals

src/Database/PostgreSQL/Simple/ToField.hs-bootdeleted−30

@@ -1,30 +0,0 @@

1−module Database.PostgreSQL.Simple.ToField where

2−

3−import Database.PostgreSQL.Simple.Types

4−import Data.ByteString.Builder(Builder)

5−import Data.ByteString(ByteString)

6−

7−-- | How to render an element when substituting it into a query.

8−data Action =

9− Plain Builder

10− -- ^ Render without escaping or quoting. Use for non-text types

11− -- such as numbers, when you are /certain/ that they will not

12− -- introduce formatting vulnerabilities via use of characters such

13− -- as spaces or \"@'@\".

14− | Escape ByteString

15− -- ^ Escape and enclose in quotes before substituting. Use for all

16− -- text-like types, and anything else that may contain unsafe

17− -- characters when rendered.

18− | EscapeByteA ByteString

19− -- ^ Escape binary data for use as a @bytea@ literal. Include surrounding

20− -- quotes. This is used by the 'Binary' newtype wrapper.

21− | EscapeIdentifier ByteString

22− -- ^ Escape before substituting. Use for all sql identifiers like

23− -- table, column names, etc. This is used by the 'Identifier' newtype

24− -- wrapper.

25− | Many [Action]

26− -- ^ Concatenate a series of rendering actions.

27−

28−class ToField a

29−

30−instance ToField Oid

src/Database/PostgreSQL/Simple/ToRow.hs+3−129

@@ -1,4 +1,3 @@

1−{-# LANGUAGE DefaultSignatures, FlexibleInstances, FlexibleContexts #-}

2------------------------------------------------------------------------------

1------------------------------------------------------------------------------

3-- |

2-- |

4-- Module: Database.PostgreSQL.Simple.ToRow

3-- Module: Database.PostgreSQL.Simple.ToRow

@@ -7,6 +6,7 @@

7-- License: BSD3

6-- License: BSD3

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

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

9-- Stability: experimental

8-- Stability: experimental

9+-- Portability: portable

10--

11-- The 'ToRow' typeclass, for rendering a collection of

12-- parameters to a SQL query.

@@ -23,33 +23,14 @@ module Database.PostgreSQL.Simple.ToRow

24import Database.PostgreSQL.Simple.ToField (Action(..), ToField(..))

25import Database.PostgreSQL.Simple.Types (Only(..), (:.)(..))

26−import GHC.Generics

28-- | A collection type that can be turned into a list of rendering

27-- | A collection type that can be turned into a list of rendering

29-- 'Action's.

28-- 'Action's.

30--

29--

31−-- Instances should use the 'toField' method of the 'ToField' class

30+-- Instances should use the 'render' method of the 'Param' class

32-- to perform conversion of each element of the collection.

31-- 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.

49class ToRow a where

32class ToRow a where

50 toRow :: a -> [Action]

33 toRow :: a -> [Action]

51− default toRow :: (Generic a, GToRow (Rep a)) => a -> [Action]

52− toRow = gtoRow . from

53 -- ^ ToField a collection of values.

34 -- ^ ToField a collection of values.

55instance ToRow () where

36instance ToRow () where

@@ -105,115 +86,8 @@ instance (ToField a, ToField b, ToField c, ToField d, ToField e, ToField f,

105 [toField a, toField b, toField c, toField d, toField e, toField f,

86 [toField a, toField b, toField c, toField d, toField e, toField f,

106 toField g, toField h, toField i, toField j]

87 toField g, toField h, toField i, toField j]

107

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−

198instance (ToField a) => ToRow [a] where

89instance (ToField a) => ToRow [a] where

199 toRow = map toField

90 toRow = map toField

200

201instance (ToRow a, ToRow b) => ToRow (a :. b) where

92instance (ToRow a, ToRow b) => ToRow (a :. b) where

202− toRow (a :. b) = toRow a ++ toRow b

93+ 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-bootdeleted−18

@@ -1,18 +0,0 @@

1−{-# LANGUAGE DefaultSignatures, FlexibleInstances, FlexibleContexts #-}

2−module Database.PostgreSQL.Simple.ToRow (

3− ToRow(..)

4− ) where

5−

6−import Database.PostgreSQL.Simple.Types

7−import {-# SOURCE #-} Database.PostgreSQL.Simple.ToField

8−import GHC.Generics

9−

10−class ToRow a where

11− toRow :: a -> [Action]

12− default toRow :: (Generic a, GToRow (Rep a)) => a -> [Action]

13− toRow = gtoRow . from

14−

15−class GToRow f where

16− gtoRow :: f p -> [Action]

17−

18−instance ToField a => ToRow (Only a)

src/Database/PostgreSQL/Simple/Transaction.hsdeleted−264

@@ -1,264 +0,0 @@

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

12−

13−module Database.PostgreSQL.Simple.Transaction

14− (

15− -- * Transaction handling

16− withTransaction

17− , withTransactionLevel

18− , withTransactionMode

19− , withTransactionModeRetry

20− , withTransactionModeRetry'

21− , withTransactionSerializable

22− , TransactionMode(..)

23− , IsolationLevel(..)

24− , ReadWriteMode(..)

25− , defaultTransactionMode

26− , defaultIsolationLevel

27− , defaultReadWriteMode

28−-- , Base.autocommit

29− , begin

30− , beginLevel

31− , beginMode

32− , commit

33− , rollback

34−

35− -- * Savepoint

36− , withSavepoint

37− , Savepoint

38− , newSavepoint

39− , releaseSavepoint

40− , rollbackToSavepoint

41− , rollbackToAndReleaseSavepoint

42−

43− -- * Error predicates

44− , isSerializationError

45− , isNoActiveTransactionError

46− , isFailedTransactionError

47− ) where

48−

49−import qualified Control.Exception as E

50−import qualified Data.ByteString as B

51−import Database.PostgreSQL.Simple.Internal

52−import Database.PostgreSQL.Simple.Types

53−import Database.PostgreSQL.Simple.Errors

54−import Database.PostgreSQL.Simple.Compat (mask, (<>))

55−

56−

57−-- | Of the four isolation levels defined by the SQL standard,

58−-- 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>

60−-- for more information. Note that prior to PostgreSQL 9.0, 'RepeatableRead'

61−-- was equivalent to 'Serializable'.

62−

63−data IsolationLevel

64− = DefaultIsolationLevel -- ^ the isolation level will be taken from

65− -- PostgreSQL's per-connection

66− -- @default_transaction_isolation@ variable,

67− -- which is initialized according to the

68− -- server's config. The default configuration

69− -- is 'ReadCommitted'.

70− | ReadCommitted

71− | RepeatableRead

72− | Serializable

73− deriving (Show, Eq, Ord, Enum, Bounded)

74−

75−data ReadWriteMode

76− = DefaultReadWriteMode -- ^ the read-write mode will be taken from

77− -- PostgreSQL's per-connection

78− -- @default_transaction_read_only@ variable,

79− -- which is initialized according to the

80− -- server's config. The default configuration

81− -- is 'ReadWrite'.

82− | ReadWrite

83− | ReadOnly

84− deriving (Show, Eq, Ord, Enum, Bounded)

85−

86−data TransactionMode = TransactionMode {

87− isolationLevel :: !IsolationLevel,

88− readWriteMode :: !ReadWriteMode

89− } deriving (Show, Eq)

90−

91−defaultTransactionMode :: TransactionMode

92−defaultTransactionMode = TransactionMode

93− defaultIsolationLevel

94− defaultReadWriteMode

95−

96−defaultIsolationLevel :: IsolationLevel

97−defaultIsolationLevel = DefaultIsolationLevel

98−

99−defaultReadWriteMode :: ReadWriteMode

100−defaultReadWriteMode = DefaultReadWriteMode

101−

102−-- | Execute an action inside a SQL transaction.

103−--

104−-- This function initiates a transaction with a \"@begin

105−-- transaction@\" statement, then executes the supplied action. If

106−-- the action succeeds, the transaction will be completed with

107−-- 'Base.commit' before this function returns.

108−--

109−-- If the action throws /any/ kind of exception (not just a

110−-- PostgreSQL-related exception), the transaction will be rolled back using

111−-- 'rollback', then the exception will be rethrown.

112−--

113−-- For nesting transactions, see 'withSavepoint'.

114−withTransaction :: Connection -> IO a -> IO a

115−withTransaction = withTransactionMode defaultTransactionMode

116−

117−-- | Execute an action inside of a 'Serializable' transaction. If a

118−-- serialization failure occurs, roll back the transaction and try again.

119−-- Be warned that this may execute the IO action multiple times.

120−--

121−-- A 'Serializable' transaction creates the illusion that your program has

122−-- exclusive access to the database. This means that, even in a concurrent

123−-- setting, you can perform queries in sequence without having to worry about

124−-- what might happen between one statement and the next.

125−--

126−-- Think of it as STM, but without @retry@.

127−withTransactionSerializable :: Connection -> IO a -> IO a

128−withTransactionSerializable =

129− withTransactionModeRetry

130− TransactionMode

131− { isolationLevel = Serializable

132− , readWriteMode = ReadWrite

133− }

134− isSerializationError

135−

136−-- | Execute an action inside a SQL transaction with a given isolation level.

137−withTransactionLevel :: IsolationLevel -> Connection -> IO a -> IO a

138−withTransactionLevel lvl

139− = withTransactionMode defaultTransactionMode { isolationLevel = lvl }

140−

141−-- | Execute an action inside a SQL transaction with a given transaction mode.

142−withTransactionMode :: TransactionMode -> Connection -> IO a -> IO a

143−withTransactionMode mode conn act =

144− mask $ \restore -> do

145− beginMode mode conn

146− r <- restore act `E.onException` rollback_ conn

147− commit conn

148− return r

149−

150−-- | 'withTransactionModeRetry'' but with the exception type pinned to 'SqlError'.

151−withTransactionModeRetry :: TransactionMode -> (SqlError -> Bool) -> Connection -> IO a -> IO a

152−withTransactionModeRetry = withTransactionModeRetry'

153−

154−-- | 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@

158−-- occurs then the transaction will be rolled back and the exception rethrown.

159−--

160−-- 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 =

163− mask $ \restore ->

164− retryLoop $ E.try $ do

165− a <- restore act `E.onException` rollback_ conn

166− commit conn

167− return a

168− where

169− retryLoop :: IO (Either e a) -> IO a

170− retryLoop act' = do

171− beginMode mode conn

172− r <- act'

173− case r of

174− Left e ->

175− case shouldRetry e of

176− True -> retryLoop act'

177− False -> E.throwIO e

178− Right a ->

179− return a

180−

181−-- | Rollback a transaction.

182−rollback :: 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 ()

188−

189−-- | Commit a transaction.

190−commit :: Connection -> IO ()

191−commit conn = execute_ conn "COMMIT" >> return ()

192−

193−-- | Begin a transaction.

194−begin :: Connection -> IO ()

195−begin = beginMode defaultTransactionMode

196−

197−-- | Begin a transaction with a given isolation level

198−beginLevel :: IsolationLevel -> Connection -> IO ()

199−beginLevel lvl = beginMode defaultTransactionMode { isolationLevel = lvl }

200−

201−-- | Begin a transaction with a given transaction mode

202−beginMode :: TransactionMode -> Connection -> IO ()

203−beginMode mode conn = do

204− _ <- execute_ conn $! Query (B.concat ["BEGIN", isolevel, readmode])

205− return ()

206− where

207− isolevel = case isolationLevel mode of

208− DefaultIsolationLevel -> ""

209− ReadCommitted -> " ISOLATION LEVEL READ COMMITTED"

210− RepeatableRead -> " ISOLATION LEVEL REPEATABLE READ"

211− Serializable -> " ISOLATION LEVEL SERIALIZABLE"

212− readmode = case readWriteMode mode of

213− DefaultReadWriteMode -> ""

214− ReadWrite -> " READ WRITE"

215− ReadOnly -> " READ ONLY"

216−

217−------------------------------------------------------------------------

218−-- Savepoint

219−

220−-- | Create a savepoint, and roll back to it if an error occurs. This may only

221−-- be used inside of a transaction, and provides a sort of

222−-- \"nested transaction\".

223−--

224−-- See <https://www.postgresql.org/docs/9.5/static/sql-savepoint.html>

225−withSavepoint :: Connection -> IO a -> IO a

226−withSavepoint conn body =

227− mask $ \restore -> do

228− sp <- newSavepoint conn

229− r <- restore body `E.onException` rollbackToAndReleaseSavepoint conn sp

230− releaseSavepoint conn sp `E.catch` \err ->

231− if isFailedTransactionError err

232− then rollbackToAndReleaseSavepoint conn sp

233− else E.throwIO err

234− return r

235−

236−-- | Create a new savepoint. This may only be used inside of a transaction.

237−newSavepoint :: Connection -> IO Savepoint

238−newSavepoint conn = do

239− name <- newTempName conn

240− _ <- execute_ conn ("SAVEPOINT " <> name)

241− return (Savepoint name)

242−

243−-- | Destroy a savepoint, but retain its effects.

244−--

245−-- Warning: this will throw a 'SqlError' matching 'isFailedTransactionError' if

246−-- the transaction is aborted due to an error. 'commit' would merely warn and

247−-- roll back.

248−releaseSavepoint :: Connection -> Savepoint -> IO ()

249−releaseSavepoint conn (Savepoint name) =

250− execute_ conn ("RELEASE SAVEPOINT " <> name) >> return ()

251−

252−-- | Roll back to a savepoint. This will not release the savepoint.

253−rollbackToSavepoint :: Connection -> Savepoint -> IO ()

254−rollbackToSavepoint conn (Savepoint name) =

255− execute_ conn ("ROLLBACK TO SAVEPOINT " <> name) >> return ()

256−

257−-- | Roll back to a savepoint and release it. This is like calling

258−-- 'rollbackToSavepoint' followed by 'releaseSavepoint', but avoids a

259−-- round trip to the database server.

260−rollbackToAndReleaseSavepoint :: Connection -> Savepoint -> IO ()

261−rollbackToAndReleaseSavepoint conn (Savepoint name) =

262− execute_ conn sql >> return ()

263− where

264− sql = "ROLLBACK TO SAVEPOINT " <> name <> "; RELEASE SAVEPOINT " <> name

src/Database/PostgreSQL/Simple/TypeInfo.hsdeleted−121

@@ -1,121 +0,0 @@

1−{-# LANGUAGE RecordWildCards #-}

2−

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

4−-- |

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

7−-- License: BSD3

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

9−-- Stability: experimental

10−--

11−-- This module provides convenient and efficient access to parts of the

12−-- @pg_type@ metatable. At the moment, this requires PostgreSQL 8.4 if

13−-- you need to work with types that do not appear in

14−-- 'Database.PostgreSQL.Simple.TypeInfo.Static'.

15−--

16−-- The current scheme could be more efficient, especially for some use

17−-- cases. In particular, connection pools that use many user-added

18−-- types and connect to a set of servers with identical (or at least

19−-- compatible) @pg_type@ and associated tables could share a common

20−-- typeinfo cache, thus saving memory and communication between the

21−-- client and server.

22−--

23−------------------------------------------------------------------------------

24−

25−module Database.PostgreSQL.Simple.TypeInfo

26− ( getTypeInfo

27− , TypeInfo(..)

28− , Attribute(..)

29− ) where

30−

31−import qualified Data.ByteString as B

32−import qualified Data.IntMap as IntMap

33−import qualified Data.Vector as V

34−import qualified Data.Vector.Mutable as MV

35−import Control.Concurrent.MVar

36−import Control.Exception (throw)

37−

38−import qualified Database.PostgreSQL.LibPQ as PQ

39−import {-# SOURCE #-} Database.PostgreSQL.Simple

40−import Database.PostgreSQL.Simple.Internal

41−import Database.PostgreSQL.Simple.Types

42−import Database.PostgreSQL.Simple.TypeInfo.Types

43−import Database.PostgreSQL.Simple.TypeInfo.Static

44−

45−-- | Returns the metadata of the type with a particular oid. To find

46−-- this data, 'getTypeInfo' first consults postgresql-simple's

47−-- built-in 'staticTypeInfo' table, then checks the connection's

48−-- typeinfo cache. Finally, the database's 'pg_type' table will

49−-- be queried only if necessary, and the result will be stored

50−-- in the connections's cache.

51−

52−getTypeInfo :: Connection -> PQ.Oid -> IO TypeInfo

53−getTypeInfo conn@Connection{..} oid' =

54− case staticTypeInfo oid' of

55− Just name' -> return name'

56− Nothing -> modifyMVar connectionObjects $ getTypeInfo' conn oid'

57−

58−getTypeInfo' :: Connection -> PQ.Oid -> TypeInfoCache

59− -> IO (TypeInfoCache, TypeInfo)

60−getTypeInfo' conn oid' oidmap =

61− case IntMap.lookup (oid2int oid') oidmap of

62− Just typeinfo -> return (oidmap, typeinfo)

63− Nothing -> do

64− names <- query conn "SELECT oid, typcategory, typdelim, typname,\

65− \ typelem, typrelid\

66− \ FROM pg_type WHERE oid = ?"

67− (Only oid')

68− (oidmap', typeInfo) <-

69− case names of

70− [] -> return $ throw (fatalError "invalid type oid")

71− [(typoid, typcategory, typdelim, typname, typelem_, typrelid)] -> do

72− case typcategory of

73− 'A' -> do

74− (oidmap', typelem) <- getTypeInfo' conn typelem_ oidmap

75− let !typeInfo = Array{..}

76− return $! (oidmap', typeInfo)

77− 'R' -> do

78− rngsubtypeOids <- query conn "SELECT rngsubtype\

79− \ FROM pg_range\

80− \ WHERE rngtypid = ?"

81− (Only oid')

82− case rngsubtypeOids of

83− [Only rngsubtype_] -> do

84− (oidmap', rngsubtype) <-

85− getTypeInfo' conn rngsubtype_ oidmap

86− let !typeInfo = Range{..}

87− return $! (oidmap', typeInfo)

88− _ -> fail "range subtype query failed to return exactly one result"

89− 'C' -> do

90− cols <- query conn "SELECT attname, atttypid\

91− \ FROM pg_attribute\

92− \ WHERE attrelid = ?\

93− \ AND attnum > 0\

94− \ AND NOT attisdropped\

95− \ ORDER BY attnum"

96− (Only typrelid)

97− vec <- MV.new $! length cols

98− (oidmap', attributes) <- getAttInfos conn cols oidmap vec 0

99− let !typeInfo = Composite{..}

100− return $! (oidmap', typeInfo)

101− _ -> do

102− let !typeInfo = Basic{..}

103− return $! (oidmap, typeInfo)

104− _ -> fail "typename query returned more than one result"

105− -- oid is a primary key, so the query should

106− -- never return more than one result

107− let !oidmap'' = IntMap.insert (oid2int oid') typeInfo oidmap'

108− return $! (oidmap'', typeInfo)

109−

110−getAttInfos :: Connection -> [(B.ByteString, PQ.Oid)] -> TypeInfoCache

111− -> MV.IOVector Attribute -> Int

112− -> IO (TypeInfoCache, V.Vector Attribute)

113−getAttInfos conn cols oidmap vec n =

114− case cols of

115− [] -> do

116− !attributes <- V.unsafeFreeze vec

117− return $! (oidmap, attributes)

118− ((attname, attTypeOid):xs) -> do

119− (oidmap', atttype) <- getTypeInfo' conn attTypeOid oidmap

120− MV.write vec n $! Attribute{..}

121− getAttInfos conn xs oidmap' vec (n+1)

src/Database/PostgreSQL/Simple/TypeInfo/Macro.hsdeleted−53

@@ -1,53 +0,0 @@

1−{-# LANGUAGE CPP #-}

2−#if __GLASGOW_HASKELL__ >= 800

3−{-# LANGUAGE TemplateHaskellQuotes #-}

4−#else

5−{-# LANGUAGE TemplateHaskell #-}

6−#endif

7−

8−------------------------------------------------------------------------------

9−-- |

10−-- Module: Database.PostgreSQL.Simple.TypeInfo.Macro

12−-- License: BSD3

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

14−-- Stability: experimental

15−--

16−-- A Template Haskell macro for efficiently checking membership in

17−-- a set of type oids.

18−--

19−------------------------------------------------------------------------------

20−

21−module Database.PostgreSQL.Simple.TypeInfo.Macro

22− ( mkCompats

23− , inlineTypoid

24− ) where

25−

26−import Database.PostgreSQL.Simple.TypeInfo.Static

27−import Database.PostgreSQL.Simple.Types (Oid(..))

28−import Language.Haskell.TH

29−

30−-- | Returns an expression that has type @'Oid' -> 'Bool'@, true if the

31−-- oid is equal to any one of the 'typoid's of the given 'TypeInfo's.

32−mkCompats :: [TypeInfo] -> ExpQ

33−mkCompats tys = do

34− x <- newName "x"

35− lamE [conP 'Oid [varP x]] $ caseE (varE x) (map alt tys ++ [catchAll])

36− where

37− alt :: TypeInfo -> MatchQ

38− alt ty = match (inlineTypoidP ty) (normalB [| True |]) []

39−

40− catchAll :: MatchQ

41− catchAll = match wildP (normalB [| False |]) []

42−

43−-- | Literally substitute the 'typoid' of a 'TypeInfo' expression.

44−-- Returns an expression of type 'Oid'. Useful because GHC tends

45−-- not to fold constants.

46−inlineTypoid :: TypeInfo -> ExpQ

47−inlineTypoid ty = conE 'Oid `appE` litE (getTypoid ty)

48−

49−inlineTypoidP :: TypeInfo -> PatQ

50−inlineTypoidP ty = litP (getTypoid ty)

51−

52−getTypoid :: TypeInfo -> Lit

53−getTypoid ty = let (Oid x) = typoid ty in integerL (fromIntegral x)

src/Database/PostgreSQL/Simple/TypeInfo/Static.hsdeleted−1802

@@ -1,1802 +0,0 @@

1−------------------------------------------------------------------------------

2−-- |

3−-- Module: Database.PostgreSQL.Simple.TypeInfo

5−-- License: BSD3

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

7−-- Stability: experimental

8−--

9−-- This module contains portions of the @pg_type@ table that are relevant

10−-- to postgresql-simple and are believed to not change between PostgreSQL

11−-- versions.

12−--

13−------------------------------------------------------------------------------

14−

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

16−-- not be edited directly

17−

18−module Database.PostgreSQL.Simple.TypeInfo.Static

19− ( TypeInfo(..)

20− , staticTypeInfo

21− , bool

22− , boolOid

23− , bytea

24− , byteaOid

25− , char

26− , charOid

27− , name

28− , nameOid

29− , int8

30− , int8Oid

31− , int2

32− , int2Oid

33− , int4

34− , int4Oid

35− , regproc

36− , regprocOid

37− , text

38− , textOid

39− , oid

40− , oidOid

41− , tid

42− , tidOid

43− , xid

44− , xidOid

45− , cid

46− , cidOid

47− , xml

48− , xmlOid

49− , point

50− , pointOid

51− , lseg

52− , lsegOid

53− , path

54− , pathOid

55− , box

56− , boxOid

57− , polygon

58− , polygonOid

59− , line

60− , lineOid

61− , cidr

62− , cidrOid

63− , float4

64− , float4Oid

65− , float8

66− , float8Oid

67− , unknown

68− , unknownOid

69− , circle

70− , circleOid

71− , money

72− , moneyOid

73− , macaddr

74− , macaddrOid

75− , inet

76− , inetOid

77− , bpchar

78− , bpcharOid

79− , varchar

80− , varcharOid

81− , date

82− , dateOid

83− , time

84− , timeOid

85− , timestamp

86− , timestampOid

87− , timestamptz

88− , timestamptzOid

89− , interval

90− , intervalOid

91− , timetz

92− , timetzOid

93− , bit

94− , bitOid

95− , varbit

96− , varbitOid

97− , numeric

98− , numericOid

99− , refcursor

100− , refcursorOid

101− , record

102− , recordOid

103− , 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

117− , uuid

118− , uuidOid

119− , json

120− , jsonOid

121− , jsonb

122− , jsonbOid

123− , int2vector

124− , int2vectorOid

125− , oidvector

126− , oidvectorOid

127− , array_xml

128− , array_xmlOid

129− , array_json

130− , array_jsonOid

131− , array_line

132− , array_lineOid

133− , array_cidr

134− , array_cidrOid

135− , array_circle

136− , array_circleOid

137− , array_money

138− , array_moneyOid

139− , array_bool

140− , array_boolOid

141− , array_bytea

142− , array_byteaOid

143− , array_char

144− , array_charOid

145− , array_name

146− , array_nameOid

147− , array_int2

148− , array_int2Oid

149− , array_int2vector

150− , array_int2vectorOid

151− , array_int4

152− , array_int4Oid

153− , array_regproc

154− , array_regprocOid

155− , array_text

156− , array_textOid

157− , array_tid

158− , array_tidOid

159− , array_xid

160− , array_xidOid

161− , array_cid

162− , array_cidOid

163− , array_oidvector

164− , array_oidvectorOid

165− , array_bpchar

166− , array_bpcharOid

167− , array_varchar

168− , array_varcharOid

169− , array_int8

170− , array_int8Oid

171− , array_point

172− , array_pointOid

173− , array_lseg

174− , array_lsegOid

175− , array_path

176− , array_pathOid

177− , array_box

178− , array_boxOid

179− , array_float4

180− , array_float4Oid

181− , array_float8

182− , array_float8Oid

183− , array_polygon

184− , array_polygonOid

185− , array_oid

186− , array_oidOid

187− , array_macaddr

188− , array_macaddrOid

189− , array_inet

190− , array_inetOid

191− , array_timestamp

192− , array_timestampOid

193− , array_date

194− , array_dateOid

195− , array_time

196− , array_timeOid

197− , array_timestamptz

198− , array_timestamptzOid

199− , array_interval

200− , array_intervalOid

201− , array_numeric

202− , array_numericOid

203− , array_timetz

204− , array_timetzOid

205− , array_bit

206− , array_bitOid

207− , array_varbit

208− , array_varbitOid

209− , array_refcursor

210− , array_refcursorOid

211− , array_regprocedure

212− , array_regprocedureOid

213− , array_regoper

214− , array_regoperOid

215− , array_regoperator

216− , array_regoperatorOid

217− , array_regclass

218− , array_regclassOid

219− , array_regtype

220− , array_regtypeOid

221− , array_uuid

222− , array_uuidOid

223− , array_jsonb

224− , array_jsonbOid

225− , int4range

226− , int4rangeOid

227− , _int4range

228− , _int4rangeOid

229− , numrange

230− , numrangeOid

231− , _numrange

232− , _numrangeOid

233− , tsrange

234− , tsrangeOid

235− , _tsrange

236− , _tsrangeOid

237− , tstzrange

238− , tstzrangeOid

239− , _tstzrange

240− , _tstzrangeOid

241− , daterange

242− , daterangeOid

243− , _daterange

244− , _daterangeOid

245− , int8range

246− , int8rangeOid

247− , _int8range

248− , _int8rangeOid

249− ) where

250−

251−import Database.PostgreSQL.LibPQ (Oid(..))

252−import Database.PostgreSQL.Simple.TypeInfo.Types

253−

254−staticTypeInfo :: Oid -> Maybe TypeInfo

255−staticTypeInfo (Oid x) = case x of

256− 16 -> Just bool

257− 17 -> Just bytea

258− 18 -> Just char

259− 19 -> Just name

260− 20 -> Just int8

261− 21 -> Just int2

262− 23 -> Just int4

263− 24 -> Just regproc

264− 25 -> Just text

265− 26 -> Just oid

266− 27 -> Just tid

267− 28 -> Just xid

268− 29 -> Just cid

269− 142 -> Just xml

270− 600 -> Just point

271− 601 -> Just lseg

272− 602 -> Just path

273− 603 -> Just box

274− 604 -> Just polygon

275− 628 -> Just line

276− 650 -> Just cidr

277− 700 -> Just float4

278− 701 -> Just float8

279− 705 -> Just unknown

280− 718 -> Just circle

281− 790 -> Just money

282− 829 -> Just macaddr

283− 869 -> Just inet

284− 1042 -> Just bpchar

285− 1043 -> Just varchar

286− 1082 -> Just date

287− 1083 -> Just time

288− 1114 -> Just timestamp

289− 1184 -> Just timestamptz

290− 1186 -> Just interval

291− 1266 -> Just timetz

292− 1560 -> Just bit

293− 1562 -> Just varbit

294− 1700 -> Just numeric

295− 1790 -> Just refcursor

296− 2249 -> Just record

297− 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

304− 2950 -> Just uuid

305− 114 -> Just json

306− 3802 -> Just jsonb

307− 22 -> Just int2vector

308− 30 -> Just oidvector

309− 143 -> Just array_xml

310− 199 -> Just array_json

311− 629 -> Just array_line

312− 651 -> Just array_cidr

313− 719 -> Just array_circle

314− 791 -> Just array_money

315− 1000 -> Just array_bool

316− 1001 -> Just array_bytea

317− 1002 -> Just array_char

318− 1003 -> Just array_name

319− 1005 -> Just array_int2

320− 1006 -> Just array_int2vector

321− 1007 -> Just array_int4

322− 1008 -> Just array_regproc

323− 1009 -> Just array_text

324− 1010 -> Just array_tid

325− 1011 -> Just array_xid

326− 1012 -> Just array_cid

327− 1013 -> Just array_oidvector

328− 1014 -> Just array_bpchar

329− 1015 -> Just array_varchar

330− 1016 -> Just array_int8

331− 1017 -> Just array_point

332− 1018 -> Just array_lseg

333− 1019 -> Just array_path

334− 1020 -> Just array_box

335− 1021 -> Just array_float4

336− 1022 -> Just array_float8

337− 1027 -> Just array_polygon

338− 1028 -> Just array_oid

339− 1040 -> Just array_macaddr

340− 1041 -> Just array_inet

341− 1115 -> Just array_timestamp

342− 1182 -> Just array_date

343− 1183 -> Just array_time

344− 1185 -> Just array_timestamptz

345− 1187 -> Just array_interval

346− 1231 -> Just array_numeric

347− 1270 -> Just array_timetz

348− 1561 -> Just array_bit

349− 1563 -> Just array_varbit

350− 2201 -> Just array_refcursor

351− 2207 -> Just array_regprocedure

352− 2208 -> Just array_regoper

353− 2209 -> Just array_regoperator

354− 2210 -> Just array_regclass

355− 2211 -> Just array_regtype

356− 2951 -> Just array_uuid

357− 3807 -> Just array_jsonb

358− 3904 -> Just int4range

359− 3905 -> Just _int4range

360− 3906 -> Just numrange

361− 3907 -> Just _numrange

362− 3908 -> Just tsrange

363− 3909 -> Just _tsrange

364− 3910 -> Just tstzrange

365− 3911 -> Just _tstzrange

366− 3912 -> Just daterange

367− 3913 -> Just _daterange

368− 3926 -> Just int8range

369− 3927 -> Just _int8range

370− _ -> Nothing

371−

372−bool :: TypeInfo

373−bool = Basic {

374− typoid = boolOid,

375− typcategory = 'B',

376− typdelim = ',',

377− typname = "bool"

378− }

379−

380−boolOid :: Oid

381−boolOid = Oid 16

382−{-# INLINE boolOid #-}

383−

384−bytea :: TypeInfo

385−bytea = Basic {

386− typoid = byteaOid,

387− typcategory = 'U',

388− typdelim = ',',

389− typname = "bytea"

390− }

391−

392−byteaOid :: Oid

393−byteaOid = Oid 17

394−{-# INLINE byteaOid #-}

395−

396−char :: TypeInfo

397−char = Basic {

398− typoid = charOid,

399− typcategory = 'S',

400− typdelim = ',',

401− typname = "char"

402− }

403−

404−charOid :: Oid

405−charOid = Oid 18

406−{-# INLINE charOid #-}

407−

408−name :: TypeInfo

409−name = Basic {

410− typoid = nameOid,

411− typcategory = 'S',

412− typdelim = ',',

413− typname = "name"

414− }

415−

416−nameOid :: Oid

417−nameOid = Oid 19

418−{-# INLINE nameOid #-}

419−

420−int8 :: TypeInfo

421−int8 = Basic {

422− typoid = int8Oid,

423− typcategory = 'N',

424− typdelim = ',',

425− typname = "int8"

426− }

427−

428−int8Oid :: Oid

429−int8Oid = Oid 20

430−{-# INLINE int8Oid #-}

431−

432−int2 :: TypeInfo

433−int2 = Basic {

434− typoid = int2Oid,

435− typcategory = 'N',

436− typdelim = ',',

437− typname = "int2"

438− }

439−

440−int2Oid :: Oid

441−int2Oid = Oid 21

442−{-# INLINE int2Oid #-}

443−

444−int4 :: TypeInfo

445−int4 = Basic {

446− typoid = int4Oid,

447− typcategory = 'N',

448− typdelim = ',',

449− typname = "int4"

450− }

451−

452−int4Oid :: Oid

453−int4Oid = Oid 23

454−{-# INLINE int4Oid #-}

455−

456−regproc :: TypeInfo

457−regproc = Basic {

458− typoid = regprocOid,

459− typcategory = 'N',

460− typdelim = ',',

461− typname = "regproc"

462− }

463−

464−regprocOid :: Oid

465−regprocOid = Oid 24

466−{-# INLINE regprocOid #-}

467−

468−text :: TypeInfo

469−text = Basic {

470− typoid = textOid,

471− typcategory = 'S',

472− typdelim = ',',

473− typname = "text"

474− }

475−

476−textOid :: Oid

477−textOid = Oid 25

478−{-# INLINE textOid #-}

479−

480−oid :: TypeInfo

481−oid = Basic {

482− typoid = oidOid,

483− typcategory = 'N',

484− typdelim = ',',

485− typname = "oid"

486− }

487−

488−oidOid :: Oid

489−oidOid = Oid 26

490−{-# INLINE oidOid #-}

491−

492−tid :: TypeInfo

493−tid = Basic {

494− typoid = tidOid,

495− typcategory = 'U',

496− typdelim = ',',

497− typname = "tid"

498− }

499−

500−tidOid :: Oid

501−tidOid = Oid 27

502−{-# INLINE tidOid #-}

503−

504−xid :: TypeInfo

505−xid = Basic {

506− typoid = xidOid,

507− typcategory = 'U',

508− typdelim = ',',

509− typname = "xid"

510− }

511−

512−xidOid :: Oid

513−xidOid = Oid 28

514−{-# INLINE xidOid #-}

515−

516−cid :: TypeInfo

517−cid = Basic {

518− typoid = cidOid,

519− typcategory = 'U',

520− typdelim = ',',

521− typname = "cid"

522− }

523−

524−cidOid :: Oid

525−cidOid = Oid 29

526−{-# INLINE cidOid #-}

527−

528−xml :: TypeInfo

529−xml = Basic {

530− typoid = xmlOid,

531− typcategory = 'U',

532− typdelim = ',',

533− typname = "xml"

534− }

535−

536−xmlOid :: Oid

537−xmlOid = Oid 142

538−{-# INLINE xmlOid #-}

539−

540−point :: TypeInfo

541−point = Basic {

542− typoid = pointOid,

543− typcategory = 'G',

544− typdelim = ',',

545− typname = "point"

546− }

547−

548−pointOid :: Oid

549−pointOid = Oid 600

550−{-# INLINE pointOid #-}

551−

552−lseg :: TypeInfo

553−lseg = Basic {

554− typoid = lsegOid,

555− typcategory = 'G',

556− typdelim = ',',

557− typname = "lseg"

558− }

559−

560−lsegOid :: Oid

561−lsegOid = Oid 601

562−{-# INLINE lsegOid #-}

563−

564−path :: TypeInfo

565−path = Basic {

566− typoid = pathOid,

567− typcategory = 'G',

568− typdelim = ',',

569− typname = "path"

570− }

571−

572−pathOid :: Oid

573−pathOid = Oid 602

574−{-# INLINE pathOid #-}

575−

576−box :: TypeInfo

577−box = Basic {

578− typoid = boxOid,

579− typcategory = 'G',

580− typdelim = ';',

581− typname = "box"

582− }

583−

584−boxOid :: Oid

585−boxOid = Oid 603

586−{-# INLINE boxOid #-}

587−

588−polygon :: TypeInfo

589−polygon = Basic {

590− typoid = polygonOid,

591− typcategory = 'G',

592− typdelim = ',',

593− typname = "polygon"

594− }

595−

596−polygonOid :: Oid

597−polygonOid = Oid 604

598−{-# INLINE polygonOid #-}

599−

600−line :: TypeInfo

601−line = Basic {

602− typoid = lineOid,

603− typcategory = 'G',

604− typdelim = ',',

605− typname = "line"

606− }

607−

608−lineOid :: Oid

609−lineOid = Oid 628

610−{-# INLINE lineOid #-}

611−

612−cidr :: TypeInfo

613−cidr = Basic {

614− typoid = cidrOid,

615− typcategory = 'I',

616− typdelim = ',',

617− typname = "cidr"

618− }

619−

620−cidrOid :: Oid

621−cidrOid = Oid 650

622−{-# INLINE cidrOid #-}

623−

624−float4 :: TypeInfo

625−float4 = Basic {

626− typoid = float4Oid,

627− typcategory = 'N',

628− typdelim = ',',

629− typname = "float4"

630− }

631−

632−float4Oid :: Oid

633−float4Oid = Oid 700

634−{-# INLINE float4Oid #-}

635−

636−float8 :: TypeInfo

637−float8 = Basic {

638− typoid = float8Oid,

639− typcategory = 'N',

640− typdelim = ',',

641− typname = "float8"

642− }

643−

644−float8Oid :: Oid

645−float8Oid = Oid 701

646−{-# INLINE float8Oid #-}

647−

648−unknown :: TypeInfo

649−unknown = Basic {

650− typoid = unknownOid,

651− typcategory = 'X',

652− typdelim = ',',

653− typname = "unknown"

654− }

655−

656−unknownOid :: Oid

657−unknownOid = Oid 705

658−{-# INLINE unknownOid #-}

659−

660−circle :: TypeInfo

661−circle = Basic {

662− typoid = circleOid,

663− typcategory = 'G',

664− typdelim = ',',

665− typname = "circle"

666− }

667−

668−circleOid :: Oid

669−circleOid = Oid 718

670−{-# INLINE circleOid #-}

671−

672−money :: TypeInfo

673−money = Basic {

674− typoid = moneyOid,

675− typcategory = 'N',

676− typdelim = ',',

677− typname = "money"

678− }

679−

680−moneyOid :: Oid

681−moneyOid = Oid 790

682−{-# INLINE moneyOid #-}

683−

684−macaddr :: TypeInfo

685−macaddr = Basic {

686− typoid = macaddrOid,

687− typcategory = 'U',

688− typdelim = ',',

689− typname = "macaddr"

690− }

691−

692−macaddrOid :: Oid

693−macaddrOid = Oid 829

694−{-# INLINE macaddrOid #-}

695−

696−inet :: TypeInfo

697−inet = Basic {

698− typoid = inetOid,

699− typcategory = 'I',

700− typdelim = ',',

701− typname = "inet"

702− }

703−

704−inetOid :: Oid

705−inetOid = Oid 869

706−{-# INLINE inetOid #-}

707−

708−bpchar :: TypeInfo

709−bpchar = Basic {

710− typoid = bpcharOid,

711− typcategory = 'S',

712− typdelim = ',',

713− typname = "bpchar"

714− }

715−

716−bpcharOid :: Oid

717−bpcharOid = Oid 1042

718−{-# INLINE bpcharOid #-}

719−

720−varchar :: TypeInfo

721−varchar = Basic {

722− typoid = varcharOid,

723− typcategory = 'S',

724− typdelim = ',',

725− typname = "varchar"

726− }

727−

728−varcharOid :: Oid

729−varcharOid = Oid 1043

730−{-# INLINE varcharOid #-}

731−

732−date :: TypeInfo

733−date = Basic {

734− typoid = dateOid,

735− typcategory = 'D',

736− typdelim = ',',

737− typname = "date"

738− }

739−

740−dateOid :: Oid

741−dateOid = Oid 1082

742−{-# INLINE dateOid #-}

743−

744−time :: TypeInfo

745−time = Basic {

746− typoid = timeOid,

747− typcategory = 'D',

748− typdelim = ',',

749− typname = "time"

750− }

751−

752−timeOid :: Oid

753−timeOid = Oid 1083

754−{-# INLINE timeOid #-}

755−

756−timestamp :: TypeInfo

757−timestamp = Basic {

758− typoid = timestampOid,

759− typcategory = 'D',

760− typdelim = ',',

761− typname = "timestamp"

762− }

763−

764−timestampOid :: Oid

765−timestampOid = Oid 1114

766−{-# INLINE timestampOid #-}

767−

768−timestamptz :: TypeInfo

769−timestamptz = Basic {

770− typoid = timestamptzOid,

771− typcategory = 'D',

772− typdelim = ',',

773− typname = "timestamptz"

774− }

775−

776−timestamptzOid :: Oid

777−timestamptzOid = Oid 1184

778−{-# INLINE timestamptzOid #-}

779−

780−interval :: TypeInfo

781−interval = Basic {

782− typoid = intervalOid,

783− typcategory = 'T',

784− typdelim = ',',

785− typname = "interval"

786− }

787−

788−intervalOid :: Oid

789−intervalOid = Oid 1186

790−{-# INLINE intervalOid #-}

791−

792−timetz :: TypeInfo

793−timetz = Basic {

794− typoid = timetzOid,

795− typcategory = 'D',

796− typdelim = ',',

797− typname = "timetz"

798− }

799−

800−timetzOid :: Oid

801−timetzOid = Oid 1266

802−{-# INLINE timetzOid #-}

803−

804−bit :: TypeInfo

805−bit = Basic {

806− typoid = bitOid,

807− typcategory = 'V',

808− typdelim = ',',

809− typname = "bit"

810− }

811−

812−bitOid :: Oid

813−bitOid = Oid 1560

814−{-# INLINE bitOid #-}

815−

816−varbit :: TypeInfo

817−varbit = Basic {

818− typoid = varbitOid,

819− typcategory = 'V',

820− typdelim = ',',

821− typname = "varbit"

822− }

823−

824−varbitOid :: Oid

825−varbitOid = Oid 1562

826−{-# INLINE varbitOid #-}

827−

828−numeric :: TypeInfo

829−numeric = Basic {

830− typoid = numericOid,

831− typcategory = 'N',

832− typdelim = ',',

833− typname = "numeric"

834− }

835−

836−numericOid :: Oid

837−numericOid = Oid 1700

838−{-# INLINE numericOid #-}

839−

840−refcursor :: TypeInfo

841−refcursor = Basic {

842− typoid = refcursorOid,

843− typcategory = 'U',

844− typdelim = ',',

845− typname = "refcursor"

846− }

847−

848−refcursorOid :: Oid

849−refcursorOid = Oid 1790

850−{-# INLINE refcursorOid #-}

851−

852−record :: TypeInfo

853−record = Basic {

854− typoid = recordOid,

855− typcategory = 'P',

856− typdelim = ',',

857− typname = "record"

858− }

859−

860−recordOid :: Oid

861−recordOid = Oid 2249

862−{-# INLINE recordOid #-}

863−

864−void :: TypeInfo

865−void = Basic {

866− typoid = voidOid,

867− typcategory = 'P',

868− typdelim = ',',

869− typname = "void"

870− }

871−

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−

949−uuid :: TypeInfo

950−uuid = Basic {

951− typoid = uuidOid,

952− typcategory = 'U',

953− typdelim = ',',

954− typname = "uuid"

955− }

956−

957−uuidOid :: Oid

958−uuidOid = Oid 2950

959−{-# INLINE uuidOid #-}

960−

961−json :: TypeInfo

962−json = Basic {

963− typoid = jsonOid,

964− typcategory = 'U',

965− typdelim = ',',

966− typname = "json"

967− }

968−

969−jsonOid :: Oid

970−jsonOid = Oid 114

971−{-# INLINE jsonOid #-}

972−

973−jsonb :: TypeInfo

974−jsonb = Basic {

975− typoid = jsonbOid,

976− typcategory = 'U',

977− typdelim = ',',

978− typname = "jsonb"

979− }

980−

981−jsonbOid :: Oid

982−jsonbOid = Oid 3802

983−{-# INLINE jsonbOid #-}

984−

985−int2vector :: TypeInfo

986−int2vector = Array {

987− typoid = int2vectorOid,

988− typcategory = 'A',

989− typdelim = ',',

990− typname = "int2vector",

991− typelem = int2

992− }

993−

994−int2vectorOid :: Oid

995−int2vectorOid = Oid 22

996−{-# INLINE int2vectorOid #-}

997−

998−oidvector :: TypeInfo

999−oidvector = Array {

1000− typoid = oidvectorOid,

1001− typcategory = 'A',

1002− typdelim = ',',

1003− typname = "oidvector",

1004− typelem = oid

1005− }

1006−

1007−oidvectorOid :: Oid

1008−oidvectorOid = Oid 30

1009−{-# INLINE oidvectorOid #-}

1010−

1011−array_xml :: TypeInfo

1012−array_xml = Array {

1013− typoid = array_xmlOid,

1014− typcategory = 'A',

1015− typdelim = ',',

1016− typname = "_xml",

1017− typelem = xml

1018− }

1019−

1020−array_xmlOid :: Oid

1021−array_xmlOid = Oid 143

1022−{-# INLINE array_xmlOid #-}

1023−

1024−array_json :: TypeInfo

1025−array_json = Array {

1026− typoid = array_jsonOid,

1027− typcategory = 'A',

1028− typdelim = ',',

1029− typname = "_json",

1030− typelem = json

1031− }

1032−

1033−array_jsonOid :: Oid

1034−array_jsonOid = Oid 199

1035−{-# INLINE array_jsonOid #-}

1036−

1037−array_line :: TypeInfo

1038−array_line = Array {

1039− typoid = array_lineOid,

1040− typcategory = 'A',

1041− typdelim = ',',

1042− typname = "_line",

1043− typelem = line

1044− }

1045−

1046−array_lineOid :: Oid

1047−array_lineOid = Oid 629

1048−{-# INLINE array_lineOid #-}

1049−

1050−array_cidr :: TypeInfo

1051−array_cidr = Array {

1052− typoid = array_cidrOid,

1053− typcategory = 'A',

1054− typdelim = ',',

1055− typname = "_cidr",

1056− typelem = cidr

1057− }

1058−

1059−array_cidrOid :: Oid

1060−array_cidrOid = Oid 651

1061−{-# INLINE array_cidrOid #-}

1062−

1063−array_circle :: TypeInfo

1064−array_circle = Array {

1065− typoid = array_circleOid,

1066− typcategory = 'A',

1067− typdelim = ',',

1068− typname = "_circle",

1069− typelem = circle

1070− }

1071−

1072−array_circleOid :: Oid

1073−array_circleOid = Oid 719

1074−{-# INLINE array_circleOid #-}

1075−

1076−array_money :: TypeInfo

1077−array_money = Array {

1078− typoid = array_moneyOid,

1079− typcategory = 'A',

1080− typdelim = ',',

1081− typname = "_money",

1082− typelem = money

1083− }

1084−

1085−array_moneyOid :: Oid

1086−array_moneyOid = Oid 791

1087−{-# INLINE array_moneyOid #-}

1088−

1089−array_bool :: TypeInfo

1090−array_bool = Array {

1091− typoid = array_boolOid,

1092− typcategory = 'A',

1093− typdelim = ',',

1094− typname = "_bool",

1095− typelem = bool

1096− }

1097−

1098−array_boolOid :: Oid

1099−array_boolOid = Oid 1000

1100−{-# INLINE array_boolOid #-}

1101−

1102−array_bytea :: TypeInfo

1103−array_bytea = Array {

1104− typoid = array_byteaOid,

1105− typcategory = 'A',

1106− typdelim = ',',

1107− typname = "_bytea",

1108− typelem = bytea

1109− }

1110−

1111−array_byteaOid :: Oid

1112−array_byteaOid = Oid 1001

1113−{-# INLINE array_byteaOid #-}

1114−

1115−array_char :: TypeInfo

1116−array_char = Array {

1117− typoid = array_charOid,

1118− typcategory = 'A',

1119− typdelim = ',',

1120− typname = "_char",

1121− typelem = char

1122− }

1123−

1124−array_charOid :: Oid

1125−array_charOid = Oid 1002

1126−{-# INLINE array_charOid #-}

1127−

1128−array_name :: TypeInfo

1129−array_name = Array {

1130− typoid = array_nameOid,

1131− typcategory = 'A',

1132− typdelim = ',',

1133− typname = "_name",

1134− typelem = name

1135− }

1136−

1137−array_nameOid :: Oid

1138−array_nameOid = Oid 1003

1139−{-# INLINE array_nameOid #-}

1140−

1141−array_int2 :: TypeInfo

1142−array_int2 = Array {

1143− typoid = array_int2Oid,

1144− typcategory = 'A',

1145− typdelim = ',',

1146− typname = "_int2",

1147− typelem = int2

1148− }

1149−

1150−array_int2Oid :: Oid

1151−array_int2Oid = Oid 1005

1152−{-# INLINE array_int2Oid #-}

1153−

1154−array_int2vector :: TypeInfo

1155−array_int2vector = Array {

1156− typoid = array_int2vectorOid,

1157− typcategory = 'A',

1158− typdelim = ',',

1159− typname = "_int2vector",

1160− typelem = int2vector

1161− }

1162−

1163−array_int2vectorOid :: Oid

1164−array_int2vectorOid = Oid 1006

1165−{-# INLINE array_int2vectorOid #-}

1166−

1167−array_int4 :: TypeInfo

1168−array_int4 = Array {

1169− typoid = array_int4Oid,

1170− typcategory = 'A',

1171− typdelim = ',',

1172− typname = "_int4",

1173− typelem = int4

1174− }

1175−

1176−array_int4Oid :: Oid

1177−array_int4Oid = Oid 1007

1178−{-# INLINE array_int4Oid #-}

1179−

1180−array_regproc :: TypeInfo

1181−array_regproc = Array {

1182− typoid = array_regprocOid,

1183− typcategory = 'A',

1184− typdelim = ',',

1185− typname = "_regproc",

1186− typelem = regproc

1187− }

1188−

1189−array_regprocOid :: Oid

1190−array_regprocOid = Oid 1008

1191−{-# INLINE array_regprocOid #-}

1192−

1193−array_text :: TypeInfo

1194−array_text = Array {

1195− typoid = array_textOid,

1196− typcategory = 'A',

1197− typdelim = ',',

1198− typname = "_text",

1199− typelem = text

1200− }

1201−

1202−array_textOid :: Oid

1203−array_textOid = Oid 1009

1204−{-# INLINE array_textOid #-}

1205−

1206−array_tid :: TypeInfo

1207−array_tid = Array {

1208− typoid = array_tidOid,

1209− typcategory = 'A',

1210− typdelim = ',',

1211− typname = "_tid",

1212− typelem = tid

1213− }

1214−

1215−array_tidOid :: Oid

1216−array_tidOid = Oid 1010

1217−{-# INLINE array_tidOid #-}

1218−

1219−array_xid :: TypeInfo

1220−array_xid = Array {

1221− typoid = array_xidOid,

1222− typcategory = 'A',

1223− typdelim = ',',

1224− typname = "_xid",

1225− typelem = xid

1226− }

1227−

1228−array_xidOid :: Oid

1229−array_xidOid = Oid 1011

1230−{-# INLINE array_xidOid #-}

1231−

1232−array_cid :: TypeInfo

1233−array_cid = Array {

1234− typoid = array_cidOid,

1235− typcategory = 'A',

1236− typdelim = ',',

1237− typname = "_cid",

1238− typelem = cid

1239− }

1240−

1241−array_cidOid :: Oid

1242−array_cidOid = Oid 1012

1243−{-# INLINE array_cidOid #-}

1244−

1245−array_oidvector :: TypeInfo

1246−array_oidvector = Array {

1247− typoid = array_oidvectorOid,

1248− typcategory = 'A',

1249− typdelim = ',',

1250− typname = "_oidvector",

1251− typelem = oidvector

1252− }

1253−

1254−array_oidvectorOid :: Oid

1255−array_oidvectorOid = Oid 1013

1256−{-# INLINE array_oidvectorOid #-}

1257−

1258−array_bpchar :: TypeInfo

1259−array_bpchar = Array {

1260− typoid = array_bpcharOid,

1261− typcategory = 'A',

1262− typdelim = ',',

1263− typname = "_bpchar",

1264− typelem = bpchar

1265− }

1266−

1267−array_bpcharOid :: Oid

1268−array_bpcharOid = Oid 1014

1269−{-# INLINE array_bpcharOid #-}

1270−

1271−array_varchar :: TypeInfo

1272−array_varchar = Array {

1273− typoid = array_varcharOid,

1274− typcategory = 'A',

1275− typdelim = ',',

1276− typname = "_varchar",

1277− typelem = varchar

1278− }

1279−

1280−array_varcharOid :: Oid

1281−array_varcharOid = Oid 1015

1282−{-# INLINE array_varcharOid #-}

1283−

1284−array_int8 :: TypeInfo

1285−array_int8 = Array {

1286− typoid = array_int8Oid,

1287− typcategory = 'A',

1288− typdelim = ',',

1289− typname = "_int8",

1290− typelem = int8

1291− }

1292−

1293−array_int8Oid :: Oid

1294−array_int8Oid = Oid 1016

1295−{-# INLINE array_int8Oid #-}

1296−

1297−array_point :: TypeInfo

1298−array_point = Array {

1299− typoid = array_pointOid,

1300− typcategory = 'A',

1301− typdelim = ',',

1302− typname = "_point",

1303− typelem = point

1304− }

1305−

1306−array_pointOid :: Oid

1307−array_pointOid = Oid 1017

1308−{-# INLINE array_pointOid #-}

1309−

1310−array_lseg :: TypeInfo

1311−array_lseg = Array {

1312− typoid = array_lsegOid,

1313− typcategory = 'A',

1314− typdelim = ',',

1315− typname = "_lseg",

1316− typelem = lseg

1317− }

1318−

1319−array_lsegOid :: Oid

1320−array_lsegOid = Oid 1018

1321−{-# INLINE array_lsegOid #-}

1322−

1323−array_path :: TypeInfo

1324−array_path = Array {

1325− typoid = array_pathOid,

1326− typcategory = 'A',

1327− typdelim = ',',

1328− typname = "_path",

1329− typelem = path

1330− }

1331−

1332−array_pathOid :: Oid

1333−array_pathOid = Oid 1019

1334−{-# INLINE array_pathOid #-}

1335−

1336−array_box :: TypeInfo

1337−array_box = Array {

1338− typoid = array_boxOid,

1339− typcategory = 'A',

1340− typdelim = ';',

1341− typname = "_box",

1342− typelem = box

1343− }

1344−

1345−array_boxOid :: Oid

1346−array_boxOid = Oid 1020

1347−{-# INLINE array_boxOid #-}

1348−

1349−array_float4 :: TypeInfo

1350−array_float4 = Array {

1351− typoid = array_float4Oid,

1352− typcategory = 'A',

1353− typdelim = ',',

1354− typname = "_float4",

1355− typelem = float4

1356− }

1357−

1358−array_float4Oid :: Oid

1359−array_float4Oid = Oid 1021

1360−{-# INLINE array_float4Oid #-}

1361−

1362−array_float8 :: TypeInfo

1363−array_float8 = Array {

1364− typoid = array_float8Oid,

1365− typcategory = 'A',

1366− typdelim = ',',

1367− typname = "_float8",

1368− typelem = float8

1369− }

1370−

1371−array_float8Oid :: Oid

1372−array_float8Oid = Oid 1022

1373−{-# INLINE array_float8Oid #-}

1374−

1375−array_polygon :: TypeInfo

1376−array_polygon = Array {

1377− typoid = array_polygonOid,

1378− typcategory = 'A',

1379− typdelim = ',',

1380− typname = "_polygon",

1381− typelem = polygon

1382− }

1383−

1384−array_polygonOid :: Oid

1385−array_polygonOid = Oid 1027

1386−{-# INLINE array_polygonOid #-}

1387−

1388−array_oid :: TypeInfo

1389−array_oid = Array {

1390− typoid = array_oidOid,

1391− typcategory = 'A',

1392− typdelim = ',',

1393− typname = "_oid",

1394− typelem = oid

1395− }

1396−

1397−array_oidOid :: Oid

1398−array_oidOid = Oid 1028

1399−{-# INLINE array_oidOid #-}

1400−

1401−array_macaddr :: TypeInfo

1402−array_macaddr = Array {

1403− typoid = array_macaddrOid,

1404− typcategory = 'A',

1405− typdelim = ',',

1406− typname = "_macaddr",

1407− typelem = macaddr

1408− }

1409−

1410−array_macaddrOid :: Oid

1411−array_macaddrOid = Oid 1040

1412−{-# INLINE array_macaddrOid #-}

1413−

1414−array_inet :: TypeInfo

1415−array_inet = Array {

1416− typoid = array_inetOid,

1417− typcategory = 'A',

1418− typdelim = ',',

1419− typname = "_inet",

1420− typelem = inet

1421− }

1422−

1423−array_inetOid :: Oid

1424−array_inetOid = Oid 1041

1425−{-# INLINE array_inetOid #-}

1426−

1427−array_timestamp :: TypeInfo

1428−array_timestamp = Array {

1429− typoid = array_timestampOid,

1430− typcategory = 'A',

1431− typdelim = ',',

1432− typname = "_timestamp",

1433− typelem = timestamp

1434− }

1435−

1436−array_timestampOid :: Oid

1437−array_timestampOid = Oid 1115

1438−{-# INLINE array_timestampOid #-}

1439−

1440−array_date :: TypeInfo

1441−array_date = Array {

1442− typoid = array_dateOid,

1443− typcategory = 'A',

1444− typdelim = ',',

1445− typname = "_date",

1446− typelem = date

1447− }

1448−

1449−array_dateOid :: Oid

1450−array_dateOid = Oid 1182

1451−{-# INLINE array_dateOid #-}

1452−

1453−array_time :: TypeInfo

1454−array_time = Array {

1455− typoid = array_timeOid,

1456− typcategory = 'A',

1457− typdelim = ',',

1458− typname = "_time",

1459− typelem = time

1460− }

1461−

1462−array_timeOid :: Oid

1463−array_timeOid = Oid 1183

1464−{-# INLINE array_timeOid #-}

1465−

1466−array_timestamptz :: TypeInfo

1467−array_timestamptz = Array {

1468− typoid = array_timestamptzOid,

1469− typcategory = 'A',

1470− typdelim = ',',

1471− typname = "_timestamptz",

1472− typelem = timestamptz

1473− }

1474−

1475−array_timestamptzOid :: Oid

1476−array_timestamptzOid = Oid 1185

1477−{-# INLINE array_timestamptzOid #-}

1478−

1479−array_interval :: TypeInfo

1480−array_interval = Array {

1481− typoid = array_intervalOid,

1482− typcategory = 'A',

1483− typdelim = ',',

1484− typname = "_interval",

1485− typelem = interval

1486− }

1487−

1488−array_intervalOid :: Oid

1489−array_intervalOid = Oid 1187

1490−{-# INLINE array_intervalOid #-}

1491−

1492−array_numeric :: TypeInfo

1493−array_numeric = Array {

1494− typoid = array_numericOid,

1495− typcategory = 'A',

1496− typdelim = ',',

1497− typname = "_numeric",

1498− typelem = numeric

1499− }

1500−

1501−array_numericOid :: Oid

1502−array_numericOid = Oid 1231

1503−{-# INLINE array_numericOid #-}

1504−

1505−array_timetz :: TypeInfo

1506−array_timetz = Array {

1507− typoid = array_timetzOid,

1508− typcategory = 'A',

1509− typdelim = ',',

1510− typname = "_timetz",

1511− typelem = timetz

1512− }

1513−

1514−array_timetzOid :: Oid

1515−array_timetzOid = Oid 1270

1516−{-# INLINE array_timetzOid #-}

1517−

1518−array_bit :: TypeInfo

1519−array_bit = Array {

1520− typoid = array_bitOid,

1521− typcategory = 'A',

1522− typdelim = ',',

1523− typname = "_bit",

1524− typelem = bit

1525− }

1526−

1527−array_bitOid :: Oid

1528−array_bitOid = Oid 1561

1529−{-# INLINE array_bitOid #-}

1530−

1531−array_varbit :: TypeInfo

1532−array_varbit = Array {

1533− typoid = array_varbitOid,

1534− typcategory = 'A',

1535− typdelim = ',',

1536− typname = "_varbit",

1537− typelem = varbit

1538− }

1539−

1540−array_varbitOid :: Oid

1541−array_varbitOid = Oid 1563

1542−{-# INLINE array_varbitOid #-}

1543−

1544−array_refcursor :: TypeInfo

1545−array_refcursor = Array {

1546− typoid = array_refcursorOid,

1547− typcategory = 'A',

1548− typdelim = ',',

1549− typname = "_refcursor",

1550− typelem = refcursor

1551− }

1552−

1553−array_refcursorOid :: Oid

1554−array_refcursorOid = Oid 2201

1555−{-# INLINE array_refcursorOid #-}

1556−

1557−array_regprocedure :: TypeInfo

1558−array_regprocedure = Array {

1559− typoid = array_regprocedureOid,

1560− typcategory = 'A',

1561− typdelim = ',',

1562− typname = "_regprocedure",

1563− typelem = regprocedure

1564− }

1565−

1566−array_regprocedureOid :: Oid

1567−array_regprocedureOid = Oid 2207

1568−{-# INLINE array_regprocedureOid #-}

1569−

1570−array_regoper :: TypeInfo

1571−array_regoper = Array {

1572− typoid = array_regoperOid,

1573− typcategory = 'A',

1574− typdelim = ',',

1575− typname = "_regoper",

1576− typelem = regoper

1577− }

1578−

1579−array_regoperOid :: Oid

1580−array_regoperOid = Oid 2208

1581−{-# INLINE array_regoperOid #-}

1582−

1583−array_regoperator :: TypeInfo

1584−array_regoperator = Array {

1585− typoid = array_regoperatorOid,

1586− typcategory = 'A',

1587− typdelim = ',',

1588− typname = "_regoperator",

1589− typelem = regoperator

1590− }

1591−

1592−array_regoperatorOid :: Oid

1593−array_regoperatorOid = Oid 2209

1594−{-# INLINE array_regoperatorOid #-}

1595−

1596−array_regclass :: TypeInfo

1597−array_regclass = Array {

1598− typoid = array_regclassOid,

1599− typcategory = 'A',

1600− typdelim = ',',

1601− typname = "_regclass",

1602− typelem = regclass

1603− }

1604−

1605−array_regclassOid :: Oid

1606−array_regclassOid = Oid 2210

1607−{-# INLINE array_regclassOid #-}

1608−

1609−array_regtype :: TypeInfo

1610−array_regtype = Array {

1611− typoid = array_regtypeOid,

1612− typcategory = 'A',

1613− typdelim = ',',

1614− typname = "_regtype",

1615− typelem = regtype

1616− }

1617−

1618−array_regtypeOid :: Oid

1619−array_regtypeOid = Oid 2211

1620−{-# INLINE array_regtypeOid #-}

1621−

1622−array_uuid :: TypeInfo

1623−array_uuid = Array {

1624− typoid = array_uuidOid,

1625− typcategory = 'A',

1626− typdelim = ',',

1627− typname = "_uuid",

1628− typelem = uuid

1629− }

1630−

1631−array_uuidOid :: Oid

1632−array_uuidOid = Oid 2951

1633−{-# INLINE array_uuidOid #-}

1634−

1635−array_jsonb :: TypeInfo

1636−array_jsonb = Array {

1637− typoid = array_jsonbOid,

1638− typcategory = 'A',

1639− typdelim = ',',

1640− typname = "_jsonb",

1641− typelem = jsonb

1642− }

1643−

1644−array_jsonbOid :: Oid

1645−array_jsonbOid = Oid 3807

1646−{-# INLINE array_jsonbOid #-}

1647−

1648−int4range :: TypeInfo

1649−int4range = Range {

1650− typoid = int4rangeOid,

1651− typcategory = 'R',

1652− typdelim = ',',

1653− typname = "int4range",

1654− rngsubtype = int4

1655− }

1656−

1657−int4rangeOid :: Oid

1658−int4rangeOid = Oid 3904

1659−{-# INLINE int4rangeOid #-}

1660−

1661−_int4range :: TypeInfo

1662−_int4range = Array {

1663− typoid = _int4rangeOid,

1664− typcategory = 'A',

1665− typdelim = ',',

1666− typname = "_int4range",

1667− typelem = int4range

1668− }

1669−

1670−_int4rangeOid :: Oid

1671−_int4rangeOid = Oid 3905

1672−{-# INLINE _int4rangeOid #-}

1673−

1674−numrange :: TypeInfo

1675−numrange = Range {

1676− typoid = numrangeOid,

1677− typcategory = 'R',

1678− typdelim = ',',

1679− typname = "numrange",

1680− rngsubtype = numeric

1681− }

1682−

1683−numrangeOid :: Oid

1684−numrangeOid = Oid 3906

1685−{-# INLINE numrangeOid #-}

1686−

1687−_numrange :: TypeInfo

1688−_numrange = Array {

1689− typoid = _numrangeOid,

1690− typcategory = 'A',

1691− typdelim = ',',

1692− typname = "_numrange",

1693− typelem = numrange

1694− }

1695−

1696−_numrangeOid :: Oid

1697−_numrangeOid = Oid 3907

1698−{-# INLINE _numrangeOid #-}

1699−

1700−tsrange :: TypeInfo

1701−tsrange = Range {

1702− typoid = tsrangeOid,

1703− typcategory = 'R',

1704− typdelim = ',',

1705− typname = "tsrange",

1706− rngsubtype = timestamp

1707− }

1708−

1709−tsrangeOid :: Oid

1710−tsrangeOid = Oid 3908

1711−{-# INLINE tsrangeOid #-}

1712−

1713−_tsrange :: TypeInfo

1714−_tsrange = Array {

1715− typoid = _tsrangeOid,

1716− typcategory = 'A',

1717− typdelim = ',',

1718− typname = "_tsrange",

1719− typelem = tsrange

1720− }

1721−

1722−_tsrangeOid :: Oid

1723−_tsrangeOid = Oid 3909

1724−{-# INLINE _tsrangeOid #-}

1725−

1726−tstzrange :: TypeInfo

1727−tstzrange = Range {

1728− typoid = tstzrangeOid,

1729− typcategory = 'R',

1730− typdelim = ',',

1731− typname = "tstzrange",

1732− rngsubtype = timestamptz

1733− }

1734−

1735−tstzrangeOid :: Oid

1736−tstzrangeOid = Oid 3910

1737−{-# INLINE tstzrangeOid #-}

1738−

1739−_tstzrange :: TypeInfo

1740−_tstzrange = Array {

1741− typoid = _tstzrangeOid,

1742− typcategory = 'A',

1743− typdelim = ',',

1744− typname = "_tstzrange",

1745− typelem = tstzrange

1746− }

1747−

1748−_tstzrangeOid :: Oid

1749−_tstzrangeOid = Oid 3911

1750−{-# INLINE _tstzrangeOid #-}

1751−

1752−daterange :: TypeInfo

1753−daterange = Range {

1754− typoid = daterangeOid,

1755− typcategory = 'R',

1756− typdelim = ',',

1757− typname = "daterange",

1758− rngsubtype = date

1759− }

1760−

1761−daterangeOid :: Oid

1762−daterangeOid = Oid 3912

1763−{-# INLINE daterangeOid #-}

1764−

1765−_daterange :: TypeInfo

1766−_daterange = Array {

1767− typoid = _daterangeOid,

1768− typcategory = 'A',

1769− typdelim = ',',

1770− typname = "_daterange",

1771− typelem = daterange

1772− }

1773−

1774−_daterangeOid :: Oid

1775−_daterangeOid = Oid 3913

1776−{-# INLINE _daterangeOid #-}

1777−

1778−int8range :: TypeInfo

1779−int8range = Range {

1780− typoid = int8rangeOid,

1781− typcategory = 'R',

1782− typdelim = ',',

1783− typname = "int8range",

1784− rngsubtype = int8

1785− }

1786−

1787−int8rangeOid :: Oid

1788−int8rangeOid = Oid 3926

1789−{-# INLINE int8rangeOid #-}

1790−

1791−_int8range :: TypeInfo

1792−_int8range = Array {

1793− typoid = _int8rangeOid,

1794− typcategory = 'A',

1795− typdelim = ',',

1796− typname = "_int8range",

1797− typelem = int8range

1798− }

1799−

1800−_int8rangeOid :: Oid

1801−_int8rangeOid = Oid 3927

1802−{-# INLINE _int8rangeOid #-}

src/Database/PostgreSQL/Simple/TypeInfo/Types.hsdeleted−56

@@ -1,56 +0,0 @@

1−------------------------------------------------------------------------------

2−-- |

3−-- Module: Database.PostgreSQL.Simple.TypeInfo.Types

5−-- License: BSD3

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

7−-- Stability: experimental

8−--

9−------------------------------------------------------------------------------

10−

11−module Database.PostgreSQL.Simple.TypeInfo.Types where

12−

13−import Data.ByteString(ByteString)

14−import Database.PostgreSQL.LibPQ(Oid)

15−import Data.Vector(Vector)

16−

17−-- | A structure representing some of the metadata regarding a PostgreSQL

18−-- type, mostly taken from the @pg_type@ table.

19−

20−data TypeInfo

21−

22− = Basic { typoid :: {-# UNPACK #-} !Oid

23− , typcategory :: {-# UNPACK #-} !Char

24− , typdelim :: {-# UNPACK #-} !Char

25− , typname :: !ByteString

26− }

27−

28− | Array { typoid :: {-# UNPACK #-} !Oid

29− , typcategory :: {-# UNPACK #-} !Char

30− , typdelim :: {-# UNPACK #-} !Char

31− , typname :: !ByteString

32− , typelem :: !TypeInfo

33− }

34−

35− | Range { typoid :: {-# UNPACK #-} !Oid

36− , typcategory :: {-# UNPACK #-} !Char

37− , typdelim :: {-# UNPACK #-} !Char

38− , typname :: !ByteString

39− , rngsubtype :: !TypeInfo

40− }

41−

42− | Composite { typoid :: {-# UNPACK #-} !Oid

43− , typcategory :: {-# UNPACK #-} !Char

44− , typdelim :: {-# UNPACK #-} !Char

45− , typname :: !ByteString

46− , typrelid :: {-# UNPACK #-} !Oid

47− , attributes :: !(Vector Attribute)

48− }

49−

50− deriving (Show)

51−

52−data Attribute

53− = Attribute { attname :: !ByteString

54− , atttype :: !TypeInfo

55− }

56− deriving (Show)

src/Database/PostgreSQL/Simple/Types.hs+34−160

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

1−{-# LANGUAGE CPP, DeriveDataTypeable, DeriveFunctor, GeneralizedNewtypeDeriving #-}

1+{-# LANGUAGE DeriveDataTypeable, DeriveFunctor, GeneralizedNewtypeDeriving #-}

3------------------------------------------------------------------------------

4-- |

@@ -8,6 +8,7 @@

8-- License: BSD3

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

10-- Stability: experimental

11+-- Portability: portable

11--

12--

12-- Basic types.

13-- Basic types.

13--

14--

@@ -16,43 +17,31 @@

16module Database.PostgreSQL.Simple.Types

17module Database.PostgreSQL.Simple.Types

17 (

18 (

18 Null(..)

19 Null(..)

19− , Default(..)

20 , Only(..)

21 , In(..)

22 , Binary(..)

23− , Identifier(..)

24− , QualifiedIdentifier(..)

25 , Query(..)

23 , Query(..)

26 , Oid(..)

24 , Oid(..)

27 , (:.)(..)

25 , (:.)(..)

28− , Savepoint(..)

29− , PGArray(..)

30− , Values(..)

31 ) where

26 ) where

28+import Blaze.ByteString.Builder (toByteString)

33−import Control.Arrow (first)

29+import Control.Arrow (first)

34−import Data.ByteString (ByteString)

30+import Data.ByteString (ByteString)

35−import Data.Hashable (Hashable(hashWithSalt))

36−import Data.Foldable (toList)

37−import Data.Monoid (Monoid(..))

31+import Data.Monoid (Monoid(..))

38−import Data.Semigroup

39−import Data.String (IsString(..))

32+import Data.String (IsString(..))

40−import Data.Typeable (Typeable)

33+import Data.Typeable (Typeable)

41−import Data.ByteString.Builder ( stringUtf8 )

34+import qualified Blaze.ByteString.Builder.Char.Utf8 as Utf8

42import qualified Data.ByteString as B

35import qualified Data.ByteString as B

43−import Data.Text (Text)

44−import qualified Data.Text as T

45−import Data.Tuple.Only (Only(..))

46−import Database.PostgreSQL.LibPQ (Oid(..))

36+import Database.PostgreSQL.LibPQ (Oid(..))

47−import Database.PostgreSQL.Simple.Compat (toByteString)

49-- | A placeholder for the SQL @NULL@ value.

38-- | A placeholder for the SQL @NULL@ value.

50data Null = Null

39data Null = Null

51 deriving (Read, Show, Typeable)

40 deriving (Read, Show, Typeable)

53−-- | A placeholder for the PostgreSQL @DEFAULT@ value.

42+instance Eq Null where

54−data Default = Default

43+ _ == _ = False

55− deriving (Read, Show, Typeable)

44+ _ /= _ = False

57-- | A query string. This type is intended to make it difficult to

46-- | A query string. This type is intended to make it difficult to

58-- construct a SQL query by concatenating string fragments, as that is

47-- construct a SQL query by concatenating string fragments, as that is

@@ -84,98 +73,42 @@ instance Read Query where

84 readsPrec i = fmap (first Query) . readsPrec i

73 readsPrec i = fmap (first Query) . readsPrec i

86instance IsString Query where

75instance IsString Query where

87− fromString = Query . toByteString . stringUtf8

76+ fromString = Query . toByteString . Utf8.fromString

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)

94instance Monoid Query where

78instance Monoid Query where

95 mempty = Query B.empty

79 mempty = Query B.empty

80+ mappend (Query a) (Query b) = Query (B.append a b)

81+ {-# INLINE mappend #-}

97−-- | Wrap a list of values for use in an @IN@ clause. Replaces a

83+-- | A single-value \"collection\".

98−-- single \"@?@\" character with a parenthesized list of rendered

99−-- values.

100−--

101−-- Example:

102−--

103−-- > query c "select * from whatever where id in ?" (Only (In [3,4,5]))

104−--

105−-- Note that @In []@ expands to @(null)@, which works as expected in

106−-- the query above, but evaluates to the logical null value on every

107−-- row instead of @TRUE@. This means that changing the query above

108−-- to @... id NOT in ?@ and supplying the empty list as the parameter

109−-- returns zero rows, instead of all of them as one would expect.

110−--

111−-- Since postgresql doesn't seem to provide a syntax for actually specifying

112−-- an empty list, which could solve this completely, there are two

113−-- workarounds particularly worth mentioning, namely:

114--

84--

115−-- 1. Use postgresql-simple's 'Values' type instead, which can handle the

85+-- This is useful if you need to supply a single parameter to a SQL

116−-- empty case correctly. Note however that while specifying the

86+-- query, or extract a single column from a SQL result.

117−-- postgresql type @"int4"@ is mandatory in the empty case, specifying

118−-- the haskell type @Values (Only Int)@ would not normally be needed in

119−-- realistic use cases.

120--

87--

121−-- > query c "select * from whatever where id not in ?"

88+-- Parameter example:

122−-- > (Only (Values ["int4"] [] :: Values (Only Int)))

123--

89--

90+-- @query c \"select x from scores where x > ?\" ('Only' (42::Int))@

124--

91--

125−-- 2. Use sql's @COALESCE@ operator to turn a logical @null@ into the correct

92+-- Result example:

126−-- boolean. Note however that the correct boolean depends on the use

127−-- case:

128--

93--

129−-- > query c "select * from whatever where coalesce(id NOT in ?, TRUE)"

94+-- @xs <- query_ c \"select id from users\"

130−-- > (Only (In [] :: In [Int]))

95+--forM_ xs $ \\('Only' id) -> {- ... -}@

96+newtype Only a = Only {

97+ fromOnly :: a

98+ } deriving (Eq, Ord, Read, Show, Typeable, Functor)

99+

100+-- | Wrap a list of values for use in an @IN@ clause. Replaces a

101+-- single \"@?@\" character with a parenthesized list of rendered

102+-- values.

131--

103--

132−-- > query c "select * from whatever where coalesce(id IN ?, FALSE)"

104+-- Example:

133−-- > (Only (In [] :: In [Int]))

134--

105--

135−-- Note that at as of PostgreSQL 9.4, the query planner cannot see inside

106+-- > query c "select * from whatever where id in ?" (In [3,4,5])

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−

142newtype In a = In a

107newtype In a = In a

143 deriving (Eq, Ord, Read, Show, Typeable, Functor)

108 deriving (Eq, Ord, Read, Show, Typeable, Functor)

144

109

145-- | Wrap binary data for use as a @bytea@ value.

110-- | Wrap binary data for use as a @bytea@ value.

146−newtype Binary a = Binary {fromBinary :: a}

111+newtype Binary a = Binary a

147− deriving (Eq, Ord, Read, Show, Typeable, Functor)

148−

149−-- | Wrap text for use as sql identifier, i.e. a table or column name.

150−newtype Identifier = Identifier {fromIdentifier :: Text}

151− deriving (Eq, Ord, Read, Show, Typeable, IsString)

152−

153−instance Hashable Identifier where

154− hashWithSalt i (Identifier t) = hashWithSalt i t

155−

156−-- | Wrap text for use as (maybe) qualified identifier, i.e. a table

157−-- with schema, or column with table.

158−data QualifiedIdentifier = QualifiedIdentifier (Maybe Text) Text

159− deriving (Eq, Ord, Read, Show, Typeable)

160−

161−instance Hashable QualifiedIdentifier where

162− hashWithSalt i (QualifiedIdentifier q t) = hashWithSalt i (q, t)

163−

164−-- | @\"foo.bar\"@ will get turned into

165−-- @QualifiedIdentifier (Just \"foo\") \"bar\"@, while @\"foo\"@ will get

166−-- turned into @QualifiedIdentifier Nothing \"foo\"@. Note this instance

167−-- is for convenience, and does not match postgres syntax. It

168−-- only examines the first period character, and thus cannot be used if the

169−-- qualifying identifier contains a period for example.

170−

171−instance IsString QualifiedIdentifier where

172− fromString str = let (x,y) = T.break (== '.') (fromString str)

173− in if T.null y

174− then QualifiedIdentifier Nothing x

175− else QualifiedIdentifier (Just x) (T.tail y)

176−

177−-- | Wrap a list for use as a PostgreSQL array.

178−newtype PGArray a = PGArray {fromPGArray :: [a]}

179 deriving (Eq, Ord, Read, Show, Typeable, Functor)

112 deriving (Eq, Ord, Read, Show, Typeable, Functor)

180

113

181-- | A composite type to parse your custom data structures without

114-- | A composite type to parse your custom data structures without

@@ -197,62 +130,3 @@ newtype PGArray a = PGArray {fromPGArray :: [a]}

197data h :. t = h :. t deriving (Eq,Ord,Show,Read,Typeable)

130data h :. t = h :. t deriving (Eq,Ord,Show,Read,Typeable)

198

131

199infixr 3 :.

132infixr 3 :.

200−

201−newtype Savepoint = Savepoint Query

202− deriving (Eq, Ord, Show, Read, Typeable)

203−

204−-- | Represents a @VALUES@ table literal, usable as an alternative to

205−-- 'Database.PostgreSQL.Simple.executeMany' and

206−-- 'Database.PostgreSQL.Simple.returning'. The main advantage is that

207−-- you can parametrize more than just a single @VALUES@ expression.

208−-- For example, here's a query to insert a thing into one table

209−-- and some attributes of that thing into another, returning the

210−-- new id generated by the database:

211−--

212−--

213−-- > query c [sql|

214−-- > WITH new_thing AS (

215−-- > INSERT INTO thing (name) VALUES (?) RETURNING id

216−-- > ), new_attributes AS (

217−-- > INSERT INTO thing_attributes

218−-- > SELECT new_thing.id, attrs.*

219−-- > FROM new_thing JOIN ? attrs ON TRUE

220−-- > ) SELECT * FROM new_thing

221−-- > |] ("foo", Values [ "int4", "text" ]

222−-- > [ ( 1 , "hello" )

223−-- > , ( 2 , "world" ) ])

224−--

225−-- (Note this example uses writable common table expressions,

226−-- which were added in PostgreSQL 9.1)

227−--

228−-- The second parameter gets expanded into the following SQL syntax:

229−--

230−-- > (VALUES (1::"int4",'hello'::"text"),(2,'world'))

231−--

232−-- When the list of attributes is empty, the second parameter expands to:

233−--

234−-- > (VALUES (null::"int4",null::"text") LIMIT 0)

235−--

236−-- By contrast, @executeMany@ and @returning@ don't issue the query

237−-- in the empty case, and simply return @0@ and @[]@ respectively.

238−-- This behavior is usually correct given their intended use cases,

239−-- but would certainly be wrong in the example above.

240−--

241−-- The first argument is a list of postgresql type names. Because this

242−-- is turned into a properly quoted identifier, the type name is case

243−-- sensitive and must be as it appears in the @pg_type@ table. Thus,

244−-- you must write @timestamptz@ instead of @timestamp with time zone@,

245−-- @int4@ instead of @integer@ or @serial@, @_int8@ instead of @bigint[]@,

246−-- etcetera.

247−--

248−-- You may omit the type names, however, if you do so the list

249−-- of values must be non-empty, and postgresql must be able to infer

250−-- the types of the columns from the surrounding context. If the first

251−-- condition is not met, postgresql-simple will throw an exception

252−-- without issuing the query. In the second case, the postgres server

253−-- will return an error which will be turned into a @SqlError@ exception.

254−--

255−-- See <https://www.postgresql.org/docs/9.5/static/sql-values.html> for

256−-- more information.

257−data Values a = Values [QualifiedIdentifier] [a]

258− deriving (Eq, Ord, Show, Read, Typeable)

src/Database/PostgreSQL/Simple/Vector.hsdeleted−45

@@ -1,45 +0,0 @@

1−-- | 'query' variants returning 'V.Vector'.

2−module Database.PostgreSQL.Simple.Vector where

3−

4−import Database.PostgreSQL.Simple (Connection, formatQuery, formatMany)

5−import Database.PostgreSQL.Simple.FromRow (FromRow(..))

6−import Database.PostgreSQL.Simple.ToRow (ToRow(..))

7−import Database.PostgreSQL.Simple.Internal (RowParser, exec)

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

9−import Database.PostgreSQL.Simple.Types ( Query (..) )

10−

11−import qualified Data.Vector as V

12−

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

14−-- results. All results are retrieved and converted before this

15−-- function returns.

16−query :: (ToRow q, FromRow r) => Connection -> Query -> q -> IO (V.Vector r)

17−query = queryWith fromRow

18−

19−-- | A version of 'query' that does not perform query substitution.

20−query_ :: (FromRow r) => Connection -> Query -> IO (V.Vector r)

21−query_ = queryWith_ fromRow

22−

23−-- | A version of 'query' taking parser as argument

24−queryWith :: ToRow q => RowParser r -> Connection -> Query -> q -> IO (V.Vector r)

25−queryWith parser conn template qs = do

26− result <- exec conn =<< formatQuery conn template qs

27− finishQueryWithV parser conn template result

28−

29−-- | A version of 'query_' taking parser as argument

30−queryWith_ :: RowParser r -> Connection -> Query -> IO (V.Vector r)

31−queryWith_ parser conn q@(Query que) = do

32− result <- exec conn que

33− finishQueryWithV parser conn q result

34−

35−-- | Execute @INSERT ... RETURNING@, @UPDATE ... RETURNING@, or other SQL

36−-- query that accepts multi-row input and is expected to return results.

37−returning :: (ToRow q, FromRow r) => Connection -> Query -> [q] -> IO (V.Vector r)

38−returning = returningWith fromRow

39−

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

41−returningWith :: (ToRow q) => RowParser r -> Connection -> Query -> [q] -> IO (V.Vector r)

42−returningWith _ _ _ [] = return V.empty

43−returningWith parser conn q qs = do

44− result <- exec conn =<< formatMany conn q qs

45− finishQueryWithV parser conn q result

src/Database/PostgreSQL/Simple/Vector/Unboxed.hsdeleted−44

@@ -1,44 +0,0 @@

1−module Database.PostgreSQL.Simple.Vector.Unboxed where

2−

3−import Database.PostgreSQL.Simple (Connection, formatQuery, formatMany)

4−import Database.PostgreSQL.Simple.FromRow (FromRow(..))

5−import Database.PostgreSQL.Simple.ToRow (ToRow(..))

6−import Database.PostgreSQL.Simple.Internal (RowParser, exec)

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

8−import Database.PostgreSQL.Simple.Types ( Query (..) )

9−

10−import qualified Data.Vector.Unboxed as VU

11−

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

13−-- results. All results are retrieved and converted before this

14−-- function returns.

15−query :: (ToRow q, FromRow r, VU.Unbox r) => Connection -> Query -> q -> IO (VU.Vector r)

16−query = queryWith fromRow

17−

18−-- | A version of 'query' that does not perform query substitution.

19−query_ :: (FromRow r, VU.Unbox r) => Connection -> Query -> IO (VU.Vector r)

20−query_ = queryWith_ fromRow

21−

22−-- | A version of 'query' taking parser as argument

23−queryWith :: (ToRow q, VU.Unbox r) => RowParser r -> Connection -> Query -> q -> IO (VU.Vector r)

24−queryWith parser conn template qs = do

25− result <- exec conn =<< formatQuery conn template qs

26− finishQueryWithVU parser conn template result

27−

28−-- | A version of 'query_' taking parser as argument

29−queryWith_ :: VU.Unbox r => RowParser r -> Connection -> Query -> IO (VU.Vector r)

30−queryWith_ parser conn q@(Query que) = do

31− result <- exec conn que

32− finishQueryWithVU parser conn q result

33−

34−-- | Execute @INSERT ... RETURNING@, @UPDATE ... RETURNING@, or other SQL

35−-- query that accepts multi-row input and is expected to return results.

36−returning :: (ToRow q, FromRow r, VU.Unbox r) => Connection -> Query -> [q] -> IO (VU.Vector r)

37−returning = returningWith fromRow

38−

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

40−returningWith :: (ToRow q, VU.Unbox r) => RowParser r -> Connection -> Query -> [q] -> IO (VU.Vector r)

41−returningWith _ _ _ [] = return VU.empty

42−returningWith parser conn q qs = do

43− result <- exec conn =<< formatMany conn q qs

44− finishQueryWithVU parser conn q result

test/Bytea.hsnew file+25

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

1+module Bytea (testBytea) where

3+import Common

4+import qualified Data.ByteString as B

6+testBytea :: TestEnv -> Test

7+testBytea TestEnv{..} = TestList

8+ [ testStr "empty" []

9+ , testStr "\"hello\"" $ map (fromIntegral . fromEnum) ("hello" :: String)

10+ , testStr "ascending" [0..255]

11+ , testStr "descending" [255,254..0]

12+ , testStr "ascending, doubled up" $ doubleUp [0..255]

13+ , testStr "descending, doubled up" $ doubleUp [255,254..0]

14+ ]

15+ where

16+ testStr label bytes = TestLabel label $ TestCase $ do

17+ let bs = B.pack bytes

18+

19+ [Only h] <- query conn "SELECT md5(?::bytea)" [Binary bs]

20+ assertBool "Haskell -> SQL conversion altered the string" $ md5 bs == h

21+

22+ [Only (Binary r)] <- query conn "SELECT ?::bytea" [Binary bs]

23+ assertBool "SQL -> Haskell conversion altered the string" $ bs == r

24+

25+ doubleUp = concatMap (\x -> [x, x])

test/Common.hs+2−2

@@ -1,6 +1,6 @@

1module Common (

2 module Database.PostgreSQL.Simple,

3− module Test.Tasty.HUnit,

3+ module Test.HUnit,

4 TestEnv(..),

5 md5,

6) where

@@ -8,7 +8,7 @@ module Common (

8import Data.ByteString (ByteString)

9import Data.Text (Text)

10import Database.PostgreSQL.Simple

11−import Test.Tasty.HUnit

11+import Test.HUnit

13import qualified Crypto.Hash.MD5 as MD5

14import 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/ExecuteMany.hsnew file+23

@@ -0,0 +1,23 @@

1+module ExecuteMany (testExecuteMany) where

3+import Common

5+import Data.ByteString (ByteString)

7+testExecuteMany :: TestEnv -> Test

8+testExecuteMany TestEnv{..} = TestCase $ do

9+ execute_ conn "CREATE TEMPORARY TABLE tmp_executeMany (i INT, t TEXT, b BYTEA)"

10+

11+ let rows :: [(Int, String, Binary ByteString)]

12+ rows = [ (1, "hello", Binary "bye")

13+ , (2, "world", Binary "\0\r\t\n")

14+ , (3, "?", Binary "")

15+ ]

16+

17+ count <- executeMany conn "INSERT INTO tmp_executeMany VALUES (?, ?, ?)" rows

18+ assertEqual "count" (fromIntegral $ length rows) count

19+

20+ rows' <- query_ conn "SELECT * FROM tmp_executeMany"

21+ assertEqual "rows" rows rows'

22+

23+ return ()

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+24−628

@@ -1,648 +1,44 @@

1−{-# LANGUAGE CPP #-}

2−{-# LANGUAGE DeriveGeneric #-}

3−{-# LANGUAGE DeriveDataTypeable #-}

4−{-# LANGUAGE DoAndIfThenElse #-}

5−{-# LANGUAGE ScopedTypeVariables #-}

6−#if __GLASGOW_HASKELL__ >= 806

7−{-# LANGUAGE DerivingStrategies #-}

8−{-# LANGUAGE DerivingVia #-}

9−{-# LANGUAGE DeriveAnyClass #-}

10−#endif

11−module Main (main) where

12−

13import Common

1import Common

14−import Database.PostgreSQL.Simple.Copy

15−import Database.PostgreSQL.Simple.ToField (ToField)

16−import Database.PostgreSQL.Simple.FromField (FromField)

17−import Database.PostgreSQL.Simple.HStore

18−import Database.PostgreSQL.Simple.Newtypes

19−import Database.PostgreSQL.Simple.Internal (breakOnSingleQuestionMark)

20−import Database.PostgreSQL.Simple.Types(Query(..),Values(..), PGArray(..))

21−import qualified Database.PostgreSQL.Simple.Transaction as ST

22−

23−import Control.Applicative

24−import Control.Exception as E

2+import Control.Exception (bracket)

25−import Control.Monad

3+import Control.Monad (when)

26−import Data.Char

4+import System.Exit (exitFailure)

27−import Data.Foldable (toList)

28−import Data.List (concat, sort)

29−import Data.IORef

30−import Data.Monoid ((<>))

31−import Data.String (fromString)

32−import Data.Typeable

33−import GHC.Generics (Generic)

34−

35−import Data.Aeson

36−import Data.ByteString (ByteString)

37−import qualified Data.ByteString as B

38−import qualified Data.ByteString.Char8 as BS8

39−import qualified Data.ByteString.Lazy.Char8 as BL

40−import Data.CaseInsensitive (CI)

41−import qualified Data.CaseInsensitive as CI

42−import Data.Map (Map)

43−import qualified Data.Map as Map

44−import Data.Text(Text)

45−import qualified Data.Text.Encoding as T

46−import qualified Data.Vector as V

47−import System.FilePath

48−import System.Timeout(timeout)

49−import Data.Time.Compat (getCurrentTime, diffUTCTime)

50−import System.Environment (getEnvironment)

5+import System.IO

52−import Test.Tasty

7+import Bytea

53−import Test.Tasty.Golden

8+import ExecuteMany

54import Notify

9import Notify

55import Serializable

10import Serializable

56import Time

11import 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

89− ]

90−

91−testBytea :: TestEnv -> TestTree

92−testBytea TestEnv{..} = testGroup "Bytea"

93− [ testStr "empty" []

94− , testStr "\"hello\"" $ map (fromIntegral . fromEnum) ("hello" :: String)

95− , testStr "ascending" [0..255]

96− , testStr "descending" [255,254..0]

97− , testStr "ascending, doubled up" $ doubleUp [0..255]

98− , testStr "descending, doubled up" $ doubleUp [255,254..0]

99− ]

100− where

101− testStr label bytes = testCase label $ do

102− let bs = B.pack bytes

103−

104− [Only h] <- query conn "SELECT md5(?::bytea)" [Binary bs]

105− assertBool "Haskell -> SQL conversion altered the string" $ md5 bs == h

106−

107− [Only (Binary r)] <- query conn "SELECT ?::bytea" [Binary bs]

108− assertBool "SQL -> Haskell conversion altered the string" $ bs == r

109−

110− doubleUp = concatMap (\x -> [x, x])

111−

112−testExecuteMany :: TestEnv -> Assertion

113−testExecuteMany TestEnv{..} = do

114− execute_ conn "CREATE TEMPORARY TABLE tmp_executeMany (i INT, t TEXT, b BYTEA)"

115−

116− let rows :: [(Int, String, Binary ByteString)]

117− rows = [ (1, "hello", Binary "bye")

118− , (2, "world", Binary "\0\r\t\n")

119− , (3, "?", Binary "")

120− ]

121−

122− count <- executeMany conn "INSERT INTO tmp_executeMany VALUES (?, ?, ?)" rows

123− count @?= fromIntegral (length rows)

124−

125− rows' <- query_ conn "SELECT * FROM tmp_executeMany"

126− rows' @?= rows

127−

128− return ()

129−

130−testFold :: TestEnv -> Assertion

131−testFold TestEnv{..} = do

132− xs <- fold_ conn "SELECT generate_series(1,10000)"

133− [] $ \xs (Only x) -> return (x:xs)

134− reverse xs @?= ([1..10000] :: [Int])

135−

136− ref <- newIORef []

137− forEach conn "SELECT * FROM generate_series(1,?) a, generate_series(1,?) b"

138− (100 :: Int, 50 :: Int) $ \(a :: Int, b :: Int) -> do

139− xs <- readIORef ref

140− writeIORef ref $! (a,b):xs

141− xs <- readIORef ref

142− reverse xs @?= [(a,b) | b <- [1..50], a <- [1..100]]

143−

144− -- Make sure fold propagates our exception.

145− ref <- newIORef []

146− True <- expectError (== TestException) $

147− forEach_ conn "SELECT generate_series(1,10)" $ \(Only a) ->

148− if a == 5 then do

149− -- Cause a SQL error to trip up CLOSE.

150− True <- expectError isSyntaxError $

151− execute_ conn "asdf"

152− True <- expectError ST.isFailedTransactionError $

153− (query_ conn "SELECT 1" :: IO [(Only Int)])

154− throwIO TestException

155− else do

156− xs <- readIORef ref

157− writeIORef ref $! (a :: Int) : xs

158− xs <- readIORef ref

159− reverse xs @?= [1..4]

160−

161− withTransaction conn $ replicateM_ 2 $ do

162− xs <- fold_ conn "VALUES (1), (2), (3), (4), (5)"

163− [] $ \xs (Only x) -> return (x:xs)

164− reverse xs @?= ([1..5] :: [Int])

165−

166− ref <- newIORef []

167− forEach_ conn "SELECT generate_series(1,101)" $ \(Only a) ->

168− forEach_ conn "SELECT generate_series(1,55)" $ \(Only b) -> do

169− xs <- readIORef ref

170− writeIORef ref $! (a :: Int, b :: Int) : xs

171− xs <- readIORef ref

172− reverse xs @?= [(a,b) | a <- [1..101], b <- [1..55]]

173−

174− xs <- fold_ conn "SELECT 1 WHERE FALSE"

175− [] $ \xs (Only x) -> return (x:xs)

176− xs @?= ([] :: [Int])

177−

178− -- TODO: add more complete tests, e.g.:

179− --

180− -- * Fold in a transaction

181− --

182− -- * Fold in a transaction after a previous fold has been performed

183− --

184− -- * Nested fold

185−

186− return ()

187−

188−queryFailure :: forall a. (FromField a, Typeable a, Show a)

189− => Connection -> Query -> a -> Assertion

190−queryFailure conn q resultType = do

191− x :: Either SomeException [Only a] <- E.try $ query_ conn q

192− case x of

193− Left _ -> return ()

194− Right val -> assertFailure ("Did not fail as expected: "

195− ++ show q

196− ++ " :: "

197− ++ show (typeOf resultType)

198− ++ " -> " ++ show val)

199−

200−testArray :: TestEnv -> Assertion

201−testArray TestEnv{..} = do

202− xs <- query_ conn "SELECT '{1,2,3,4}'::_int4"

203− xs @?= [Only (V.fromList [1,2,3,4 :: Int])]

204− xs <- query_ conn "SELECT '{{1,2},{3,4}}'::_int4"

205− xs @?= [Only (V.fromList [V.fromList [1,2],

206− V.fromList [3,4 :: Int]])]

207− queryFailure conn "SELECT '{1,2,3,4}'::_int4" (undefined :: V.Vector Bool)

208− queryFailure conn "SELECT '{{1,2},{3,4}}'::_int4" (undefined :: V.Vector Int)

209−

210−testNullableArray :: TestEnv -> Assertion

211−testNullableArray TestEnv{..} = do

212− xs <- query_ conn "SELECT '{sometext, \"NULL\"}'::_text"

213− xs @?= [Only (V.fromList ["sometext", "NULL" :: Text])]

214− xs <- query_ conn "SELECT '{sometext, NULL}'::_text"

215− xs @?= [Only (V.fromList [Just "sometext", Nothing :: Maybe Text])]

216− queryFailure conn "SELECT '{sometext, NULL}'::_text" (undefined :: V.Vector Text)

217−

218−testHStore :: TestEnv -> Assertion

219−testHStore TestEnv{..} = do

220− execute_ conn "CREATE EXTENSION IF NOT EXISTS hstore"

221− roundTrip []

222− roundTrip [("foo","bar"),("bar","baz"),("baz","hello")]

223− roundTrip [("fo\"o","bar"),("b\\ar","baz"),("baz","\"value\\with\"escapes")]

224− where

225− roundTrip :: [(Text,Text)] -> Assertion

226− roundTrip xs = do

227− let m = Only (HStoreMap (Map.fromList xs))

228− m' <- query conn "SELECT ?::hstore" m

229− [m] @?= m'

230−

231−testCIText :: TestEnv -> Assertion

232−testCIText TestEnv{..} = do

233− execute_ conn "CREATE EXTENSION IF NOT EXISTS citext"

234− roundTrip (CI.mk "")

235− roundTrip (CI.mk "UPPERCASE")

236− roundTrip (CI.mk "lowercase")

237− where

238− roundTrip :: (CI Text) -> Assertion

239− roundTrip cit = do

240− let toPostgres = Only cit

241− fromPostgres <- query conn "SELECT ?::citext" toPostgres

242− [toPostgres] @?= fromPostgres

243−

244−testJSON :: TestEnv -> Assertion

245−testJSON TestEnv{..} = do

246− roundTrip (Map.fromList [] :: Map Text Text)

247− roundTrip (Map.fromList [("foo","bar"),("bar","baz"),("baz","hello")] :: Map Text Text)

248− roundTrip (Map.fromList [("fo\"o","bar"),("b\\ar","baz"),("baz","\"value\\with\"escapes")] :: Map Text Text)

249− roundTrip (V.fromList [1,2,3,4,5::Int])

250− roundTrip ("foo" :: Text)

251− roundTrip (42 :: Int)

252− where

253− roundTrip :: ToJSON a => a -> Assertion

254− roundTrip a = do

255− let js = Only (toJSON a)

256− js' <- query conn "SELECT ?::json" js

257− [js] @?= js'

258−

259−testAeson :: TestEnv -> Assertion

260−testAeson TestEnv{..} = do

261− roundTrip (Map.fromList [] :: Map Text Text)

262− roundTrip (Map.fromList [("foo","bar"),("bar","baz"),("baz","hello")] :: Map Text Text)

263− roundTrip (Map.fromList [("fo\"o","bar"),("b\\ar","baz"),("baz","\"value\\with\"escapes")] :: Map Text Text)

264− roundTrip (V.fromList [1,2,3,4,5::Int])

265− roundTrip ("foo" :: Text)

266− roundTrip (42 :: Int)

267− where

268− roundTrip :: (Eq a, Show a, Typeable a, ToJSON a, FromJSON a)=> a -> Assertion

269− roundTrip x = do

270− y <- query conn "SELECT ?::json" (Only (Aeson x))

271− [Only (Aeson x)] @?= y

272−

273−testDerivingVia :: TestEnv -> Assertion

274−testDerivingVia TestEnv{..} = do

275−#if __GLASGOW_HASKELL__ <806

276− return ()

277−#else

278− roundTrip $ DerivingVia1 42 "Meaning of Life"

279− where

280− roundTrip :: (Eq a, Show a, Typeable a, ToField a, FromField a)=> a -> Assertion

281− roundTrip x = do

282− y <- query conn "SELECT ?::json" (Only x)

283− [Only x] @?= y

284−

285−data DerivingVia1 = DerivingVia1 Int String

286− deriving stock (Eq, Show, Generic)

287− deriving anyclass (FromJSON, ToJSON)

288− deriving (ToField, FromField) via Aeson DerivingVia1

289−

290−#endif

291−

292−

293−testQM :: TestEnv -> Assertion

294−testQM TestEnv{..} = do

295− -- Just test on a single string

296− let testQuery' b = "testing for ?" <> b <> " and making sure "

297− testQueryDoubleQM = testQuery' "?"

298− testQueryRest = "? is substituted"

299− testQuery = fromString $ testQueryDoubleQM <> testQueryRest

300− -- expect the entire first part with double QMs replaced with literal '?'

301− expected = (fromString $ testQuery' "", fromString testQueryRest)

302− tried = breakOnSingleQuestionMark testQuery

303− errMsg = concat

304− [ "Failed to break on single question mark exclusively:\n"

305− , "expected: ", show expected

306− , "result: ", show tried

307− ]

308− assertBool errMsg $ tried == expected

309−

310− -- Let's also test the question mark operators in action

311− -- ? -> Does the string exist as a top-level key within the JSON value?

312− positiveQuery "SELECT ?::jsonb ?? ?" (testObj, "foo" :: Text)

313− negativeQuery "SELECT ?::jsonb ?? ?" (testObj, "baz" :: Text)

314− negativeQuery "SELECT ?::jsonb ?? ?" (toJSON numArray, "1" :: Text)

315− -- ?| -> Do any of these array strings exist as top-level keys?

316− positiveQuery "SELECT ?::jsonb ??| ?" (testObj, PGArray ["nope","bar","6" :: Text])

317− negativeQuery "SELECT ?::jsonb ??| ?" (testObj, PGArray ["nope","6" :: Text])

318− negativeQuery "SELECT ?::jsonb ??| ?" (toJSON numArray, PGArray ["1","2","6" :: Text])

319− -- ?& -> Do all of these array strings exist as top-level keys?

320− positiveQuery "SELECT ?::jsonb ??& ?" (testObj, PGArray ["foo","bar","quux" :: Text])

321− positiveQuery "SELECT ?::jsonb ??& ?" (testObj, PGArray ["foo","bar" :: Text])

322− negativeQuery "SELECT ?::jsonb ??& ?" (testObj, PGArray ["foo","bar","baz" :: Text])

323− negativeQuery "SELECT ?::jsonb ??& ?" (toJSON numArray, PGArray ["1","2","3","4","5" :: Text])

324− -- Format error for 2 question marks, not 4

325− True <- expectError (isFormatError 2) $

326− (query conn "SELECT ?::jsonb ?? ?" $ Only testObj :: IO [Only Bool])

327− return ()

328− where positiveQuery :: ToRow a => Query -> a -> Assertion

329− positiveQuery = boolQuery True

330− negativeQuery :: ToRow a => Query -> a -> Assertion

331− negativeQuery = boolQuery False

332− numArray :: [Int]

333− numArray = [1,2,3,4,5]

334− boolQuery :: ToRow a => Bool -> Query -> a -> Assertion

335− boolQuery b t x = do

336− a <- query conn t x

337− [Only b] @?= a

338− testObj = toJSON (Map.fromList [("foo",toJSON (1 :: Int))

339− ,("bar",String "baz")

340− ,("quux",toJSON [1 :: Int,2,3,4,5])] :: Map Text Value

341− )

342

343−testSavepoint :: TestEnv -> Assertion

13+tests :: [TestEnv -> Test]

344−testSavepoint TestEnv{..} = do

14+tests =

345− True <- expectError ST.isNoActiveTransactionError $

15+ [ TestLabel "Bytea" . testBytea

346− withSavepoint conn $ return ()

16+ , TestLabel "Notify" . testNotify

347−

17+ , TestLabel "ExecuteMany" . testExecuteMany

348− let getRows :: IO [Int]

18+ , TestLabel "Time" . testTime

349− getRows = map fromOnly <$> query_ conn "SELECT a FROM tmp_savepoint ORDER BY a"

19+ , TestLabel "Serializable" . testSerializable

350− withTransaction conn $ do

351− execute_ conn "CREATE TEMPORARY TABLE tmp_savepoint (a INT UNIQUE)"

352− execute_ conn "INSERT INTO tmp_savepoint VALUES (1)"

353− [1] <- getRows

354−

355− withSavepoint conn $ do

356− execute_ conn "INSERT INTO tmp_savepoint VALUES (2)"

357− [1,2] <- getRows

358− return ()

359− [1,2] <- getRows

360−

361− withSavepoint conn $ do

362− execute_ conn "INSERT INTO tmp_savepoint VALUES (3)"

363− [1,2,3] <- getRows

364− True <- expectError isUniqueViolation $

365− execute_ conn "INSERT INTO tmp_savepoint VALUES (2)"

366− True <- expectError ST.isFailedTransactionError getRows

367−

368− -- Body returning successfully after handling error,

369− -- but 'withSavepoint' will roll back without complaining.

370− return ()

371− -- Rolling back clears the error condition.

372− [1,2] <- getRows

373−

374− -- 'withSavepoint' will roll back after an exception, even if the

375− -- exception wasn't SQL-related.

376− True <- expectError (== TestException) $

377− withSavepoint conn $ do

378− execute_ conn "INSERT INTO tmp_savepoint VALUES (3)"

379− [1,2,3] <- getRows

380− throwIO TestException

381− [1,2] <- getRows

382−

383− -- Nested savepoint can be rolled back while the

384− -- outer effects are retained.

385− withSavepoint conn $ do

386− execute_ conn "INSERT INTO tmp_savepoint VALUES (3)"

387− True <- expectError isUniqueViolation $

388− withSavepoint conn $ do

389− execute_ conn "INSERT INTO tmp_savepoint VALUES (4)"

390− [1,2,3,4] <- getRows

391− execute_ conn "INSERT INTO tmp_savepoint VALUES (4)"

392− [1,2,3] <- getRows

393− return ()

394− [1,2,3] <- getRows

395−

396− return ()

397−

398− -- Transaction committed successfully, even though there were errors

399− -- (but we rolled them back).

400− [1,2,3] <- getRows

401−

402− return ()

403−

404−testUnicode :: TestEnv -> Assertion

405−testUnicode TestEnv{..} = do

406− let q = Query . T.encodeUtf8 -- Handle encoding ourselves to ensure

407− -- the table gets created correctly.

408− let messages = map Only ["привет","мир"] :: [Only Text]

409− execute_ conn (q "CREATE TEMPORARY TABLE ру́сский (сообщение TEXT)")

410− executeMany conn "INSERT INTO ру́сский (сообщение) VALUES (?)" messages

411− messages' <- query_ conn "SELECT сообщение FROM ру́сский"

412− sort messages @?= sort messages'

413−

414−testValues :: TestEnv -> Assertion

415−testValues TestEnv{..} = do

416− execute_ conn "CREATE TEMPORARY TABLE values_test (x int, y text)"

417− test (Values ["int4","text"] [])

418− test (Values ["int4","text"] [(1,"hello")])

419− test (Values ["int4","text"] [(1,"hello"),(2,"world")])

420− test (Values ["int4","text"] [(1,"hello"),(2,"world"),(3,"goodbye")])

421− test (Values [] [(1,"hello")])

422− test (Values [] [(1,"hello"),(2,"world")])

423− test (Values [] [(1,"hello"),(2,"world"),(3,"goodbye")])

424− where

425− test :: Values (Int, Text) -> Assertion

426− test table@(Values _ vals) = do

427− execute conn "INSERT INTO values_test ?" (Only table)

428− vals' <- query_ conn "DELETE FROM values_test RETURNING *"

429− sort vals @?= sort vals'

430−

431−

432−testCopy :: TestEnv -> Assertion

433−testCopy TestEnv{..} = do

434− execute_ conn "CREATE TEMPORARY TABLE copy_test (x int, y text)"

435− copy_ conn "COPY copy_test FROM STDIN (FORMAT CSV)"

436− mapM_ (putCopyData conn) copyRows

437− putCopyEnd conn

438− copy_ conn "COPY copy_test FROM STDIN (FORMAT CSV)"

439− mapM_ (putCopyData conn) abortRows

440− putCopyError conn "aborted"

441− -- Hmm, does postgres always produce \n as an end-of-line here, or

442− -- are there cases where it will use a \r\n as well?

443− copy_ conn "COPY copy_test TO STDOUT (FORMAT CSV)"

444− rows <- loop []

445− sort rows @?= sort copyRows

446− -- Now, let's just verify that the connection state is back to ready,

447− -- so that we can issue more queries:

448− [Only (x::Int)] <- query_ conn "SELECT 2 + 2"

449− x @?= 4

450− -- foldCopyData

451− copy_ conn "COPY copy_test TO STDOUT (FORMAT CSV)"

452− (acc, count) <- foldCopyData conn

453− (\acc row -> return (row:acc))

454− (\acc count -> return (acc, count))

455− []

456− sort acc @?= sort copyRows

457− count @?= 2

458− where

459− copyRows = ["1,foo\n"

460− ,"2,bar\n"]

461− abortRows = ["3,baz\n"]

462− loop rows = do

463− mrow <- getCopyData conn

464− case mrow of

465− CopyOutDone _ -> return rows

466− CopyOutRow row -> loop (row:rows)

467−

468−testCopyFailures :: TestEnv -> TestTree

469−testCopyFailures env = testGroup "Copy failures"

470− $ map ($ env)

471− [ testCopyUniqueConstraintError

472− , testCopyMalformedError

473 ]

20 ]

474

475−goldenTest :: TestName -> IO BL.ByteString -> TestTree

476−goldenTest testName =

477− goldenVsStringDiff testName diff (resultsDir </> fileName<.>"expected")

478− where

479− resultsDir = "test" </> "results"

480− fileName = map normalize testName

481− normalize c | not (isAlpha c) = '-'

482− | otherwise = c

483− diff ref new = ["diff", "-u", ref, new]

484−

485−-- | Test that we provide a sensible error message on failure

486−testCopyUniqueConstraintError :: TestEnv -> TestTree

487−testCopyUniqueConstraintError TestEnv{..} =

488− goldenTest "unique constraint violation"

489− $ handle (\(SomeException exc) -> return $ BL.pack $ show exc) $ do

490− execute_ conn "CREATE TEMPORARY TABLE copy_unique_constraint_error_test (x int PRIMARY KEY, y text)"

491− copy_ conn "COPY copy_unique_constraint_error_test FROM STDIN (FORMAT CSV)"

492− mapM_ (putCopyData conn) copyRows

493− _n <- putCopyEnd conn

494− return BL.empty

495− where

496− copyRows = ["1,foo\n"

497− ,"2,bar\n"

498− ,"1,baz\n"]

499−

500−testCopyMalformedError :: TestEnv -> TestTree

501−testCopyMalformedError TestEnv{..} =

502− goldenTest "malformed input"

503− $ handle (\(SomeException exc) -> return $ BL.pack $ show exc) $ do

504− execute_ conn "CREATE TEMPORARY TABLE copy_malformed_input_error_test (x int PRIMARY KEY, y text)"

505− copy_ conn "COPY copy_unique_constraint_error_test FROM STDIN (FORMAT CSV)"

506− mapM_ (putCopyData conn) copyRows

507− _n <- putCopyEnd conn

508− return BL.empty

509− where

510− copyRows = ["1,foo\n"

511− ,"2,bar\n"

512− ,"z,baz\n"]

513−

514−testTimeout :: TestEnv -> Assertion

515−testTimeout TestEnv{..} =

516− withConn $ \c -> do

517− start_t <- getCurrentTime

518− res <- timeout 200000 $ do

519− withTransaction c $ do

520− query_ c "SELECT pg_sleep(1)" :: IO [Only ()]

521− end_t <- getCurrentTime

522− assertBool "Timeout did not occur" (res == Nothing)

523−#if !defined(mingw32_HOST_OS)

524−-- At the moment, you cannot timely abandon queries with async exceptions on

525−-- Windows.

526− let d = end_t `diffUTCTime` start_t

527− assertBool "Timeout didn't work in a timely fashion" (0.1 < d && d < 0.6)

528−#endif

529−

530−testDouble :: TestEnv -> Assertion

531−testDouble TestEnv{..} = do

532− [Only (x :: Double)] <- query_ conn "SELECT 'NaN'::float8"

533− assertBool "expected NaN" (isNaN x)

534− [Only (x :: Double)] <- query_ conn "SELECT 'Infinity'::float8"

535− x @?= (1 / 0)

536− [Only (x :: Double)] <- query_ conn "SELECT '-Infinity'::float8"

537− x @?= (-1 / 0)

538−

539−

540−testGeneric1 :: TestEnv -> Assertion

541−testGeneric1 TestEnv{..} = do

542− roundTrip conn (Gen1 123)

543− where

544− roundTrip conn x0 = do

545− r <- query conn "SELECT ?::int" (x0 :: Gen1)

546− r @?= [x0]

547−

548−testGeneric2 :: TestEnv -> Assertion

549−testGeneric2 TestEnv{..} = do

550− roundTrip conn (Gen2 123 "asdf")

551− where

552− roundTrip conn x0 = do

553− r <- query conn "SELECT ?::int, ?::text" x0

554− r @?= [x0]

555−

556−testGeneric3 :: TestEnv -> Assertion

557−testGeneric3 TestEnv{..} = do

558− roundTrip conn (Gen3 123 "asdf" True)

559− where

560− roundTrip conn x0 = do

561− r <- query conn "SELECT ?::int, ?::text, ?::bool" x0

562− r @?= [x0]

563−

564−data Gen1 = Gen1 Int

565− deriving (Show,Eq,Generic)

566−instance FromRow Gen1

567−instance ToRow Gen1

568−

569−data Gen2 = Gen2 Int Text

570− deriving (Show,Eq,Generic)

571−instance FromRow Gen2

572−instance ToRow Gen2

573−

574−data Gen3 = Gen3 Int Text Bool

575− deriving (Show,Eq,Generic)

576−instance FromRow Gen3

577−instance ToRow Gen3

578−

579−data TestException

580− = TestException

581− deriving (Eq, Show, Typeable)

582−

583−instance Exception TestException

584−

585−expectError :: Exception e => (e -> Bool) -> IO a -> IO Bool

586−expectError p io =

587− (io >> return False) `E.catch` \ex ->

588− if p ex then return True else throwIO ex

589−

590−isUniqueViolation :: SqlError -> Bool

591−isUniqueViolation SqlError{..} = sqlState == "23505"

592−

593−isSyntaxError :: SqlError -> Bool

594−isSyntaxError SqlError{..} = sqlState == "42601"

595−

596−isFormatError :: Int -> FormatError -> Bool

597−isFormatError i FormatError{..}

598− | null fmtMessage = False

599− | otherwise = fmtMessage == concat [ show i

600− , " single '?' characters, but "

601− , show (length fmtParams)

602− , " parameters"

603− ]

604−------------------------------------------------------------------------

605−

606-- | Action for connecting to the database that will be used for testing.

22-- | Action for connecting to the database that will be used for testing.

607--

23--

608-- Note that some tests, such as Notify, use multiple connections, and assume

24-- Note that some tests, such as Notify, use multiple connections, and assume

609-- that 'testConnect' connects to the same database every time it is called.

25-- that 'testConnect' connects to the same database every time it is called.

610−withTestEnv :: ByteString -> (TestEnv -> IO a) -> IO a

26+testConnect :: IO Connection

611−withTestEnv connstr cb =

27+testConnect = connectPostgreSQL ""

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'"

616

29+withTestEnv :: (TestEnv -> IO a) -> IO a

30+withTestEnv cb =

31+ withConn $ \conn ->

617 cb TestEnv

32 cb TestEnv

618 { conn = conn

33 { conn = conn

619 , withConn = withConn

34 , withConn = withConn

620 }

35 }

621 where

36 where

622− withConn = bracket (connectPostgreSQL connstr) close

37+ withConn = bracket testConnect close

623

624main :: IO ()

39main :: IO ()

625−main = withConnstring $ \connstring -> do

40+main = do

626− withTestEnv connstring (defaultMain . tests)

41+ mapM_ (`hSetBuffering` LineBuffering) [stdout, stderr]

627−

42+ Counts{cases, tried, errors, failures} <-

628−withConnstring :: (BS8.ByteString -> IO ()) -> IO ()

43+ withTestEnv $ \env -> runTestTT $ TestList $ map ($ env) tests

629−withConnstring kont = do

44+ when (cases /= tried || errors /= 0 || failures /= 0) $ exitFailure

630− env <- getEnvironment

631− case lookup "DATABASE_CONNSTRING" env of

632− Just s -> kont (BS8.pack (special s))

633− Nothing -> case lookup "GITHUB_ACTIONS" env of

634− Just "true" -> kont (BS8.pack gha)

635− _ -> putStrLn "Set DATABASE_CONNSTRING environment variable"

636− where

637− -- https://www.appveyor.com/docs/services-databases/

638− special "appveyor" = "dbname='TestDb' user='postgres' password='Password12!'"

639− special "travis" = ""

640− special s = s

641−

642− gha = unwords

643− [ "dbname='postgres'"

644− , "user='postgres'"

645− , "password='postgres'"

646− , "host='postgres'"

647− , "port=5432"

648− ]

test/Notify.hs+2−1

@@ -14,8 +14,9 @@ import qualified Data.ByteString as B

14-- TODO: Test with payload, but only for PostgreSQL >= 9.0

15-- (when that feature was introduced).

17−testNotify :: TestEnv -> Assertion

17+testNotify :: TestEnv -> Test

18testNotify TestEnv{..} =

19+ TestCase $

19 withConn $ \conn2 -> do

20 withConn $ \conn2 -> do

20 execute_ conn "LISTEN foo"

21 execute_ conn "LISTEN foo"

21 execute_ conn "LISTEN bar"

22 execute_ conn "LISTEN bar"

test/Serializable.hs+10−9

@@ -1,10 +1,13 @@

1+{-# LANGUAGE ScopedTypeVariables #-}

1module Serializable (testSerializable) where

2module Serializable (testSerializable) where

3import Common

4import Common

4import Control.Concurrent

5import Control.Concurrent

5import Control.Exception as E

6import Control.Exception as E

6import Data.IORef

7import Data.IORef

7−import Database.PostgreSQL.Simple.Transaction

9+atomic :: Connection -> IO a -> IO a

10+atomic = withTransactionSerializable ReadWrite

9initCounter :: Connection -> IO ()

12initCounter :: Connection -> IO ()

10initCounter conn = do

13initCounter conn = do

@@ -23,8 +26,9 @@ putCounter conn n = do

23 1 <- execute conn "UPDATE testSerializableCounter SET n=?" (Only n)

26 1 <- execute conn "UPDATE testSerializableCounter SET n=?" (Only n)

24 return ()

27 return ()

26−testSerializable :: TestEnv -> Assertion

29+testSerializable :: TestEnv -> Test

27testSerializable TestEnv{..} =

30testSerializable TestEnv{..} =

31+ TestCase $

28 withConn $ \conn2 -> do

32 withConn $ \conn2 -> do

29 initCounter conn

33 initCounter conn

@@ -34,7 +38,7 @@ testSerializable TestEnv{..} =

34 finished <- newEmptyMVar

38 finished <- newEmptyMVar

36 _ <- forkIO $ do

40 _ <- forkIO $ do

37− withTransactionSerializable conn2 $ do

41+ atomic conn2 $ do

38 modifyIORef attemptCounter (+1)

42 modifyIORef attemptCounter (+1)

39 n <- getCounter conn2

43 n <- getCounter conn2

40 True <- tryPutMVar readyToBother ()

44 True <- tryPutMVar readyToBother ()

@@ -43,7 +47,7 @@ testSerializable TestEnv{..} =

43 putMVar finished ()

47 putMVar finished ()

45 takeMVar readyToBother

49 takeMVar readyToBother

46− withTransactionSerializable conn $ do

50+ atomic conn $ do

47 n <- getCounter conn

51 n <- getCounter conn

48 putCounter conn (n+1)

52 putCounter conn (n+1)

49 True <- tryPutMVar bothered ()

53 True <- tryPutMVar bothered ()

@@ -53,12 +57,9 @@ testSerializable TestEnv{..} =

53 ac <- readIORef attemptCounter

57 ac <- readIORef attemptCounter

54 assertEqual "attemptCounter" 2 ac

58 assertEqual "attemptCounter" 2 ac

56− ok <- E.catch (do withTransactionSerializable conn (fail "Whoops")

60+ ok <- E.catch (atomic conn (fail "Whoops") >> return False)

57− return False)

58 (\(_ :: IOException) -> return True)

61 (\(_ :: IOException) -> return True)

59− assertBool "Exceptions (besides serialization failure) should be\

62+ assertBool "Exceptions (besides serialization failure) should be propagated through atomic" ok

60− \ propagated through withTransactionSerializable"

61− ok

63 -- Make sure transaction isn't dangling

64 -- Make sure transaction isn't dangling

64 1 <- execute_ conn "UPDATE testSerializableCounter SET n=12345"

65 1 <- execute_ conn "UPDATE testSerializableCounter SET n=12345"

test/Time.hs+16−64

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

1−{-# LANGUAGE QuasiQuotes #-}

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

3{-

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

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

18would still pass these tests.

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

20-}

35module Time (testTime) where

22module Time (testTime) where

37import Common

24import Common

38import Control.Monad(forM_, replicateM_)

25import Control.Monad(forM_, replicateM_)

39−import Data.Time.Compat

26+import Data.Time

40import Data.ByteString(ByteString)

27import Data.ByteString(ByteString)

41import Database.PostgreSQL.Simple.SqlQQ

28import Database.PostgreSQL.Simple.SqlQQ

43numTests :: Int

30numTests :: Int

44numTests = 200

31numTests = 200

46−testTime :: TestEnv -> Assertion

33+testTime :: TestEnv -> Test

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

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

48 initializeTable env

35 initializeTable env

49 execute_ conn "SET timezone TO 'UTC'"

36 execute_ conn "SET timezone TO 'UTC'"

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

37+ checkRoundTrips env

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

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

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

39+ checkRoundTrips env

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

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

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

41+ checkRoundTrips env

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

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

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

43+ checkRoundTrips env

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

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

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

45+ checkRoundTrips env

60initializeTable :: TestEnv -> IO ()

47initializeTable :: TestEnv -> IO ()

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

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

62 execute_ conn

49 execute_ conn

63 [sql| CREATE TEMPORARY TABLE testtime

50 [sql| CREATE TEMPORARY TABLE testtime

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

51 ( 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−

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

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

93 replicateM_ numTests $ execute conn

53 replicateM_ numTests $ execute conn

94 [sql| INSERT INTO testtime (y) VALUES

54 [sql| INSERT INTO testtime (y) VALUES

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

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

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

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

97 pop "1 microsecond" 6.3113904e15

57 pop "1 microsecond" 6.3113904e15

98 pop "10 microseconds" 6.3113904e14

58 pop "10 microseconds" 6.3113904e14

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

102 pop "100 milliseconds" 6.3113904e10

62 pop "100 milliseconds" 6.3113904e10

103 pop "1 second" 6.3113904e9

63 pop "1 second" 6.3113904e9

104

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

65+checkRoundTrips :: TestEnv -> IO ()

106−checkRoundTrips TestEnv{..} limit = do

66+checkRoundTrips TestEnv{..} = do

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

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

108 forM_ yxs $ \yx -> do

68 forM_ yxs $ \yx -> do

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

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

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

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

111 res == [Only True]

71 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/WRITING-TESTS+23−31

@@ -1,42 +1,34 @@

1−Do what is EASIEST. Having a test at all is more important than,

1+Main.hs is a small wrapper around HUnit that opens a database connection and

2−say, pretty failure output.

2+starts the HUnit text-based test controller.

4−To add a test, open Main.hs, and add an entry to tests, e.g.:

4+To add a new module to the test suite, do the following:

6− tests :: [TestEnv -> Test]

6+ * Create a new module that exports a function of type TestEnv -> Test.

7− tests =

7+ For example:

8− [ ...

9− , TestLabel "Foo" . testFoo

10− ]

12− testFoo :: TestEnv -> Test

9+ module Foo (testFoo) where

13− testFoo TestEnv{..} = TestCase $ do

14− meaningOfLife @?= 42

15− 2013 <- getCurrentYear

16− return ()

18−Mnemonic for HUnit @=? and @?= operators:

11+ import Common

20− * `?` is the value whose correctness is in question

13+ testFoo :: TestEnv -> Test

14+ testFoo TestEnv{..} = ...

22− * `=` is the expected value

16+ 'TestEnv' (defined in Common.hs) contains information for accessing the

17+ database. `TestEnv{..}` is a record wildcard which brings the following

18+ definitions into scope:

24−If you move a test to a separate module, don't forget to add it to

20+ conn :: Connection

25−"other-modules" in postgresql-simple.cabal . Otherwise, the module will be

21+ withConn :: (Connection -> IO a) -> IO a

26−left out of the tarball generated by `cabal sdist`, and tests will fail to

27−build when installing from Hackage.

29−'TestEnv' (defined in Common.hs) contains information for accessing the

23+ 'conn' is a database connection shared by all the tests.

30−database. `TestEnv{..}` is a record wildcard which brings the following

24+ 'withConn' can be used to open additional connections (to the same database).

31−definitions into scope:

33− conn :: Connection

26+ 'Test' is basically a tree of 'Assertion's, where 'Assertion' is just a type

34− withConn :: (Connection -> IO a) -> IO a

27+ alias for IO (). See the HLint documentation for more information.

36−'conn' is a database connection shared by all the tests.

29+ * Add an entry to 'tests' in Main.hs (along with the corresponding

37−'withConn' can be used to open additional connections (to the same database).

30+ module import) so the test driver will know about the new module.

39−'Test' is basically a tree of 'Assertion's, where 'Assertion' is just a type

32+ * Add the module to postgresql-simple.cabal, under test-suite > other-modules.

40−alias for IO (). See the [HUnit documentation][1] for more information.

33+ Otherwise, the module will be left out of the tarball generated by

41−

34+ `cabal sdist`, and tests will fail to build when installing from Hackage.

42− [1]: http://hackage.haskell.org/packages/archive/HUnit/latest/doc/html/Test-HUnit-Base.html

test/results/malformed-input.expecteddeleted−4

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

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

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

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

4−)

test/results/unique-constraint-violation.expecteddeleted−5

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

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

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

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

4−CONTEXT: COPY copy_unique_constraint_error_test, line 3

5−)

tools/GenBuiltinTypes.hsnew file+180

@@ -0,0 +1,180 @@

1+------------------------------------------------------------------------------

2+-- |

3+-- Module: GenBuiltinTypes

5+-- License: BSD3

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

7+-- Stability: experimental

8+--

9+-- Queries a PostgreSQL for the Object IDs associated with built-in typenames,

10+-- and generates Haskell boilerplate to handle this mapping. The subset

11+-- of types handled this way is easily modifiable, but note that

12+-- user-defined types do not have stable oids, and can differ between

13+-- databases or dumps/reloads.

14+------------------------------------------------------------------------------

15+

16+{-# LANGUAGE OverloadedStrings, QuasiQuotes, ViewPatterns #-}

17+module GenBuiltinTypes where

18+

19+import Prelude hiding ((++))

20+

21+import StringsQQ

22+import Database.PostgreSQL.Simple

23+import qualified Data.ByteString.Char8 as B

24+import qualified Data.ByteString.Lazy as L

25+import qualified Blaze.ByteString.Builder as Blaze

26+import qualified Blaze.ByteString.Builder.ByteString as Blaze

27+import qualified Blaze.ByteString.Builder.Char8 as Blaze

28+import Data.String

29+import Data.List ( sort, intersperse )

30+import qualified Data.Map as Map

31+

32+import Data.Monoid

33+

34+(++) :: Monoid a => a -> a -> a

35+(++) = mappend

36+infixr 5 ++

37+

38+type Map = Map.Map B.ByteString Int

39+builtins :: [(B.ByteString, B.ByteString)]

40+builtins = [strings|

41+bool

42+bytea ByteA

43+char

44+name

45+int8

46+int2

47+int4

48+regproc RegProc

49+text

50+oid

51+tid

52+xid

53+cid

54+xml

55+point

56+lseg LSeg

57+path

58+box

59+polygon

60+line

61+cidr

62+float4

63+float8

64+abstime AbsTime

65+reltime RelTime

66+tinterval TInterval

67+unknown

68+circle

69+money

70+macaddr MacAddr

71+inet

72+bpchar BpChar

73+varchar VarChar

74+date

75+time

76+timestamp

77+timestamptz TimestampTZ

78+interval

79+timetz TimeTZ

80+bit

81+varbit VarBit

82+numeric

83+refcursor RefCursor

84+record

85+void

86+uuid UUID

87+|]

88+

89+instance IsString Blaze.Builder where

90+ fromString = Blaze.fromByteString . fromString

91+

92+main = do

93+ conn <- connectPostgreSQL ""

94+ xs <- query conn "SELECT typname::text, oid::int\

95+ \ FROM pg_type\

96+ \ WHERE typname IN ?"

97+ (Only (In (sort (map fst builtins))))

98+ close conn

99+ let oidmap = Map.fromList xs :: Map

100+ L.writeFile "../src/Database/PostgreSQL/Simple/BuiltinTypes.hs"

101+ (Blaze.toLazyByteString (renderFile oidmap builtins))

102+

103+padCons str = fromString (replicate (len - B.length str) ' ')

104+ where

105+ len = maximum (map (B.length . snd) builtins)

106+

107+renderOid oidmap x

108+ = case Map.lookup x oidmap of

109+ Nothing -> error (B.unpack x)

110+ Just (show -> n) -> fromString (replicate (4 - length n) ' ')

111+ ++ fromString n

112+

113+renderOid' oidmap x

114+ = case Map.lookup x oidmap of

115+ Nothing -> error (B.unpack x)

116+ Just (show -> n) -> fromString n

117+ ++ fromString (replicate (4 - length n) ' ')

118+

119+bs = Blaze.fromByteString

120+

121+renderFile :: Map -> [(B.ByteString,B.ByteString)] -> Blaze.Builder

122+renderFile oidmap builtins = ([longstring|

123+{-# LANGUAGE DeriveDataTypeable, OverloadedStrings #-}

124+

125+------------------------------------------------------------------------------

126+-- |

127+-- Module: Database.PostgreSQL.Simple.BuiltinTypes

129+-- License: BSD3

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

131+-- Stability: experimental

132+--

133+------------------------------------------------------------------------------

134+

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

136+-- not be edited directly

137+

138+module Database.PostgreSQL.Simple.BuiltinTypes

139+ ( BuiltinType (..)

140+ , builtin2oid

141+ , oid2builtin

142+ , builtin2typname

143+ , oid2typname

144+ ) where

145+

146+import Data.Typeable

147+import Data.ByteString (ByteString)

148+import qualified Database.PostgreSQL.LibPQ as PQ

149+

150+data BuiltinType

151+ = |] ++ mconcat (intersperse "\n | " (map (Blaze.fromByteString . snd) builtins)) ++ [longstring|

152+

153+ deriving (Eq, Ord, Enum, Bounded, Read, Show, Typeable)

154+

155+builtin2oid :: BuiltinType -> PQ.Oid

156+builtin2oid typ = PQ.Oid $ case typ of

157+|] ++ mconcat [mconcat [ " ", bs y, padCons y, " -> "

158+ , renderOid oidmap x, "\n" ]

159+ | (x,y) <- builtins ] ++ [longstring|

160+

161+oid2builtin :: PQ.Oid -> Maybe BuiltinType

162+oid2builtin (PQ.Oid x) = case x of

163+|] ++ mconcat [mconcat [ " ", renderOid' oidmap x, " -> Just ", bs y, "\n" ]

164+ | (x,y) <- builtins ] ++ [longstring|

165+ _ -> Nothing

166+

167+builtin2typname :: BuiltinType -> ByteString

168+builtin2typname typ = case typ of

169+|] ++ mconcat [mconcat [ " ", bs y, padCons y, " -> ", bs x, "\n"]

170+ | (x,y) <- builtins] ++ [longstring|

171+

172+oid2typname :: PQ.Oid -> Maybe ByteString

173+oid2typname (PQ.Oid x) = case x of

174+|] ++ mconcat [mconcat [ " ", renderOid' oidmap x, " -> Just ", bs x, "\n" ]

175+ | (x,y) <- builtins ]

176+ ++ " _ -> Nothing\n"

177+ ++ mconcat [mconcat [ "\n"

178+ , bs x, " :: ByteString\n"

179+ , bs x, " = \"", bs x, "\"\n"]

180+ | (x,_y) <- builtins ])

tools/GenTypeInfo.hsdeleted−381

@@ -1,381 +0,0 @@

1−------------------------------------------------------------------------------

2−-- |

3−-- Module: GenTypeInfo

5−-- License: BSD3

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

7−-- Stability: experimental

8−--

9−-- Queries a PostgreSQL database for the Object IDs and other type

10−-- information associated with typenames, and generates a module with

11−-- data constants representing part of the pg_type table.

12−--

13−-- Note that only some of the built-in types have stable type OIDs, and

14−-- thus a TypeInfo module that contains user-defined types is liable to

15−-- not work across different database instances. For these types, it is

16−-- better for `FromField` to use the `typeinfo` operator that works for

17−-- any type, whether or not it is in this module.

18−--

19−-- `typeinfo` works because postgresql-simple will dynamically query

20−-- the pg_types table the first time it receives a type OID it doesn't

21−-- know about. It then constructs a TypeInfo record and stores it in

22−-- a per-connection cache for later use.

23−--

24−-- @

25−-- runghc -itools tools/GenTypeInfo.hs

26−-- @

27−------------------------------------------------------------------------------

28−

29−{-# LANGUAGE OverloadedStrings, QuasiQuotes, ViewPatterns, RecordWildCards #-}

30−

31−module GenBuiltinTypes where

32−

33−import Prelude hiding ((++), concat)

34−

35−import StringsQQ

36−import Control.Arrow((&&&))

37−import Control.Applicative

38−import Control.Exception(bracket)

39−import Database.PostgreSQL.Simple

40−import Database.PostgreSQL.Simple.FromRow

41−import Database.PostgreSQL.Simple.Ok

42−import Database.PostgreSQL.Simple.Types(Oid(..))

43−import Database.PostgreSQL.Simple.SqlQQ

44−import qualified Data.ByteString.Char8 as B8

45−import Data.ByteString(ByteString)

46−import qualified Data.ByteString.Lazy as L

47−import qualified Data.ByteString.Builder as Blaze

48−import Data.String

49−import Data.List ( sort, intersperse )

50−import qualified Data.Map as Map

51−

52−import Data.Monoid

53−

54−(++) :: Monoid a => a -> a -> a

55−(++) = mappend

56−infixr 5 ++

57−

58−concat :: Monoid a => [a] -> a

59−concat = mconcat

60−

61−data TypeInfo = TypeInfo

62− { typoid :: Oid

63− , typcategory :: Char

64− , typdelim :: Char

65− , typname :: ByteString

66− , typelem :: Oid

67− , rngsubtype :: Maybe Oid

68− }

69−

70−instance FromRow TypeInfo where

71− fromRow = TypeInfo <$> field <*> field <*> field <*> field <*> field <*> field

72−

73−type NameMap = Map.Map B8.ByteString TypeInfo

74−

75−type OidMap = Map.Map Oid TypeInfo

76−

77−type TypeName = (B8.ByteString, B8.ByteString)

78−

79−type TypeNames = [TypeName]

80−

81−-- Note that the following syntax is "pgName <whitespace> hsName", though

82−-- they default to the same thing if there is only one identifier

83−typeNames :: TypeNames

84−typeNames = [typenames|

85−bool

86−bytea

87−char

88−name

89−int8

90−int2

91−int4

92−regproc

93−text

94−oid

95−tid

96−xid

97−cid

98−xml

99−point

100−lseg

101−path

102−box

103−polygon

104−line

105−cidr

106−float4

107−float8

108−unknown

109−circle

110−money

111−macaddr

112−inet

113−bpchar

114−varchar

115−date

116−time

117−timestamp

118−timestamptz

119−interval

120−timetz

121−bit

122−varbit

123−numeric

124−refcursor

125−record

126−void

127−_record array_record

128−regprocedure

129−regoper

130−regoperator

131−regclass

132−regtype

133−uuid

134−json

135−jsonb

136−int2vector

137−oidvector

138−_xml array_xml

139−_json array_json

140−_line array_line

141−_cidr array_cidr

142−_circle array_circle

143−_money array_money

144−_bool array_bool

145−_bytea array_bytea

146−_char array_char

147−_name array_name

148−_int2 array_int2

149−_int2vector array_int2vector

150−_int4 array_int4

151−_regproc array_regproc

152−_text array_text

153−_tid array_tid

154−_xid array_xid

155−_cid array_cid

156−_oidvector array_oidvector

157−_bpchar array_bpchar

158−_varchar array_varchar

159−_int8 array_int8

160−_point array_point

161−_lseg array_lseg

162−_path array_path

163−_box array_box

164−_float4 array_float4

165−_float8 array_float8

166−_polygon array_polygon

167−_oid array_oid

168−_macaddr array_macaddr

169−_inet array_inet

170−_timestamp array_timestamp

171−_date array_date

172−_time array_time

173−_timestamptz array_timestamptz

174−_interval array_interval

175−_numeric array_numeric

176−_timetz array_timetz

177−_bit array_bit

178−_varbit array_varbit

179−_refcursor array_refcursor

180−_regprocedure array_regprocedure

181−_regoper array_regoper

182−_regoperator array_regoperator

183−_regclass array_regclass

184−_regtype array_regtype

185−_uuid array_uuid

186−_jsonb array_jsonb

187−int4range

188−_int4range

189−numrange

190−_numrange

191−tsrange

192−_tsrange

193−tstzrange

194−_tstzrange

195−daterange

196−_daterange

197−int8range

198−_int8range

199−|]

200−

201−connectionString = "dbname=postgres"

202−

203−withPostgreSQL = bracket (connectPostgreSQL connectionString) close

204−

205−getTypeInfos :: TypeNames -> IO (OidMap, NameMap)

206−getTypeInfos 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))))

213− loop conn (oidMap infos) (nameMap infos) infos

214− where

215− oidMap = Map.fromList . map (typoid &&& id)

216− nameMap = Map.fromList . map (typname &&& id)

217− loop conn oids names infos = do

218− let unknowns = [ x | x <- map typelem infos ++

219− [ x | Just x <- map rngsubtype infos ],

220− x /= Oid 0,

221− not (Map.member x oids) ]

222− case unknowns of

223− [] -> return (oids, names)

224− (_:_) -> do

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

232− let oids' = oids `Map.union` oidMap infos'

233− names' = names `Map.union` nameMap infos'

234− loop conn oids' names' infos'

235−

236−main = do

237− (oidmap, namemap) <- getTypeInfos typeNames

238− L.writeFile "src/Database/PostgreSQL/Simple/TypeInfo/Static.hs"

239− (Blaze.toLazyByteString (renderFile oidmap namemap typeNames))

240−

241−

242−showOid (Oid n) = show n

243−

244−renderOid :: NameMap -> TypeName -> Blaze.Builder

245−renderOid byName name

246− = case Map.lookup (pg name) byName of

247− Nothing -> error (B8.unpack (pg name))

248− Just (showOid . typoid -> n) -> fromString n

249− ++ fromString (replicate (4 - length n) ' ')

250−

251−renderElem :: OidMap -> Oid -> Blaze.Builder

252−renderElem byOid elemOid

253− | elemOid == Oid 0 = "Nothing"

254− | otherwise = case Map.lookup elemOid byOid of

255− Nothing -> error ("oid not found: " ++ show elemOid)

256− Just x -> "Just " ++ bs (typname x)

257−

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−

328−-- FIXME: add in any names that we need that we didn't specify, (i.e.

329−-- the "unknowns" in getTypeInfos

330−-- and munge them into a valid haskell identifier if needed.

331−getNames :: NameMap -> TypeNames -> TypeNames

332−getNames _ x = x

333−

334−bs = Blaze.byteString

335−

336−pg = fst

337−

338−hs = snd

339−

340−renderFile :: OidMap -> NameMap -> TypeNames -> Blaze.Builder

341−renderFile byOid byName names = ([longstring|

342−------------------------------------------------------------------------------

343−-- |

344−-- Module: Database.PostgreSQL.Simple.TypeInfo

346−-- License: BSD3

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

348−-- Stability: experimental

349−--

350−-- This module contains portions of the @pg_type@ table that are relevant

351−-- to postgresql-simple and are believed to not change between PostgreSQL

352−-- versions.

353−--

354−------------------------------------------------------------------------------

355−

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

357−-- not be edited directly

358−

359−module Database.PostgreSQL.Simple.TypeInfo.Static

360− ( TypeInfo(..)

361− , staticTypeInfo

362−|] ++ concat [ " , " ++ bs (hs name) ++ "\n"

363− ++ " , " ++ bs (hs name) ++ "Oid\n"

364− | name <- names ] ++ [longstring|

365− ) where

366−

367−import Database.PostgreSQL.LibPQ (Oid(..))

368−import Database.PostgreSQL.Simple.TypeInfo.Types

369−

370−staticTypeInfo :: Oid -> Maybe TypeInfo

371−staticTypeInfo (Oid x) = case x of

372−|] ++ concat [concat [ " ", renderOid byName name,

373− " -> Just ", bs (hs name), "\n"

374− ]

375− | name <- names ]

376− ++ [longstring|

377− _ -> Nothing

378−|]

379− ++ concat [ renderTypeInfo byOid typeInfo name

380− | name <- getNames byName names

381− , let (Just typeInfo) = Map.lookup (pg name) byName])

tools/StringsQQ.hs+1−12

@@ -1,6 +1,6 @@

1{-# LANGUAGE TemplateHaskell #-}

3−module StringsQQ (strings, longstring, typenames) where

3+module StringsQQ (strings, longstring) where

5import Language.Haskell.TH

6import Language.Haskell.TH.Quote

@@ -28,14 +28,3 @@ longstring = QuasiQuoter { quotePat = undefined,

29longstringExp ('\n':xs) = stringE xs

30longstringExp xs = stringE xs

31−

32−typenames = QuasiQuoter { quotePat = undefined,

33− quoteType = undefined,

34− quoteExp = typenamesExp,

35− quoteDec = undefined }

36−

37−typenamesExp :: String -> Q Exp

38−typenamesExp = foldr (\x xs -> [e| $(x) : $(xs) |]) [e| [] |]

39− . map delta . filter (not . null) . map words . lines

40− where delta [xs] = delta [xs,xs]

41− delta [xs,ys] = [e| ( $(stringE xs) , $(stringE ys) ) |]