{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}

-- | This module defines an interpreter for 'Class.RunQuery'.
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

-- | Interpreter for 'Class.RunQuery' which dispatches queries to a pool of database connections
--
-- @since 0.0.0
newtype ConnectionPoolT m a = ConnectionPoolT
  { ConnectionPoolT m a -> PoolT Connection m a
unConnectionPoolT :: Pool.Monad.PoolT Connection m a }
  deriving newtype
    ( Functor -- ^ @since 0.0.0
    , Applicative -- ^ @since 0.0.0
    , Monad -- ^ @since 0.0.0
    , MonadFail -- ^ @since 0.0.0
    , MonadIO -- ^ @since 0.0.0
    , MonadState s -- ^ @since 0.0.0
    , Except.MonadError e -- ^ @since 0.0.0
    , MonadWriter w -- ^ @since 0.0.0
    , Catch.MonadThrow -- ^ @since 0.0.0
    , Catch.MonadCatch -- ^ @since 0.0.0
    , Catch.MonadMask -- ^ @since 0.0.0
    , MonadConc -- ^ @since 0.0.0
    )

-- | @since 0.0.0
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

-- | @since 0.0.0
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 #-}

-- | Default settings for the connection pool
--
-- @since 0.0.0
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 -- seconds
  , settings_returnPolicy :: ReturnPolicy
Pool.settings_returnPolicy = ReturnPolicy
Pool.ReturnToFront
  , settings_maxLiveLimit :: Maybe Int
Pool.settings_maxLiveLimit = Maybe Int
forall a. Maybe a
Nothing
  }

-- | Run connection pool transformer.
--
-- @since 0.0.0
runConnectionPoolT
  :: (MonadIO m, MonadConc m)
  => m Connection
  -- ^ Action to establish a new connection
  -> Pool.Settings
  -- ^ Connection pool settings
  -> ConnectionPoolT m a
  -- ^ Transformer to run
  -> 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 #-}

-- | Retrieve the connection pool metrics.
--
-- @since 0.0.0
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