diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,3 +1,14 @@ +# 0.5.1.0 + +## Added features + + * `MonadBase` and `MonadBaseControl` instances for `Pg` + +## Bug fixes + + * Fix possible memory corruption by copying row data + * Remove invalid parentheses emitted by `pgUnnest` + # 0.5.0.0 ## Interface changes @@ -25,6 +36,10 @@ * Only detect primary keys of tables in visible schemas * Fix emitting of `DECIMAL` type * Report JSON correct decoding errors instead of throwing `UnexpectedNull` + +## Behavior changes + + * `runReturningOne` and `runResturningList` now fetch all rows at once instead of using cursors # 0.4.0.0 diff --git a/Database/Beam/Postgres/Connection.hs b/Database/Beam/Postgres/Connection.hs --- a/Database/Beam/Postgres/Connection.hs +++ b/Database/Beam/Postgres/Connection.hs @@ -26,8 +26,10 @@ , postgresUriSyntax ) where import Control.Exception (SomeException(..), throwIO) +import Control.Monad.Base (MonadBase(..)) import Control.Monad.Free.Church import Control.Monad.IO.Class +import Control.Monad.Trans.Control (MonadBaseControl(..)) import Database.Beam hiding (runDelete, runUpdate, runInsert, insert) import Database.Beam.Backend.SQL.BeamExtensions @@ -141,7 +143,7 @@ step (ParseOneField _) curCol colCount _ | curCol >= colCount = pure (Left (BeamRowReadError (Just (fromIntegral curCol)) (ColumnNotEnoughColumns (fromIntegral colCount)))) step (ParseOneField (next' :: next -> _)) curCol colCount (field:remainingFields) = - do fieldValue <- Pg.getvalue res rowIdx (Pg.Col curCol) + do fieldValue <- Pg.getvalue' res rowIdx (Pg.Col curCol) res' <- Pg.runConversion (Pg.fromField field fieldValue) conn case res' of Pg.Errors errs -> @@ -182,7 +184,7 @@ withPgDebug dbg conn (Pg action) = let finish x = pure (Right x) step (PgLiftIO io next) = io >>= next - step (PgLiftWithHandle withConn next) = withConn conn >>= next + step (PgLiftWithHandle withConn next) = withConn dbg conn >>= next step (PgFetchNext next) = next Nothing step (PgRunReturning CursorBatching (PgCommandSyntax PgCommandTypeQuery syntax) @@ -232,7 +234,7 @@ stepReturningNone :: forall a. PgF (IO (Either BeamRowReadError a)) -> IO (Either BeamRowReadError a) stepReturningNone (PgLiftIO action' next) = action' >>= next - stepReturningNone (PgLiftWithHandle withConn next) = withConn conn >>= next + stepReturningNone (PgLiftWithHandle withConn next) = withConn dbg conn >>= next stepReturningNone (PgFetchNext next) = next Nothing stepReturningNone (PgRunReturning {}) = pure (Left (BeamRowReadError Nothing (ColumnErrorInternal "Nested queries not allowed"))) @@ -286,7 +288,7 @@ PgFetchNext :: FromBackendRow Postgres x => (Maybe x -> next) -> PgF next - PgLiftWithHandle :: (Pg.Connection -> IO a) -> (a -> next) -> PgF next + PgLiftWithHandle :: ((String -> IO ()) -> Pg.Connection -> IO a) -> (a -> next) -> PgF next deriving instance Functor PgF -- | How to fetch results. @@ -309,8 +311,19 @@ instance MonadIO Pg where liftIO x = liftF (PgLiftIO x id) +instance MonadBase IO Pg where + liftBase = liftIO + +instance MonadBaseControl IO Pg where + type StM Pg a = a + + liftBaseWith action = + liftF (PgLiftWithHandle (\dbg conn -> action (runBeamPostgresDebug dbg conn)) id) + + restoreM = pure + liftIOWithHandle :: (Pg.Connection -> IO a) -> Pg a -liftIOWithHandle f = liftF (PgLiftWithHandle f id) +liftIOWithHandle f = liftF (PgLiftWithHandle (\_ -> f) id) runBeamPostgresDebug :: (String -> IO ()) -> Pg.Connection -> Pg a -> IO a runBeamPostgresDebug dbg conn action = diff --git a/Database/Beam/Postgres/PgSpecific.hs b/Database/Beam/Postgres/PgSpecific.hs --- a/Database/Beam/Postgres/PgSpecific.hs +++ b/Database/Beam/Postgres/PgSpecific.hs @@ -1407,8 +1407,7 @@ . Beamable tbl => QExpr Postgres s (PgSetOf tbl) -> Q Postgres db s (QExprTable Postgres s tbl) -pgUnnest (QExpr q) = - pgUnnest' (\t -> pgParens (fromPgExpression (q t))) +pgUnnest (QExpr q) = pgUnnest' $ fromPgExpression . q data PgUnnestArrayTbl a f = PgUnnestArrayTbl (C f a) deriving Generic diff --git a/beam-postgres.cabal b/beam-postgres.cabal --- a/beam-postgres.cabal +++ b/beam-postgres.cabal @@ -1,5 +1,5 @@ name: beam-postgres -version: 0.5.0.0 +version: 0.5.1.0 synopsis: Connection layer between beam and postgres description: Beam driver for , an advanced open-source RDBMS homepage: https://haskell-beam.github.io/beam/user-guide/backends/beam-postgres @@ -50,7 +50,7 @@ monad-control >=1.0 && <1.1, mtl >=2.1 && <2.3, conduit >=1.2 && <1.4, - aeson >=0.11 && <1.5, + aeson >=0.11 && <1.6, uuid-types >=1.0 && <1.1, case-insensitive >=1.2 && <1.3, scientific >=0.3 && <0.4, @@ -58,6 +58,7 @@ network-uri >=2.6 && <2.7, unordered-containers >= 0.2 && <0.3, tagged >=0.8 && <0.9, + transformers-base >=0.4 && <0.5, haskell-src-exts >=1.18 && <1.24 default-language: Haskell2010 diff --git a/test/Database/Beam/Postgres/Test/Select.hs b/test/Database/Beam/Postgres/Test/Select.hs --- a/test/Database/Beam/Postgres/Test/Select.hs +++ b/test/Database/Beam/Postgres/Test/Select.hs @@ -40,6 +40,7 @@ ] , testInRowValues getConn , testReturningMany getConn + , testPgUnnest getConn ] testPgArrayToJSON :: IO ByteString -> TestTree @@ -103,3 +104,13 @@ testFunction :: IO ByteString -> String -> (Connection -> Assertion) -> TestTree testFunction getConn name mkAssertion = testCase name $ withTestPostgres name getConn mkAssertion + +-- | Regression test for +testPgUnnest :: IO ByteString -> TestTree +testPgUnnest getConn = testCase "pgUnnest works" $ + withTestPostgres "pg_unnest" getConn $ \conn -> do + let values = [Bool True, Number 1] + result <- runBeamPostgres conn $ runSelectReturningList $ select $ + pgUnnest $ pgJsonArrayElements $ val_ $ + PgJSONB $ Array $ V.fromList values + assertEqual "result" (PgJSONB <$> values) $ pgJsonElement <$> result