{-# LANGUAGE DeriveDataTypeable, NamedFieldPuns, RecordWildCards,
    ScopedTypeVariables, FlexibleContexts #-}

-- |
-- Module:      Network.Riak.Connection.Pool
-- Copyright:   (c) 2011 MailRank, Inc.
-- License:     Apache
-- Maintainer:  Mark Hibberd <mark@hibberd.id.au>, Nathan Hunter <nhunter@janrain.com>
-- Stability:   experimental
-- Portability: portable
--
-- A high-performance striped pooling abstraction for managing
-- connections to a Riak cluster. This is a thin wrapper around
-- 'Data.Pool'.
module Network.Riak.Connection.Pool
    (
      Pool
    , client
    , create
    , idleTime
    , maxConnections
    , numStripes
    , withConnection
    , withConnectionM
    ) where

import Control.Monad.Trans.Control (MonadBaseControl)
import Data.Time.Clock (NominalDiffTime)
import Data.Typeable (Typeable)
import Network.Riak (Client(clientID), Connection, connect, disconnect)
import Network.Riak.Connection (makeClientID)
import qualified Data.Pool as Pool

-- | A pool of connections to a Riak server.
--
-- This pool is \"striped\", i.e. it consists of several sub-pools
-- that are managed independently.
--
-- The total number of connections that can possibly be open at once
-- is 'maxConnections' * 'numStripes'.
data Pool = Pool {
      Pool -> Client
client :: Client
    -- ^ Client specification.  The client ID is ignored, and always
    -- regenerated automatically for each new connection.
    , Pool -> Pool Connection
pool :: Pool.Pool Connection
    } deriving (Typeable)

instance Show Pool where
    show :: Pool -> String
show Pool
p = String
"Pool { client = " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Client -> String
forall a. Show a => a -> String
show (Pool -> Client
client Pool
p) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
", " String -> ShowS
forall a. [a] -> [a] -> [a]
++
                    String
"numStripes = " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (Pool -> Int
numStripes Pool
p) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
", " String -> ShowS
forall a. [a] -> [a] -> [a]
++
                    String
"idleTime = " String -> ShowS
forall a. [a] -> [a] -> [a]
++ NominalDiffTime -> String
forall a. Show a => a -> String
show (Pool -> NominalDiffTime
idleTime Pool
p) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
", " String -> ShowS
forall a. [a] -> [a] -> [a]
++
                    String
"maxConnections = " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (Pool -> Int
maxConnections Pool
p) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"}"

instance Eq Pool where
    Pool
a == :: Pool -> Pool -> Bool
== Pool
b = Pool -> Client
client Pool
a Client -> Client -> Bool
forall a. Eq a => a -> a -> Bool
== Pool -> Client
client Pool
b Bool -> Bool -> Bool
&& Pool -> Int
numStripes Pool
a Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Pool -> Int
numStripes Pool
b Bool -> Bool -> Bool
&&
             Pool -> NominalDiffTime
idleTime Pool
a NominalDiffTime -> NominalDiffTime -> Bool
forall a. Eq a => a -> a -> Bool
== Pool -> NominalDiffTime
idleTime Pool
b Bool -> Bool -> Bool
&& Pool -> Int
maxConnections Pool
a Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Pool -> Int
maxConnections Pool
b

-- | Create a new connection pool.
create :: Client
       -- ^ Client configuration.  The client ID is ignored, and
       -- always regenerated automatically for each new connection.
       -> Int
       -- ^ Stripe count.  The number of distinct sub-pools to
       -- maintain.  The smallest acceptable value is 1.
       -> NominalDiffTime
       -- ^ Amount of time for which an unused connection is kept
       -- open.  The smallest acceptable value is 0.5 seconds.
       --
       -- The elapsed time before closing may be a little longer than
       -- requested, as the reaper thread wakes at 2-second intervals.
       -> Int
       -- ^ Maximum number of connections to keep open per stripe.
       -- The smallest acceptable value is 1.
       --
       -- Requests for connections will block if this limit is reached
       -- on a single stripe, even if other stripes have idle
       -- connections available.
       -> IO Pool
create :: Client -> Int -> NominalDiffTime -> Int -> IO Pool
create Client
client Int
ns NominalDiffTime
it Int
mc =
    Client -> Pool Connection -> Pool
Pool Client
client (Pool Connection -> Pool) -> IO (Pool Connection) -> IO Pool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` IO Connection
-> (Connection -> IO ())
-> Int
-> NominalDiffTime
-> Int
-> IO (Pool Connection)
forall a.
IO a
-> (a -> IO ()) -> Int -> NominalDiffTime -> Int -> IO (Pool a)
Pool.createPool IO Connection
c Connection -> IO ()
disconnect Int
ns NominalDiffTime
it Int
mc
  where c :: IO Connection
c = do
          ClientID
cid <- IO ClientID
makeClientID
          Client -> IO Connection
connect Client
client { clientID :: ClientID
clientID = ClientID
cid }

-- | Stripe count.  The number of distinct sub-pools to maintain.  The
-- smallest acceptable value is 1.
numStripes :: Pool -> Int
numStripes :: Pool -> Int
numStripes = Pool Connection -> Int
forall a. Pool a -> Int
Pool.numStripes (Pool Connection -> Int)
-> (Pool -> Pool Connection) -> Pool -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pool -> Pool Connection
pool

-- | Amount of time for which an unused connection is kept open.  The
-- smallest acceptable value is 0.5 seconds.
--
-- The elapsed time before closing may be a little longer than
-- requested, as the reaper thread wakes at 1-second intervals.
idleTime :: Pool -> NominalDiffTime
idleTime :: Pool -> NominalDiffTime
idleTime = Pool Connection -> NominalDiffTime
forall a. Pool a -> NominalDiffTime
Pool.idleTime (Pool Connection -> NominalDiffTime)
-> (Pool -> Pool Connection) -> Pool -> NominalDiffTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pool -> Pool Connection
pool

-- | Maximum number of connections to keep open per stripe.  The
-- smallest acceptable value is 1.
--
-- Requests for connections will block if this limit is reached on a
-- single stripe, even if other stripes have idle connections
-- available.
maxConnections :: Pool -> Int
maxConnections :: Pool -> Int
maxConnections = Pool Connection -> Int
forall a. Pool a -> Int
Pool.maxResources (Pool Connection -> Int)
-> (Pool -> Pool Connection) -> Pool -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pool -> Pool Connection
pool

-- | Temporarily take a connection from a 'Pool', perform an action
-- with it, and return it to the pool afterwards.
--
-- * If the pool has a connection available, it is used
--   immediately.
--
-- * Otherwise, if the maximum number of connections has not been
--   reached, a new connection is created and used.
--
-- * If the maximum number of connections has been reached, this
--   function blocks until a connection becomes available, then that
--   connection is used.
--
-- If the action throws an exception of any type, the 'Connection' is
-- destroyed, and not returned to the pool.
--
-- It probably goes without saying that you should never call
-- 'disconnect' on a connection, as doing so will cause a subsequent
-- user (who expects the connection to be valid) to throw an exception.
withConnection :: Pool -> (Connection -> IO a) -> IO a
withConnection :: Pool -> (Connection -> IO a) -> IO a
withConnection = Pool Connection -> (Connection -> IO a) -> IO a
forall (m :: * -> *) a b.
MonadBaseControl IO m =>
Pool a -> (a -> m b) -> m b
Pool.withResource (Pool Connection -> (Connection -> IO a) -> IO a)
-> (Pool -> Pool Connection)
-> Pool
-> (Connection -> IO a)
-> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pool -> Pool Connection
pool

-- | Temporarily take a connection from a 'Pool', perform an action
-- with it, and return it to the pool afterwards. This is a
-- generalization of 'withConnection', which remains specialized to
-- prevent breaking source compatibility with existing code.
--
-- * If the pool has a connection available, it is used
--   immediately.
--
-- * Otherwise, if the maximum number of connections has not been
--   reached, a new connection is created and used.
--
-- * If the maximum number of connections has been reached, this
--   function blocks until a connection becomes available, then that
--   connection is used.
--
-- If the action throws an exception of any type, the 'Connection' is
-- destroyed, and not returned to the pool.
--
-- It probably goes without saying that you should never call
-- 'disconnect' on a connection, as doing so will cause a subsequent
-- user (who expects the connection to be valid) to throw an exception.
withConnectionM :: MonadBaseControl IO m => Pool -> (Connection -> m a) -> m a
withConnectionM :: Pool -> (Connection -> m a) -> m a
withConnectionM = Pool Connection -> (Connection -> m a) -> m a
forall (m :: * -> *) a b.
MonadBaseControl IO m =>
Pool a -> (a -> m b) -> m b
Pool.withResource (Pool Connection -> (Connection -> m a) -> m a)
-> (Pool -> Pool Connection) -> Pool -> (Connection -> m a) -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pool -> Pool Connection
pool