{-|
Module: Database.Persist.Monad

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:

@
myFunction :: (MonadSqlQuery m, MonadIO m) => m ()
myFunction = do
  insert_ $ Person { name = \"Alice\", age = Just 25 }
  insert_ $ Person { name = \"Bob\", age = Nothing }

  -- some other business logic

  personList <- selectList [] []
  liftIO $ print (personList :: [Person])

  -- everything in here will run in a transaction
  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 FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}

module Database.Persist.Monad
  (
  -- * Type class for executing database queries
    MonadSqlQuery
  , withTransaction

  -- * SqlQueryT monad transformer
  , SqlQueryT
  , mapSqlQueryT
  , runSqlQueryT
  , runSqlQueryTWith
  , SqlQueryEnv(..)
  , mkSqlQueryEnv

  -- * Transactions
  , SqlTransaction
  , rerunnableLift
  , TransactionError(..)

  -- * Lifted functions
  , 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.Logger (MonadLogger)
import Control.Monad.Reader (ReaderT(..), 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 UnliftIO.Concurrent (threadDelay)
import UnliftIO.Exception (Exception, SomeException, catchJust, throwIO)
import UnliftIO.Pool (withResource)

import Control.Monad.IO.Rerunnable (MonadRerunnableIO, rerunnableIO)
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
  { SqlTransaction m a -> SqlPersistT m a
unSqlTransaction :: SqlPersistT m a
  }
  deriving (a -> SqlTransaction m b -> SqlTransaction m a
(a -> b) -> SqlTransaction m a -> SqlTransaction m b
(forall a b. (a -> b) -> SqlTransaction m a -> SqlTransaction m b)
-> (forall a b. a -> SqlTransaction m b -> SqlTransaction m a)
-> Functor (SqlTransaction m)
forall a b. a -> SqlTransaction m b -> SqlTransaction m a
forall a b. (a -> b) -> SqlTransaction m a -> SqlTransaction m b
forall (m :: * -> *) a b.
Functor m =>
a -> SqlTransaction m b -> SqlTransaction m a
forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> SqlTransaction m a -> SqlTransaction m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> SqlTransaction m b -> SqlTransaction m a
$c<$ :: forall (m :: * -> *) a b.
Functor m =>
a -> SqlTransaction m b -> SqlTransaction m a
fmap :: (a -> b) -> SqlTransaction m a -> SqlTransaction m b
$cfmap :: forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> SqlTransaction m a -> SqlTransaction m b
Functor, Functor (SqlTransaction m)
a -> SqlTransaction m a
Functor (SqlTransaction m)
-> (forall a. a -> SqlTransaction m a)
-> (forall a b.
    SqlTransaction m (a -> b)
    -> SqlTransaction m a -> SqlTransaction m b)
-> (forall a b c.
    (a -> b -> c)
    -> SqlTransaction m a -> SqlTransaction m b -> SqlTransaction m c)
-> (forall a b.
    SqlTransaction m a -> SqlTransaction m b -> SqlTransaction m b)
-> (forall a b.
    SqlTransaction m a -> SqlTransaction m b -> SqlTransaction m a)
-> Applicative (SqlTransaction m)
SqlTransaction m a -> SqlTransaction m b -> SqlTransaction m b
SqlTransaction m a -> SqlTransaction m b -> SqlTransaction m a
SqlTransaction m (a -> b)
-> SqlTransaction m a -> SqlTransaction m b
(a -> b -> c)
-> SqlTransaction m a -> SqlTransaction m b -> SqlTransaction m c
forall a. a -> SqlTransaction m a
forall a b.
SqlTransaction m a -> SqlTransaction m b -> SqlTransaction m a
forall a b.
SqlTransaction m a -> SqlTransaction m b -> SqlTransaction m b
forall a b.
SqlTransaction m (a -> b)
-> SqlTransaction m a -> SqlTransaction m b
forall a b c.
(a -> b -> c)
-> SqlTransaction m a -> SqlTransaction m b -> SqlTransaction 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 (SqlTransaction m)
forall (m :: * -> *) a. Applicative m => a -> SqlTransaction m a
forall (m :: * -> *) a b.
Applicative m =>
SqlTransaction m a -> SqlTransaction m b -> SqlTransaction m a
forall (m :: * -> *) a b.
Applicative m =>
SqlTransaction m a -> SqlTransaction m b -> SqlTransaction m b
forall (m :: * -> *) a b.
Applicative m =>
SqlTransaction m (a -> b)
-> SqlTransaction m a -> SqlTransaction m b
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> c)
-> SqlTransaction m a -> SqlTransaction m b -> SqlTransaction m c
<* :: SqlTransaction m a -> SqlTransaction m b -> SqlTransaction m a
$c<* :: forall (m :: * -> *) a b.
Applicative m =>
SqlTransaction m a -> SqlTransaction m b -> SqlTransaction m a
*> :: SqlTransaction m a -> SqlTransaction m b -> SqlTransaction m b
$c*> :: forall (m :: * -> *) a b.
Applicative m =>
SqlTransaction m a -> SqlTransaction m b -> SqlTransaction m b
liftA2 :: (a -> b -> c)
-> SqlTransaction m a -> SqlTransaction m b -> SqlTransaction m c
$cliftA2 :: forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> c)
-> SqlTransaction m a -> SqlTransaction m b -> SqlTransaction m c
<*> :: SqlTransaction m (a -> b)
-> SqlTransaction m a -> SqlTransaction m b
$c<*> :: forall (m :: * -> *) a b.
Applicative m =>
SqlTransaction m (a -> b)
-> SqlTransaction m a -> SqlTransaction m b
pure :: a -> SqlTransaction m a
$cpure :: forall (m :: * -> *) a. Applicative m => a -> SqlTransaction m a
$cp1Applicative :: forall (m :: * -> *). Applicative m => Functor (SqlTransaction m)
Applicative, Applicative (SqlTransaction m)
a -> SqlTransaction m a
Applicative (SqlTransaction m)
-> (forall a b.
    SqlTransaction m a
    -> (a -> SqlTransaction m b) -> SqlTransaction m b)
-> (forall a b.
    SqlTransaction m a -> SqlTransaction m b -> SqlTransaction m b)
-> (forall a. a -> SqlTransaction m a)
-> Monad (SqlTransaction m)
SqlTransaction m a
-> (a -> SqlTransaction m b) -> SqlTransaction m b
SqlTransaction m a -> SqlTransaction m b -> SqlTransaction m b
forall a. a -> SqlTransaction m a
forall a b.
SqlTransaction m a -> SqlTransaction m b -> SqlTransaction m b
forall a b.
SqlTransaction m a
-> (a -> SqlTransaction m b) -> SqlTransaction m b
forall (m :: * -> *). Monad m => Applicative (SqlTransaction m)
forall (m :: * -> *) a. Monad m => a -> SqlTransaction m a
forall (m :: * -> *) a b.
Monad m =>
SqlTransaction m a -> SqlTransaction m b -> SqlTransaction m b
forall (m :: * -> *) a b.
Monad m =>
SqlTransaction m a
-> (a -> SqlTransaction m b) -> SqlTransaction 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 :: a -> SqlTransaction m a
$creturn :: forall (m :: * -> *) a. Monad m => a -> SqlTransaction m a
>> :: SqlTransaction m a -> SqlTransaction m b -> SqlTransaction m b
$c>> :: forall (m :: * -> *) a b.
Monad m =>
SqlTransaction m a -> SqlTransaction m b -> SqlTransaction m b
>>= :: SqlTransaction m a
-> (a -> SqlTransaction m b) -> SqlTransaction m b
$c>>= :: forall (m :: * -> *) a b.
Monad m =>
SqlTransaction m a
-> (a -> SqlTransaction m b) -> SqlTransaction m b
$cp1Monad :: forall (m :: * -> *). Monad m => Applicative (SqlTransaction m)
Monad, Monad (SqlTransaction m)
Monad (SqlTransaction m)
-> (forall a. IO a -> SqlTransaction m a)
-> MonadRerunnableIO (SqlTransaction m)
IO a -> SqlTransaction m a
forall a. IO a -> SqlTransaction m a
forall (m :: * -> *).
Monad m -> (forall a. IO a -> m a) -> MonadRerunnableIO m
forall (m :: * -> *).
MonadRerunnableIO m =>
Monad (SqlTransaction m)
forall (m :: * -> *) a.
MonadRerunnableIO m =>
IO a -> SqlTransaction m a
rerunnableIO :: IO a -> SqlTransaction m a
$crerunnableIO :: forall (m :: * -> *) a.
MonadRerunnableIO m =>
IO a -> SqlTransaction m a
$cp1MonadRerunnableIO :: forall (m :: * -> *).
MonadRerunnableIO m =>
Monad (SqlTransaction m)
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 :: IO a -> SqlTransaction m a
liftIO = IO a -> SqlTransaction m a
forall a. HasCallStack => a
undefined

instance (MonadSqlQuery m, MonadUnliftIO m) => MonadSqlQuery (SqlTransaction m) where
  type TransactionM (SqlTransaction m) = TransactionM m

  runQueryRep :: SqlQueryRep record a -> SqlTransaction m a
runQueryRep = SqlPersistT m a -> SqlTransaction m a
forall (m :: * -> *) a. SqlPersistT m a -> SqlTransaction m a
SqlTransaction (SqlPersistT m a -> SqlTransaction m a)
-> (SqlQueryRep record a -> SqlPersistT m a)
-> SqlQueryRep record a
-> SqlTransaction m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SqlQueryRep record a -> SqlPersistT m a
forall (m :: * -> *) record a.
MonadUnliftIO m =>
SqlQueryRep record a -> SqlPersistT m a
runSqlQueryRep

  -- Delegate to 'm', since 'm' is in charge of starting/stopping transactions.
  -- 'SqlTransaction' is ONLY in charge of executing queries.
  withTransaction :: TransactionM (SqlTransaction m) a -> SqlTransaction m a
withTransaction = SqlPersistT m a -> SqlTransaction m a
forall (m :: * -> *) a. SqlPersistT m a -> SqlTransaction m a
SqlTransaction (SqlPersistT m a -> SqlTransaction m a)
-> (TransactionM m a -> SqlPersistT m a)
-> TransactionM m a
-> SqlTransaction m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TransactionM m a -> SqlPersistT m a
forall (m :: * -> *) a. MonadSqlQuery m => TransactionM m a -> m a
withTransaction

runSqlTransaction :: MonadUnliftIO m => SqlBackend -> SqlTransaction m a -> m a
runSqlTransaction :: SqlBackend -> SqlTransaction m a -> m a
runSqlTransaction SqlBackend
conn = (ReaderT SqlBackend m a -> SqlBackend -> m a
forall backend (m :: * -> *) a.
(MonadUnliftIO m, BackendCompatible SqlBackend backend) =>
ReaderT backend m a -> backend -> m a
`runSqlConn` SqlBackend
conn) (ReaderT SqlBackend m a -> m a)
-> (SqlTransaction m a -> ReaderT SqlBackend m a)
-> SqlTransaction m a
-> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SqlTransaction m a -> ReaderT SqlBackend m a
forall (m :: * -> *) a. SqlTransaction m a -> SqlPersistT m a
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 a -> SqlTransaction m a
rerunnableLift m a
m = SqlPersistT m a -> SqlTransaction m a
forall (m :: * -> *) a. SqlPersistT m a -> SqlTransaction m a
SqlTransaction (SqlPersistT m a -> SqlTransaction m a)
-> SqlPersistT m a -> SqlTransaction m a
forall a b. (a -> b) -> a -> b
$ m a -> SqlPersistT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m a -> SqlPersistT m a) -> m a -> SqlPersistT m a
forall a b. (a -> b) -> a -> b
$ ((forall a. m a -> IO a) -> IO a) -> m a
forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO (((forall a. m a -> IO a) -> IO a) -> m a)
-> ((forall a. m a -> IO a) -> IO a) -> m a
forall a b. (a -> b) -> a -> b
$ \forall a. m a -> IO a
runInIO -> IO a -> IO a
forall (m :: * -> *) a. MonadRerunnableIO m => IO a -> m a
rerunnableIO (IO a -> IO a) -> IO a -> IO a
forall a b. (a -> b) -> a -> b
$ m a -> IO a
forall a. m a -> IO a
runInIO m a
m

-- | Errors that can occur within a SQL transaction.
data TransactionError
  = RetryLimitExceeded
    -- ^ The retry limit was reached when retrying a transaction.
  deriving (Int -> TransactionError -> ShowS
[TransactionError] -> ShowS
TransactionError -> String
(Int -> TransactionError -> ShowS)
-> (TransactionError -> String)
-> ([TransactionError] -> ShowS)
-> Show TransactionError
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
(TransactionError -> TransactionError -> Bool)
-> (TransactionError -> TransactionError -> Bool)
-> Eq TransactionError
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

{- 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
  { SqlQueryEnv -> Pool SqlBackend
backendPool :: Pool SqlBackend
    -- ^ The pool for your persistent backend. Get this from @withSqlitePool@
    -- or the equivalent for your backend.

  , SqlQueryEnv -> SomeException -> Bool
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)

  , SqlQueryEnv -> Int
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 :: Pool SqlBackend -> (SqlQueryEnv -> SqlQueryEnv) -> SqlQueryEnv
mkSqlQueryEnv Pool SqlBackend
backendPool SqlQueryEnv -> SqlQueryEnv
f = SqlQueryEnv -> SqlQueryEnv
f SqlQueryEnv :: Pool SqlBackend -> (SomeException -> Bool) -> Int -> SqlQueryEnv
SqlQueryEnv
  { Pool SqlBackend
backendPool :: Pool SqlBackend
backendPool :: Pool SqlBackend
backendPool
  , retryIf :: SomeException -> Bool
retryIf = Bool -> SomeException -> Bool
forall a b. a -> b -> a
const Bool
False
  , retryLimit :: Int
retryLimit = Int
10
  }

-- | The monad transformer that implements 'MonadSqlQuery'.
newtype SqlQueryT m a = SqlQueryT
  { SqlQueryT m a -> ReaderT SqlQueryEnv m a
unSqlQueryT :: ReaderT SqlQueryEnv m a
  } deriving
    ( a -> SqlQueryT m b -> SqlQueryT m a
(a -> b) -> SqlQueryT m a -> SqlQueryT m b
(forall a b. (a -> b) -> SqlQueryT m a -> SqlQueryT m b)
-> (forall a b. a -> SqlQueryT m b -> SqlQueryT m a)
-> Functor (SqlQueryT m)
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
<$ :: a -> SqlQueryT m b -> SqlQueryT m a
$c<$ :: forall (m :: * -> *) a b.
Functor m =>
a -> SqlQueryT m b -> SqlQueryT m a
fmap :: (a -> b) -> SqlQueryT m a -> SqlQueryT m b
$cfmap :: forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> SqlQueryT m a -> SqlQueryT m b
Functor
    , Functor (SqlQueryT m)
a -> SqlQueryT m a
Functor (SqlQueryT m)
-> (forall a. a -> SqlQueryT m a)
-> (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 a b. SqlQueryT m a -> SqlQueryT m b -> SqlQueryT m b)
-> (forall a b. SqlQueryT m a -> SqlQueryT m b -> SqlQueryT m a)
-> Applicative (SqlQueryT m)
SqlQueryT m a -> SqlQueryT m b -> SqlQueryT m b
SqlQueryT m a -> SqlQueryT m b -> SqlQueryT m a
SqlQueryT m (a -> b) -> SqlQueryT m a -> SqlQueryT m b
(a -> b -> c) -> SqlQueryT m a -> SqlQueryT m b -> SqlQueryT m c
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
<* :: 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
*> :: 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 :: (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
<*> :: 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 :: a -> SqlQueryT m a
$cpure :: forall (m :: * -> *) a. Applicative m => a -> SqlQueryT m a
$cp1Applicative :: forall (m :: * -> *). Applicative m => Functor (SqlQueryT m)
Applicative
    , Applicative (SqlQueryT m)
a -> SqlQueryT m a
Applicative (SqlQueryT m)
-> (forall a b.
    SqlQueryT m a -> (a -> SqlQueryT m b) -> SqlQueryT m b)
-> (forall a b. SqlQueryT m a -> SqlQueryT m b -> SqlQueryT m b)
-> (forall a. a -> SqlQueryT m a)
-> Monad (SqlQueryT m)
SqlQueryT m a -> (a -> SqlQueryT m b) -> SqlQueryT m b
SqlQueryT m a -> SqlQueryT m b -> SqlQueryT m b
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 :: a -> SqlQueryT m a
$creturn :: forall (m :: * -> *) a. Monad m => a -> SqlQueryT m a
>> :: 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
>>= :: 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
$cp1Monad :: forall (m :: * -> *). Monad m => Applicative (SqlQueryT m)
Monad
    , Monad (SqlQueryT m)
Monad (SqlQueryT m)
-> (forall a. IO a -> SqlQueryT m a) -> MonadIO (SqlQueryT m)
IO a -> SqlQueryT m a
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 :: IO a -> SqlQueryT m a
$cliftIO :: forall (m :: * -> *) a. MonadIO m => IO a -> SqlQueryT m a
$cp1MonadIO :: forall (m :: * -> *). MonadIO m => Monad (SqlQueryT m)
MonadIO
    , m a -> SqlQueryT m a
(forall (m :: * -> *) a. Monad m => m a -> SqlQueryT m a)
-> MonadTrans SqlQueryT
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 :: m a -> SqlQueryT m a
$clift :: forall (m :: * -> *) a. Monad m => m a -> SqlQueryT m a
MonadTrans
    , MonadIO (SqlQueryT m)
MonadIO (SqlQueryT m)
-> (forall a. ResourceT IO a -> SqlQueryT m a)
-> MonadResource (SqlQueryT m)
ResourceT IO a -> SqlQueryT m a
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 :: ResourceT IO a -> SqlQueryT m a
$cliftResourceT :: forall (m :: * -> *) a.
MonadResource m =>
ResourceT IO a -> SqlQueryT m a
$cp1MonadResource :: forall (m :: * -> *). MonadResource m => MonadIO (SqlQueryT m)
MonadResource
    , Monad (SqlQueryT m)
Monad (SqlQueryT m)
-> (forall a. IO a -> SqlQueryT m a)
-> MonadRerunnableIO (SqlQueryT m)
IO a -> SqlQueryT m a
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 :: IO a -> SqlQueryT m a
$crerunnableIO :: forall (m :: * -> *) a.
MonadRerunnableIO m =>
IO a -> SqlQueryT m a
$cp1MonadRerunnableIO :: forall (m :: * -> *). MonadRerunnableIO m => Monad (SqlQueryT m)
MonadRerunnableIO
    , Monad (SqlQueryT m)
e -> SqlQueryT m a
Monad (SqlQueryT m)
-> (forall e a. Exception e => e -> SqlQueryT m a)
-> MonadThrow (SqlQueryT m)
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 :: e -> SqlQueryT m a
$cthrowM :: forall (m :: * -> *) e a.
(MonadThrow m, Exception e) =>
e -> SqlQueryT m a
$cp1MonadThrow :: forall (m :: * -> *). MonadThrow m => Monad (SqlQueryT m)
MonadThrow
    , MonadThrow (SqlQueryT m)
MonadThrow (SqlQueryT m)
-> (forall e a.
    Exception e =>
    SqlQueryT m a -> (e -> SqlQueryT m a) -> SqlQueryT m a)
-> MonadCatch (SqlQueryT m)
SqlQueryT m a -> (e -> SqlQueryT m a) -> SqlQueryT m a
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 :: 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
$cp1MonadCatch :: forall (m :: * -> *). MonadCatch m => MonadThrow (SqlQueryT m)
MonadCatch
    , MonadCatch (SqlQueryT m)
MonadCatch (SqlQueryT m)
-> (forall b.
    ((forall a. SqlQueryT m a -> SqlQueryT m a) -> SqlQueryT m b)
    -> SqlQueryT m b)
-> (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))
-> MonadMask (SqlQueryT m)
SqlQueryT m a
-> (a -> ExitCase b -> SqlQueryT m c)
-> (a -> SqlQueryT m b)
-> SqlQueryT m (b, c)
((forall a. SqlQueryT m a -> SqlQueryT m a) -> SqlQueryT m b)
-> SqlQueryT m b
((forall a. SqlQueryT m a -> SqlQueryT m a) -> SqlQueryT m b)
-> SqlQueryT m b
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 :: * -> *).
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
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)
generalBracket :: 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 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 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
$cp1MonadMask :: forall (m :: * -> *). MonadMask m => MonadCatch (SqlQueryT m)
MonadMask
    , Monad (SqlQueryT m)
Monad (SqlQueryT m)
-> (forall msg.
    ToLogStr msg =>
    Loc -> LogSource -> LogLevel -> msg -> SqlQueryT m ())
-> MonadLogger (SqlQueryT m)
Loc -> LogSource -> LogLevel -> msg -> SqlQueryT m ()
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 :: Loc -> LogSource -> LogLevel -> msg -> SqlQueryT m ()
$cmonadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> LogSource -> LogLevel -> msg -> SqlQueryT m ()
$cp1MonadLogger :: forall (m :: * -> *). MonadLogger m => Monad (SqlQueryT m)
MonadLogger
    )

instance MonadUnliftIO m => MonadSqlQuery (SqlQueryT m) where
  type TransactionM (SqlQueryT m) = SqlTransaction (SqlQueryT m)

  -- Running a query directly in SqlQueryT will create a one-off transaction.
  runQueryRep :: SqlQueryRep record a -> SqlQueryT m a
runQueryRep = SqlTransaction (SqlQueryT m) a -> SqlQueryT m a
forall (m :: * -> *) a. MonadSqlQuery m => TransactionM m a -> m a
withTransaction (SqlTransaction (SqlQueryT m) a -> SqlQueryT m a)
-> (SqlQueryRep record a -> SqlTransaction (SqlQueryT m) a)
-> SqlQueryRep record a
-> SqlQueryT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SqlQueryRep record a -> SqlTransaction (SqlQueryT m) a
forall (m :: * -> *) record a.
(MonadSqlQuery m, Typeable record) =>
SqlQueryRep record a -> m a
runQueryRep

  -- Start a new transaction and run the given 'SqlTransaction'
  withTransaction :: TransactionM (SqlQueryT m) a -> SqlQueryT m a
withTransaction TransactionM (SqlQueryT m) a
m = do
    SqlQueryEnv{Int
Pool SqlBackend
SomeException -> Bool
retryLimit :: Int
retryIf :: SomeException -> Bool
backendPool :: Pool SqlBackend
retryLimit :: SqlQueryEnv -> Int
retryIf :: SqlQueryEnv -> SomeException -> Bool
backendPool :: SqlQueryEnv -> Pool SqlBackend
..} <- ReaderT SqlQueryEnv m SqlQueryEnv -> SqlQueryT m SqlQueryEnv
forall (m :: * -> *) a. ReaderT SqlQueryEnv m a -> SqlQueryT m a
SqlQueryT ReaderT SqlQueryEnv m SqlQueryEnv
forall r (m :: * -> *). MonadReader r m => m r
ask
    Pool SqlBackend -> (SqlBackend -> SqlQueryT m a) -> SqlQueryT m a
forall (m :: * -> *) a b.
MonadUnliftIO m =>
Pool a -> (a -> m b) -> m b
withResource Pool SqlBackend
backendPool ((SqlBackend -> SqlQueryT m a) -> SqlQueryT m a)
-> (SqlBackend -> SqlQueryT m a) -> SqlQueryT m a
forall a b. (a -> b) -> a -> b
$ \SqlBackend
conn ->
      let filterRetry :: SomeException -> Maybe SomeException
filterRetry SomeException
e = if SomeException -> Bool
retryIf SomeException
e then SomeException -> Maybe SomeException
forall a. a -> Maybe a
Just SomeException
e else Maybe SomeException
forall a. Maybe a
Nothing
          loop :: Int -> SqlQueryT m a
loop Int
i = (SomeException -> Maybe SomeException)
-> SqlQueryT m a
-> (SomeException -> SqlQueryT m a)
-> SqlQueryT m a
forall (m :: * -> *) e b a.
(MonadUnliftIO m, Exception e) =>
(e -> Maybe b) -> m a -> (b -> m a) -> m a
catchJust SomeException -> Maybe SomeException
filterRetry (SqlBackend -> SqlTransaction (SqlQueryT m) a -> SqlQueryT m a
forall (m :: * -> *) a.
MonadUnliftIO m =>
SqlBackend -> SqlTransaction m a -> m a
runSqlTransaction SqlBackend
conn TransactionM (SqlQueryT m) a
SqlTransaction (SqlQueryT m) a
m) ((SomeException -> SqlQueryT m a) -> SqlQueryT m a)
-> (SomeException -> SqlQueryT m a) -> SqlQueryT m a
forall a b. (a -> b) -> a -> b
$ \SomeException
_ ->
            if Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
retryLimit
              then do
                Int -> SqlQueryT m ()
forall (m :: * -> *). MonadIO m => Int -> m ()
threadDelay (Int -> SqlQueryT m ()) -> Int -> SqlQueryT m ()
forall a b. (a -> b) -> a -> b
$ Int
1000 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
2Int -> Int -> Int
forall a b. (Num a, Integral b) => a -> b -> a
^Int
i
                Int -> SqlQueryT m a
loop (Int -> SqlQueryT m a) -> Int -> SqlQueryT m a
forall a b. (a -> b) -> a -> b
$! Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
              else TransactionError -> SqlQueryT m a
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 a. SqlQueryT m a -> IO a) -> IO b) -> SqlQueryT m b
withRunInIO = (ReaderT SqlQueryEnv m b -> SqlQueryT m b)
-> (forall a. SqlQueryT m a -> ReaderT SqlQueryEnv m a)
-> ((forall a. SqlQueryT m a -> IO a) -> IO b)
-> SqlQueryT m b
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 ReaderT SqlQueryEnv m b -> SqlQueryT m b
forall (m :: * -> *) a. ReaderT SqlQueryEnv m a -> SqlQueryT m a
SqlQueryT forall a. SqlQueryT m a -> ReaderT SqlQueryEnv m a
forall (m :: * -> *) a. SqlQueryT m a -> ReaderT SqlQueryEnv m a
unSqlQueryT

mapSqlQueryT :: (m a -> n b) -> SqlQueryT m a -> SqlQueryT n b
mapSqlQueryT :: (m a -> n b) -> SqlQueryT m a -> SqlQueryT n b
mapSqlQueryT m a -> n b
f = ReaderT SqlQueryEnv n b -> SqlQueryT n b
forall (m :: * -> *) a. ReaderT SqlQueryEnv m a -> SqlQueryT m a
SqlQueryT (ReaderT SqlQueryEnv n b -> SqlQueryT n b)
-> (SqlQueryT m a -> ReaderT SqlQueryEnv n b)
-> SqlQueryT m a
-> SqlQueryT n b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (m a -> n b) -> ReaderT SqlQueryEnv m a -> ReaderT SqlQueryEnv n b
forall (m :: * -> *) a (n :: * -> *) b r.
(m a -> n b) -> ReaderT r m a -> ReaderT r n b
mapReaderT m a -> n b
f (ReaderT SqlQueryEnv m a -> ReaderT SqlQueryEnv n b)
-> (SqlQueryT m a -> ReaderT SqlQueryEnv m a)
-> SqlQueryT m a
-> ReaderT SqlQueryEnv n b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SqlQueryT m a -> ReaderT SqlQueryEnv m a
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 = m r -> SqlQueryT m r
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m r
forall r (m :: * -> *). MonadReader r m => m r
ask
    local :: (r -> r) -> SqlQueryT m a -> SqlQueryT m a
local = (m a -> m a) -> SqlQueryT m a -> SqlQueryT m a
forall (m :: * -> *) a (n :: * -> *) b.
(m a -> n b) -> SqlQueryT m a -> SqlQueryT n b
mapSqlQueryT ((m a -> m a) -> SqlQueryT m a -> SqlQueryT m a)
-> ((r -> r) -> m a -> m a)
-> (r -> r)
-> SqlQueryT m a
-> SqlQueryT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (r -> r) -> m a -> m a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local

{- Running SqlQueryT -}

-- | Run the 'SqlQueryT' monad transformer with the given backend.
runSqlQueryT :: Pool SqlBackend -> SqlQueryT m a -> m a
runSqlQueryT :: Pool SqlBackend -> SqlQueryT m a -> m a
runSqlQueryT Pool SqlBackend
backendPool = SqlQueryEnv -> SqlQueryT m a -> m a
forall (m :: * -> *) a. SqlQueryEnv -> SqlQueryT m a -> m a
runSqlQueryTWith (SqlQueryEnv -> SqlQueryT m a -> m a)
-> SqlQueryEnv -> SqlQueryT m a -> m a
forall a b. (a -> b) -> a -> b
$ Pool SqlBackend -> (SqlQueryEnv -> SqlQueryEnv) -> SqlQueryEnv
mkSqlQueryEnv Pool SqlBackend
backendPool SqlQueryEnv -> SqlQueryEnv
forall a. a -> a
id

-- | Run the 'SqlQueryT' monad transformer with the explicitly provided
-- environment.
runSqlQueryTWith :: SqlQueryEnv -> SqlQueryT m a -> m a
runSqlQueryTWith :: SqlQueryEnv -> SqlQueryT m a -> m a
runSqlQueryTWith SqlQueryEnv
env = (ReaderT SqlQueryEnv m a -> SqlQueryEnv -> m a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
`runReaderT` SqlQueryEnv
env) (ReaderT SqlQueryEnv m a -> m a)
-> (SqlQueryT m a -> ReaderT SqlQueryEnv m a)
-> SqlQueryT m a
-> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SqlQueryT m a -> ReaderT SqlQueryEnv m a
forall (m :: * -> *) a. SqlQueryT m a -> ReaderT SqlQueryEnv m a
unSqlQueryT