6e30ae7 · typeable/postgresql-simple

git.iko.soy/typeable/postgresql-simple

Escape double '??' to a literal '?'

This change makes it possible to use literal question marks in queries to PostgreSQL. This is needed to be able to use the new JSON operators. https://www.postgresql.org/docs/9.5/static/functions-json.html This change can't break anything, since: * Anyone using double question marks would get an error if not supplied the adequate amount of accompanying values (in case of people trying the new JSON operators); or * If supplied the adequate amount of accompanying values, PostgreSQL would throw a fit because you'd supply two values directly next to each other, which doesn't make sense.

commit6e30ae70ca2d4913f3da84744a50d9a3a7b3f911 authorFelix Paulusma <Vlix@users.noreply.github.com> dateWed 14 Mar 2018, 00:33 (9 years ago) parent80a8698

16 files changed+218−119

compare with master

unifiedsplit

.travis.yml+45−39

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

11# This Travis job script has been generated by a script via

22#

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'

44#

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

66#

77language: c

8−sudo: false

9−

10−services:

11− - postgresql

8+dist: xenial

129

1310git:

1411 submodules: false # whether to recursively clone submodules

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

2219 - $HOME/.cabal/packages

2320 - $HOME/.cabal/store

2421

22+services:

23+- postgresql

24+addons:

25+ postgresql: '10'

26+

2527before_cache:

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

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

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

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

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

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

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

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

3335

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

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

3537

3638matrix:

3739 include:

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

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

5961

6062before_install:

61− - HC=${CC}

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

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

6365 - unset CC

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

67+ - CABALHOME=$HOME/.cabal

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

6469 - ROOTDIR=$(pwd)

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

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

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

6871 - echo $HCNUMVER

6972

7073install:

71− - cabal --version

74+ - ${CABAL} --version

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

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

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

75− - HADDOCK=${HADDOCK-true}

7678 - UNCONSTRAINED=${UNCONSTRAINED-true}

77− - NOINSTALLEDCONSTRAINTS=${NOINSTALLEDCONSTRAINTS-false}

7879 - GHCHEAD=${GHCHEAD-false}

79− - travis_retry cabal update -v

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

80+ - travis_retry ${CABAL} update -v

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

8182 - rm -fv cabal.project cabal.project.local

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

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

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

84+ - rm -f cabal.project

85+ - touch cabal.project

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

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

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

8790 - cat cabal.project || true

8891 - cat cabal.project.local || true

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

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

91− fi

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

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

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"

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

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

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

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

97101

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

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

100104script:

101105 # test that source-distributions can be generated

102− - cabal new-sdist all

106+ - ${CABAL} new-sdist all

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

104108 - cd ${DISTDIR} || false

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

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

110+ - rm -f cabal.project

111+ - touch cabal.project

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

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

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

110116 - cat cabal.project || true

111117 - cat cabal.project.local || true

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

114120

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

122+ - ${CABAL} new-build -w ${HC} ${TEST} ${BENCH} all

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

118124

119− # cabal check

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

125+ # ${CABAL} check

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

121127

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

124130

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

127133

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

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

129135# EOF

CHANGES.md+2−2

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

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

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.

55 Consider a downstream library depending already both on

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

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

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

317317

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

320320

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

322322 foldWithOptions, executeMany, and returning operators.

cabal.haskell-cinew file+5

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

1+branches: master

2+postgresql: True

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

5+-- osx: 8.4.4

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

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

276276 skipSpace = B.dropWhile isSpace_ascii

277277

278278

279−

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

281280buildQuery conn q template xs =

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

283282 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

285286 in byteString h

286287 : if B.null t

287288 then []

288289 else split (B.tail t)

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

290291 zipParams [t] [] = t

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

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

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

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

293294 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

294304

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

296306-- expected to return results.

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

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

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

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

525535

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

527537foldWithOptionsAndParser_ :: FoldOptions

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

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

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

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

535545

536546doFold :: FoldOptions

537547 -> RowParser row

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

567577 go = bracket declare closeCursor $ \cursor ->

568578 let loop a = fetch cursor a >>=

569579 \r -> case r of

570− Left a -> return a

571− Right a -> loop a

580+ Left x -> return x

581+ Right x -> loop x

572582 in loop a0

573583

574584-- 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 '}'

4242quoted :: Parser ByteString

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

4444 where

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

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

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

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

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

4848

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

5050-- not containing the delimiter character.

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

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

4848import qualified Database.PostgreSQL.LibPQ as PQ

4949import Database.PostgreSQL.Simple

5050import Database.PostgreSQL.Simple.Types

51−import Database.PostgreSQL.Simple.Internal

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

5252

5353

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

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

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

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

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

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

3434import Database.PostgreSQL.Simple.Internal.PQResultUtils

3535import Database.PostgreSQL.Simple.Transaction

3636import qualified Database.PostgreSQL.LibPQ as PQ

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

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

9191foldM' f a lo hi = loop a lo

9292 where

93− loop a !n

94− | n > hi = return a

93+ loop x !n

94+ | n > hi = return x

9595 | otherwise = do

96− a' <- f a n

97− loop a' (n+1)

96+ x' <- f x n

97+ loop x' (n+1)

9898{-# INLINE foldM' #-}

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

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

300300

301301-- | \"char\", bpchar

302302instance FromField Char where

303− fromField f bs =

303+ fromField f bs0 =

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

305− then case bs of

305+ then case bs0 of

306306 Nothing -> returnError UnexpectedNull f ""

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

308308 then returnError ConversionFailed f "length not 1"

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

390390

391391unescapeBytea :: Field -> SB.ByteString

392392 -> Conversion (Binary SB.ByteString)

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

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

394394 Nothing -> returnError ConversionFailed f "unescapeBytea failed"

395395 Just str -> pure (Binary str)

396396

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

477477

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

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

480−ff compatOid hsType parse f mstr =

480+ff compatOid hsType parseBS f mstr =

481481 if typeOid f /= compatOid

482482 then err Incompatible ""

483483 else case mstr of

484484 Nothing -> err UnexpectedNull ""

485− Just str -> case parse str of

485+ Just str -> case parseBS str of

486486 Left msg -> err ConversionFailed msg

487487 Right val -> return val

488488 where

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

520520 _ -> returnError Incompatible f ""

521521

522522fromArray :: 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

524524 where

525− delim = typdelim (typelem typeInfo)

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

525+ delim = typdelim (typelem typInfo)

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

527527

528528 parseIt item =

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

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

552552

553553-- | json, jsonb

554554instance FromField JSON.Value where

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

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

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

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

557557 Left err -> returnError ConversionFailed f err

558558 Right val -> pure val

559559

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

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

131131 else do

132132 let !result = rowresult

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

134− !field = Field{..}

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

134+ !field' = Field{..}

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

136136

137137field :: FromField a => RowParser a

138138field = fieldWith fromField

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

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

5353toBuilder :: HStoreBuilder -> Builder

5454toBuilder x = case x of

5555 Empty -> mempty

56− Comma x -> x

56+ Comma c -> c

5757

5858toLazyByteString :: HStoreBuilder -> BL.ByteString

5959toLazyByteString x = case x of

6060 Empty -> BL.empty

61− Comma x -> BU.toLazyByteString x

61+ Comma c -> BU.toLazyByteString c

6262

6363instance Semigroup HStoreBuilder where

6464 Empty <> x = x

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

150150

151151instance ToHStore HStoreMap where

152152 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'

154154

155155instance ToField HStoreMap where

156156 toField xs = toField (toHStore xs)

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

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

290290

291291 str name field

292292 | null value = id

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

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

294294 where value = field connectInfo

295295

296296 num name field

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

298298 | otherwise = showString name . shows value . space

299299 where value = field connectInfo

300300

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

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

302302 where

303303 delta c cs = case c of

304304 '\\' -> '\\' : '\\' : cs

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

386386 nstr <- PQ.cmdTuples result

387387 return $ case nstr of

388388 Nothing -> 0 -- is this appropriate?

389− Just str -> toInteger str

389+ Just str -> mkInteger str

390390 PQ.TuplesOk -> do

391391 ncols <- PQ.nfields result

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

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

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

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

401401 where

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

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

403403 where

404404 delta acc c =

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

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

414414 PQ.resultErrorField result PQ.DiagMessageDetail

415415 hint <- fromMaybe "" <$>

416416 PQ.resultErrorField result PQ.DiagMessageHint

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

418− throwIO $ SqlError { sqlState = state

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

418+ throwIO $ SqlError { sqlState = state'

419419 , sqlExecStatus = status

420420 , sqlErrorMsg = errormsg

421421 , sqlErrorDetail = detail

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

589589

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

591591escapeByteaConn = 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_)

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

2626import Database.PostgreSQL.Simple.Ok

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

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

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

2929import Database.PostgreSQL.Simple.TypeInfo

3030import qualified Database.PostgreSQL.LibPQ as PQ

3131import qualified Data.ByteString.Char8 as B

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

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

110110 PGRange _lb NegInfinity -> False

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

112112 where

113− checkLB lb x =

113+ checkLB lb y =

114114 case lb of

115115 NegInfinity -> True

116116 PosInfinity -> False

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

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

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

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

119119

120− checkUB ub x =

120+ checkUB ub y =

121121 case ub of

122122 NegInfinity -> False

123123 PosInfinity -> True

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

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

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

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

126126

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

128128lowerBound = (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

319319 where quote = char8 '\''

320320

321321interleaveFoldr :: (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

323323{-# INLINE interleaveFoldr #-}

324324

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

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

366366

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

368368 typedRows [] _ _ = error funcname

369− typedRows (val:vals) types rest =

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

369+ typedRows (val:vals) typs rest =

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

371371

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

373373 untypedRows [] _ = error funcname

src/Database/PostgreSQL/Simple/TypeInfo.hs+9−9

@@ -50,21 +50,21 @@ import Database.PostgreSQL.Simple.TypeInfo.Static

5050-- in the connections's cache.

5151

5252getTypeInfo :: Connection -> PQ.Oid -> IO TypeInfo

53−getTypeInfo conn@Connection{..} oid =

54− case staticTypeInfo oid of

55− Just name -> return name

56− Nothing -> modifyMVar connectionObjects $ getTypeInfo' conn oid

53+getTypeInfo conn@Connection{..} oid' =

54+ case staticTypeInfo oid' of

55+ Just name' -> return name'

56+ Nothing -> modifyMVar connectionObjects $ getTypeInfo' conn oid'

5757

5858getTypeInfo' :: Connection -> PQ.Oid -> TypeInfoCache

5959 -> IO (TypeInfoCache, TypeInfo)

60−getTypeInfo' conn oid oidmap =

61− case IntMap.lookup (oid2int oid) oidmap of

60+getTypeInfo' conn oid' oidmap =

61+ case IntMap.lookup (oid2int oid') oidmap of

6262 Just typeinfo -> return (oidmap, typeinfo)

6363 Nothing -> do

6464 names <- query conn "SELECT oid, typcategory, typdelim, typname,\

6565 \ typelem, typrelid\

6666 \ FROM pg_type WHERE oid = ?"

67− (Only oid)

67+ (Only oid')

6868 (oidmap', typeInfo) <-

6969 case names of

7070 [] -> return $ throw (fatalError "invalid type oid")

@@ -78,7 +78,7 @@ getTypeInfo' conn oid oidmap =

7878 rngsubtypeOids <- query conn "SELECT rngsubtype\

7979 \ FROM pg_range\

8080 \ WHERE rngtypid = ?"

81− (Only oid)

81+ (Only oid')

8282 case rngsubtypeOids of

8383 [Only rngsubtype_] -> do

8484 (oidmap', rngsubtype) <-

@@ -104,7 +104,7 @@ getTypeInfo' conn oid oidmap =

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

105105 -- oid is a primary key, so the query should

106106 -- never return more than one result

107− let !oidmap'' = IntMap.insert (oid2int oid) typeInfo oidmap'

107+ let !oidmap'' = IntMap.insert (oid2int oid') typeInfo oidmap'

108108 return $! (oidmap'', typeInfo)

109109

110110getAttInfos :: Connection -> [(B.ByteString, PQ.Oid)] -> TypeInfoCache

test/Main.hs+84−22

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

44{-# LANGUAGE DoAndIfThenElse #-}

55{-# LANGUAGE ScopedTypeVariables #-}

66import Common

7+import Database.PostgreSQL.Simple.Copy

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

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

99import 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(..))

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

1213

1314import Control.Applicative

1415import Control.Exception as E

1516import Control.Monad

1617import Data.Char

17−import Data.List (sort)

18+import Data.List (concat, sort)

1819import Data.IORef

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

21+import Data.String (fromString)

1922import Data.Typeable

2023import GHC.Generics (Generic)

2124

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

4447tests env = testGroup "tests"

4548 $ map ($ env)

4649 [ testBytea

47− , testCase "ExecuteMany" . testExecuteMany

48− , testCase "Fold" . testFold

49− , testCase "Notify" . testNotify

50− , testCase "Serializable" . testSerializable

51− , testCase "Time" . testTime

52− , testCase "Array" . testArray

53− , testCase "Array of nullables" . testNullableArray

54− , testCase "HStore" . testHStore

55− , testCase "citext" . testCIText

56− , testCase "JSON" . testJSON

57− , testCase "Savepoint" . testSavepoint

58− , testCase "Unicode" . testUnicode

59− , testCase "Values" . testValues

60− , testCase "Copy" . testCopy

50+ , testCase "ExecuteMany" . testExecuteMany

51+ , testCase "Fold" . testFold

52+ , testCase "Notify" . testNotify

53+ , testCase "Serializable" . testSerializable

54+ , testCase "Time" . testTime

55+ , testCase "Array" . testArray

56+ , testCase "Array of nullables" . testNullableArray

57+ , testCase "HStore" . testHStore

58+ , testCase "citext" . testCIText

59+ , testCase "JSON" . testJSON

60+ , testCase "Question mark escape" . testQM

61+ , testCase "Savepoint" . testSavepoint

62+ , testCase "Unicode" . testUnicode

63+ , testCase "Values" . testValues

64+ , testCase "Copy" . testCopy

6165 , testCopyFailures

62− , testCase "Double" . testDouble

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

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

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

66− , testCase "Timeout" . testTimeout

66+ , testCase "Double" . testDouble

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

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

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

70+ , testCase "Timeout" . testTimeout

6771 ]

6872

6973testBytea :: TestEnv -> TestTree

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

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

235239 [js] @?= js'

236240

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+

237291testSavepoint :: TestEnv -> Assertion

238292testSavepoint TestEnv{..} = do

239293 True <- expectError ST.isNoActiveTransactionError $

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

478532isSyntaxError :: SqlError -> Bool

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

480534

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

481543------------------------------------------------------------------------

482544

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