{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
module PostgreSQL.ConnectionPool
( ConnectionPoolT (..)
, runConnectionPoolT
, defaultConnectionPoolSettings
, connectionPoolMetrics
)
where
import qualified Control.Monad.Catch as Catch
import Control.Monad.Conc.Class (MonadConc)
import qualified Control.Monad.Except as Except
import Control.Monad.IO.Class (MonadIO, liftIO)
import qualified Control.Monad.Reader as Reader
import Control.Monad.State.Class (MonadState)
import Control.Monad.Trans (MonadTrans, lift)
import Control.Monad.Writer.Class (MonadWriter)
import qualified Database.PostgreSQL.LibPQ as PQ
import Numeric.Natural (Natural)
import qualified PostgreSQL.Class as Class
import qualified PostgreSQL.Query as Query
import PostgreSQL.Types (Connection)
import qualified Simpoole as Pool
import qualified Simpoole.Monad as Pool.Monad
import qualified Simpoole.Monad.Internal as Pool.Monad
newtype ConnectionPoolT m a = ConnectionPoolT
{ ConnectionPoolT m a -> PoolT Connection m a
unConnectionPoolT :: Pool.Monad.PoolT Connection m a }
deriving newtype
( Functor
, Applicative
, Monad
, MonadFail
, MonadIO
, MonadState s
, Except.MonadError e
, MonadWriter w
, Catch.MonadThrow
, Catch.MonadCatch
, Catch.MonadMask
, MonadConc
)
instance MonadTrans ConnectionPoolT where
lift :: m a -> ConnectionPoolT m a
lift = PoolT Connection m a -> ConnectionPoolT m a
forall (m :: * -> *) a. PoolT Connection m a -> ConnectionPoolT m a
ConnectionPoolT (PoolT Connection m a -> ConnectionPoolT m a)
-> (m a -> PoolT Connection m a) -> m a -> ConnectionPoolT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m a -> PoolT Connection m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
Reader.lift
instance
(Catch.MonadMask m, MonadIO m)
=> Class.RunQuery (Query.QueryT m) (ConnectionPoolT m)
where
runQuery :: QueryT m a -> ConnectionPoolT m (Either Errors a)
runQuery QueryT m a
query = PoolT Connection m (Either Errors a)
-> ConnectionPoolT m (Either Errors a)
forall (m :: * -> *) a. PoolT Connection m a -> ConnectionPoolT m a
ConnectionPoolT (PoolT Connection m (Either Errors a)
-> ConnectionPoolT m (Either Errors a))
-> PoolT Connection m (Either Errors a)
-> ConnectionPoolT m (Either Errors a)
forall a b. (a -> b) -> a -> b
$ (Connection -> PoolT Connection m (Either Errors a))
-> PoolT Connection m (Either Errors a)
forall resource (m :: * -> *) a.
MonadPool resource m =>
(resource -> m a) -> m a
Pool.Monad.withResource ((Connection -> PoolT Connection m (Either Errors a))
-> PoolT Connection m (Either Errors a))
-> (Connection -> PoolT Connection m (Either Errors a))
-> PoolT Connection m (Either Errors a)
forall a b. (a -> b) -> a -> b
$ \Connection
conn ->
m (Either Errors a) -> PoolT Connection m (Either Errors a)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (Either Errors a) -> PoolT Connection m (Either Errors a))
-> m (Either Errors a) -> PoolT Connection m (Either Errors a)
forall a b. (a -> b) -> a -> b
$ Connection -> QueryT m a -> m (Either Errors a)
forall (m :: * -> *) a.
Connection -> QueryT m a -> m (Either Errors a)
Query.runQueryT Connection
conn QueryT m a
query
{-# INLINE runQuery #-}
defaultConnectionPoolSettings :: Pool.Settings
defaultConnectionPoolSettings :: Settings
defaultConnectionPoolSettings = Settings
Pool.defaultSettings
{ settings_idleTimeout :: Maybe NominalDiffTime
Pool.settings_idleTimeout = NominalDiffTime -> Maybe NominalDiffTime
forall a. a -> Maybe a
Just NominalDiffTime
60
, settings_returnPolicy :: ReturnPolicy
Pool.settings_returnPolicy = ReturnPolicy
Pool.ReturnToFront
, settings_maxLiveLimit :: Maybe Int
Pool.settings_maxLiveLimit = Maybe Int
forall a. Maybe a
Nothing
}
runConnectionPoolT
:: (MonadIO m, MonadConc m)
=> m Connection
-> Pool.Settings
-> ConnectionPoolT m a
-> m a
runConnectionPoolT :: m Connection -> Settings -> ConnectionPoolT m a -> m a
runConnectionPoolT m Connection
connect Settings
poolSettings (ConnectionPoolT PoolT Connection m a
inner) = do
Pool m Connection
pool <- m Connection
-> (Connection -> m ()) -> Settings -> m (Pool m Connection)
forall (m :: * -> *) a.
(MonadConc m, MonadIO m) =>
m a -> (a -> m ()) -> Settings -> m (Pool m a)
Pool.newPool m Connection
connect (IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> (Connection -> IO ()) -> Connection -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Connection -> IO ()
PQ.finish) Settings
poolSettings
Pool m Connection -> PoolT Connection m a -> m a
forall (m :: * -> *) resource a.
Pool m resource -> PoolT resource m a -> m a
Pool.Monad.runPoolT Pool m Connection
pool PoolT Connection m a
inner
{-# INLINE runConnectionPoolT #-}
connectionPoolMetrics :: ConnectionPoolT m (Pool.Metrics Natural)
connectionPoolMetrics :: ConnectionPoolT m (Metrics Natural)
connectionPoolMetrics = PoolT Connection m (Metrics Natural)
-> ConnectionPoolT m (Metrics Natural)
forall (m :: * -> *) a. PoolT Connection m a -> ConnectionPoolT m a
ConnectionPoolT PoolT Connection m (Metrics Natural)
forall resource (m :: * -> *). PoolT resource m (Metrics Natural)
Pool.Monad.metricsPoolT