persistent-mtl 0.1.0.1 → 0.2.0.0

raw patch · 12 files changed

+625/−205 lines, 12 filesdep +persistent-postgresqldep ~resource-pooldep ~unliftioPVP ok

version bump matches the API change (PVP)

Dependencies added: persistent-postgresql

Dependency ranges changed: resource-pool, unliftio

API changes (from Hackage documentation)

Files

• CHANGELOG.md +7/−0
• README.md +56/−3
• persistent-mtl.cabal +7/−2
• src/Control/Monad/IO/Rerunnable.hs +71/−0
• src/Database/Persist/Monad.hs +127/−27
• src/Database/Persist/Monad/Class.hs +26/−17
• src/Database/Persist/Monad/TestUtils.hs +7/−0
• test/Example.hs +22/−14
• test/Generated.hs +2/−2
• test/Integration.hs +251/−139
• test/MockSqlQueryT.hs +0/−1
• test/TestUtils/DB.hs +49/−0

@@ -1,3 +1,10 @@+# 0.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  Fix quickstart

@@ -54,12 +54,12 @@ instance MonadUnliftIO MyApp where   withRunInIO = wrappedWithRunInIO MyApp unMyApp -getYoungPeople :: (MonadIO m, MonadSqlQuery m) => m [Entity Person]+getYoungPeople :: MonadSqlQuery m => m [Entity Person] getYoungPeople = selectList [PersonAge <. 18] []  main :: IO ()-main = runStderrLoggingT $ withSqlitePool "db.sqlite" 5 $ \conn ->-  liftIO $ runSqlQueryT conn $ unMyApp $ do+main = runStderrLoggingT $ withSqlitePool "db.sqlite" 5 $ \pool ->+  liftIO $ runSqlQueryT pool $ unMyApp $ do     runMigration migrate     insert_ $ Person "Alice" 25     insert_ $ Person "Bob" 10@@ -228,6 +228,59 @@     `fooAndBar` will run both `foo` and `bar` in the same transaction. Note that `foo` and `bar` themselves don't say anything about transactions. By default, using a `persistent` function without `withTransaction` will run each query in its own transaction. And if `foo` did use `withTransaction`, it would start a transaction within a transaction (if the SQL backend supports it). Now, `foo` and `bar` are composable!  In summary, `persistent-mtl` takes all the good things about option 2, implements them out of the box (so you don't have to do it yourself), and makes your business logic functions composable with transactions behaving the way YOU want.++### Easy transaction management++Some databases will throw an error if two transactions conflict (e.g. [PostgreSQL](https://www.postgresql.org/docs/9.5/transaction-iso.html)). The client is expected to retry transactions if this error is thrown. `persistent` doesn't easily support this out of the box, but `persistent-mtl` does!++```hs+import Database.PostgreSQL.Simple.Errors (isSerializationError)++main :: IO ()+main = withPostgresqlPool "..." 5 $ \pool -> do+  let env = mkSqlQueryEnv pool $ \env -> env+        { retryIf = isSerializationError . fromException+        , retryLimit = 100 -- defaults to 10+        }++  -- in any of the marked transactions below, if someone else is querying+  -- the postgresql database at the same time with queries that conflict+  -- with yours, your operations will automatically be retried+  runSqlQueryTWith env $ do+    -- transaction 1+    insert_ $ ...++    -- transaction 2+    withTransaction $ do+      insert_ $ ...++      -- transaction 2.5: transaction-within-a-transaction is supported in PostgreSQL+      withTransaction $ do+        insert_ $ ...++      insert_ $ ...++    -- transaction 3+    insert_ $ ...+```++Because of this built-in retry support, any IO actions inside `withTransaction` have to be explicitly marked with `rerunnableIO`. If you try to use a function with a `MonadIO m` constraint, you'll get a compile-time error!++```+.../Foo.hs:100:5: error:+    • Cannot run arbitrary IO actions within a transaction. If the IO action is rerunnable, use rerunnableIO+    • In a stmt of a 'do' block: arbitraryIO+      In the second argument of ‘($)’, namely+        ‘withTransaction+           $ do insert_ record1+                arbitraryIO+                insert_ record2’+    |+100 |     arbitraryIO+    |     ^^^^^^^^^^^+```++Note that this **only** applies for transactions, so `MonadIO` and `MonadSqlQuery` constraints can still co-exist (for a function with IO actions that are not rerunnable) as long as the function is never called within `withTransaction`.  ### Testing functions that use `persistent` operations 

@@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: 9b6ae20631ee5ad633b82ab405f64730ea1603ef8da2099ea41ef126cab9d817+-- hash: 9c53e0610dea4ca814133d0596978b961b85fd54cb6df7a82eccb6d260824dde  name:           persistent-mtl-version:        0.1.0.1+version:        0.2.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.@@ -32,6 +32,7 @@  library   exposed-modules:+      Control.Monad.IO.Rerunnable       Database.Persist.Monad       Database.Persist.Monad.Class       Database.Persist.Monad.Shim@@ -53,6 +54,7 @@     , resourcet-pool >=0.1.0.0 && <0.2     , text >=1.2.3.0 && <2     , transformers >=0.5.2.0 && <0.6+    , unliftio >=0.2.7.0 && <0.3     , unliftio-core >=0.1.2.0 && <0.3   default-language: Haskell2010 @@ -66,6 +68,7 @@       Mocked       MockSqlQueryT       SqlQueryRepTest+      TestUtils.DB       TestUtils.Match       Paths_persistent_mtl   hs-source-dirs:@@ -79,8 +82,10 @@     , monad-logger     , persistent     , persistent-mtl+    , persistent-postgresql     , persistent-sqlite     , persistent-template+    , resource-pool     , resourcet     , tasty     , tasty-golden

@@ -0,0 +1,71 @@+{-|+Module: Control.Monad.IO.Rerunnable++Defines the 'MonadRerunnableIO' type class that is functionally equivalent+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++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.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@.+  --+  -- The given IO operation may be rerun, so use of this function requires+  -- manually verifying that the given IO operation is rerunnable.+  rerunnableIO :: IO a -> m a++instance MonadRerunnableIO IO where+  rerunnableIO = id++{- Instances for common monad transformers -}++instance MonadRerunnableIO m => MonadRerunnableIO (Reader.ReaderT r m) where+  rerunnableIO = lift . rerunnableIO++instance MonadRerunnableIO m => MonadRerunnableIO (Except.ExceptT e m) where+  rerunnableIO = lift . rerunnableIO++instance MonadRerunnableIO m => MonadRerunnableIO (Identity.IdentityT m) where+  rerunnableIO = lift . rerunnableIO++instance MonadRerunnableIO m => MonadRerunnableIO (Maybe.MaybeT m) where+  rerunnableIO = lift . rerunnableIO++instance (Monoid w, MonadRerunnableIO m) => MonadRerunnableIO (RWS.Lazy.RWST r w s m) where+  rerunnableIO = lift . rerunnableIO++instance (Monoid w, MonadRerunnableIO m) => MonadRerunnableIO (RWS.Strict.RWST r w s m) where+  rerunnableIO = lift . rerunnableIO++instance MonadRerunnableIO m => MonadRerunnableIO (State.Lazy.StateT s m) where+  rerunnableIO = lift . rerunnableIO++instance MonadRerunnableIO m => MonadRerunnableIO (State.Strict.StateT s m) where+  rerunnableIO = lift . rerunnableIO++instance (Monoid w, MonadRerunnableIO m) => MonadRerunnableIO (Writer.Lazy.WriterT w m) where+  rerunnableIO = lift . rerunnableIO++instance (Monoid w, MonadRerunnableIO m) => MonadRerunnableIO (Writer.Strict.WriterT w m) where+  rerunnableIO = lift . rerunnableIO++instance MonadRerunnableIO m => MonadRerunnableIO (Resource.ResourceT m) where+  rerunnableIO = lift . rerunnableIO

@@ -1,8 +1,11 @@ {-| Module: Database.Persist.Monad -Defines the 'SqlQueryT' monad transformer that has a 'MonadSqlQuery' instance-to execute @persistent@ database operations.+Defines the 'SqlQueryT' monad transformer, which has a 'MonadSqlQuery' instance+to execute @persistent@ database operations. Also provides easy transaction+management with 'withTransaction', which supports retrying with exponential+backoff and restricts IO actions to only allow IO actions explicitly marked+as rerunnable.  Usage: @@ -18,60 +21,155 @@   liftIO $ print (personList :: [Person])    -- everything in here will run in a transaction-  withTransaction $+  withTransaction $ do     selectFirst [PersonAge >. 30] [] >>= \\case       Nothing -> insert_ $ Person { name = \"Claire\", age = Just 50 }       Just (Entity key person) -> replace key person{ age = Just (age person - 10) } +    -- liftIO doesn't work in here, since transactions can be retried.+    -- Use rerunnableIO to run IO actions, after verifying that the IO action+    -- can be rerun if the transaction needs to be retried.+    rerunnableIO $ putStrLn "Transaction is finished!"+   -- some more business logic    return () @ -} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}  module Database.Persist.Monad   (   -- * Type class for executing database queries     MonadSqlQuery   , withTransaction-  , SqlQueryRep(..)    -- * SqlQueryT monad transformer   , SqlQueryT   , runSqlQueryT+  , runSqlQueryTWith+  , SqlQueryEnv(..)+  , mkSqlQueryEnv +  -- * Transactions+  , SqlTransaction+  , TransactionError(..)+   -- * Lifted functions   , module Database.Persist.Monad.Shim   ) where  import Control.Monad.IO.Class (MonadIO(..)) import Control.Monad.IO.Unlift (MonadUnliftIO(..), wrappedWithRunInIO)-import Control.Monad.Reader (ReaderT, ask, local, runReaderT)+import Control.Monad.Reader (ReaderT, ask, runReaderT) import Control.Monad.Trans.Class (MonadTrans(..)) import Control.Monad.Trans.Resource (MonadResource) import Data.Acquire (withAcquire) import Data.Pool (Pool) import Data.Pool.Acquire (poolToAcquire)-import Database.Persist.Sql (SqlBackend, runSqlConn)+import Database.Persist.Sql (SqlBackend, SqlPersistT, runSqlConn)+import qualified GHC.TypeLits as GHC+import UnliftIO.Concurrent (threadDelay)+import UnliftIO.Exception (Exception, SomeException, catchJust, throwIO) +import Control.Monad.IO.Rerunnable (MonadRerunnableIO) import Database.Persist.Monad.Class 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++-- | 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'. data SqlQueryEnv = SqlQueryEnv   { backendPool :: Pool SqlBackend-  , currentConn :: Maybe SqlBackend+    -- ^ 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.   } +-- | Build a SqlQueryEnv from the default.+--+-- Usage:+--+-- @+-- 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+  }+ -- | The monad transformer that implements 'MonadSqlQuery'. newtype SqlQueryT m a = SqlQueryT   { unSqlQueryT :: ReaderT SqlQueryEnv m a@@ -82,19 +180,28 @@     , MonadIO     , MonadTrans     , MonadResource+    , MonadRerunnableIO     )  instance MonadUnliftIO m => MonadSqlQuery (SqlQueryT m) where-  runQueryRep queryRep = do-    SqlQueryEnv{currentConn} <- SqlQueryT ask-    case currentConn of-      Just conn -> runWithConn conn-      Nothing -> withTransactionConn runWithConn-    where-      runWithConn = runReaderT (runSqlQueryRep queryRep)+  type TransactionM (SqlQueryT m) = SqlTransaction (SqlQueryT m) -  withTransaction action = withTransactionConn $ \_ -> action+  -- Running a query directly in SqlQueryT will create a one-off transaction.+  runQueryRep = withTransaction . runQueryRep +  -- Start a new transaction and run the given 'SqlTransaction'+  withTransaction m = do+    SqlQueryEnv{..} <- SqlQueryT ask+    withAcquire (poolToAcquire backendPool) $ \conn ->+      let filterRetry e = if retryIf e then Just e else Nothing+          loop i = catchJust filterRetry (runSqlTransaction conn m) $ \_ ->+            if i < retryLimit+              then do+                threadDelay $ 1000 * 2^i+                loop $! i + 1+              else throwIO RetryLimitExceeded+      in loop 0+ instance MonadUnliftIO m => MonadUnliftIO (SqlQueryT m) where   withRunInIO = wrappedWithRunInIO SqlQueryT unSqlQueryT @@ -102,16 +209,9 @@  -- | Run the 'SqlQueryT' monad transformer with the given backend. runSqlQueryT :: Pool SqlBackend -> SqlQueryT m a -> m a-runSqlQueryT backendPool = (`runReaderT` env) . unSqlQueryT-  where-    env = SqlQueryEnv { currentConn = Nothing, .. }+runSqlQueryT backendPool = runSqlQueryTWith $ mkSqlQueryEnv backendPool id --- | Start a new transaction and get the connection.-withTransactionConn :: MonadUnliftIO m => (SqlBackend -> SqlQueryT m a) -> SqlQueryT m a-withTransactionConn f = do-  SqlQueryEnv{backendPool} <- SqlQueryT ask-  withAcquire (poolToAcquire backendPool) $ \conn ->-    SqlQueryT . local (setCurrentConn conn) . unSqlQueryT $-      runSqlConn (lift $ f conn) conn-  where-    setCurrentConn conn env = env { currentConn = Just conn }+-- | Run the 'SqlQueryT' monad transformer with the explicitly provided+-- environment.+runSqlQueryTWith :: SqlQueryEnv -> SqlQueryT m a -> m a+runSqlQueryTWith env = (`runReaderT` env) . unSqlQueryT

@@ -6,6 +6,7 @@ 'Database.Persist.Monad.SqlQueryRep.SqlQueryRep' sent by a lifted function from @Database.Persist.Monad.Shim@. -}+{-# LANGUAGE TypeFamilies #-}  module Database.Persist.Monad.Class   ( MonadSqlQuery(..)@@ -22,61 +23,69 @@ 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+import Data.Kind (Type) import Data.Typeable (Typeable)  import Database.Persist.Monad.SqlQueryRep (SqlQueryRep)  -- | The type-class for monads that can run persistent database queries. class Monad m => MonadSqlQuery m where-  -- | The main function that interprets a SQL query operation and runs it-  -- in the monadic context.+  type TransactionM m :: Type -> Type++  -- | Interpret the given SQL query operation.   runQueryRep :: Typeable record => SqlQueryRep record a -> m a    -- | Run all queries in the given action using the same database connection.-  ---  -- You should make sure to not fork any threads within this action. This-  -- will almost certainly cause problems.-  -- https://github.com/brandonchinn178/persistent-mtl/issues/7-  withTransaction :: m a -> m a+  withTransaction :: TransactionM m a -> m a  {- Instances for common monad transformers -}  instance MonadSqlQuery m => MonadSqlQuery (Reader.ReaderT r m) where+  type TransactionM (Reader.ReaderT r m) = TransactionM m   runQueryRep = lift . runQueryRep-  withTransaction = Reader.mapReaderT withTransaction+  withTransaction = lift . withTransaction  instance MonadSqlQuery m => MonadSqlQuery (Except.ExceptT e m) where+  type TransactionM (Except.ExceptT e m) = TransactionM m   runQueryRep = lift . runQueryRep-  withTransaction = Except.mapExceptT withTransaction+  withTransaction = lift . withTransaction  instance MonadSqlQuery m => MonadSqlQuery (Identity.IdentityT m) where+  type TransactionM (Identity.IdentityT m) = TransactionM m   runQueryRep = lift . runQueryRep-  withTransaction = Identity.mapIdentityT withTransaction+  withTransaction = lift . withTransaction  instance MonadSqlQuery m => MonadSqlQuery (Maybe.MaybeT m) where+  type TransactionM (Maybe.MaybeT m) = TransactionM m   runQueryRep = lift . runQueryRep-  withTransaction = Maybe.mapMaybeT withTransaction+  withTransaction = lift . withTransaction  instance (Monoid w, MonadSqlQuery m) => MonadSqlQuery (RWS.Lazy.RWST r w s m) where+  type TransactionM (RWS.Lazy.RWST r w s m) = TransactionM m   runQueryRep = lift . runQueryRep-  withTransaction = RWS.Lazy.mapRWST withTransaction+  withTransaction = lift . withTransaction  instance (Monoid w, MonadSqlQuery m) => MonadSqlQuery (RWS.Strict.RWST r w s m) where+  type TransactionM (RWS.Strict.RWST r w s m) = TransactionM m   runQueryRep = lift . runQueryRep-  withTransaction = RWS.Strict.mapRWST withTransaction+  withTransaction = lift . withTransaction  instance MonadSqlQuery m => MonadSqlQuery (State.Lazy.StateT s m) where+  type TransactionM (State.Lazy.StateT s m) = TransactionM m   runQueryRep = lift . runQueryRep-  withTransaction = State.Lazy.mapStateT withTransaction+  withTransaction = lift . withTransaction  instance MonadSqlQuery m => MonadSqlQuery (State.Strict.StateT s m) where+  type TransactionM (State.Strict.StateT s m) = TransactionM m   runQueryRep = lift . runQueryRep-  withTransaction = State.Strict.mapStateT withTransaction+  withTransaction = lift . withTransaction  instance (Monoid w, MonadSqlQuery m) => MonadSqlQuery (Writer.Lazy.WriterT w m) where+  type TransactionM (Writer.Lazy.WriterT w m) = TransactionM m   runQueryRep = lift . runQueryRep-  withTransaction = Writer.Lazy.mapWriterT withTransaction+  withTransaction = lift . withTransaction  instance (Monoid w, MonadSqlQuery m) => MonadSqlQuery (Writer.Strict.WriterT w m) where+  type TransactionM (Writer.Strict.WriterT w m) = TransactionM m   runQueryRep = lift . runQueryRep-  withTransaction = Writer.Strict.mapWriterT withTransaction+  withTransaction = lift . withTransaction

@@ -11,6 +11,7 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}  module Database.Persist.Monad.TestUtils   ( MockSqlQueryT@@ -18,12 +19,16 @@   , withRecord   , mockQuery   , MockQuery+   -- * Specialized helpers   , mockSelectSource   , mockSelectKeys   , mockWithRawQuery   , mockRawQuery   , mockRawSql++  -- * Re-exports+  , SqlQueryRep(..)   ) where  import Conduit ((.|))@@ -85,6 +90,8 @@ runMockSqlQueryT action mockQueries = (`runReaderT` mockQueries) . unMockSqlQueryT $ action  instance MonadIO m => MonadSqlQuery (MockSqlQueryT m) where+  type TransactionM (MockSqlQueryT m) = MockSqlQueryT m+   runQueryRep rep = do     mockQueries <- MockSqlQueryT ask     maybe (error $ "Could not find mock for query: " ++ show rep) liftIO

@@ -17,6 +17,7 @@ module Example   ( TestApp   , runTestApp+  , runTestAppWith      -- * Person   , Person(..)@@ -40,11 +41,9 @@  import Control.Arrow ((&&&)) import Control.Monad.IO.Class (MonadIO(..))-import Control.Monad.Logger (runNoLoggingT) import Control.Monad.Trans.Resource (MonadResource, ResourceT, runResourceT)-import qualified Data.Text as Text-import Database.Persist.Sql (Entity(..), EntityField, Key, Unique, toSqlKey)-import Database.Persist.Sqlite (withSqlitePool)+import Database.Persist.Sql+    (Entity(..), EntityField, Key, SelectOpt(..), Unique, toSqlKey) import Database.Persist.TH     ( mkDeleteCascade     , mkMigrate@@ -53,9 +52,11 @@     , share     , sqlSettings     )-import UnliftIO (MonadUnliftIO(..), withSystemTempDirectory, wrappedWithRunInIO)+import UnliftIO (MonadUnliftIO(..), wrappedWithRunInIO) +import Control.Monad.IO.Rerunnable (MonadRerunnableIO) import Database.Persist.Monad+import TestUtils.DB (BackendType(..), withTestDB)  share   [ mkPersist sqlSettings@@ -96,6 +97,7 @@     , Applicative     , Monad     , MonadIO+    , MonadRerunnableIO     , MonadSqlQuery     , MonadResource     )@@ -103,15 +105,21 @@ instance MonadUnliftIO TestApp where   withRunInIO = wrappedWithRunInIO TestApp unTestApp -runTestApp :: TestApp a -> IO a-runTestApp m =-  withSystemTempDirectory "persistent-mtl-testapp" $ \dir -> do-    let db = Text.pack $ dir ++ "/db.sqlite"-    runNoLoggingT $ withSqlitePool db 5 $ \pool ->-      liftIO . runResourceT . runSqlQueryT pool . unTestApp $ do-        _ <- runMigrationSilent migration-        m+runTestApp :: BackendType -> TestApp a -> IO a+runTestApp backendType m =+  withTestDB backendType $ \pool ->+    runResourceT . runSqlQueryT pool . unTestApp $ do+      _ <- runMigrationSilent migration+      m +runTestAppWith :: BackendType -> (SqlQueryEnv -> SqlQueryEnv) -> TestApp a -> IO a+runTestAppWith backendType f m =+  withTestDB backendType $ \pool -> do+    let env = mkSqlQueryEnv pool f+    runResourceT . runSqlQueryTWith env . unTestApp $ do+      _ <- runMigrationSilent migration+      m+ {- Person functions -}  person :: String -> Person@@ -121,7 +129,7 @@ getName = personName . entityVal  getPeople :: MonadSqlQuery m => m [Person]-getPeople = map entityVal <$> selectList [] []+getPeople = map entityVal <$> selectList [] [Asc PersonId]  getPeopleNames :: MonadSqlQuery m => m [String] getPeopleNames = map personName <$> getPeople

@@ -12,9 +12,9 @@ import Data.Map (Map) import Data.Text (Text) import Data.Void (Void)-import Database.Persist.Sql hiding (pattern Update)+import Database.Persist.Sql (CautiousMigration, Entity, Key, PersistValue, Sql) -import Database.Persist.Monad+import Database.Persist.Monad.TestUtils (SqlQueryRep(..)) import Example  {-# ANN module "HLint: ignore" #-}

@@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-}@@ -16,6 +17,7 @@ import Data.Typeable (Typeable) import Database.Persist.Sql     ( Entity(..)+    , Migration     , PersistField     , PersistRecordBackend     , PersistValue@@ -30,68 +32,151 @@ #endif import Test.Tasty import Test.Tasty.HUnit-import UnliftIO (Exception, MonadIO, MonadUnliftIO, liftIO, throwIO, try)+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.Match (Match(..), (@?~))  tests :: TestTree-tests = testGroup "Integration tests"-  [ testWithTransaction-  , testPersistentAPI+tests = testGroup "Integration tests" $+  map testsWithBackend allBackendTypes++testsWithBackend :: BackendType -> TestTree+testsWithBackend backendType = testGroup (show backendType)+  [ testWithTransaction backendType+  , testComposability backendType+  , testPersistentAPI backendType   ] -testWithTransaction :: TestTree-testWithTransaction = testGroup "withTransaction"+testWithTransaction :: BackendType -> TestTree+testWithTransaction backendType = testGroup "withTransaction"   [ testCase "it uses the same transaction" $ do       -- without transactions, the INSERT shouldn't be rolled back-      runTestApp $ do+      runTestApp backendType $ do         catchTestError $ insertAndFail $ person "Alice"         result <- getPeopleNames         liftIO $ result @?= ["Alice"]        -- with transactions, the INSERT should be rolled back-      runTestApp $ do+      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   ] -testPersistentAPI :: TestTree-testPersistentAPI = testGroup "Persistent API"+-- 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 $ do+      result <- runTestApp backendType $ do         insert_ $ person "Alice"         mapM get [1, 2]       map (fmap personName) result @?= [Just "Alice", Nothing]    , testCase "getMany" $ do-      result <- runTestApp $ do+      result <- runTestApp backendType $ do         insert_ $ person "Alice"         getMany [1]       personName <$> Map.lookup 1 result @?= Just "Alice"    , testCase "getJust" $ do-      result <- runTestApp $ do+      result <- runTestApp backendType $ do         insert_ $ person "Alice"         getJust 1       personName result @?= "Alice"    , testCase "getJustEntity" $ do-      result <- runTestApp $ do+      result <- runTestApp backendType $ do         insert_ $ person "Alice"         getJustEntity 1       getName result @?= "Alice"    , testCase "getEntity" $ do-      result <- runTestApp $ do+      result <- runTestApp backendType $ do         insert_ $ person "Alice"         mapM getEntity [1, 2]       map (fmap getName) result @?= [Just "Alice", Nothing]    , testCase "belongsTo" $ do-      result <- runTestApp $ do+      result <- runTestApp backendType $ do         aliceKey <- insert $ person "Alice"         let post1 = Post "Post #1" aliceKey (Just aliceKey)             post2 = Post "Post #2" aliceKey Nothing@@ -100,7 +185,7 @@       map (fmap personName) result @?= [Just "Alice", Nothing]    , testCase "belongsToJust" $ do-      result <- runTestApp $ do+      result <- runTestApp backendType $ do         aliceKey <- insert $ person "Alice"         let post1 = Post "Post #1" aliceKey Nothing         insert_ post1@@ -108,35 +193,35 @@       personName result @?= "Alice"    , testCase "insert" $ do-      result <- runTestApp $ do+      result <- runTestApp backendType $ do         aliceKey <- insert $ person "Alice"         people <- getPeopleNames         return (aliceKey, people)       result @?= (1, ["Alice"])    , testCase "insert_" $ do-      result <- runTestApp $ do+      result <- runTestApp backendType $ do         result <- insert_ $ person "Alice"         people <- getPeopleNames         return (result, people)       result @?= ((), ["Alice"])    , testCase "insertMany" $ do-      result <- runTestApp $ 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 $ do+      result <- runTestApp backendType $ do         result <- insertMany_ [person "Alice", person "Bob"]         people <- getPeopleNames         return (result, people)       result @?= ((), ["Alice", "Bob"])    , testCase "insertEntityMany" $ do-      result <- runTestApp $ do+      result <- runTestApp backendType $ do         result <- insertEntityMany           [ Entity 1 $ person "Alice"           , Entity 2 $ person "Bob"@@ -146,14 +231,14 @@       result @?= ((), ["Alice", "Bob"])    , testCase "insertKey" $ do-      result <- runTestApp $ do+      result <- runTestApp backendType $ do         result <- insertKey 1 $ person "Alice"         people <- getPeopleNames         return (result, people)       result @?= ((), ["Alice"])    , testCase "repsert" $ do-      result <- runTestApp $ do+      result <- runTestApp backendType $ do         let alice = person "Alice"         insert_ alice         repsert 1 $ alice { personAge = 100 }@@ -165,7 +250,7 @@         ]    , testCase "repsertMany" $ do-      result <- runTestApp $ do+      result <- runTestApp backendType $ do         let alice = person "Alice" -- https://github.com/yesodweb/persistent/issues/832 #if MIN_VERSION_persistent(2,9,0)@@ -185,7 +270,7 @@         ]    , testCase "replace" $ do-      result <- runTestApp $ do+      result <- runTestApp backendType $ do         let alice = person "Alice"         insert_ alice         replace 1 $ alice { personAge = 100 }@@ -193,21 +278,21 @@       personAge result @?= 100    , testCase "delete" $ do-      result <- runTestApp $ do+      result <- runTestApp backendType $ do         aliceKey <- insert $ person "Alice"         delete aliceKey         getPeople       result @?= []    , testCase "update" $ do-      result <- runTestApp $ do+      result <- runTestApp backendType $ do         key <- insert $ person "Alice"         update key [PersonName =. "Alicia"]         getPeopleNames       result @?= ["Alicia"]    , testCase "updateGet" $ do-      (updateResult, getResult) <- runTestApp $ do+      (updateResult, getResult) <- runTestApp backendType $ do         key <- insert $ person "Alice"         updateResult <- updateGet key [PersonName =. "Alicia"]         getResult <- getJust key@@ -215,34 +300,34 @@       updateResult @?= getResult    , testCase "insertEntity" $ do-      (insertResult, getResult) <- runTestApp $ 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 $ do+      (insertResult, getResult) <- runTestApp backendType $ do         insertResult <- insertRecord $ person "Alice"         getResult <- getJust 1         return (insertResult, getResult)       insertResult @?= getResult    , testCase "getBy" $ do-      result <- runTestApp $ 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 $ 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 $ do+      result <- runTestApp backendType $ do         let alice = person "Alice"         insert_ alice         mapM checkUnique@@ -254,7 +339,7 @@  #if MIN_VERSION_persistent(2,11,0)   , testCase "checkUniqueUpdateable" $ do-      result <- runTestApp $ do+      result <- runTestApp backendType $ do         let alice = person "Alice"         insert_ alice         mapM checkUniqueUpdateable@@ -266,14 +351,14 @@ #endif    , testCase "deleteBy" $ do-      result <- runTestApp $ do+      result <- runTestApp backendType $ do         insert_ $ person "Alice"         deleteBy $ UniqueName "Alice"         getPeople       result @?= []    , testCase "insertUnique" $ do-      (result1, result2, people) <- runTestApp $ do+      (result1, result2, people) <- runTestApp backendType $ do         result1 <- insertUnique $ person "Alice"         result2 <- insertUnique $ person "Alice"         people <- getPeopleNames@@ -283,7 +368,7 @@       people @?= ["Alice"]    , testCase "upsert" $ do-      (result1, result2, people) <- runTestApp $ do+      (result1, result2, people) <- runTestApp backendType $ do         result1 <- upsert (person "Alice") [PersonAge =. 0]         result2 <- upsert (person "Alice") [PersonAge =. 100]         people <- getPeople@@ -294,7 +379,7 @@       map nameAndAge people @?= [("Alice", 100)]    , testCase "upsertBy" $ do-      (result1, result2, people) <- runTestApp $ 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@@ -305,7 +390,7 @@       map nameAndAge people @?= [("Alice", 100)]    , testCase "putMany" $ do-      result <- runTestApp $ do+      result <- runTestApp backendType $ do         let alice = person "Alice"         insert_ alice         putMany@@ -319,7 +404,7 @@         ]    , testCase "insertBy" $ do-      (result1, result2, people) <- runTestApp $ do+      (result1, result2, people) <- runTestApp backendType $ do         let alice = person "Alice"         result1 <- insertBy alice         result2 <- insertBy $ alice { personAge = 100 }@@ -330,7 +415,7 @@       map nameAndAge people @?= [("Alice", 0)]    , testCase "insertUniqueEntity" $ do-      (result1, result2, people) <- runTestApp $ do+      (result1, result2, people) <- runTestApp backendType $ do         let alice = person "Alice"         result1 <- insertUniqueEntity alice         result2 <- insertUniqueEntity $ alice { personAge = 100 }@@ -341,7 +426,7 @@       map nameAndAge people @?= [("Alice", 0)]    , testCase "replaceUnique" $ do-      (result1, result2, people) <- runTestApp $ do+      (result1, result2, people) <- runTestApp backendType $ do         let alice = person "Alice"             bob = person "Bob"         insertMany_ [alice, bob]@@ -354,11 +439,11 @@       map nameAndAge people @?= [("Alice", 0), ("Bob", 100)]    , testCase "onlyUnique" $ do-      result <- runTestApp $ onlyUnique $ person "Alice"+      result <- runTestApp backendType $ onlyUnique $ person "Alice"       result @?= UniqueName "Alice"    , testCase "selectSourceRes" $ do-      result <- runTestApp $ do+      result <- runTestApp backendType $ do         insertMany_ [person "Alice", person "Bob"]         acquire <- selectSourceRes [] []         Acquire.with acquire $ \conduit ->@@ -366,7 +451,7 @@       result @?= ["Alice", "Bob"]    , testCase "selectFirst" $ do-      result <- runTestApp $ do+      result <- runTestApp backendType $ do         insert_ $ person "Alice"         sequence           [ selectFirst [PersonName ==. "Alice"] []@@ -375,7 +460,7 @@       map (fmap getName) result @?= [Just "Alice", Nothing]    , testCase "selectKeysRes" $ do-      result <- runTestApp $ do+      result <- runTestApp backendType $ do         insertMany_ [person "Alice", person "Bob"]         acquire <- selectKeysRes @_ @Person [] []         Acquire.with acquire $ \conduit ->@@ -383,61 +468,61 @@       result @?= [1, 2]    , testCase "count" $ do-      result <- runTestApp $ 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 $ do+      result <- runTestApp backendType $ do         insertMany_ [person "Alice", person "Bob"]         exists [PersonName ==. "Alice"]       result @?= True #endif    , testCase "selectSource" $ do-      result <- runTestApp $ 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 $ do+      result <- runTestApp backendType $ do         insertMany_ [person "Alice", person "Bob"]         runConduit $ selectKeys @Person [] [] .| Conduit.sinkList       result @?= [1, 2]    , testCase "selectList" $ do-      result <- runTestApp $ do+      result <- runTestApp backendType $ do         insert_ $ person "Alice"         insert_ $ person "Bob"         selectList [] []       map getName result @?= ["Alice", "Bob"]    , testCase "selectKeysList" $ do-      result <- runTestApp $ do+      result <- runTestApp backendType $ do         insert_ $ person "Alice"         insert_ $ person "Bob"         selectKeysList @Person [] []       result @?= [1, 2]    , testCase "updateWhere" $ do-      result <- runTestApp $ 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 $ do+      result <- runTestApp backendType $ do         insertMany_ [person "Alice", person "Bob"]         deleteWhere [PersonName ==. "Alice"]         getPeopleNames       result @?= ["Bob"]    , testCase "updateWhereCount" $ do-      (rowsUpdated, people) <- runTestApp $ do+      (rowsUpdated, people) <- runTestApp backendType $ do         insertMany_ [person "Alice", person "Bob"]         rowsUpdated <- updateWhereCount [PersonName ==. "Alice"] [PersonAge =. 100]         people <- getPeople@@ -446,7 +531,7 @@       map nameAndAge people @?= [("Alice", 100), ("Bob", 0)]    , testCase "deleteWhereCount" $ do-      (rowsDeleted, names) <- runTestApp $ do+      (rowsDeleted, names) <- runTestApp backendType $ do         insertMany_ [person "Alice", person "Bob"]         rowsDeleted <- deleteWhereCount [PersonName ==. "Alice"]         names <- getPeopleNames@@ -455,7 +540,7 @@       names @?= ["Bob"]    , testCase "deleteCascade" $ do-      (people, posts) <- runTestApp $ do+      (people, posts) <- runTestApp backendType $ do         aliceKey <- insert $ person "Alice"         bobKey <- insert $ person "Bob"         insertMany_@@ -470,7 +555,7 @@       posts @?= ["Post #2"]    , testCase "deleteCascadeWhere" $ do-      (people, posts) <- runTestApp $ do+      (people, posts) <- runTestApp backendType $ do         aliceKey <- insert $ person "Alice"         bobKey <- insert $ person "Bob"         insertMany_@@ -485,29 +570,37 @@       posts @?= ["Post #2"]    , testCase "parseMigration" $ do-      result <- runTestApp $ do+      result <- runTestApp backendType $ do         setupUnsafeMigration         parseMigration migration-      result @?~ Right @[Text]-        [ Match-            ( 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-        , Match (True, "DROP TABLE \"person\"")-        , Anything-        , Anything-        , Match (False, "DROP TABLE \"person_backup\"")-        ] +      let sql = case backendType of+            Sqlite ->+              [ Match+                  ( 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+              , Match (True, "DROP TABLE \"person\"")+              , Anything+              , Anything+              , Match (False, "DROP TABLE \"person_backup\"")+              ]+            Postgresql ->+              [ Match (True, "ALTER TABLE \"person\" DROP COLUMN \"foo\"")+              ]++      result @?~ Right @[Text] sql+   , testCase "parseMigration'" $ do-      let action f = runTestApp $ do+      let action :: (Migration -> TestApp a) -> IO a+          action f = runTestApp backendType $ do             setupUnsafeMigration             f migration @@ -516,63 +609,77 @@       Right result' @?= result    , testCase "printMigration" $-      runTestApp $ do+      runTestApp backendType $ do         setupUnsafeMigration         printMigration migration    , testCase "showMigration" $ do-      result <- runTestApp $ do+      result <- runTestApp backendType $ do         setupUnsafeMigration         showMigration migration-      result @?~-        [ Match $ 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-        , Match "DROP TABLE \"person\";"-        , Anything-        , Anything-        , Match "DROP TABLE \"person_backup\";"-        ] +      let sql = case backendType of+            Sqlite ->+              [ Match $ 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+              , Match "DROP TABLE \"person\";"+              , Anything+              , Anything+              , Match "DROP TABLE \"person_backup\";"+              ]+            Postgresql ->+              [ Match "ALTER TABLE \"person\" DROP COLUMN \"foo\";"+              ]++      result @?~ sql+   , testCase "getMigration" $ do-      result <- runTestApp $ do+      result <- runTestApp backendType $ do         setupUnsafeMigration         getMigration migration-      result @?~-        [ Match $ 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-        , Match "DROP TABLE \"person\""-        , Anything-        , Anything-        , Match "DROP TABLE \"person_backup\""-        ] +      let sql = case backendType of+            Sqlite ->+              [ Match $ 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+              , Match "DROP TABLE \"person\""+              , Anything+              , Anything+              , Match "DROP TABLE \"person_backup\""+              ]+            Postgresql ->+              [ Match "ALTER TABLE \"person\" DROP COLUMN \"foo\""+              ]++      result @?~ sql+   , testCase "runMigration" $ do-      result <- runTestApp $ do+      result <- runTestApp backendType $ do         setupSafeMigration         runMigration migration-        getSchemaColumnNames "person"+        getSchemaColumnNames backendType "person"       assertNotIn "removed_column" result  #if MIN_VERSION_persistent(2,10,2)   , testCase "runMigrationQuiet" $ do-      (withQuiet, cols) <- runTestApp $ do+      (withQuiet, cols) <- runTestApp backendType $ do         setupSafeMigration         sql <- runMigrationQuiet migration-        cols <- getSchemaColumnNames "person"+        cols <- getSchemaColumnNames backendType "person"         return (sql, cols)-      withSilent <- runTestApp $ do+      withSilent <- runTestApp backendType $ do         setupSafeMigration         runMigrationSilent migration       assertNotIn "removed_column" cols@@ -580,46 +687,46 @@ #endif    , testCase "runMigrationSilent" $ do-      (sqlPlanned, sqlExecuted, cols) <- runTestApp $ do+      (sqlPlanned, sqlExecuted, cols) <- runTestApp backendType $ do         setupSafeMigration         sqlPlanned <- getMigration migration         sqlExecuted <- runMigrationSilent migration-        cols <- getSchemaColumnNames "person"+        cols <- getSchemaColumnNames backendType "person"         return (sqlPlanned, sqlExecuted, cols)       assertNotIn "removed_column" cols       sqlExecuted @?= sqlPlanned    , testCase "runMigrationUnsafe" $ do-      result <- runTestApp $ do+      result <- runTestApp backendType $ do         setupUnsafeMigration         runMigrationUnsafe migration-        getSchemaColumnNames "person"+        getSchemaColumnNames backendType "person"       assertNotIn "removed_column" result  #if MIN_VERSION_persistent(2,10,2)   , testCase "runMigrationUnsafeQuiet" $ do-      (sqlPlanned, sqlExecuted, cols) <- runTestApp $ do+      (sqlPlanned, sqlExecuted, cols) <- runTestApp backendType $ do         setupUnsafeMigration         sqlPlanned <- getMigration migration         sqlExecuted <- runMigrationUnsafeQuiet migration-        cols <- getSchemaColumnNames "person"+        cols <- getSchemaColumnNames backendType "person"         return (sqlPlanned, sqlExecuted, cols)       assertNotIn "removed_column" cols       sqlExecuted @?= sqlPlanned #endif    , testCase "getFieldName" $ do-      result <- runTestApp $+      result <- runTestApp backendType $         getFieldName PersonName       result @?= "\"name\""    , testCase "getTableName" $ do-      result <- runTestApp $+      result <- runTestApp backendType $         getTableName $ person "Alice"       result @?= "\"person\""    , testCase "withRawQuery" $ do-      result <- runTestApp $ do+      result <- runTestApp backendType $ do         insertMany_ [person "Alice", person "Bob"]         withRawQuery "SELECT name FROM person" [] $           Conduit.mapC (fromPersistValue' @Text . head) .| Conduit.sinkList@@ -627,7 +734,7 @@       result @?= ["Alice", "Bob"]    , testCase "rawQueryRes" $ do-      result <- runTestApp $ do+      result <- runTestApp backendType $ do         insertMany_ [person "Alice", person "Bob"]         acquire <- rawQueryRes "SELECT name FROM person" []         Acquire.with acquire $ \conduit ->@@ -635,20 +742,20 @@       result @?= ["Alice", "Bob"]    , testCase "rawQuery" $ do-      result <- runTestApp $ 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 $ 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 $ do+      (rowsUpdated, people) <- runTestApp backendType $ do         insertMany_ [person "Alice", person "Bob"]         rowsUpdated <- rawExecuteCount "UPDATE person SET age = 100 WHERE name = 'Alice'" []         people <- getPeople@@ -657,20 +764,20 @@       map nameAndAge people @?= [("Alice", 100), ("Bob", 0)]    , testCase "rawSql" $ do-      result <- runTestApp $ 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 $ do+      result1 <- runTestApp backendType $ do         catchTestError $ withTransaction $ do           insert_ $ person "Alice"           insertAndFail $ person "Bob"         getPeopleNames       result1 @?= [] -      result2 <- runTestApp $ do+      result2 <- runTestApp backendType $ do         catchTestError $ withTransaction $ do           insert_ $ person "Alice"           transactionSave@@ -680,14 +787,14 @@  #if MIN_VERSION_persistent(2,9,0)   , testCase "transactionSaveWithIsolation" $ do-      result1 <- runTestApp $ do+      result1 <- runTestApp backendType $ do         catchTestError $ withTransaction $ do           insert_ $ person "Alice"           insertAndFail $ person "Bob"         getPeopleNames       result1 @?= [] -      result2 <- runTestApp $ do+      result2 <- runTestApp backendType $ do         catchTestError $ withTransaction $ do           insert_ $ person "Alice"           transactionSaveWithIsolation Serializable@@ -697,7 +804,7 @@ #endif    , testCase "transactionUndo" $ do-      result <- runTestApp $ withTransaction $ do+      result <- runTestApp backendType $ withTransaction $ do         insert_ $ person "Alice"         transactionUndo         getPeopleNames@@ -705,7 +812,7 @@  #if MIN_VERSION_persistent(2,9,0)   , testCase "transactionUndoWithIsolation" $ do-      result <- runTestApp $ withTransaction $ do+      result <- runTestApp backendType $ withTransaction $ do         insert_ $ person "Alice"         transactionUndoWithIsolation Serializable         getPeopleNames@@ -729,10 +836,15 @@ setupUnsafeMigration = rawExecute "ALTER TABLE person ADD COLUMN foo VARCHAR" []  -- | Get the names of all columns in the given table.-getSchemaColumnNames :: MonadSqlQuery m => String -> m [String]-getSchemaColumnNames tableName = map unSingle <$> rawSql sql []+getSchemaColumnNames :: MonadSqlQuery m => BackendType -> String -> m [String]+getSchemaColumnNames backendType tableName = map unSingle <$> rawSql sql []   where-    sql = Text.pack $ "SELECT name FROM pragma_table_info('" ++ tableName ++ "')"+    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 -} @@ -747,7 +859,7 @@   liftIO $ result @?= Left TestError  insertAndFail ::-  ( MonadIO m+  ( MonadRerunnableIO m   , MonadSqlQuery m   , PersistRecordBackend record SqlBackend   , Typeable record@@ -755,7 +867,7 @@   => record -> m () insertAndFail record = do   insert_ record-  throwIO TestError+  rerunnableIO $ throwIO TestError  assertNotIn :: (Eq a, Show a) => a -> [a] -> Assertion assertNotIn a as = as @?= filter (/= a) as

@@ -10,7 +10,6 @@ import Test.Tasty.HUnit import UnliftIO (SomeException, try) -import Database.Persist.Monad import Database.Persist.Monad.TestUtils import Example 

@@ -0,0 +1,49 @@+{-# LANGUAGE OverloadedStrings #-}++module TestUtils.DB+  ( BackendType(..)+  , allBackendTypes+  , withTestDB+  ) where++import Control.Monad.Logger (runNoLoggingT)+import qualified Data.ByteString.Char8 as Char8+import Data.Maybe (fromMaybe)+import Data.Pool (Pool)+import qualified Data.Text as Text+import Database.Persist.Postgresql (withPostgresqlPool)+import Database.Persist.Sql (SqlBackend, rawExecute, runSqlPool)+import Database.Persist.Sqlite (withSqlitePool)+import System.Environment (lookupEnv)+import System.IO.Unsafe (unsafePerformIO)+import UnliftIO (liftIO, withSystemTempDirectory)++data BackendType = Sqlite | Postgresql+  deriving (Show)++allBackendTypes :: [BackendType]+allBackendTypes = Sqlite : [Postgresql | isEnabled "TEST_POSTGRESQL"]+  where+    isEnabled envVarName = unsafePerformIO (lookupEnv envVarName) == Just "1"++withTestDB :: BackendType -> (Pool SqlBackend -> IO a) -> IO a+withTestDB Sqlite = withTestDBSqlite+withTestDB Postgresql = withTestDBPostgresql++withTestDBSqlite :: (Pool SqlBackend -> IO a) -> IO a+withTestDBSqlite f =+  withSystemTempDirectory "persistent-mtl-testapp" $ \dir -> do+    let db = Text.pack $ dir ++ "/db.sqlite"+    runNoLoggingT $ withSqlitePool db 5 $ \pool -> liftIO $ f pool++-- Requires running database, with connection string specified in POSTGRESQL_URL+withTestDBPostgresql :: (Pool SqlBackend -> IO a) -> IO a+withTestDBPostgresql f = do+  url <- fromMaybe defaultUrl <$> lookupEnv "POSTGRESQL_URL"+  runNoLoggingT $ withPostgresqlPool (Char8.pack url) 5 $ \pool -> do+    (`runSqlPool` pool) $+      rawExecute "DROP SCHEMA public CASCADE; CREATE SCHEMA public;" []++    liftIO $ f pool+  where+    defaultUrl = "postgresql://postgres@localhost/persistent_mtl"