f03cd61 · typeable/postgresql-simple

.travis.yml+45−39

compare with master

unifiedsplit

@@ -1,14 +1,11 @@

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'

3+# haskell-ci '--config' 'cabal.haskell-ci' '--output' '.travis.yml' 'postgresql-simple.cabal'

4#

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

6#

7language: c

8−sudo: false

8+dist: xenial

9−

10−services:

11− - postgresql

12

9

13git:

10git:

14 submodules: false # whether to recursively clone submodules

11 submodules: false # whether to recursively clone submodules

@@ -22,16 +19,21 @@ cache:

22 - $HOME/.cabal/packages

19 - $HOME/.cabal/packages

23 - $HOME/.cabal/store

20 - $HOME/.cabal/store

24

21

22+services:

23+- postgresql

24+addons:

25+ postgresql: '10'

26+

25before_cache:

27before_cache:

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

28+ - rm -fv $CABALHOME/packages/hackage.haskell.org/build-reports.log

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

29 # remove files that are regenerated by 'cabal update'

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

30+ - rm -fv $CABALHOME/packages/hackage.haskell.org/00-index.*

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

31+ - rm -fv $CABALHOME/packages/hackage.haskell.org/*.json

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

32+ - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.cache

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

33+ - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.tar

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

34+ - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.tar.idx

33

35

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

36+ - rm -rfv $CABALHOME/packages/head.hackage

35

37

36matrix:

38matrix:

37 include:

39 include:

@@ -58,40 +60,42 @@ matrix:

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

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

59

61

60before_install:

62before_install:

61− - HC=${CC}

63+ - HC=/opt/ghc/bin/${CC}

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

64 - HCPKG=${HC/ghc/ghc-pkg}

63 - unset CC

65 - unset CC

66+ - CABAL=/opt/ghc/bin/cabal

67+ - CABALHOME=$HOME/.cabal

68+ - "export PATH=\"$CABALHOME/bin:$PATH\""

64 - ROOTDIR=$(pwd)

69 - 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/') ))

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

68 - echo $HCNUMVER

71 - echo $HCNUMVER

69

72

70install:

73install:

71− - cabal --version

74+ - ${CABAL} --version

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

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

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

76 - BENCH=${BENCH---enable-benchmarks}

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

77 - TEST=${TEST---enable-tests}

75− - HADDOCK=${HADDOCK-true}

76 - UNCONSTRAINED=${UNCONSTRAINED-true}

78 - UNCONSTRAINED=${UNCONSTRAINED-true}

77− - NOINSTALLEDCONSTRAINTS=${NOINSTALLEDCONSTRAINTS-false}

78 - GHCHEAD=${GHCHEAD-false}

79 - GHCHEAD=${GHCHEAD-false}

79− - travis_retry cabal update -v

80+ - travis_retry ${CABAL} update -v

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

81+ - "sed -i.bak 's/^jobs:/-- jobs:/' $CABALHOME/config"

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

82 - rm -fv cabal.project cabal.project.local

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

83+ - grep -Ev -- '^\s*--' $CABALHOME/config | grep -Ev '^\s*$'

84+ - rm -f cabal.project

85+ - touch cabal.project

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

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

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

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

85 - touch cabal.project.local

88 - 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"

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

87 - cat cabal.project || true

90 - cat cabal.project || true

88 - cat cabal.project.local || true

91 - cat cabal.project.local || true

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

92+ - if [ -f "./configure.ac" ]; then (cd "." && autoreconf -i); fi

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

91− fi

92 - rm -f cabal.project.freeze

93 - rm -f cabal.project.freeze

94+ - ${CABAL} new-freeze -w ${HC} ${TEST} ${BENCH} --project-file="cabal.project" --dry

95+ - "cat \"cabal.project.freeze\" | sed -E 's/^(constraints: *| *)//' | sed 's/any.//'"

96+ - rm "cabal.project.freeze"

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

97+ - ${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

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

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

99 - rm -rf .ghc.environment.* "."/dist

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

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

97

101

@@ -99,31 +103,33 @@ install:

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

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

100script:

104script:

101 # test that source-distributions can be generated

105 # test that source-distributions can be generated

102− - cabal new-sdist all

106+ - ${CABAL} new-sdist all

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

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

104 - cd ${DISTDIR} || false

108 - cd ${DISTDIR} || false

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

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

110+ - rm -f cabal.project

111+ - touch cabal.project

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

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

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

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

108 - touch cabal.project.local

114 - 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"

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

110 - cat cabal.project || true

116 - cat cabal.project || true

111 - cat cabal.project.local || true

117 - cat cabal.project.local || true

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

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

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

119+ - ${CABAL} new-build -w ${HC} --disable-tests --disable-benchmarks all

114

120

115 # build & run tests, build benchmarks

121 # build & run tests, build benchmarks

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

122+ - ${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

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

118

124

119− # cabal check

125+ # ${CABAL} check

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

126+ - (cd postgresql-simple-* && ${CABAL} check)

121

127

122 # haddock

128 # haddock

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

129+ - ${CABAL} new-haddock -w ${HC} ${TEST} ${BENCH} all

124

130

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

131 # 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

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

127

133

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

134+# REGENDATA ["--config","cabal.haskell-ci","--output",".travis.yml","postgresql-simple.cabal"]

129# EOF

135# EOF

CHANGES.md+2−2

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

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

2

3− * *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.

4

5 Consider a downstream library depending already both on

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

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

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

317

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

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

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

320

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

322 foldWithOptions, executeMany, and returning operators.

cabal.haskell-cinew file+5

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

1+branches: master

2+postgresql: True

3+

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

5+-- osx: 8.4.4

src/Database/PostgreSQL/Simple.hs+18−8

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

276 skipSpace = B.dropWhile isSpace_ascii

277

278

279−

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

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

281buildQuery conn q template xs =

280buildQuery conn q template xs =

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

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

283 where split s =

282 where split s =

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

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

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

285+ let (h,t) = breakOnSingleQuestionMark s

285 in byteString h

286 in byteString h

286 : if B.null t

287 : if B.null t

287 then []

288 then []

288 else split (B.tail t)

289 else split (B.tail t)

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

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

290 zipParams [t] [] = t

291 zipParams [t] [] = t

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

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

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

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

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

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

295+ countSingleQs = go 0 template

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

297+ go i bs = case qms of

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

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

300+ _ -> i

301+ where qms = B.splitAt 1 qmBS

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

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

294

304

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

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

296-- expected to return results.

306-- expected to return results.

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

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

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

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

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

523 -> IO a

533 -> IO a

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

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

525

535

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

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

527foldWithOptionsAndParser_ :: FoldOptions

537foldWithOptionsAndParser_ :: FoldOptions

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

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

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

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

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

533 -> IO a

543 -> IO a

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

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

535

545

536doFold :: FoldOptions

546doFold :: FoldOptions

537 -> RowParser row

547 -> RowParser row

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

567 go = bracket declare closeCursor $ \cursor ->

577 go = bracket declare closeCursor $ \cursor ->

568 let loop a = fetch cursor a >>=

578 let loop a = fetch cursor a >>=

569 \r -> case r of

579 \r -> case r of

570− Left a -> return a

580+ Left x -> return x

571− Right a -> loop a

581+ Right x -> loop x

572 in loop a0

582 in loop a0

573

583

574-- FIXME: choose the Automatic chunkSize more intelligently

584-- FIXME: choose the Automatic chunkSize more intelligently

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/Copy.hs+1−1

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

48import qualified Database.PostgreSQL.LibPQ as PQ

49import Database.PostgreSQL.Simple

50import Database.PostgreSQL.Simple.Types

51−import Database.PostgreSQL.Simple.Internal

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

52

53

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

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

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

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 a !n

93+ loop x !n

94− | n > hi = return a

94+ | n > hi = return x

95 | otherwise = do

96− a' <- f a n

96+ x' <- f x n

97− loop a' (n+1)

97+ loop x' (n+1)

98{-# INLINE foldM' #-}

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

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

300

301-- | \"char\", bpchar

302instance FromField Char where

303− fromField f bs =

303+ fromField f bs0 =

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

305− then case bs of

305+ then case bs0 of

306 Nothing -> returnError UnexpectedNull f ""

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

308 then returnError ConversionFailed f "length not 1"

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

390

391unescapeBytea :: Field -> SB.ByteString

392 -> Conversion (Binary SB.ByteString)

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

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

394 Nothing -> returnError ConversionFailed f "unescapeBytea failed"

395 Just str -> pure (Binary str)

396

@@ -477,12 +477,12 @@ instance FromField Date where

477

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

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

480−ff compatOid hsType parse f mstr =

480+ff compatOid hsType parseBS f mstr =

481 if typeOid f /= compatOid

482 then err Incompatible ""

483 else case mstr of

484 Nothing -> err UnexpectedNull ""

485− Just str -> case parse str of

485+ Just str -> case parseBS str of

486 Left msg -> err ConversionFailed msg

487 Right val -> return val

488 where

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

520 _ -> returnError Incompatible f ""

521

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

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

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

524 where

525− delim = typdelim (typelem typeInfo)

525+ delim = typdelim (typelem typInfo)

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

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

527

528 parseIt item =

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

@@ -552,8 +552,8 @@ instance FromField UUID where

552

553-- | json, jsonb

554instance FromField JSON.Value where

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

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

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

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

557 Left err -> returnError ConversionFailed f err

558 Right val -> pure val

559

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+3−3

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

53toBuilder :: HStoreBuilder -> Builder

54toBuilder x = case x of

55 Empty -> mempty

56− Comma x -> x

56+ Comma c -> c

57

58toLazyByteString :: HStoreBuilder -> BL.ByteString

59toLazyByteString x = case x of

60 Empty -> BL.empty

61− Comma x -> BU.toLazyByteString x

61+ Comma c -> BU.toLazyByteString c

62

63instance Semigroup HStoreBuilder where

64 Empty <> x = x

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

150

151instance ToHStore HStoreMap where

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

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

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

154

155instance ToField HStoreMap where

156 toField xs = toField (toHStore xs)

src/Database/PostgreSQL/Simple/Internal.hs+22−6

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

290

291 str name field

292 | null value = id

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

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

294 where value = field connectInfo

295

296 num name field

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

298 | otherwise = showString name . shows value . space

299 where value = field connectInfo

300

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

301+ addQuotes s rest = '\'' : foldr delta ('\'' : rest) s

302 where

303 delta c cs = case c of

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

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

386 nstr <- PQ.cmdTuples result

387 return $ case nstr of

388 Nothing -> 0 -- is this appropriate?

389− Just str -> toInteger str

389+ Just str -> mkInteger str

390 PQ.TuplesOk -> do

391 ncols <- PQ.nfields result

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

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

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

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

401 where

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

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

403 where

404 delta acc c =

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

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

414 PQ.resultErrorField result PQ.DiagMessageDetail

415 hint <- fromMaybe "" <$>

416 PQ.resultErrorField result PQ.DiagMessageHint

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

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

418− throwIO $ SqlError { sqlState = state

418+ throwIO $ SqlError { sqlState = state'

419 , sqlExecStatus = status

420 , sqlErrorMsg = errormsg

421 , sqlErrorDetail = detail

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

589

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

591escapeByteaConn = escapeWrap PQ.escapeByteaConn

592+

593+breakOnSingleQuestionMark :: ByteString -> (ByteString, ByteString)

594+breakOnSingleQuestionMark b = go (B8.empty, b)

595+ where go (x,bs) = (x `B8.append` x',bs')

596+ -- seperate from first QM

597+ where tup@(noQ, restWithQ) = B8.break (=='?') bs

598+ -- if end of query, just return

599+ -- else check for second QM in 'go2'

600+ (x', bs') = maybe tup go2 $

601+ -- drop found QM and peek at next char

602+ B8.uncons restWithQ >>= B8.uncons . snd

603+ -- another QM after the first means:

604+ -- take literal QM and keep going.

605+ go2 ('?', t2) = go (noQ `B8.snoc` '?',t2)

606+ -- Anything else means

607+ go2 _ = tup

src/Database/PostgreSQL/Simple/Internal/PQResultUtils.hs+1−1

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

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

29import Database.PostgreSQL.Simple.TypeInfo

30import qualified Database.PostgreSQL.LibPQ as PQ

31import qualified Data.ByteString.Char8 as B

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

@@ -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 x =

113+ checkLB lb y =

114 case lb of

115 NegInfinity -> True

116 PosInfinity -> False

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

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

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

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

119

120− checkUB ub x =

120+ checkUB ub y =

121 case ub of

122 NegInfinity -> False

123 PosInfinity -> True

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

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

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

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

126

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

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

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

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

319 where quote = char8 '\''

320

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

322−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

323{-# INLINE interleaveFoldr #-}

324

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

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

366

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

368 typedRows [] _ _ = error funcname

369− typedRows (val:vals) types rest =

369+ typedRows (val:vals) typs rest =

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

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

371

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

373 untypedRows [] _ = error funcname

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

test/Main.hs+84−22

@@ -4,18 +4,21 @@

4{-# LANGUAGE DoAndIfThenElse #-}

5{-# LANGUAGE ScopedTypeVariables #-}

6import Common

7+import Database.PostgreSQL.Simple.Copy

7import Database.PostgreSQL.Simple.FromField (FromField)

8import Database.PostgreSQL.Simple.FromField (FromField)

8−import Database.PostgreSQL.Simple.Types(Query(..),Values(..))

9import Database.PostgreSQL.Simple.HStore

10−import Database.PostgreSQL.Simple.Copy

10+import Database.PostgreSQL.Simple.Internal (breakOnSingleQuestionMark)

11+import Database.PostgreSQL.Simple.Types(Query(..),Values(..), PGArray(..))

11import qualified Database.PostgreSQL.Simple.Transaction as ST

12import qualified Database.PostgreSQL.Simple.Transaction as ST

12

13

13import Control.Applicative

14import Control.Applicative

14import Control.Exception as E

15import Control.Exception as E

15import Control.Monad

16import Control.Monad

16import Data.Char

17import Data.Char

17−import Data.List (sort)

18+import Data.List (concat, sort)

18import Data.IORef

19import Data.IORef

20+import Data.Monoid ((<>))

21+import Data.String (fromString)

19import Data.Typeable

22import Data.Typeable

20import GHC.Generics (Generic)

23import GHC.Generics (Generic)

21

24

@@ -44,26 +47,27 @@ tests :: TestEnv -> TestTree

44tests env = testGroup "tests"

47tests env = testGroup "tests"

45 $ map ($ env)

48 $ map ($ env)

46 [ testBytea

49 [ testBytea

47− , testCase "ExecuteMany" . testExecuteMany

50+ , testCase "ExecuteMany" . testExecuteMany

48− , testCase "Fold" . testFold

51+ , testCase "Fold" . testFold

49− , testCase "Notify" . testNotify

52+ , testCase "Notify" . testNotify

50− , testCase "Serializable" . testSerializable

53+ , testCase "Serializable" . testSerializable

51− , testCase "Time" . testTime

54+ , testCase "Time" . testTime

52− , testCase "Array" . testArray

55+ , testCase "Array" . testArray

53− , testCase "Array of nullables" . testNullableArray

56+ , testCase "Array of nullables" . testNullableArray

54− , testCase "HStore" . testHStore

57+ , testCase "HStore" . testHStore

55− , testCase "citext" . testCIText

58+ , testCase "citext" . testCIText

56− , testCase "JSON" . testJSON

59+ , testCase "JSON" . testJSON

60+ , testCase "Question mark escape" . testQM

57− , testCase "Savepoint" . testSavepoint

61+ , testCase "Savepoint" . testSavepoint

58− , testCase "Unicode" . testUnicode

62+ , testCase "Unicode" . testUnicode

59− , testCase "Values" . testValues

63+ , testCase "Values" . testValues

60− , testCase "Copy" . testCopy

64+ , testCase "Copy" . testCopy

61 , testCopyFailures

65 , testCopyFailures

62− , testCase "Double" . testDouble

66+ , testCase "Double" . testDouble

63− , testCase "1-ary generic" . testGeneric1

67+ , testCase "1-ary generic" . testGeneric1

64− , testCase "2-ary generic" . testGeneric2

68+ , testCase "2-ary generic" . testGeneric2

65− , testCase "3-ary generic" . testGeneric3

69+ , testCase "3-ary generic" . testGeneric3

66− , testCase "Timeout" . testTimeout

70+ , testCase "Timeout" . testTimeout

67 ]

71 ]

68

72

69testBytea :: TestEnv -> TestTree

73testBytea :: TestEnv -> TestTree

@@ -234,6 +238,56 @@ testJSON TestEnv{..} = do

234 js' <- query conn "SELECT ?::json" js

238 js' <- query conn "SELECT ?::json" js

235 [js] @?= js'

239 [js] @?= js'

236

240

241+testQM :: TestEnv -> Assertion

242+testQM TestEnv{..} = do

243+ -- Just test on a single string

244+ let testQuery' b = "testing for ?" <> b <> " and making sure "

245+ testQueryDoubleQM = testQuery' "?"

246+ testQueryRest = "? is substituted"

247+ testQuery = fromString $ testQueryDoubleQM <> testQueryRest

248+ -- expect the entire first part with double QMs replaced with literal '?'

249+ expected = (fromString $ testQuery' "", fromString testQueryRest)

250+ tried = breakOnSingleQuestionMark testQuery

251+ errMsg = concat

252+ [ "Failed to break on single question mark exclusively:\n"

253+ , "expected: ", show expected

254+ , "result: ", show tried

255+ ]

256+ assertBool errMsg $ tried == expected

257+

258+ -- Let's also test the question mark operators in action

259+ -- ? -> Does the string exist as a top-level key within the JSON value?

260+ positiveQuery "SELECT ?::jsonb ?? ?" (testObj, "foo" :: Text)

261+ negativeQuery "SELECT ?::jsonb ?? ?" (testObj, "baz" :: Text)

262+ negativeQuery "SELECT ?::jsonb ?? ?" (toJSON numArray, "1" :: Text)

263+ -- ?| -> Do any of these array strings exist as top-level keys?

264+ positiveQuery "SELECT ?::jsonb ??| ?" (testObj, PGArray ["nope","bar","6" :: Text])

265+ negativeQuery "SELECT ?::jsonb ??| ?" (testObj, PGArray ["nope","6" :: Text])

266+ negativeQuery "SELECT ?::jsonb ??| ?" (toJSON numArray, PGArray ["1","2","6" :: Text])

267+ -- ?& -> Do all of these array strings exist as top-level keys?

268+ positiveQuery "SELECT ?::jsonb ??& ?" (testObj, PGArray ["foo","bar","quux" :: Text])

269+ positiveQuery "SELECT ?::jsonb ??& ?" (testObj, PGArray ["foo","bar" :: Text])

270+ negativeQuery "SELECT ?::jsonb ??& ?" (testObj, PGArray ["foo","bar","baz" :: Text])

271+ negativeQuery "SELECT ?::jsonb ??& ?" (toJSON numArray, PGArray ["1","2","3","4","5" :: Text])

272+ -- Format error for 2 question marks, not 4

273+ True <- expectError (isFormatError 2) $

274+ (query conn "SELECT ?::jsonb ?? ?" $ Only testObj :: IO [Only Bool])

275+ return ()

276+ where positiveQuery :: ToRow a => Query -> a -> Assertion

277+ positiveQuery = boolQuery True

278+ negativeQuery :: ToRow a => Query -> a -> Assertion

279+ negativeQuery = boolQuery False

280+ numArray :: [Int]

281+ numArray = [1,2,3,4,5]

282+ boolQuery :: ToRow a => Bool -> Query -> a -> Assertion

283+ boolQuery b t x = do

284+ a <- query conn t x

285+ [Only b] @?= a

286+ testObj = toJSON (Map.fromList [("foo",toJSON (1 :: Int))

287+ ,("bar",String "baz")

288+ ,("quux",toJSON [1 :: Int,2,3,4,5])] :: Map Text Value

289+ )

290+

237testSavepoint :: TestEnv -> Assertion

291testSavepoint :: TestEnv -> Assertion

238testSavepoint TestEnv{..} = do

292testSavepoint TestEnv{..} = do

239 True <- expectError ST.isNoActiveTransactionError $

293 True <- expectError ST.isNoActiveTransactionError $

@@ -478,6 +532,14 @@ isUniqueViolation SqlError{..} = sqlState == "23505"

478isSyntaxError :: SqlError -> Bool

532isSyntaxError :: SqlError -> Bool

479isSyntaxError SqlError{..} = sqlState == "42601"

533isSyntaxError SqlError{..} = sqlState == "42601"

480

534

535+isFormatError :: Int -> FormatError -> Bool

536+isFormatError i FormatError{..}

537+ | null fmtMessage = False

538+ | otherwise = fmtMessage == concat [ show i

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

540+ , show (length fmtParams)

541+ , " parameters"

542+ ]

481------------------------------------------------------------------------

543------------------------------------------------------------------------

482

544

483-- | Action for connecting to the database that will be used for testing.

545-- | Action for connecting to the database that will be used for testing.