diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,36 +1,49 @@ # Unreleased -# 0.4.0.0 +# v0.5.0.0 +* Export `SqlQueryT` constructor ([#46](https://github.com/brandonchinn178/persistent-mtl/pull/46)) +* Drop support for GHC < 8.10 +* Drop support for `persistent` < 2.13 +* Add support for `persistent-2.14` +* Add `Database.Persist.Sql.Shim` module that re-exports `Database.Persist.Sql` and `Database.Persist.Monad.Shim` +* Add `MonadFix` instance to `SqlQueryT` and `SqlTransaction` +* Add `getSqlBackendPool` +* Move `rerunnableLift` into `MonadRerunnableTrans` typeclass in `Control.Monad.Trans.Rerunnable` +* Add `catchSqlTransaction` +* Add `retryCallback` to `SqlQueryEnv` + +# v0.4.0.0 + * Add some mtl instances: `MonadThrow`, `MonadCatch`, `MonadMask`, `MonadLogger`, `MonadReader` * Removed support for GHC 8.2, 8.4 * Add `MonadSqlQuery (TransactionM m)` superclass constraint to allow writing functions generic on some `MonadSqlQuery m` using `withTransaction`, as shown in examples in README -# 0.3.0.0 +# v0.3.0.0 * Add `unsafeLiftSql` ([#38](https://github.com/brandonchinn178/persistent-mtl/pull/38)) -# 0.2.2.0 +# v0.2.2.0 * Fix for persistent 2.13 -# 0.2.1.0 +# v0.2.1.0 * Add `rerunnableLift` for `SqlTransaction` * Use `unliftio-pool` instead of `resourcet-pool`, which has better async exeception safety -# 0.2.0.0 +# v0.2.0.0 * Use a separate monad within `withTransaction` to prevent unsafe/arbitrary IO actions ([#7](https://github.com/brandonchinn178/persistent-mtl/issues/7), [#28](https://github.com/brandonchinn178/persistent-mtl/issues/28)) * Add `MonadRerunnableIO` to support IO actions within `withTransaction` only if the IO action is determined to be rerunnable * Add built-in support for retrying transactions if a serialization error occurs * Remove `SqlQueryRep` as an export from `Database.Persist.Monad`. You shouldn't ever need it for normal usage. It is now re-exported by `Database.Persist.Monad.TestUtils`, since most of the usage of `SqlQueryRep` is in mocking queries. If you need it otherwise, you can import it directly from `Database.Persist.Monad.SqlQueryRep`. -# 0.1.0.1 +# v0.1.0.1 Fix quickstart -# 0.1.0.0 +# v0.1.0.0 Initial release * `SqlQueryT` + `MonadSqlQuery` diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,8 +1,8 @@ # `persistent-mtl` -[![CircleCI](https://img.shields.io/circleci/build/github/brandonchinn178/persistent-mtl)](https://app.circleci.com/pipelines/github/brandonchinn178/persistent-mtl) +[![GitHub Actions](https://img.shields.io/github/workflow/status/brandonchinn178/persistent-mtl/CI/main)](https://github.com/brandonchinn178/persistent-mtl/actions?query=branch%3Amain) [![Hackage](https://img.shields.io/hackage/v/persistent-mtl)](https://hackage.haskell.org/package/persistent-mtl) -[![Codecov](https://img.shields.io/codecov/c/gh/brandonchinn178/persistent-mtl)](https://codecov.io/gh/brandonchinn178/persistent-mtl) +[![Codecov](https://img.shields.io/codecov/c/gh/brandonchinn178/persistent-mtl)](https://app.codecov.io/gh/brandonchinn178/persistent-mtl) Use the `persistent` API in your monad transformer stack, seamlessly interleaving business logic with database operations by simply dropping `SqlQueryT` into your stack. diff --git a/persistent-mtl.cabal b/persistent-mtl.cabal --- a/persistent-mtl.cabal +++ b/persistent-mtl.cabal @@ -1,11 +1,11 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.34.4. +-- This file has been generated from package.yaml by hpack version 0.35.0. -- -- see: https://github.com/sol/hpack name: persistent-mtl -version: 0.4.0.0 +version: 0.5.0.0 synopsis: Monad transformer for the persistent API description: A monad transformer and mtl-style type class for using the persistent API directly in your monad transformer stack. @@ -19,12 +19,8 @@ extra-source-files: CHANGELOG.md README.md - test/goldens/persistent-2.10/sqlqueryrep_show_representation.golden - test/goldens/persistent-2.11/sqlqueryrep_show_representation.golden - test/goldens/persistent-2.12/sqlqueryrep_show_representation.golden test/goldens/persistent-2.13/sqlqueryrep_show_representation.golden - test/goldens/persistent-2.8/sqlqueryrep_show_representation.golden - test/goldens/persistent-2.9/sqlqueryrep_show_representation.golden + test/goldens/persistent-2.14/sqlqueryrep_show_representation.golden source-repository head type: git @@ -33,50 +29,55 @@ library exposed-modules: Control.Monad.IO.Rerunnable + Control.Monad.Trans.Rerunnable Database.Persist.Monad Database.Persist.Monad.Class + Database.Persist.Monad.Internal.PersistentShim + Database.Persist.Monad.Internal.SqlTransaction Database.Persist.Monad.Shim Database.Persist.Monad.SqlQueryRep Database.Persist.Monad.TestUtils + Database.Persist.Sql.Shim other-modules: Paths_persistent_mtl hs-source-dirs: src ghc-options: -Wall build-depends: - base >=4.10 && <4.16 - , conduit >=1.3.0.3 && <1.4 - , containers >=0.5.10.2 && <0.7 - , exceptions >=0.8 && <0.11 - , monad-logger >=0.3.29 && <0.4 + base >=4.14 && <4.16 + , conduit >=1.3.4 && <1.4 + , containers ==0.6.* + , exceptions ==0.10.* + , monad-logger ==0.3.* , mtl >=2.2.2 && <2.3 - , persistent >=2.8.2 && <2.14 + , persistent >=2.13 && <2.15 , resource-pool >=0.2.3.2 && <0.3 - , resourcet >=1.2.1 && <1.3 - , text >=1.2.3.0 && <1.3 - , transformers >=0.5.2.0 && <0.6 - , unliftio >=0.2.7.0 && <0.3 - , unliftio-core >=0.1.2.0 && <0.3 - , unliftio-pool >=0.2.0.0 && <0.3 + , resourcet >=1.2.4 && <1.3 + , text >=1.2.4 && <1.3 + , transformers >=0.5.6 && <0.6 + , unliftio ==0.2.* + , unliftio-core ==0.2.* + , unliftio-pool ==0.2.* default-language: Haskell2010 test-suite persistent-mtl-test type: exitcode-stdio-1.0 main-is: Main.hs other-modules: - Basic Example Generated - Integration - Mocked - MockSqlQueryT + IntegrationTest + MockedTest + READMETest SqlQueryRepTest TestUtils.DB TestUtils.Esqueleto Paths_persistent_mtl hs-source-dirs: test - ghc-options: -Wall + ghc-options: -Wall -F -pgmF=tasty-autocollect + build-tool-depends: + tasty-autocollect:tasty-autocollect build-depends: base , bytestring @@ -93,6 +94,7 @@ , resource-pool , resourcet , tasty + , tasty-autocollect , tasty-golden , tasty-hunit , text diff --git a/src/Control/Monad/IO/Rerunnable.hs b/src/Control/Monad/IO/Rerunnable.hs --- a/src/Control/Monad/IO/Rerunnable.hs +++ b/src/Control/Monad/IO/Rerunnable.hs @@ -5,10 +5,9 @@ to 'Control.Monad.IO.Class.MonadIO', but use of it requires the user to explicitly acknowledge that the given IO operation can be rerun. -} - -module Control.Monad.IO.Rerunnable - ( MonadRerunnableIO(..) - ) where +module Control.Monad.IO.Rerunnable ( + MonadRerunnableIO (..), +) where import Control.Monad.Trans.Class (lift) import qualified Control.Monad.Trans.Except as Except @@ -23,8 +22,9 @@ import qualified Control.Monad.Trans.Writer.Lazy as Writer.Lazy import qualified Control.Monad.Trans.Writer.Strict as Writer.Strict --- | A copy of 'Control.Monad.IO.Class.MonadIO' to explicitly allow only IO --- operations that are rerunnable, e.g. in the context of a SQL transaction. +{-| A copy of 'Control.Monad.IO.Class.MonadIO' to explicitly allow only IO + operations that are rerunnable, e.g. in the context of a SQL transaction. +-} class Monad m => MonadRerunnableIO m where -- | Lift the given IO operation to @m@. -- diff --git a/src/Control/Monad/Trans/Rerunnable.hs b/src/Control/Monad/Trans/Rerunnable.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/Trans/Rerunnable.hs @@ -0,0 +1,68 @@ +{-| +Module: Control.Monad.Trans.Rerunnable + +Defines the 'MonadRerunnableTrans' type class that is functionally equivalent +to 'Control.Monad.Trans.Class.MonadTrans', but use of it requires the user to +explicitly acknowledge that lifting the given action can be rerun. +-} +module Control.Monad.Trans.Rerunnable ( + MonadRerunnableTrans (..), +) where + +import Control.Monad.Trans.Class (lift) +import qualified Control.Monad.Trans.Except as Except +import qualified Control.Monad.Trans.Identity as Identity +import qualified Control.Monad.Trans.Maybe as Maybe +import qualified Control.Monad.Trans.RWS.Lazy as RWS.Lazy +import qualified Control.Monad.Trans.RWS.Strict as RWS.Strict +import qualified Control.Monad.Trans.Reader as Reader +import qualified Control.Monad.Trans.Resource as Resource +import qualified Control.Monad.Trans.State.Lazy as State.Lazy +import qualified Control.Monad.Trans.State.Strict as State.Strict +import qualified Control.Monad.Trans.Writer.Lazy as Writer.Lazy +import qualified Control.Monad.Trans.Writer.Strict as Writer.Strict + +{-| A copy of 'Control.Monad.Trans.Class.MonadTrans' to explicitly allow only +lifting actions that are rerunnable, e.g. in the context of a SQL transaction. +-} +class MonadRerunnableTrans t where + -- | Lift the given action. + -- + -- The given action may be rerun, so use of this function requires + -- manually verifying that the given action is rerunnable. + rerunnableLift :: Monad m => m a -> t m a + +{- Instances for common monad transformers -} + +instance MonadRerunnableTrans (Reader.ReaderT r) where + rerunnableLift = lift + +instance MonadRerunnableTrans (Except.ExceptT e) where + rerunnableLift = lift + +instance MonadRerunnableTrans Identity.IdentityT where + rerunnableLift = lift + +instance MonadRerunnableTrans Maybe.MaybeT where + rerunnableLift = lift + +instance Monoid w => MonadRerunnableTrans (RWS.Lazy.RWST r w s) where + rerunnableLift = lift + +instance Monoid w => MonadRerunnableTrans (RWS.Strict.RWST r w s) where + rerunnableLift = lift + +instance MonadRerunnableTrans (State.Lazy.StateT s) where + rerunnableLift = lift + +instance MonadRerunnableTrans (State.Strict.StateT s) where + rerunnableLift = lift + +instance Monoid w => MonadRerunnableTrans (Writer.Lazy.WriterT w) where + rerunnableLift = lift + +instance Monoid w => MonadRerunnableTrans (Writer.Strict.WriterT w) where + rerunnableLift = lift + +instance MonadRerunnableTrans Resource.ResourceT where + rerunnableLift = lift diff --git a/src/Database/Persist/Monad.hs b/src/Database/Persist/Monad.hs --- a/src/Database/Persist/Monad.hs +++ b/src/Database/Persist/Monad.hs @@ -1,3 +1,14 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + {-| Module: Database.Persist.Monad @@ -36,159 +47,104 @@ return () @ -} - -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} - -module Database.Persist.Monad - ( +module Database.Persist.Monad ( -- * Type class for executing database queries - MonadSqlQuery - , withTransaction + MonadSqlQuery, + withTransaction, -- * SqlQueryT monad transformer - , SqlQueryT - , mapSqlQueryT - , runSqlQueryT - , runSqlQueryTWith - , SqlQueryEnv(..) - , mkSqlQueryEnv + SqlQueryT (..), + mapSqlQueryT, + runSqlQueryT, + runSqlQueryTWith, + SqlQueryEnv (..), + mkSqlQueryEnv, + -- ** SqlQueryT environment + getSqlBackendPool, + -- * Transactions - , SqlTransaction - , rerunnableLift - , TransactionError(..) + SqlTransaction, + TransactionError (..), + catchSqlTransaction, -- * Lifted functions - , module Database.Persist.Monad.Shim - ) where + module Database.Persist.Monad.Shim, +) where import Control.Monad.Catch (MonadCatch, MonadMask, MonadThrow) -import Control.Monad.IO.Class (MonadIO(..)) -import Control.Monad.IO.Unlift (MonadUnliftIO(..), wrappedWithRunInIO) +import Control.Monad.Fix (MonadFix) +import Control.Monad.IO.Class (MonadIO (..)) +import Control.Monad.IO.Unlift (MonadUnliftIO (..), wrappedWithRunInIO) import Control.Monad.Logger (MonadLogger) -import Control.Monad.Reader (ReaderT(..), mapReaderT) -import Control.Monad.Reader.Class (MonadReader(..)) -import Control.Monad.Trans.Class (MonadTrans(..)) +import Control.Monad.Reader (ReaderT (..), asks, mapReaderT) +import Control.Monad.Reader.Class (MonadReader (..)) +import Control.Monad.Trans.Class (MonadTrans (..)) import Control.Monad.Trans.Resource (MonadResource) import Data.Pool (Pool) -import Database.Persist.Sql (SqlBackend, SqlPersistT, runSqlConn) -import qualified GHC.TypeLits as GHC +import Database.Persist.Sql (SqlBackend) import UnliftIO.Concurrent (threadDelay) import UnliftIO.Exception (Exception, SomeException, catchJust, throwIO) import UnliftIO.Pool (withResource) -import Control.Monad.IO.Rerunnable (MonadRerunnableIO, rerunnableIO) +import Control.Monad.IO.Rerunnable (MonadRerunnableIO) import Database.Persist.Monad.Class +import Database.Persist.Monad.Internal.SqlTransaction import Database.Persist.Monad.Shim -import Database.Persist.Monad.SqlQueryRep -{- SqlTransaction -} - --- | The monad that tracks transaction state. --- --- Conceptually equivalent to 'Database.Persist.Sql.SqlPersistT', but restricts --- IO operations, for two reasons: --- 1. Forking a thread that uses the same 'SqlBackend' as the current thread --- causes Bad Things to happen. --- 2. Transactions may need to be retried, in which case IO operations in --- a transaction are required to be rerunnable. --- --- You shouldn't need to explicitly use this type; your functions should only --- declare the 'MonadSqlQuery' constraint. -newtype SqlTransaction m a = SqlTransaction - { unSqlTransaction :: SqlPersistT m a - } - deriving (Functor, Applicative, Monad, MonadRerunnableIO) - -instance - ( GHC.TypeError ('GHC.Text "Cannot run arbitrary IO actions within a transaction. If the IO action is rerunnable, use rerunnableIO") - , Monad m - ) - => MonadIO (SqlTransaction m) where - liftIO = undefined - -instance (MonadSqlQuery m, MonadUnliftIO m) => MonadSqlQuery (SqlTransaction m) where - type TransactionM (SqlTransaction m) = TransactionM m - - runQueryRep = SqlTransaction . runSqlQueryRep - - -- Delegate to 'm', since 'm' is in charge of starting/stopping transactions. - -- 'SqlTransaction' is ONLY in charge of executing queries. - withTransaction = SqlTransaction . withTransaction - -runSqlTransaction :: MonadUnliftIO m => SqlBackend -> SqlTransaction m a -> m a -runSqlTransaction conn = (`runSqlConn` conn) . unSqlTransaction - --- | 'SqlTransaction' does not have an instance for 'MonadTrans' to prevent --- accidental lifting of unsafe monadic actions. Use this function to explicitly --- mark a monadic action as rerunnable. -rerunnableLift :: MonadUnliftIO m => m a -> SqlTransaction m a -rerunnableLift m = SqlTransaction $ lift $ withRunInIO $ \runInIO -> rerunnableIO $ runInIO m - --- | Errors that can occur within a SQL transaction. -data TransactionError - = RetryLimitExceeded - -- ^ The retry limit was reached when retrying a transaction. - deriving (Show, Eq) - -instance Exception TransactionError - {- SqlQueryT monad -} --- | Environment to configure running 'SqlQueryT'. --- --- For simple usage, you can just use 'runSqlQueryT', but for more advanced --- usage, including the ability to retry transactions, use 'mkSqlQueryEnv' with --- 'runSqlQueryTWith'. +{-| Environment to configure running 'SqlQueryT'. + + For simple usage, you can just use 'runSqlQueryT', but for more advanced + usage, including the ability to retry transactions, use 'mkSqlQueryEnv' with + 'runSqlQueryTWith'. +-} data SqlQueryEnv = SqlQueryEnv { backendPool :: Pool SqlBackend - -- ^ The pool for your persistent backend. Get this from @withSqlitePool@ - -- or the equivalent for your backend. + -- ^ The pool for your persistent backend. Get this from @withSqlitePool@ + -- or the equivalent for your backend. + , retryIf :: SomeException -> Bool + -- ^ Retry a transaction when an exception matches this predicate. Will + -- retry with an exponential backoff. + -- + -- Defaults to always returning False (i.e. never retry) + , retryLimit :: Int + -- ^ The number of times to retry, if 'retryIf' is satisfied. + -- + -- Defaults to 10. + , retryCallback :: SomeException -> IO () + -- ^ A callback to run if 'retryIf' returns True. Useful for logging. + } - , retryIf :: SomeException -> Bool - -- ^ Retry a transaction when an exception matches this predicate. Will - -- retry with an exponential backoff. - -- - -- Defaults to always returning False (i.e. never retry) +{-| Build a SqlQueryEnv from the default. - , retryLimit :: Int - -- ^ The number of times to retry, if 'retryIf' is satisfied. - -- - -- Defaults to 10. - } + Usage: --- | Build a SqlQueryEnv from the default. --- --- Usage: --- --- @ --- let env = mkSqlQueryEnv pool $ \\env -> env { retryIf = 10 } --- in runSqlQueryTWith env m --- @ + @ + let env = mkSqlQueryEnv pool $ \\env -> env { retryIf = 10 } + in runSqlQueryTWith env m + @ +-} mkSqlQueryEnv :: Pool SqlBackend -> (SqlQueryEnv -> SqlQueryEnv) -> SqlQueryEnv -mkSqlQueryEnv backendPool f = f SqlQueryEnv - { backendPool - , retryIf = const False - , retryLimit = 10 - } +mkSqlQueryEnv backendPool f = + f + SqlQueryEnv + { backendPool + , retryIf = const False + , retryLimit = 10 + , retryCallback = \_ -> pure () + } -- | The monad transformer that implements 'MonadSqlQuery'. newtype SqlQueryT m a = SqlQueryT { unSqlQueryT :: ReaderT SqlQueryEnv m a - } deriving + } + deriving ( Functor , Applicative , Monad + , MonadFix , MonadIO , MonadTrans , MonadResource @@ -209,14 +165,20 @@ withTransaction m = do SqlQueryEnv{..} <- SqlQueryT ask withResource backendPool $ \conn -> - let filterRetry e = if retryIf e then Just e else Nothing - loop i = catchJust filterRetry (runSqlTransaction conn m) $ \_ -> + let transactionEnv = + SqlTransactionEnv + { sqlBackend = conn + , ignoreCatch = retryIf -- don't catch retry errors + } + filterRetry e = if retryIf e then Just e else Nothing + loop i = catchJust filterRetry (runSqlTransaction transactionEnv m) $ \e -> if i < retryLimit then do - threadDelay $ 1000 * 2^i + liftIO $ retryCallback e + threadDelay $ 1000 * 2 ^ i loop $! i + 1 else throwIO RetryLimitExceeded - in loop 0 + in loop 0 instance MonadUnliftIO m => MonadUnliftIO (SqlQueryT m) where withRunInIO = wrappedWithRunInIO SqlQueryT unSqlQueryT @@ -225,16 +187,30 @@ mapSqlQueryT f = SqlQueryT . mapReaderT f . unSqlQueryT instance MonadReader r m => MonadReader r (SqlQueryT m) where - ask = lift ask - local = mapSqlQueryT . local + ask = lift ask + local = mapSqlQueryT . local +-- | Errors that can occur when running a SQL transaction. +data TransactionError + = -- | The retry limit was reached when retrying a transaction. + RetryLimitExceeded + deriving (Show, Eq) + +instance Exception TransactionError + {- Running SqlQueryT -} -- | Run the 'SqlQueryT' monad transformer with the given backend. runSqlQueryT :: Pool SqlBackend -> SqlQueryT m a -> m a runSqlQueryT backendPool = runSqlQueryTWith $ mkSqlQueryEnv backendPool id --- | Run the 'SqlQueryT' monad transformer with the explicitly provided --- environment. +{-| Run the 'SqlQueryT' monad transformer with the explicitly provided + environment. +-} runSqlQueryTWith :: SqlQueryEnv -> SqlQueryT m a -> m a runSqlQueryTWith env = (`runReaderT` env) . unSqlQueryT + +{- SqlQueryT environment -} + +getSqlBackendPool :: Monad m => SqlQueryT m (Pool SqlBackend) +getSqlBackendPool = SqlQueryT (asks backendPool) diff --git a/src/Database/Persist/Monad/Class.hs b/src/Database/Persist/Monad/Class.hs --- a/src/Database/Persist/Monad/Class.hs +++ b/src/Database/Persist/Monad/Class.hs @@ -1,3 +1,7 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableSuperClasses #-} + {-| Module: Database.Persist.Monad.Class @@ -6,13 +10,9 @@ 'Database.Persist.Monad.SqlQueryRep.SqlQueryRep' sent by a lifted function from @Database.Persist.Monad.Shim@. -} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableSuperClasses #-} - -module Database.Persist.Monad.Class - ( MonadSqlQuery(..) - ) where +module Database.Persist.Monad.Class ( + MonadSqlQuery (..), +) where import Control.Monad.Trans.Class (lift) import qualified Control.Monad.Trans.Except as Except diff --git a/src/Database/Persist/Monad/Internal/PersistentShim.hs b/src/Database/Persist/Monad/Internal/PersistentShim.hs new file mode 100644 --- /dev/null +++ b/src/Database/Persist/Monad/Internal/PersistentShim.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} + +module Database.Persist.Monad.Internal.PersistentShim ( + SafeToInsert, +) where + +#if MIN_VERSION_persistent(2,14,1) +import Database.Persist.Class (SafeToInsert) +#elif MIN_VERSION_persistent(2,14,0) +import Database.Persist.Class.PersistEntity (SafeToInsert) +#endif + +#if !MIN_VERSION_persistent(2,14,0) +class SafeToInsert record +instance SafeToInsert record +#endif diff --git a/src/Database/Persist/Monad/Internal/SqlTransaction.hs b/src/Database/Persist/Monad/Internal/SqlTransaction.hs new file mode 100644 --- /dev/null +++ b/src/Database/Persist/Monad/Internal/SqlTransaction.hs @@ -0,0 +1,92 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +module Database.Persist.Monad.Internal.SqlTransaction ( + SqlTransaction (..), + SqlTransactionEnv (..), + runSqlTransaction, + catchSqlTransaction, +) where + +import Control.Monad.Fix (MonadFix) +import Control.Monad.IO.Class (MonadIO (..)) +import Control.Monad.IO.Unlift (MonadUnliftIO (..)) +import Control.Monad.Reader (ReaderT, ask, withReaderT) +import Database.Persist.Sql (SqlBackend, runSqlConn) +import qualified GHC.TypeLits as GHC +import UnliftIO.Exception (Exception, SomeException, catchJust, fromException) + +import Control.Monad.IO.Rerunnable (MonadRerunnableIO) +import Control.Monad.Trans.Rerunnable (MonadRerunnableTrans) +import Database.Persist.Monad.Class +import Database.Persist.Monad.SqlQueryRep + +{-| The monad that tracks transaction state. + + Conceptually equivalent to 'Database.Persist.Sql.SqlPersistT', but restricts + IO operations, for two reasons: + + 1. Forking a thread that uses the same 'SqlBackend' as the current thread + causes Bad Things to happen. + 2. Transactions may need to be retried, in which case IO operations in + a transaction are required to be rerunnable. + + You shouldn't need to explicitly use this type; your functions should only + declare the 'MonadSqlQuery' constraint. +-} +newtype SqlTransaction m a = UnsafeSqlTransaction + { unSqlTransaction :: ReaderT SqlTransactionEnv m a + } + deriving (Functor, Applicative, Monad, MonadFix, MonadRerunnableIO, MonadRerunnableTrans) + +instance + ( GHC.TypeError ( 'GHC.Text "Cannot run arbitrary IO actions within a transaction. If the IO action is rerunnable, use rerunnableIO") + , Monad m + ) => + MonadIO (SqlTransaction m) + where + liftIO = undefined + +instance (MonadSqlQuery m, MonadUnliftIO m) => MonadSqlQuery (SqlTransaction m) where + type TransactionM (SqlTransaction m) = TransactionM m + + runQueryRep = UnsafeSqlTransaction . withReaderT sqlBackend . runSqlQueryRep + + -- Delegate to 'm', since 'm' is in charge of starting/stopping transactions. + -- 'SqlTransaction' is ONLY in charge of executing queries. + withTransaction = UnsafeSqlTransaction . withTransaction + +data SqlTransactionEnv = SqlTransactionEnv + { sqlBackend :: SqlBackend + , ignoreCatch :: SomeException -> Bool + } + +runSqlTransaction :: + MonadUnliftIO m => + SqlTransactionEnv -> + SqlTransaction m a -> + m a +runSqlTransaction opts = + (`runSqlConn` sqlBackend opts) + . withReaderT (\conn -> opts{sqlBackend = conn}) + . unSqlTransaction + +-- | Like normal 'catch', except ignores errors specified by 'ignoreCatch'. +catchSqlTransaction :: + (MonadUnliftIO m, Exception e) => + SqlTransaction m a -> + (e -> SqlTransaction m a) -> + SqlTransaction m a +catchSqlTransaction (UnsafeSqlTransaction m) handler = + UnsafeSqlTransaction $ m `catch` (unSqlTransaction . handler) + where + catch a b = do + SqlTransactionEnv{ignoreCatch} <- ask + catchJust + (\e -> if ignoreCatch e then Nothing else fromException e) + a + b diff --git a/src/Database/Persist/Monad/Shim.hs b/src/Database/Persist/Monad/Shim.hs --- a/src/Database/Persist/Monad/Shim.hs +++ b/src/Database/Persist/Monad/Shim.hs @@ -1,3 +1,6 @@ +{- THIS FILE IS AUTOGENERATED AND SHOULD NOT BE EDITED MANUALLY -} +{- FOURMOLU_DISABLE -} + {-| Module: Database.Persist.Monad.Shim @@ -7,8 +10,6 @@ @Database.Persist.Monad.SqlQueryRep@. -} -{- THIS FILE IS AUTOGENERATED AND SHOULD NOT BE EDITED MANUALLY -} - {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} @@ -33,7 +34,9 @@ import Database.Persist.Monad.Class (MonadSqlQuery(..)) import Database.Persist.Monad.SqlQueryRep (SqlQueryRep(..)) -{-# ANN module "HLint: ignore" #-} +#if !MIN_VERSION_persistent(2,14,1) +import Database.Persist.Monad.Internal.PersistentShim (SafeToInsert) +#endif -- | The lifted version of 'Database.Persist.Sql.get' get @@ -79,25 +82,25 @@ -- | The lifted version of 'Database.Persist.Sql.insert' insert - :: (PersistRecordBackend record SqlBackend, Typeable record, MonadSqlQuery m) + :: (PersistRecordBackend record SqlBackend, SafeToInsert record, Typeable record, MonadSqlQuery m) => record -> m (Key record) insert a1 = runQueryRep $ Insert a1 -- | The lifted version of 'Database.Persist.Sql.insert_' insert_ - :: (PersistRecordBackend record SqlBackend, Typeable record, MonadSqlQuery m) + :: (PersistRecordBackend record SqlBackend, SafeToInsert record, Typeable record, MonadSqlQuery m) => record -> m () insert_ a1 = runQueryRep $ Insert_ a1 -- | The lifted version of 'Database.Persist.Sql.insertMany' insertMany - :: (PersistRecordBackend record SqlBackend, Typeable record, MonadSqlQuery m) + :: (PersistRecordBackend record SqlBackend, SafeToInsert record, Typeable record, MonadSqlQuery m) => [record] -> m [Key record] insertMany a1 = runQueryRep $ InsertMany a1 -- | The lifted version of 'Database.Persist.Sql.insertMany_' insertMany_ - :: (PersistRecordBackend record SqlBackend, Typeable record, MonadSqlQuery m) + :: (PersistRecordBackend record SqlBackend, SafeToInsert record, Typeable record, MonadSqlQuery m) => [record] -> m () insertMany_ a1 = runQueryRep $ InsertMany_ a1 @@ -151,13 +154,13 @@ -- | The lifted version of 'Database.Persist.Sql.insertEntity' insertEntity - :: (PersistRecordBackend record SqlBackend, Typeable record, MonadSqlQuery m) + :: (PersistRecordBackend record SqlBackend, SafeToInsert record, Typeable record, MonadSqlQuery m) => record -> m (Entity record) insertEntity a1 = runQueryRep $ InsertEntity a1 -- | The lifted version of 'Database.Persist.Sql.insertRecord' insertRecord - :: (PersistRecordBackend record SqlBackend, Typeable record, MonadSqlQuery m) + :: (PersistRecordBackend record SqlBackend, SafeToInsert record, Typeable record, MonadSqlQuery m) => record -> m record insertRecord a1 = runQueryRep $ InsertRecord a1 @@ -167,35 +170,23 @@ => Unique record -> m (Maybe (Entity record)) getBy a1 = runQueryRep $ GetBy a1 -#if MIN_VERSION_persistent(2,10,0) -- | The lifted version of 'Database.Persist.Sql.getByValue' getByValue :: (PersistRecordBackend record SqlBackend, AtLeastOneUniqueKey record, Typeable record, MonadSqlQuery m) => record -> m (Maybe (Entity record)) getByValue a1 = runQueryRep $ GetByValue a1 -#endif -#if !MIN_VERSION_persistent(2,10,0) --- | The lifted version of 'Database.Persist.Sql.getByValue' -getByValue - :: (PersistRecordBackend record SqlBackend, Typeable record, MonadSqlQuery m) - => record -> m (Maybe (Entity record)) -getByValue a1 = runQueryRep $ GetByValue a1 -#endif - -- | The lifted version of 'Database.Persist.Sql.checkUnique' checkUnique :: (PersistRecordBackend record SqlBackend, Typeable record, MonadSqlQuery m) => record -> m (Maybe (Unique record)) checkUnique a1 = runQueryRep $ CheckUnique a1 -#if MIN_VERSION_persistent(2,11,0) -- | The lifted version of 'Database.Persist.Sql.checkUniqueUpdateable' checkUniqueUpdateable :: (PersistRecordBackend record SqlBackend, Typeable record, MonadSqlQuery m) => Entity record -> m (Maybe (Unique record)) checkUniqueUpdateable a1 = runQueryRep $ CheckUniqueUpdateable a1 -#endif -- | The lifted version of 'Database.Persist.Sql.deleteBy' deleteBy @@ -205,57 +196,37 @@ -- | The lifted version of 'Database.Persist.Sql.insertUnique' insertUnique - :: (PersistRecordBackend record SqlBackend, Typeable record, MonadSqlQuery m) + :: (PersistRecordBackend record SqlBackend, SafeToInsert record, Typeable record, MonadSqlQuery m) => record -> m (Maybe (Key record)) insertUnique a1 = runQueryRep $ InsertUnique a1 -#if MIN_VERSION_persistent(2,10,0) -- | The lifted version of 'Database.Persist.Sql.upsert' upsert - :: (PersistRecordBackend record SqlBackend, OnlyOneUniqueKey record, Typeable record, MonadSqlQuery m) + :: (PersistRecordBackend record SqlBackend, OnlyOneUniqueKey record, SafeToInsert record, Typeable record, MonadSqlQuery m) => record -> [Update record] -> m (Entity record) upsert a1 a2 = runQueryRep $ Upsert a1 a2 -#endif -#if !MIN_VERSION_persistent(2,10,0) --- | The lifted version of 'Database.Persist.Sql.upsert' -upsert - :: (PersistRecordBackend record SqlBackend, Typeable record, MonadSqlQuery m) - => record -> [Update record] -> m (Entity record) -upsert a1 a2 = runQueryRep $ Upsert a1 a2 -#endif - -- | The lifted version of 'Database.Persist.Sql.upsertBy' upsertBy - :: (PersistRecordBackend record SqlBackend, Typeable record, MonadSqlQuery m) + :: (PersistRecordBackend record SqlBackend, SafeToInsert record, Typeable record, MonadSqlQuery m) => Unique record -> record -> [Update record] -> m (Entity record) upsertBy a1 a2 a3 = runQueryRep $ UpsertBy a1 a2 a3 -- | The lifted version of 'Database.Persist.Sql.putMany' putMany - :: (PersistRecordBackend record SqlBackend, Typeable record, MonadSqlQuery m) + :: (PersistRecordBackend record SqlBackend, SafeToInsert record, Typeable record, MonadSqlQuery m) => [record] -> m () putMany a1 = runQueryRep $ PutMany a1 -#if MIN_VERSION_persistent(2,10,0) -- | The lifted version of 'Database.Persist.Sql.insertBy' insertBy - :: (PersistRecordBackend record SqlBackend, AtLeastOneUniqueKey record, Typeable record, MonadSqlQuery m) + :: (PersistRecordBackend record SqlBackend, AtLeastOneUniqueKey record, SafeToInsert record, Typeable record, MonadSqlQuery m) => record -> m (Either (Entity record) (Key record)) insertBy a1 = runQueryRep $ InsertBy a1 -#endif -#if !MIN_VERSION_persistent(2,10,0) --- | The lifted version of 'Database.Persist.Sql.insertBy' -insertBy - :: (PersistRecordBackend record SqlBackend, Typeable record, MonadSqlQuery m) - => record -> m (Either (Entity record) (Key record)) -insertBy a1 = runQueryRep $ InsertBy a1 -#endif - -- | The lifted version of 'Database.Persist.Sql.insertUniqueEntity' insertUniqueEntity - :: (PersistRecordBackend record SqlBackend, Typeable record, MonadSqlQuery m) + :: (PersistRecordBackend record SqlBackend, SafeToInsert record, Typeable record, MonadSqlQuery m) => record -> m (Maybe (Entity record)) insertUniqueEntity a1 = runQueryRep $ InsertUniqueEntity a1 @@ -265,22 +236,12 @@ => Key record -> record -> m (Maybe (Unique record)) replaceUnique a1 a2 = runQueryRep $ ReplaceUnique a1 a2 -#if MIN_VERSION_persistent(2,10,0) -- | The lifted version of 'Database.Persist.Sql.onlyUnique' onlyUnique :: (PersistRecordBackend record SqlBackend, OnlyOneUniqueKey record, Typeable record, MonadSqlQuery m) => record -> m (Unique record) onlyUnique a1 = runQueryRep $ OnlyUnique a1 -#endif -#if !MIN_VERSION_persistent(2,10,0) --- | The lifted version of 'Database.Persist.Sql.onlyUnique' -onlyUnique - :: (PersistRecordBackend record SqlBackend, Typeable record, MonadSqlQuery m) - => record -> m (Unique record) -onlyUnique a1 = runQueryRep $ OnlyUnique a1 -#endif - -- | The lifted version of 'Database.Persist.Sql.selectSourceRes' selectSourceRes :: (MonadIO m2, PersistRecordBackend record SqlBackend, Typeable record, MonadSqlQuery m) @@ -305,13 +266,11 @@ => [Filter record] -> m Int count a1 = runQueryRep $ Count a1 -#if MIN_VERSION_persistent(2,11,0) -- | The lifted version of 'Database.Persist.Sql.exists' exists :: (PersistRecordBackend record SqlBackend, Typeable record, MonadSqlQuery m) => [Filter record] -> m Bool exists a1 = runQueryRep $ Exists a1 -#endif -- | The lifted version of 'Database.Persist.Sql.selectSource' selectSource @@ -361,22 +320,6 @@ => [Filter record] -> [Update record] -> m Int64 updateWhereCount a1 a2 = runQueryRep $ UpdateWhereCount a1 a2 -#if !MIN_VERSION_persistent(2,13,0) --- | The lifted version of 'Database.Persist.Sql.deleteCascade' -deleteCascade - :: (DeleteCascade record SqlBackend, Typeable record, MonadSqlQuery m) - => Key record -> m () -deleteCascade a1 = runQueryRep $ DeleteCascade a1 -#endif - -#if !MIN_VERSION_persistent(2,13,0) --- | The lifted version of 'Database.Persist.Sql.deleteCascadeWhere' -deleteCascadeWhere - :: (DeleteCascade record SqlBackend, Typeable record, MonadSqlQuery m) - => [Filter record] -> m () -deleteCascadeWhere a1 = runQueryRep $ DeleteCascadeWhere a1 -#endif - -- | The lifted version of 'Database.Persist.Sql.parseMigration' parseMigration :: (HasCallStack, MonadSqlQuery m) @@ -413,13 +356,11 @@ => Migration -> m () runMigration a1 = runQueryRep $ RunMigration a1 -#if MIN_VERSION_persistent(2,10,2) -- | The lifted version of 'Database.Persist.Sql.runMigrationQuiet' runMigrationQuiet :: (MonadSqlQuery m) => Migration -> m [Text] runMigrationQuiet a1 = runQueryRep $ RunMigrationQuiet a1 -#endif -- | The lifted version of 'Database.Persist.Sql.runMigrationSilent' runMigrationSilent @@ -433,13 +374,11 @@ => Migration -> m () runMigrationUnsafe a1 = runQueryRep $ RunMigrationUnsafe a1 -#if MIN_VERSION_persistent(2,10,2) -- | The lifted version of 'Database.Persist.Sql.runMigrationUnsafeQuiet' runMigrationUnsafeQuiet :: (HasCallStack, MonadSqlQuery m) => Migration -> m [Text] runMigrationUnsafeQuiet a1 = runQueryRep $ RunMigrationUnsafeQuiet a1 -#endif -- | The lifted version of 'Database.Persist.Sql.getFieldName' getFieldName @@ -495,13 +434,11 @@ => m () transactionSave = runQueryRep $ TransactionSave -#if MIN_VERSION_persistent(2,9,0) -- | The lifted version of 'Database.Persist.Sql.transactionSaveWithIsolation' transactionSaveWithIsolation :: (MonadSqlQuery m) => IsolationLevel -> m () transactionSaveWithIsolation a1 = runQueryRep $ TransactionSaveWithIsolation a1 -#endif -- | The lifted version of 'Database.Persist.Sql.transactionUndo' transactionUndo @@ -509,13 +446,11 @@ => m () transactionUndo = runQueryRep $ TransactionUndo -#if MIN_VERSION_persistent(2,9,0) -- | The lifted version of 'Database.Persist.Sql.transactionUndoWithIsolation' transactionUndoWithIsolation :: (MonadSqlQuery m) => IsolationLevel -> m () transactionUndoWithIsolation a1 = runQueryRep $ TransactionUndoWithIsolation a1 -#endif -- | Lift an arbitrary 'SqlPersistT' action into 'MonadSqlQuery'. -- diff --git a/src/Database/Persist/Monad/SqlQueryRep.hs b/src/Database/Persist/Monad/SqlQueryRep.hs --- a/src/Database/Persist/Monad/SqlQueryRep.hs +++ b/src/Database/Persist/Monad/SqlQueryRep.hs @@ -1,3 +1,6 @@ +{- THIS FILE IS AUTOGENERATED AND SHOULD NOT BE EDITED MANUALLY -} +{- FOURMOLU_DISABLE -} + {-| Module: Database.Persist.Monad.SqlQueryRep @@ -8,8 +11,6 @@ @Database.Persist.Monad.Shim@. -} -{- THIS FILE IS AUTOGENERATED AND SHOULD NOT BE EDITED MANUALLY -} - {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} @@ -38,7 +39,9 @@ import Database.Persist.Sql as Persist hiding (pattern Update) import GHC.Stack (HasCallStack) -{-# ANN module "HLint: ignore" #-} +#if !MIN_VERSION_persistent(2,14,1) +import Database.Persist.Monad.Internal.PersistentShim (SafeToInsert) +#endif -- | The data type containing a constructor for each persistent function we'd -- like to lift into 'Database.Persist.Monad.MonadSqlQuery'. @@ -87,22 +90,22 @@ -- | Constructor corresponding to 'Persist.insert' Insert - :: (PersistRecordBackend record SqlBackend) + :: (PersistRecordBackend record SqlBackend, SafeToInsert record) => record -> SqlQueryRep record (Key record) -- | Constructor corresponding to 'Persist.insert_' Insert_ - :: (PersistRecordBackend record SqlBackend) + :: (PersistRecordBackend record SqlBackend, SafeToInsert record) => record -> SqlQueryRep record () -- | Constructor corresponding to 'Persist.insertMany' InsertMany - :: (PersistRecordBackend record SqlBackend) + :: (PersistRecordBackend record SqlBackend, SafeToInsert record) => [record] -> SqlQueryRep record [Key record] -- | Constructor corresponding to 'Persist.insertMany_' InsertMany_ - :: (PersistRecordBackend record SqlBackend) + :: (PersistRecordBackend record SqlBackend, SafeToInsert record) => [record] -> SqlQueryRep record () -- | Constructor corresponding to 'Persist.insertEntityMany' @@ -147,12 +150,12 @@ -- | Constructor corresponding to 'Persist.insertEntity' InsertEntity - :: (PersistRecordBackend record SqlBackend) + :: (PersistRecordBackend record SqlBackend, SafeToInsert record) => record -> SqlQueryRep record (Entity record) -- | Constructor corresponding to 'Persist.insertRecord' InsertRecord - :: (PersistRecordBackend record SqlBackend) + :: (PersistRecordBackend record SqlBackend, SafeToInsert record) => record -> SqlQueryRep record record -- | Constructor corresponding to 'Persist.getBy' @@ -160,31 +163,20 @@ :: (PersistRecordBackend record SqlBackend) => Unique record -> SqlQueryRep record (Maybe (Entity record)) -#if MIN_VERSION_persistent(2,10,0) -- | Constructor corresponding to 'Persist.getByValue' GetByValue :: (PersistRecordBackend record SqlBackend, AtLeastOneUniqueKey record) => record -> SqlQueryRep record (Maybe (Entity record)) -#endif -#if !MIN_VERSION_persistent(2,10,0) - -- | Constructor corresponding to 'Persist.getByValue' - GetByValue - :: (PersistRecordBackend record SqlBackend) - => record -> SqlQueryRep record (Maybe (Entity record)) -#endif - -- | Constructor corresponding to 'Persist.checkUnique' CheckUnique :: (PersistRecordBackend record SqlBackend) => record -> SqlQueryRep record (Maybe (Unique record)) -#if MIN_VERSION_persistent(2,11,0) -- | Constructor corresponding to 'Persist.checkUniqueUpdateable' CheckUniqueUpdateable :: (PersistRecordBackend record SqlBackend) => Entity record -> SqlQueryRep record (Maybe (Unique record)) -#endif -- | Constructor corresponding to 'Persist.deleteBy' DeleteBy @@ -193,50 +185,32 @@ -- | Constructor corresponding to 'Persist.insertUnique' InsertUnique - :: (PersistRecordBackend record SqlBackend) + :: (PersistRecordBackend record SqlBackend, SafeToInsert record) => record -> SqlQueryRep record (Maybe (Key record)) -#if MIN_VERSION_persistent(2,10,0) -- | Constructor corresponding to 'Persist.upsert' Upsert - :: (PersistRecordBackend record SqlBackend, OnlyOneUniqueKey record) + :: (PersistRecordBackend record SqlBackend, OnlyOneUniqueKey record, SafeToInsert record) => record -> [Update record] -> SqlQueryRep record (Entity record) -#endif -#if !MIN_VERSION_persistent(2,10,0) - -- | Constructor corresponding to 'Persist.upsert' - Upsert - :: (PersistRecordBackend record SqlBackend) - => record -> [Update record] -> SqlQueryRep record (Entity record) -#endif - -- | Constructor corresponding to 'Persist.upsertBy' UpsertBy - :: (PersistRecordBackend record SqlBackend) + :: (PersistRecordBackend record SqlBackend, SafeToInsert record) => Unique record -> record -> [Update record] -> SqlQueryRep record (Entity record) -- | Constructor corresponding to 'Persist.putMany' PutMany - :: (PersistRecordBackend record SqlBackend) + :: (PersistRecordBackend record SqlBackend, SafeToInsert record) => [record] -> SqlQueryRep record () -#if MIN_VERSION_persistent(2,10,0) -- | Constructor corresponding to 'Persist.insertBy' InsertBy - :: (PersistRecordBackend record SqlBackend, AtLeastOneUniqueKey record) + :: (PersistRecordBackend record SqlBackend, AtLeastOneUniqueKey record, SafeToInsert record) => record -> SqlQueryRep record (Either (Entity record) (Key record)) -#endif -#if !MIN_VERSION_persistent(2,10,0) - -- | Constructor corresponding to 'Persist.insertBy' - InsertBy - :: (PersistRecordBackend record SqlBackend) - => record -> SqlQueryRep record (Either (Entity record) (Key record)) -#endif - -- | Constructor corresponding to 'Persist.insertUniqueEntity' InsertUniqueEntity - :: (PersistRecordBackend record SqlBackend) + :: (PersistRecordBackend record SqlBackend, SafeToInsert record) => record -> SqlQueryRep record (Maybe (Entity record)) -- | Constructor corresponding to 'Persist.replaceUnique' @@ -244,20 +218,11 @@ :: (PersistRecordBackend record SqlBackend, Eq (Unique record), Eq record) => Key record -> record -> SqlQueryRep record (Maybe (Unique record)) -#if MIN_VERSION_persistent(2,10,0) -- | Constructor corresponding to 'Persist.onlyUnique' OnlyUnique :: (PersistRecordBackend record SqlBackend, OnlyOneUniqueKey record) => record -> SqlQueryRep record (Unique record) -#endif -#if !MIN_VERSION_persistent(2,10,0) - -- | Constructor corresponding to 'Persist.onlyUnique' - OnlyUnique - :: (PersistRecordBackend record SqlBackend) - => record -> SqlQueryRep record (Unique record) -#endif - -- | Constructor corresponding to 'Persist.selectSourceRes' SelectSourceRes :: (MonadIO m2, PersistRecordBackend record SqlBackend) @@ -278,12 +243,10 @@ :: (PersistRecordBackend record SqlBackend) => [Filter record] -> SqlQueryRep record Int -#if MIN_VERSION_persistent(2,11,0) -- | Constructor corresponding to 'Persist.exists' Exists :: (PersistRecordBackend record SqlBackend) => [Filter record] -> SqlQueryRep record Bool -#endif -- | Constructor corresponding to 'Persist.selectList' SelectList @@ -315,20 +278,6 @@ :: (PersistRecordBackend record SqlBackend) => [Filter record] -> [Update record] -> SqlQueryRep record Int64 -#if !MIN_VERSION_persistent(2,13,0) - -- | Constructor corresponding to 'Persist.deleteCascade' - DeleteCascade - :: (DeleteCascade record SqlBackend) - => Key record -> SqlQueryRep record () -#endif - -#if !MIN_VERSION_persistent(2,13,0) - -- | Constructor corresponding to 'Persist.deleteCascadeWhere' - DeleteCascadeWhere - :: (DeleteCascade record SqlBackend) - => [Filter record] -> SqlQueryRep record () -#endif - -- | Constructor corresponding to 'Persist.parseMigration' ParseMigration :: (HasCallStack) @@ -359,12 +308,10 @@ :: () => Migration -> SqlQueryRep Void () -#if MIN_VERSION_persistent(2,10,2) -- | Constructor corresponding to 'Persist.runMigrationQuiet' RunMigrationQuiet :: () => Migration -> SqlQueryRep Void [Text] -#endif -- | Constructor corresponding to 'Persist.runMigrationSilent' RunMigrationSilent @@ -376,12 +323,10 @@ :: () => Migration -> SqlQueryRep Void () -#if MIN_VERSION_persistent(2,10,2) -- | Constructor corresponding to 'Persist.runMigrationUnsafeQuiet' RunMigrationUnsafeQuiet :: (HasCallStack) => Migration -> SqlQueryRep Void [Text] -#endif -- | Constructor corresponding to 'Persist.getFieldName' GetFieldName @@ -423,24 +368,20 @@ :: () => SqlQueryRep Void () -#if MIN_VERSION_persistent(2,9,0) -- | Constructor corresponding to 'Persist.transactionSaveWithIsolation' TransactionSaveWithIsolation :: () => IsolationLevel -> SqlQueryRep Void () -#endif -- | Constructor corresponding to 'Persist.transactionUndo' TransactionUndo :: () => SqlQueryRep Void () -#if MIN_VERSION_persistent(2,9,0) -- | Constructor corresponding to 'Persist.transactionUndoWithIsolation' TransactionUndoWithIsolation :: () => IsolationLevel -> SqlQueryRep Void () -#endif -- | Constructor for lifting an arbitrary SqlPersistT action into SqlQueryRep. UnsafeLiftSql @@ -470,73 +411,39 @@ InsertEntity{} -> "InsertEntity{..}" ++ record InsertRecord{} -> "InsertRecord{..}" ++ record GetBy{} -> "GetBy{..}" ++ record -#if MIN_VERSION_persistent(2,10,0) GetByValue{} -> "GetByValue{..}" ++ record -#endif -#if !MIN_VERSION_persistent(2,10,0) - GetByValue{} -> "GetByValue{..}" ++ record -#endif CheckUnique{} -> "CheckUnique{..}" ++ record -#if MIN_VERSION_persistent(2,11,0) CheckUniqueUpdateable{} -> "CheckUniqueUpdateable{..}" ++ record -#endif DeleteBy{} -> "DeleteBy{..}" ++ record InsertUnique{} -> "InsertUnique{..}" ++ record -#if MIN_VERSION_persistent(2,10,0) Upsert{} -> "Upsert{..}" ++ record -#endif -#if !MIN_VERSION_persistent(2,10,0) - Upsert{} -> "Upsert{..}" ++ record -#endif UpsertBy{} -> "UpsertBy{..}" ++ record PutMany{} -> "PutMany{..}" ++ record -#if MIN_VERSION_persistent(2,10,0) InsertBy{} -> "InsertBy{..}" ++ record -#endif -#if !MIN_VERSION_persistent(2,10,0) - InsertBy{} -> "InsertBy{..}" ++ record -#endif InsertUniqueEntity{} -> "InsertUniqueEntity{..}" ++ record ReplaceUnique{} -> "ReplaceUnique{..}" ++ record -#if MIN_VERSION_persistent(2,10,0) OnlyUnique{} -> "OnlyUnique{..}" ++ record -#endif -#if !MIN_VERSION_persistent(2,10,0) - OnlyUnique{} -> "OnlyUnique{..}" ++ record -#endif SelectSourceRes{} -> "SelectSourceRes{..}" ++ record SelectFirst{} -> "SelectFirst{..}" ++ record SelectKeysRes{} -> "SelectKeysRes{..}" ++ record Count{} -> "Count{..}" ++ record -#if MIN_VERSION_persistent(2,11,0) Exists{} -> "Exists{..}" ++ record -#endif SelectList{} -> "SelectList{..}" ++ record SelectKeysList{} -> "SelectKeysList{..}" ++ record UpdateWhere{} -> "UpdateWhere{..}" ++ record DeleteWhere{} -> "DeleteWhere{..}" ++ record DeleteWhereCount{} -> "DeleteWhereCount{..}" ++ record UpdateWhereCount{} -> "UpdateWhereCount{..}" ++ record -#if !MIN_VERSION_persistent(2,13,0) - DeleteCascade{} -> "DeleteCascade{..}" ++ record -#endif -#if !MIN_VERSION_persistent(2,13,0) - DeleteCascadeWhere{} -> "DeleteCascadeWhere{..}" ++ record -#endif ParseMigration{} -> "ParseMigration{..}" ++ record ParseMigration'{} -> "ParseMigration'{..}" ++ record PrintMigration{} -> "PrintMigration{..}" ++ record ShowMigration{} -> "ShowMigration{..}" ++ record GetMigration{} -> "GetMigration{..}" ++ record RunMigration{} -> "RunMigration{..}" ++ record -#if MIN_VERSION_persistent(2,10,2) RunMigrationQuiet{} -> "RunMigrationQuiet{..}" ++ record -#endif RunMigrationSilent{} -> "RunMigrationSilent{..}" ++ record RunMigrationUnsafe{} -> "RunMigrationUnsafe{..}" ++ record -#if MIN_VERSION_persistent(2,10,2) RunMigrationUnsafeQuiet{} -> "RunMigrationUnsafeQuiet{..}" ++ record -#endif GetFieldName{} -> "GetFieldName{..}" ++ record GetTableName{} -> "GetTableName{..}" ++ record WithRawQuery{} -> "WithRawQuery{..}" ++ record @@ -545,13 +452,9 @@ RawExecuteCount{} -> "RawExecuteCount{..}" ++ record RawSql{} -> "RawSql{..}" ++ record TransactionSave{} -> "TransactionSave{..}" ++ record -#if MIN_VERSION_persistent(2,9,0) TransactionSaveWithIsolation{} -> "TransactionSaveWithIsolation{..}" ++ record -#endif TransactionUndo{} -> "TransactionUndo{..}" ++ record -#if MIN_VERSION_persistent(2,9,0) TransactionUndoWithIsolation{} -> "TransactionUndoWithIsolation{..}" ++ record -#endif UnsafeLiftSql label _ -> "UnsafeLiftSql{" ++ Text.unpack label ++ "}" where record = case recordTypeRep of @@ -587,73 +490,39 @@ InsertEntity a1 -> Persist.insertEntity a1 InsertRecord a1 -> Persist.insertRecord a1 GetBy a1 -> Persist.getBy a1 -#if MIN_VERSION_persistent(2,10,0) GetByValue a1 -> Persist.getByValue a1 -#endif -#if !MIN_VERSION_persistent(2,10,0) - GetByValue a1 -> Persist.getByValue a1 -#endif CheckUnique a1 -> Persist.checkUnique a1 -#if MIN_VERSION_persistent(2,11,0) CheckUniqueUpdateable a1 -> Persist.checkUniqueUpdateable a1 -#endif DeleteBy a1 -> Persist.deleteBy a1 InsertUnique a1 -> Persist.insertUnique a1 -#if MIN_VERSION_persistent(2,10,0) Upsert a1 a2 -> Persist.upsert a1 a2 -#endif -#if !MIN_VERSION_persistent(2,10,0) - Upsert a1 a2 -> Persist.upsert a1 a2 -#endif UpsertBy a1 a2 a3 -> Persist.upsertBy a1 a2 a3 PutMany a1 -> Persist.putMany a1 -#if MIN_VERSION_persistent(2,10,0) InsertBy a1 -> Persist.insertBy a1 -#endif -#if !MIN_VERSION_persistent(2,10,0) - InsertBy a1 -> Persist.insertBy a1 -#endif InsertUniqueEntity a1 -> Persist.insertUniqueEntity a1 ReplaceUnique a1 a2 -> Persist.replaceUnique a1 a2 -#if MIN_VERSION_persistent(2,10,0) OnlyUnique a1 -> Persist.onlyUnique a1 -#endif -#if !MIN_VERSION_persistent(2,10,0) - OnlyUnique a1 -> Persist.onlyUnique a1 -#endif SelectSourceRes a1 a2 -> Persist.selectSourceRes a1 a2 SelectFirst a1 a2 -> Persist.selectFirst a1 a2 SelectKeysRes a1 a2 -> Persist.selectKeysRes a1 a2 Count a1 -> Persist.count a1 -#if MIN_VERSION_persistent(2,11,0) Exists a1 -> Persist.exists a1 -#endif SelectList a1 a2 -> Persist.selectList a1 a2 SelectKeysList a1 a2 -> Persist.selectKeysList a1 a2 UpdateWhere a1 a2 -> Persist.updateWhere a1 a2 DeleteWhere a1 -> Persist.deleteWhere a1 DeleteWhereCount a1 -> Persist.deleteWhereCount a1 UpdateWhereCount a1 a2 -> Persist.updateWhereCount a1 a2 -#if !MIN_VERSION_persistent(2,13,0) - DeleteCascade a1 -> Persist.deleteCascade a1 -#endif -#if !MIN_VERSION_persistent(2,13,0) - DeleteCascadeWhere a1 -> Persist.deleteCascadeWhere a1 -#endif ParseMigration a1 -> Persist.parseMigration a1 ParseMigration' a1 -> Persist.parseMigration' a1 PrintMigration a1 -> Persist.printMigration a1 ShowMigration a1 -> Persist.showMigration a1 GetMigration a1 -> Persist.getMigration a1 RunMigration a1 -> Persist.runMigration a1 -#if MIN_VERSION_persistent(2,10,2) RunMigrationQuiet a1 -> Persist.runMigrationQuiet a1 -#endif RunMigrationSilent a1 -> Persist.runMigrationSilent a1 RunMigrationUnsafe a1 -> Persist.runMigrationUnsafe a1 -#if MIN_VERSION_persistent(2,10,2) RunMigrationUnsafeQuiet a1 -> Persist.runMigrationUnsafeQuiet a1 -#endif GetFieldName a1 -> Persist.getFieldName a1 GetTableName a1 -> Persist.getTableName a1 WithRawQuery a1 a2 a3 -> Persist.withRawQuery a1 a2 a3 @@ -662,11 +531,7 @@ RawExecuteCount a1 a2 -> Persist.rawExecuteCount a1 a2 RawSql a1 a2 -> Persist.rawSql a1 a2 TransactionSave -> Persist.transactionSave -#if MIN_VERSION_persistent(2,9,0) TransactionSaveWithIsolation a1 -> Persist.transactionSaveWithIsolation a1 -#endif TransactionUndo -> Persist.transactionUndo -#if MIN_VERSION_persistent(2,9,0) TransactionUndoWithIsolation a1 -> Persist.transactionUndoWithIsolation a1 -#endif UnsafeLiftSql _ action -> action diff --git a/src/Database/Persist/Monad/TestUtils.hs b/src/Database/Persist/Monad/TestUtils.hs --- a/src/Database/Persist/Monad/TestUtils.hs +++ b/src/Database/Persist/Monad/TestUtils.hs @@ -1,10 +1,3 @@ -{-| -Module: Database.Persist.Monad.TestUtils - -Defines 'MockSqlQueryT', which one can use in tests in order to mock out -@persistent@ database queries called in production code. --} - {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} @@ -13,44 +6,57 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} -module Database.Persist.Monad.TestUtils - ( MockSqlQueryT - , runMockSqlQueryT - , withRecord - , mockQuery - , MockQuery +{-| +Module: Database.Persist.Monad.TestUtils +Defines 'MockSqlQueryT', which one can use in tests in order to mock out +@persistent@ database queries called in production code. +-} +module Database.Persist.Monad.TestUtils ( + MockSqlQueryT, + runMockSqlQueryT, + withRecord, + mockQuery, + MockQuery, + -- * Specialized helpers - , mockSelectSource - , mockSelectKeys - , mockWithRawQuery - , mockRawQuery - , mockRawSql + mockSelectSource, + mockSelectKeys, + mockWithRawQuery, + mockRawQuery, + mockRawSql, -- * Re-exports - , SqlQueryRep(..) - ) where + SqlQueryRep (..), +) where import Conduit ((.|)) import qualified Conduit import Control.Monad (msum) -import Control.Monad.IO.Class (MonadIO(..)) +import Control.Monad.IO.Class (MonadIO (..)) import Control.Monad.Reader (ReaderT, ask, runReaderT) import Control.Monad.Trans.Resource (MonadResource) import qualified Data.Acquire as Acquire import Data.Text (Text) import qualified Data.Text as Text -import Data.Typeable (Typeable, eqT, (:~:)(..)) -import Database.Persist.Sql - (Entity, Filter, Key, PersistValue, SelectOpt, rawSqlProcessRow) +import Data.Typeable (Typeable, eqT, (:~:) (..)) +import Database.Persist.Sql ( + Entity, + Filter, + Key, + PersistValue, + SelectOpt, + rawSqlProcessRow, + ) -import Database.Persist.Monad.Class (MonadSqlQuery(..)) -import Database.Persist.Monad.SqlQueryRep (SqlQueryRep(..)) +import Database.Persist.Monad.Class (MonadSqlQuery (..)) +import Database.Persist.Monad.SqlQueryRep (SqlQueryRep (..)) -- | A monad transformer for testing functions that use 'MonadSqlQuery'. newtype MockSqlQueryT m a = MockSqlQueryT { unMockSqlQueryT :: ReaderT [MockQuery] m a - } deriving + } + deriving ( Functor , Applicative , Monad @@ -58,34 +64,35 @@ , MonadResource ) --- | Runs a 'MockSqlQueryT' monad transformer using the given mocks. --- --- When a database query is executed, the first mock that returns a 'Just' is --- returned. If no mocks match the query, an error is thrown. See 'SqlQueryRep' --- for the constructors available to match against. Most of the time, you'll --- want to use 'withRecord' to only match queries against a specific @record@ --- type (e.g. only match 'Database.Persist.Monad.Shim.selectList' calls for --- the @Person@ entity). --- --- Usage: --- --- @ --- myFunction :: MonadSqlQuery m => m [String] --- myFunction = map personName <$> selectList [PersonAge >. 25] [] --- --- let persons = [Person ...] --- result <- runMockSqlQueryT myFunction --- [ withRecord \@Person $ \\case --- SelectList _ _ -> Just persons --- _ -> Nothing --- , withRecord \@Post $ \\case --- Insert Post{ name = "post1" } -> Just $ toSqlKey 1 --- _ -> Nothing --- , mockQuery $ \\case --- RawExecuteCount "DELETE FROM person WHERE name = \'Alice\'" [] -> Just 1 --- _ -> Nothing --- ] --- @ +{-| Runs a 'MockSqlQueryT' monad transformer using the given mocks. + + When a database query is executed, the first mock that returns a 'Just' is + returned. If no mocks match the query, an error is thrown. See 'SqlQueryRep' + for the constructors available to match against. Most of the time, you'll + want to use 'withRecord' to only match queries against a specific @record@ + type (e.g. only match 'Database.Persist.Monad.Shim.selectList' calls for + the @Person@ entity). + + Usage: + + @ + myFunction :: MonadSqlQuery m => m [String] + myFunction = map personName <$> selectList [PersonAge >. 25] [] + + let persons = [Person ...] + result <- runMockSqlQueryT myFunction + [ withRecord \@Person $ \\case + SelectList _ _ -> Just persons + _ -> Nothing + , withRecord \@Post $ \\case + Insert Post{ name = "post1" } -> Just $ toSqlKey 1 + _ -> Nothing + , mockQuery $ \\case + RawExecuteCount "DELETE FROM person WHERE name = \'Alice\'" [] -> Just 1 + _ -> Nothing + ] + @ +-} runMockSqlQueryT :: MockSqlQueryT m a -> [MockQuery] -> m a runMockSqlQueryT action mockQueries = (`runReaderT` mockQueries) . unMockSqlQueryT $ action @@ -94,149 +101,158 @@ runQueryRep rep = do mockQueries <- MockSqlQueryT ask - maybe (error $ "Could not find mock for query: " ++ show rep) liftIO - $ msum $ map tryMockQuery mockQueries + maybe (error $ "Could not find mock for query: " ++ show rep) liftIO $ + msum $ + map tryMockQuery mockQueries where tryMockQuery (MockQuery f) = f rep withTransaction = id --- | A mocked query to use in 'runMockSqlQueryT'. --- --- Use 'withRecord' or another helper to create a 'MockQuery'. +{-| A mocked query to use in 'runMockSqlQueryT'. + + Use 'withRecord' or another helper to create a 'MockQuery'. +-} data MockQuery = MockQuery (forall record a. Typeable record => SqlQueryRep record a -> Maybe (IO a)) --- | A helper for defining a mocked database query against a specific @record@ --- type. Designed to be used with TypeApplications. --- --- Most 'SqlQueryRep' constructors are in the context of a specific @record@ --- type, like @Person@. This helper only matches mocked database queries that --- are querying the record you specify. --- --- Some constructors reference multiple @record@ types, like --- 'Database.Persist.Monad.BelongsTo'. Look at the type to see the record you --- need to match against. For example, --- --- @ --- withRecord \@(Person, Post) $ \\case --- BelongsTo _ _ -> ... --- @ --- --- would match the function call --- --- @ --- belongsTo :: (Person -> Maybe (Key Post)) -> Person -> SqlQueryRep (Person, Post) (Maybe Post) --- @ +{-| A helper for defining a mocked database query against a specific @record@ + type. Designed to be used with TypeApplications. + + Most 'SqlQueryRep' constructors are in the context of a specific @record@ + type, like @Person@. This helper only matches mocked database queries that + are querying the record you specify. + + Some constructors reference multiple @record@ types, like + 'Database.Persist.Monad.BelongsTo'. Look at the type to see the record you + need to match against. For example, + + @ + withRecord \@(Person, Post) $ \\case + BelongsTo _ _ -> ... + @ + + would match the function call + + @ + belongsTo :: (Person -> Maybe (Key Post)) -> Person -> SqlQueryRep (Person, Post) (Maybe Post) + @ +-} withRecord :: forall record. Typeable record => (forall a. SqlQueryRep record a -> Maybe a) -> MockQuery withRecord f = MockQuery $ \(rep :: SqlQueryRep someRecord result) -> case eqT @record @someRecord of Just Refl -> pure <$> f rep Nothing -> Nothing --- | A helper for defining a mocked database query. --- --- This does not do any matching on the @record@ type, so it is mostly useful --- for queries that don't use the @record@ type, like --- 'Database.Persist.Monad.Shim.rawExecute'. +{-| A helper for defining a mocked database query. + + This does not do any matching on the @record@ type, so it is mostly useful + for queries that don't use the @record@ type, like + 'Database.Persist.Monad.Shim.rawExecute'. +-} mockQuery :: (forall record a. Typeable record => SqlQueryRep record a -> Maybe a) -> MockQuery mockQuery f = MockQuery (fmap pure . f) --- | A helper for mocking a 'Database.Persist.Monad.Shim.selectSource' or --- 'Database.Persist.Monad.Shim.selectSourceRes' call. --- --- Usage: --- --- @ --- mockSelectSource $ \\filters opts -> --- if null filters && null opts --- then --- let person1 = [Entity (toSqlKey 1) $ Person \"Alice\"] --- person2 = [Entity (toSqlKey 2) $ Person \"Bob\"] --- in Just [person1, person2] --- else Nothing --- @ +{-| A helper for mocking a 'Database.Persist.Monad.Shim.selectSource' or + 'Database.Persist.Monad.Shim.selectSourceRes' call. + + Usage: + + @ + mockSelectSource $ \\filters opts -> + if null filters && null opts + then + let person1 = [Entity (toSqlKey 1) $ Person \"Alice\"] + person2 = [Entity (toSqlKey 2) $ Person \"Bob\"] + in Just [person1, person2] + else Nothing + @ +-} mockSelectSource :: forall record. Typeable record => ([Filter record] -> [SelectOpt record] -> Maybe [Entity record]) -> MockQuery mockSelectSource f = withRecord @record $ \case SelectSourceRes filters opts -> let toAcquire entities = Acquire.mkAcquire (pure $ Conduit.yieldMany entities) (\_ -> pure ()) - in toAcquire <$> f filters opts + in toAcquire <$> f filters opts _ -> Nothing --- | A helper for mocking a 'Database.Persist.Monad.Shim.selectKeys' or --- 'Database.Persist.Monad.Shim.selectKeysRes' call. --- --- Usage: --- --- @ --- mockSelectKeys $ \\filters opts -> --- if null filters && null opts --- then Just $ map toSqlKey [1, 2] --- else Nothing --- @ +{-| A helper for mocking a 'Database.Persist.Monad.Shim.selectKeys' or + 'Database.Persist.Monad.Shim.selectKeysRes' call. + + Usage: + + @ + mockSelectKeys $ \\filters opts -> + if null filters && null opts + then Just $ map toSqlKey [1, 2] + else Nothing + @ +-} mockSelectKeys :: forall record. Typeable record => ([Filter record] -> [SelectOpt record] -> Maybe [Key record]) -> MockQuery mockSelectKeys f = withRecord @record $ \case SelectKeysRes filters opts -> let toAcquire keys = Acquire.mkAcquire (pure $ Conduit.yieldMany keys) (\_ -> pure ()) - in toAcquire <$> f filters opts + in toAcquire <$> f filters opts _ -> Nothing --- | A helper for mocking a 'Database.Persist.Monad.Shim.withRawQuery' call. --- --- Usage: --- --- @ --- mockWithRawQuery $ \\sql vals -> --- if sql == "SELECT id, name FROM person" --- then --- let row1 = [toPersistValue 1, toPersistValue \"Alice\"] --- row2 = [toPersistValue 2, toPersistValue \"Bob\"] --- in Just [row1, row2] --- else Nothing --- @ +{-| A helper for mocking a 'Database.Persist.Monad.Shim.withRawQuery' call. + + Usage: + + @ + mockWithRawQuery $ \\sql vals -> + if sql == "SELECT id, name FROM person" + then + let row1 = [toPersistValue 1, toPersistValue \"Alice\"] + row2 = [toPersistValue 2, toPersistValue \"Bob\"] + in Just [row1, row2] + else Nothing + @ +-} mockWithRawQuery :: (Text -> [PersistValue] -> Maybe [[PersistValue]]) -> MockQuery mockWithRawQuery f = MockQuery $ \case WithRawQuery sql vals conduit -> let outputRows rows = Conduit.runConduit $ Conduit.yieldMany rows .| conduit - in outputRows <$> f sql vals + in outputRows <$> f sql vals _ -> Nothing --- | A helper for mocking a 'Database.Persist.Monad.Shim.rawQuery' or --- 'Database.Persist.Monad.Shim.rawQueryRes' call. --- --- Usage: --- --- @ --- mockRawQuery $ \\sql vals -> --- if sql == "SELECT id, name FROM person" --- then --- let row1 = [toPersistValue 1, toPersistValue \"Alice\"] --- row2 = [toPersistValue 2, toPersistValue \"Bob\"] --- in Just [row1, row2] --- else Nothing --- @ +{-| A helper for mocking a 'Database.Persist.Monad.Shim.rawQuery' or + 'Database.Persist.Monad.Shim.rawQueryRes' call. + + Usage: + + @ + mockRawQuery $ \\sql vals -> + if sql == "SELECT id, name FROM person" + then + let row1 = [toPersistValue 1, toPersistValue \"Alice\"] + row2 = [toPersistValue 2, toPersistValue \"Bob\"] + in Just [row1, row2] + else Nothing + @ +-} mockRawQuery :: (Text -> [PersistValue] -> Maybe [[PersistValue]]) -> MockQuery mockRawQuery f = MockQuery $ \case RawQueryRes sql vals -> let toAcquire rows = Acquire.mkAcquire (pure $ Conduit.yieldMany rows) (\_ -> pure ()) - in pure . toAcquire <$> f sql vals + in pure . toAcquire <$> f sql vals _ -> Nothing --- | A helper for mocking a 'Database.Persist.Monad.Shim.rawSql' call. --- --- Usage: --- --- @ --- mockRawSql $ \\sql vals -> --- if sql == "SELECT id, name FROM person" --- then --- let row1 = [toPersistValue 1, toPersistValue \"Alice\"] --- row2 = [toPersistValue 2, toPersistValue \"Bob\"] --- in Just [row1, row2] --- else Nothing --- @ +{-| A helper for mocking a 'Database.Persist.Monad.Shim.rawSql' call. + + Usage: + + @ + mockRawSql $ \\sql vals -> + if sql == "SELECT id, name FROM person" + then + let row1 = [toPersistValue 1, toPersistValue \"Alice\"] + row2 = [toPersistValue 2, toPersistValue \"Bob\"] + in Just [row1, row2] + else Nothing + @ +-} mockRawSql :: (Text -> [PersistValue] -> Maybe [[PersistValue]]) -> MockQuery mockRawSql f = MockQuery $ \case RawSql sql vals -> let fromRow = either (error . Text.unpack) id . rawSqlProcessRow - in pure . map fromRow <$> f sql vals + in pure . map fromRow <$> f sql vals _ -> Nothing diff --git a/src/Database/Persist/Sql/Shim.hs b/src/Database/Persist/Sql/Shim.hs new file mode 100644 --- /dev/null +++ b/src/Database/Persist/Sql/Shim.hs @@ -0,0 +1,233 @@ +{- THIS FILE IS AUTOGENERATED AND SHOULD NOT BE EDITED MANUALLY -} +{- FOURMOLU_DISABLE -} + +{-| +Module: Database.Persist.Sql.Shim + +Defines all the @persistent@ functions lifted into 'MonadSqlQuery', and +re-exports a version of the @Database.Persist.Sql@ module replacing each +function with the lifted version. + +This file is autogenerated, to keep it in sync with +@Database.Persist.Monad.Shim@. +-} + +{-# LANGUAGE CPP #-} + +module Database.Persist.Sql.Shim ( + module Database.Persist.Sql, + get, + getMany, + getJust, + getJustEntity, + getEntity, + belongsTo, + belongsToJust, + insert, + insert_, + insertMany, + insertMany_, + insertEntityMany, + insertKey, + repsert, + repsertMany, + replace, + delete, + update, + updateGet, + insertEntity, + insertRecord, + getBy, + getByValue, + checkUnique, + checkUniqueUpdateable, + deleteBy, + insertUnique, + upsert, + upsertBy, + putMany, + insertBy, + insertUniqueEntity, + replaceUnique, + onlyUnique, + selectSourceRes, + selectFirst, + selectKeysRes, + count, + exists, + selectSource, + selectKeys, + selectList, + selectKeysList, + updateWhere, + deleteWhere, + deleteWhereCount, + updateWhereCount, + parseMigration, + parseMigration', + printMigration, + showMigration, + getMigration, + runMigration, + runMigrationQuiet, + runMigrationSilent, + runMigrationUnsafe, + runMigrationUnsafeQuiet, + getFieldName, + getTableName, + withRawQuery, + rawQueryRes, + rawQuery, + rawExecute, + rawExecuteCount, + rawSql, + transactionSave, + transactionSaveWithIsolation, + transactionUndo, + transactionUndoWithIsolation, + unsafeLiftSql, + ) where + +import Database.Persist.Monad.Shim ( + get, + getMany, + getJust, + getJustEntity, + getEntity, + belongsTo, + belongsToJust, + insert, + insert_, + insertMany, + insertMany_, + insertEntityMany, + insertKey, + repsert, + repsertMany, + replace, + delete, + update, + updateGet, + insertEntity, + insertRecord, + getBy, + getByValue, + checkUnique, + checkUniqueUpdateable, + deleteBy, + insertUnique, + upsert, + upsertBy, + putMany, + insertBy, + insertUniqueEntity, + replaceUnique, + onlyUnique, + selectSourceRes, + selectFirst, + selectKeysRes, + count, + exists, + selectSource, + selectKeys, + selectList, + selectKeysList, + updateWhere, + deleteWhere, + deleteWhereCount, + updateWhereCount, + parseMigration, + parseMigration', + printMigration, + showMigration, + getMigration, + runMigration, + runMigrationQuiet, + runMigrationSilent, + runMigrationUnsafe, + runMigrationUnsafeQuiet, + getFieldName, + getTableName, + withRawQuery, + rawQueryRes, + rawQuery, + rawExecute, + rawExecuteCount, + rawSql, + transactionSave, + transactionSaveWithIsolation, + transactionUndo, + transactionUndoWithIsolation, + unsafeLiftSql + ) +import Database.Persist.Sql hiding ( + get, + getMany, + getJust, + getJustEntity, + getEntity, + belongsTo, + belongsToJust, + insert, + insert_, + insertMany, + insertMany_, + insertEntityMany, + insertKey, + repsert, + repsertMany, + replace, + delete, + update, + updateGet, + insertEntity, + insertRecord, + getBy, + getByValue, + checkUnique, + checkUniqueUpdateable, + deleteBy, + insertUnique, + upsert, + upsertBy, + putMany, + insertBy, + insertUniqueEntity, + replaceUnique, + onlyUnique, + selectSourceRes, + selectFirst, + selectKeysRes, + count, + exists, + selectSource, + selectKeys, + selectList, + selectKeysList, + updateWhere, + deleteWhere, + deleteWhereCount, + updateWhereCount, + parseMigration, + parseMigration', + printMigration, + showMigration, + getMigration, + runMigration, + runMigrationQuiet, + runMigrationSilent, + runMigrationUnsafe, + runMigrationUnsafeQuiet, + getFieldName, + getTableName, + withRawQuery, + rawQueryRes, + rawQuery, + rawExecute, + rawExecuteCount, + rawSql, + transactionSave, + transactionSaveWithIsolation, + transactionUndo, + transactionUndoWithIsolation, + ) diff --git a/test/Basic.hs b/test/Basic.hs deleted file mode 100644 --- a/test/Basic.hs +++ /dev/null @@ -1,31 +0,0 @@ -{-# LANGUAGE GADTs #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE TypeApplications #-} - -module Basic where - -import Test.Tasty -import Test.Tasty.HUnit - -import Database.Persist.Monad -import Database.Persist.Monad.TestUtils -import Example - -tests :: TestTree -tests = testGroup "Basic functionality tests" - [ testCase "Ensure withTransaction README example typechecks" $ do - let foo :: MonadSqlQuery m => m () - foo = insert_ $ person "Alice" - bar :: MonadSqlQuery m => m () - bar = insert_ $ person "Bob" - fooAndBar :: MonadSqlQuery m => m () - fooAndBar = withTransaction $ foo >> bar - runMockSqlQueryT fooAndBar - [ withRecord @Person $ \case - Insert_ _ -> Just () - _ -> Nothing - , withRecord @Person $ \case - Insert_ _ -> Just () - _ -> Nothing - ] - ] diff --git a/test/Example.hs b/test/Example.hs --- a/test/Example.hs +++ b/test/Example.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleInstances #-} @@ -11,55 +10,60 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} -{-# OPTIONS_GHC -Wno-unused-top-binds #-} {-# OPTIONS_GHC -Wno-missing-methods #-} +{-# OPTIONS_GHC -Wno-unused-top-binds #-} -module Example - ( TestApp - , runTestApp - , runTestAppWith +module Example ( + TestApp, + runTestApp, + runTestAppWith, - -- * Person - , Person(..) - , person - , getPeople - , getPeopleNames - , getName - , nameAndAge + -- * Person + Person (..), + person, + getPeople, + getPeopleNames, + getName, + nameAndAge, - -- * Post - , Post(..) - , post - , getPosts - , getPostTitles + -- * Post + Post (..), + post, + getPosts, + getPostTitles, - -- * Persistent - , EntityField(..) - , Unique(..) - , migration - ) where + -- * Persistent + EntityField (..), + Unique (..), + migration, +) where import Control.Arrow ((&&&)) -import Control.Monad.IO.Class (MonadIO(..)) +import Control.Monad.IO.Class (MonadIO (..)) import Control.Monad.Trans.Resource (MonadResource, ResourceT, runResourceT) -import Database.Persist.Sql - (Entity(..), EntityField, Key, SelectOpt(..), Unique, toSqlKey) -import Database.Persist.TH - (mkMigrate, mkPersist, persistLowerCase, share, sqlSettings) -#if !MIN_VERSION_persistent(2,13,0) -import qualified Database.Persist.TH -#endif -import UnliftIO (MonadUnliftIO(..), wrappedWithRunInIO) +import Database.Persist.Sql ( + Entity (..), + EntityField, + Key, + SelectOpt (..), + Unique, + toSqlKey, + ) +import Database.Persist.TH ( + mkMigrate, + mkPersist, + persistLowerCase, + share, + sqlSettings, + ) +import UnliftIO (MonadUnliftIO (..), wrappedWithRunInIO) import Control.Monad.IO.Rerunnable (MonadRerunnableIO) import Database.Persist.Monad -import TestUtils.DB (BackendType(..), withTestDB) +import TestUtils.DB (BackendType (..), withTestDB) share [ mkPersist sqlSettings -#if !MIN_VERSION_persistent(2,13,0) - , Database.Persist.TH.mkDeleteCascade sqlSettings -#endif , mkMigrate "migration" ] [persistLowerCase| @@ -72,20 +76,13 @@ Post title String -#if MIN_VERSION_persistent(2,13,0) author PersonId editor PersonId Maybe -#else - author PersonId OnDeleteCascade - editor PersonId Maybe OnDeleteCascade -#endif deriving Show Eq |] deriving instance Eq (Unique Person) -#if !MIN_VERSION_persistent_template(2,6,0) || MIN_VERSION_persistent_template(2,9,0) deriving instance Show (Unique Person) -#endif -- Let tests use a literal number for keys instance Num (Key Person) where @@ -96,7 +93,8 @@ newtype TestApp a = TestApp { unTestApp :: SqlQueryT (ResourceT IO) a - } deriving + } + deriving ( Functor , Applicative , Monad diff --git a/test/Generated.hs b/test/Generated.hs --- a/test/Generated.hs +++ b/test/Generated.hs @@ -1,4 +1,5 @@ {- THIS FILE IS AUTOGENERATED AND SHOULD NOT BE EDITED MANUALLY -} +{- FOURMOLU_DISABLE -} {-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-} @@ -17,8 +18,6 @@ import Database.Persist.Monad.TestUtils (SqlQueryRep(..)) import Example -{-# ANN module "HLint: ignore" #-} - allSqlQueryRepShowRepresentations :: [String] allSqlQueryRepShowRepresentations = [ show (Get undefined :: SqlQueryRep Person (Maybe Person)) @@ -43,73 +42,39 @@ , show (InsertEntity undefined :: SqlQueryRep Person (Entity Person)) , show (InsertRecord undefined :: SqlQueryRep Person Person) , show (GetBy undefined :: SqlQueryRep Person (Maybe (Entity Person))) -#if MIN_VERSION_persistent(2,10,0) , show (GetByValue undefined :: SqlQueryRep Person (Maybe (Entity Person))) -#endif -#if !MIN_VERSION_persistent(2,10,0) - , show (GetByValue undefined :: SqlQueryRep Person (Maybe (Entity Person))) -#endif , show (CheckUnique undefined :: SqlQueryRep Person (Maybe (Unique Person))) -#if MIN_VERSION_persistent(2,11,0) , show (CheckUniqueUpdateable undefined :: SqlQueryRep Person (Maybe (Unique Person))) -#endif , show (DeleteBy undefined :: SqlQueryRep Person ()) , show (InsertUnique undefined :: SqlQueryRep Person (Maybe (Key Person))) -#if MIN_VERSION_persistent(2,10,0) , show (Upsert undefined undefined :: SqlQueryRep Person (Entity Person)) -#endif -#if !MIN_VERSION_persistent(2,10,0) - , show (Upsert undefined undefined :: SqlQueryRep Person (Entity Person)) -#endif , show (UpsertBy undefined undefined undefined :: SqlQueryRep Person (Entity Person)) , show (PutMany undefined :: SqlQueryRep Person ()) -#if MIN_VERSION_persistent(2,10,0) , show (InsertBy undefined :: SqlQueryRep Person (Either (Entity Person) (Key Person))) -#endif -#if !MIN_VERSION_persistent(2,10,0) - , show (InsertBy undefined :: SqlQueryRep Person (Either (Entity Person) (Key Person))) -#endif , show (InsertUniqueEntity undefined :: SqlQueryRep Person (Maybe (Entity Person))) , show (ReplaceUnique undefined undefined :: SqlQueryRep Person (Maybe (Unique Person))) -#if MIN_VERSION_persistent(2,10,0) , show (OnlyUnique undefined :: SqlQueryRep Person (Unique Person)) -#endif -#if !MIN_VERSION_persistent(2,10,0) - , show (OnlyUnique undefined :: SqlQueryRep Person (Unique Person)) -#endif , show (SelectSourceRes undefined undefined :: SqlQueryRep Person (Acquire (ConduitM () (Entity Person) IO ()))) , show (SelectFirst undefined undefined :: SqlQueryRep Person (Maybe (Entity Person))) , show (SelectKeysRes undefined undefined :: SqlQueryRep Person (Acquire (ConduitM () (Key Person) IO ()))) , show (Count undefined :: SqlQueryRep Person Int) -#if MIN_VERSION_persistent(2,11,0) , show (Exists undefined :: SqlQueryRep Person Bool) -#endif , show (SelectList undefined undefined :: SqlQueryRep Person [Entity Person]) , show (SelectKeysList undefined undefined :: SqlQueryRep Person [Key Person]) , show (UpdateWhere undefined undefined :: SqlQueryRep Person ()) , show (DeleteWhere undefined :: SqlQueryRep Person ()) , show (DeleteWhereCount undefined :: SqlQueryRep Person Int64) , show (UpdateWhereCount undefined undefined :: SqlQueryRep Person Int64) -#if !MIN_VERSION_persistent(2,13,0) - , show (DeleteCascade undefined :: SqlQueryRep Person ()) -#endif -#if !MIN_VERSION_persistent(2,13,0) - , show (DeleteCascadeWhere undefined :: SqlQueryRep Person ()) -#endif , show (ParseMigration undefined :: SqlQueryRep Void (Either [Text] CautiousMigration)) , show (ParseMigration' undefined :: SqlQueryRep Void CautiousMigration) , show (PrintMigration undefined :: SqlQueryRep Void ()) , show (ShowMigration undefined :: SqlQueryRep Void [Text]) , show (GetMigration undefined :: SqlQueryRep Void [Sql]) , show (RunMigration undefined :: SqlQueryRep Void ()) -#if MIN_VERSION_persistent(2,10,2) , show (RunMigrationQuiet undefined :: SqlQueryRep Void [Text]) -#endif , show (RunMigrationSilent undefined :: SqlQueryRep Void [Text]) , show (RunMigrationUnsafe undefined :: SqlQueryRep Void ()) -#if MIN_VERSION_persistent(2,10,2) , show (RunMigrationUnsafeQuiet undefined :: SqlQueryRep Void [Text]) -#endif , show (GetFieldName undefined :: SqlQueryRep Person Text) , show (GetTableName undefined :: SqlQueryRep Person Text) , show (WithRawQuery undefined undefined undefined :: SqlQueryRep Void a) @@ -118,11 +83,7 @@ , show (RawExecuteCount undefined undefined :: SqlQueryRep Void Int64) , show (RawSql undefined undefined :: SqlQueryRep Void [Entity Person]) , show (TransactionSave :: SqlQueryRep Void ()) -#if MIN_VERSION_persistent(2,9,0) , show (TransactionSaveWithIsolation undefined :: SqlQueryRep Void ()) -#endif , show (TransactionUndo :: SqlQueryRep Void ()) -#if MIN_VERSION_persistent(2,9,0) , show (TransactionUndoWithIsolation undefined :: SqlQueryRep Void ()) -#endif ] diff --git a/test/Integration.hs b/test/Integration.hs deleted file mode 100644 --- a/test/Integration.hs +++ /dev/null @@ -1,898 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} - -module Integration where - -import Conduit (runConduit, (.|)) -import qualified Conduit -import Control.Arrow ((&&&)) -import qualified Data.Acquire as Acquire -import Data.Bifunctor (first) -import qualified Data.Map.Strict as Map -import Data.Text (Text) -import qualified Data.Text as Text -import Data.Typeable (Typeable) -#if MIN_VERSION_esqueleto(3,5,0) -import qualified Database.Esqueleto.Experimental as E -#else -import qualified Database.Esqueleto as E -#endif -import Database.Persist.Sql - ( Entity(..) - , Migration - , PersistField - , PersistRecordBackend - , PersistValue - , Single(..) - , SqlBackend - , fromPersistValue - , (=.) - , (==.) - ) -#if MIN_VERSION_persistent(2,9,0) -import Database.Persist.Sql (IsolationLevel(..)) -#endif -import Test.Predicates (anything, elemsAre, eq, right) -import Test.Predicates.HUnit ((@?~)) -import Test.Tasty -import Test.Tasty.HUnit -import UnliftIO (MonadIO, MonadUnliftIO, liftIO) -import UnliftIO.Exception - ( Exception - , SomeException - , StringException(..) - , fromException - , throwIO - , throwString - , try - ) -import UnliftIO.IORef (atomicModifyIORef, newIORef) - -import Control.Monad.IO.Rerunnable (MonadRerunnableIO, rerunnableIO) -import Database.Persist.Monad -import Example -import TestUtils.DB (BackendType(..), allBackendTypes) -import TestUtils.Esqueleto (esqueletoSelect) - -tests :: TestTree -tests = testGroup "Integration tests" $ - map testsWithBackend allBackendTypes - -testsWithBackend :: BackendType -> TestTree -testsWithBackend backendType = testGroup (show backendType) - [ testWithTransaction backendType - , testComposability backendType - , testPersistentAPI backendType - , testInterop backendType - ] - -testWithTransaction :: BackendType -> TestTree -testWithTransaction backendType = testGroup "withTransaction" - [ testCase "it uses the same transaction" $ do - -- without transactions, the INSERT shouldn't be rolled back - runTestApp backendType $ do - catchTestError $ insertAndFail $ person "Alice" - result <- getPeopleNames - liftIO $ result @?= ["Alice"] - - -- with transactions, the INSERT should be rolled back - runTestApp backendType $ do - catchTestError $ withTransaction $ insertAndFail $ person "Alice" - result <- getPeopleNames - liftIO $ result @?= [] - - , testCase "retries transactions" $ do - let retryIf e = case fromException e of - Just (StringException "retry me" _) -> True - _ -> False - setRetry env = env { retryIf, retryLimit = 5 } - - counter <- newIORef (0 :: Int) - - result <- try @_ @SomeException $ runTestAppWith backendType setRetry $ - withTransaction $ rerunnableIO $ do - x <- atomicModifyIORef counter $ \x -> (x + 1, x) - if x > 2 - then return () - else throwString "retry me" - - case result of - Right () -> return () - Left e -> error $ "Got unexpected error: " ++ show e - - , testCase "throws error when retry hits limit" $ do - let setRetry env = env { retryIf = const True, retryLimit = 2 } - - result <- try @_ @TransactionError @() $ runTestAppWith backendType setRetry $ - withTransaction $ rerunnableIO $ throwString "retry me" - - result @?= Left RetryLimitExceeded - ] - --- this should compile -testComposability :: BackendType -> TestTree -testComposability backendType = testCase "Operations can be composed" $ do - let onlySql :: MonadSqlQuery m => m () - onlySql = do - _ <- getPeople - return () - - sqlAndRerunnableIO :: (MonadSqlQuery m, MonadRerunnableIO m) => m () - sqlAndRerunnableIO = do - _ <- getPeopleNames - _ <- rerunnableIO $ newIORef True - return () - - onlyRerunnableIO :: MonadRerunnableIO m => m () - onlyRerunnableIO = do - _ <- rerunnableIO $ newIORef True - return () - - arbitraryIO :: MonadIO m => m () - arbitraryIO = do - _ <- liftIO $ newIORef True - return () - - -- everything should compose naturally by default - runTestApp backendType $ do - onlySql - sqlAndRerunnableIO - onlyRerunnableIO - arbitraryIO - - -- in a transaction, you can compose everything except arbitrary IO - runTestApp backendType $ withTransaction $ do - onlySql - sqlAndRerunnableIO - onlyRerunnableIO - -- uncomment this to get compile error - -- arbitraryIO - -testPersistentAPI :: BackendType -> TestTree -testPersistentAPI backendType = testGroup "Persistent API" - [ testCase "get" $ do - result <- runTestApp backendType $ do - insert_ $ person "Alice" - mapM get [1, 2] - map (fmap personName) result @?= [Just "Alice", Nothing] - - , testCase "getMany" $ do - result <- runTestApp backendType $ do - insert_ $ person "Alice" - getMany [1] - personName <$> Map.lookup 1 result @?= Just "Alice" - - , testCase "getJust" $ do - result <- runTestApp backendType $ do - insert_ $ person "Alice" - getJust 1 - personName result @?= "Alice" - - , testCase "getJustEntity" $ do - result <- runTestApp backendType $ do - insert_ $ person "Alice" - getJustEntity 1 - getName result @?= "Alice" - - , testCase "getEntity" $ do - result <- runTestApp backendType $ do - insert_ $ person "Alice" - mapM getEntity [1, 2] - map (fmap getName) result @?= [Just "Alice", Nothing] - - , testCase "belongsTo" $ do - result <- runTestApp backendType $ do - aliceKey <- insert $ person "Alice" - let post1 = Post "Post #1" aliceKey (Just aliceKey) - post2 = Post "Post #2" aliceKey Nothing - insertMany_ [post1, post2] - mapM (belongsTo postEditor) [post1, post2] - map (fmap personName) result @?= [Just "Alice", Nothing] - - , testCase "belongsToJust" $ do - result <- runTestApp backendType $ do - aliceKey <- insert $ person "Alice" - let post1 = Post "Post #1" aliceKey Nothing - insert_ post1 - belongsToJust postAuthor post1 - personName result @?= "Alice" - - , testCase "insert" $ do - result <- runTestApp backendType $ do - aliceKey <- insert $ person "Alice" - people <- getPeopleNames - return (aliceKey, people) - result @?= (1, ["Alice"]) - - , testCase "insert_" $ do - result <- runTestApp backendType $ do - result <- insert_ $ person "Alice" - people <- getPeopleNames - return (result, people) - result @?= ((), ["Alice"]) - - , testCase "insertMany" $ do - result <- runTestApp backendType $ do - keys <- insertMany [person "Alice", person "Bob"] - people <- getPeopleNames - return (keys, people) - result @?= ([1, 2], ["Alice", "Bob"]) - - , testCase "insertMany_" $ do - result <- runTestApp backendType $ do - result <- insertMany_ [person "Alice", person "Bob"] - people <- getPeopleNames - return (result, people) - result @?= ((), ["Alice", "Bob"]) - - , testCase "insertEntityMany" $ do - result <- runTestApp backendType $ do - result <- insertEntityMany - [ Entity 1 $ person "Alice" - , Entity 2 $ person "Bob" - ] - people <- getPeopleNames - return (result, people) - result @?= ((), ["Alice", "Bob"]) - - , testCase "insertKey" $ do - result <- runTestApp backendType $ do - result <- insertKey 1 $ person "Alice" - people <- getPeopleNames - return (result, people) - result @?= ((), ["Alice"]) - - , testCase "repsert" $ do - result <- runTestApp backendType $ do - let alice = person "Alice" - insert_ alice - repsert 1 $ alice { personAge = 100 } - repsert 2 $ person "Bob" - getPeople - map nameAndAge result @?= - [ ("Alice", 100) - , ("Bob", 0) - ] - - , testCase "repsertMany" $ do - result <- runTestApp backendType $ do - let alice = person "Alice" --- https://github.com/yesodweb/persistent/issues/832 -#if MIN_VERSION_persistent(2,9,0) - insert_ alice - repsertMany - [ (1, alice { personAge = 100 }) - , (2, person "Bob") - ] -#else - repsertMany [(1, alice { personAge = 100 })] - repsertMany [(2, person "Bob")] -#endif - getPeople - map nameAndAge result @?= - [ ("Alice", 100) - , ("Bob", 0) - ] - - , testCase "replace" $ do - result <- runTestApp backendType $ do - let alice = person "Alice" - insert_ alice - replace 1 $ alice { personAge = 100 } - getJust 1 - personAge result @?= 100 - - , testCase "delete" $ do - result <- runTestApp backendType $ do - aliceKey <- insert $ person "Alice" - delete aliceKey - getPeople - result @?= [] - - , testCase "update" $ do - result <- runTestApp backendType $ do - key <- insert $ person "Alice" - update key [PersonName =. "Alicia"] - getPeopleNames - result @?= ["Alicia"] - - , testCase "updateGet" $ do - (updateResult, getResult) <- runTestApp backendType $ do - key <- insert $ person "Alice" - updateResult <- updateGet key [PersonName =. "Alicia"] - getResult <- getJust key - return (updateResult, getResult) - updateResult @?= getResult - - , testCase "insertEntity" $ do - (insertResult, getResult) <- runTestApp backendType $ do - insertResult <- insertEntity $ person "Alice" - getResult <- getJust $ entityKey insertResult - return (insertResult, getResult) - entityVal insertResult @?= getResult - - , testCase "insertRecord" $ do - (insertResult, getResult) <- runTestApp backendType $ do - insertResult <- insertRecord $ person "Alice" - getResult <- getJust 1 - return (insertResult, getResult) - insertResult @?= getResult - - , testCase "getBy" $ do - result <- runTestApp backendType $ do - insert_ $ person "Alice" - mapM getBy [UniqueName "Alice", UniqueName "Bob"] - map (fmap getName) result @?= [Just "Alice", Nothing] - - , testCase "getByValue" $ do - result <- runTestApp backendType $ do - let alice = person "Alice" - insert_ alice - mapM getByValue [alice, person "Bob"] - map (fmap getName) result @?= [Just "Alice", Nothing] - - , testCase "checkUnique" $ do - result <- runTestApp backendType $ do - let alice = person "Alice" - insert_ alice - mapM checkUnique - [ alice - , person "Bob" - , (person "Alice"){ personAge = 100 } - ] - result @?= [Just (UniqueName "Alice"), Nothing, Just (UniqueName "Alice")] - -#if MIN_VERSION_persistent(2,11,0) - , testCase "checkUniqueUpdateable" $ do - result <- runTestApp backendType $ do - let alice = person "Alice" - insert_ alice - mapM checkUniqueUpdateable - [ Entity 1 alice - , Entity 2 $ person "Bob" - , Entity 3 $ (person "Alice"){ personAge = 100 } - ] - result @?= [Nothing, Nothing, Just (UniqueName "Alice")] -#endif - - , testCase "deleteBy" $ do - result <- runTestApp backendType $ do - insert_ $ person "Alice" - deleteBy $ UniqueName "Alice" - getPeople - result @?= [] - - , testCase "insertUnique" $ do - (result1, result2, people) <- runTestApp backendType $ do - result1 <- insertUnique $ person "Alice" - result2 <- insertUnique $ person "Alice" - people <- getPeopleNames - return (result1, result2, people) - result1 @?= Just 1 - result2 @?= Nothing - people @?= ["Alice"] - - , testCase "upsert" $ do - (result1, result2, people) <- runTestApp backendType $ do - result1 <- upsert (person "Alice") [PersonAge =. 0] - result2 <- upsert (person "Alice") [PersonAge =. 100] - people <- getPeople - return (result1, result2, people) - entityKey result1 @?= entityKey result2 - nameAndAge (entityVal result1) @?= ("Alice", 0) - nameAndAge (entityVal result2) @?= ("Alice", 100) - map nameAndAge people @?= [("Alice", 100)] - - , testCase "upsertBy" $ do - (result1, result2, people) <- runTestApp backendType $ do - result1 <- upsertBy (UniqueName "Alice") (person "Alice") [PersonAge =. 0] - result2 <- upsertBy (UniqueName "Alice") (person "Alice") [PersonAge =. 100] - people <- getPeople - return (result1, result2, people) - entityKey result1 @?= entityKey result2 - nameAndAge (entityVal result1) @?= ("Alice", 0) - nameAndAge (entityVal result2) @?= ("Alice", 100) - map nameAndAge people @?= [("Alice", 100)] - - , testCase "putMany" $ do - result <- runTestApp backendType $ do - let alice = person "Alice" - insert_ alice - putMany - [ alice { personAge = 100 } - , person "Bob" - ] - getPeople - map nameAndAge result @?= - [ ("Alice", 100) - , ("Bob", 0) - ] - - , testCase "insertBy" $ do - (result1, result2, people) <- runTestApp backendType $ do - let alice = person "Alice" - result1 <- insertBy alice - result2 <- insertBy $ alice { personAge = 100 } - people <- getPeople - return (result1, result2, people) - result1 @?= Right 1 - first (entityKey &&& getName) result2 @?= Left (1, "Alice") - map nameAndAge people @?= [("Alice", 0)] - - , testCase "insertUniqueEntity" $ do - (result1, result2, people) <- runTestApp backendType $ do - let alice = person "Alice" - result1 <- insertUniqueEntity alice - result2 <- insertUniqueEntity $ alice { personAge = 100 } - people <- getPeople - return (result1, result2, people) - (entityKey &&& getName) <$> result1 @?= Just (1, "Alice") - result2 @?= Nothing - map nameAndAge people @?= [("Alice", 0)] - - , testCase "replaceUnique" $ do - (result1, result2, people) <- runTestApp backendType $ do - let alice = person "Alice" - bob = person "Bob" - insertMany_ [alice, bob] - result1 <- replaceUnique 1 $ alice { personName = "Bob" } - result2 <- replaceUnique 2 $ bob { personAge = 100 } - people <- getPeople - return (result1, result2, people) - result1 @?= Just (UniqueName "Bob") - result2 @?= Nothing - map nameAndAge people @?= [("Alice", 0), ("Bob", 100)] - - , testCase "onlyUnique" $ do - result <- runTestApp backendType $ onlyUnique $ person "Alice" - result @?= UniqueName "Alice" - - , testCase "selectSourceRes" $ do - result <- runTestApp backendType $ do - insertMany_ [person "Alice", person "Bob"] - acquire <- selectSourceRes [] [] - Acquire.with acquire $ \conduit -> - runConduit $ conduit .| Conduit.mapC getName .| Conduit.sinkList - result @?= ["Alice", "Bob"] - - , testCase "selectFirst" $ do - result <- runTestApp backendType $ do - insert_ $ person "Alice" - sequence - [ selectFirst [PersonName ==. "Alice"] [] - , selectFirst [PersonName ==. "Bob"] [] - ] - map (fmap getName) result @?= [Just "Alice", Nothing] - - , testCase "selectKeysRes" $ do - result <- runTestApp backendType $ do - insertMany_ [person "Alice", person "Bob"] - acquire <- selectKeysRes @_ @Person [] [] - Acquire.with acquire $ \conduit -> - runConduit $ conduit .| Conduit.sinkList - result @?= [1, 2] - - , testCase "count" $ do - result <- runTestApp backendType $ do - insertMany_ $ map (\p -> p{personAge = 100}) [person "Alice", person "Bob"] - count [PersonAge ==. 100] - result @?= 2 - -#if MIN_VERSION_persistent(2,11,0) - , testCase "exists" $ do - result <- runTestApp backendType $ do - insertMany_ [person "Alice", person "Bob"] - exists [PersonName ==. "Alice"] - result @?= True -#endif - - , testCase "selectSource" $ do - result <- runTestApp backendType $ do - insertMany_ [person "Alice", person "Bob"] - runConduit $ selectSource [] [] .| Conduit.mapC getName .| Conduit.sinkList - result @?= ["Alice", "Bob"] - - , testCase "selectKeys" $ do - result <- runTestApp backendType $ do - insertMany_ [person "Alice", person "Bob"] - runConduit $ selectKeys @Person [] [] .| Conduit.sinkList - result @?= [1, 2] - - , testCase "selectList" $ do - result <- runTestApp backendType $ do - insert_ $ person "Alice" - insert_ $ person "Bob" - selectList [] [] - map getName result @?= ["Alice", "Bob"] - - , testCase "selectKeysList" $ do - result <- runTestApp backendType $ do - insert_ $ person "Alice" - insert_ $ person "Bob" - selectKeysList @Person [] [] - result @?= [1, 2] - - , testCase "updateWhere" $ do - result <- runTestApp backendType $ do - insertMany_ [person "Alice", person "Bob"] - updateWhere [PersonName ==. "Alice"] [PersonAge =. 100] - getPeople - map nameAndAge result @?= [("Alice", 100), ("Bob", 0)] - - , testCase "deleteWhere" $ do - result <- runTestApp backendType $ do - insertMany_ [person "Alice", person "Bob"] - deleteWhere [PersonName ==. "Alice"] - getPeopleNames - result @?= ["Bob"] - - , testCase "updateWhereCount" $ do - (rowsUpdated, people) <- runTestApp backendType $ do - insertMany_ [person "Alice", person "Bob"] - rowsUpdated <- updateWhereCount [PersonName ==. "Alice"] [PersonAge =. 100] - people <- getPeople - return (rowsUpdated, people) - rowsUpdated @?= 1 - map nameAndAge people @?= [("Alice", 100), ("Bob", 0)] - - , testCase "deleteWhereCount" $ do - (rowsDeleted, names) <- runTestApp backendType $ do - insertMany_ [person "Alice", person "Bob"] - rowsDeleted <- deleteWhereCount [PersonName ==. "Alice"] - names <- getPeopleNames - return (rowsDeleted, names) - rowsDeleted @?= 1 - names @?= ["Bob"] - -#if !MIN_VERSION_persistent(2,13,0) - , testCase "deleteCascade" $ do - (people, posts) <- runTestApp backendType $ do - aliceKey <- insert $ person "Alice" - bobKey <- insert $ person "Bob" - insertMany_ - [ post "Post #1" aliceKey - , post "Post #2" bobKey - ] - deleteCascade aliceKey - people <- getPeopleNames - posts <- getPostTitles - return (people, posts) - people @?= ["Bob"] - posts @?= ["Post #2"] - - , testCase "deleteCascadeWhere" $ do - (people, posts) <- runTestApp backendType $ do - aliceKey <- insert $ person "Alice" - bobKey <- insert $ person "Bob" - insertMany_ - [ post "Post #1" aliceKey - , post "Post #2" bobKey - ] - deleteCascadeWhere [PersonName ==. "Alice"] - people <- getPeopleNames - posts <- getPostTitles - return (people, posts) - people @?= ["Bob"] - posts @?= ["Post #2"] -#endif - - , testCase "parseMigration" $ do - result <- runTestApp backendType $ do - setupUnsafeMigration - parseMigration migration - - let sql = case backendType of - Sqlite -> - [ eq - ( False - , Text.concat - [ "CREATE TEMP TABLE \"person_backup\"(" - , "\"id\" INTEGER PRIMARY KEY," - , "\"name\" VARCHAR NOT NULL," - , "\"age\" INTEGER NOT NULL," - , "CONSTRAINT \"unique_name\" UNIQUE (\"name\"))" - ] - ) - , anything - , eq (True, "DROP TABLE \"person\"") - , anything - , anything - , eq (False, "DROP TABLE \"person_backup\"") - ] - Postgresql -> - [ eq (True, "ALTER TABLE \"person\" DROP COLUMN \"foo\"") - ] - - result @?~ right (elemsAre sql) - - , testCase "parseMigration'" $ do - let action :: (Migration -> TestApp a) -> IO a - action f = runTestApp backendType $ do - setupUnsafeMigration - f migration - - result <- action parseMigration - result' <- action parseMigration' - Right result' @?= result - - , testCase "printMigration" $ - runTestApp backendType $ do - setupUnsafeMigration - printMigration migration - - , testCase "showMigration" $ do - result <- runTestApp backendType $ do - setupUnsafeMigration - showMigration migration - - let sql = case backendType of - Sqlite -> - [ eq $ Text.concat - [ "CREATE TEMP TABLE \"person_backup\"(" - , "\"id\" INTEGER PRIMARY KEY," - , "\"name\" VARCHAR NOT NULL," - , "\"age\" INTEGER NOT NULL," - , "CONSTRAINT \"unique_name\" UNIQUE (\"name\"));" - ] - , anything - , eq "DROP TABLE \"person\";" - , anything - , anything - , eq "DROP TABLE \"person_backup\";" - ] - Postgresql -> - [ eq "ALTER TABLE \"person\" DROP COLUMN \"foo\";" - ] - - result @?~ elemsAre sql - - , testCase "getMigration" $ do - result <- runTestApp backendType $ do - setupUnsafeMigration - getMigration migration - - let sql = case backendType of - Sqlite -> - [ eq $ Text.concat - [ "CREATE TEMP TABLE \"person_backup\"(" - , "\"id\" INTEGER PRIMARY KEY," - , "\"name\" VARCHAR NOT NULL," - , "\"age\" INTEGER NOT NULL," - , "CONSTRAINT \"unique_name\" UNIQUE (\"name\"))" - ] - , anything - , eq "DROP TABLE \"person\"" - , anything - , anything - , eq "DROP TABLE \"person_backup\"" - ] - Postgresql -> - [ eq "ALTER TABLE \"person\" DROP COLUMN \"foo\"" - ] - - result @?~ elemsAre sql - - , testCase "runMigration" $ do - result <- runTestApp backendType $ do - setupSafeMigration - runMigration migration - getSchemaColumnNames backendType "person" - assertNotIn "removed_column" result - -#if MIN_VERSION_persistent(2,10,2) - , testCase "runMigrationQuiet" $ do - (withQuiet, cols) <- runTestApp backendType $ do - setupSafeMigration - sql <- runMigrationQuiet migration - cols <- getSchemaColumnNames backendType "person" - return (sql, cols) - withSilent <- runTestApp backendType $ do - setupSafeMigration - runMigrationSilent migration - assertNotIn "removed_column" cols - withQuiet @?= withSilent -#endif - - , testCase "runMigrationSilent" $ do - (sqlPlanned, sqlExecuted, cols) <- runTestApp backendType $ do - setupSafeMigration - sqlPlanned <- getMigration migration - sqlExecuted <- runMigrationSilent migration - cols <- getSchemaColumnNames backendType "person" - return (sqlPlanned, sqlExecuted, cols) - assertNotIn "removed_column" cols - sqlExecuted @?= sqlPlanned - - , testCase "runMigrationUnsafe" $ do - result <- runTestApp backendType $ do - setupUnsafeMigration - runMigrationUnsafe migration - getSchemaColumnNames backendType "person" - assertNotIn "removed_column" result - -#if MIN_VERSION_persistent(2,10,2) - , testCase "runMigrationUnsafeQuiet" $ do - (sqlPlanned, sqlExecuted, cols) <- runTestApp backendType $ do - setupUnsafeMigration - sqlPlanned <- getMigration migration - sqlExecuted <- runMigrationUnsafeQuiet migration - cols <- getSchemaColumnNames backendType "person" - return (sqlPlanned, sqlExecuted, cols) - assertNotIn "removed_column" cols - sqlExecuted @?= sqlPlanned -#endif - - , testCase "getFieldName" $ do - result <- runTestApp backendType $ - getFieldName PersonName - result @?= "\"name\"" - - , testCase "getTableName" $ do - result <- runTestApp backendType $ - getTableName $ person "Alice" - result @?= "\"person\"" - - , testCase "withRawQuery" $ do - result <- runTestApp backendType $ do - insertMany_ [person "Alice", person "Bob"] - withRawQuery "SELECT name FROM person" [] $ - Conduit.mapC (fromPersistValue' @Text . head) .| Conduit.sinkList - - result @?= ["Alice", "Bob"] - - , testCase "rawQueryRes" $ do - result <- runTestApp backendType $ do - insertMany_ [person "Alice", person "Bob"] - acquire <- rawQueryRes "SELECT name FROM person" [] - Acquire.with acquire $ \conduit -> - runConduit $ conduit .| Conduit.mapC (fromPersistValue' @Text . head) .| Conduit.sinkList - result @?= ["Alice", "Bob"] - - , testCase "rawQuery" $ do - result <- runTestApp backendType $ do - insertMany_ [person "Alice", person "Bob"] - runConduit $ rawQuery "SELECT name FROM person" [] .| Conduit.mapC (fromPersistValue' @Text . head) .| Conduit.sinkList - result @?= ["Alice", "Bob"] - - , testCase "rawExecute" $ do - result <- runTestApp backendType $ do - insertMany_ [person "Alice", person "Bob"] - rawExecute "UPDATE person SET age = 100 WHERE name = 'Alice'" [] - getPeople - map nameAndAge result @?= [("Alice", 100), ("Bob", 0)] - - , testCase "rawExecuteCount" $ do - (rowsUpdated, people) <- runTestApp backendType $ do - insertMany_ [person "Alice", person "Bob"] - rowsUpdated <- rawExecuteCount "UPDATE person SET age = 100 WHERE name = 'Alice'" [] - people <- getPeople - return (rowsUpdated, people) - rowsUpdated @?= 1 - map nameAndAge people @?= [("Alice", 100), ("Bob", 0)] - - , testCase "rawSql" $ do - result <- runTestApp backendType $ do - insertMany_ [person "Alice", person "Bob"] - rawSql @(Single String) "SELECT name FROM person" [] - map unSingle result @?= ["Alice", "Bob"] - - , testCase "transactionSave" $ do - result1 <- runTestApp backendType $ do - catchTestError $ withTransaction $ do - insert_ $ person "Alice" - insertAndFail $ person "Bob" - getPeopleNames - result1 @?= [] - - result2 <- runTestApp backendType $ do - catchTestError $ withTransaction $ do - insert_ $ person "Alice" - transactionSave - insertAndFail $ person "Bob" - getPeopleNames - result2 @?= ["Alice"] - -#if MIN_VERSION_persistent(2,9,0) - , testCase "transactionSaveWithIsolation" $ do - result1 <- runTestApp backendType $ do - catchTestError $ withTransaction $ do - insert_ $ person "Alice" - insertAndFail $ person "Bob" - getPeopleNames - result1 @?= [] - - result2 <- runTestApp backendType $ do - catchTestError $ withTransaction $ do - insert_ $ person "Alice" - transactionSaveWithIsolation Serializable - insertAndFail $ person "Bob" - getPeopleNames - result2 @?= ["Alice"] -#endif - - , testCase "transactionUndo" $ do - result <- runTestApp backendType $ withTransaction $ do - insert_ $ person "Alice" - transactionUndo - getPeopleNames - result @?= [] - -#if MIN_VERSION_persistent(2,9,0) - , testCase "transactionUndoWithIsolation" $ do - result <- runTestApp backendType $ withTransaction $ do - insert_ $ person "Alice" - transactionUndoWithIsolation Serializable - getPeopleNames - result @?= [] -#endif - ] - -testInterop :: BackendType -> TestTree -testInterop backendType = testGroup "Interop with third-party Persistent libraries" - [ testCase "unsafeLiftSql" $ do - let alice = person "Alice" - result <- runTestApp backendType $ do - insert_ alice - esqueletoSelect $ -#if MIN_VERSION_esqueleto(3,5,0) - E.from $ E.table @Person -#else - E.from $ \p -> return p -#endif - result @?= [Entity 1 alice] - ] - -{- Persistent helpers -} - -fromPersistValue' :: PersistField a => PersistValue -> a -fromPersistValue' = either (error . Text.unpack) id . fromPersistValue - -{- Meta SQL helpers -} - --- | Put the database in a state where running a migration is safe. -setupSafeMigration :: MonadSqlQuery m => m () -setupSafeMigration = rawExecute "ALTER TABLE person ADD COLUMN removed_column VARCHAR" [] - --- | Put the database in a state where running a migration is unsafe. -setupUnsafeMigration :: MonadSqlQuery m => m () -setupUnsafeMigration = rawExecute "ALTER TABLE person ADD COLUMN foo VARCHAR" [] - --- | Get the names of all columns in the given table. -getSchemaColumnNames :: MonadSqlQuery m => BackendType -> String -> m [String] -getSchemaColumnNames backendType tableName = map unSingle <$> rawSql sql [] - where - sql = Text.pack $ case backendType of - Sqlite -> "SELECT name FROM pragma_table_info('" ++ tableName ++ "')" - Postgresql -> unlines - [ "SELECT column_name FROM information_schema.columns" - , "WHERE table_schema = 'public' AND table_name = '" ++ tableName ++ "'" - ] - -{- Test helpers -} - -data TestError = TestError - deriving (Show, Eq) - -instance Exception TestError - -catchTestError :: (MonadUnliftIO m, Eq a, Show a) => m a -> m () -catchTestError m = do - result <- try m - liftIO $ result @?= Left TestError - -insertAndFail :: - ( MonadRerunnableIO m - , MonadSqlQuery m - , PersistRecordBackend record SqlBackend - , Typeable record - ) - => record -> m () -insertAndFail record = do - insert_ record - rerunnableIO $ throwIO TestError - -assertNotIn :: (Eq a, Show a) => a -> [a] -> Assertion -assertNotIn a as = as @?= filter (/= a) as diff --git a/test/IntegrationTest.hs b/test/IntegrationTest.hs new file mode 100644 --- /dev/null +++ b/test/IntegrationTest.hs @@ -0,0 +1,846 @@ +{- AUTOCOLLECT.TEST -} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} + +module IntegrationTest ( + -- $AUTOCOLLECT.TEST.export$ +) where + +import Conduit (runConduit, (.|)) +import qualified Conduit +import Control.Arrow ((&&&)) +import qualified Data.Acquire as Acquire +import Data.Bifunctor (first) +import qualified Data.Map.Strict as Map +import Data.Text (Text) +import qualified Data.Text as Text +import Data.Typeable (Typeable) +import qualified Database.Esqueleto.Experimental as E +import Database.Persist.Sql ( + Entity (..), + IsolationLevel (..), + Migration, + PersistField, + PersistRecordBackend, + PersistValue, + Single (..), + SqlBackend, + fromPersistValue, + (=.), + (==.), + ) +import Test.Predicates (anything, elemsAre, eq, right) +import Test.Predicates.HUnit ((@?~)) +import Test.Tasty +import Test.Tasty.HUnit +import UnliftIO (MonadIO, MonadUnliftIO, liftIO) +import UnliftIO.Exception ( + Exception, + SomeException, + StringException (..), + fromException, + throwIO, + throwString, + try, + ) +import UnliftIO.IORef (atomicModifyIORef, newIORef, readIORef, writeIORef) + +import Control.Monad.IO.Rerunnable (MonadRerunnableIO, rerunnableIO) +import Database.Persist.Monad +import Database.Persist.Monad.Internal.PersistentShim (SafeToInsert) +import Example +import TestUtils.DB (BackendType (..), allBackendTypes) +import TestUtils.Esqueleto (esqueletoSelect) + +test_batch = + [ testGroup + (show backendType) + [ testWithTransaction backendType + , testCatchTransaction backendType + , testComposability backendType + , testPersistentAPI backendType + , testInterop backendType + ] + | backendType <- allBackendTypes + ] + +testWithTransaction :: BackendType -> TestTree +testWithTransaction backendType = + testGroup + "withTransaction" + [ testCase "it uses the same transaction" $ do + -- without transactions, the INSERT shouldn't be rolled back + runTestApp backendType $ do + catchTestError $ insertAndFail $ person "Alice" + result <- getPeopleNames + liftIO $ result @?= ["Alice"] + + -- with transactions, the INSERT should be rolled back + runTestApp backendType $ do + catchTestError $ withTransaction $ insertAndFail $ person "Alice" + result <- getPeopleNames + liftIO $ result @?= [] + , testCase "retries transactions" $ do + let retryIf e = case fromException e of + Just (StringException "retry me" _) -> True + _ -> False + setRetry env = env{retryIf, retryLimit = 5} + + counter <- newIORef (0 :: Int) + + result <- try @_ @SomeException $ + runTestAppWith backendType setRetry $ + withTransaction $ + rerunnableIO $ do + x <- atomicModifyIORef counter $ \x -> (x + 1, x) + if x > 2 + then return () + else throwString "retry me" + + case result of + Right () -> return () + Left e -> error $ "Got unexpected error: " ++ show e + , testCase "throws error when retry hits limit" $ do + let setRetry env = env{retryIf = const True, retryLimit = 2} + + result <- + try @_ @TransactionError @() $ + runTestAppWith backendType setRetry $ + withTransaction $ + rerunnableIO $ + throwString "retry me" + + result @?= Left RetryLimitExceeded + , testCase "Runs retryCallback" $ do + callbackRef <- newIORef Nothing + + let setRetry env = + env + { retryIf = const True + , retryLimit = 2 + , retryCallback = writeIORef callbackRef . Just + } + _ <- + try @_ @TransactionError @() $ + runTestAppWith backendType setRetry . withTransaction $ + rerunnableIO (throwIO TestError) + + mError <- readIORef callbackRef + case mError >>= fromException of + Just TestError -> return () + _ -> assertFailure $ "Unexpected result: " ++ show mError + ] + +testCatchTransaction :: BackendType -> TestTree +testCatchTransaction backendType = + testGroup + "catchSqlTransaction" + [ testCase "catches errors" $ do + wasCaughtRef <- newIORef False + runTestApp backendType . withTransaction $ + (`catchSqlTransaction` markCaught wasCaughtRef) $ + rerunnableIO (throwString "error") + wasCaught <- readIORef wasCaughtRef + wasCaught @?= True + , testCase "does not catch retry errors" $ do + let retryIf e = case fromException e of + Just (StringException "retry me" _) -> True + _ -> False + setRetry env = env{retryIf, retryLimit = 2} + + wasCaughtRef <- newIORef False + _ <- + try @_ @SomeException $ + runTestAppWith backendType setRetry . withTransaction $ + (`catchSqlTransaction` markCaught wasCaughtRef) $ + rerunnableIO (throwString "retry me") + wasCaught <- readIORef wasCaughtRef + wasCaught @?= False + ] + where + markCaught wasCaughtRef (_ :: SomeException) = + rerunnableIO $ writeIORef wasCaughtRef True + +-- this should compile +testComposability :: BackendType -> TestTree +testComposability backendType = testCase "Operations can be composed" $ do + let onlySql :: MonadSqlQuery m => m () + onlySql = do + _ <- getPeople + return () + + sqlAndRerunnableIO :: (MonadSqlQuery m, MonadRerunnableIO m) => m () + sqlAndRerunnableIO = do + _ <- getPeopleNames + _ <- rerunnableIO $ newIORef True + return () + + onlyRerunnableIO :: MonadRerunnableIO m => m () + onlyRerunnableIO = do + _ <- rerunnableIO $ newIORef True + return () + + arbitraryIO :: MonadIO m => m () + arbitraryIO = do + _ <- liftIO $ newIORef True + return () + + -- everything should compose naturally by default + runTestApp backendType $ do + onlySql + sqlAndRerunnableIO + onlyRerunnableIO + arbitraryIO + + -- in a transaction, you can compose everything except arbitrary IO + runTestApp backendType $ withTransaction $ do + onlySql + sqlAndRerunnableIO + onlyRerunnableIO + +-- uncomment this to get compile error +-- arbitraryIO + +testPersistentAPI :: BackendType -> TestTree +testPersistentAPI backendType = + testGroup + "Persistent API" + [ testCase "get" $ do + result <- runTestApp backendType $ do + insert_ $ person "Alice" + mapM get [1, 2] + map (fmap personName) result @?= [Just "Alice", Nothing] + , testCase "getMany" $ do + result <- runTestApp backendType $ do + insert_ $ person "Alice" + getMany [1] + personName <$> Map.lookup 1 result @?= Just "Alice" + , testCase "getJust" $ do + result <- runTestApp backendType $ do + insert_ $ person "Alice" + getJust 1 + personName result @?= "Alice" + , testCase "getJustEntity" $ do + result <- runTestApp backendType $ do + insert_ $ person "Alice" + getJustEntity 1 + getName result @?= "Alice" + , testCase "getEntity" $ do + result <- runTestApp backendType $ do + insert_ $ person "Alice" + mapM getEntity [1, 2] + map (fmap getName) result @?= [Just "Alice", Nothing] + , testCase "belongsTo" $ do + result <- runTestApp backendType $ do + aliceKey <- insert $ person "Alice" + let post1 = Post "Post #1" aliceKey (Just aliceKey) + post2 = Post "Post #2" aliceKey Nothing + insertMany_ [post1, post2] + mapM (belongsTo postEditor) [post1, post2] + map (fmap personName) result @?= [Just "Alice", Nothing] + , testCase "belongsToJust" $ do + result <- runTestApp backendType $ do + aliceKey <- insert $ person "Alice" + let post1 = Post "Post #1" aliceKey Nothing + insert_ post1 + belongsToJust postAuthor post1 + personName result @?= "Alice" + , testCase "insert" $ do + result <- runTestApp backendType $ do + aliceKey <- insert $ person "Alice" + people <- getPeopleNames + return (aliceKey, people) + result @?= (1, ["Alice"]) + , testCase "insert_" $ do + result <- runTestApp backendType $ do + result <- insert_ $ person "Alice" + people <- getPeopleNames + return (result, people) + result @?= ((), ["Alice"]) + , testCase "insertMany" $ do + result <- runTestApp backendType $ do + keys <- insertMany [person "Alice", person "Bob"] + people <- getPeopleNames + return (keys, people) + result @?= ([1, 2], ["Alice", "Bob"]) + , testCase "insertMany_" $ do + result <- runTestApp backendType $ do + result <- insertMany_ [person "Alice", person "Bob"] + people <- getPeopleNames + return (result, people) + result @?= ((), ["Alice", "Bob"]) + , testCase "insertEntityMany" $ do + result <- runTestApp backendType $ do + result <- + insertEntityMany + [ Entity 1 $ person "Alice" + , Entity 2 $ person "Bob" + ] + people <- getPeopleNames + return (result, people) + result @?= ((), ["Alice", "Bob"]) + , testCase "insertKey" $ do + result <- runTestApp backendType $ do + result <- insertKey 1 $ person "Alice" + people <- getPeopleNames + return (result, people) + result @?= ((), ["Alice"]) + , testCase "repsert" $ do + result <- runTestApp backendType $ do + let alice = person "Alice" + insert_ alice + repsert 1 $ alice{personAge = 100} + repsert 2 $ person "Bob" + getPeople + map nameAndAge result + @?= [ ("Alice", 100) + , ("Bob", 0) + ] + , testCase "repsertMany" $ do + result <- runTestApp backendType $ do + let alice = person "Alice" + -- https://github.com/yesodweb/persistent/issues/832 + insert_ alice + repsertMany + [ (1, alice{personAge = 100}) + , (2, person "Bob") + ] + getPeople + map nameAndAge result + @?= [ ("Alice", 100) + , ("Bob", 0) + ] + , testCase "replace" $ do + result <- runTestApp backendType $ do + let alice = person "Alice" + insert_ alice + replace 1 $ alice{personAge = 100} + getJust 1 + personAge result @?= 100 + , testCase "delete" $ do + result <- runTestApp backendType $ do + aliceKey <- insert $ person "Alice" + delete aliceKey + getPeople + result @?= [] + , testCase "update" $ do + result <- runTestApp backendType $ do + key <- insert $ person "Alice" + update key [PersonName =. "Alicia"] + getPeopleNames + result @?= ["Alicia"] + , testCase "updateGet" $ do + (updateResult, getResult) <- runTestApp backendType $ do + key <- insert $ person "Alice" + updateResult <- updateGet key [PersonName =. "Alicia"] + getResult <- getJust key + return (updateResult, getResult) + updateResult @?= getResult + , testCase "insertEntity" $ do + (insertResult, getResult) <- runTestApp backendType $ do + insertResult <- insertEntity $ person "Alice" + getResult <- getJust $ entityKey insertResult + return (insertResult, getResult) + entityVal insertResult @?= getResult + , testCase "insertRecord" $ do + (insertResult, getResult) <- runTestApp backendType $ do + insertResult <- insertRecord $ person "Alice" + getResult <- getJust 1 + return (insertResult, getResult) + insertResult @?= getResult + , testCase "getBy" $ do + result <- runTestApp backendType $ do + insert_ $ person "Alice" + mapM getBy [UniqueName "Alice", UniqueName "Bob"] + map (fmap getName) result @?= [Just "Alice", Nothing] + , testCase "getByValue" $ do + result <- runTestApp backendType $ do + let alice = person "Alice" + insert_ alice + mapM getByValue [alice, person "Bob"] + map (fmap getName) result @?= [Just "Alice", Nothing] + , testCase "checkUnique" $ do + result <- runTestApp backendType $ do + let alice = person "Alice" + insert_ alice + mapM + checkUnique + [ alice + , person "Bob" + , (person "Alice"){personAge = 100} + ] + result @?= [Just (UniqueName "Alice"), Nothing, Just (UniqueName "Alice")] + , testCase "checkUniqueUpdateable" $ do + result <- runTestApp backendType $ do + let alice = person "Alice" + insert_ alice + mapM + checkUniqueUpdateable + [ Entity 1 alice + , Entity 2 $ person "Bob" + , Entity 3 $ (person "Alice"){personAge = 100} + ] + result @?= [Nothing, Nothing, Just (UniqueName "Alice")] + , testCase "deleteBy" $ do + result <- runTestApp backendType $ do + insert_ $ person "Alice" + deleteBy $ UniqueName "Alice" + getPeople + result @?= [] + , testCase "insertUnique" $ do + (result1, result2, people) <- runTestApp backendType $ do + result1 <- insertUnique $ person "Alice" + result2 <- insertUnique $ person "Alice" + people <- getPeopleNames + return (result1, result2, people) + result1 @?= Just 1 + result2 @?= Nothing + people @?= ["Alice"] + , testCase "upsert" $ do + (result1, result2, people) <- runTestApp backendType $ do + result1 <- upsert (person "Alice") [PersonAge =. 0] + result2 <- upsert (person "Alice") [PersonAge =. 100] + people <- getPeople + return (result1, result2, people) + entityKey result1 @?= entityKey result2 + nameAndAge (entityVal result1) @?= ("Alice", 0) + nameAndAge (entityVal result2) @?= ("Alice", 100) + map nameAndAge people @?= [("Alice", 100)] + , testCase "upsertBy" $ do + (result1, result2, people) <- runTestApp backendType $ do + result1 <- upsertBy (UniqueName "Alice") (person "Alice") [PersonAge =. 0] + result2 <- upsertBy (UniqueName "Alice") (person "Alice") [PersonAge =. 100] + people <- getPeople + return (result1, result2, people) + entityKey result1 @?= entityKey result2 + nameAndAge (entityVal result1) @?= ("Alice", 0) + nameAndAge (entityVal result2) @?= ("Alice", 100) + map nameAndAge people @?= [("Alice", 100)] + , testCase "putMany" $ do + result <- runTestApp backendType $ do + let alice = person "Alice" + insert_ alice + putMany + [ alice{personAge = 100} + , person "Bob" + ] + getPeople + map nameAndAge result + @?= [ ("Alice", 100) + , ("Bob", 0) + ] + , testCase "insertBy" $ do + (result1, result2, people) <- runTestApp backendType $ do + let alice = person "Alice" + result1 <- insertBy alice + result2 <- insertBy $ alice{personAge = 100} + people <- getPeople + return (result1, result2, people) + result1 @?= Right 1 + first (entityKey &&& getName) result2 @?= Left (1, "Alice") + map nameAndAge people @?= [("Alice", 0)] + , testCase "insertUniqueEntity" $ do + (result1, result2, people) <- runTestApp backendType $ do + let alice = person "Alice" + result1 <- insertUniqueEntity alice + result2 <- insertUniqueEntity $ alice{personAge = 100} + people <- getPeople + return (result1, result2, people) + (entityKey &&& getName) <$> result1 @?= Just (1, "Alice") + result2 @?= Nothing + map nameAndAge people @?= [("Alice", 0)] + , testCase "replaceUnique" $ do + (result1, result2, people) <- runTestApp backendType $ do + let alice = person "Alice" + bob = person "Bob" + insertMany_ [alice, bob] + result1 <- replaceUnique 1 $ alice{personName = "Bob"} + result2 <- replaceUnique 2 $ bob{personAge = 100} + people <- getPeople + return (result1, result2, people) + result1 @?= Just (UniqueName "Bob") + result2 @?= Nothing + map nameAndAge people @?= [("Alice", 0), ("Bob", 100)] + , testCase "onlyUnique" $ do + result <- runTestApp backendType $ onlyUnique $ person "Alice" + result @?= UniqueName "Alice" + , testCase "selectSourceRes" $ do + result <- runTestApp backendType $ do + insertMany_ [person "Alice", person "Bob"] + acquire <- selectSourceRes [] [] + Acquire.with acquire $ \conduit -> + runConduit $ conduit .| Conduit.mapC getName .| Conduit.sinkList + result @?= ["Alice", "Bob"] + , testCase "selectFirst" $ do + result <- runTestApp backendType $ do + insert_ $ person "Alice" + sequence + [ selectFirst [PersonName ==. "Alice"] [] + , selectFirst [PersonName ==. "Bob"] [] + ] + map (fmap getName) result @?= [Just "Alice", Nothing] + , testCase "selectKeysRes" $ do + result <- runTestApp backendType $ do + insertMany_ [person "Alice", person "Bob"] + acquire <- selectKeysRes @_ @Person [] [] + Acquire.with acquire $ \conduit -> + runConduit $ conduit .| Conduit.sinkList + result @?= [1, 2] + , testCase "count" $ do + result <- runTestApp backendType $ do + insertMany_ $ map (\p -> p{personAge = 100}) [person "Alice", person "Bob"] + count [PersonAge ==. 100] + result @?= 2 + , testCase "exists" $ do + result <- runTestApp backendType $ do + insertMany_ [person "Alice", person "Bob"] + exists [PersonName ==. "Alice"] + result @?= True + , testCase "selectSource" $ do + result <- runTestApp backendType $ do + insertMany_ [person "Alice", person "Bob"] + runConduit $ selectSource [] [] .| Conduit.mapC getName .| Conduit.sinkList + result @?= ["Alice", "Bob"] + , testCase "selectKeys" $ do + result <- runTestApp backendType $ do + insertMany_ [person "Alice", person "Bob"] + runConduit $ selectKeys @Person [] [] .| Conduit.sinkList + result @?= [1, 2] + , testCase "selectList" $ do + result <- runTestApp backendType $ do + insert_ $ person "Alice" + insert_ $ person "Bob" + selectList [] [] + map getName result @?= ["Alice", "Bob"] + , testCase "selectKeysList" $ do + result <- runTestApp backendType $ do + insert_ $ person "Alice" + insert_ $ person "Bob" + selectKeysList @Person [] [] + result @?= [1, 2] + , testCase "updateWhere" $ do + result <- runTestApp backendType $ do + insertMany_ [person "Alice", person "Bob"] + updateWhere [PersonName ==. "Alice"] [PersonAge =. 100] + getPeople + map nameAndAge result @?= [("Alice", 100), ("Bob", 0)] + , testCase "deleteWhere" $ do + result <- runTestApp backendType $ do + insertMany_ [person "Alice", person "Bob"] + deleteWhere [PersonName ==. "Alice"] + getPeopleNames + result @?= ["Bob"] + , testCase "updateWhereCount" $ do + (rowsUpdated, people) <- runTestApp backendType $ do + insertMany_ [person "Alice", person "Bob"] + rowsUpdated <- updateWhereCount [PersonName ==. "Alice"] [PersonAge =. 100] + people <- getPeople + return (rowsUpdated, people) + rowsUpdated @?= 1 + map nameAndAge people @?= [("Alice", 100), ("Bob", 0)] + , testCase "deleteWhereCount" $ do + (rowsDeleted, names) <- runTestApp backendType $ do + insertMany_ [person "Alice", person "Bob"] + rowsDeleted <- deleteWhereCount [PersonName ==. "Alice"] + names <- getPeopleNames + return (rowsDeleted, names) + rowsDeleted @?= 1 + names @?= ["Bob"] + , testCase "parseMigration" $ do + result <- runTestApp backendType $ do + setupUnsafeMigration + parseMigration migration + + let sql = case backendType of + Sqlite -> + [ eq + ( False + , Text.concat + [ "CREATE TEMP TABLE \"person_backup\"(" + , "\"id\" INTEGER PRIMARY KEY," + , "\"name\" VARCHAR NOT NULL," + , "\"age\" INTEGER NOT NULL," + , "CONSTRAINT \"unique_name\" UNIQUE (\"name\"))" + ] + ) + , anything + , eq (True, "DROP TABLE \"person\"") + , anything + , anything + , eq (False, "DROP TABLE \"person_backup\"") + ] + Postgresql -> + [ eq (True, "ALTER TABLE \"person\" DROP COLUMN \"foo\"") + ] + + result @?~ right (elemsAre sql) + , testCase "parseMigration'" $ do + let action :: (Migration -> TestApp a) -> IO a + action f = runTestApp backendType $ do + setupUnsafeMigration + f migration + + result <- action parseMigration + result' <- action parseMigration' + Right result' @?= result + , testCase "printMigration" $ + runTestApp backendType $ do + setupUnsafeMigration + printMigration migration + , testCase "showMigration" $ do + result <- runTestApp backendType $ do + setupUnsafeMigration + showMigration migration + + let sql = case backendType of + Sqlite -> + [ eq $ + Text.concat + [ "CREATE TEMP TABLE \"person_backup\"(" + , "\"id\" INTEGER PRIMARY KEY," + , "\"name\" VARCHAR NOT NULL," + , "\"age\" INTEGER NOT NULL," + , "CONSTRAINT \"unique_name\" UNIQUE (\"name\"));" + ] + , anything + , eq "DROP TABLE \"person\";" + , anything + , anything + , eq "DROP TABLE \"person_backup\";" + ] + Postgresql -> + [ eq "ALTER TABLE \"person\" DROP COLUMN \"foo\";" + ] + + result @?~ elemsAre sql + , testCase "getMigration" $ do + result <- runTestApp backendType $ do + setupUnsafeMigration + getMigration migration + + let sql = case backendType of + Sqlite -> + [ eq $ + Text.concat + [ "CREATE TEMP TABLE \"person_backup\"(" + , "\"id\" INTEGER PRIMARY KEY," + , "\"name\" VARCHAR NOT NULL," + , "\"age\" INTEGER NOT NULL," + , "CONSTRAINT \"unique_name\" UNIQUE (\"name\"))" + ] + , anything + , eq "DROP TABLE \"person\"" + , anything + , anything + , eq "DROP TABLE \"person_backup\"" + ] + Postgresql -> + [ eq "ALTER TABLE \"person\" DROP COLUMN \"foo\"" + ] + + result @?~ elemsAre sql + , testCase "runMigration" $ do + result <- runTestApp backendType $ do + setupSafeMigration + runMigration migration + getSchemaColumnNames backendType "person" + assertNotIn "removed_column" result + , testCase "runMigrationQuiet" $ do + (withQuiet, cols) <- runTestApp backendType $ do + setupSafeMigration + sql <- runMigrationQuiet migration + cols <- getSchemaColumnNames backendType "person" + return (sql, cols) + withSilent <- runTestApp backendType $ do + setupSafeMigration + runMigrationSilent migration + assertNotIn "removed_column" cols + withQuiet @?= withSilent + , testCase "runMigrationSilent" $ do + (sqlPlanned, sqlExecuted, cols) <- runTestApp backendType $ do + setupSafeMigration + sqlPlanned <- getMigration migration + sqlExecuted <- runMigrationSilent migration + cols <- getSchemaColumnNames backendType "person" + return (sqlPlanned, sqlExecuted, cols) + assertNotIn "removed_column" cols + sqlExecuted @?= sqlPlanned + , testCase "runMigrationUnsafe" $ do + result <- runTestApp backendType $ do + setupUnsafeMigration + runMigrationUnsafe migration + getSchemaColumnNames backendType "person" + assertNotIn "removed_column" result + , testCase "runMigrationUnsafeQuiet" $ do + (sqlPlanned, sqlExecuted, cols) <- runTestApp backendType $ do + setupUnsafeMigration + sqlPlanned <- getMigration migration + sqlExecuted <- runMigrationUnsafeQuiet migration + cols <- getSchemaColumnNames backendType "person" + return (sqlPlanned, sqlExecuted, cols) + assertNotIn "removed_column" cols + sqlExecuted @?= sqlPlanned + , testCase "getFieldName" $ do + result <- + runTestApp backendType $ + getFieldName PersonName + result @?= "\"name\"" + , testCase "getTableName" $ do + result <- + runTestApp backendType $ + getTableName $ + person "Alice" + result @?= "\"person\"" + , testCase "withRawQuery" $ do + result <- runTestApp backendType $ do + insertMany_ [person "Alice", person "Bob"] + withRawQuery "SELECT name FROM person" [] $ + Conduit.mapC (fromPersistValue' @Text . head) .| Conduit.sinkList + + result @?= ["Alice", "Bob"] + , testCase "rawQueryRes" $ do + result <- runTestApp backendType $ do + insertMany_ [person "Alice", person "Bob"] + acquire <- rawQueryRes "SELECT name FROM person" [] + Acquire.with acquire $ \conduit -> + runConduit $ conduit .| Conduit.mapC (fromPersistValue' @Text . head) .| Conduit.sinkList + result @?= ["Alice", "Bob"] + , testCase "rawQuery" $ do + result <- runTestApp backendType $ do + insertMany_ [person "Alice", person "Bob"] + runConduit $ rawQuery "SELECT name FROM person" [] .| Conduit.mapC (fromPersistValue' @Text . head) .| Conduit.sinkList + result @?= ["Alice", "Bob"] + , testCase "rawExecute" $ do + result <- runTestApp backendType $ do + insertMany_ [person "Alice", person "Bob"] + rawExecute "UPDATE person SET age = 100 WHERE name = 'Alice'" [] + getPeople + map nameAndAge result @?= [("Alice", 100), ("Bob", 0)] + , testCase "rawExecuteCount" $ do + (rowsUpdated, people) <- runTestApp backendType $ do + insertMany_ [person "Alice", person "Bob"] + rowsUpdated <- rawExecuteCount "UPDATE person SET age = 100 WHERE name = 'Alice'" [] + people <- getPeople + return (rowsUpdated, people) + rowsUpdated @?= 1 + map nameAndAge people @?= [("Alice", 100), ("Bob", 0)] + , testCase "rawSql" $ do + result <- runTestApp backendType $ do + insertMany_ [person "Alice", person "Bob"] + rawSql @(Single String) "SELECT name FROM person" [] + map unSingle result @?= ["Alice", "Bob"] + , testCase "transactionSave" $ do + result1 <- runTestApp backendType $ do + catchTestError $ withTransaction $ do + insert_ $ person "Alice" + insertAndFail $ person "Bob" + getPeopleNames + result1 @?= [] + + result2 <- runTestApp backendType $ do + catchTestError $ withTransaction $ do + insert_ $ person "Alice" + transactionSave + insertAndFail $ person "Bob" + getPeopleNames + result2 @?= ["Alice"] + , testCase "transactionSaveWithIsolation" $ do + result1 <- runTestApp backendType $ do + catchTestError $ withTransaction $ do + insert_ $ person "Alice" + insertAndFail $ person "Bob" + getPeopleNames + result1 @?= [] + + result2 <- runTestApp backendType $ do + catchTestError $ withTransaction $ do + insert_ $ person "Alice" + transactionSaveWithIsolation Serializable + insertAndFail $ person "Bob" + getPeopleNames + result2 @?= ["Alice"] + , testCase "transactionUndo" $ do + result <- runTestApp backendType $ withTransaction $ do + insert_ $ person "Alice" + transactionUndo + getPeopleNames + result @?= [] + , testCase "transactionUndoWithIsolation" $ do + result <- runTestApp backendType $ withTransaction $ do + insert_ $ person "Alice" + transactionUndoWithIsolation Serializable + getPeopleNames + result @?= [] + ] + +testInterop :: BackendType -> TestTree +testInterop backendType = + testGroup + "Interop with third-party Persistent libraries" + [ testCase "unsafeLiftSql" $ do + let alice = person "Alice" + result <- runTestApp backendType $ do + insert_ alice + esqueletoSelect $ + E.from $ + E.table @Person + result @?= [Entity 1 alice] + ] + +{- Persistent helpers -} + +fromPersistValue' :: PersistField a => PersistValue -> a +fromPersistValue' = either (error . Text.unpack) id . fromPersistValue + +{- Meta SQL helpers -} + +-- | Put the database in a state where running a migration is safe. +setupSafeMigration :: MonadSqlQuery m => m () +setupSafeMigration = rawExecute "ALTER TABLE person ADD COLUMN removed_column VARCHAR" [] + +-- | Put the database in a state where running a migration is unsafe. +setupUnsafeMigration :: MonadSqlQuery m => m () +setupUnsafeMigration = rawExecute "ALTER TABLE person ADD COLUMN foo VARCHAR" [] + +-- | Get the names of all columns in the given table. +getSchemaColumnNames :: MonadSqlQuery m => BackendType -> String -> m [String] +getSchemaColumnNames backendType tableName = map unSingle <$> rawSql sql [] + where + sql = Text.pack $ case backendType of + Sqlite -> "SELECT name FROM pragma_table_info('" ++ tableName ++ "')" + Postgresql -> + unlines + [ "SELECT column_name FROM information_schema.columns" + , "WHERE table_schema = 'public' AND table_name = '" ++ tableName ++ "'" + ] + +{- Test helpers -} + +data TestError = TestError + deriving (Show, Eq) + +instance Exception TestError + +catchTestError :: (MonadUnliftIO m, Eq a, Show a) => m a -> m () +catchTestError m = do + result <- try m + liftIO $ result @?= Left TestError + +insertAndFail :: + ( MonadRerunnableIO m + , MonadSqlQuery m + , PersistRecordBackend record SqlBackend + , Typeable record + , SafeToInsert record + ) => + record -> + m () +insertAndFail record = do + insert_ record + rerunnableIO $ throwIO TestError + +assertNotIn :: (Eq a, Show a) => a -> [a] -> Assertion +assertNotIn a as = as @?= filter (/= a) as diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -1,19 +1,4 @@ -import Test.Tasty - -import qualified Basic -import qualified Integration -import qualified MockSqlQueryT -import qualified Mocked -import qualified SqlQueryRepTest - -main :: IO () -main = defaultMain tests - -tests :: TestTree -tests = testGroup "persistent-mtl" - [ Basic.tests - , Mocked.tests - , Integration.tests - , MockSqlQueryT.tests - , SqlQueryRepTest.tests - ] +{- AUTOCOLLECT.MAIN +suite_name = persistent-mtl +strip_suffix = Test +-} diff --git a/test/MockSqlQueryT.hs b/test/MockSqlQueryT.hs deleted file mode 100644 --- a/test/MockSqlQueryT.hs +++ /dev/null @@ -1,38 +0,0 @@ -{-# LANGUAGE GADTs #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE TypeApplications #-} - -module MockSqlQueryT where - -import Database.Persist (Entity(..)) -import Database.Persist.Sql (toSqlKey) -import Test.Tasty -import Test.Tasty.HUnit -import UnliftIO (SomeException, try) - -import Database.Persist.Monad.TestUtils -import Example - -tests :: TestTree -tests = testGroup "MockSqlQueryT" - [ testCase "it errors if it could not find a mock" $ do - result <- try $ runMockSqlQueryT getPeopleNames [] - case result of - Right _ -> assertFailure "runMockSqlQueryT did not fail" - Left e -> do - let msg = head $ lines $ show (e :: SomeException) - msg @?= "Could not find mock for query: SelectList{..}" - , testCase "it continues after a mock doesn't match" $ do - result <- runMockSqlQueryT getPeopleNames - [ withRecord @Post $ \_ -> error "getPeopleNames matched Post record" - , mockQuery $ \_ -> Nothing - , withRecord @Person $ \case - SelectList _ _ -> Just - [ Entity (toSqlKey 1) (Person "Alice" 10) - , Entity (toSqlKey 2) (Person "Bob" 20) - ] - _ -> Nothing - ] - - result @?= ["Alice", "Bob"] - ] diff --git a/test/Mocked.hs b/test/Mocked.hs deleted file mode 100644 --- a/test/Mocked.hs +++ /dev/null @@ -1,548 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeApplications #-} - -module Mocked where - -import Conduit (runConduit, runResourceT, (.|)) -import qualified Conduit -import qualified Data.Acquire as Acquire -import qualified Data.Map.Strict as Map -import Database.Persist.Sql - (Entity(..), Single(..), toPersistValue, (=.), (==.)) -import Test.Tasty -import Test.Tasty.HUnit - -import Database.Persist.Monad -import Database.Persist.Monad.TestUtils -import Example - -tests :: TestTree -tests = testGroup "Mocked tests" - [ testWithTransaction - , testPersistentAPI - ] - -testWithTransaction :: TestTree -testWithTransaction = testGroup "withTransaction" - [ testCase "it doesn't error with MockSqlQueryT" $ - runMockSqlQueryT (withTransaction $ insert_ $ person "Alice") - [ withRecord @Person $ \case - Insert_ _ -> Just () - _ -> Nothing - ] - ] - -testPersistentAPI :: TestTree -testPersistentAPI = testGroup "Persistent API" - [ testCase "get" $ do - result <- runMockSqlQueryT (mapM get [1, 2]) - [ withRecord @Person $ \case - Get n - | n == 1 -> Just $ Just $ person "Alice" - | n == 2 -> Just Nothing - _ -> Nothing - ] - map (fmap personName) result @?= [Just "Alice", Nothing] - - , testCase "getMany" $ do - result <- runMockSqlQueryT (getMany [1]) - [ withRecord @Person $ \case - GetMany _ -> Just $ Map.fromList [(1, person "Alice")] - _ -> Nothing - ] - personName <$> Map.lookup 1 result @?= Just "Alice" - - , testCase "getJust" $ do - result <- runMockSqlQueryT (getJust 1) - [ withRecord @Person $ \case - GetJust _ -> Just $ person "Alice" - _ -> Nothing - ] - personName result @?= "Alice" - - , testCase "getJustEntity" $ do - result <- runMockSqlQueryT (getJustEntity 1) - [ withRecord @Person $ \case - GetJustEntity _ -> Just $ Entity 1 $ person "Alice" - _ -> Nothing - ] - getName result @?= "Alice" - - , testCase "getEntity" $ do - result <- runMockSqlQueryT (mapM getEntity [1, 2]) - [ withRecord @Person $ \case - GetEntity n - | n == 1 -> Just $ Just $ Entity 1 $ person "Alice" - | n == 2 -> Just Nothing - _ -> Nothing - ] - map (fmap getName) result @?= [Just "Alice", Nothing] - - , testCase "belongsTo" $ do - let post1 = Post "Post #1" 1 (Just 1) - post2 = Post "Post #2" 1 Nothing - result <- runMockSqlQueryT (mapM (belongsTo postEditor) [post1, post2]) - [ withRecord @(Post, Person) $ \case - BelongsTo _ Post{postEditor = Just 1} -> Just $ Just $ person "Alice" - BelongsTo _ Post{postEditor = Nothing} -> Just Nothing - _ -> Nothing - ] - map (fmap personName) result @?= [Just "Alice", Nothing] - - , testCase "belongsToJust" $ do - let post1 = Post "Post #1" 1 Nothing - result <- runMockSqlQueryT (belongsToJust postAuthor post1) - [ withRecord @(Post, Person) $ \case - BelongsToJust _ _ -> Just $ person "Alice" - _ -> Nothing - ] - personName result @?= "Alice" - - , testCase "insert" $ do - result <- runMockSqlQueryT (insert $ person "Alice") - [ withRecord @Person $ \case - Insert _ -> Just 1 - _ -> Nothing - ] - result @?= 1 - - , testCase "insert_" $ do - result <- runMockSqlQueryT (insert_ $ person "Alice") - [ withRecord @Person $ \case - Insert_ _ -> Just () - _ -> Nothing - ] - result @?= () - - , testCase "insertMany" $ do - result <- runMockSqlQueryT (insertMany [person "Alice", person "Bob"]) - [ withRecord @Person $ \case - InsertMany records -> Just $ map fromIntegral [ 1 .. length records ] - _ -> Nothing - ] - result @?= [1, 2] - - , testCase "insertMany_" $ do - result <- runMockSqlQueryT (insertMany_ [person "Alice", person "Bob"]) - [ withRecord @Person $ \case - InsertMany_ _ -> Just () - _ -> Nothing - ] - result @?= () - - , testCase "insertEntityMany" $ do - result <- runMockSqlQueryT (insertEntityMany [Entity 1 $ person "Alice"]) - [ withRecord @Person $ \case - InsertEntityMany _ -> Just () - _ -> Nothing - ] - result @?= () - - , testCase "insertKey" $ do - result <- runMockSqlQueryT (insertKey 1 $ person "Alice") - [ withRecord @Person $ \case - InsertKey _ _ -> Just () - _ -> Nothing - ] - result @?= () - - , testCase "repsert" $ do - result <- runMockSqlQueryT (repsert 1 $ person "Alice") - [ withRecord @Person $ \case - Repsert _ _ -> Just () - _ -> Nothing - ] - result @?= () - - , testCase "repsertMany" $ do - result <- runMockSqlQueryT (repsertMany [(1, person "Alice")]) - [ withRecord @Person $ \case - RepsertMany _ -> Just () - _ -> Nothing - ] - result @?= () - - , testCase "replace" $ do - result <- runMockSqlQueryT (replace 1 $ person "Alice") - [ withRecord @Person $ \case - Replace _ _ -> Just () - _ -> Nothing - ] - result @?= () - - , testCase "delete" $ do - result <- runMockSqlQueryT (delete @Person 1) - [ withRecord @Person $ \case - Delete _ -> Just () - _ -> Nothing - ] - result @?= () - - , testCase "update" $ do - result <- runMockSqlQueryT (update 1 [PersonName =. "Alicia"]) - [ withRecord @Person $ \case - Update _ _ -> Just () - _ -> Nothing - ] - result @?= () - - , testCase "updateGet" $ do - result <- runMockSqlQueryT (updateGet 1 [PersonName =. "Alicia"]) - [ withRecord @Person $ \case - UpdateGet _ _ -> Just $ person "Alicia" - _ -> Nothing - ] - personName result @?= "Alicia" - - , testCase "insertEntity" $ do - let alice = person "Alice" - result <- runMockSqlQueryT (insertEntity alice) - [ withRecord @Person $ \case - InsertEntity _ -> Just $ Entity 1 alice - _ -> Nothing - ] - entityVal result @?= alice - - , testCase "insertRecord" $ do - let alice = person "Alice" - result <- runMockSqlQueryT (insertRecord alice) - [ withRecord @Person $ \case - InsertRecord _ -> Just alice - _ -> Nothing - ] - result @?= alice - - , testCase "getBy" $ do - result <- runMockSqlQueryT (mapM getBy [UniqueName "Alice", UniqueName "Bob"]) - [ withRecord @Person $ \case - GetBy (UniqueName "Alice") -> Just $ Just $ Entity 1 $ person "Alice" - GetBy (UniqueName "Bob") -> Just Nothing - _ -> Nothing - ] - map (fmap getName) result @?= [Just "Alice", Nothing] - - , testCase "getByValue" $ do - result <- runMockSqlQueryT (mapM getByValue [person "Alice", person "Bob"]) - [ withRecord @Person $ \case - GetByValue Person{personName = "Alice"} -> Just $ Just $ Entity 1 $ person "Alice" - GetByValue Person{personName = "Bob"} -> Just Nothing - _ -> Nothing - ] - map (fmap getName) result @?= [Just "Alice", Nothing] - - , testCase "checkUnique" $ do - result <- runMockSqlQueryT (mapM checkUnique [person "Alice", person "Bob"]) - [ withRecord @Person $ \case - CheckUnique Person{personName = "Alice"} -> Just $ Just $ UniqueName "Alice" - CheckUnique Person{personName = "Bob"} -> Just Nothing - _ -> Nothing - ] - result @?= [Just $ UniqueName "Alice", Nothing] - -#if MIN_VERSION_persistent(2,11,0) - , testCase "checkUniqueUpdateable" $ do - result <- runMockSqlQueryT (mapM checkUniqueUpdateable [Entity 1 $ person "Alice", Entity 2 $ person "Bob"]) - [ withRecord @Person $ \case - CheckUniqueUpdateable (Entity _ Person{personName = "Alice"}) -> Just $ Just $ UniqueName "Alice" - CheckUniqueUpdateable (Entity _ Person{personName = "Bob"}) -> Just Nothing - _ -> Nothing - ] - result @?= [Just $ UniqueName "Alice", Nothing] -#endif - - , testCase "deleteBy" $ do - result <- runMockSqlQueryT (deleteBy $ UniqueName "Alice") - [ withRecord @Person $ \case - DeleteBy _ -> Just () - _ -> Nothing - ] - result @?= () - - , testCase "insertUnique" $ do - result <- runMockSqlQueryT (mapM insertUnique [person "Alice", person "Bob"]) - [ withRecord @Person $ \case - InsertUnique Person{personName = "Alice"} -> Just $ Just 1 - InsertUnique Person{personName = "Bob"} -> Just Nothing - _ -> Nothing - ] - result @?= [Just 1, Nothing] - - , testCase "upsert" $ do - let alice = person "Alice" - result <- runMockSqlQueryT (upsert alice [PersonAge =. 100]) - [ withRecord @Person $ \case - Upsert _ _ -> Just $ Entity 1 alice - _ -> Nothing - ] - result @?= Entity 1 alice - - , testCase "upsertBy" $ do - let alice = person "Alice" - result <- runMockSqlQueryT (upsertBy (UniqueName "Alice") alice [PersonAge =. 100]) - [ withRecord @Person $ \case - UpsertBy _ _ _ -> Just $ Entity 1 alice - _ -> Nothing - ] - result @?= Entity 1 alice - - , testCase "putMany" $ do - result <- runMockSqlQueryT (putMany [person "Alice"]) - [ withRecord @Person $ \case - PutMany _ -> Just () - _ -> Nothing - ] - result @?= () - - , testCase "insertBy" $ do - let alice = person "Alice" - result <- runMockSqlQueryT (mapM insertBy [alice, person "Bob"]) - [ withRecord @Person $ \case - InsertBy Person{personName = "Alice"} -> Just $ Left $ Entity 1 alice - InsertBy Person{personName = "Bob"} -> Just $ Right 2 - _ -> Nothing - ] - result @?= [Left $ Entity 1 alice, Right 2] - - , testCase "insertUniqueEntity" $ do - let bob = person "Bob" - result <- runMockSqlQueryT (mapM insertUniqueEntity [person "Alice", bob]) - [ withRecord @Person $ \case - InsertUniqueEntity Person{personName = "Alice"} -> Just Nothing - InsertUniqueEntity Person{personName = "Bob"} -> Just $ Just $ Entity 1 bob - _ -> Nothing - ] - result @?= [Nothing, Just $ Entity 1 bob] - - , testCase "replaceUnique" $ do - result <- runMockSqlQueryT (mapM (uncurry replaceUnique) [(1, person "Alice"), (2, person "Bob")]) - [ withRecord @Person $ \case - ReplaceUnique _ Person{personName = "Alice"} -> Just Nothing - ReplaceUnique _ Person{personName = "Bob"} -> Just $ Just $ UniqueName "Bob" - _ -> Nothing - ] - result @?= [Nothing, Just $ UniqueName "Bob"] - - , testCase "onlyUnique" $ do - result <- runMockSqlQueryT (onlyUnique $ person "Alice") - [ withRecord @Person $ \case - OnlyUnique _ -> Just $ UniqueName "Alice" - _ -> Nothing - ] - result @?= UniqueName "Alice" - - , testCase "selectSourceRes" $ do - acquire <- runMockSqlQueryT (selectSourceRes [] []) - [ mockSelectSource $ \_ _ -> Just - [ Entity 1 $ person "Alice" - , Entity 2 $ person "Bob" - ] - ] - result <- Acquire.with acquire $ \conduit -> - runConduit $ conduit .| Conduit.mapC getName .| Conduit.sinkList - result @?= ["Alice", "Bob"] - - , testCase "selectFirst" $ do - result1 <- runMockSqlQueryT (selectFirst [PersonName ==. "Alice"] []) - [ withRecord @Person $ \case - SelectFirst _ _ -> Just $ Just $ Entity 1 $ person "Alice" - _ -> Nothing - ] - getName <$> result1 @?= Just "Alice" - result2 <- runMockSqlQueryT (selectFirst [PersonName ==. "Alice"] []) - [ withRecord @Person $ \case - SelectFirst _ _ -> Just Nothing - _ -> Nothing - ] - result2 @?= Nothing - - , testCase "selectKeysRes" $ do - let keys = [1, 2, 3] - acquire <- runMockSqlQueryT (selectKeysRes @_ @Person [] []) - [ mockSelectKeys $ \_ _ -> Just keys - ] - result <- Acquire.with acquire $ \conduit -> - runConduit $ conduit .| Conduit.sinkList - result @?= keys - - , testCase "count" $ do - result <- runMockSqlQueryT (count @Person []) - [ withRecord @Person $ \case - Count _ -> Just 10 - _ -> Nothing - ] - result @?= 10 - -#if MIN_VERSION_persistent(2,11,0) - , testCase "exists" $ do - result <- runMockSqlQueryT (exists @Person []) - [ withRecord @Person $ \case - Exists _ -> Just True - _ -> Nothing - ] - result @?= True -#endif - - , testCase "selectSource" $ do - result <- runResourceT $ runMockSqlQueryT - (runConduit $ selectSource [] [] .| Conduit.mapC getName .| Conduit.sinkList) - [ mockSelectSource $ \_ _ -> Just - [ Entity 1 $ person "Alice" - , Entity 2 $ person "Bob" - ] - ] - result @?= ["Alice", "Bob"] - - , testCase "selectKeys" $ do - let keys = [1, 2, 3] - result <- runResourceT $ runMockSqlQueryT - (runConduit $ selectKeys @Person [] [] .| Conduit.sinkList) - [ mockSelectKeys $ \_ _ -> Just keys - ] - result @?= keys - - , testCase "selectList" $ do - result <- runMockSqlQueryT (selectList [] []) - [ withRecord @Person $ \case - SelectList _ _ -> Just - [ Entity 1 (person "Alice") - , Entity 2 (person "Bob") - ] - _ -> Nothing - ] - map getName result @?= ["Alice", "Bob"] - - , testCase "selectKeysList" $ do - let keys = [1, 2, 3] - result <- runMockSqlQueryT (selectKeysList @Person [] []) - [ withRecord @Person $ \case - SelectKeysList _ _ -> Just keys - _ -> Nothing - ] - result @?= keys - - , testCase "updateWhere" $ do - result <- runMockSqlQueryT (updateWhere [] [PersonAge =. 100]) - [ withRecord @Person $ \case - UpdateWhere _ _ -> Just () - _ -> Nothing - ] - result @?= () - - , testCase "deleteWhere" $ do - result <- runMockSqlQueryT (deleteWhere [PersonName ==. "Alice"]) - [ withRecord @Person $ \case - DeleteWhere _ -> Just () - _ -> Nothing - ] - result @?= () - - , testCase "updateWhereCount" $ do - result <- runMockSqlQueryT (updateWhereCount [] [PersonAge =. 100]) - [ withRecord @Person $ \case - UpdateWhereCount _ _ -> Just 10 - _ -> Nothing - ] - result @?= 10 - - , testCase "deleteWhereCount" $ do - result <- runMockSqlQueryT (deleteWhereCount [PersonName ==. "Alice"]) - [ withRecord @Person $ \case - DeleteWhereCount _ -> Just 10 - _ -> Nothing - ] - result @?= 10 - -#if !MIN_VERSION_persistent(2,13,0) - , testCase "deleteCascade" $ do - result <- runMockSqlQueryT (deleteCascade @Person 1) - [ withRecord @Person $ \case - DeleteCascade _ -> Just () - _ -> Nothing - ] - result @?= () - - , testCase "deleteCascadeWhere" $ do - result <- runMockSqlQueryT (deleteCascadeWhere [PersonName ==. "Alice"]) - [ withRecord @Person $ \case - DeleteCascadeWhere _ -> Just () - _ -> Nothing - ] - result @?= () -#endif - - , testCase "getFieldName" $ do - result <- runMockSqlQueryT (getFieldName PersonName) - [ withRecord @Person $ \case - GetFieldName PersonName -> Just "\"name\"" - _ -> Nothing - ] - result @?= "\"name\"" - - , testCase "getTableName" $ do - result <- runMockSqlQueryT (getTableName $ person "Alice") - [ withRecord @Person $ \case - GetTableName _ -> Just "\"person\"" - _ -> Nothing - ] - result @?= "\"person\"" - - , testCase "withRawQuery" $ do - let query = "SELECT name FROM person" - row1 = [toPersistValue @String "Alice"] - row2 = [toPersistValue @String "Bob"] - rows = [row1, row2] - result <- runMockSqlQueryT (withRawQuery query [] Conduit.sinkList) - [ mockWithRawQuery $ \sql _ -> - if sql == query - then Just rows - else Nothing - ] - result @?= rows - - , testCase "rawQueryRes" $ do - let row1 = [toPersistValue @String "Alice"] - row2 = [toPersistValue @String "Bob"] - rows = [row1, row2] - acquire <- runMockSqlQueryT (rawQueryRes "SELECT name FROM person" []) - [ mockRawQuery $ \_ _ -> Just rows - ] - result <- Acquire.with acquire $ \conduit -> - runConduit $ conduit .| Conduit.sinkList - result @?= rows - - , testCase "rawQuery" $ do - let row1 = [toPersistValue @String "Alice"] - row2 = [toPersistValue @String "Bob"] - rows = [row1, row2] - result <- runResourceT $ runMockSqlQueryT - (runConduit $ rawQuery "SELECT name FROM person" [] .| Conduit.sinkList) - [ mockRawQuery $ \_ _ -> Just rows - ] - result @?= rows - - , testCase "rawExecute" $ do - result <- runMockSqlQueryT (rawExecute "DELETE FROM person" []) - [ mockQuery $ \case - RawExecute _ _ -> Just () - _ -> Nothing - ] - result @?= () - - , testCase "rawExecuteCount" $ do - result <- runMockSqlQueryT (rawExecuteCount "DELETE FROM person" []) - [ mockQuery $ \case - RawExecuteCount _ _ -> Just 10 - _ -> Nothing - ] - result @?= 10 - - , testCase "rawSql" $ do - let names = ["Alice", "Bob"] :: [String] - result <- runMockSqlQueryT (rawSql "SELECT name FROM person" []) - [ mockRawSql $ \_ _ -> Just $ map ((:[]) . toPersistValue) names - ] - map unSingle result @?= names - ] diff --git a/test/MockedTest.hs b/test/MockedTest.hs new file mode 100644 --- /dev/null +++ b/test/MockedTest.hs @@ -0,0 +1,621 @@ +{- AUTOCOLLECT.TEST -} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} + +module MockedTest ( + -- $AUTOCOLLECT.TEST.export$ +) where + +import Conduit (runConduit, runResourceT, (.|)) +import qualified Conduit +import qualified Data.Acquire as Acquire +import qualified Data.Map.Strict as Map +import Database.Persist.Sql ( + Entity (..), + Single (..), + toPersistValue, + toSqlKey, + (=.), + (==.), + ) +import Test.Tasty +import Test.Tasty.HUnit +import UnliftIO (SomeException, try) + +import Database.Persist.Monad +import Database.Persist.Monad.TestUtils +import Example + +test = + testGroup + "withTransaction" + [ testCase "it doesn't error with MockSqlQueryT" $ + runMockSqlQueryT + (withTransaction $ insert_ $ person "Alice") + [ withRecord @Person $ \case + Insert_ _ -> Just () + _ -> Nothing + ] + ] + +test = + testGroup + "MockSqlQueryT" + [ testCase "it errors if it could not find a mock" $ do + result <- try $ runMockSqlQueryT getPeopleNames [] + case result of + Right _ -> assertFailure "runMockSqlQueryT did not fail" + Left e -> do + let msg = head $ lines $ show (e :: SomeException) + msg @?= "Could not find mock for query: SelectList{..}" + , testCase "it continues after a mock doesn't match" $ do + result <- + runMockSqlQueryT + getPeopleNames + [ withRecord @Post $ \_ -> error "getPeopleNames matched Post record" + , mockQuery $ \_ -> Nothing + , withRecord @Person $ \case + SelectList _ _ -> + Just + [ Entity (toSqlKey 1) (Person "Alice" 10) + , Entity (toSqlKey 2) (Person "Bob" 20) + ] + _ -> Nothing + ] + + result @?= ["Alice", "Bob"] + ] + +test = + testGroup + "Persistent API" + [ testCase "get" $ do + result <- + runMockSqlQueryT + (mapM get [1, 2]) + [ withRecord @Person $ \case + Get n + | n == 1 -> Just $ Just $ person "Alice" + | n == 2 -> Just Nothing + _ -> Nothing + ] + map (fmap personName) result @?= [Just "Alice", Nothing] + , testCase "getMany" $ do + result <- + runMockSqlQueryT + (getMany [1]) + [ withRecord @Person $ \case + GetMany _ -> Just $ Map.fromList [(1, person "Alice")] + _ -> Nothing + ] + personName <$> Map.lookup 1 result @?= Just "Alice" + , testCase "getJust" $ do + result <- + runMockSqlQueryT + (getJust 1) + [ withRecord @Person $ \case + GetJust _ -> Just $ person "Alice" + _ -> Nothing + ] + personName result @?= "Alice" + , testCase "getJustEntity" $ do + result <- + runMockSqlQueryT + (getJustEntity 1) + [ withRecord @Person $ \case + GetJustEntity _ -> Just $ Entity 1 $ person "Alice" + _ -> Nothing + ] + getName result @?= "Alice" + , testCase "getEntity" $ do + result <- + runMockSqlQueryT + (mapM getEntity [1, 2]) + [ withRecord @Person $ \case + GetEntity n + | n == 1 -> Just $ Just $ Entity 1 $ person "Alice" + | n == 2 -> Just Nothing + _ -> Nothing + ] + map (fmap getName) result @?= [Just "Alice", Nothing] + , testCase "belongsTo" $ do + let post1 = Post "Post #1" 1 (Just 1) + post2 = Post "Post #2" 1 Nothing + result <- + runMockSqlQueryT + (mapM (belongsTo postEditor) [post1, post2]) + [ withRecord @(Post, Person) $ \case + BelongsTo _ Post{postEditor = Just 1} -> Just $ Just $ person "Alice" + BelongsTo _ Post{postEditor = Nothing} -> Just Nothing + _ -> Nothing + ] + map (fmap personName) result @?= [Just "Alice", Nothing] + , testCase "belongsToJust" $ do + let post1 = Post "Post #1" 1 Nothing + result <- + runMockSqlQueryT + (belongsToJust postAuthor post1) + [ withRecord @(Post, Person) $ \case + BelongsToJust _ _ -> Just $ person "Alice" + _ -> Nothing + ] + personName result @?= "Alice" + , testCase "insert" $ do + result <- + runMockSqlQueryT + (insert $ person "Alice") + [ withRecord @Person $ \case + Insert _ -> Just 1 + _ -> Nothing + ] + result @?= 1 + , testCase "insert_" $ do + result <- + runMockSqlQueryT + (insert_ $ person "Alice") + [ withRecord @Person $ \case + Insert_ _ -> Just () + _ -> Nothing + ] + result @?= () + , testCase "insertMany" $ do + result <- + runMockSqlQueryT + (insertMany [person "Alice", person "Bob"]) + [ withRecord @Person $ \case + InsertMany records -> Just $ map fromIntegral [1 .. length records] + _ -> Nothing + ] + result @?= [1, 2] + , testCase "insertMany_" $ do + result <- + runMockSqlQueryT + (insertMany_ [person "Alice", person "Bob"]) + [ withRecord @Person $ \case + InsertMany_ _ -> Just () + _ -> Nothing + ] + result @?= () + , testCase "insertEntityMany" $ do + result <- + runMockSqlQueryT + (insertEntityMany [Entity 1 $ person "Alice"]) + [ withRecord @Person $ \case + InsertEntityMany _ -> Just () + _ -> Nothing + ] + result @?= () + , testCase "insertKey" $ do + result <- + runMockSqlQueryT + (insertKey 1 $ person "Alice") + [ withRecord @Person $ \case + InsertKey _ _ -> Just () + _ -> Nothing + ] + result @?= () + , testCase "repsert" $ do + result <- + runMockSqlQueryT + (repsert 1 $ person "Alice") + [ withRecord @Person $ \case + Repsert _ _ -> Just () + _ -> Nothing + ] + result @?= () + , testCase "repsertMany" $ do + result <- + runMockSqlQueryT + (repsertMany [(1, person "Alice")]) + [ withRecord @Person $ \case + RepsertMany _ -> Just () + _ -> Nothing + ] + result @?= () + , testCase "replace" $ do + result <- + runMockSqlQueryT + (replace 1 $ person "Alice") + [ withRecord @Person $ \case + Replace _ _ -> Just () + _ -> Nothing + ] + result @?= () + , testCase "delete" $ do + result <- + runMockSqlQueryT + (delete @Person 1) + [ withRecord @Person $ \case + Delete _ -> Just () + _ -> Nothing + ] + result @?= () + , testCase "update" $ do + result <- + runMockSqlQueryT + (update 1 [PersonName =. "Alicia"]) + [ withRecord @Person $ \case + Update _ _ -> Just () + _ -> Nothing + ] + result @?= () + , testCase "updateGet" $ do + result <- + runMockSqlQueryT + (updateGet 1 [PersonName =. "Alicia"]) + [ withRecord @Person $ \case + UpdateGet _ _ -> Just $ person "Alicia" + _ -> Nothing + ] + personName result @?= "Alicia" + , testCase "insertEntity" $ do + let alice = person "Alice" + result <- + runMockSqlQueryT + (insertEntity alice) + [ withRecord @Person $ \case + InsertEntity _ -> Just $ Entity 1 alice + _ -> Nothing + ] + entityVal result @?= alice + , testCase "insertRecord" $ do + let alice = person "Alice" + result <- + runMockSqlQueryT + (insertRecord alice) + [ withRecord @Person $ \case + InsertRecord _ -> Just alice + _ -> Nothing + ] + result @?= alice + , testCase "getBy" $ do + result <- + runMockSqlQueryT + (mapM getBy [UniqueName "Alice", UniqueName "Bob"]) + [ withRecord @Person $ \case + GetBy (UniqueName "Alice") -> Just $ Just $ Entity 1 $ person "Alice" + GetBy (UniqueName "Bob") -> Just Nothing + _ -> Nothing + ] + map (fmap getName) result @?= [Just "Alice", Nothing] + , testCase "getByValue" $ do + result <- + runMockSqlQueryT + (mapM getByValue [person "Alice", person "Bob"]) + [ withRecord @Person $ \case + GetByValue Person{personName = "Alice"} -> Just $ Just $ Entity 1 $ person "Alice" + GetByValue Person{personName = "Bob"} -> Just Nothing + _ -> Nothing + ] + map (fmap getName) result @?= [Just "Alice", Nothing] + , testCase "checkUnique" $ do + result <- + runMockSqlQueryT + (mapM checkUnique [person "Alice", person "Bob"]) + [ withRecord @Person $ \case + CheckUnique Person{personName = "Alice"} -> Just $ Just $ UniqueName "Alice" + CheckUnique Person{personName = "Bob"} -> Just Nothing + _ -> Nothing + ] + result @?= [Just $ UniqueName "Alice", Nothing] + , testCase "checkUniqueUpdateable" $ do + result <- + runMockSqlQueryT + (mapM checkUniqueUpdateable [Entity 1 $ person "Alice", Entity 2 $ person "Bob"]) + [ withRecord @Person $ \case + CheckUniqueUpdateable (Entity _ Person{personName = "Alice"}) -> Just $ Just $ UniqueName "Alice" + CheckUniqueUpdateable (Entity _ Person{personName = "Bob"}) -> Just Nothing + _ -> Nothing + ] + result @?= [Just $ UniqueName "Alice", Nothing] + , testCase "deleteBy" $ do + result <- + runMockSqlQueryT + (deleteBy $ UniqueName "Alice") + [ withRecord @Person $ \case + DeleteBy _ -> Just () + _ -> Nothing + ] + result @?= () + , testCase "insertUnique" $ do + result <- + runMockSqlQueryT + (mapM insertUnique [person "Alice", person "Bob"]) + [ withRecord @Person $ \case + InsertUnique Person{personName = "Alice"} -> Just $ Just 1 + InsertUnique Person{personName = "Bob"} -> Just Nothing + _ -> Nothing + ] + result @?= [Just 1, Nothing] + , testCase "upsert" $ do + let alice = person "Alice" + result <- + runMockSqlQueryT + (upsert alice [PersonAge =. 100]) + [ withRecord @Person $ \case + Upsert _ _ -> Just $ Entity 1 alice + _ -> Nothing + ] + result @?= Entity 1 alice + , testCase "upsertBy" $ do + let alice = person "Alice" + result <- + runMockSqlQueryT + (upsertBy (UniqueName "Alice") alice [PersonAge =. 100]) + [ withRecord @Person $ \case + UpsertBy _ _ _ -> Just $ Entity 1 alice + _ -> Nothing + ] + result @?= Entity 1 alice + , testCase "putMany" $ do + result <- + runMockSqlQueryT + (putMany [person "Alice"]) + [ withRecord @Person $ \case + PutMany _ -> Just () + _ -> Nothing + ] + result @?= () + , testCase "insertBy" $ do + let alice = person "Alice" + result <- + runMockSqlQueryT + (mapM insertBy [alice, person "Bob"]) + [ withRecord @Person $ \case + InsertBy Person{personName = "Alice"} -> Just $ Left $ Entity 1 alice + InsertBy Person{personName = "Bob"} -> Just $ Right 2 + _ -> Nothing + ] + result @?= [Left $ Entity 1 alice, Right 2] + , testCase "insertUniqueEntity" $ do + let bob = person "Bob" + result <- + runMockSqlQueryT + (mapM insertUniqueEntity [person "Alice", bob]) + [ withRecord @Person $ \case + InsertUniqueEntity Person{personName = "Alice"} -> Just Nothing + InsertUniqueEntity Person{personName = "Bob"} -> Just $ Just $ Entity 1 bob + _ -> Nothing + ] + result @?= [Nothing, Just $ Entity 1 bob] + , testCase "replaceUnique" $ do + result <- + runMockSqlQueryT + (mapM (uncurry replaceUnique) [(1, person "Alice"), (2, person "Bob")]) + [ withRecord @Person $ \case + ReplaceUnique _ Person{personName = "Alice"} -> Just Nothing + ReplaceUnique _ Person{personName = "Bob"} -> Just $ Just $ UniqueName "Bob" + _ -> Nothing + ] + result @?= [Nothing, Just $ UniqueName "Bob"] + , testCase "onlyUnique" $ do + result <- + runMockSqlQueryT + (onlyUnique $ person "Alice") + [ withRecord @Person $ \case + OnlyUnique _ -> Just $ UniqueName "Alice" + _ -> Nothing + ] + result @?= UniqueName "Alice" + , testCase "selectSourceRes" $ do + acquire <- + runMockSqlQueryT + (selectSourceRes [] []) + [ mockSelectSource $ \_ _ -> + Just + [ Entity 1 $ person "Alice" + , Entity 2 $ person "Bob" + ] + ] + result <- Acquire.with acquire $ \conduit -> + runConduit $ conduit .| Conduit.mapC getName .| Conduit.sinkList + result @?= ["Alice", "Bob"] + , testCase "selectFirst" $ do + result1 <- + runMockSqlQueryT + (selectFirst [PersonName ==. "Alice"] []) + [ withRecord @Person $ \case + SelectFirst _ _ -> Just $ Just $ Entity 1 $ person "Alice" + _ -> Nothing + ] + getName <$> result1 @?= Just "Alice" + result2 <- + runMockSqlQueryT + (selectFirst [PersonName ==. "Alice"] []) + [ withRecord @Person $ \case + SelectFirst _ _ -> Just Nothing + _ -> Nothing + ] + result2 @?= Nothing + , testCase "selectKeysRes" $ do + let keys = [1, 2, 3] + acquire <- + runMockSqlQueryT + (selectKeysRes @_ @Person [] []) + [ mockSelectKeys $ \_ _ -> Just keys + ] + result <- Acquire.with acquire $ \conduit -> + runConduit $ conduit .| Conduit.sinkList + result @?= keys + , testCase "count" $ do + result <- + runMockSqlQueryT + (count @Person []) + [ withRecord @Person $ \case + Count _ -> Just 10 + _ -> Nothing + ] + result @?= 10 + , testCase "exists" $ do + result <- + runMockSqlQueryT + (exists @Person []) + [ withRecord @Person $ \case + Exists _ -> Just True + _ -> Nothing + ] + result @?= True + , testCase "selectSource" $ do + result <- + runResourceT $ + runMockSqlQueryT + (runConduit $ selectSource [] [] .| Conduit.mapC getName .| Conduit.sinkList) + [ mockSelectSource $ \_ _ -> + Just + [ Entity 1 $ person "Alice" + , Entity 2 $ person "Bob" + ] + ] + result @?= ["Alice", "Bob"] + , testCase "selectKeys" $ do + let keys = [1, 2, 3] + result <- + runResourceT $ + runMockSqlQueryT + (runConduit $ selectKeys @Person [] [] .| Conduit.sinkList) + [ mockSelectKeys $ \_ _ -> Just keys + ] + result @?= keys + , testCase "selectList" $ do + result <- + runMockSqlQueryT + (selectList [] []) + [ withRecord @Person $ \case + SelectList _ _ -> + Just + [ Entity 1 (person "Alice") + , Entity 2 (person "Bob") + ] + _ -> Nothing + ] + map getName result @?= ["Alice", "Bob"] + , testCase "selectKeysList" $ do + let keys = [1, 2, 3] + result <- + runMockSqlQueryT + (selectKeysList @Person [] []) + [ withRecord @Person $ \case + SelectKeysList _ _ -> Just keys + _ -> Nothing + ] + result @?= keys + , testCase "updateWhere" $ do + result <- + runMockSqlQueryT + (updateWhere [] [PersonAge =. 100]) + [ withRecord @Person $ \case + UpdateWhere _ _ -> Just () + _ -> Nothing + ] + result @?= () + , testCase "deleteWhere" $ do + result <- + runMockSqlQueryT + (deleteWhere [PersonName ==. "Alice"]) + [ withRecord @Person $ \case + DeleteWhere _ -> Just () + _ -> Nothing + ] + result @?= () + , testCase "updateWhereCount" $ do + result <- + runMockSqlQueryT + (updateWhereCount [] [PersonAge =. 100]) + [ withRecord @Person $ \case + UpdateWhereCount _ _ -> Just 10 + _ -> Nothing + ] + result @?= 10 + , testCase "deleteWhereCount" $ do + result <- + runMockSqlQueryT + (deleteWhereCount [PersonName ==. "Alice"]) + [ withRecord @Person $ \case + DeleteWhereCount _ -> Just 10 + _ -> Nothing + ] + result @?= 10 + , testCase "getFieldName" $ do + result <- + runMockSqlQueryT + (getFieldName PersonName) + [ withRecord @Person $ \case + GetFieldName PersonName -> Just "\"name\"" + _ -> Nothing + ] + result @?= "\"name\"" + , testCase "getTableName" $ do + result <- + runMockSqlQueryT + (getTableName $ person "Alice") + [ withRecord @Person $ \case + GetTableName _ -> Just "\"person\"" + _ -> Nothing + ] + result @?= "\"person\"" + , testCase "withRawQuery" $ do + let query = "SELECT name FROM person" + row1 = [toPersistValue @String "Alice"] + row2 = [toPersistValue @String "Bob"] + rows = [row1, row2] + result <- + runMockSqlQueryT + (withRawQuery query [] Conduit.sinkList) + [ mockWithRawQuery $ \sql _ -> + if sql == query + then Just rows + else Nothing + ] + result @?= rows + , testCase "rawQueryRes" $ do + let row1 = [toPersistValue @String "Alice"] + row2 = [toPersistValue @String "Bob"] + rows = [row1, row2] + acquire <- + runMockSqlQueryT + (rawQueryRes "SELECT name FROM person" []) + [ mockRawQuery $ \_ _ -> Just rows + ] + result <- Acquire.with acquire $ \conduit -> + runConduit $ conduit .| Conduit.sinkList + result @?= rows + , testCase "rawQuery" $ do + let row1 = [toPersistValue @String "Alice"] + row2 = [toPersistValue @String "Bob"] + rows = [row1, row2] + result <- + runResourceT $ + runMockSqlQueryT + (runConduit $ rawQuery "SELECT name FROM person" [] .| Conduit.sinkList) + [ mockRawQuery $ \_ _ -> Just rows + ] + result @?= rows + , testCase "rawExecute" $ do + result <- + runMockSqlQueryT + (rawExecute "DELETE FROM person" []) + [ mockQuery $ \case + RawExecute _ _ -> Just () + _ -> Nothing + ] + result @?= () + , testCase "rawExecuteCount" $ do + result <- + runMockSqlQueryT + (rawExecuteCount "DELETE FROM person" []) + [ mockQuery $ \case + RawExecuteCount _ _ -> Just 10 + _ -> Nothing + ] + result @?= 10 + , testCase "rawSql" $ do + let names = ["Alice", "Bob"] :: [String] + result <- + runMockSqlQueryT + (rawSql "SELECT name FROM person" []) + [ mockRawSql $ \_ _ -> Just $ map ((: []) . toPersistValue) names + ] + map unSingle result @?= names + ] diff --git a/test/READMETest.hs b/test/READMETest.hs new file mode 100644 --- /dev/null +++ b/test/READMETest.hs @@ -0,0 +1,32 @@ +{- AUTOCOLLECT.TEST -} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TypeApplications #-} + +module READMETest ( + -- $AUTOCOLLECT.TEST.export$ +) where + +import Test.Tasty.HUnit + +import Database.Persist.Monad +import Database.Persist.Monad.TestUtils +import Example + +test = + testCase "withTransaction example works" $ do + let foo :: MonadSqlQuery m => m () + foo = insert_ $ person "Alice" + bar :: MonadSqlQuery m => m () + bar = insert_ $ person "Bob" + fooAndBar :: MonadSqlQuery m => m () + fooAndBar = withTransaction $ foo >> bar + runMockSqlQueryT + fooAndBar + [ withRecord @Person $ \case + Insert_ _ -> Just () + _ -> Nothing + , withRecord @Person $ \case + Insert_ _ -> Just () + _ -> Nothing + ] diff --git a/test/SqlQueryRepTest.hs b/test/SqlQueryRepTest.hs --- a/test/SqlQueryRepTest.hs +++ b/test/SqlQueryRepTest.hs @@ -1,6 +1,9 @@ +{- AUTOCOLLECT.TEST -} {-# LANGUAGE CPP #-} -module SqlQueryRepTest where +module SqlQueryRepTest ( + -- $AUTOCOLLECT.TEST.export$ +) where import qualified Data.ByteString.Lazy.Char8 as Char8 import Test.Tasty @@ -8,32 +11,21 @@ import Generated -{-# ANN module "HLint: ignore" #-} - persistentVersionDir :: FilePath -#if MIN_VERSION_persistent(2,14,0) -persistentVersionDir = error "Running tests against persistent > 2.13 is not supported" +#if MIN_VERSION_persistent(2,15,0) +persistentVersionDir = error "Running tests against persistent > 2.14 is not supported" +#elif MIN_VERSION_persistent(2,14,0) +persistentVersionDir = "persistent-2.14/" #elif MIN_VERSION_persistent(2,13,0) persistentVersionDir = "persistent-2.13/" -#elif MIN_VERSION_persistent(2,12,0) -persistentVersionDir = "persistent-2.12/" -#elif MIN_VERSION_persistent(2,11,0) -persistentVersionDir = "persistent-2.11/" -#elif MIN_VERSION_persistent(2,10,0) -persistentVersionDir = "persistent-2.10/" -#elif MIN_VERSION_persistent(2,9,0) -persistentVersionDir = "persistent-2.9/" -#elif MIN_VERSION_persistent(2,8,0) -persistentVersionDir = "persistent-2.8/" #else -persistentVersionDir = error "Running tests against persistent < 2.8 is not supported" +persistentVersionDir = error "Running tests against persistent < 2.13 is not supported" #endif -tests :: TestTree -tests = testGroup "SqlQueryRep tests" - [ golden "Show representation" (persistentVersionDir ++ "sqlqueryrep_show_representation.golden") $ - pure $ unlines allSqlQueryRepShowRepresentations - ] +test = + golden "Show representation" (persistentVersionDir ++ "sqlqueryrep_show_representation.golden") $ + pure $ + unlines allSqlQueryRepShowRepresentations golden :: String -> FilePath -> IO String -> TestTree golden name fp action = goldenVsStringDiff name diffCmd ("test/goldens/" ++ fp) $ Char8.pack <$> action diff --git a/test/TestUtils/DB.hs b/test/TestUtils/DB.hs --- a/test/TestUtils/DB.hs +++ b/test/TestUtils/DB.hs @@ -1,10 +1,10 @@ {-# LANGUAGE OverloadedStrings #-} -module TestUtils.DB - ( BackendType(..) - , allBackendTypes - , withTestDB - ) where +module TestUtils.DB ( + BackendType (..), + allBackendTypes, + withTestDB, +) where import Control.Monad.Logger (runNoLoggingT) import qualified Data.ByteString.Char8 as Char8 diff --git a/test/TestUtils/Esqueleto.hs b/test/TestUtils/Esqueleto.hs --- a/test/TestUtils/Esqueleto.hs +++ b/test/TestUtils/Esqueleto.hs @@ -1,17 +1,11 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} -module TestUtils.Esqueleto - ( esqueletoSelect - ) where +module TestUtils.Esqueleto ( + esqueletoSelect, +) where -#if MIN_VERSION_esqueleto(3,5,0) import qualified Database.Esqueleto.Experimental as E import qualified Database.Esqueleto.Internal.Internal as E -#else -import qualified Database.Esqueleto as E -import qualified Database.Esqueleto.Internal.Sql as E -#endif import Database.Persist.Monad (MonadSqlQuery, unsafeLiftSql) diff --git a/test/goldens/persistent-2.10/sqlqueryrep_show_representation.golden b/test/goldens/persistent-2.10/sqlqueryrep_show_representation.golden deleted file mode 100644 --- a/test/goldens/persistent-2.10/sqlqueryrep_show_representation.golden +++ /dev/null @@ -1,66 +0,0 @@ -Get{..} -GetMany{..} -GetJust{..} -GetJustEntity{..} -GetEntity{..} -BelongsTo{..}<(Person,Post)> -BelongsToJust{..}<(Person,Post)> -Insert{..} -Insert_{..} -InsertMany{..} -InsertMany_{..} -InsertEntityMany{..} -InsertKey{..} -Repsert{..} -RepsertMany{..} -Replace{..} -Delete{..} -Update{..} -UpdateGet{..} -InsertEntity{..} -InsertRecord{..} -GetBy{..} -GetByValue{..} -CheckUnique{..} -DeleteBy{..} -InsertUnique{..} -Upsert{..} -UpsertBy{..} -PutMany{..} -InsertBy{..} -InsertUniqueEntity{..} -ReplaceUnique{..} -OnlyUnique{..} -SelectSourceRes{..} -SelectFirst{..} -SelectKeysRes{..} -Count{..} -SelectList{..} -SelectKeysList{..} -UpdateWhere{..} -DeleteWhere{..} -DeleteWhereCount{..} -UpdateWhereCount{..} -DeleteCascade{..} -DeleteCascadeWhere{..} -ParseMigration{..} -ParseMigration'{..} -PrintMigration{..} -ShowMigration{..} -GetMigration{..} -RunMigration{..} -RunMigrationQuiet{..} -RunMigrationSilent{..} -RunMigrationUnsafe{..} -RunMigrationUnsafeQuiet{..} -GetFieldName{..} -GetTableName{..} -WithRawQuery{..} -RawQueryRes{..} -RawExecute{..} -RawExecuteCount{..} -RawSql{..} -TransactionSave{..} -TransactionSaveWithIsolation{..} -TransactionUndo{..} -TransactionUndoWithIsolation{..} diff --git a/test/goldens/persistent-2.11/sqlqueryrep_show_representation.golden b/test/goldens/persistent-2.11/sqlqueryrep_show_representation.golden deleted file mode 100644 --- a/test/goldens/persistent-2.11/sqlqueryrep_show_representation.golden +++ /dev/null @@ -1,68 +0,0 @@ -Get{..} -GetMany{..} -GetJust{..} -GetJustEntity{..} -GetEntity{..} -BelongsTo{..}<(Person,Post)> -BelongsToJust{..}<(Person,Post)> -Insert{..} -Insert_{..} -InsertMany{..} -InsertMany_{..} -InsertEntityMany{..} -InsertKey{..} -Repsert{..} -RepsertMany{..} -Replace{..} -Delete{..} -Update{..} -UpdateGet{..} -InsertEntity{..} -InsertRecord{..} -GetBy{..} -GetByValue{..} -CheckUnique{..} -CheckUniqueUpdateable{..} -DeleteBy{..} -InsertUnique{..} -Upsert{..} -UpsertBy{..} -PutMany{..} -InsertBy{..} -InsertUniqueEntity{..} -ReplaceUnique{..} -OnlyUnique{..} -SelectSourceRes{..} -SelectFirst{..} -SelectKeysRes{..} -Count{..} -Exists{..} -SelectList{..} -SelectKeysList{..} -UpdateWhere{..} -DeleteWhere{..} -DeleteWhereCount{..} -UpdateWhereCount{..} -DeleteCascade{..} -DeleteCascadeWhere{..} -ParseMigration{..} -ParseMigration'{..} -PrintMigration{..} -ShowMigration{..} -GetMigration{..} -RunMigration{..} -RunMigrationQuiet{..} -RunMigrationSilent{..} -RunMigrationUnsafe{..} -RunMigrationUnsafeQuiet{..} -GetFieldName{..} -GetTableName{..} -WithRawQuery{..} -RawQueryRes{..} -RawExecute{..} -RawExecuteCount{..} -RawSql{..} -TransactionSave{..} -TransactionSaveWithIsolation{..} -TransactionUndo{..} -TransactionUndoWithIsolation{..} diff --git a/test/goldens/persistent-2.12/sqlqueryrep_show_representation.golden b/test/goldens/persistent-2.12/sqlqueryrep_show_representation.golden deleted file mode 100644 --- a/test/goldens/persistent-2.12/sqlqueryrep_show_representation.golden +++ /dev/null @@ -1,68 +0,0 @@ -Get{..} -GetMany{..} -GetJust{..} -GetJustEntity{..} -GetEntity{..} -BelongsTo{..}<(Person,Post)> -BelongsToJust{..}<(Person,Post)> -Insert{..} -Insert_{..} -InsertMany{..} -InsertMany_{..} -InsertEntityMany{..} -InsertKey{..} -Repsert{..} -RepsertMany{..} -Replace{..} -Delete{..} -Update{..} -UpdateGet{..} -InsertEntity{..} -InsertRecord{..} -GetBy{..} -GetByValue{..} -CheckUnique{..} -CheckUniqueUpdateable{..} -DeleteBy{..} -InsertUnique{..} -Upsert{..} -UpsertBy{..} -PutMany{..} -InsertBy{..} -InsertUniqueEntity{..} -ReplaceUnique{..} -OnlyUnique{..} -SelectSourceRes{..} -SelectFirst{..} -SelectKeysRes{..} -Count{..} -Exists{..} -SelectList{..} -SelectKeysList{..} -UpdateWhere{..} -DeleteWhere{..} -DeleteWhereCount{..} -UpdateWhereCount{..} -DeleteCascade{..} -DeleteCascadeWhere{..} -ParseMigration{..} -ParseMigration'{..} -PrintMigration{..} -ShowMigration{..} -GetMigration{..} -RunMigration{..} -RunMigrationQuiet{..} -RunMigrationSilent{..} -RunMigrationUnsafe{..} -RunMigrationUnsafeQuiet{..} -GetFieldName{..} -GetTableName{..} -WithRawQuery{..} -RawQueryRes{..} -RawExecute{..} -RawExecuteCount{..} -RawSql{..} -TransactionSave{..} -TransactionSaveWithIsolation{..} -TransactionUndo{..} -TransactionUndoWithIsolation{..} diff --git a/test/goldens/persistent-2.14/sqlqueryrep_show_representation.golden b/test/goldens/persistent-2.14/sqlqueryrep_show_representation.golden new file mode 100644 --- /dev/null +++ b/test/goldens/persistent-2.14/sqlqueryrep_show_representation.golden @@ -0,0 +1,66 @@ +Get{..} +GetMany{..} +GetJust{..} +GetJustEntity{..} +GetEntity{..} +BelongsTo{..}<(Person,Post)> +BelongsToJust{..}<(Person,Post)> +Insert{..} +Insert_{..} +InsertMany{..} +InsertMany_{..} +InsertEntityMany{..} +InsertKey{..} +Repsert{..} +RepsertMany{..} +Replace{..} +Delete{..} +Update{..} +UpdateGet{..} +InsertEntity{..} +InsertRecord{..} +GetBy{..} +GetByValue{..} +CheckUnique{..} +CheckUniqueUpdateable{..} +DeleteBy{..} +InsertUnique{..} +Upsert{..} +UpsertBy{..} +PutMany{..} +InsertBy{..} +InsertUniqueEntity{..} +ReplaceUnique{..} +OnlyUnique{..} +SelectSourceRes{..} +SelectFirst{..} +SelectKeysRes{..} +Count{..} +Exists{..} +SelectList{..} +SelectKeysList{..} +UpdateWhere{..} +DeleteWhere{..} +DeleteWhereCount{..} +UpdateWhereCount{..} +ParseMigration{..} +ParseMigration'{..} +PrintMigration{..} +ShowMigration{..} +GetMigration{..} +RunMigration{..} +RunMigrationQuiet{..} +RunMigrationSilent{..} +RunMigrationUnsafe{..} +RunMigrationUnsafeQuiet{..} +GetFieldName{..} +GetTableName{..} +WithRawQuery{..} +RawQueryRes{..} +RawExecute{..} +RawExecuteCount{..} +RawSql{..} +TransactionSave{..} +TransactionSaveWithIsolation{..} +TransactionUndo{..} +TransactionUndoWithIsolation{..} diff --git a/test/goldens/persistent-2.8/sqlqueryrep_show_representation.golden b/test/goldens/persistent-2.8/sqlqueryrep_show_representation.golden deleted file mode 100644 --- a/test/goldens/persistent-2.8/sqlqueryrep_show_representation.golden +++ /dev/null @@ -1,62 +0,0 @@ -Get{..} -GetMany{..} -GetJust{..} -GetJustEntity{..} -GetEntity{..} -BelongsTo{..}<(Person,Post)> -BelongsToJust{..}<(Person,Post)> -Insert{..} -Insert_{..} -InsertMany{..} -InsertMany_{..} -InsertEntityMany{..} -InsertKey{..} -Repsert{..} -RepsertMany{..} -Replace{..} -Delete{..} -Update{..} -UpdateGet{..} -InsertEntity{..} -InsertRecord{..} -GetBy{..} -GetByValue{..} -CheckUnique{..} -DeleteBy{..} -InsertUnique{..} -Upsert{..} -UpsertBy{..} -PutMany{..} -InsertBy{..} -InsertUniqueEntity{..} -ReplaceUnique{..} -OnlyUnique{..} -SelectSourceRes{..} -SelectFirst{..} -SelectKeysRes{..} -Count{..} -SelectList{..} -SelectKeysList{..} -UpdateWhere{..} -DeleteWhere{..} -DeleteWhereCount{..} -UpdateWhereCount{..} -DeleteCascade{..} -DeleteCascadeWhere{..} -ParseMigration{..} -ParseMigration'{..} -PrintMigration{..} -ShowMigration{..} -GetMigration{..} -RunMigration{..} -RunMigrationSilent{..} -RunMigrationUnsafe{..} -GetFieldName{..} -GetTableName{..} -WithRawQuery{..} -RawQueryRes{..} -RawExecute{..} -RawExecuteCount{..} -RawSql{..} -TransactionSave{..} -TransactionUndo{..} diff --git a/test/goldens/persistent-2.9/sqlqueryrep_show_representation.golden b/test/goldens/persistent-2.9/sqlqueryrep_show_representation.golden deleted file mode 100644 --- a/test/goldens/persistent-2.9/sqlqueryrep_show_representation.golden +++ /dev/null @@ -1,64 +0,0 @@ -Get{..} -GetMany{..} -GetJust{..} -GetJustEntity{..} -GetEntity{..} -BelongsTo{..}<(Person,Post)> -BelongsToJust{..}<(Person,Post)> -Insert{..} -Insert_{..} -InsertMany{..} -InsertMany_{..} -InsertEntityMany{..} -InsertKey{..} -Repsert{..} -RepsertMany{..} -Replace{..} -Delete{..} -Update{..} -UpdateGet{..} -InsertEntity{..} -InsertRecord{..} -GetBy{..} -GetByValue{..} -CheckUnique{..} -DeleteBy{..} -InsertUnique{..} -Upsert{..} -UpsertBy{..} -PutMany{..} -InsertBy{..} -InsertUniqueEntity{..} -ReplaceUnique{..} -OnlyUnique{..} -SelectSourceRes{..} -SelectFirst{..} -SelectKeysRes{..} -Count{..} -SelectList{..} -SelectKeysList{..} -UpdateWhere{..} -DeleteWhere{..} -DeleteWhereCount{..} -UpdateWhereCount{..} -DeleteCascade{..} -DeleteCascadeWhere{..} -ParseMigration{..} -ParseMigration'{..} -PrintMigration{..} -ShowMigration{..} -GetMigration{..} -RunMigration{..} -RunMigrationSilent{..} -RunMigrationUnsafe{..} -GetFieldName{..} -GetTableName{..} -WithRawQuery{..} -RawQueryRes{..} -RawExecute{..} -RawExecuteCount{..} -RawSql{..} -TransactionSave{..} -TransactionSaveWithIsolation{..} -TransactionUndo{..} -TransactionUndoWithIsolation{..}