master..3389f02 · typeable/postgresql-simple

.ghcinew file+16

since splitsnapshots

unifiedsplit

@@ -0,0 +1,16 @@

1+:set -isrc -itest -optP-includedist/build/autogen/cabal_macros.h

2+:set -Wall -fno-warn-name-shadowing

3+

4+:set -XDoAndIfThenElse

5+:set -XOverloadedStrings

6+:set -XBangPatterns

7+:set -XViewPatterns

8+:set -XTypeOperators

9+

10+-- for tests

11+:set -XNamedFieldPuns

12+:set -XRank2Types

13+:set -XRecordWildCards

14+:set -XPatternGuards

15+:set -XScopedTypeVariables

16+:set -fno-warn-unused-do-bind

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

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

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

2−#

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

4−#

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

6−#

7−# haskell-ci regenerate

8−#

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

10−#

11−# version: 0.17.20231110

12−#

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

14−#

15−name: Haskell-CI

16−on:

17− push:

18− branches:

19− - master

20− pull_request:

21− branches:

22− - master

23−jobs:

24− linux:

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

26− runs-on: ubuntu-20.04

27− timeout-minutes:

28− 60

29− container:

30− image: buildpack-deps:bionic

31− services:

32− postgres:

33− image: postgres:14

34− env:

35− POSTGRES_PASSWORD: postgres

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

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

38− strategy:

39− matrix:

40− include:

41− - compiler: ghc-9.8.1

42− compilerKind: ghc

43− compilerVersion: 9.8.1

44− setup-method: ghcup

45− allow-failure: false

46− - compiler: ghc-9.6.3

47− compilerKind: ghc

48− compilerVersion: 9.6.3

49− setup-method: ghcup

50− allow-failure: false

51− - compiler: ghc-9.4.8

52− compilerKind: ghc

53− compilerVersion: 9.4.8

54− setup-method: ghcup

55− allow-failure: false

56− - compiler: ghc-9.2.8

57− compilerKind: ghc

58− compilerVersion: 9.2.8

59− setup-method: ghcup

60− allow-failure: false

61− - compiler: ghc-9.0.2

62− compilerKind: ghc

63− compilerVersion: 9.0.2

64− setup-method: ghcup

65− allow-failure: false

66− - compiler: ghc-8.10.7

67− compilerKind: ghc

68− compilerVersion: 8.10.7

69− setup-method: ghcup

70− allow-failure: false

71− - compiler: ghc-8.8.4

72− compilerKind: ghc

73− compilerVersion: 8.8.4

74− setup-method: hvr-ppa

75− allow-failure: false

76− - compiler: ghc-8.6.5

77− compilerKind: ghc

78− compilerVersion: 8.6.5

79− setup-method: hvr-ppa

80− allow-failure: false

81− fail-fast: false

82− steps:

83− - name: apt

84− run: |

85− apt-get update

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

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

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

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

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

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

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

93− else

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

95− apt-get update

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

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

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

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

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

101− fi

102− env:

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

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

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

106− - name: Set PATH and environment variables

107− run: |

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

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

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

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

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

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

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

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

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

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

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

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

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

121− else

122− HC=$HCDIR/bin/$HCKIND

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

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

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

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

127− fi

128−

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

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

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

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

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

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

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

136− env:

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

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

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

140− - name: env

141− run: |

142− env

143− - name: write cabal config

144− run: |

145− mkdir -p $CABAL_DIR

146− cat >> $CABAL_CONFIG <<EOF

147− remote-build-reporting: anonymous

148− write-ghc-environment-files: never

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

150− logs-dir: $CABAL_DIR/logs

151− world-file: $CABAL_DIR/world

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

153− symlink-bindir: $CABAL_DIR/bin

154− installdir: $CABAL_DIR/bin

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

156− store-dir: $CABAL_DIR/store

157− install-dirs user

158− prefix: $CABAL_DIR

159− repository hackage.haskell.org

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

161− EOF

162− cat >> $CABAL_CONFIG <<EOF

163− program-default-options

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

165− EOF

166− cat $CABAL_CONFIG

167− - name: versions

168− run: |

169− $HC --version || true

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

171− $CABAL --version || true

172− - name: update cabal index

173− run: |

174− $CABAL v2-update -v

175− - name: install cabal-plan

176− run: |

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

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

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

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

181− rm -f cabal-plan.xz

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

183− cabal-plan --version

184− - name: checkout

185− uses: actions/checkout@v3

186− with:

187− path: source

188− - name: initial cabal.project for sdist

189− run: |

190− touch cabal.project

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

192− cat cabal.project

193− - name: sdist

194− run: |

195− mkdir -p sdist

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

197− - name: unpack

198− run: |

199− mkdir -p unpacked

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

201− - name: generate cabal.project

202− run: |

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

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

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

206− touch cabal.project

207− touch cabal.project.local

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

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

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

211− cat >> cabal.project <<EOF

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

213− EOF

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

215− cat cabal.project

216− cat cabal.project.local

217− - name: dump install plan

218− run: |

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

220− cabal-plan

221− - name: restore cache

222− uses: actions/cache/restore@v3

223− with:

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

225− path: ~/.cabal/store

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

227− - name: install dependencies

228− run: |

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

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

231− - name: build w/o tests

232− run: |

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

234− - name: build

235− run: |

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

237− - name: tests

238− run: |

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

240− - name: cabal check

241− run: |

242− cd ${PKGDIR_postgresql_simple} || false

243− ${CABAL} -vnormal check

244− - name: haddock

245− run: |

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

247− - name: unconstrained build

248− run: |

249− rm -f cabal.project.local

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

251− - name: save cache

252− uses: actions/cache/save@v3

253− if: always()

254− with:

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

256− path: ~/.cabal/store

.github/workflows/simple.ymldeleted−58

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

1−name: Simple

2−on:

3− push:

4− branches:

5− - master

6− pull_request:

7− branches:

8− - master

9−

10−jobs:

11− native:

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

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

14− strategy:

15− matrix:

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

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

18− fail-fast: false

19− timeout-minutes:

20− 60

21− steps:

22− - name: Set git to use LF

23− run: |

24− git config --global core.autocrlf false

25− git config --global core.eol lf

26−

27− - name: Set up Haskell

28− id: setup-haskell

29− uses: haskell/actions/setup@v2

30− with:

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

32− cabal-version: '3.10.2.0'

33−

34− - name: Set up PostgreSQL

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

36− id: postgres

37− with:

38− username: ci

39− password: sw0rdfish

40− database: test

41−

42− - name: Checkout

43− uses: actions/checkout@v3.0.2

44−

45− - name: Cache

46− uses: actions/cache@v2.1.3

47− with:

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

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

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

51−

52− - name: Build

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

54−

55− - name: Test

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

57− env:

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

.gitignore−2

@@ -13,5 +13,3 @@ dist/

13cabal.sandbox.config

14/dist-newstyle

15.ghc.environment.*

16−cabal.project.local

17−dump-core

.travis.ymlnew file+129

@@ -0,0 +1,129 @@

1+# This Travis job script has been generated by a script via

2+#

3+# runghc make_travis_yml_2.hs '--branch' 'master' '--output' '.travis.yml' 'postgresql-simple.cabal'

4+#

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

6+#

7+language: c

8+sudo: false

9+

10+services:

11+ - postgresql

12+

13+git:

14+ submodules: false # whether to recursively clone submodules

15+

16+branches:

17+ only:

18+ - master

19+

20+cache:

21+ directories:

22+ - $HOME/.cabal/packages

23+ - $HOME/.cabal/store

24+

25+before_cache:

26+ - rm -fv $HOME/.cabal/packages/hackage.haskell.org/build-reports.log

27+ # remove files that are regenerated by 'cabal update'

28+ - rm -fv $HOME/.cabal/packages/hackage.haskell.org/00-index.*

29+ - rm -fv $HOME/.cabal/packages/hackage.haskell.org/*.json

30+ - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.cache

31+ - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.tar

32+ - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.tar.idx

33+

34+ - rm -rfv $HOME/.cabal/packages/head.hackage

35+

36+matrix:

37+ include:

38+ - compiler: "ghc-8.6.3"

39+ # env: TEST=--disable-tests BENCH=--disable-benchmarks

40+ addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.4,ghc-8.6.3], sources: [hvr-ghc]}}

41+ - compiler: "ghc-8.4.4"

42+ # env: TEST=--disable-tests BENCH=--disable-benchmarks

43+ addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.4,ghc-8.4.4], sources: [hvr-ghc]}}

44+ - compiler: "ghc-8.2.2"

45+ # env: TEST=--disable-tests BENCH=--disable-benchmarks

46+ addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.4,ghc-8.2.2], sources: [hvr-ghc]}}

47+ - compiler: "ghc-8.0.2"

48+ # env: TEST=--disable-tests BENCH=--disable-benchmarks

49+ addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.4,ghc-8.0.2], sources: [hvr-ghc]}}

50+ - compiler: "ghc-7.10.3"

51+ # env: TEST=--disable-tests BENCH=--disable-benchmarks

52+ addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.4,ghc-7.10.3], sources: [hvr-ghc]}}

53+ - compiler: "ghc-7.8.4"

54+ # env: TEST=--disable-tests BENCH=--disable-benchmarks

55+ addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.4,ghc-7.8.4], sources: [hvr-ghc]}}

56+ - compiler: "ghc-7.6.3"

57+ # env: TEST=--disable-tests BENCH=--disable-benchmarks

58+ addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.4,ghc-7.6.3], sources: [hvr-ghc]}}

59+

60+before_install:

61+ - HC=${CC}

62+ - HCPKG=${HC/ghc/ghc-pkg}

63+ - unset CC

64+ - ROOTDIR=$(pwd)

65+ - mkdir -p $HOME/.local/bin

66+ - "PATH=/opt/ghc/bin:/opt/ghc-ppa-tools/bin:$HOME/local/bin:$PATH"

67+ - HCNUMVER=$(( $(${HC} --numeric-version|sed -E 's/([0-9]+)\.([0-9]+)\.([0-9]+).*/\1 * 10000 + \2 * 100 + \3/') ))

68+ - echo $HCNUMVER

69+

70+install:

71+ - cabal --version

72+ - echo "$(${HC} --version) [$(${HC} --print-project-git-commit-id 2> /dev/null || echo '?')]"

73+ - BENCH=${BENCH---enable-benchmarks}

74+ - TEST=${TEST---enable-tests}

75+ - HADDOCK=${HADDOCK-true}

76+ - UNCONSTRAINED=${UNCONSTRAINED-true}

77+ - NOINSTALLEDCONSTRAINTS=${NOINSTALLEDCONSTRAINTS-false}

78+ - GHCHEAD=${GHCHEAD-false}

79+ - travis_retry cabal update -v

80+ - "sed -i.bak 's/^jobs:/-- jobs:/' ${HOME}/.cabal/config"

81+ - rm -fv cabal.project cabal.project.local

82+ - grep -Ev -- '^\s*--' ${HOME}/.cabal/config | grep -Ev '^\s*$'

83+ - "printf 'packages: \".\"\\n' > cabal.project"

84+ - "printf 'write-ghc-environment-files: always\\n' >> cabal.project"

85+ - touch cabal.project.local

86+ - "if ! $NOINSTALLEDCONSTRAINTS; then for pkg in $($HCPKG list --simple-output); do echo $pkg | grep -vw -- postgresql-simple | sed 's/^/constraints: /' | sed 's/-[^-]*$/ installed/' >> cabal.project.local; done; fi"

87+ - cat cabal.project || true

88+ - cat cabal.project.local || true

89+ - if [ -f "./configure.ac" ]; then

90+ (cd "." && autoreconf -i);

91+ fi

92+ - rm -f cabal.project.freeze

93+ - cabal new-build -w ${HC} ${TEST} ${BENCH} --project-file="cabal.project" --dep -j2 all

94+ - cabal new-build -w ${HC} --disable-tests --disable-benchmarks --project-file="cabal.project" --dep -j2 all

95+ - rm -rf .ghc.environment.* "."/dist

96+ - DISTDIR=$(mktemp -d /tmp/dist-test.XXXX)

97+

98+# Here starts the actual work to be performed for the package under test;

99+# any command which exits with a non-zero exit code causes the build to fail.

100+script:

101+ # test that source-distributions can be generated

102+ - cabal new-sdist all

103+ - mv dist-newstyle/sdist/*.tar.gz ${DISTDIR}/

104+ - cd ${DISTDIR} || false

105+ - find . -maxdepth 1 -name '*.tar.gz' -exec tar -xvf '{}' \;

106+ - "printf 'packages: postgresql-simple-*/*.cabal\\n' > cabal.project"

107+ - "printf 'write-ghc-environment-files: always\\n' >> cabal.project"

108+ - touch cabal.project.local

109+ - "if ! $NOINSTALLEDCONSTRAINTS; then for pkg in $($HCPKG list --simple-output); do echo $pkg | grep -vw -- postgresql-simple | sed 's/^/constraints: /' | sed 's/-[^-]*$/ installed/' >> cabal.project.local; done; fi"

110+ - cat cabal.project || true

111+ - cat cabal.project.local || true

112+ # this builds all libraries and executables (without tests/benchmarks)

113+ - cabal new-build -w ${HC} --disable-tests --disable-benchmarks all

114+

115+ # build & run tests, build benchmarks

116+ - cabal new-build -w ${HC} ${TEST} ${BENCH} all

117+ - if [ "x$TEST" = "x--enable-tests" ]; then cabal new-test -w ${HC} ${TEST} ${BENCH} all; fi

118+

119+ # cabal check

120+ - (cd postgresql-simple-* && cabal check)

121+

122+ # haddock

123+ - if $HADDOCK; then cabal new-haddock -w ${HC} ${TEST} ${BENCH} all; else echo "Skipping haddock generation";fi

124+

125+ # Build without installed constraints for packages in global-db

126+ - if $UNCONSTRAINED; then rm -f cabal.project.local; echo cabal new-build -w ${HC} --disable-tests --disable-benchmarks all; else echo "Not building without installed constraints"; fi

127+

128+# REGENDATA ["--branch","master","--output",".travis.yml","postgresql-simple.cabal"]

129+# EOF

CHANGES.md+7−82

@@ -1,81 +1,6 @@

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

1+### Version 0.6 (2018-09-25)

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.

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

79

4

80 Consider a downstream library depending already both on

5 Consider a downstream library depending already both on

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

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

@@ -271,7 +196,7 @@

271 support UTF8 except for Mule Internal Code, the Multilingual

196 support UTF8 except for Mule Internal Code, the Multilingual

272 Extensions for Emacs. An exception should be raised upon

197 Extensions for Emacs. An exception should be raised upon

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

198 connecting to a database by the backend if the backend cannot

274− accommodate this requirement.

199+ accomodate this requirement.

275

200

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

201 * Added `Eq` and `Typeable` instances for `Connection`.

277

202

@@ -391,7 +316,7 @@

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

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

392

317

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

318### Version 0.4.2.2 (2014-05-15)

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

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

395

320

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

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

397 foldWithOptions, executeMany, and returning operators.

322 foldWithOptions, executeMany, and returning operators.

@@ -409,7 +334,7 @@

409

334

410 * Changed the Identifier and QualifiedIdentifier to use Text in

335 * Changed the Identifier and QualifiedIdentifier to use Text in

411 order to avoid encoding errors. Technically this requires a

336 order to avoid encoding errors. Technically this requires a

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

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

413

338

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

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

415 and tweaked error messages.

340 and tweaked error messages.

@@ -569,7 +494,7 @@

569

494

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

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

571 convenient and efficient access to the pg_type metatable. This

496 convenient and efficient access to the pg_type metatable. This

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

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

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

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

574 work on this feature.

499 work on this feature.

575

500

@@ -661,7 +586,7 @@

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

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

662

587

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

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

664− that accommodate PostgreSQL's infinities.

589+ that accomodate PostgreSQL's infinities.

665

590

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

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

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

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

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.

README.md+3

@@ -1,4 +1,7 @@

1+[![Continuous Integration status][status-png]][status]

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

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

2

3

4+ [status-png]: https://api.travis-ci.org/lpsmith/postgresql-simple.svg

5+ [status]: http://travis-ci.org/lpsmith/postgresql-simple?branch=master

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

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

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

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

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.project−2

@@ -1,4 +1,2 @@

1packages: .

2tests: 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+146−129

@@ -1,175 +1,192 @@

1−cabal-version: 1.12

1+Cabal-version: 1.12

2−name: postgresql-simple

2+Name: postgresql-simple

3−version: 0.7.0.0

3+Version: 0.6

4−x-revision: 1

4+

5−synopsis: Mid-Level PostgreSQL client library

5+Synopsis: Mid-Level PostgreSQL client library

6−description:

6+Description:

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

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

8−

8+License: BSD3

9−license: BSD3

10−license-file: LICENSE

9+License-file: LICENSE

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

10+Author: Bryan O'Sullivan, Leon P Smith

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

11+Maintainer: Oleg Grenrus <oleg.grenrus@iki.fi>

13−copyright:

17−

18−category: Database

15+Category: Database

19−build-type: Simple

16+Build-type: Simple

17+

20extra-source-files:

18extra-source-files:

21− CHANGES.md

22 CONTRIBUTORS

19 CONTRIBUTORS

20+ CHANGES.md

23 test/results/malformed-input.expected

21 test/results/malformed-input.expected

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

22 test/results/unique-constraint-violation.expected

25

23

26tested-with:

24tested-with:

27− GHC ==8.6.5

25+ GHC == 7.6.3

28− || ==8.8.4

26+ || == 7.8.4

29− || ==8.10.7

27+ || == 7.10.3

30− || ==9.0.2

28+ || == 8.0.2

31− || ==9.2.8

29+ || == 8.2.2

32− || ==9.4.8

30+ || == 8.4.4

33− || ==9.6.3

31+ || == 8.6.3

34− || ==9.8.1

32+

35−

33+Library

36−library

37− default-language: Haskell2010

34+ default-language: Haskell2010

38− hs-source-dirs: src

35+ hs-source-dirs: src

39− exposed-modules:

36+ Exposed-modules:

40− Database.PostgreSQL.Simple

37+ Database.PostgreSQL.Simple

41− Database.PostgreSQL.Simple.Arrays

38+ Database.PostgreSQL.Simple.Arrays

42− Database.PostgreSQL.Simple.Copy

39+ Database.PostgreSQL.Simple.Copy

43− Database.PostgreSQL.Simple.Cursor

40+ Database.PostgreSQL.Simple.Cursor

44− Database.PostgreSQL.Simple.Errors

45− Database.PostgreSQL.Simple.FromField

41+ Database.PostgreSQL.Simple.FromField

46− Database.PostgreSQL.Simple.FromRow

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

43+ Database.PostgreSQL.Simple.LargeObjects

51− Database.PostgreSQL.Simple.Newtypes

44+ Database.PostgreSQL.Simple.HStore

45+ Database.PostgreSQL.Simple.HStore.Internal

52− Database.PostgreSQL.Simple.Notification

46+ Database.PostgreSQL.Simple.Notification

53− Database.PostgreSQL.Simple.Ok

47+ Database.PostgreSQL.Simple.Ok

54− Database.PostgreSQL.Simple.Range

48+ Database.PostgreSQL.Simple.Range

55− Database.PostgreSQL.Simple.SqlQQ

49+ Database.PostgreSQL.Simple.SqlQQ

56− Database.PostgreSQL.Simple.Time

50+ Database.PostgreSQL.Simple.Time

57− Database.PostgreSQL.Simple.Time.Internal

51+ Database.PostgreSQL.Simple.Time.Internal

58− Database.PostgreSQL.Simple.ToField

52+ Database.PostgreSQL.Simple.ToField

59− Database.PostgreSQL.Simple.ToRow

53+ Database.PostgreSQL.Simple.ToRow

60− Database.PostgreSQL.Simple.Transaction

54+ Database.PostgreSQL.Simple.Transaction

61− Database.PostgreSQL.Simple.TypeInfo

55+ Database.PostgreSQL.Simple.TypeInfo

62− Database.PostgreSQL.Simple.TypeInfo.Macro

56+ Database.PostgreSQL.Simple.TypeInfo.Macro

63− Database.PostgreSQL.Simple.TypeInfo.Static

57+ Database.PostgreSQL.Simple.TypeInfo.Static

64− Database.PostgreSQL.Simple.Types

58+ Database.PostgreSQL.Simple.Types

65− Database.PostgreSQL.Simple.Vector

59+ Database.PostgreSQL.Simple.Errors

60+ Database.PostgreSQL.Simple.Vector

66− Database.PostgreSQL.Simple.Vector.Unboxed

61+ Database.PostgreSQL.Simple.Vector.Unboxed

67−

62+

68− -- Other-modules:

63+-- Other-modules:

64+ Database.PostgreSQL.Simple.Internal

65+

69− other-modules:

66+ Other-modules:

70− Database.PostgreSQL.Simple.Compat

67+ Database.PostgreSQL.Simple.Compat

71− Database.PostgreSQL.Simple.HStore.Implementation

68+ Database.PostgreSQL.Simple.HStore.Implementation

72− Database.PostgreSQL.Simple.Internal.PQResultUtils

69+ Database.PostgreSQL.Simple.Internal.PQResultUtils

73− Database.PostgreSQL.Simple.Time.Implementation

70+ Database.PostgreSQL.Simple.Time.Implementation

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

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

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

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

76− Database.PostgreSQL.Simple.TypeInfo.Types

73+ Database.PostgreSQL.Simple.TypeInfo.Types

77

74

78 -- GHC bundled libs

75 -- GHC bundled libs

79− build-depends:

76+ Build-depends:

80− base >=4.12.0.0 && <4.20

77+ base >=4.6.0.0 && <4.13

81− , bytestring >=0.10.8.2 && <0.13

78+ , bytestring >=0.10.0.0 && <0.11

82− , containers >=0.6.0.1 && <0.7

79+ , containers >=0.5.0.0 && <0.7

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

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

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

80+ , time >=1.4.0.1 && <1.9

86− , transformers >=0.5.6.2 && <0.7

81+ , transformers >=0.3.0.0 && <0.6

82+ , template-haskell >=2.8.0.0 && <2.15

83+ , text >=1.2.3.0 && <1.3

87

84

88 -- Other dependencies

85 -- Other dependencies

89− build-depends:

86+ Build-depends:

90− aeson >=2.1.2.1 && <2.3

87+ aeson >=1.4.1.0 && <1.5

91− , attoparsec >=0.14.4 && <0.15

88+ , attoparsec >=0.13.2.2 && <0.14

89+ , bytestring-builder >=0.10.8.1.0 && <0.11

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

90+ , case-insensitive >=1.2.0.11 && <1.3

93− , hashable >=1.4.3.0 && <1.5

91+ , hashable >=1.2.7.0 && <1.3

94− , Only >=0.1 && <0.1.1

92+ , Only >=0.1 && <0.1.1

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

93+ , postgresql-libpq >=0.9.4.2 && < 0.10

96− , scientific >=0.3.7.0 && <0.4

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

94+ , uuid-types >=1.0.3 && <1.1

95+ , scientific >=0.3.6.2 && <0.4

98− , vector >=0.13.0.0 && <0.14

96+ , vector >=0.12.0.1 && <0.13

97+

98+ if !impl(ghc >= 8.0)

99+ Build-depends:

100+ semigroups >=0.18.5 && <0.19

101+

102+ if !impl(ghc >= 7.6)

103+ Build-depends:

104+ ghc-prim

99

105

100 default-extensions:

106 default-extensions:

101− BangPatterns

102 DoAndIfThenElse

107 DoAndIfThenElse

103 OverloadedStrings

108 OverloadedStrings

104− TypeOperators

109+ BangPatterns

105 ViewPatterns

110 ViewPatterns

111+ TypeOperators

106

112

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

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

108

114

109source-repository head

115source-repository head

110 type: git

116 type: git

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

117+ location: http://github.com/phadej/postgresql-simple

118+

119+source-repository this

120+ type: git

121+ location: http://github.com/phadej/postgresql-simple

122+ tag: v0.6

112

123

113test-suite inspection

124test-suite inspection

125+ if !impl(ghc >= 8.0)

126+ buildable: False

127+

114 default-language: Haskell2010

128 default-language: Haskell2010

115− type: exitcode-stdio-1.0

129+ type: exitcode-stdio-1.0

116− hs-source-dirs: test

130+ hs-source-dirs: test

117− main-is: Inspection.hs

131+ main-is: Inspection.hs

118 build-depends:

132 build-depends:

119 base

133 base

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

134+ , inspection-testing >=0.4.1.1 && <0.5

121− , postgresql-libpq

122 , postgresql-simple

135 , postgresql-simple

136+ , postgresql-libpq

123 , tasty

137 , tasty

124 , tasty-hunit

138 , tasty-hunit

125

139

126test-suite test

140test-suite test

127− default-language: Haskell2010

141+ default-language: Haskell2010

128− type: exitcode-stdio-1.0

142+ type: exitcode-stdio-1.0

143+

129− hs-source-dirs: test

144+ hs-source-dirs: test

130− main-is: Main.hs

145+ main-is: Main.hs

131 other-modules:

146 other-modules:

132 Common

147 Common

133− Exception

134− Interval

135 Notify

148 Notify

136 Serializable

149 Serializable

137 Time

150 Time

138

151

139− ghc-options: -threaded

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

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

153+

141 default-extensions:

154 default-extensions:

142 NamedFieldPuns

155 NamedFieldPuns

143 OverloadedStrings

156 OverloadedStrings

144− PatternGuards

145 Rank2Types

157 Rank2Types

146 RecordWildCards

158 RecordWildCards

159+ PatternGuards

147 ScopedTypeVariables

160 ScopedTypeVariables

148

161

149− build-depends:

162+ build-depends: base

150− aeson

163+ , aeson

151− , base

152− , base16-bytestring

164+ , base16-bytestring

153− , bytestring

165+ , bytestring

154− , case-insensitive

155− , containers

166+ , containers

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

167+ , cryptohash

157− , filepath

168+ , filepath

169+ , tasty

170+ , tasty-hunit

171+ , tasty-golden

158− , HUnit

172+ , HUnit

159− , postgresql-simple

173+ , postgresql-simple

160− , tasty

161− , tasty-golden

162− , tasty-hunit

163− , text

174+ , text

164− , time-compat

175+ , time

165− , vector

176+ , vector

177+ , case-insensitive

178+

179+ if !impl(ghc >= 7.6)

180+ build-depends:

181+ ghc-prim

166

182

167benchmark select

183benchmark select

168 default-language: Haskell2010

184 default-language: Haskell2010

169 type: exitcode-stdio-1.0

185 type: exitcode-stdio-1.0

186+

170− hs-source-dirs: bench

187+ hs-source-dirs: bench

171− main-is: Select.hs

188+ main-is: Select.hs

189+

172− build-depends:

190+ build-depends: base

173− base

174− , postgresql-simple

191+ , postgresql-simple

175− , vector

192+ , vector

src/Database/PostgreSQL/Simple.hs+10−22

@@ -64,7 +64,6 @@ module Database.PostgreSQL.Simple

64 , Only(..)

65 , (:.)(..)

66 -- ** Exceptions

67− , SomePostgreSqlException(..)

68 , SqlError(..)

67 , SqlError(..)

69 , PQ.ExecStatus(..)

68 , PQ.ExecStatus(..)

70 , FormatError(..)

69 , FormatError(..)

@@ -74,7 +73,6 @@ module Database.PostgreSQL.Simple

74 , Base.connectPostgreSQL

73 , Base.connectPostgreSQL

75 , Base.close

74 , Base.close

76 , Base.connect

75 , Base.connect

77− , Base.withConnect

78 , Base.ConnectInfo(..)

76 , Base.ConnectInfo(..)

79 , Base.defaultConnectInfo

77 , Base.defaultConnectInfo

80 , Base.postgreSQLConnectionString

78 , Base.postgreSQLConnectionString

@@ -278,31 +276,21 @@ parseTemplate template =

278 skipSpace = B.dropWhile isSpace_ascii

276 skipSpace = B.dropWhile isSpace_ascii

279

277

280

278

279+

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

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

282buildQuery conn q template xs =

281buildQuery conn q template xs =

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

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

284 where split s =

283 where split s =

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

284+ let (h,t) = B.break (=='?') s

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

287− let (h,t) = breakOnSingleQuestionMark s

288 in byteString h

285 in byteString h

289 : if B.null t

286 : if B.null t

290 then []

287 then []

291 else split (B.tail t)

288 else split (B.tail t)

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

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

293 zipParams [t] [] = t

290 zipParams [t] [] = t

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

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

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

292+ " '?' characters, but " ++

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

293 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

294

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

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

308-- expected to return results.

296-- expected to return results.

@@ -340,7 +328,7 @@ execute conn template qs = do

340-- @

328-- @

341-- executeMany c [sql|

329-- executeMany c [sql|

342-- UPDATE sometable

330-- UPDATE sometable

343−-- SET y = upd.y

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

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

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

345-- WHERE sometable.x = upd.x

333-- WHERE sometable.x = upd.x

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

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

@@ -533,7 +521,7 @@ foldWithOptions_ :: (FromRow r) =>

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

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

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

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

535 -> IO a

523 -> IO a

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

524+foldWithOptions_ opts conn query a f = doFold opts fromRow conn query query a f

537

525

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

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

539foldWithOptionsAndParser_ :: FoldOptions

527foldWithOptionsAndParser_ :: FoldOptions

@@ -543,7 +531,7 @@ foldWithOptionsAndParser_ :: FoldOptions

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

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

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

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

545 -> IO a

533 -> IO a

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

534+foldWithOptionsAndParser_ opts parser conn query a f = doFold opts parser conn query query a f

547

535

548doFold :: FoldOptions

536doFold :: FoldOptions

549 -> RowParser row

537 -> RowParser row

@@ -579,8 +567,8 @@ doFold FoldOptions{..} parser conn _template q a0 f = do

579 go = bracket declare closeCursor $ \cursor ->

567 go = bracket declare closeCursor $ \cursor ->

580 let loop a = fetch cursor a >>=

568 let loop a = fetch cursor a >>=

581 \r -> case r of

569 \r -> case r of

582− Left x -> return x

570+ Left a -> return a

583− Right x -> loop x

571+ Right a -> loop a

584 in loop a0

572 in loop a0

585

573

586-- FIXME: choose the Automatic chunkSize more intelligently

574-- FIXME: choose the Automatic chunkSize more intelligently

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

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

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

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

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

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

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

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

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

906--

894--

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

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

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

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

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

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

42quoted :: Parser ByteString

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

44 where

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

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

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

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

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.

src/Database/PostgreSQL/Simple/Compat.hs+53

@@ -12,13 +12,36 @@ module Database.PostgreSQL.Simple.Compat

12 ) where

13

14import qualified Control.Exception as E

15+import Data.Monoid

15import Data.ByteString (ByteString)

16import Data.ByteString (ByteString)

17+#if MIN_VERSION_bytestring(0,10,0)

16import Data.ByteString.Lazy (toStrict)

18import Data.ByteString.Lazy (toStrict)

19+#else

20+import qualified Data.ByteString as B

21+import Data.ByteString.Lazy (toChunks)

22+#endif

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

23import Data.ByteString.Builder (Builder, toLazyByteString)

24+

25+#if MIN_VERSION_scientific(0,3,0)

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

26import Data.Text.Lazy.Builder.Scientific (scientificBuilder)

27+#else

28+import Data.Scientific (scientificBuilder)

29+#endif

30+

31+#if __GLASGOW_HASKELL__ >= 702

19import System.IO.Unsafe (unsafeDupablePerformIO)

32import System.IO.Unsafe (unsafeDupablePerformIO)

33+#elif __GLASGOW_HASKELL__ >= 611

34+import GHC.IO (unsafeDupablePerformIO)

35+#else

36+import GHC.IOBase (unsafeDupablePerformIO)

37+#endif

38+

20import Data.Fixed (Pico)

39import Data.Fixed (Pico)

40+#if MIN_VERSION_base(4,7,0)

21import Data.Fixed (Fixed(MkFixed))

41import Data.Fixed (Fixed(MkFixed))

42+#else

43+import Unsafe.Coerce (unsafeCoerce)

44+#endif

22

45

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

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

24--

47--

@@ -28,14 +51,44 @@ import Data.Fixed (Fixed(MkFixed))

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

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

29-- don't need that polymorphism.

52-- don't need that polymorphism.

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

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

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

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

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

56+#else

57+mask io = do

58+ b <- E.blocked

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

60+#endif

32{-# INLINE mask #-}

61{-# INLINE mask #-}

33

62

63+#if !MIN_VERSION_base(4,5,0)

64+infixr 6 <>

65+

66+(<>) :: Monoid m => m -> m -> m

67+(<>) = mappend

68+{-# INLINE (<>) #-}

69+#endif

70+

34toByteString :: Builder -> ByteString

71toByteString :: Builder -> ByteString

72+#if MIN_VERSION_bytestring(0,10,0)

35toByteString x = toStrict (toLazyByteString x)

73toByteString x = toStrict (toLazyByteString x)

74+#else

75+toByteString x = B.concat (toChunks (toLazyByteString x))

76+#endif

77+

78+#if MIN_VERSION_base(4,7,0)

36

79

37toPico :: Integer -> Pico

80toPico :: Integer -> Pico

38toPico = MkFixed

81toPico = MkFixed

39

82

40fromPico :: Pico -> Integer

83fromPico :: Pico -> Integer

41fromPico (MkFixed i) = i

84fromPico (MkFixed i) = i

85+

86+#else

87+

88+toPico :: Integer -> Pico

89+toPico = unsafeCoerce

90+

91+fromPico :: Pico -> Integer

92+fromPico = unsafeCoerce

93+

94+#endif

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

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

32 ( copy

33 , copy_

34 , CopyOutResult(..)

35− , foldCopyData

36 , getCopyData

35 , getCopyData

37 , putCopyData

36 , putCopyData

38 , putCopyEnd

37 , putCopyEnd

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

49import qualified Database.PostgreSQL.LibPQ as PQ

48import qualified Database.PostgreSQL.LibPQ as PQ

50import Database.PostgreSQL.Simple

49import Database.PostgreSQL.Simple

51import Database.PostgreSQL.Simple.Types

50import Database.PostgreSQL.Simple.Types

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

51+import Database.PostgreSQL.Simple.Internal

53

52

54

53

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

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

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

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

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

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

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

59

58

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

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

61copy conn template qs = do

60copy conn template qs = do

@@ -86,8 +85,12 @@ doCopy funcName conn template q = do

86 PQ.TuplesOk -> err

85 PQ.TuplesOk -> err

87 PQ.CopyOut -> return ()

86 PQ.CopyOut -> return ()

88 PQ.CopyIn -> return ()

87 PQ.CopyIn -> return ()

88+#if MIN_VERSION_postgresql_libpq(0,9,3)

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

90+#endif

91+#if MIN_VERSION_postgresql_libpq(0,9,2)

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

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

93+#endif

91 PQ.BadResponse -> throwResultError funcName result status

94 PQ.BadResponse -> throwResultError funcName result status

92 PQ.NonfatalError -> throwResultError funcName result status

95 PQ.NonfatalError -> throwResultError funcName result status

93 PQ.FatalError -> throwResultError funcName result status

96 PQ.FatalError -> throwResultError funcName result status

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

101 deriving (Eq, Typeable, Show)

104 deriving (Eq, Typeable, Show)

102

105

103

106

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

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

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

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

src/Database/PostgreSQL/Simple/Cursor.hs+5−5

@@ -30,7 +30,7 @@ import Data.Monoid (mconcat)

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

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

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

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

33+import Database.PostgreSQL.Simple.Internal as Base

34import Database.PostgreSQL.Simple.Internal.PQResultUtils

35import Database.PostgreSQL.Simple.Transaction

36import qualified Database.PostgreSQL.LibPQ as PQ

@@ -90,9 +90,9 @@ foldForward cursor = foldForwardWithParser cursor fromRow

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

91foldM' f a lo hi = loop a lo

92 where

93− loop x !n

93+ loop a !n

94− | n > hi = return x

94+ | n > hi = return a

95 | otherwise = do

96− x' <- f x n

96+ a' <- f a n

97− loop x' (n+1)

97+ loop a' (n+1)

98{-# INLINE foldM' #-}

src/Database/PostgreSQL/Simple/Errors.hs+3−4

@@ -25,6 +25,7 @@ module Database.PostgreSQL.Simple.Errors

25 )

26 where

27

28+import Control.Applicative

28import Control.Exception as E

29import Control.Exception as E

29

30

30import Data.Attoparsec.ByteString.Char8

31import Data.Attoparsec.ByteString.Char8

@@ -59,13 +60,11 @@ data ConstraintViolation

59 deriving (Show, Eq, Ord, Typeable)

60 deriving (Show, Eq, Ord, Typeable)

60

61

61-- Default instance should be enough

62-- Default instance should be enough

62−instance Exception ConstraintViolation where

63+instance Exception ConstraintViolation

63− toException = postgresqlExceptionToException

64− fromException = postgresqlExceptionFromException

65

64

66

65

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

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

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

67+-- succeedes only if able to parse sqlErrorMsg.

69--

68--

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

69-- > createUser = handleJust constraintViolation handler $ execute conn ...

71-- > where

70-- > where

src/Database/PostgreSQL/Simple/FromField.hs+33−70

@@ -2,7 +2,6 @@

2{-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-}

3{-# LANGUAGE PatternGuards, ScopedTypeVariables #-}

4{-# LANGUAGE RecordWildCards #-}

5−{-# LANGUAGE PolyKinds #-}

6

5

7{- |

6{- |

8Module: Database.PostgreSQL.Simple.FromField

7Module: Database.PostgreSQL.Simple.FromField

@@ -107,27 +106,26 @@ module Database.PostgreSQL.Simple.FromField

107 , PQ.Oid(..)

106 , PQ.Oid(..)

108 , PQ.Format(..)

107 , PQ.Format(..)

109 , pgArrayFieldParser

108 , pgArrayFieldParser

110− , attoFieldParser

111

109

112 , optionalField

110 , optionalField

113 , fromJSONField

111 , fromJSONField

114− , fromFieldJSONByteString

115 ) where

112 ) where

116

113

117#include "MachDeps.h"

114#include "MachDeps.h"

118

115

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

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

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

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

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

118+import Control.Exception (Exception)

122import qualified Data.Aeson as JSON

119import qualified Data.Aeson as JSON

120+import qualified Data.Aeson.Internal as JSON

121+import qualified Data.Aeson.Parser as JSON (value')

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

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

124import Data.ByteString (ByteString)

123import Data.ByteString (ByteString)

125import qualified Data.ByteString.Char8 as B

124import qualified Data.ByteString.Char8 as B

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

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

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

128import Data.IORef (IORef, newIORef)

126import Data.IORef (IORef, newIORef)

129import Data.Ratio (Ratio)

127import Data.Ratio (Ratio)

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

128+import Data.Time ( UTCTime, ZonedTime, LocalTime, Day, TimeOfDay )

131import Data.Typeable (Typeable, typeOf)

129import Data.Typeable (Typeable, typeOf)

132import Data.Vector (Vector)

130import Data.Vector (Vector)

133import Data.Vector.Mutable (IOVector)

131import Data.Vector.Mutable (IOVector)

@@ -154,8 +152,6 @@ import qualified Data.UUID.Types as UUID

154import Data.Scientific (Scientific)

152import Data.Scientific (Scientific)

155import GHC.Real (infinity, notANumber)

153import GHC.Real (infinity, notANumber)

156

154

157−import qualified Data.Aeson.Types as JSON

158−

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

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

160-- value fails.

156-- value fails.

161data ResultError = Incompatible { errSQLType :: String

157data ResultError = Incompatible { errSQLType :: String

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

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

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

183 deriving (Eq, Show, Typeable)

179 deriving (Eq, Show, Typeable)

184

180

185−instance Exception ResultError where

181+instance Exception ResultError

186− toException = postgresqlExceptionToException

187− fromException = postgresqlExceptionFromException

188

182

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

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

190left = conversionError

184left = conversionError

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

250 then Nothing

244 then Nothing

251 else Just x

245 else Just x

252

246

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

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

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

248+-- off the associated table column. Numbering starts from 0. Analogous

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

249+-- to libpq's @PQftablecol@.

258

250

259tableColumn :: Field -> Int

251tableColumn :: Field -> Int

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

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

@@ -273,12 +265,6 @@ instance FromField () where

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

265 | typeOid f /= TI.voidOid = returnError Incompatible f ""

274 | otherwise = pure ()

266 | otherwise = pure ()

275

267

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

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

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

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

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

@@ -314,9 +300,9 @@ instance FromField Bool where

314

300

315-- | \"char\", bpchar

301-- | \"char\", bpchar

316instance FromField Char where

302instance FromField Char where

317− fromField f bs0 =

303+ fromField f bs =

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

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

319− then case bs0 of

305+ then case bs of

320 Nothing -> returnError UnexpectedNull f ""

306 Nothing -> returnError UnexpectedNull f ""

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

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

322 then returnError ConversionFailed f "length not 1"

308 then returnError ConversionFailed f "length not 1"

@@ -325,11 +311,11 @@ instance FromField Char where

325

311

326-- | int2

312-- | int2

327instance FromField Int16 where

313instance FromField Int16 where

328− fromField = attoFieldParser ok16 $ signed decimal

314+ fromField = atto ok16 $ signed decimal

329

315

330-- | int2, int4

316-- | int2, int4

331instance FromField Int32 where

317instance FromField Int32 where

332− fromField = attoFieldParser ok32 $ signed decimal

318+ fromField = atto ok32 $ signed decimal

333

319

334#if WORD_SIZE_IN_BITS < 64

320#if WORD_SIZE_IN_BITS < 64

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

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

@@ -339,36 +325,36 @@ instance FromField Int32 where

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

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

340#endif

326#endif

341instance FromField Int where

327instance FromField Int where

342− fromField = attoFieldParser okInt $ signed decimal

328+ fromField = atto okInt $ signed decimal

343

329

344-- | int2, int4, int8

330-- | int2, int4, int8

345instance FromField Int64 where

331instance FromField Int64 where

346− fromField = attoFieldParser ok64 $ signed decimal

332+ fromField = atto ok64 $ signed decimal

347

333

348-- | int2, int4, int8

334-- | int2, int4, int8

349instance FromField Integer where

335instance FromField Integer where

350− fromField = attoFieldParser ok64 $ signed decimal

336+ fromField = atto ok64 $ signed decimal

351

337

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

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

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

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

354instance FromField Float where

340instance FromField Float where

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

341+ fromField = atto ok (realToFrac <$> pg_double)

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

342 where ok = eq TI.float4Oid \/ eq TI.int2Oid

357

343

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

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

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

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

360instance FromField Double where

346instance FromField Double where

361− fromField = attoFieldParser ok pg_double

347+ fromField = atto ok pg_double

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

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

363

349

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

350-- | int2, int4, int8, float4, float8, numeric

365instance FromField (Ratio Integer) where

351instance FromField (Ratio Integer) where

366− fromField = attoFieldParser ok pg_rational

352+ fromField = atto ok pg_rational

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

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

368

354

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

355-- | int2, int4, int8, float4, float8, numeric

370instance FromField Scientific where

356instance FromField Scientific where

371− fromField = attoFieldParser ok rational

357+ fromField = atto ok rational

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

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

373

359

374unBinary :: Binary t -> t

360unBinary :: Binary t -> t

@@ -396,7 +382,7 @@ instance FromField SB.ByteString where

396

382

397-- | oid

383-- | oid

398instance FromField PQ.Oid where

384instance FromField PQ.Oid where

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

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

400

386

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

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

402instance FromField LB.ByteString where

388instance FromField LB.ByteString where

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

404

390

405unescapeBytea :: Field -> SB.ByteString

391unescapeBytea :: Field -> SB.ByteString

406 -> Conversion (Binary SB.ByteString)

392 -> Conversion (Binary SB.ByteString)

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

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

408 Nothing -> returnError ConversionFailed f "unescapeBytea failed"

394 Nothing -> returnError ConversionFailed f "unescapeBytea failed"

409 Just str -> pure (Binary str)

395 Just str -> pure (Binary str)

410

396

@@ -489,23 +475,14 @@ instance FromField LocalTimestamp where

489instance FromField Date where

475instance FromField Date where

490 fromField = ff TI.dateOid "Date" parseDate

476 fromField = ff TI.dateOid "Date" parseDate

491

477

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−

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

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

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

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

503−ff compatOid hsType parseBS f mstr =

480+ff compatOid hsType parse f mstr =

504 if typeOid f /= compatOid

481 if typeOid f /= compatOid

505 then err Incompatible ""

482 then err Incompatible ""

506 else case mstr of

483 else case mstr of

507 Nothing -> err UnexpectedNull ""

484 Nothing -> err UnexpectedNull ""

508− Just str -> case parseBS str of

485+ Just str -> case parse str of

509 Left msg -> err ConversionFailed msg

486 Left msg -> err ConversionFailed msg

510 Right val -> return val

487 Right val -> return val

511 where

488 where

@@ -543,10 +520,10 @@ pgArrayFieldParser fieldParser f mdat = do

543 _ -> returnError Incompatible f ""

520 _ -> returnError Incompatible f ""

544

521

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

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

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

523+fromArray fieldParser typeInfo f = sequence . (parseIt <$>) <$> array delim

547 where

524 where

548− delim = typdelim (typelem typInfo)

525+ delim = typdelim (typelem typeInfo)

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

526+ fElem = f{ typeOid = typoid (typelem typeInfo) }

550

527

551 parseIt item =

528 parseIt item =

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

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

@@ -575,14 +552,12 @@ instance FromField UUID where

575

552

576-- | json, jsonb

553-- | json, jsonb

577instance FromField JSON.Value where

554instance FromField JSON.Value where

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

555+ fromField f mbs = parse =<< fromFieldJSONByteString f mbs

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

556+ where parse bs = case parseOnly (JSON.value' <* endOfInput) bs of

580 Left err -> returnError ConversionFailed f err

557 Left err -> returnError ConversionFailed f err

581 Right val -> pure val

558 Right val -> pure val

582

559

583-- | Return the JSON ByteString directly

560-- | Return the JSON ByteString directly

584−--

585−-- @since 0.6.3

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

561fromFieldJSONByteString :: Field -> Maybe ByteString -> Conversion ByteString

587fromFieldJSONByteString f mbs =

562fromFieldJSONByteString f mbs =

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

563 if typeOid f /= TI.jsonOid && typeOid f /= TI.jsonbOid

@@ -684,22 +659,10 @@ returnError mkErr f msg = do

684 (show (typeOf (undefined :: a)))

659 (show (typeOf (undefined :: a)))

685 msg

660 msg

686

661

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)

662+atto :: forall a. (Typeable a)

697− => (PQ.Oid -> Bool)

663+ => Compat -> Parser a -> Field -> Maybe ByteString

698− -- ^ Predicate for whether the postgresql type oid is compatible with this parser

664+ -> Conversion a

699− -> Parser a

700− -- ^ An attoparsec parser.

701− -> FieldParser a

702−attoFieldParser types p0 f dat = doFromField f types (go p0) dat

665+atto types p0 f dat = doFromField f types (go p0) dat

703 where

666 where

704 go :: Parser a -> ByteString -> Conversion a

667 go :: Parser a -> ByteString -> Conversion a

705 go p s =

668 go p s =

src/Database/PostgreSQL/Simple/FromRow.hs+2−2

@@ -131,8 +131,8 @@ fieldWith fieldP = RP $ do

131 else do

132 let !result = rowresult

133 !typeOid = unsafeDupablePerformIO (PQ.ftype result column)

134− !field' = Field{..}

134+ !field = Field{..}

135− lift (lift (fieldP field' (getvalue result row column)))

135+ lift (lift (fieldP field (getvalue result row column)))

136

137field :: FromField a => RowParser a

138field = fieldWith fromField

src/Database/PostgreSQL/Simple/HStore/Implementation.hs+9−3

@@ -22,6 +22,9 @@ import Data.ByteString.Builder (Builder, byteString, char8)

22import qualified Data.ByteString.Builder as BU

23import Data.ByteString.Internal (c2w, w2c)

24import qualified Data.ByteString.Lazy as BL

25+#if !MIN_VERSION_bytestring(0,10,0)

26+import qualified Data.ByteString.Lazy.Internal as BL (foldrChunks)

27+#endif

25import Data.Map(Map)

28import Data.Map(Map)

26import qualified Data.Map as Map

29import qualified Data.Map as Map

27import Data.Text(Text)

30import Data.Text(Text)

@@ -50,12 +53,12 @@ instance ToHStore HStoreBuilder where

50toBuilder :: HStoreBuilder -> Builder

53toBuilder :: HStoreBuilder -> Builder

51toBuilder x = case x of

54toBuilder x = case x of

52 Empty -> mempty

55 Empty -> mempty

53− Comma c -> c

56+ Comma x -> x

54

57

55toLazyByteString :: HStoreBuilder -> BL.ByteString

58toLazyByteString :: HStoreBuilder -> BL.ByteString

56toLazyByteString x = case x of

59toLazyByteString x = case x of

57 Empty -> BL.empty

60 Empty -> BL.empty

58− Comma c -> BU.toLazyByteString c

61+ Comma x -> BU.toLazyByteString x

59

62

60instance Semigroup HStoreBuilder where

63instance Semigroup HStoreBuilder where

61 Empty <> x = x

64 Empty <> x = x

@@ -66,6 +69,9 @@ instance Semigroup HStoreBuilder where

66

69

67instance Monoid HStoreBuilder where

70instance Monoid HStoreBuilder where

68 mempty = Empty

71 mempty = Empty

72+#if !(MIN_VERSION_base(4,11,0))

73+ mappend = (<>)

74+#endif

69

75

70class ToHStoreText a where

76class ToHStoreText a where

71 toHStoreText :: a -> HStoreText

77 toHStoreText :: a -> HStoreText

@@ -144,7 +150,7 @@ newtype HStoreMap = HStoreMap {fromHStoreMap :: Map Text Text} deriving (Eq, Or

144

150

145instance ToHStore HStoreMap where

151instance ToHStore HStoreMap where

146 toHStore (HStoreMap xs) = Map.foldrWithKey f mempty xs

152 toHStore (HStoreMap xs) = Map.foldrWithKey f mempty xs

147− where f k v xs' = hstore k v `mappend` xs'

153+ where f k v xs = hstore k v `mappend` xs

148

154

149instance ToField HStoreMap where

155instance ToField HStoreMap where

150 toField xs = toField (toHStore xs)

156 toField xs = toField (toHStore xs)

src/Database/PostgreSQL/Simple/Internal.hs+13−59

@@ -1,8 +1,6 @@

1{-# LANGUAGE CPP, BangPatterns, DoAndIfThenElse, RecordWildCards #-}

2{-# LANGUAGE DeriveDataTypeable, DeriveGeneric #-}

3{-# LANGUAGE GeneralizedNewtypeDeriving #-}

4−{-# LANGUAGE ExistentialQuantification #-}

5−{-# LANGUAGE InstanceSigs #-}

6

4

7------------------------------------------------------------------------------

5------------------------------------------------------------------------------

8-- |

6-- |

@@ -36,6 +34,7 @@ import Data.Int (Int64)

36import qualified Data.IntMap as IntMap

34import qualified Data.IntMap as IntMap

37import Data.IORef

35import Data.IORef

38import Data.Maybe(fromMaybe)

36import Data.Maybe(fromMaybe)

37+import Data.Monoid

39import Data.String

38import Data.String

40import qualified Data.Text as T

39import qualified Data.Text as T

41import qualified Data.Text.Encoding as TE

40import qualified Data.Text.Encoding as TE

@@ -83,25 +82,6 @@ data Connection = Connection {

83instance Eq Connection where

82instance Eq Connection where

84 x == y = connectionHandle x == connectionHandle y

83 x == y = connectionHandle x == connectionHandle y

85

84

86−-- | Superclass for postgresql exceptions

87−data SomePostgreSqlException = forall e. Exception e => SomePostgreSqlException e

88− deriving Typeable

89−

90−postgresqlExceptionToException :: Exception e => e -> SomeException

91−postgresqlExceptionToException = toException . SomePostgreSqlException

92−

93−postgresqlExceptionFromException :: Exception e => SomeException -> Maybe e

94−postgresqlExceptionFromException x = do

95− SomePostgreSqlException a <- fromException x

96− cast a

97−

98−instance Show SomePostgreSqlException where

99− showsPrec :: Int -> SomePostgreSqlException -> ShowS

100− showsPrec p (SomePostgreSqlException e) = showsPrec p e

101−

102−instance Exception SomePostgreSqlException where

103− displayException (SomePostgreSqlException e) = displayException e

104−

105data SqlError = SqlError {

85data SqlError = SqlError {

106 sqlState :: ByteString

86 sqlState :: ByteString

107 , sqlExecStatus :: ExecStatus

87 , sqlExecStatus :: ExecStatus

@@ -113,10 +93,7 @@ data SqlError = SqlError {

113fatalError :: ByteString -> SqlError

93fatalError :: ByteString -> SqlError

114fatalError msg = SqlError "" FatalError msg "" ""

94fatalError msg = SqlError "" FatalError msg "" ""

115

95

116−instance Exception SqlError where

96+instance Exception SqlError

117− toException = postgresqlExceptionToException

118− fromException = postgresqlExceptionFromException

119−

120

97

121-- | Exception thrown if 'query' is used to perform an @INSERT@-like

98-- | Exception thrown if 'query' is used to perform an @INSERT@-like

122-- operation, or 'execute' is used to perform a @SELECT@-like operation.

99-- operation, or 'execute' is used to perform a @SELECT@-like operation.

@@ -125,9 +102,7 @@ data QueryError = QueryError {

125 , qeQuery :: Query

102 , qeQuery :: Query

126 } deriving (Eq, Show, Typeable)

103 } deriving (Eq, Show, Typeable)

127

104

128−instance Exception QueryError where

105+instance Exception QueryError

129− toException = postgresqlExceptionToException

130− fromException = postgresqlExceptionFromException

131

106

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

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

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

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

@@ -138,9 +113,7 @@ data FormatError = FormatError {

138 , fmtParams :: [ByteString]

113 , fmtParams :: [ByteString]

139 } deriving (Eq, Show, Typeable)

114 } deriving (Eq, Show, Typeable)

140

115

141−instance Exception FormatError where

116+instance Exception FormatError

142− toException = postgresqlExceptionToException

143− fromException = postgresqlExceptionFromException

144

117

145data ConnectInfo = ConnectInfo {

118data ConnectInfo = ConnectInfo {

146 connectHost :: String

119 connectHost :: String

@@ -182,12 +155,6 @@ defaultConnectInfo = ConnectInfo {

182connect :: ConnectInfo -> IO Connection

155connect :: ConnectInfo -> IO Connection

183connect = connectPostgreSQL . postgreSQLConnectionString

156connect = connectPostgreSQL . postgreSQLConnectionString

184

157

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.

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

159-- See <https://www.postgresql.org/docs/9.5/static/libpq-connect.html#LIBPQ-CONNSTRING>

193-- for more information. Also note that environment variables also affect

160-- for more information. Also note that environment variables also affect

@@ -323,7 +290,7 @@ postgreSQLConnectionString connectInfo = fromString connstr

323

290

324 str name field

291 str name field

325 | null value = id

292 | null value = id

326− | otherwise = showString name . addQuotes value . space

293+ | otherwise = showString name . quote value . space

327 where value = field connectInfo

294 where value = field connectInfo

328

295

329 num name field

296 num name field

@@ -331,7 +298,7 @@ postgreSQLConnectionString connectInfo = fromString connstr

331 | otherwise = showString name . shows value . space

298 | otherwise = showString name . shows value . space

332 where value = field connectInfo

299 where value = field connectInfo

333

300

334− addQuotes s rest = '\'' : foldr delta ('\'' : rest) s

301+ quote str rest = '\'' : foldr delta ('\'' : rest) str

335 where

302 where

336 delta c cs = case c of

303 delta c cs = case c of

337 '\\' -> '\\' : '\\' : cs

304 '\\' -> '\\' : '\\' : cs

@@ -419,7 +386,7 @@ finishExecute _conn q result = do

419 nstr <- PQ.cmdTuples result

386 nstr <- PQ.cmdTuples result

420 return $ case nstr of

387 return $ case nstr of

421 Nothing -> 0 -- is this appropriate?

388 Nothing -> 0 -- is this appropriate?

422− Just str -> mkInteger str

389+ Just str -> toInteger str

423 PQ.TuplesOk -> do

390 PQ.TuplesOk -> do

424 ncols <- PQ.nfields result

391 ncols <- PQ.nfields result

425 throwIO $ QueryError ("execute resulted in " ++ show ncols ++

392 throwIO $ QueryError ("execute resulted in " ++ show ncols ++

@@ -432,7 +399,7 @@ finishExecute _conn q result = do

432 PQ.NonfatalError -> throwResultError "execute" result status

399 PQ.NonfatalError -> throwResultError "execute" result status

433 PQ.FatalError -> throwResultError "execute" result status

400 PQ.FatalError -> throwResultError "execute" result status

434 where

401 where

435− mkInteger str = B8.foldl' delta 0 str

402+ toInteger str = B8.foldl' delta 0 str

436 where

403 where

437 delta acc c =

404 delta acc c =

438 if '0' <= c && c <= '9'

405 if '0' <= c && c <= '9'

@@ -447,8 +414,8 @@ throwResultError _ result status = do

447 PQ.resultErrorField result PQ.DiagMessageDetail

414 PQ.resultErrorField result PQ.DiagMessageDetail

448 hint <- fromMaybe "" <$>

415 hint <- fromMaybe "" <$>

449 PQ.resultErrorField result PQ.DiagMessageHint

416 PQ.resultErrorField result PQ.DiagMessageHint

450− state' <- maybe "" id <$> PQ.resultErrorField result PQ.DiagSqlstate

417+ state <- maybe "" id <$> PQ.resultErrorField result PQ.DiagSqlstate

451− throwIO $ SqlError { sqlState = state'

418+ throwIO $ SqlError { sqlState = state

452 , sqlExecStatus = status

419 , sqlExecStatus = status

453 , sqlErrorMsg = errormsg

420 , sqlErrorMsg = errormsg

454 , sqlErrorDetail = detail

421 , sqlErrorDetail = detail

@@ -517,6 +484,9 @@ instance Alternative Conversion where

517 Errors _ -> (oka <|>) <$> runConversion mb conn

484 Errors _ -> (oka <|>) <$> runConversion mb conn

518

485

519instance Monad Conversion where

486instance Monad Conversion where

487+#if !(MIN_VERSION_base(4,8,0))

488+ return = pure

489+#endif

520 m >>= f = Conversion $ \conn -> do

490 m >>= f = Conversion $ \conn -> do

521 oka <- runConversion m conn

491 oka <- runConversion m conn

522 case oka of

492 case oka of

@@ -619,19 +589,3 @@ escapeIdentifier = escapeWrap PQ.escapeIdentifier

619

589

620escapeByteaConn :: Connection -> ByteString -> IO (Either ByteString ByteString)

590escapeByteaConn :: Connection -> ByteString -> IO (Either ByteString ByteString)

621escapeByteaConn = escapeWrap PQ.escapeByteaConn

591escapeByteaConn = 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.hs+6−2

@@ -25,7 +25,7 @@ import Data.Foldable (for_)

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

26import Database.PostgreSQL.Simple.Ok

27import Database.PostgreSQL.Simple.Types (Query(..))

28−import Database.PostgreSQL.Simple.Internal as Base hiding (result, row)

28+import Database.PostgreSQL.Simple.Internal as Base

29import Database.PostgreSQL.Simple.TypeInfo

30import qualified Database.PostgreSQL.LibPQ as PQ

31import qualified Data.ByteString.Char8 as B

@@ -73,11 +73,15 @@ finishQueryWith' q result k = do

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

76+ PQ.CommandOk -> queryErr "query resulted in a command response"

77 PQ.CopyOut -> queryErr "query: COPY TO is not supported"

78 PQ.CopyIn -> queryErr "query: COPY FROM is not supported"

79+#if MIN_VERSION_postgresql_libpq(0,9,3)

79 PQ.CopyBoth -> queryErr "query: COPY BOTH is not supported"

80 PQ.CopyBoth -> queryErr "query: COPY BOTH is not supported"

81+#endif

82+#if MIN_VERSION_postgresql_libpq(0,9,2)

80 PQ.SingleTuple -> queryErr "query: single-row mode is not supported"

83 PQ.SingleTuple -> queryErr "query: single-row mode is not supported"

84+#endif

81 PQ.BadResponse -> throwResultError "query" result status

85 PQ.BadResponse -> throwResultError "query" result status

82 PQ.NonfatalError -> throwResultError "query" result status

86 PQ.NonfatalError -> throwResultError "query" result status

83 PQ.FatalError -> throwResultError "query" result status

87 PQ.FatalError -> throwResultError "query" result status

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

@@ -47,6 +47,8 @@ import GHC.IO.Exception ( ioe_location )

47

48#if defined(mingw32_HOST_OS)

49import Control.Concurrent ( threadDelay )

50+#elif !MIN_VERSION_base(4,7,0)

51+import Control.Concurrent ( threadWaitRead )

50#else

52#else

51import GHC.Conc ( atomically )

53import GHC.Conc ( atomically )

52import Control.Concurrent ( threadWaitReadSTM )

54import Control.Concurrent ( threadWaitReadSTM )

@@ -92,6 +94,21 @@ getNotification conn = join $ withConnection conn fetch

92 -- with async exceptions, whereas threadDelay can.

94 -- with async exceptions, whereas threadDelay can.

93 Just _fd -> do

95 Just _fd -> do

94 return (threadDelay 1000000 >> loop)

96 return (threadDelay 1000000 >> loop)

97+#elif !MIN_VERSION_base(4,7,0)

98+ -- Technically there's a race condition that is usually benign.

99+ -- If the connection is closed or reset after we drop the

100+ -- lock, and then the fd index is reallocated to a new

101+ -- descriptor before we call threadWaitRead, then

102+ -- we could end up waiting on the wrong descriptor.

103+ --

104+ -- Now, if the descriptor becomes readable promptly, then

105+ -- it's no big deal as we'll wake up and notice the change

106+ -- on the next iteration of the loop. But if are very

107+ -- unlucky, then we could end up waiting a long time.

108+ Just fd -> do

109+ return $ do

110+ threadWaitRead fd `catch` (throwIO . setIOErrorLocation)

111+ loop

95#else

112#else

96 -- This case fixes the race condition above. By registering

113 -- This case fixes the race condition above. By registering

97 -- our interest in the descriptor before we drop the lock,

114 -- our interest in the descriptor before we drop the lock,

src/Database/PostgreSQL/Simple/Ok.hs+4−7

@@ -37,8 +37,6 @@ import Control.Exception

37import Control.Monad(MonadPlus(..))

38import Data.Typeable

39

40−import qualified Control.Monad.Fail as Fail

41−

42-- FIXME: [SomeException] should probably be something else, maybe

40-- FIXME: [SomeException] should probably be something else, maybe

43-- a difference list (or a tree?)

41-- a difference list (or a tree?)

44

42

@@ -72,14 +70,13 @@ instance MonadPlus Ok where

72 mplus = (<|>)

70 mplus = (<|>)

73

71

74instance Monad Ok where

72instance Monad Ok where

73+#if !(MIN_VERSION_base(4,8,0))

74+ return = pure

75+#endif

76+

75 Errors es >>= _ = Errors es

77 Errors es >>= _ = Errors es

76 Ok a >>= f = f a

78 Ok a >>= f = f a

77

79

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

80 fail str = Errors [SomeException (ErrorCall str)]

84

81

85-- | a way to reify a list of exceptions into a single exception

82-- | a way to reify a list of exceptions into a single exception

src/Database/PostgreSQL/Simple/Range.hs+7−7

@@ -38,7 +38,7 @@ import Data.Monoid (mempty)

38import Data.Scientific (Scientific)

39import qualified Data.Text.Lazy.Builder as LT

40import qualified Data.Text.Lazy.Encoding as LT

41−import Data.Time.Compat (Day, LocalTime,

41+import Data.Time (Day, LocalTime,

42 NominalDiffTime,

43 TimeOfDay, UTCTime,

44 ZonedTime,

@@ -110,19 +110,19 @@ containsBy cmp rng x =

110 PGRange _lb NegInfinity -> False

111 PGRange lb ub -> checkLB lb x && checkUB ub x

112 where

113− checkLB lb y =

113+ checkLB lb x =

114 case lb of

115 NegInfinity -> True

116 PosInfinity -> False

117− Inclusive a -> cmp a y /= GT

117+ Inclusive a -> cmp a x /= GT

118− Exclusive a -> cmp a y == LT

118+ Exclusive a -> cmp a x == LT

119

120− checkUB ub y =

120+ checkUB ub x =

121 case ub of

122 NegInfinity -> False

123 PosInfinity -> True

124− Inclusive z -> cmp y z /= GT

124+ Inclusive z -> cmp x z /= GT

125− Exclusive z -> cmp y z == LT

125+ Exclusive z -> cmp x z == LT

126

127lowerBound :: Parser (a -> RangeBound a)

128lowerBound = (A.char '(' *> pure Exclusive) <|> (A.char '[' *> pure Inclusive)

src/Database/PostgreSQL/Simple/SqlQQ.hs+1−1

@@ -35,7 +35,7 @@ import Data.String

35-- > (beginTime,endTime,string)

36--

37-- This quasiquoter returns a literal string expression of type 'Query',

38−-- and attempts to minimize whitespace; otherwise the above query would

38+-- and attempts to mimimize whitespace; otherwise the above query would

39-- consist of approximately half whitespace when sent to the database

40-- backend. It also recognizes and strips out standard sql comments "--".

41--

src/Database/PostgreSQL/Simple/Time.hs−2

@@ -227,7 +227,6 @@ module Database.PostgreSQL.Simple.Time

227 , parseUTCTimestamp

228 , parseZonedTimestamp

229 , parseLocalTimestamp

230− , parseCalendarDiffTime

231 , dayToBuilder

230 , dayToBuilder

232 , utcTimeToBuilder

231 , utcTimeToBuilder

233 , zonedTimeToBuilder

232 , zonedTimeToBuilder

@@ -240,7 +239,6 @@ module Database.PostgreSQL.Simple.Time

240 , localTimestampToBuilder

239 , localTimestampToBuilder

241 , unboundedToBuilder

240 , unboundedToBuilder

242 , nominalDiffTimeToBuilder

241 , nominalDiffTimeToBuilder

243− , calendarDiffTimeToBuilder

244 ) where

242 ) where

245

243

246import Database.PostgreSQL.Simple.Time.Implementation

244import Database.PostgreSQL.Simple.Time.Implementation

src/Database/PostgreSQL/Simple/Time/Implementation.hs+1−11

@@ -18,8 +18,7 @@ import Data.ByteString.Builder.Prim(primBounded)

18import Control.Arrow((***))

19import Control.Applicative

20import qualified Data.ByteString as B

21−import Data.Time.Compat (LocalTime, UTCTime, ZonedTime, Day, TimeOfDay, TimeZone, NominalDiffTime, utc)

21+import Data.Time hiding (getTimeZone, getZonedTime)

22−import Data.Time.LocalTime.Compat (CalendarDiffTime)

23import Data.Typeable

22import Data.Typeable

24import Data.Maybe (fromMaybe)

23import Data.Maybe (fromMaybe)

25import qualified Data.Attoparsec.ByteString.Char8 as A

24import qualified Data.Attoparsec.ByteString.Char8 as A

@@ -78,9 +77,6 @@ parseLocalTimestamp = A.parseOnly (getLocalTimestamp <* A.endOfInput)

78parseDate :: B.ByteString -> Either String Date

77parseDate :: B.ByteString -> Either String Date

79parseDate = A.parseOnly (getDate <* A.endOfInput)

78parseDate = A.parseOnly (getDate <* A.endOfInput)

80

79

81−parseCalendarDiffTime :: B.ByteString -> Either String CalendarDiffTime

82−parseCalendarDiffTime = A.parseOnly (getCalendarDiffTime <* A.endOfInput)

83−

84getUnbounded :: A.Parser a -> A.Parser (Unbounded a)

80getUnbounded :: A.Parser a -> A.Parser (Unbounded a)

85getUnbounded getFinite

81getUnbounded getFinite

86 = (pure NegInfinity <* A.string "-infinity")

82 = (pure NegInfinity <* A.string "-infinity")

@@ -129,9 +125,6 @@ getUTCTime = TP.utcTime

129getUTCTimestamp :: A.Parser UTCTimestamp

125getUTCTimestamp :: A.Parser UTCTimestamp

130getUTCTimestamp = getUnbounded getUTCTime

126getUTCTimestamp = getUnbounded getUTCTime

131

127

132−getCalendarDiffTime :: A.Parser CalendarDiffTime

133−getCalendarDiffTime = TP.calendarDiffTime

134−

135dayToBuilder :: Day -> Builder

128dayToBuilder :: Day -> Builder

136dayToBuilder = primBounded TPP.day

129dayToBuilder = primBounded TPP.day

137

130

@@ -171,6 +164,3 @@ dateToBuilder = unboundedToBuilder dayToBuilder

171

164

172nominalDiffTimeToBuilder :: NominalDiffTime -> Builder

165nominalDiffTimeToBuilder :: NominalDiffTime -> Builder

173nominalDiffTimeToBuilder = TPP.nominalDiffTime

166nominalDiffTimeToBuilder = TPP.nominalDiffTime

174−

175−calendarDiffTimeToBuilder :: CalendarDiffTime -> Builder

176−calendarDiffTimeToBuilder = TPP.calendarDiffTime

src/Database/PostgreSQL/Simple/Time/Internal/Parser.hs+3−12

@@ -21,24 +21,20 @@ module Database.PostgreSQL.Simple.Time.Internal.Parser

21 , localToUTCTimeOfDayHMS

22 , utcTime

23 , zonedTime

24− , calendarDiffTime

25 ) where

24 ) where

26

25

27import Control.Applicative ((<$>), (<*>), (<*), (*>))

26import Control.Applicative ((<$>), (<*>), (<*), (*>))

28import Database.PostgreSQL.Simple.Compat (toPico)

27import Database.PostgreSQL.Simple.Compat (toPico)

29import Data.Attoparsec.ByteString.Char8 as A

28import Data.Attoparsec.ByteString.Char8 as A

30import Data.Bits ((.&.))

29import Data.Bits ((.&.))

31−import Data.ByteString (ByteString)

32import Data.Char (ord)

30import Data.Char (ord)

33import Data.Fixed (Pico)

31import Data.Fixed (Pico)

34import Data.Int (Int64)

32import Data.Int (Int64)

35import Data.Maybe (fromMaybe)

33import Data.Maybe (fromMaybe)

36−import Data.Time.Calendar.Compat (Day, fromGregorianValid, addDays)

34+import Data.Time.Calendar (Day, fromGregorianValid, addDays)

37−import Data.Time.Clock.Compat (UTCTime(..))

35+import Data.Time.Clock (UTCTime(..))

38−import Data.Time.Format.ISO8601.Compat (iso8601ParseM)

39−import Data.Time.LocalTime.Compat (CalendarDiffTime)

40import qualified Data.ByteString.Char8 as B8

36import qualified Data.ByteString.Char8 as B8

41−import qualified Data.Time.LocalTime.Compat as Local

37+import qualified Data.Time.LocalTime as Local

42

38

43-- | Parse a date of the form @YYYY-MM-DD@.

39-- | Parse a date of the form @YYYY-MM-DD@.

44day :: Parser Day

40day :: Parser Day

@@ -197,8 +193,3 @@ zonedTime = Local.ZonedTime <$> localTime <*> (fromMaybe utc <$> timeZone)

197

193

198utc :: Local.TimeZone

194utc :: Local.TimeZone

199utc = Local.TimeZone 0 False ""

195utc = 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.hs+2−14

@@ -17,23 +17,19 @@ module Database.PostgreSQL.Simple.Time.Internal.Printer

17 , localTime

18 , zonedTime

19 , nominalDiffTime

20− , calendarDiffTime

21 ) where

20 ) where

22

21

23import Control.Arrow ((>>>))

22import Control.Arrow ((>>>))

24−import Data.ByteString.Builder (Builder, byteString, integerDec)

23+import Data.ByteString.Builder (Builder, integerDec)

25import Data.ByteString.Builder.Prim

24import Data.ByteString.Builder.Prim

26 ( liftFixedToBounded, (>$<), (>*<)

25 ( liftFixedToBounded, (>$<), (>*<)

27 , BoundedPrim, primBounded, condB, emptyB, FixedPrim, char8, int32Dec)

26 , BoundedPrim, primBounded, condB, emptyB, FixedPrim, char8, int32Dec)

28import Data.Char ( chr )

27import Data.Char ( chr )

29import Data.Int ( Int32, Int64 )

28import Data.Int ( Int32, Int64 )

30−import Data.String (fromString)

29+import Data.Time

31−import Data.Time.Compat

32 ( UTCTime(..), ZonedTime(..), LocalTime(..), NominalDiffTime

30 ( UTCTime(..), ZonedTime(..), LocalTime(..), NominalDiffTime

33 , Day, toGregorian, TimeOfDay(..), timeToTimeOfDay

31 , Day, toGregorian, TimeOfDay(..), timeToTimeOfDay

34 , TimeZone, timeZoneMinutes )

32 , TimeZone, timeZoneMinutes )

35−import Data.Time.Format.ISO8601.Compat (iso8601Show)

36−import Data.Time.LocalTime.Compat (CalendarDiffTime)

37import Database.PostgreSQL.Simple.Compat ((<>), fromPico)

33import Database.PostgreSQL.Simple.Compat ((<>), fromPico)

38import Unsafe.Coerce (unsafeCoerce)

34import Unsafe.Coerce (unsafeCoerce)

39

35

@@ -125,11 +121,3 @@ nominalDiffTime :: NominalDiffTime -> Builder

125nominalDiffTime xy = integerDec x <> primBounded frac (abs (fromIntegral y))

121nominalDiffTime xy = integerDec x <> primBounded frac (abs (fromIntegral y))

126 where

122 where

127 (x,y) = fromPico (unsafeCoerce xy) `quotRem` 1000000000000

123 (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+11−22

@@ -1,6 +1,5 @@

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

2{-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-}

3−{-# LANGUAGE PolyKinds #-}

4

3

5------------------------------------------------------------------------------

4------------------------------------------------------------------------------

6-- |

5-- |

@@ -23,7 +22,6 @@ module Database.PostgreSQL.Simple.ToField

23 , inQuotes

22 , inQuotes

24 ) where

23 ) where

25

24

26−import Control.Applicative (Const(Const))

27import qualified Data.Aeson as JSON

25import qualified Data.Aeson as JSON

28import Data.ByteString (ByteString)

26import Data.ByteString (ByteString)

29import Data.ByteString.Builder

27import Data.ByteString.Builder

@@ -32,12 +30,10 @@ import Data.ByteString.Builder

32 , wordDec, word8Dec, word16Dec, word32Dec, word64Dec

30 , wordDec, word8Dec, word16Dec, word32Dec, word64Dec

33 , floatDec, doubleDec

31 , floatDec, doubleDec

34 )

32 )

35−import Data.Functor.Identity (Identity(Identity))

36import Data.Int (Int8, Int16, Int32, Int64)

33import Data.Int (Int8, Int16, Int32, Int64)

37import Data.List (intersperse)

34import Data.List (intersperse)

38import Data.Monoid (mappend)

35import Data.Monoid (mappend)

39−import Data.Time.Compat (Day, TimeOfDay, LocalTime, UTCTime, ZonedTime, NominalDiffTime)

36+import Data.Time (Day, TimeOfDay, LocalTime, UTCTime, ZonedTime, NominalDiffTime)

40−import Data.Time.LocalTime.Compat (CalendarDiffTime)

41import Data.Typeable (Typeable)

37import Data.Typeable (Typeable)

42import Data.Word (Word, Word8, Word16, Word32, Word64)

38import Data.Word (Word, Word8, Word16, Word32, Word64)

43import {-# SOURCE #-} Database.PostgreSQL.Simple.ToRow

39import {-# SOURCE #-} Database.PostgreSQL.Simple.ToRow

@@ -59,7 +55,11 @@ import qualified Data.Vector as V

59import qualified Database.PostgreSQL.LibPQ as PQ

55import qualified Database.PostgreSQL.LibPQ as PQ

60import Database.PostgreSQL.Simple.Time

56import Database.PostgreSQL.Simple.Time

61import Data.Scientific (Scientific)

57import Data.Scientific (Scientific)

58+#if MIN_VERSION_scientific(0,3,0)

62import Data.Text.Lazy.Builder.Scientific (scientificBuilder)

59import Data.Text.Lazy.Builder.Scientific (scientificBuilder)

60+#else

61+import Data.Scientific (scientificBuilder)

62+#endif

63import Foreign.C.Types (CUInt(..))

64

65-- | How to render an element when substituting it into a query.

@@ -100,14 +100,6 @@ instance ToField Action where

100 toField a = a

101 {-# 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

103instance (ToField a) => ToField (Maybe a) where

112 toField Nothing = renderNull

104 toField Nothing = renderNull

113 toField (Just a) = toField a

105 toField (Just a) = toField a

@@ -290,10 +282,6 @@ instance ToField NominalDiffTime where

290 toField = Plain . inQuotes . nominalDiffTimeToBuilder

282 toField = Plain . inQuotes . nominalDiffTimeToBuilder

291 {-# INLINE toField #-}

283 {-# INLINE toField #-}

292

284

293−instance ToField CalendarDiffTime where

294− toField = Plain . inQuotes . calendarDiffTimeToBuilder

295− {-# INLINE toField #-}

296−

297instance (ToField a) => ToField (PGArray a) where

285instance (ToField a) => ToField (PGArray a) where

298 toField pgArray =

286 toField pgArray =

299 case fromPGArray pgArray of

287 case fromPGArray pgArray of

@@ -314,13 +302,14 @@ instance ToField UUID where

314instance ToField JSON.Value where

302instance ToField JSON.Value where

315 toField = toField . JSON.encode

303 toField = toField . JSON.encode

316

304

317−-- | Convert a Haskell value to JSON using 'JSON.toEncoding'.

305+-- | Convert a Haskell value to a JSON 'JSON.Value' using

306+-- 'JSON.toJSON' and convert that to a field using 'toField'.

318--

307--

319-- This can be used as the default implementation for the 'toField'

308-- This can be used as the default implementation for the 'toField'

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

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

321-- PostgreSQL.

310-- PostgreSQL.

322toJSONField :: JSON.ToJSON a => a -> Action

311toJSONField :: JSON.ToJSON a => a -> Action

323−toJSONField = toField . JSON.encode

312+toJSONField = toField . JSON.toJSON

324

313

325-- | Surround a string with single-quote characters: \"@'@\"

314-- | Surround a string with single-quote characters: \"@'@\"

326--

315--

@@ -330,7 +319,7 @@ inQuotes b = quote `mappend` b `mappend` quote

330 where quote = char8 '\''

319 where quote = char8 '\''

331

320

332interleaveFoldr :: (a -> [b] -> [b]) -> b -> [b] -> [a] -> [b]

321interleaveFoldr :: (a -> [b] -> [b]) -> b -> [b] -> [a] -> [b]

333−interleaveFoldr f b bs' as = foldr (\a bs -> b : f a bs) bs' as

322+interleaveFoldr f b bs as = foldr (\a bs -> b : f a bs) bs as

334{-# INLINE interleaveFoldr #-}

323{-# INLINE interleaveFoldr #-}

335

324

336instance ToRow a => ToField (Values a) where

325instance ToRow a => ToField (Values a) where

@@ -377,8 +366,8 @@ instance ToRow a => ToField (Values a) where

377

366

378 typedRows :: ToRow a => [a] -> [QualifiedIdentifier] -> [Action] -> [Action]

367 typedRows :: ToRow a => [a] -> [QualifiedIdentifier] -> [Action] -> [Action]

379 typedRows [] _ _ = error funcname

368 typedRows [] _ _ = error funcname

380− typedRows (val:vals) typs rest =

369+ typedRows (val:vals) types rest =

381− typedRow (toRow val) typs (multiRows vals rest)

370+ typedRow (toRow val) types (multiRows vals rest)

382

371

383 untypedRows :: ToRow a => [a] -> [Action] -> [Action]

372 untypedRows :: ToRow a => [a] -> [Action] -> [Action]

384 untypedRows [] _ = error funcname

373 untypedRows [] _ = error funcname

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

@@ -17,7 +17,6 @@ module Database.PostgreSQL.Simple.Transaction

17 , withTransactionLevel

18 , withTransactionMode

19 , withTransactionModeRetry

20− , withTransactionModeRetry'

21 , withTransactionSerializable

20 , withTransactionSerializable

22 , TransactionMode(..)

21 , TransactionMode(..)

23 , IsolationLevel(..)

22 , IsolationLevel(..)

@@ -147,34 +146,31 @@ withTransactionMode mode conn act =

147 commit conn

146 commit conn

148 return r

147 return r

149

148

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

149-- | Like 'withTransactionMode', but also takes a custom callback to

155−-- determine if a transaction should be retried if an exception occurs.

150+-- determine if a transaction should be retried if an 'SqlError' occurs.

156−-- If the callback returns 'True', then the transaction will be retried.

151+-- If the callback returns True, then the transaction will be retried.

157−-- If the callback returns 'False', or an exception other than an @e@

152+-- If the callback returns False, or an exception other than an 'SqlError'

158-- occurs then the transaction will be rolled back and the exception rethrown.

153-- occurs then the transaction will be rolled back and the exception rethrown.

159--

154--

160-- This is used to implement 'withTransactionSerializable'.

155-- This is used to implement 'withTransactionSerializable'.

161−withTransactionModeRetry' :: forall a e. E.Exception e => TransactionMode -> (e -> Bool) -> Connection -> IO a -> IO a

156+withTransactionModeRetry :: TransactionMode -> (SqlError -> Bool) -> Connection -> IO a -> IO a

162−withTransactionModeRetry' mode shouldRetry conn act =

157+withTransactionModeRetry mode shouldRetry conn act =

163 mask $ \restore ->

158 mask $ \restore ->

164 retryLoop $ E.try $ do

159 retryLoop $ E.try $ do

165− a <- restore act `E.onException` rollback_ conn

160+ a <- restore act

166 commit conn

161 commit conn

167 return a

162 return a

168 where

163 where

169− retryLoop :: IO (Either e a) -> IO a

164+ retryLoop :: IO (Either E.SomeException a) -> IO a

170 retryLoop act' = do

165 retryLoop act' = do

171 beginMode mode conn

166 beginMode mode conn

172 r <- act'

167 r <- act'

173 case r of

168 case r of

174− Left e ->

169+ Left e -> do

170+ rollback_ conn

175− case shouldRetry e of

171+ case fmap shouldRetry (E.fromException e) of

176− True -> retryLoop act'

172+ Just True -> retryLoop act'

177− False -> E.throwIO e

173+ _ -> E.throwIO e

178 Right a ->

174 Right a ->

179 return a

175 return a

180

176

src/Database/PostgreSQL/Simple/TypeInfo.hs+9−9

@@ -50,21 +50,21 @@ import Database.PostgreSQL.Simple.TypeInfo.Static

50-- in the connections's cache.

51

52getTypeInfo :: Connection -> PQ.Oid -> IO TypeInfo

53−getTypeInfo conn@Connection{..} oid' =

53+getTypeInfo conn@Connection{..} oid =

54− case staticTypeInfo oid' of

54+ case staticTypeInfo oid of

55− Just name' -> return name'

55+ Just name -> return name

56− Nothing -> modifyMVar connectionObjects $ getTypeInfo' conn oid'

56+ Nothing -> modifyMVar connectionObjects $ getTypeInfo' conn oid

57

58getTypeInfo' :: Connection -> PQ.Oid -> TypeInfoCache

59 -> IO (TypeInfoCache, TypeInfo)

60−getTypeInfo' conn oid' oidmap =

60+getTypeInfo' conn oid oidmap =

61− case IntMap.lookup (oid2int oid') oidmap of

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

67+ (Only oid)

68 (oidmap', typeInfo) <-

69 case names of

70 [] -> return $ throw (fatalError "invalid type oid")

@@ -78,7 +78,7 @@ getTypeInfo' conn oid' oidmap =

78 rngsubtypeOids <- query conn "SELECT rngsubtype\

79 \ FROM pg_range\

80 \ WHERE rngtypid = ?"

81− (Only oid')

81+ (Only oid)

82 case rngsubtypeOids of

83 [Only rngsubtype_] -> do

84 (oidmap', rngsubtype) <-

@@ -104,7 +104,7 @@ getTypeInfo' conn oid' oidmap =

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'

107+ let !oidmap'' = IntMap.insert (oid2int oid) typeInfo oidmap'

108 return $! (oidmap'', typeInfo)

109

110getAttInfos :: Connection -> [(B.ByteString, PQ.Oid)] -> TypeInfoCache

src/Database/PostgreSQL/Simple/Types.hs+7

@@ -50,6 +50,10 @@ import Database.PostgreSQL.Simple.Compat (toByteString)

50data Null = Null

51 deriving (Read, Show, Typeable)

52

53+instance Eq Null where

54+ _ == _ = False

55+ _ /= _ = False

56+

53-- | A placeholder for the PostgreSQL @DEFAULT@ value.

57-- | A placeholder for the PostgreSQL @DEFAULT@ value.

54data Default = Default

58data Default = Default

55 deriving (Read, Show, Typeable)

59 deriving (Read, Show, Typeable)

@@ -93,6 +97,9 @@ instance Semigroup Query where

93

97

94instance Monoid Query where

98instance Monoid Query where

95 mempty = Query B.empty

99 mempty = Query B.empty

100+#if !(MIN_VERSION_base(4,11,0))

101+ mappend = (<>)

102+#endif

96

103

97-- | Wrap a list of values for use in an @IN@ clause. Replaces a

104-- | Wrap a list of values for use in an @IN@ clause. Replaces a

98-- single \"@?@\" character with a parenthesized list of rendered

105-- single \"@?@\" character with a parenthesized list of rendered

test/Exception.hsdeleted−70

@@ -1,70 +0,0 @@

1−{-# LANGUAGE CPP #-}

2−{-# LANGUAGE OverloadedStrings #-}

3−{-# LANGUAGE ScopedTypeVariables #-}

4−

5−module Exception (testExceptions) where

6−

7−import Database.PostgreSQL.Simple

8−import Test.Tasty.HUnit (Assertion, assertBool)

9−import Common (TestEnv)

10−import Control.Exception (Exception (..), SomeException)

11−import Data.Maybe (isJust)

12−import Data.Either (isLeft)

13−import Control.Exception (throwIO, try)

14−

15−testExceptions :: TestEnv -> Assertion

16−testExceptions _ = do

17− let sqlError = SqlError

18− { sqlState = ""

19− , sqlExecStatus = FatalError

20− , sqlErrorMsg = ""

21− , sqlErrorDetail = ""

22− , sqlErrorHint = ""

23− }

24− let sqlEx :: SomeException = toException sqlError

25− assertBool "SqlError is SomePostgreSqlException" $ isJust (fromException sqlEx :: Maybe SomePostgreSqlException)

26− assertBool "SqlError is SqlError" $ isJust (fromException sqlEx :: Maybe SqlError)

27− eSqlError :: Either SqlError () <- try $ throwIO sqlEx

28− assertBool "Can catch SqlError" $ isLeft eSqlError

29− eSqlPostgreSqlEx :: Either SomePostgreSqlException () <- try $ throwIO sqlEx

30− assertBool "Can catch SomePostgreSqlException from SqlError" $ isLeft eSqlPostgreSqlEx

31−

32− let formatError = FormatError

33− { fmtMessage = ""

34− , fmtQuery = ""

35− , fmtParams = []

36− }

37− let formatEx :: SomeException = toException formatError

38− assertBool "FormatError is SomePostgreSqlException" $ isJust (fromException formatEx :: Maybe SomePostgreSqlException)

39− assertBool "FormatError is FormatError" $ isJust (fromException formatEx :: Maybe FormatError)

40− eFormatError :: Either FormatError () <- try $ throwIO formatEx

41− assertBool "Can catch FormatError" $ isLeft eFormatError

42− eFormatPostreSqlEx :: Either SomePostgreSqlException () <- try $ throwIO formatEx

43− assertBool "Can catch SomePostgreSqlException from FormatError" $ isLeft eFormatPostreSqlEx

44−

45− let queryError = QueryError

46− { qeMessage = ""

47− , qeQuery = ""

48− }

49− let queryEx :: SomeException = toException queryError

50− assertBool "QueryError is SomePostgreSqlException" $ isJust (fromException queryEx :: Maybe SomePostgreSqlException)

51− assertBool "QueryError is QueryError" $ isJust (fromException queryEx :: Maybe QueryError)

52− eQueryError :: Either QueryError () <- try $ throwIO queryEx

53− assertBool "Can catch QueryError" $ isLeft eQueryError

54− eQueryPostgreSqlEx :: Either SomePostgreSqlException () <- try $ throwIO queryEx

55− assertBool "Can catch SomePostgreSqlException from QueryError" $ isLeft eQueryPostgreSqlEx

56−

57− let resultError = Incompatible

58− { errSQLType = ""

59− , errSQLTableOid = Nothing

60− , errSQLField = ""

61− , errHaskellType = ""

62− , errMessage = ""

63− }

64− let resultEx :: SomeException = toException resultError

65− assertBool "ResultError is SomePostgreSqlException" $ isJust (fromException resultEx :: Maybe SomePostgreSqlException)

66− assertBool "ResultError is ResultError" $ isJust (fromException resultEx :: Maybe ResultError)

67− eResultEx :: Either ResultError () <- try $ throwIO resultEx

68− assertBool "Can catch ResultError" $ isLeft eResultEx

69− eResultPostgreSqlEx :: Either SomePostgreSqlException () <- try $ throwIO resultEx

70− assertBool "Can catch SomePostgreSqlException from ResultError" $ isLeft eResultPostgreSqlEx

test/Inspection.hs+1−6

@@ -53,12 +53,7 @@ inspectionTests = testGroup "inspection"

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)

56+ assertFailure' $(inspectTest $ 'lhs02 ==- 'rhs02)

62 ]

57 ]

63

58

64assertSuccess :: Result -> IO ()

59assertSuccess :: Result -> IO ()

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+32−179

@@ -3,39 +3,25 @@

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

6import Common

14−import Database.PostgreSQL.Simple.Copy

15−import Database.PostgreSQL.Simple.ToField (ToField)

16import Database.PostgreSQL.Simple.FromField (FromField)

7import Database.PostgreSQL.Simple.FromField (FromField)

8+import Database.PostgreSQL.Simple.Types(Query(..),Values(..))

17import Database.PostgreSQL.Simple.HStore

9import Database.PostgreSQL.Simple.HStore

18−import Database.PostgreSQL.Simple.Newtypes

10+import Database.PostgreSQL.Simple.Copy

19−import Database.PostgreSQL.Simple.Internal (breakOnSingleQuestionMark)

20−import Database.PostgreSQL.Simple.Types(Query(..),Values(..), PGArray(..))

21import qualified Database.PostgreSQL.Simple.Transaction as ST

11import qualified Database.PostgreSQL.Simple.Transaction as ST

22

12

23import Control.Applicative

13import Control.Applicative

24import Control.Exception as E

14import Control.Exception as E

25import Control.Monad

15import Control.Monad

26import Data.Char

16import Data.Char

27−import Data.Foldable (toList)

17+import Data.List (sort)

28−import Data.List (concat, sort)

29import Data.IORef

18import Data.IORef

30−import Data.Monoid ((<>))

31−import Data.String (fromString)

32import Data.Typeable

19import Data.Typeable

33import GHC.Generics (Generic)

20import GHC.Generics (Generic)

34

21

35import Data.Aeson

22import Data.Aeson

36import Data.ByteString (ByteString)

23import Data.ByteString (ByteString)

37import qualified Data.ByteString as B

24import qualified Data.ByteString as B

38−import qualified Data.ByteString.Char8 as BS8

39import qualified Data.ByteString.Lazy.Char8 as BL

25import qualified Data.ByteString.Lazy.Char8 as BL

40import Data.CaseInsensitive (CI)

26import Data.CaseInsensitive (CI)

41import qualified Data.CaseInsensitive as CI

27import qualified Data.CaseInsensitive as CI

@@ -46,46 +32,38 @@ import qualified Data.Text.Encoding as T

46import qualified Data.Vector as V

32import qualified Data.Vector as V

47import System.FilePath

33import System.FilePath

48import System.Timeout(timeout)

34import System.Timeout(timeout)

49−import Data.Time.Compat (getCurrentTime, diffUTCTime)

35+import Data.Time(getCurrentTime, diffUTCTime)

50−import System.Environment (getEnvironment)

51

36

52import Test.Tasty

37import Test.Tasty

53import Test.Tasty.Golden

38import Test.Tasty.Golden

54import Notify

39import Notify

55import Serializable

40import Serializable

56import Time

41import Time

57−import Interval

58−import Exception (testExceptions)

59

42

60tests :: TestEnv -> TestTree

43tests :: TestEnv -> TestTree

61tests env = testGroup "tests"

44tests env = testGroup "tests"

62 $ map ($ env)

45 $ map ($ env)

63 [ testBytea

46 [ testBytea

64− , testCase "ExecuteMany" . testExecuteMany

47+ , testCase "ExecuteMany" . testExecuteMany

65− , testCase "Fold" . testFold

48+ , testCase "Fold" . testFold

66− , testCase "Notify" . testNotify

49+ , testCase "Notify" . testNotify

67− , testCase "Serializable" . testSerializable

50+ , testCase "Serializable" . testSerializable

68− , testCase "Time" . testTime

51+ , testCase "Time" . testTime

69− , testCase "Interval" . testInterval

70− , testCase "Array" . testArray

52+ , testCase "Array" . testArray

71− , testCase "Array of nullables" . testNullableArray

53+ , testCase "Array of nullables" . testNullableArray

72− , testCase "HStore" . testHStore

54+ , testCase "HStore" . testHStore

73− , testCase "citext" . testCIText

55+ , testCase "citext" . testCIText

74− , testCase "JSON" . testJSON

56+ , testCase "JSON" . testJSON

75− , testCase "Aeson newtype" . testAeson

76− , testCase "DerivingVia" . testDerivingVia

77− , testCase "Question mark escape" . testQM

78− , testCase "Savepoint" . testSavepoint

57+ , testCase "Savepoint" . testSavepoint

79− , testCase "Unicode" . testUnicode

58+ , testCase "Unicode" . testUnicode

80− , testCase "Values" . testValues

59+ , testCase "Values" . testValues

81− , testCase "Copy" . testCopy

60+ , testCase "Copy" . testCopy

82 , testCopyFailures

61 , testCopyFailures

83− , testCase "Double" . testDouble

62+ , testCase "Double" . testDouble

84− , testCase "1-ary generic" . testGeneric1

63+ , testCase "1-ary generic" . testGeneric1

85− , testCase "2-ary generic" . testGeneric2

64+ , testCase "2-ary generic" . testGeneric2

86− , testCase "3-ary generic" . testGeneric3

65+ , testCase "3-ary generic" . testGeneric3

87− , testCase "Timeout" . testTimeout

66+ , testCase "Timeout" . testTimeout

88− , testCase "Exceptions" . testExceptions

89 ]

67 ]

90

68

91testBytea :: TestEnv -> TestTree

69testBytea :: TestEnv -> TestTree

@@ -139,7 +117,7 @@ testFold TestEnv{..} = do

139 xs <- readIORef ref

117 xs <- readIORef ref

140 writeIORef ref $! (a,b):xs

118 writeIORef ref $! (a,b):xs

141 xs <- readIORef ref

119 xs <- readIORef ref

142− reverse xs @?= [(a,b) | b <- [1..50], a <- [1..100]]

120+ reverse xs @?= [(a,b) | a <- [1..100], b <- [1..50]]

143

121

144 -- Make sure fold propagates our exception.

122 -- Make sure fold propagates our exception.

145 ref <- newIORef []

123 ref <- newIORef []

@@ -256,90 +234,6 @@ testJSON TestEnv{..} = do

256 js' <- query conn "SELECT ?::json" js

234 js' <- query conn "SELECT ?::json" js

257 [js] @?= js'

235 [js] @?= js'

258

236

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−

343testSavepoint :: TestEnv -> Assertion

237testSavepoint :: TestEnv -> Assertion

344testSavepoint TestEnv{..} = do

238testSavepoint TestEnv{..} = do

345 True <- expectError ST.isNoActiveTransactionError $

239 True <- expectError ST.isNoActiveTransactionError $

@@ -447,14 +341,6 @@ testCopy TestEnv{..} = do

447 -- so that we can issue more queries:

341 -- so that we can issue more queries:

448 [Only (x::Int)] <- query_ conn "SELECT 2 + 2"

342 [Only (x::Int)] <- query_ conn "SELECT 2 + 2"

449 x @?= 4

343 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

344 where

459 copyRows = ["1,foo\n"

345 copyRows = ["1,foo\n"

460 ,"2,bar\n"]

346 ,"2,bar\n"]

@@ -474,13 +360,12 @@ testCopyFailures env = testGroup "Copy failures"

474

360

475goldenTest :: TestName -> IO BL.ByteString -> TestTree

361goldenTest :: TestName -> IO BL.ByteString -> TestTree

476goldenTest testName =

362goldenTest testName =

477− goldenVsStringDiff testName diff (resultsDir </> fileName<.>"expected")

363+ goldenVsString testName (resultsDir </> fileName<.>"expected")

478 where

364 where

479 resultsDir = "test" </> "results"

365 resultsDir = "test" </> "results"

480 fileName = map normalize testName

366 fileName = map normalize testName

481 normalize c | not (isAlpha c) = '-'

367 normalize c | not (isAlpha c) = '-'

482 | otherwise = c

368 | otherwise = c

483− diff ref new = ["diff", "-u", ref, new]

484

369

485-- | Test that we provide a sensible error message on failure

370-- | Test that we provide a sensible error message on failure

486testCopyUniqueConstraintError :: TestEnv -> TestTree

371testCopyUniqueConstraintError :: TestEnv -> TestTree

@@ -593,56 +478,24 @@ isUniqueViolation SqlError{..} = sqlState == "23505"

593isSyntaxError :: SqlError -> Bool

478isSyntaxError :: SqlError -> Bool

594isSyntaxError SqlError{..} = sqlState == "42601"

479isSyntaxError SqlError{..} = sqlState == "42601"

595

480

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

481------------------------------------------------------------------------

605

482

606-- | Action for connecting to the database that will be used for testing.

483-- | Action for connecting to the database that will be used for testing.

607--

484--

608-- Note that some tests, such as Notify, use multiple connections, and assume

485-- 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.

486-- that 'testConnect' connects to the same database every time it is called.

610−withTestEnv :: ByteString -> (TestEnv -> IO a) -> IO a

487+testConnect :: IO Connection

611−withTestEnv connstr cb =

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

489

490+withTestEnv :: (TestEnv -> IO a) -> IO a

491+withTestEnv cb =

492+ withConn $ \conn ->

617 cb TestEnv

493 cb TestEnv

618 { conn = conn

494 { conn = conn

619 , withConn = withConn

495 , withConn = withConn

620 }

496 }

621 where

497 where

622− withConn = bracket (connectPostgreSQL connstr) close

498+ withConn = bracket testConnect close

623

499

624main :: IO ()

500main :: IO ()

625−main = withConnstring $ \connstring -> do

626− withTestEnv connstring (defaultMain . tests)

501+main = withTestEnv $ defaultMain . tests

627−

628−withConnstring :: (BS8.ByteString -> IO ()) -> IO ()

629−withConnstring kont = do

630− env <- getEnvironment

631− case lookup "DATABASE_CONNSTRING" env of

632− Just s -> kont (BS8.pack (special s))

633− Nothing -> case lookup "GITHUB_ACTIONS" env of

634− Just "true" -> kont (BS8.pack gha)

635− _ -> putStrLn "Set DATABASE_CONNSTRING environment variable"

636− where

637− -- https://www.appveyor.com/docs/services-databases/

638− special "appveyor" = "dbname='TestDb' user='postgres' password='Password12!'"

639− special "travis" = ""

640− special s = s

641−

642− gha = unwords

643− [ "dbname='postgres'"

644− , "user='postgres'"

645− , "password='postgres'"

646− , "host='postgres'"

647− , "port=5432"

648− ]

test/Time.hs+1−1

@@ -36,7 +36,7 @@ module Time (testTime) where

36

37import Common

38import Control.Monad(forM_, replicateM_)

39−import Data.Time.Compat

39+import Data.Time

40import Data.ByteString(ByteString)

41import Database.PostgreSQL.Simple.SqlQQ

42

test/results/malformed-input.expected+1−1

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

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

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

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

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

4)