{-# LANGUAGE ScopedTypeVariables #-}
module Database.Persist.Sql.Run where
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)
import Data.Pool as P
import qualified Data.Map as Map
import qualified Data.Text as T
import Database.Persist.Class.PersistStore
import Database.Persist.Sql.Types
import Database.Persist.Sql.Types.Internal
import Database.Persist.Sql.Raw
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 = do
ReaderT backend m a -> Pool backend -> Maybe IsolationLevel -> m a
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
forall a. Maybe a
Nothing
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 =
ReaderT backend m a -> Pool backend -> Maybe IsolationLevel -> m a
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 (IsolationLevel -> Maybe IsolationLevel
forall a. a -> Maybe a
Just IsolationLevel
i)
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 -> Pool backend -> Maybe IsolationLevel -> m a
runSqlPoolNoTransaction ReaderT backend m a
r Pool backend
pconn Maybe IsolationLevel
i =
ReaderT backend m a
-> Pool backend
-> Maybe IsolationLevel
-> (backend -> m ())
-> (backend -> m ())
-> (backend -> SomeException -> m ())
-> m a
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 ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) (\backend
_ -> () -> m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) (\backend
_ SomeException
_ -> () -> m ()
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 :: ReaderT backend m a -> Pool backend -> Maybe IsolationLevel -> m a
rawRunSqlPool ReaderT backend m a
r Pool backend
pconn Maybe IsolationLevel
mi =
ReaderT backend m a
-> Pool backend
-> Maybe IsolationLevel
-> (backend -> m ())
-> (backend -> m ())
-> (backend -> SomeException -> m ())
-> m a
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 backend -> m ()
forall sub (m :: * -> *).
(BackendCompatible SqlBackend sub, MonadIO m) =>
sub -> m ()
after backend -> SomeException -> m ()
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 = backend -> 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
IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
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 = sub -> 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
IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
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 = sub -> 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
IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ SqlBackend -> (Text -> IO Statement) -> IO ()
connRollback SqlBackend
sqlBackend Text -> IO Statement
getter
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 -> UE.SomeException -> m onException)
-> m a
runSqlPoolWithHooks :: 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 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 ->
Pool backend -> (backend -> IO a) -> IO a
forall (m :: * -> *) a b.
MonadBaseControl IO m =>
Pool a -> (a -> m b) -> m b
withResource Pool backend
pconn ((backend -> IO a) -> IO a) -> (backend -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \backend
conn ->
((forall a. IO a -> IO a) -> IO a) -> IO a
forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> m a) -> m b) -> m b
UE.mask (((forall a. IO a -> IO a) -> IO a) -> IO a)
-> ((forall a. IO a -> IO a) -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \forall a. IO a -> IO a
restore -> do
before
_ <- IO before -> IO before
forall a. IO a -> IO a
restore (IO before -> IO before) -> IO before -> IO before
forall a b. (a -> b) -> a -> b
$ m before -> IO before
forall a. m a -> IO a
runInIO (m before -> IO before) -> m before -> IO before
forall a b. (a -> b) -> a -> b
$ backend -> m before
before backend
conn
a
a <- IO a -> IO a
forall a. IO a -> IO a
restore (m a -> IO a
forall a. m a -> IO a
runInIO (ReaderT backend m a -> backend -> m a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT backend m a
r backend
conn))
IO a -> (SomeException -> IO a) -> IO a
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> (SomeException -> m a) -> m a
`UE.catchAny` \SomeException
e -> do
onException
_ <- IO onException -> IO onException
forall a. IO a -> IO a
restore (IO onException -> IO onException)
-> IO onException -> IO onException
forall a b. (a -> b) -> a -> b
$ m onException -> IO onException
forall a. m a -> IO a
runInIO (m onException -> IO onException)
-> m onException -> IO onException
forall a b. (a -> b) -> a -> b
$ backend -> SomeException -> m onException
onException backend
conn SomeException
e
SomeException -> IO a
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
UE.throwIO SomeException
e
after
_ <- IO after -> IO after
forall a. IO a -> IO a
restore (IO after -> IO after) -> IO after -> IO after
forall a b. (a -> b) -> a -> b
$ m after -> IO after
forall a. m a -> IO a
runInIO (m after -> IO after) -> m after -> IO after
forall a b. (a -> b) -> a -> b
$ backend -> m after
after backend
conn
a -> IO a
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 :: 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 -> 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
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
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
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
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. (MonadLoggerIO m, MonadUnliftIO m, BackendCompatible SqlBackend backend)
=> (LogFunc -> IO backend)
-> Int
-> (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.
(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
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)
-> 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 (m :: * -> *) a b c.
MonadUnliftIO m =>
m a -> (a -> m b) -> (a -> m c) -> m c
UE.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.
(MonadLoggerIO 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. (MonadLoggerIO 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.
(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 } )
createSqlPoolWithConfig
:: forall m backend. (MonadLoggerIO m, MonadUnliftIO m, BackendCompatible SqlBackend backend)
=> (LogFunc -> IO backend)
-> 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 :: * -> *). MonadLoggerIO m => m LogFunc
askLoggerIO
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 -> do
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
SomeException -> IO ()
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
UE.throwIO SomeException
e
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)
withSqlConn
:: forall backend m a. (MonadUnliftIO m, MonadLoggerIO 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 :: * -> *). MonadLoggerIO m => m LogFunc
askLoggerIO
((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 (m :: * -> *) a b c.
MonadUnliftIO m =>
m a -> (a -> m b) -> (a -> m c) -> m c
UE.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