-- | A simple resource pool implementation.
--
-- Use 'newPool' to construct a resource 'Pool' of a certain size and use 'withResource' to acquire and release
-- resources.
module Data.Pool
  ( -- * A simple resource pool and its configuration
    Pool (..)
  , PoolConfig (..)

    -- ** creating a pool
  , defaultPoolConfig
  , newPool

    -- * using a resource from a pool
  , withResource
  )
where

import Control.Concurrent.QSem (QSem, newQSem, signalQSem, waitQSem)
import Control.Exception (bracket)
import Control.Monad.IO.Class (MonadIO (liftIO))
import Control.Monad.IO.Unlift (MonadUnliftIO (withRunInIO))

-- | a simple resource pool
--
-- Use 'newPool' to construct a 'Pool'
data Pool a = UnsafeMkPool
  { forall a. Pool a -> PoolConfig a
poolConfig :: !(PoolConfig a)
  -- ^ the config of the 'Pool'
  , forall a. Pool a -> QSem
poolSem :: QSem
  -- ^ the quantity semaphore managing the available resources
  }

-- | a simple resource pool config
data PoolConfig a = MkPoolConfig
  { forall a. PoolConfig a -> IO a
createResource :: IO a
  -- ^ the action that creates a resource of type @a@
  , forall a. PoolConfig a -> a -> IO ()
destroyResource :: a -> IO ()
  -- ^ the action that destorys a resource of type @a@
  , forall a. PoolConfig a -> Int
maxResources :: !Int
  -- ^ the maximum amount of used resources. It needs to be at least 0
  }

-- | constructing a default 'PoolConfig'
defaultPoolConfig
  :: IO a
  -- ^ the action that creates a resource of type @a@
  -> (a -> IO ())
  -- ^ the action that destroys a resource of type @a@
  -> Int
  -- ^ the maximum amount of used resources. It needs to be at lest 0
  -> PoolConfig a
defaultPoolConfig :: forall a. IO a -> (a -> IO ()) -> Int -> PoolConfig a
defaultPoolConfig = IO a -> (a -> IO ()) -> Int -> PoolConfig a
forall a. IO a -> (a -> IO ()) -> Int -> PoolConfig a
MkPoolConfig

-- | given a 'PoolConfig', create a new 'Pool'
newPool :: MonadIO m => PoolConfig a -> m (Pool a)
newPool :: forall (m :: * -> *) a. MonadIO m => PoolConfig a -> m (Pool a)
newPool PoolConfig a
cfg = do
  QSem
sem <- IO QSem -> m QSem
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO QSem -> m QSem) -> IO QSem -> m QSem
forall a b. (a -> b) -> a -> b
$ Int -> IO QSem
newQSem (PoolConfig a -> Int
forall a. PoolConfig a -> Int
maxResources PoolConfig a
cfg)
  Pool a -> m (Pool a)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PoolConfig a -> QSem -> Pool a
forall a. PoolConfig a -> QSem -> Pool a
UnsafeMkPool PoolConfig a
cfg QSem
sem)

-- | acquire a resource from a pool and run an action on it
withResource :: MonadUnliftIO m => Pool a -> (a -> m r) -> m r
withResource :: forall (m :: * -> *) a r.
MonadUnliftIO m =>
Pool a -> (a -> m r) -> m r
withResource Pool a
pool a -> m r
k = ((forall a. m a -> IO a) -> IO r) -> m r
forall b. ((forall a. m a -> IO a) -> IO b) -> m b
forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO (((forall a. m a -> IO a) -> IO r) -> m r)
-> ((forall a. m a -> IO a) -> IO r) -> m r
forall a b. (a -> b) -> a -> b
$ \forall a. m a -> IO a
inIO ->
  IO a -> (a -> IO ()) -> (a -> IO r) -> IO r
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket
    ( do
        QSem -> IO ()
waitQSem (QSem -> IO ()) -> QSem -> IO ()
forall a b. (a -> b) -> a -> b
$ Pool a -> QSem
forall a. Pool a -> QSem
poolSem Pool a
pool
        PoolConfig a -> IO a
forall a. PoolConfig a -> IO a
createResource (PoolConfig a -> IO a) -> PoolConfig a -> IO a
forall a b. (a -> b) -> a -> b
$ Pool a -> PoolConfig a
forall a. Pool a -> PoolConfig a
poolConfig Pool a
pool
    )
    ( \a
res -> do
        PoolConfig a -> a -> IO ()
forall a. PoolConfig a -> a -> IO ()
destroyResource (Pool a -> PoolConfig a
forall a. Pool a -> PoolConfig a
poolConfig Pool a
pool) a
res
        QSem -> IO ()
signalQSem (QSem -> IO ()) -> QSem -> IO ()
forall a b. (a -> b) -> a -> b
$ Pool a -> QSem
forall a. Pool a -> QSem
poolSem Pool a
pool
    )
    (m r -> IO r
forall a. m a -> IO a
inIO (m r -> IO r) -> (a -> m r) -> a -> IO r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> m r
k)