{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
module Database.Persist.Sql.Run where

import Control.Monad.IO.Unlift
import Control.Monad.Logger.CallStack
import Control.Monad (void)
import Control.Monad.Reader (MonadReader)
import qualified Control.Monad.Reader as MonadReader
import Control.Monad.Trans.Reader hiding (local)
import Control.Monad.Trans.Resource
import Data.Acquire (Acquire, ReleaseType(..), mkAcquireType, with)
import Data.Pool as P
import qualified Data.Text as T
import qualified UnliftIO.Exception as UE

import Database.Persist.Class.PersistStore
import Database.Persist.Sql.Raw
import Database.Persist.Sql.Types
import Database.Persist.Sql.Types.Internal
import Database.Persist.SqlBackend.Internal.StatementCache
import Database.Persist.SqlBackend.Internal.SqlPoolHooks

-- | Get a connection from the pool, run the given action, and then return the
-- connection to the pool.
--
-- This function performs the given action in a transaction. If an
-- exception occurs during the action, then the transaction is rolled back.
--
-- Note: This function previously timed out after 2 seconds, but this behavior
-- was buggy and caused more problems than it solved. Since version 2.1.2, it
-- performs no timeout checks.
runSqlPool
    :: forall backend m a. (MonadUnliftIO m, BackendCompatible SqlBackend backend)
    => ReaderT backend m a -> Pool backend -> m a
runSqlPool :: forall backend (m :: * -> *) a.
(MonadUnliftIO m, BackendCompatible SqlBackend backend) =>
ReaderT backend m a -> Pool backend -> m a
runSqlPool ReaderT backend m a
r Pool backend
pconn = do
    forall backend (m :: * -> *) a.
(MonadUnliftIO m, BackendCompatible SqlBackend backend) =>
ReaderT backend m a -> Pool backend -> Maybe IsolationLevel -> m a
rawRunSqlPool ReaderT backend m a
r Pool backend
pconn forall a. Maybe a
Nothing

-- | Like 'runSqlPool', but supports specifying an isolation level.
--
-- @since 2.9.0
runSqlPoolWithIsolation
    :: forall backend m a. (MonadUnliftIO m, BackendCompatible SqlBackend backend)
    => ReaderT backend m a -> Pool backend -> IsolationLevel -> m a
runSqlPoolWithIsolation :: forall backend (m :: * -> *) a.
(MonadUnliftIO m, BackendCompatible SqlBackend backend) =>
ReaderT backend m a -> Pool backend -> IsolationLevel -> m a
runSqlPoolWithIsolation ReaderT backend m a
r Pool backend
pconn IsolationLevel
i =
    forall backend (m :: * -> *) a.
(MonadUnliftIO m, BackendCompatible SqlBackend backend) =>
ReaderT backend m a -> Pool backend -> Maybe IsolationLevel -> m a
rawRunSqlPool ReaderT backend m a
r Pool backend
pconn (forall a. a -> Maybe a
Just IsolationLevel
i)

-- | Like 'runSqlPool', but does not surround the action in a transaction.
-- This action might leave your database in a weird state.
--
-- @since 2.12.0.0
runSqlPoolNoTransaction
    :: forall backend m a. (MonadUnliftIO m, BackendCompatible SqlBackend backend)
    => ReaderT backend m a -> Pool backend -> Maybe IsolationLevel -> m a
runSqlPoolNoTransaction :: forall backend (m :: * -> *) a.
(MonadUnliftIO m, BackendCompatible SqlBackend backend) =>
ReaderT backend m a -> Pool backend -> Maybe IsolationLevel -> m a
runSqlPoolNoTransaction ReaderT backend m a
r Pool backend
pconn Maybe IsolationLevel
i =
    forall backend (m :: * -> *) a before after onException.
(MonadUnliftIO m, BackendCompatible SqlBackend backend) =>
ReaderT backend m a
-> Pool backend
-> Maybe IsolationLevel
-> (backend -> m before)
-> (backend -> m after)
-> (backend -> SomeException -> m onException)
-> m a
runSqlPoolWithHooks ReaderT backend m a
r Pool backend
pconn Maybe IsolationLevel
i (\backend
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) (\backend
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) (\backend
_ SomeException
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ())

rawRunSqlPool
    :: forall backend m a. (MonadUnliftIO m, BackendCompatible SqlBackend backend)
    => ReaderT backend m a -> Pool backend -> Maybe IsolationLevel -> m a
rawRunSqlPool :: forall backend (m :: * -> *) a.
(MonadUnliftIO m, BackendCompatible SqlBackend backend) =>
ReaderT backend m a -> Pool backend -> Maybe IsolationLevel -> m a
rawRunSqlPool ReaderT backend m a
r Pool backend
pconn Maybe IsolationLevel
mi =
    forall backend (m :: * -> *) a before after onException.
(MonadUnliftIO m, BackendCompatible SqlBackend backend) =>
ReaderT backend m a
-> Pool backend
-> Maybe IsolationLevel
-> (backend -> m before)
-> (backend -> m after)
-> (backend -> SomeException -> m onException)
-> m a
runSqlPoolWithHooks ReaderT backend m a
r Pool backend
pconn Maybe IsolationLevel
mi backend -> m ()
before forall {sub} {m :: * -> *}.
(BackendCompatible SqlBackend sub, MonadIO m) =>
sub -> m ()
after forall {sub} {m :: * -> *} {p}.
(BackendCompatible SqlBackend sub, MonadIO m) =>
sub -> p -> m ()
onException
  where
    before :: backend -> m ()
before backend
conn = do
        let sqlBackend :: SqlBackend
sqlBackend = forall sup sub. BackendCompatible sup sub => sub -> sup
projectBackend backend
conn
        let getter :: Text -> IO Statement
getter = SqlBackend -> Text -> IO Statement
getStmtConn SqlBackend
sqlBackend
        forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ SqlBackend
-> (Text -> IO Statement) -> Maybe IsolationLevel -> IO ()
connBegin SqlBackend
sqlBackend Text -> IO Statement
getter Maybe IsolationLevel
mi
    after :: sub -> m ()
after sub
conn = do
        let sqlBackend :: SqlBackend
sqlBackend = forall sup sub. BackendCompatible sup sub => sub -> sup
projectBackend sub
conn
        let getter :: Text -> IO Statement
getter = SqlBackend -> Text -> IO Statement
getStmtConn SqlBackend
sqlBackend
        forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ SqlBackend -> (Text -> IO Statement) -> IO ()
connCommit SqlBackend
sqlBackend Text -> IO Statement
getter
    onException :: sub -> p -> m ()
onException sub
conn p
_ = do
        let sqlBackend :: SqlBackend
sqlBackend = forall sup sub. BackendCompatible sup sub => sub -> sup
projectBackend sub
conn
        let getter :: Text -> IO Statement
getter = SqlBackend -> Text -> IO Statement
getStmtConn SqlBackend
sqlBackend
        forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ SqlBackend -> (Text -> IO Statement) -> IO ()
connRollback SqlBackend
sqlBackend Text -> IO Statement
getter

-- | This function is how 'runSqlPool' and 'runSqlPoolNoTransaction' are
-- defined. In addition to the action to be performed and the 'Pool' of
-- conections to use, we give you the opportunity to provide three actions
-- - initialize, afterwards, and onException.
--
-- @since 2.12.0.0
runSqlPoolWithHooks
    :: forall backend m a before after onException. (MonadUnliftIO m, BackendCompatible SqlBackend backend)
    => ReaderT backend m a
    -> Pool backend
    -> Maybe IsolationLevel
    -> (backend -> m before)
    -- ^ Run this action immediately before the action is performed.
    -> (backend -> m after)
    -- ^ Run this action immediately after the action is completed.
    -> (backend -> UE.SomeException -> m onException)
    -- ^ This action is performed when an exception is received. The
    -- exception is provided as a convenience - it is rethrown once this
    -- cleanup function is complete.
    -> m a
runSqlPoolWithHooks :: forall backend (m :: * -> *) a before after onException.
(MonadUnliftIO m, BackendCompatible SqlBackend backend) =>
ReaderT backend m a
-> Pool backend
-> Maybe IsolationLevel
-> (backend -> m before)
-> (backend -> m after)
-> (backend -> SomeException -> m onException)
-> m a
runSqlPoolWithHooks ReaderT backend m a
r Pool backend
pconn Maybe IsolationLevel
i backend -> m before
before backend -> m after
after backend -> SomeException -> m onException
onException =
    forall backend (m :: * -> *) a.
(MonadUnliftIO m, BackendCompatible SqlBackend backend) =>
ReaderT backend m a
-> Pool backend
-> Maybe IsolationLevel
-> SqlPoolHooks m backend
-> m a
runSqlPoolWithExtensibleHooks ReaderT backend m a
r Pool backend
pconn Maybe IsolationLevel
i forall a b. (a -> b) -> a -> b
$ SqlPoolHooks
        { alterBackend :: backend -> m backend
alterBackend = forall (f :: * -> *) a. Applicative f => a -> f a
pure
        , runBefore :: backend -> Maybe IsolationLevel -> m ()
runBefore = \backend
conn Maybe IsolationLevel
_ -> forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ backend -> m before
before backend
conn
        , runAfter :: backend -> Maybe IsolationLevel -> m ()
runAfter = \backend
conn Maybe IsolationLevel
_ -> forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ backend -> m after
after backend
conn
        , runOnException :: backend -> Maybe IsolationLevel -> SomeException -> m ()
runOnException = \backend
b Maybe IsolationLevel
_ SomeException
e -> forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ backend -> SomeException -> m onException
onException backend
b SomeException
e
        }

-- | This function is how 'runSqlPoolWithHooks' is defined.
--
-- It's currently the most general function for using a SQL pool.
--
-- @since 2.13.0.0
runSqlPoolWithExtensibleHooks
    :: forall backend m a. (MonadUnliftIO m, BackendCompatible SqlBackend backend)
    => ReaderT backend m a
    -> Pool backend
    -> Maybe IsolationLevel
    -> SqlPoolHooks m backend
    -> m a
runSqlPoolWithExtensibleHooks :: forall backend (m :: * -> *) a.
(MonadUnliftIO m, BackendCompatible SqlBackend backend) =>
ReaderT backend m a
-> Pool backend
-> Maybe IsolationLevel
-> SqlPoolHooks m backend
-> m a
runSqlPoolWithExtensibleHooks ReaderT backend m a
r Pool backend
pconn Maybe IsolationLevel
i SqlPoolHooks{backend -> m backend
backend -> Maybe IsolationLevel -> m ()
backend -> Maybe IsolationLevel -> SomeException -> m ()
runOnException :: backend -> Maybe IsolationLevel -> SomeException -> m ()
runAfter :: backend -> Maybe IsolationLevel -> m ()
runBefore :: backend -> Maybe IsolationLevel -> m ()
alterBackend :: backend -> m backend
runOnException :: forall (m :: * -> *) backend.
SqlPoolHooks m backend
-> backend -> Maybe IsolationLevel -> SomeException -> m ()
runAfter :: forall (m :: * -> *) backend.
SqlPoolHooks m backend -> backend -> Maybe IsolationLevel -> m ()
runBefore :: forall (m :: * -> *) backend.
SqlPoolHooks m backend -> backend -> Maybe IsolationLevel -> m ()
alterBackend :: forall (m :: * -> *) backend.
SqlPoolHooks m backend -> backend -> m backend
..} =
    forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO forall a b. (a -> b) -> a -> b
$ \forall a. m a -> IO a
runInIO ->
    forall a r. Pool a -> (a -> IO r) -> IO r
withResource Pool backend
pconn forall a b. (a -> b) -> a -> b
$ \backend
conn ->
    forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> m a) -> m b) -> m b
UE.mask forall a b. (a -> b) -> a -> b
$ \forall a. IO a -> IO a
restore -> do
        backend
conn' <- forall a. IO a -> IO a
restore forall a b. (a -> b) -> a -> b
$ forall a. m a -> IO a
runInIO forall a b. (a -> b) -> a -> b
$ backend -> m backend
alterBackend backend
conn
        ()
_ <- forall a. IO a -> IO a
restore forall a b. (a -> b) -> a -> b
$ forall a. m a -> IO a
runInIO forall a b. (a -> b) -> a -> b
$ backend -> Maybe IsolationLevel -> m ()
runBefore backend
conn' Maybe IsolationLevel
i
        a
a <- forall a. IO a -> IO a
restore (forall a. m a -> IO a
runInIO (forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT backend m a
r backend
conn'))
            forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> (SomeException -> m a) -> m a
`UE.catchAny` \SomeException
e -> do
                ()
_ <- forall a. IO a -> IO a
restore forall a b. (a -> b) -> a -> b
$ forall a. m a -> IO a
runInIO forall a b. (a -> b) -> a -> b
$ backend -> Maybe IsolationLevel -> SomeException -> m ()
runOnException backend
conn' Maybe IsolationLevel
i SomeException
e
                forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
UE.throwIO SomeException
e
        ()
_ <- forall a. IO a -> IO a
restore forall a b. (a -> b) -> a -> b
$ forall a. m a -> IO a
runInIO forall a b. (a -> b) -> a -> b
$ backend -> Maybe IsolationLevel -> m ()
runAfter backend
conn' Maybe IsolationLevel
i
        forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a

rawAcquireSqlConn
    :: forall backend m
     . (MonadReader backend m, BackendCompatible SqlBackend backend)
    => Maybe IsolationLevel -> m (Acquire backend)
rawAcquireSqlConn :: forall backend (m :: * -> *).
(MonadReader backend m, BackendCompatible SqlBackend backend) =>
Maybe IsolationLevel -> m (Acquire backend)
rawAcquireSqlConn Maybe IsolationLevel
isolation = do
    backend
conn <- forall r (m :: * -> *). MonadReader r m => m r
MonadReader.ask
    let rawConn :: SqlBackend
        rawConn :: SqlBackend
rawConn = forall sup sub. BackendCompatible sup sub => sub -> sup
projectBackend backend
conn

        getter :: T.Text -> IO Statement
        getter :: Text -> IO Statement
getter = SqlBackend -> Text -> IO Statement
getStmtConn SqlBackend
rawConn

        beginTransaction :: IO backend
        beginTransaction :: IO backend
beginTransaction = backend
conn forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ SqlBackend
-> (Text -> IO Statement) -> Maybe IsolationLevel -> IO ()
connBegin SqlBackend
rawConn Text -> IO Statement
getter Maybe IsolationLevel
isolation

        finishTransaction :: backend -> ReleaseType -> IO ()
        finishTransaction :: backend -> ReleaseType -> IO ()
finishTransaction backend
_ ReleaseType
relType = case ReleaseType
relType of
            ReleaseType
ReleaseException -> do
                SqlBackend -> (Text -> IO Statement) -> IO ()
connRollback SqlBackend
rawConn Text -> IO Statement
getter
            ReleaseType
_ -> SqlBackend -> (Text -> IO Statement) -> IO ()
connCommit SqlBackend
rawConn Text -> IO Statement
getter

    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. IO a -> (a -> ReleaseType -> IO ()) -> Acquire a
mkAcquireType IO backend
beginTransaction backend -> ReleaseType -> IO ()
finishTransaction

-- | Starts a new transaction on the connection. When the acquired connection
-- is released the transaction is committed and the connection returned to the
-- pool.
--
-- Upon an exception the transaction is rolled back and the connection
-- destroyed.
--
-- This is equivalent to 'runSqlConn' but does not incur the 'MonadUnliftIO'
-- constraint, meaning it can be used within, for example, a 'Conduit'
-- pipeline.
--
-- @since 2.10.5
acquireSqlConn
    :: (MonadReader backend m, BackendCompatible SqlBackend backend)
    => m (Acquire backend)
acquireSqlConn :: forall backend (m :: * -> *).
(MonadReader backend m, BackendCompatible SqlBackend backend) =>
m (Acquire backend)
acquireSqlConn = forall backend (m :: * -> *).
(MonadReader backend m, BackendCompatible SqlBackend backend) =>
Maybe IsolationLevel -> m (Acquire backend)
rawAcquireSqlConn forall a. Maybe a
Nothing

-- | Like 'acquireSqlConn', but lets you specify an explicit isolation level.
--
-- @since 2.10.5
acquireSqlConnWithIsolation
    :: (MonadReader backend m, BackendCompatible SqlBackend backend)
    => IsolationLevel -> m (Acquire backend)
acquireSqlConnWithIsolation :: forall backend (m :: * -> *).
(MonadReader backend m, BackendCompatible SqlBackend backend) =>
IsolationLevel -> m (Acquire backend)
acquireSqlConnWithIsolation = forall backend (m :: * -> *).
(MonadReader backend m, BackendCompatible SqlBackend backend) =>
Maybe IsolationLevel -> m (Acquire backend)
rawAcquireSqlConn forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just

runSqlConn :: forall backend m a. (MonadUnliftIO m, BackendCompatible SqlBackend backend) => ReaderT backend m a -> backend -> m a
runSqlConn :: forall backend (m :: * -> *) a.
(MonadUnliftIO m, BackendCompatible SqlBackend backend) =>
ReaderT backend m a -> backend -> m a
runSqlConn ReaderT backend m a
r backend
conn = forall (m :: * -> *) a b.
MonadUnliftIO m =>
Acquire a -> (a -> m b) -> m b
with (forall backend (m :: * -> *).
(MonadReader backend m, BackendCompatible SqlBackend backend) =>
m (Acquire backend)
acquireSqlConn backend
conn) forall a b. (a -> b) -> a -> b
$ forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT backend m a
r

-- | Like 'runSqlConn', but supports specifying an isolation level.
--
-- @since 2.9.0
runSqlConnWithIsolation :: forall backend m a. (MonadUnliftIO m, BackendCompatible SqlBackend backend) => ReaderT backend m a -> backend -> IsolationLevel -> m a
runSqlConnWithIsolation :: forall backend (m :: * -> *) a.
(MonadUnliftIO m, BackendCompatible SqlBackend backend) =>
ReaderT backend m a -> backend -> IsolationLevel -> m a
runSqlConnWithIsolation ReaderT backend m a
r backend
conn IsolationLevel
isolation =
  forall (m :: * -> *) a b.
MonadUnliftIO m =>
Acquire a -> (a -> m b) -> m b
with (forall backend (m :: * -> *).
(MonadReader backend m, BackendCompatible SqlBackend backend) =>
IsolationLevel -> m (Acquire backend)
acquireSqlConnWithIsolation IsolationLevel
isolation backend
conn) forall a b. (a -> b) -> a -> b
$ forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT backend m a
r

runSqlPersistM
    :: (BackendCompatible SqlBackend backend)
    => ReaderT backend (NoLoggingT (ResourceT IO)) a -> backend -> IO a
runSqlPersistM :: forall backend a.
BackendCompatible SqlBackend backend =>
ReaderT backend (NoLoggingT (ResourceT IO)) a -> backend -> IO a
runSqlPersistM ReaderT backend (NoLoggingT (ResourceT IO)) a
x backend
conn = forall (m :: * -> *) a. MonadUnliftIO m => ResourceT m a -> m a
runResourceT forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. NoLoggingT m a -> m a
runNoLoggingT forall a b. (a -> b) -> a -> b
$ forall backend (m :: * -> *) a.
(MonadUnliftIO m, BackendCompatible SqlBackend backend) =>
ReaderT backend m a -> backend -> m a
runSqlConn ReaderT backend (NoLoggingT (ResourceT IO)) a
x backend
conn

runSqlPersistMPool
    :: (BackendCompatible SqlBackend backend)
    => ReaderT backend (NoLoggingT (ResourceT IO)) a -> Pool backend -> IO a
runSqlPersistMPool :: forall backend a.
BackendCompatible SqlBackend backend =>
ReaderT backend (NoLoggingT (ResourceT IO)) a
-> Pool backend -> IO a
runSqlPersistMPool ReaderT backend (NoLoggingT (ResourceT IO)) a
x Pool backend
pool = forall (m :: * -> *) a. MonadUnliftIO m => ResourceT m a -> m a
runResourceT forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. NoLoggingT m a -> m a
runNoLoggingT forall a b. (a -> b) -> a -> b
$ forall backend (m :: * -> *) a.
(MonadUnliftIO m, BackendCompatible SqlBackend backend) =>
ReaderT backend m a -> Pool backend -> m a
runSqlPool ReaderT backend (NoLoggingT (ResourceT IO)) a
x Pool backend
pool

liftSqlPersistMPool
    :: forall backend m a. (MonadIO m, BackendCompatible SqlBackend backend)
    => ReaderT backend (NoLoggingT (ResourceT IO)) a -> Pool backend -> m a
liftSqlPersistMPool :: forall backend (m :: * -> *) a.
(MonadIO m, BackendCompatible SqlBackend backend) =>
ReaderT backend (NoLoggingT (ResourceT IO)) a
-> Pool backend -> m a
liftSqlPersistMPool ReaderT backend (NoLoggingT (ResourceT IO)) a
x Pool backend
pool = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (forall backend a.
BackendCompatible SqlBackend backend =>
ReaderT backend (NoLoggingT (ResourceT IO)) a
-> Pool backend -> IO a
runSqlPersistMPool ReaderT backend (NoLoggingT (ResourceT IO)) a
x Pool backend
pool)

withSqlPool
    :: forall backend m a. (MonadLoggerIO m, MonadUnliftIO m, BackendCompatible SqlBackend backend)
    => (LogFunc -> IO backend) -- ^ create a new connection
    -> Int -- ^ connection count
    -> (Pool backend -> m a)
    -> m a
withSqlPool :: forall backend (m :: * -> *) a.
(MonadLoggerIO m, MonadUnliftIO m,
 BackendCompatible SqlBackend backend) =>
(LogFunc -> IO backend) -> Int -> (Pool backend -> m a) -> m a
withSqlPool LogFunc -> IO backend
mkConn Int
connCount Pool backend -> m a
f = forall backend (m :: * -> *) a.
(MonadLoggerIO m, MonadUnliftIO m,
 BackendCompatible SqlBackend backend) =>
(LogFunc -> IO backend)
-> ConnectionPoolConfig -> (Pool backend -> m a) -> m a
withSqlPoolWithConfig LogFunc -> IO backend
mkConn (ConnectionPoolConfig
defaultConnectionPoolConfig { connectionPoolConfigSize :: Int
connectionPoolConfigSize = Int
connCount } ) Pool backend -> m a
f

-- | Creates a pool of connections to a SQL database which can be used by the @Pool backend -> m a@ function.
-- After the function completes, the connections are destroyed.
--
-- @since 2.11.0.0
withSqlPoolWithConfig
    :: forall backend m a. (MonadLoggerIO m, MonadUnliftIO m, BackendCompatible SqlBackend backend)
    => (LogFunc -> IO backend) -- ^ Function to create a new connection
    -> ConnectionPoolConfig
    -> (Pool backend -> m a)
    -> m a
withSqlPoolWithConfig :: forall backend (m :: * -> *) a.
(MonadLoggerIO m, MonadUnliftIO m,
 BackendCompatible SqlBackend backend) =>
(LogFunc -> IO backend)
-> ConnectionPoolConfig -> (Pool backend -> m a) -> m a
withSqlPoolWithConfig LogFunc -> IO backend
mkConn ConnectionPoolConfig
poolConfig Pool backend -> m a
f = forall (m :: * -> *) a.
MonadUnliftIO m =>
(UnliftIO m -> IO a) -> m a
withUnliftIO forall a b. (a -> b) -> a -> b
$ \UnliftIO m
u -> forall (m :: * -> *) a b c.
MonadUnliftIO m =>
m a -> (a -> m b) -> (a -> m c) -> m c
UE.bracket
    (forall (m :: * -> *). UnliftIO m -> forall a. m a -> IO a
unliftIO UnliftIO m
u forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) backend.
(MonadLoggerIO m, MonadUnliftIO m,
 BackendCompatible SqlBackend backend) =>
(LogFunc -> IO backend) -> ConnectionPoolConfig -> m (Pool backend)
createSqlPoolWithConfig LogFunc -> IO backend
mkConn ConnectionPoolConfig
poolConfig)
    forall a. Pool a -> IO ()
destroyAllResources
    (forall (m :: * -> *). UnliftIO m -> forall a. m a -> IO a
unliftIO UnliftIO m
u forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pool backend -> m a
f)

createSqlPool
    :: forall backend m. (MonadLoggerIO m, MonadUnliftIO m, BackendCompatible SqlBackend backend)
    => (LogFunc -> IO backend)
    -> Int
    -> m (Pool backend)
createSqlPool :: forall backend (m :: * -> *).
(MonadLoggerIO m, MonadUnliftIO m,
 BackendCompatible SqlBackend backend) =>
(LogFunc -> IO backend) -> Int -> m (Pool backend)
createSqlPool LogFunc -> IO backend
mkConn Int
size = forall (m :: * -> *) backend.
(MonadLoggerIO m, MonadUnliftIO m,
 BackendCompatible SqlBackend backend) =>
(LogFunc -> IO backend) -> ConnectionPoolConfig -> m (Pool backend)
createSqlPoolWithConfig LogFunc -> IO backend
mkConn (ConnectionPoolConfig
defaultConnectionPoolConfig { connectionPoolConfigSize :: Int
connectionPoolConfigSize = Int
size } )

-- | Creates a pool of connections to a SQL database.
--
-- @since 2.11.0.0
createSqlPoolWithConfig
    :: forall m backend. (MonadLoggerIO m, MonadUnliftIO m, BackendCompatible SqlBackend backend)
    => (LogFunc -> IO backend) -- ^ Function to create a new connection
    -> ConnectionPoolConfig
    -> m (Pool backend)
createSqlPoolWithConfig :: forall (m :: * -> *) backend.
(MonadLoggerIO m, MonadUnliftIO m,
 BackendCompatible SqlBackend backend) =>
(LogFunc -> IO backend) -> ConnectionPoolConfig -> m (Pool backend)
createSqlPoolWithConfig LogFunc -> IO backend
mkConn ConnectionPoolConfig
config = do
    LogFunc
logFunc <- forall (m :: * -> *). MonadLoggerIO m => m LogFunc
askLoggerIO
    -- Resource pool will swallow any exceptions from close. We want to log
    -- them instead.
    let loggedClose :: backend -> IO ()
        loggedClose :: backend -> IO ()
loggedClose backend
backend = forall backend.
BackendCompatible SqlBackend backend =>
backend -> IO ()
close' backend
backend forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> (SomeException -> m a) -> m a
`UE.catchAny` \SomeException
e -> do
            forall (m :: * -> *) a. LoggingT m a -> LogFunc -> m a
runLoggingT
              (forall (m :: * -> *). (HasCallStack, MonadLogger m) => Text -> m ()
logError forall a b. (a -> b) -> a -> b
$ [Char] -> Text
T.pack forall a b. (a -> b) -> a -> b
$ [Char]
"Error closing database connection in pool: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show SomeException
e)
              LogFunc
logFunc
            forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
UE.throwIO SomeException
e
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a.
IO a
-> (a -> IO ()) -> Int -> NominalDiffTime -> Int -> IO (Pool a)
createPool
        (LogFunc -> IO backend
mkConn LogFunc
logFunc)
        backend -> IO ()
loggedClose
        (ConnectionPoolConfig -> Int
connectionPoolConfigStripes ConnectionPoolConfig
config)
        (ConnectionPoolConfig -> NominalDiffTime
connectionPoolConfigIdleTimeout ConnectionPoolConfig
config)
        (ConnectionPoolConfig -> Int
connectionPoolConfigSize ConnectionPoolConfig
config)

-- | Create a connection and run sql queries within it. This function
-- automatically closes the connection on it's completion.
--
-- === __Example usage__
--
-- > {-# LANGUAGE GADTs #-}
-- > {-# LANGUAGE ScopedTypeVariables #-}
-- > {-# LANGUAGE OverloadedStrings #-}
-- > {-# LANGUAGE MultiParamTypeClasses #-}
-- > {-# LANGUAGE TypeFamilies#-}
-- > {-# LANGUAGE TemplateHaskell#-}
-- > {-# LANGUAGE QuasiQuotes#-}
-- > {-# LANGUAGE GeneralizedNewtypeDeriving #-}
-- >
-- > import Control.Monad.IO.Class  (liftIO)
-- > import Control.Monad.Logger
-- > import Conduit
-- > import Database.Persist
-- > import Database.Sqlite
-- > import Database.Persist.Sqlite
-- > import Database.Persist.TH
-- >
-- > share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase|
-- > Person
-- >   name String
-- >   age Int Maybe
-- >   deriving Show
-- > |]
-- >
-- > openConnection :: LogFunc -> IO SqlBackend
-- > openConnection logfn = do
-- >  conn <- open "/home/sibi/test.db"
-- >  wrapConnection conn logfn
-- >
-- > main :: IO ()
-- > main = do
-- >   runNoLoggingT $ runResourceT $ withSqlConn openConnection (\backend ->
-- >                                       flip runSqlConn backend $ do
-- >                                         runMigration migrateAll
-- >                                         insert_ $ Person "John doe" $ Just 35
-- >                                         insert_ $ Person "Divya" $ Just 36
-- >                                         (pers :: [Entity Person]) <- selectList [] []
-- >                                         liftIO $ print pers
-- >                                         return ()
-- >                                      )
--
-- On executing it, you get this output:
--
-- > Migrating: CREATE TABLE "person"("id" INTEGER PRIMARY KEY,"name" VARCHAR NOT NULL,"age" INTEGER NULL)
-- > [Entity {entityKey = PersonKey {unPersonKey = SqlBackendKey {unSqlBackendKey = 1}}, entityVal = Person {personName = "John doe", personAge = Just 35}},Entity {entityKey = PersonKey {unPersonKey = SqlBackendKey {unSqlBackendKey = 2}}, entityVal = Person {personName = "Hema", personAge = Just 36}}]
--

withSqlConn
    :: forall backend m a. (MonadUnliftIO m, MonadLoggerIO m, BackendCompatible SqlBackend backend)
    => (LogFunc -> IO backend) -> (backend -> m a) -> m a
withSqlConn :: forall backend (m :: * -> *) a.
(MonadUnliftIO m, MonadLoggerIO m,
 BackendCompatible SqlBackend backend) =>
(LogFunc -> IO backend) -> (backend -> m a) -> m a
withSqlConn LogFunc -> IO backend
open backend -> m a
f = do
    LogFunc
logFunc <- forall (m :: * -> *). MonadLoggerIO m => m LogFunc
askLoggerIO
    forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO forall a b. (a -> b) -> a -> b
$ \forall a. m a -> IO a
run -> forall (m :: * -> *) a b c.
MonadUnliftIO m =>
m a -> (a -> m b) -> (a -> m c) -> m c
UE.bracket
      (LogFunc -> IO backend
open LogFunc
logFunc)
      forall backend.
BackendCompatible SqlBackend backend =>
backend -> IO ()
close'
      (forall a. m a -> IO a
run forall b c a. (b -> c) -> (a -> b) -> a -> c
. backend -> m a
f)

close' :: (BackendCompatible SqlBackend backend) => backend -> IO ()
close' :: forall backend.
BackendCompatible SqlBackend backend =>
backend -> IO ()
close' backend
conn = do
    let backend :: SqlBackend
backend = forall sup sub. BackendCompatible sup sub => sub -> sup
projectBackend backend
conn
    StatementCache -> IO ()
statementCacheClear forall a b. (a -> b) -> a -> b
$ SqlBackend -> StatementCache
connStmtMap SqlBackend
backend
    SqlBackend -> IO ()
connClose SqlBackend
backend