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

import Control.Exception (bracket, mask, onException)
import Control.Monad (liftM)
import Control.Monad.IO.Unlift
import qualified UnliftIO.Exception as UE
import Control.Monad.Logger.CallStack
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.IORef (readIORef)
import Data.Pool (Pool, LocalPool)
import Data.Pool as P
import qualified Data.Map as Map
import qualified Data.Text as T
import System.Timeout (timeout)

import Database.Persist.Class.PersistStore
import Database.Persist.Sql.Types
import Database.Persist.Sql.Types.Internal (IsolationLevel)
import Database.Persist.Sql.Raw

-- | The returned 'Acquire' gets a connection from the pool, but does __NOT__
-- start a new transaction. Used to implement 'acquireSqlConnFromPool' and
-- 'acquireSqlConnFromPoolWithIsolation', this is useful for performing actions
-- on a connection that cannot be done within a transaction, such as VACUUM in
-- Sqlite.
--
-- @since 2.10.5
unsafeAcquireSqlConnFromPool
    :: forall backend m
     . (MonadReader (Pool backend) m, BackendCompatible SqlBackend backend)
    => m (Acquire backend)
unsafeAcquireSqlConnFromPool :: m (Acquire backend)
unsafeAcquireSqlConnFromPool = do
    Pool backend
pool <- m (Pool backend)
forall r (m :: * -> *). MonadReader r m => m r
MonadReader.ask

    let freeConn :: (backend, LocalPool backend) -> ReleaseType -> IO ()
        freeConn :: (backend, LocalPool backend) -> ReleaseType -> IO ()
freeConn (backend
res, LocalPool backend
localPool) ReleaseType
relType = case ReleaseType
relType of
            ReleaseType
ReleaseException -> Pool backend -> LocalPool backend -> backend -> IO ()
forall a. Pool a -> LocalPool a -> a -> IO ()
P.destroyResource Pool backend
pool LocalPool backend
localPool backend
res
            ReleaseType
_ -> LocalPool backend -> backend -> IO ()
forall a. LocalPool a -> a -> IO ()
P.putResource LocalPool backend
localPool backend
res

    Acquire backend -> m (Acquire backend)
forall (m :: * -> *) a. Monad m => a -> m a
return (Acquire backend -> m (Acquire backend))
-> Acquire backend -> m (Acquire backend)
forall a b. (a -> b) -> a -> b
$ (backend, LocalPool backend) -> backend
forall a b. (a, b) -> a
fst ((backend, LocalPool backend) -> backend)
-> Acquire (backend, LocalPool backend) -> Acquire backend
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (backend, LocalPool backend)
-> ((backend, LocalPool backend) -> ReleaseType -> IO ())
-> Acquire (backend, LocalPool backend)
forall a. IO a -> (a -> ReleaseType -> IO ()) -> Acquire a
mkAcquireType (Pool backend -> IO (backend, LocalPool backend)
forall a. Pool a -> IO (a, LocalPool a)
P.takeResource Pool backend
pool) (backend, LocalPool backend) -> ReleaseType -> IO ()
freeConn


-- | The returned 'Acquire' gets a connection from the pool, starts a new
-- transaction and gives access to the prepared 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 'runSqlPool' but does not incur the 'MonadUnliftIO'
-- constraint, meaning it can be used within, for example, a 'Conduit'
-- pipeline.
--
-- @since 2.10.5
acquireSqlConnFromPool
    :: (MonadReader (Pool backend) m, BackendCompatible SqlBackend backend)
    => m (Acquire backend)
acquireSqlConnFromPool :: m (Acquire backend)
acquireSqlConnFromPool = do
    Acquire backend
connFromPool <- m (Acquire backend)
forall backend (m :: * -> *).
(MonadReader (Pool backend) m,
 BackendCompatible SqlBackend backend) =>
m (Acquire backend)
unsafeAcquireSqlConnFromPool
    Acquire backend -> m (Acquire backend)
forall (m :: * -> *) a. Monad m => a -> m a
return (Acquire backend -> m (Acquire backend))
-> Acquire backend -> m (Acquire backend)
forall a b. (a -> b) -> a -> b
$ Acquire backend
connFromPool Acquire backend -> (backend -> Acquire backend) -> Acquire backend
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= backend -> Acquire backend
forall backend (m :: * -> *).
(MonadReader backend m, BackendCompatible SqlBackend backend) =>
m (Acquire backend)
acquireSqlConn

-- | Like 'acquireSqlConnFromPool', but lets you specify an explicit isolation
-- level.
--
-- @since 2.10.5
acquireSqlConnFromPoolWithIsolation
    :: (MonadReader (Pool backend) m, BackendCompatible SqlBackend backend)
    => IsolationLevel -> m (Acquire backend)
acquireSqlConnFromPoolWithIsolation :: IsolationLevel -> m (Acquire backend)
acquireSqlConnFromPoolWithIsolation IsolationLevel
isolation = do
    Acquire backend
connFromPool <- m (Acquire backend)
forall backend (m :: * -> *).
(MonadReader (Pool backend) m,
 BackendCompatible SqlBackend backend) =>
m (Acquire backend)
unsafeAcquireSqlConnFromPool
    Acquire backend -> m (Acquire backend)
forall (m :: * -> *) a. Monad m => a -> m a
return (Acquire backend -> m (Acquire backend))
-> Acquire backend -> m (Acquire backend)
forall a b. (a -> b) -> a -> b
$ Acquire backend
connFromPool Acquire backend -> (backend -> Acquire backend) -> Acquire backend
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IsolationLevel -> backend -> Acquire backend
forall backend (m :: * -> *).
(MonadReader backend m, BackendCompatible SqlBackend backend) =>
IsolationLevel -> m (Acquire backend)
acquireSqlConnWithIsolation IsolationLevel
isolation

-- | Get a connection from the pool, run the given action, and then return the
-- connection to the pool.
--
-- 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 :: ReaderT backend m a -> Pool backend -> m a
runSqlPool ReaderT backend m a
r Pool backend
pconn = Acquire backend -> (backend -> m a) -> m a
forall (m :: * -> *) a b.
MonadUnliftIO m =>
Acquire a -> (a -> m b) -> m b
with (Pool backend -> Acquire backend
forall backend (m :: * -> *).
(MonadReader (Pool backend) m,
 BackendCompatible SqlBackend backend) =>
m (Acquire backend)
acquireSqlConnFromPool Pool backend
pconn) ((backend -> m a) -> m a) -> (backend -> m a) -> m a
forall a b. (a -> b) -> a -> b
$ ReaderT backend m a -> backend -> m a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT backend m a
r

-- | 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 :: ReaderT backend m a -> Pool backend -> IsolationLevel -> m a
runSqlPoolWithIsolation ReaderT backend m a
r Pool backend
pconn IsolationLevel
i =
    Acquire backend -> (backend -> m a) -> m a
forall (m :: * -> *) a b.
MonadUnliftIO m =>
Acquire a -> (a -> m b) -> m b
with (IsolationLevel -> Pool backend -> Acquire backend
forall backend (m :: * -> *).
(MonadReader (Pool backend) m,
 BackendCompatible SqlBackend backend) =>
IsolationLevel -> m (Acquire backend)
acquireSqlConnFromPoolWithIsolation IsolationLevel
i Pool backend
pconn) ((backend -> m a) -> m a) -> (backend -> m a) -> m a
forall a b. (a -> b) -> a -> b
$ ReaderT backend m a -> backend -> m a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT backend m a
r

-- | Like 'withResource', but times out the operation if resource
-- allocation does not complete within the given timeout period.
--
-- @since 2.0.0
withResourceTimeout
  :: forall a m b.  (MonadUnliftIO m)
  => Int -- ^ Timeout period in microseconds
  -> Pool a
  -> (a -> m b)
  -> m (Maybe b)
{-# SPECIALIZE withResourceTimeout :: Int -> Pool a -> (a -> IO b) -> IO (Maybe b) #-}
withResourceTimeout :: Int -> Pool a -> (a -> m b) -> m (Maybe b)
withResourceTimeout Int
ms Pool a
pool a -> m b
act = ((forall a. m a -> IO a) -> IO (Maybe b)) -> m (Maybe b)
forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO (((forall a. m a -> IO a) -> IO (Maybe b)) -> m (Maybe b))
-> ((forall a. m a -> IO a) -> IO (Maybe b)) -> m (Maybe b)
forall a b. (a -> b) -> a -> b
$ \forall a. m a -> IO a
runInIO -> ((forall a. IO a -> IO a) -> IO (Maybe b)) -> IO (Maybe b)
forall b. ((forall a. IO a -> IO a) -> IO b) -> IO b
mask (((forall a. IO a -> IO a) -> IO (Maybe b)) -> IO (Maybe b))
-> ((forall a. IO a -> IO a) -> IO (Maybe b)) -> IO (Maybe b)
forall a b. (a -> b) -> a -> b
$ \forall a. IO a -> IO a
restore -> do
    Maybe (a, LocalPool a)
mres <- Int -> IO (a, LocalPool a) -> IO (Maybe (a, LocalPool a))
forall a. Int -> IO a -> IO (Maybe a)
timeout Int
ms (IO (a, LocalPool a) -> IO (Maybe (a, LocalPool a)))
-> IO (a, LocalPool a) -> IO (Maybe (a, LocalPool a))
forall a b. (a -> b) -> a -> b
$ Pool a -> IO (a, LocalPool a)
forall a. Pool a -> IO (a, LocalPool a)
takeResource Pool a
pool
    case Maybe (a, LocalPool a)
mres of
        Maybe (a, LocalPool a)
Nothing -> m (Maybe b) -> IO (Maybe b)
forall a. m a -> IO a
runInIO (m (Maybe b) -> IO (Maybe b)) -> m (Maybe b) -> IO (Maybe b)
forall a b. (a -> b) -> a -> b
$ Maybe b -> m (Maybe b)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe b
forall a. Maybe a
Nothing :: Maybe b)
        Just (a
resource, LocalPool a
local) -> do
            Maybe b
ret <- IO (Maybe b) -> IO (Maybe b)
forall a. IO a -> IO a
restore (m (Maybe b) -> IO (Maybe b)
forall a. m a -> IO a
runInIO ((b -> Maybe b) -> m b -> m (Maybe b)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM b -> Maybe b
forall a. a -> Maybe a
Just (m b -> m (Maybe b)) -> m b -> m (Maybe b)
forall a b. (a -> b) -> a -> b
$ a -> m b
act a
resource)) IO (Maybe b) -> IO () -> IO (Maybe b)
forall a b. IO a -> IO b -> IO a
`onException`
                    Pool a -> LocalPool a -> a -> IO ()
forall a. Pool a -> LocalPool a -> a -> IO ()
destroyResource Pool a
pool LocalPool a
local a
resource
            LocalPool a -> a -> IO ()
forall a. LocalPool a -> a -> IO ()
putResource LocalPool a
local a
resource
            Maybe b -> IO (Maybe b)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe b
ret
{-# INLINABLE withResourceTimeout #-}

rawAcquireSqlConn
    :: forall backend m
     . (MonadReader backend m, BackendCompatible SqlBackend backend)
    => Maybe IsolationLevel -> m (Acquire backend)
rawAcquireSqlConn :: Maybe IsolationLevel -> m (Acquire backend)
rawAcquireSqlConn Maybe IsolationLevel
isolation = do
    backend
conn <- m backend
forall r (m :: * -> *). MonadReader r m => m r
MonadReader.ask
    let rawConn :: SqlBackend
        rawConn :: SqlBackend
rawConn = backend -> SqlBackend
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 backend -> IO () -> IO backend
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 -> 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

    Acquire backend -> m (Acquire backend)
forall (m :: * -> *) a. Monad m => a -> m a
return (Acquire backend -> m (Acquire backend))
-> Acquire backend -> m (Acquire backend)
forall a b. (a -> b) -> a -> b
$ IO backend -> (backend -> ReleaseType -> IO ()) -> Acquire backend
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 :: m (Acquire backend)
acquireSqlConn = Maybe IsolationLevel -> m (Acquire backend)
forall backend (m :: * -> *).
(MonadReader backend m, BackendCompatible SqlBackend backend) =>
Maybe IsolationLevel -> m (Acquire backend)
rawAcquireSqlConn Maybe IsolationLevel
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 :: IsolationLevel -> m (Acquire backend)
acquireSqlConnWithIsolation = Maybe IsolationLevel -> m (Acquire backend)
forall backend (m :: * -> *).
(MonadReader backend m, BackendCompatible SqlBackend backend) =>
Maybe IsolationLevel -> m (Acquire backend)
rawAcquireSqlConn (Maybe IsolationLevel -> m (Acquire backend))
-> (IsolationLevel -> Maybe IsolationLevel)
-> IsolationLevel
-> m (Acquire backend)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IsolationLevel -> Maybe IsolationLevel
forall a. a -> Maybe a
Just

runSqlConn :: forall backend m a. (MonadUnliftIO m, BackendCompatible SqlBackend backend) => ReaderT backend m a -> backend -> m a
runSqlConn :: ReaderT backend m a -> backend -> m a
runSqlConn ReaderT backend m a
r backend
conn = Acquire backend -> (backend -> m a) -> m a
forall (m :: * -> *) a b.
MonadUnliftIO m =>
Acquire a -> (a -> m b) -> m b
with (backend -> Acquire backend
forall backend (m :: * -> *).
(MonadReader backend m, BackendCompatible SqlBackend backend) =>
m (Acquire backend)
acquireSqlConn backend
conn) ((backend -> m a) -> m a) -> (backend -> m a) -> m a
forall a b. (a -> b) -> a -> b
$ ReaderT backend m a -> backend -> m a
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 :: ReaderT backend m a -> backend -> IsolationLevel -> m a
runSqlConnWithIsolation ReaderT backend m a
r backend
conn IsolationLevel
isolation =
  Acquire backend -> (backend -> m a) -> m a
forall (m :: * -> *) a b.
MonadUnliftIO m =>
Acquire a -> (a -> m b) -> m b
with (IsolationLevel -> backend -> Acquire backend
forall backend (m :: * -> *).
(MonadReader backend m, BackendCompatible SqlBackend backend) =>
IsolationLevel -> m (Acquire backend)
acquireSqlConnWithIsolation IsolationLevel
isolation backend
conn) ((backend -> m a) -> m a) -> (backend -> m a) -> m a
forall a b. (a -> b) -> a -> b
$ ReaderT backend m a -> backend -> m a
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 :: ReaderT backend (NoLoggingT (ResourceT IO)) a -> backend -> IO a
runSqlPersistM ReaderT backend (NoLoggingT (ResourceT IO)) a
x backend
conn = ResourceT IO a -> IO a
forall (m :: * -> *) a. MonadUnliftIO m => ResourceT m a -> m a
runResourceT (ResourceT IO a -> IO a) -> ResourceT IO a -> IO a
forall a b. (a -> b) -> a -> b
$ NoLoggingT (ResourceT IO) a -> ResourceT IO a
forall (m :: * -> *) a. NoLoggingT m a -> m a
runNoLoggingT (NoLoggingT (ResourceT IO) a -> ResourceT IO a)
-> NoLoggingT (ResourceT IO) a -> ResourceT IO a
forall a b. (a -> b) -> a -> b
$ ReaderT backend (NoLoggingT (ResourceT IO)) a
-> backend -> NoLoggingT (ResourceT IO) a
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 :: ReaderT backend (NoLoggingT (ResourceT IO)) a
-> Pool backend -> IO a
runSqlPersistMPool ReaderT backend (NoLoggingT (ResourceT IO)) a
x Pool backend
pool = ResourceT IO a -> IO a
forall (m :: * -> *) a. MonadUnliftIO m => ResourceT m a -> m a
runResourceT (ResourceT IO a -> IO a) -> ResourceT IO a -> IO a
forall a b. (a -> b) -> a -> b
$ NoLoggingT (ResourceT IO) a -> ResourceT IO a
forall (m :: * -> *) a. NoLoggingT m a -> m a
runNoLoggingT (NoLoggingT (ResourceT IO) a -> ResourceT IO a)
-> NoLoggingT (ResourceT IO) a -> ResourceT IO a
forall a b. (a -> b) -> a -> b
$ ReaderT backend (NoLoggingT (ResourceT IO)) a
-> Pool backend -> NoLoggingT (ResourceT IO) a
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 :: ReaderT backend (NoLoggingT (ResourceT IO)) a
-> Pool backend -> m a
liftSqlPersistMPool ReaderT backend (NoLoggingT (ResourceT IO)) a
x Pool backend
pool = IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (ReaderT backend (NoLoggingT (ResourceT IO)) a
-> Pool backend -> IO a
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. (MonadLogger m, MonadUnliftIO m, BackendCompatible SqlBackend backend)
    => (LogFunc -> IO backend) -- ^ create a new connection
    -> Int -- ^ connection count
    -> (Pool backend -> m a)
    -> m a
withSqlPool :: (LogFunc -> IO backend) -> Int -> (Pool backend -> m a) -> m a
withSqlPool LogFunc -> IO backend
mkConn Int
connCount Pool backend -> m a
f = (LogFunc -> IO backend)
-> ConnectionPoolConfig -> (Pool backend -> m a) -> m a
forall backend (m :: * -> *) a.
(MonadLogger 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. (MonadLogger m, MonadUnliftIO m, BackendCompatible SqlBackend backend)
    => (LogFunc -> IO backend) -- ^ Function to create a new connection
    -> ConnectionPoolConfig
    -> (Pool backend -> m a)
    -> m a
withSqlPoolWithConfig :: (LogFunc -> IO backend)
-> ConnectionPoolConfig -> (Pool backend -> m a) -> m a
withSqlPoolWithConfig LogFunc -> IO backend
mkConn ConnectionPoolConfig
poolConfig Pool backend -> m a
f = (UnliftIO m -> IO a) -> m a
forall (m :: * -> *) a.
MonadUnliftIO m =>
(UnliftIO m -> IO a) -> m a
withUnliftIO ((UnliftIO m -> IO a) -> m a) -> (UnliftIO m -> IO a) -> m a
forall a b. (a -> b) -> a -> b
$ \UnliftIO m
u -> IO (Pool backend)
-> (Pool backend -> IO ()) -> (Pool backend -> IO a) -> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket
    (UnliftIO m -> forall a. m a -> IO a
forall (m :: * -> *). UnliftIO m -> forall a. m a -> IO a
unliftIO UnliftIO m
u (m (Pool backend) -> IO (Pool backend))
-> m (Pool backend) -> IO (Pool backend)
forall a b. (a -> b) -> a -> b
$ (LogFunc -> IO backend) -> ConnectionPoolConfig -> m (Pool backend)
forall (m :: * -> *) backend.
(MonadLogger m, MonadUnliftIO m,
 BackendCompatible SqlBackend backend) =>
(LogFunc -> IO backend) -> ConnectionPoolConfig -> m (Pool backend)
createSqlPoolWithConfig LogFunc -> IO backend
mkConn ConnectionPoolConfig
poolConfig)
    Pool backend -> IO ()
forall a. Pool a -> IO ()
destroyAllResources
    (UnliftIO m -> forall a. m a -> IO a
forall (m :: * -> *). UnliftIO m -> forall a. m a -> IO a
unliftIO UnliftIO m
u (m a -> IO a) -> (Pool backend -> m a) -> Pool backend -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pool backend -> m a
f)

createSqlPool
    :: forall backend m. (MonadLogger m, MonadUnliftIO m, BackendCompatible SqlBackend backend)
    => (LogFunc -> IO backend)
    -> Int
    -> m (Pool backend)
createSqlPool :: (LogFunc -> IO backend) -> Int -> m (Pool backend)
createSqlPool LogFunc -> IO backend
mkConn Int
size = (LogFunc -> IO backend) -> ConnectionPoolConfig -> m (Pool backend)
forall (m :: * -> *) backend.
(MonadLogger 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. (MonadLogger m, MonadUnliftIO m, BackendCompatible SqlBackend backend)
    => (LogFunc -> IO backend) -- ^ Function to create a new connection
    -> ConnectionPoolConfig
    -> m (Pool backend)
createSqlPoolWithConfig :: (LogFunc -> IO backend) -> ConnectionPoolConfig -> m (Pool backend)
createSqlPoolWithConfig LogFunc -> IO backend
mkConn ConnectionPoolConfig
config = do
    LogFunc
logFunc <- m LogFunc
forall (m :: * -> *). (MonadUnliftIO m, MonadLogger m) => m LogFunc
askLogFunc
    -- Resource pool will swallow any exceptions from close. We want to log
    -- them instead.
    let loggedClose :: backend -> IO ()
        loggedClose :: backend -> IO ()
loggedClose backend
backend = backend -> IO ()
forall backend.
BackendCompatible SqlBackend backend =>
backend -> IO ()
close' backend
backend IO () -> (SomeException -> IO ()) -> IO ()
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> (SomeException -> m a) -> m a
`UE.catchAny` \SomeException
e -> LoggingT IO () -> LogFunc -> IO ()
forall (m :: * -> *) a. LoggingT m a -> LogFunc -> m a
runLoggingT
          (Text -> LoggingT IO ()
forall (m :: * -> *). (HasCallStack, MonadLogger m) => Text -> m ()
logError (Text -> LoggingT IO ()) -> Text -> LoggingT IO ()
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String
"Error closing database connection in pool: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ SomeException -> String
forall a. Show a => a -> String
show SomeException
e)
          LogFunc
logFunc
    IO (Pool backend) -> m (Pool backend)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Pool backend) -> m (Pool backend))
-> IO (Pool backend) -> m (Pool backend)
forall a b. (a -> b) -> a -> b
$ IO backend
-> (backend -> IO ())
-> Int
-> NominalDiffTime
-> Int
-> IO (Pool backend)
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)

-- NOTE: This function is a terrible, ugly hack. It would be much better to
-- just clean up monad-logger.
--
-- FIXME: in a future release, switch over to the new askLoggerIO function
-- added in monad-logger 0.3.10. That function was not available at the time
-- this code was written.
askLogFunc :: forall m. (MonadUnliftIO m, MonadLogger m) => m LogFunc
askLogFunc :: m LogFunc
askLogFunc = ((forall a. m a -> IO a) -> IO LogFunc) -> m LogFunc
forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO (((forall a. m a -> IO a) -> IO LogFunc) -> m LogFunc)
-> ((forall a. m a -> IO a) -> IO LogFunc) -> m LogFunc
forall a b. (a -> b) -> a -> b
$ \forall a. m a -> IO a
run ->
    LogFunc -> IO LogFunc
forall (m :: * -> *) a. Monad m => a -> m a
return (LogFunc -> IO LogFunc) -> LogFunc -> IO LogFunc
forall a b. (a -> b) -> a -> b
$ \Loc
a Text
b LogLevel
c LogStr
d -> m () -> IO ()
forall a. m a -> IO a
run (Loc -> Text -> LogLevel -> LogStr -> m ()
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
monadLoggerLog Loc
a Text
b LogLevel
c LogStr
d)

-- | 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, MonadLogger m, BackendCompatible SqlBackend backend)
    => (LogFunc -> IO backend) -> (backend -> m a) -> m a
withSqlConn :: (LogFunc -> IO backend) -> (backend -> m a) -> m a
withSqlConn LogFunc -> IO backend
open backend -> m a
f = do
    LogFunc
logFunc <- m LogFunc
forall (m :: * -> *). (MonadUnliftIO m, MonadLogger m) => m LogFunc
askLogFunc
    ((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
run -> IO backend -> (backend -> IO ()) -> (backend -> IO a) -> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket
      (LogFunc -> IO backend
open LogFunc
logFunc)
      backend -> IO ()
forall backend.
BackendCompatible SqlBackend backend =>
backend -> IO ()
close'
      (m a -> IO a
forall a. m a -> IO a
run (m a -> IO a) -> (backend -> m a) -> backend -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. backend -> m a
f)

close' :: (BackendCompatible SqlBackend backend) => backend -> IO ()
close' :: backend -> IO ()
close' backend
conn = do
    IORef (Map Text Statement) -> IO (Map Text Statement)
forall a. IORef a -> IO a
readIORef (SqlBackend -> IORef (Map Text Statement)
connStmtMap (SqlBackend -> IORef (Map Text Statement))
-> SqlBackend -> IORef (Map Text Statement)
forall a b. (a -> b) -> a -> b
$ backend -> SqlBackend
forall sup sub. BackendCompatible sup sub => sub -> sup
projectBackend backend
conn) IO (Map Text Statement) -> (Map Text Statement -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Statement -> IO ()) -> [Statement] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Statement -> IO ()
stmtFinalize ([Statement] -> IO ())
-> (Map Text Statement -> [Statement])
-> Map Text Statement
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map Text Statement -> [Statement]
forall k a. Map k a -> [a]
Map.elems
    SqlBackend -> IO ()
connClose (SqlBackend -> IO ()) -> SqlBackend -> IO ()
forall a b. (a -> b) -> a -> b
$ backend -> SqlBackend
forall sup sub. BackendCompatible sup sub => sub -> sup
projectBackend backend
conn