-- | 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
  { poolConfig :: !(PoolConfig a)
  -- ^ the config of the 'Pool'
  , poolSem :: QSem
  -- ^ the quantity semaphore managing the available resources
  }

-- | a simple resource pool config
data PoolConfig a = MkPoolConfig
  { createResource :: IO a
  -- ^ the action that creates a resource of type @a@
  , destroyResource :: a -> IO ()
  -- ^ the action that destorys a resource of type @a@
  , 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 = MkPoolConfig

-- | given a 'PoolConfig', create a new 'Pool'
newPool :: MonadIO m => PoolConfig a -> m (Pool a)
newPool cfg = do
  sem <- liftIO $ newQSem (maxResources cfg)
  pure (UnsafeMkPool cfg sem)

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