diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,3 +1,17 @@ +# 0.5.2.0 + +## Added features + + * New `conduit` streaming variants which work directly in `MonadResource` + * Heterogeneous variant of `ilike_`: `ilike_'` + * Postgres-specific `EXTRACT` fields + * GHC 9.2 and 9.0 support + +## Bug fixes + + * Throw correct exception for row errors in `conduit` implementation + * Support emitting UUID values in context where type cannot be inferred by Postgres + # 0.5.1.0 ## Added features diff --git a/Database/Beam/Postgres/Conduit.hs b/Database/Beam/Postgres/Conduit.hs --- a/Database/Beam/Postgres/Conduit.hs +++ b/Database/Beam/Postgres/Conduit.hs @@ -1,28 +1,51 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} -- | More efficient query execution functions for @beam-postgres@. These -- functions use the @conduit@ package, to execute @beam-postgres@ statements in -- an arbitrary 'MonadIO'. These functions may be more efficient for streaming -- operations than 'MonadBeam'. -module Database.Beam.Postgres.Conduit where +module Database.Beam.Postgres.Conduit + ( streamingRunSelect + , runInsert + , streamingRunInsertReturning + , runUpdate + , streamingRunUpdateReturning + , runDelete + , streamingRunDeleteReturning + , executeStatement + , streamingRunQueryReturning + -- * Deprecated streaming variants + , runSelect + , runInsertReturning + , runUpdateReturning + , runDeleteReturning + , runQueryReturning + ) where -import Database.Beam +import Database.Beam hiding (runInsert, runUpdate, runDelete) import Database.Beam.Postgres.Connection import Database.Beam.Postgres.Full import Database.Beam.Postgres.Syntax import Database.Beam.Postgres.Types +import Control.Concurrent.MVar (takeMVar, putMVar) +import Control.Exception.Base (bracket, throwIO) import Control.Exception.Lifted (finally) +import qualified Control.Exception.Lifted as Lifted +import qualified Control.Concurrent.MVar.Lifted as Lifted import Control.Monad.Trans.Control (MonadBaseControl) import qualified Database.PostgreSQL.LibPQ as Pg hiding (Connection, escapeStringConn, escapeIdentifier, escapeByteaConn, exec) +import qualified Database.PostgreSQL.LibPQ as Pq import qualified Database.PostgreSQL.Simple as Pg -import qualified Database.PostgreSQL.Simple.Internal as Pg (withConnection) +import qualified Database.PostgreSQL.Simple.Internal as Pg +import Database.PostgreSQL.Simple.Internal (connectionHandle) import qualified Database.PostgreSQL.Simple.Types as Pg (Query(..)) -import qualified Data.Conduit as C +import qualified Conduit as C import Data.Int (Int64) import Data.Maybe (fromMaybe) #if !MIN_VERSION_base(4, 11, 0) @@ -39,13 +62,22 @@ -- * @SELECT@ +-- | Run a PostgreSQL @SELECT@ statement in any 'C.MonadResource'. +streamingRunSelect :: ( C.MonadResource m, Fail.MonadFail m, FromBackendRow Postgres a ) + => Pg.Connection -> SqlSelect Postgres a + -> CONDUIT_TRANSFORMER () a m () +streamingRunSelect conn (SqlSelect (PgSelectSyntax syntax)) = + streamingRunQueryReturning conn syntax + -- | Run a PostgreSQL @SELECT@ statement in any 'MonadIO'. runSelect :: ( MonadIO m, Fail.MonadFail m, MonadBaseControl IO m, FromBackendRow Postgres a ) => Pg.Connection -> SqlSelect Postgres a -> (CONDUIT_TRANSFORMER () a m () -> m b) -> m b runSelect conn (SqlSelect (PgSelectSyntax syntax)) withSrc = runQueryReturning conn syntax withSrc +{-# DEPRECATED runSelect "Use streamingRunSelect" #-} + -- * @INSERT@ -- | Run a PostgreSQL @INSERT@ statement in any 'MonadIO'. Returns the number of @@ -56,6 +88,16 @@ runInsert conn (SqlInsert _ (PgInsertSyntax i)) = executeStatement conn i +-- | Run a PostgreSQL @INSERT ... RETURNING ...@ statement in any 'C.MonadResource' and +-- get a 'C.Source' of the newly inserted rows. +streamingRunInsertReturning :: ( C.MonadResource m, Fail.MonadFail m, FromBackendRow Postgres a ) + => Pg.Connection + -> PgInsertReturning a + -> CONDUIT_TRANSFORMER () a m () +streamingRunInsertReturning _ PgInsertReturningEmpty = pure () +streamingRunInsertReturning conn (PgInsertReturning i) = + streamingRunQueryReturning conn i + -- | Run a PostgreSQL @INSERT ... RETURNING ...@ statement in any 'MonadIO' and -- get a 'C.Source' of the newly inserted rows. runInsertReturning :: ( MonadIO m, Fail.MonadFail m, MonadBaseControl IO m, FromBackendRow Postgres a ) @@ -66,6 +108,7 @@ runInsertReturning _ PgInsertReturningEmpty withSrc = withSrc (pure ()) runInsertReturning conn (PgInsertReturning i) withSrc = runQueryReturning conn i withSrc +{-# DEPRECATED runInsertReturning "Use streamingRunInsertReturning" #-} -- * @UPDATE@ @@ -77,6 +120,16 @@ runUpdate conn (SqlUpdate _ (PgUpdateSyntax i)) = executeStatement conn i +-- | Run a PostgreSQL @UPDATE ... RETURNING ...@ statement in any 'C.MonadResource' and +-- get a 'C.Source' of the newly updated rows. +streamingRunUpdateReturning :: ( C.MonadResource m, Fail.MonadFail m, FromBackendRow Postgres a) + => Pg.Connection + -> PgUpdateReturning a + -> CONDUIT_TRANSFORMER () a m () +streamingRunUpdateReturning _ PgUpdateReturningEmpty = pure () +streamingRunUpdateReturning conn (PgUpdateReturning u) = + streamingRunQueryReturning conn u + -- | Run a PostgreSQL @UPDATE ... RETURNING ...@ statement in any 'MonadIO' and -- get a 'C.Source' of the newly updated rows. runUpdateReturning :: ( MonadIO m, Fail.MonadFail m, MonadBaseControl IO m, FromBackendRow Postgres a) @@ -87,6 +140,7 @@ runUpdateReturning _ PgUpdateReturningEmpty withSrc = withSrc (pure ()) runUpdateReturning conn (PgUpdateReturning u) withSrc = runQueryReturning conn u withSrc +{-# DEPRECATED runUpdateReturning "Use streamingRunUpdateReturning" #-} -- * @DELETE@ @@ -99,12 +153,21 @@ executeStatement conn d -- | Run a PostgreSQl @DELETE ... RETURNING ...@ statement in any +-- 'C.MonadResource' and get a 'C.Source' of the deleted rows. +streamingRunDeleteReturning :: ( C.MonadResource m, Fail.MonadFail m, FromBackendRow Postgres a ) + => Pg.Connection -> PgDeleteReturning a + -> CONDUIT_TRANSFORMER () a m () +streamingRunDeleteReturning conn (PgDeleteReturning d) = + streamingRunQueryReturning conn d + +-- | Run a PostgreSQl @DELETE ... RETURNING ...@ statement in any -- 'MonadIO' and get a 'C.Source' of the deleted rows. runDeleteReturning :: ( MonadIO m, Fail.MonadFail m, MonadBaseControl IO m, FromBackendRow Postgres a ) => Pg.Connection -> PgDeleteReturning a -> (CONDUIT_TRANSFORMER () a m () -> m b) -> m b runDeleteReturning conn (PgDeleteReturning d) withSrc = runQueryReturning conn d withSrc +{-# DEPRECATED runDeleteReturning "Use streamingRunDeleteReturning" #-} -- * Convenience functions @@ -115,77 +178,122 @@ syntax <- pgRenderSyntax conn x Pg.execute_ conn (Pg.Query syntax) + -- | Runs any query that returns a set of values -runQueryReturning - :: ( MonadIO m, Fail.MonadFail m, MonadBaseControl IO m, Functor m, FromBackendRow Postgres r ) +streamingRunQueryReturning + :: ( C.MonadResource m, Fail.MonadFail m, FromBackendRow Postgres r ) => Pg.Connection -> PgSyntax - -> (CONDUIT_TRANSFORMER () r m () -> m b) - -> m b -runQueryReturning conn x withSrc = do - success <- liftIO $ do - syntax <- pgRenderSyntax conn x + -> CONDUIT_TRANSFORMER () r m () +streamingRunQueryReturning (conn@Pg.Connection {connectionHandle}) x = do + syntax <- liftIO $ pgRenderSyntax conn x + -- We need to own the connection for the duration of the conduit's + -- lifetime, since it will be in a streaming state until we clean up + C.bracketP + (takeMVar connectionHandle) + (putMVar connectionHandle) + (\conn' -> do + success <- liftIO $ + if Pg.isNullConnection conn' + then throwIO Pg.disconnectedError + else Pg.sendQuery conn' syntax - Pg.withConnection conn (\conn' -> Pg.sendQuery conn' syntax) + if success + then do + singleRowModeSet <- liftIO $ Pg.setSingleRowMode conn' + if singleRowModeSet + then + C.bracketP + (pure ()) + (\_ -> gracefulShutdown conn') + (\_ -> streamResults conn conn' Nothing) + else Fail.fail "Could not enable single row mode" + else do + errMsg <- fromMaybe "No libpq error provided" <$> liftIO (Pg.errorMessage conn') + Fail.fail (show errMsg)) - if success - then do - singleRowModeSet <- liftIO (Pg.withConnection conn Pg.setSingleRowMode) - if singleRowModeSet - then withSrc (streamResults Nothing) `finally` gracefulShutdown - else Fail.fail "Could not enable single row mode" - else do - errMsg <- fromMaybe "No libpq error provided" <$> liftIO (Pg.withConnection conn Pg.errorMessage) - Fail.fail (show errMsg) +streamResults :: (Fail.MonadFail m, FromBackendRow Postgres r, MonadIO m) => Pg.Connection -> Pq.Connection -> Maybe [Pg.Field] -> C.ConduitT i r m () +streamResults (conn@Pg.Connection {connectionHandle}) conn' fields = do + nextRow <- liftIO (Pg.getResult conn') + case nextRow of + Nothing -> pure () + Just row -> + liftIO (Pg.resultStatus row) >>= + \case + Pg.SingleTuple -> + do fields' <- liftIO (maybe (getFields row) pure fields) + parsedRow <- liftIO $ bracket + (putMVar connectionHandle conn') + (\_ -> takeMVar connectionHandle) + (\_ -> runPgRowReader conn 0 row fields' fromBackendRow) + case parsedRow of + Left err -> liftIO (bailEarly conn' row ("Could not read row: " <> show err)) + Right parsedRow' -> + do C.yield parsedRow' + streamResults conn conn' (Just fields') + Pg.TuplesOk -> liftIO (finishQuery conn') + Pg.EmptyQuery -> Fail.fail "No query" + Pg.CommandOk -> pure () + status@Pg.BadResponse -> liftIO (Pg.throwResultError "streamResults" row status) + status@Pg.NonfatalError -> liftIO (Pg.throwResultError "streamResults" row status) + status@Pg.FatalError -> liftIO (Pg.throwResultError "streamResults" row status) + _ -> do errMsg <- liftIO (Pg.resultErrorMessage row) + Fail.fail ("Postgres error: " <> show errMsg) - where - streamResults fields = do - nextRow <- liftIO (Pg.withConnection conn Pg.getResult) - case nextRow of - Nothing -> pure () - Just row -> - liftIO (Pg.resultStatus row) >>= - \case - Pg.SingleTuple -> - do fields' <- liftIO (maybe (getFields row) pure fields) - parsedRow <- liftIO (runPgRowReader conn 0 row fields' fromBackendRow) - case parsedRow of - Left err -> liftIO (bailEarly row ("Could not read row: " <> show err)) - Right parsedRow' -> - do C.yield parsedRow' - streamResults (Just fields') - Pg.TuplesOk -> liftIO (Pg.withConnection conn finishQuery) - Pg.EmptyQuery -> Fail.fail "No query" - Pg.CommandOk -> pure () - _ -> do errMsg <- liftIO (Pg.resultErrorMessage row) - Fail.fail ("Postgres error: " <> show errMsg) +bailEarly :: Pq.Connection -> Pg.Result -> String -> IO a +bailEarly conn' row errorString = do + Pg.unsafeFreeResult row + cancelQuery conn' + Fail.fail errorString - bailEarly row errorString = do - Pg.unsafeFreeResult row - Pg.withConnection conn $ cancelQuery - Fail.fail errorString +cancelQuery :: Pq.Connection -> IO () +cancelQuery conn' = do + cancel <- Pg.getCancel conn' + case cancel of + Nothing -> pure () + Just cancel' -> do + res <- Pg.cancel cancel' + case res of + Right () -> liftIO (finishQuery conn') + Left err -> Fail.fail ("Could not cancel: " <> show err) - cancelQuery conn' = do - cancel <- Pg.getCancel conn' - case cancel of - Nothing -> pure () - Just cancel' -> do - res <- Pg.cancel cancel' - case res of - Right () -> liftIO (finishQuery conn') - Left err -> Fail.fail ("Could not cancel: " <> show err) +finishQuery :: Pq.Connection -> IO () +finishQuery conn' = do + nextRow <- Pg.getResult conn' + case nextRow of + Nothing -> pure () + Just _ -> finishQuery conn' - finishQuery conn' = do - nextRow <- Pg.getResult conn' - case nextRow of - Nothing -> pure () - Just _ -> finishQuery conn' +gracefulShutdown :: Pq.Connection -> IO () +gracefulShutdown conn' = do + sts <- Pg.transactionStatus conn' + case sts of + Pg.TransIdle -> pure () + Pg.TransInTrans -> pure () + Pg.TransInError -> pure () + Pg.TransUnknown -> pure () + Pg.TransActive -> cancelQuery conn' - gracefulShutdown = - liftIO . Pg.withConnection conn $ \conn' -> - do sts <- Pg.transactionStatus conn' - case sts of - Pg.TransIdle -> pure () - Pg.TransInTrans -> pure () - Pg.TransInError -> pure () - Pg.TransUnknown -> pure () - Pg.TransActive -> cancelQuery conn' +-- | Runs any query that returns a set of values +runQueryReturning + :: ( MonadIO m, Fail.MonadFail m, MonadBaseControl IO m, Functor m, FromBackendRow Postgres r ) + => Pg.Connection -> PgSyntax + -> (CONDUIT_TRANSFORMER () r m () -> m b) + -> m b +runQueryReturning (conn@Pg.Connection {connectionHandle}) x withSrc = do + syntax <- liftIO $ pgRenderSyntax conn x + + Lifted.bracket + (Lifted.takeMVar connectionHandle) + (Lifted.putMVar connectionHandle) + (\conn' -> do + success <- liftIO $ Pg.sendQuery conn' syntax + if success + then do + singleRowModeSet <- liftIO (Pg.setSingleRowMode conn') + if singleRowModeSet + then withSrc (streamResults conn conn' Nothing) `finally` (liftIO $ gracefulShutdown conn') + else Fail.fail "Could not enable single row mode" + else do + errMsg <- fromMaybe "No libpq error provided" <$> liftIO (Pg.errorMessage conn') + Fail.fail (show errMsg)) +{-# DEPRECATED runQueryReturning "Use streamingRunQueryReturning" #-} 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 @@ -289,7 +289,12 @@ FromBackendRow Postgres x => (Maybe x -> next) -> PgF next PgLiftWithHandle :: ((String -> IO ()) -> Pg.Connection -> IO a) -> (a -> next) -> PgF next -deriving instance Functor PgF +instance Functor PgF where + fmap f = \case + PgLiftIO io n -> PgLiftIO io $ f . n + PgRunReturning mode cmd consume n -> PgRunReturning mode cmd consume $ f . n + PgFetchNext n -> PgFetchNext $ f . n + PgLiftWithHandle withConn n -> PgLiftWithHandle withConn $ f . n -- | How to fetch results. data FetchMode diff --git a/Database/Beam/Postgres/Full.hs b/Database/Beam/Postgres/Full.hs --- a/Database/Beam/Postgres/Full.hs +++ b/Database/Beam/Postgres/Full.hs @@ -381,7 +381,7 @@ emit " RETURNING " <> pgSepBy (emit ", ") (map fromPgExpression (project (Proxy @Postgres) (mkProjection tblQ) "t")) where - SqlDelete _ pgDelete = delete table mkWhere + SqlDelete _ pgDelete = delete table $ \t -> mkWhere t tblQ = changeBeamRep (\(Columnar' f) -> Columnar' (QExpr (pure (fieldE (unqualifiedField (_fieldName f)))))) tblSettings runPgDeleteReturningList 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 @@ -106,12 +106,16 @@ , lowerInc_, upperInc_, lowerInf_, upperInf_ , rangeMerge_ + -- * Postgres @EXTRACT@ fields + , century_, decade_, dow_, doy_, epoch_, isodow_, isoyear_ + , microseconds_, milliseconds_, millennium_, quarter_, week_ + -- ** Postgres functions and aggregates , pgBoolOr, pgBoolAnd, pgStringAgg, pgStringAggOver , pgNubBy_ - , now_, ilike_ + , now_, ilike_, ilike_' ) where @@ -142,7 +146,7 @@ import Data.Scientific (Scientific, formatScientific, FPFormat(Fixed)) import Data.String import qualified Data.Text as T -import Data.Time (LocalTime) +import Data.Time (LocalTime, NominalDiffTime) import Data.Type.Bool import qualified Data.Vector as V #if !MIN_VERSION_base(4, 11, 0) @@ -164,12 +168,23 @@ now_ = QExpr (\_ -> PgExpressionSyntax (emit "NOW()")) -- | Postgres @ILIKE@ operator. A case-insensitive version of 'like_'. -ilike_ :: BeamSqlBackendIsString Postgres text - => QExpr Postgres s text - -> QExpr Postgres s text - -> QExpr Postgres s Bool -ilike_ (QExpr a) (QExpr b) = QExpr (pgBinOp "ILIKE" <$> a <*> b) +ilike_ + :: BeamSqlBackendIsString Postgres text + => QExpr Postgres s text + -> QExpr Postgres s text + -> QExpr Postgres s Bool +ilike_ = ilike_' +-- | Postgres @ILIKE@ operator. A case-insensitive version of 'like_''. +ilike_' + :: ( BeamSqlBackendIsString Postgres left + , BeamSqlBackendIsString Postgres right + ) + => QExpr Postgres s left + -> QExpr Postgres s right + -> QExpr Postgres s Bool +ilike_' (QExpr a) (QExpr b) = QExpr (pgBinOp "ILIKE" <$> a <*> b) + -- ** TsVector type -- | The type of a document preprocessed for full-text search. The contained @@ -442,7 +457,7 @@ data PgBoundType = Inclusive | Exclusive - deriving (Show, Generic) + deriving (Eq, Show, Generic) instance Hashable PgBoundType lBound :: PgBoundType -> ByteString @@ -455,7 +470,7 @@ -- | Represents a single bound on a Range. A bound always has a type, but may not have a value -- (the absense of a value represents unbounded). -data PgRangeBound a = PgRangeBound PgBoundType (Maybe a) deriving (Show, Generic) +data PgRangeBound a = PgRangeBound PgBoundType (Maybe a) deriving (Eq, Show, Generic) inclusive :: a -> PgRangeBound a inclusive = PgRangeBound Inclusive . Just @@ -474,7 +489,7 @@ data PgRange (n :: *) a = PgEmptyRange | PgRange (PgRangeBound a) (PgRangeBound a) - deriving (Show, Generic) + deriving (Eq, Show, Generic) instance Hashable a => Hashable (PgRangeBound a) @@ -1464,6 +1479,44 @@ defaultSqlDataType _ be embedded = pgUnboundedArrayType (defaultSqlDataType (Proxy :: Proxy a) be embedded) +-- ** Extract + +century_ :: HasSqlDate tgt => ExtractField Postgres tgt Int32 +century_ = ExtractField (PgExtractFieldSyntax (emit "CENTURY")) + +decade_ :: HasSqlDate tgt => ExtractField Postgres tgt Int32 +decade_ = ExtractField (PgExtractFieldSyntax (emit "DECADE")) + +dow_ :: HasSqlDate tgt => ExtractField Postgres tgt Int32 +dow_ = ExtractField (PgExtractFieldSyntax (emit "DOW")) + +doy_ :: HasSqlDate tgt => ExtractField Postgres tgt Int32 +doy_ = ExtractField (PgExtractFieldSyntax (emit "DOY")) + +epoch_ :: HasSqlTime tgt => ExtractField Postgres tgt NominalDiffTime +epoch_ = ExtractField (PgExtractFieldSyntax (emit "EPOCH")) + +isodow_ :: HasSqlDate tgt => ExtractField Postgres tgt Int32 +isodow_ = ExtractField (PgExtractFieldSyntax (emit "ISODOW")) + +isoyear_ :: HasSqlDate tgt => ExtractField Postgres tgt Int32 +isoyear_ = ExtractField (PgExtractFieldSyntax (emit "ISOYEAR")) + +microseconds_ :: HasSqlTime tgt => ExtractField Postgres tgt Int32 +microseconds_ = ExtractField (PgExtractFieldSyntax (emit "MICROSECONDS")) + +milliseconds_ :: HasSqlTime tgt => ExtractField Postgres tgt Int32 +milliseconds_ = ExtractField (PgExtractFieldSyntax (emit "MILLISECONDS")) + +millennium_ :: HasSqlDate tgt => ExtractField Postgres tgt Int32 +millennium_ = ExtractField (PgExtractFieldSyntax (emit "MILLENNIUM")) + +quarter_ :: HasSqlDate tgt => ExtractField Postgres tgt Int32 +quarter_ = ExtractField (PgExtractFieldSyntax (emit "QUARTER")) + +week_ :: HasSqlDate tgt => ExtractField Postgres tgt Int32 +week_ = ExtractField (PgExtractFieldSyntax (emit "WEEK")) + -- $full-text-search -- -- Postgres has comprehensive, and thus complicated, support for full text @@ -1551,4 +1604,3 @@ -- 'pgUnnestArrayWithOrdinality' function allows you to join against the -- elements of an array along with its index. This corresponds to the -- @UNNEST .. WITH ORDINALITY@ clause. - diff --git a/Database/Beam/Postgres/Syntax.hs b/Database/Beam/Postgres/Syntax.hs --- a/Database/Beam/Postgres/Syntax.hs +++ b/Database/Beam/Postgres/Syntax.hs @@ -120,7 +120,7 @@ import qualified Data.Text.Encoding as TE import qualified Data.Text.Lazy as TL import Data.Time (LocalTime, UTCTime, TimeOfDay, NominalDiffTime, Day) -import Data.UUID.Types (UUID) +import Data.UUID.Types (UUID, toASCIIBytes) import Data.Word import qualified Data.Vector as V import GHC.TypeLits @@ -1197,7 +1197,6 @@ DEFAULT_SQL_SYNTAX(TimeOfDay) DEFAULT_SQL_SYNTAX(NominalDiffTime) DEFAULT_SQL_SYNTAX(Day) -DEFAULT_SQL_SYNTAX(UUID) DEFAULT_SQL_SYNTAX([Char]) DEFAULT_SQL_SYNTAX(Pg.HStoreMap) DEFAULT_SQL_SYNTAX(Pg.HStoreList) @@ -1224,6 +1223,12 @@ instance HasSqlValueSyntax PgValueSyntax BL.ByteString where sqlValueSyntax = defaultPgValueSyntax . Pg.Binary + +-- This should be removed in favor of the default syntax if/when +-- https://github.com/lpsmith/postgresql-simple/issues/277 is fixed upstream. +instance HasSqlValueSyntax PgValueSyntax UUID where + sqlValueSyntax v = PgValueSyntax $ + emit "'" <> emit (toASCIIBytes v) <> emit "'::uuid" instance Pg.ToField a => HasSqlValueSyntax PgValueSyntax (V.Vector a) where sqlValueSyntax = defaultPgValueSyntax 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.1.0 +version: 0.5.2.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 @@ -40,13 +40,13 @@ postgresql-simple >=0.5 && <0.7, text >=1.0 && <1.3, - bytestring >=0.10 && <0.11, + bytestring >=0.10 && <0.12, - attoparsec >=0.13 && <0.14, - hashable >=1.1 && <1.4, + attoparsec >=0.13 && <0.15, + hashable >=1.1 && <1.5, lifted-base >=0.2 && <0.3, free >=4.12 && <5.2, - time >=1.6 && <1.10, + time >=1.6 && <1.12, monad-control >=1.0 && <1.1, mtl >=2.1 && <2.3, conduit >=1.2 && <1.4, diff --git a/test/Database/Beam/Postgres/Test.hs b/test/Database/Beam/Postgres/Test.hs --- a/test/Database/Beam/Postgres/Test.hs +++ b/test/Database/Beam/Postgres/Test.hs @@ -10,15 +10,21 @@ import Control.Exception (bracket) import Control.Monad (void) -#if MIN_VERSION_base(4,12,0) -import Control.Monad.Fail (MonadFail(..)) -#endif import Data.ByteString (ByteString) import Data.String +#if MIN_VERSION_base(4,12,0) +#if !MIN_VERSION_hedgehog(1,0,0) +import Control.Monad.Fail (MonadFail(..)) import qualified Hedgehog - +-- TODO orphan instances are bad +-- Would be easier to say 'build-depends: hedgehog >= 1.0', +-- but it's difficult to propagate to older Stackage snapshots +instance Monad m => MonadFail (Hedgehog.PropertyT m) where + fail _ = Hedgehog.failure +#endif +#endif withTestPostgres :: String -> IO ByteString -> (Pg.Connection -> IO a) -> IO a withTestPostgres dbName getConnStr action = do @@ -40,13 +46,3 @@ Pg.execute_ c' (fromString ("DROP DATABASE " <> dbName)) bracket createDatabase dropDatabase action - -#if MIN_VERSION_base(4,12,0) -#if !MIN_VERSION_hedgehog(1,0,0) --- TODO orphan instances are bad --- Would be easier to say 'build-depends: hedgehog >= 1.0', --- but it's difficult to propagate to older Stackage snapshots -instance Monad m => MonadFail (Hedgehog.PropertyT m) where - fail _ = Hedgehog.failure -#endif -#endif diff --git a/test/Database/Beam/Postgres/Test/Marshal.hs b/test/Database/Beam/Postgres/Test/Marshal.hs --- a/test/Database/Beam/Postgres/Test/Marshal.hs +++ b/test/Database/Beam/Postgres/Test/Marshal.hs @@ -13,7 +13,6 @@ import Data.ByteString (ByteString) import Data.Functor.Classes import Data.Int -import Data.Proxy (Proxy(..)) import qualified Data.Text as T import Data.Typeable import Data.UUID (UUID, fromWords) 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 @@ -5,11 +5,11 @@ import Data.Aeson import Data.ByteString (ByteString) import Data.Int -import Data.Text (Text) import qualified Data.Vector as V import Test.Tasty import Test.Tasty.HUnit import Data.UUID (UUID, nil) +import qualified Data.UUID.V5 as V5 import Database.Beam import Database.Beam.Backend.SQL.SQL92 @@ -25,18 +25,22 @@ [ testPgArrayToJSON getConn ] , testGroup "UUID" - [ testUuidFunction getConn "uuid_nil" pgUuidNil - , testUuidFunction getConn "uuid_ns_dns" pgUuidNsDns - , testUuidFunction getConn "uuid_ns_url" pgUuidNsUrl - , testUuidFunction getConn "uuid_ns_oid" pgUuidNsOid - , testUuidFunction getConn "uuid_ns_x500" pgUuidNsX500 - , testUuidFunction getConn "uuid_generate_v1" pgUuidGenerateV1 - , testUuidFunction getConn "uuid_generate_v1mc" pgUuidGenerateV1Mc + [ testUuidFunction getConn "uuid_nil" $ \ext -> pgUuidNil ext + , testUuidFunction getConn "uuid_ns_dns" $ \ext -> pgUuidNsDns ext + , testUuidFunction getConn "uuid_ns_url" $ \ext -> pgUuidNsUrl ext + , testUuidFunction getConn "uuid_ns_oid" $ \ext -> pgUuidNsOid ext + , testUuidFunction getConn "uuid_ns_x500" $ \ext -> pgUuidNsX500 ext + , testUuidFunction getConn "uuid_generate_v1" $ \ext -> + pgUuidGenerateV1 ext + , testUuidFunction getConn "uuid_generate_v1mc" $ \ext -> + pgUuidGenerateV1Mc ext , testUuidFunction getConn "uuid_generate_v3" $ \ext -> pgUuidGenerateV3 ext (val_ nil) "nil" - , testUuidFunction getConn "uuid_generate_v4" pgUuidGenerateV4 + , testUuidFunction getConn "uuid_generate_v4" $ \ext -> + pgUuidGenerateV4 ext , testUuidFunction getConn "uuid_generate_v5" $ \ext -> pgUuidGenerateV5 ext (val_ nil) "nil" + , testUuuidInValues getConn ] , testInRowValues getConn , testReturningMany getConn @@ -68,6 +72,19 @@ return $ mkUuid $ getPgExtension $ _uuidOssp $ unCheckDatabase db return () +-- | Regression test for +testUuuidInValues :: IO ByteString -> TestTree +testUuuidInValues getConn = testCase "UUID in values_ works" $ + withTestPostgres "uuid_values" getConn $ \conn -> do + result <- runBeamPostgres conn $ do + db <- executeMigration runNoReturn $ UuidSchema <$> + pgCreateExtension @UuidOssp + let ext = getPgExtension $ _uuidOssp $ unCheckDatabase db + runSelectReturningList $ select $ do + v <- values_ [val_ nil] + return $ pgUuidGenerateV5 ext v "" + assertEqual "result" [V5.generateNamed nil []] result + data Pair f = Pair { _left :: C f Bool , _right :: C f Bool @@ -77,9 +94,9 @@ testInRowValues getConn = testCase "IN with row values works" $ withTestPostgres "db_in_row_values" getConn $ \conn -> do result <- runBeamPostgres conn $ runSelectReturningList $ select $ do - let p :: forall ctx s. Pair (QGenExpr ctx Postgres s) - p = val_ $ Pair False False - return $ p `in_` [p, p] + let pair :: forall ctx s. Pair (QGenExpr ctx Postgres s) + pair = val_ $ Pair False False + return $ pair `in_` [pair, pair] assertEqual "result" [True] result testReturningMany :: IO ByteString -> TestTree