{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
module Database.Persist.Monad (
MonadSqlQuery,
withTransaction,
SqlQueryT (..),
mapSqlQueryT,
runSqlQueryT,
runSqlQueryTWith,
SqlQueryEnv (..),
mkSqlQueryEnv,
getSqlBackendPool,
SqlTransaction,
TransactionError (..),
catchSqlTransaction,
module Database.Persist.Monad.Shim,
) where
import Control.Monad.Catch (MonadCatch, MonadMask, MonadThrow)
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 (..), 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)
import UnliftIO.Concurrent (threadDelay)
import UnliftIO.Exception (Exception, SomeException, catchJust, throwIO)
import UnliftIO.Pool (withResource)
import Control.Monad.IO.Rerunnable (MonadRerunnableIO)
import Database.Persist.Monad.Class
import Database.Persist.Monad.Internal.SqlTransaction
import Database.Persist.Monad.Shim
data SqlQueryEnv = SqlQueryEnv
{ SqlQueryEnv -> Pool SqlBackend
backendPool :: Pool SqlBackend
, SqlQueryEnv -> SomeException -> Bool
retryIf :: SomeException -> Bool
, SqlQueryEnv -> Int
retryLimit :: Int
, SqlQueryEnv -> SomeException -> IO ()
retryCallback :: SomeException -> IO ()
}
mkSqlQueryEnv :: Pool SqlBackend -> (SqlQueryEnv -> SqlQueryEnv) -> SqlQueryEnv
mkSqlQueryEnv :: Pool SqlBackend -> (SqlQueryEnv -> SqlQueryEnv) -> SqlQueryEnv
mkSqlQueryEnv Pool SqlBackend
backendPool SqlQueryEnv -> SqlQueryEnv
f =
SqlQueryEnv -> SqlQueryEnv
f
SqlQueryEnv
{ Pool SqlBackend
backendPool :: Pool SqlBackend
backendPool :: Pool SqlBackend
backendPool
, retryIf :: SomeException -> Bool
retryIf = forall a b. a -> b -> a
const Bool
False
, retryLimit :: Int
retryLimit = Int
10
, retryCallback :: SomeException -> IO ()
retryCallback = \SomeException
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
}
newtype SqlQueryT m a = SqlQueryT
{ forall (m :: * -> *) a. SqlQueryT m a -> ReaderT SqlQueryEnv m a
unSqlQueryT :: ReaderT SqlQueryEnv m a
}
deriving
( forall a b. a -> SqlQueryT m b -> SqlQueryT m a
forall a b. (a -> b) -> SqlQueryT m a -> SqlQueryT m b
forall (m :: * -> *) a b.
Functor m =>
a -> SqlQueryT m b -> SqlQueryT m a
forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> SqlQueryT m a -> SqlQueryT m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> SqlQueryT m b -> SqlQueryT m a
$c<$ :: forall (m :: * -> *) a b.
Functor m =>
a -> SqlQueryT m b -> SqlQueryT m a
fmap :: forall a b. (a -> b) -> SqlQueryT m a -> SqlQueryT m b
$cfmap :: forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> SqlQueryT m a -> SqlQueryT m b
Functor
, forall a. a -> SqlQueryT m a
forall a b. SqlQueryT m a -> SqlQueryT m b -> SqlQueryT m a
forall a b. SqlQueryT m a -> SqlQueryT m b -> SqlQueryT m b
forall a b. SqlQueryT m (a -> b) -> SqlQueryT m a -> SqlQueryT m b
forall a b c.
(a -> b -> c) -> SqlQueryT m a -> SqlQueryT m b -> SqlQueryT m c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
forall {m :: * -> *}. Applicative m => Functor (SqlQueryT m)
forall (m :: * -> *) a. Applicative m => a -> SqlQueryT m a
forall (m :: * -> *) a b.
Applicative m =>
SqlQueryT m a -> SqlQueryT m b -> SqlQueryT m a
forall (m :: * -> *) a b.
Applicative m =>
SqlQueryT m a -> SqlQueryT m b -> SqlQueryT m b
forall (m :: * -> *) a b.
Applicative m =>
SqlQueryT m (a -> b) -> SqlQueryT m a -> SqlQueryT m b
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> c) -> SqlQueryT m a -> SqlQueryT m b -> SqlQueryT m c
<* :: forall a b. SqlQueryT m a -> SqlQueryT m b -> SqlQueryT m a
$c<* :: forall (m :: * -> *) a b.
Applicative m =>
SqlQueryT m a -> SqlQueryT m b -> SqlQueryT m a
*> :: forall a b. SqlQueryT m a -> SqlQueryT m b -> SqlQueryT m b
$c*> :: forall (m :: * -> *) a b.
Applicative m =>
SqlQueryT m a -> SqlQueryT m b -> SqlQueryT m b
liftA2 :: forall a b c.
(a -> b -> c) -> SqlQueryT m a -> SqlQueryT m b -> SqlQueryT m c
$cliftA2 :: forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> c) -> SqlQueryT m a -> SqlQueryT m b -> SqlQueryT m c
<*> :: forall a b. SqlQueryT m (a -> b) -> SqlQueryT m a -> SqlQueryT m b
$c<*> :: forall (m :: * -> *) a b.
Applicative m =>
SqlQueryT m (a -> b) -> SqlQueryT m a -> SqlQueryT m b
pure :: forall a. a -> SqlQueryT m a
$cpure :: forall (m :: * -> *) a. Applicative m => a -> SqlQueryT m a
Applicative
, forall a. a -> SqlQueryT m a
forall a b. SqlQueryT m a -> SqlQueryT m b -> SqlQueryT m b
forall a b. SqlQueryT m a -> (a -> SqlQueryT m b) -> SqlQueryT m b
forall {m :: * -> *}. Monad m => Applicative (SqlQueryT m)
forall (m :: * -> *) a. Monad m => a -> SqlQueryT m a
forall (m :: * -> *) a b.
Monad m =>
SqlQueryT m a -> SqlQueryT m b -> SqlQueryT m b
forall (m :: * -> *) a b.
Monad m =>
SqlQueryT m a -> (a -> SqlQueryT m b) -> SqlQueryT m b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: forall a. a -> SqlQueryT m a
$creturn :: forall (m :: * -> *) a. Monad m => a -> SqlQueryT m a
>> :: forall a b. SqlQueryT m a -> SqlQueryT m b -> SqlQueryT m b
$c>> :: forall (m :: * -> *) a b.
Monad m =>
SqlQueryT m a -> SqlQueryT m b -> SqlQueryT m b
>>= :: forall a b. SqlQueryT m a -> (a -> SqlQueryT m b) -> SqlQueryT m b
$c>>= :: forall (m :: * -> *) a b.
Monad m =>
SqlQueryT m a -> (a -> SqlQueryT m b) -> SqlQueryT m b
Monad
, forall a. (a -> SqlQueryT m a) -> SqlQueryT m a
forall (m :: * -> *).
Monad m -> (forall a. (a -> m a) -> m a) -> MonadFix m
forall {m :: * -> *}. MonadFix m => Monad (SqlQueryT m)
forall (m :: * -> *) a.
MonadFix m =>
(a -> SqlQueryT m a) -> SqlQueryT m a
mfix :: forall a. (a -> SqlQueryT m a) -> SqlQueryT m a
$cmfix :: forall (m :: * -> *) a.
MonadFix m =>
(a -> SqlQueryT m a) -> SqlQueryT m a
MonadFix
, forall a. IO a -> SqlQueryT m a
forall (m :: * -> *).
Monad m -> (forall a. IO a -> m a) -> MonadIO m
forall {m :: * -> *}. MonadIO m => Monad (SqlQueryT m)
forall (m :: * -> *) a. MonadIO m => IO a -> SqlQueryT m a
liftIO :: forall a. IO a -> SqlQueryT m a
$cliftIO :: forall (m :: * -> *) a. MonadIO m => IO a -> SqlQueryT m a
MonadIO
, forall (m :: * -> *) a. Monad m => m a -> SqlQueryT m a
forall (t :: (* -> *) -> * -> *).
(forall (m :: * -> *) a. Monad m => m a -> t m a) -> MonadTrans t
lift :: forall (m :: * -> *) a. Monad m => m a -> SqlQueryT m a
$clift :: forall (m :: * -> *) a. Monad m => m a -> SqlQueryT m a
MonadTrans
, forall a. ResourceT IO a -> SqlQueryT m a
forall (m :: * -> *).
MonadIO m -> (forall a. ResourceT IO a -> m a) -> MonadResource m
forall {m :: * -> *}. MonadResource m => MonadIO (SqlQueryT m)
forall (m :: * -> *) a.
MonadResource m =>
ResourceT IO a -> SqlQueryT m a
liftResourceT :: forall a. ResourceT IO a -> SqlQueryT m a
$cliftResourceT :: forall (m :: * -> *) a.
MonadResource m =>
ResourceT IO a -> SqlQueryT m a
MonadResource
, forall a. IO a -> SqlQueryT m a
forall (m :: * -> *).
Monad m -> (forall a. IO a -> m a) -> MonadRerunnableIO m
forall {m :: * -> *}. MonadRerunnableIO m => Monad (SqlQueryT m)
forall (m :: * -> *) a.
MonadRerunnableIO m =>
IO a -> SqlQueryT m a
rerunnableIO :: forall a. IO a -> SqlQueryT m a
$crerunnableIO :: forall (m :: * -> *) a.
MonadRerunnableIO m =>
IO a -> SqlQueryT m a
MonadRerunnableIO
, forall e a. Exception e => e -> SqlQueryT m a
forall (m :: * -> *).
Monad m -> (forall e a. Exception e => e -> m a) -> MonadThrow m
forall {m :: * -> *}. MonadThrow m => Monad (SqlQueryT m)
forall (m :: * -> *) e a.
(MonadThrow m, Exception e) =>
e -> SqlQueryT m a
throwM :: forall e a. Exception e => e -> SqlQueryT m a
$cthrowM :: forall (m :: * -> *) e a.
(MonadThrow m, Exception e) =>
e -> SqlQueryT m a
MonadThrow
, forall e a.
Exception e =>
SqlQueryT m a -> (e -> SqlQueryT m a) -> SqlQueryT m a
forall (m :: * -> *).
MonadThrow m
-> (forall e a. Exception e => m a -> (e -> m a) -> m a)
-> MonadCatch m
forall {m :: * -> *}. MonadCatch m => MonadThrow (SqlQueryT m)
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
SqlQueryT m a -> (e -> SqlQueryT m a) -> SqlQueryT m a
catch :: forall e a.
Exception e =>
SqlQueryT m a -> (e -> SqlQueryT m a) -> SqlQueryT m a
$ccatch :: forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
SqlQueryT m a -> (e -> SqlQueryT m a) -> SqlQueryT m a
MonadCatch
, forall b.
((forall a. SqlQueryT m a -> SqlQueryT m a) -> SqlQueryT m b)
-> SqlQueryT m b
forall a b c.
SqlQueryT m a
-> (a -> ExitCase b -> SqlQueryT m c)
-> (a -> SqlQueryT m b)
-> SqlQueryT m (b, c)
forall {m :: * -> *}. MonadMask m => MonadCatch (SqlQueryT m)
forall (m :: * -> *) b.
MonadMask m =>
((forall a. SqlQueryT m a -> SqlQueryT m a) -> SqlQueryT m b)
-> SqlQueryT m b
forall (m :: * -> *) a b c.
MonadMask m =>
SqlQueryT m a
-> (a -> ExitCase b -> SqlQueryT m c)
-> (a -> SqlQueryT m b)
-> SqlQueryT m (b, c)
forall (m :: * -> *).
MonadCatch m
-> (forall b. ((forall a. m a -> m a) -> m b) -> m b)
-> (forall b. ((forall a. m a -> m a) -> m b) -> m b)
-> (forall a b c.
m a -> (a -> ExitCase b -> m c) -> (a -> m b) -> m (b, c))
-> MonadMask m
generalBracket :: forall a b c.
SqlQueryT m a
-> (a -> ExitCase b -> SqlQueryT m c)
-> (a -> SqlQueryT m b)
-> SqlQueryT m (b, c)
$cgeneralBracket :: forall (m :: * -> *) a b c.
MonadMask m =>
SqlQueryT m a
-> (a -> ExitCase b -> SqlQueryT m c)
-> (a -> SqlQueryT m b)
-> SqlQueryT m (b, c)
uninterruptibleMask :: forall b.
((forall a. SqlQueryT m a -> SqlQueryT m a) -> SqlQueryT m b)
-> SqlQueryT m b
$cuninterruptibleMask :: forall (m :: * -> *) b.
MonadMask m =>
((forall a. SqlQueryT m a -> SqlQueryT m a) -> SqlQueryT m b)
-> SqlQueryT m b
mask :: forall b.
((forall a. SqlQueryT m a -> SqlQueryT m a) -> SqlQueryT m b)
-> SqlQueryT m b
$cmask :: forall (m :: * -> *) b.
MonadMask m =>
((forall a. SqlQueryT m a -> SqlQueryT m a) -> SqlQueryT m b)
-> SqlQueryT m b
MonadMask
, forall msg.
ToLogStr msg =>
Loc -> LogSource -> LogLevel -> msg -> SqlQueryT m ()
forall (m :: * -> *).
Monad m
-> (forall msg.
ToLogStr msg =>
Loc -> LogSource -> LogLevel -> msg -> m ())
-> MonadLogger m
forall {m :: * -> *}. MonadLogger m => Monad (SqlQueryT m)
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> LogSource -> LogLevel -> msg -> SqlQueryT m ()
monadLoggerLog :: forall msg.
ToLogStr msg =>
Loc -> LogSource -> LogLevel -> msg -> SqlQueryT m ()
$cmonadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> LogSource -> LogLevel -> msg -> SqlQueryT m ()
MonadLogger
)
instance (MonadUnliftIO m) => MonadSqlQuery (SqlQueryT m) where
type TransactionM (SqlQueryT m) = SqlTransaction (SqlQueryT m)
runQueryRep :: forall record a.
Typeable record =>
SqlQueryRep record a -> SqlQueryT m a
runQueryRep = forall (m :: * -> *) a. MonadSqlQuery m => TransactionM m a -> m a
withTransaction forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) record a.
(MonadSqlQuery m, Typeable record) =>
SqlQueryRep record a -> m a
runQueryRep
withTransaction :: forall a. TransactionM (SqlQueryT m) a -> SqlQueryT m a
withTransaction TransactionM (SqlQueryT m) a
m = do
SqlQueryEnv{Int
Pool SqlBackend
SomeException -> Bool
SomeException -> IO ()
retryCallback :: SomeException -> IO ()
retryLimit :: Int
retryIf :: SomeException -> Bool
backendPool :: Pool SqlBackend
retryCallback :: SqlQueryEnv -> SomeException -> IO ()
retryLimit :: SqlQueryEnv -> Int
retryIf :: SqlQueryEnv -> SomeException -> Bool
backendPool :: SqlQueryEnv -> Pool SqlBackend
..} <- forall (m :: * -> *) a. ReaderT SqlQueryEnv m a -> SqlQueryT m a
SqlQueryT forall r (m :: * -> *). MonadReader r m => m r
ask
forall (m :: * -> *) a b.
MonadUnliftIO m =>
Pool a -> (a -> m b) -> m b
withResource Pool SqlBackend
backendPool forall a b. (a -> b) -> a -> b
$ \SqlBackend
conn ->
let transactionEnv :: SqlTransactionEnv
transactionEnv =
SqlTransactionEnv
{ sqlBackend :: SqlBackend
sqlBackend = SqlBackend
conn
, ignoreCatch :: SomeException -> Bool
ignoreCatch = SomeException -> Bool
retryIf
}
filterRetry :: SomeException -> Maybe SomeException
filterRetry SomeException
e = if SomeException -> Bool
retryIf SomeException
e then forall a. a -> Maybe a
Just SomeException
e else forall a. Maybe a
Nothing
loop :: Int -> SqlQueryT m a
loop Int
i = forall (m :: * -> *) e b a.
(MonadUnliftIO m, Exception e) =>
(e -> Maybe b) -> m a -> (b -> m a) -> m a
catchJust SomeException -> Maybe SomeException
filterRetry (forall (m :: * -> *) a.
MonadUnliftIO m =>
SqlTransactionEnv -> SqlTransaction m a -> m a
runSqlTransaction SqlTransactionEnv
transactionEnv TransactionM (SqlQueryT m) a
m) forall a b. (a -> b) -> a -> b
$ \SomeException
e ->
if Int
i forall a. Ord a => a -> a -> Bool
< Int
retryLimit
then do
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ SomeException -> IO ()
retryCallback SomeException
e
forall (m :: * -> *). MonadIO m => Int -> m ()
threadDelay forall a b. (a -> b) -> a -> b
$ Int
1000 forall a. Num a => a -> a -> a
* Int
2 forall a b. (Num a, Integral b) => a -> b -> a
^ Int
i
Int -> SqlQueryT m a
loop forall a b. (a -> b) -> a -> b
$! Int
i forall a. Num a => a -> a -> a
+ Int
1
else forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO TransactionError
RetryLimitExceeded
in Int -> SqlQueryT m a
loop Int
0
instance (MonadUnliftIO m) => MonadUnliftIO (SqlQueryT m) where
withRunInIO :: forall b.
((forall a. SqlQueryT m a -> IO a) -> IO b) -> SqlQueryT m b
withRunInIO = forall (n :: * -> *) b (m :: * -> *).
MonadUnliftIO n =>
(n b -> m b)
-> (forall a. m a -> n a)
-> ((forall a. m a -> IO a) -> IO b)
-> m b
wrappedWithRunInIO forall (m :: * -> *) a. ReaderT SqlQueryEnv m a -> SqlQueryT m a
SqlQueryT forall (m :: * -> *) a. SqlQueryT m a -> ReaderT SqlQueryEnv m a
unSqlQueryT
mapSqlQueryT :: (m a -> n b) -> SqlQueryT m a -> SqlQueryT n b
mapSqlQueryT :: forall (m :: * -> *) a (n :: * -> *) b.
(m a -> n b) -> SqlQueryT m a -> SqlQueryT n b
mapSqlQueryT m a -> n b
f = forall (m :: * -> *) a. ReaderT SqlQueryEnv m a -> SqlQueryT m a
SqlQueryT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a (n :: * -> *) b r.
(m a -> n b) -> ReaderT r m a -> ReaderT r n b
mapReaderT m a -> n b
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. SqlQueryT m a -> ReaderT SqlQueryEnv m a
unSqlQueryT
instance (MonadReader r m) => MonadReader r (SqlQueryT m) where
ask :: SqlQueryT m r
ask = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall r (m :: * -> *). MonadReader r m => m r
ask
local :: forall a. (r -> r) -> SqlQueryT m a -> SqlQueryT m a
local = forall (m :: * -> *) a (n :: * -> *) b.
(m a -> n b) -> SqlQueryT m a -> SqlQueryT n b
mapSqlQueryT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local
data TransactionError
=
RetryLimitExceeded
deriving (Int -> TransactionError -> ShowS
[TransactionError] -> ShowS
TransactionError -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TransactionError] -> ShowS
$cshowList :: [TransactionError] -> ShowS
show :: TransactionError -> String
$cshow :: TransactionError -> String
showsPrec :: Int -> TransactionError -> ShowS
$cshowsPrec :: Int -> TransactionError -> ShowS
Show, TransactionError -> TransactionError -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TransactionError -> TransactionError -> Bool
$c/= :: TransactionError -> TransactionError -> Bool
== :: TransactionError -> TransactionError -> Bool
$c== :: TransactionError -> TransactionError -> Bool
Eq)
instance Exception TransactionError
runSqlQueryT :: Pool SqlBackend -> SqlQueryT m a -> m a
runSqlQueryT :: forall (m :: * -> *) a. Pool SqlBackend -> SqlQueryT m a -> m a
runSqlQueryT Pool SqlBackend
backendPool = forall (m :: * -> *) a. SqlQueryEnv -> SqlQueryT m a -> m a
runSqlQueryTWith forall a b. (a -> b) -> a -> b
$ Pool SqlBackend -> (SqlQueryEnv -> SqlQueryEnv) -> SqlQueryEnv
mkSqlQueryEnv Pool SqlBackend
backendPool forall a. a -> a
id
runSqlQueryTWith :: SqlQueryEnv -> SqlQueryT m a -> m a
runSqlQueryTWith :: forall (m :: * -> *) a. SqlQueryEnv -> SqlQueryT m a -> m a
runSqlQueryTWith SqlQueryEnv
env = (forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
`runReaderT` SqlQueryEnv
env) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. SqlQueryT m a -> ReaderT SqlQueryEnv m a
unSqlQueryT
getSqlBackendPool :: (Monad m) => SqlQueryT m (Pool SqlBackend)
getSqlBackendPool :: forall (m :: * -> *). Monad m => SqlQueryT m (Pool SqlBackend)
getSqlBackendPool = forall (m :: * -> *) a. ReaderT SqlQueryEnv m a -> SqlQueryT m a
SqlQueryT (forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks SqlQueryEnv -> Pool SqlBackend
backendPool)