{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE StrictData #-}
{-# LANGUAGE TypeApplications #-}

module Simpoole
  ( Pool
  , mapPool
  , newUnlimitedPool
  , newPool
  , withResource
  , acquireResource
  , returnResource
  , destroyResource
  , poolMetrics

  , Settings (..)
  , defaultSettings
  , ReturnPolicy (..)

  , Metrics (..)
  )
where

import qualified Control.Concurrent.Classy as Concurrent
import qualified Control.Concurrent.Classy.Async as Async
import           Control.Monad (forever, unless, void)
import qualified Control.Monad.Catch as Catch
import           Control.Monad.IO.Class (MonadIO (liftIO))
import           Data.Foldable (for_)
import qualified Data.Sequence as Seq
import qualified Data.Time as Time
import           Numeric.Natural (Natural)

-- | Strategy to use when returning resources to the pool
--
-- @since 0.1.0
data ReturnPolicy
  = ReturnToFront
  -- ^ Return resources to the front. Resources that have been used recently are more likely to be
  -- reused again quicker. This strategy is good if you want to scale down the pool more quickly in
  -- case resources are not needed.
  --
  -- @since 0.1.0
  | ReturnToBack
  -- ^ Return resources to the back. Resources that have been used recently are less likely to be
  -- used again quicker. Use this strategy if you want to keep more resources in the pool fresh, or
  -- when maintaining the pool in order to be ready for burst workloads.
  -- This strategy can lead to no resources ever been freed when all resources are used within the
  -- idle timeout.
  --
  -- @since 0.1.0
  | ReturnToMiddle
  -- ^ Return resources to the middle. This offers a middleground between 'ReturnToFront' and
  -- 'ReturnToBack'. By ensuring that the starting sub-sequence of resources is reused quicker but
  -- the trailing sub-sequence is not and therefore released more easily.
  --
  -- @since 0.1.0
  deriving stock (Int -> ReturnPolicy -> ShowS
[ReturnPolicy] -> ShowS
ReturnPolicy -> String
(Int -> ReturnPolicy -> ShowS)
-> (ReturnPolicy -> String)
-> ([ReturnPolicy] -> ShowS)
-> Show ReturnPolicy
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ReturnPolicy] -> ShowS
$cshowList :: [ReturnPolicy] -> ShowS
show :: ReturnPolicy -> String
$cshow :: ReturnPolicy -> String
showsPrec :: Int -> ReturnPolicy -> ShowS
$cshowsPrec :: Int -> ReturnPolicy -> ShowS
Show, ReadPrec [ReturnPolicy]
ReadPrec ReturnPolicy
Int -> ReadS ReturnPolicy
ReadS [ReturnPolicy]
(Int -> ReadS ReturnPolicy)
-> ReadS [ReturnPolicy]
-> ReadPrec ReturnPolicy
-> ReadPrec [ReturnPolicy]
-> Read ReturnPolicy
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [ReturnPolicy]
$creadListPrec :: ReadPrec [ReturnPolicy]
readPrec :: ReadPrec ReturnPolicy
$creadPrec :: ReadPrec ReturnPolicy
readList :: ReadS [ReturnPolicy]
$creadList :: ReadS [ReturnPolicy]
readsPrec :: Int -> ReadS ReturnPolicy
$creadsPrec :: Int -> ReadS ReturnPolicy
Read, ReturnPolicy -> ReturnPolicy -> Bool
(ReturnPolicy -> ReturnPolicy -> Bool)
-> (ReturnPolicy -> ReturnPolicy -> Bool) -> Eq ReturnPolicy
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ReturnPolicy -> ReturnPolicy -> Bool
$c/= :: ReturnPolicy -> ReturnPolicy -> Bool
== :: ReturnPolicy -> ReturnPolicy -> Bool
$c== :: ReturnPolicy -> ReturnPolicy -> Bool
Eq, Eq ReturnPolicy
Eq ReturnPolicy
-> (ReturnPolicy -> ReturnPolicy -> Ordering)
-> (ReturnPolicy -> ReturnPolicy -> Bool)
-> (ReturnPolicy -> ReturnPolicy -> Bool)
-> (ReturnPolicy -> ReturnPolicy -> Bool)
-> (ReturnPolicy -> ReturnPolicy -> Bool)
-> (ReturnPolicy -> ReturnPolicy -> ReturnPolicy)
-> (ReturnPolicy -> ReturnPolicy -> ReturnPolicy)
-> Ord ReturnPolicy
ReturnPolicy -> ReturnPolicy -> Bool
ReturnPolicy -> ReturnPolicy -> Ordering
ReturnPolicy -> ReturnPolicy -> ReturnPolicy
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: ReturnPolicy -> ReturnPolicy -> ReturnPolicy
$cmin :: ReturnPolicy -> ReturnPolicy -> ReturnPolicy
max :: ReturnPolicy -> ReturnPolicy -> ReturnPolicy
$cmax :: ReturnPolicy -> ReturnPolicy -> ReturnPolicy
>= :: ReturnPolicy -> ReturnPolicy -> Bool
$c>= :: ReturnPolicy -> ReturnPolicy -> Bool
> :: ReturnPolicy -> ReturnPolicy -> Bool
$c> :: ReturnPolicy -> ReturnPolicy -> Bool
<= :: ReturnPolicy -> ReturnPolicy -> Bool
$c<= :: ReturnPolicy -> ReturnPolicy -> Bool
< :: ReturnPolicy -> ReturnPolicy -> Bool
$c< :: ReturnPolicy -> ReturnPolicy -> Bool
compare :: ReturnPolicy -> ReturnPolicy -> Ordering
$ccompare :: ReturnPolicy -> ReturnPolicy -> Ordering
$cp1Ord :: Eq ReturnPolicy
Ord, Int -> ReturnPolicy
ReturnPolicy -> Int
ReturnPolicy -> [ReturnPolicy]
ReturnPolicy -> ReturnPolicy
ReturnPolicy -> ReturnPolicy -> [ReturnPolicy]
ReturnPolicy -> ReturnPolicy -> ReturnPolicy -> [ReturnPolicy]
(ReturnPolicy -> ReturnPolicy)
-> (ReturnPolicy -> ReturnPolicy)
-> (Int -> ReturnPolicy)
-> (ReturnPolicy -> Int)
-> (ReturnPolicy -> [ReturnPolicy])
-> (ReturnPolicy -> ReturnPolicy -> [ReturnPolicy])
-> (ReturnPolicy -> ReturnPolicy -> [ReturnPolicy])
-> (ReturnPolicy -> ReturnPolicy -> ReturnPolicy -> [ReturnPolicy])
-> Enum ReturnPolicy
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: ReturnPolicy -> ReturnPolicy -> ReturnPolicy -> [ReturnPolicy]
$cenumFromThenTo :: ReturnPolicy -> ReturnPolicy -> ReturnPolicy -> [ReturnPolicy]
enumFromTo :: ReturnPolicy -> ReturnPolicy -> [ReturnPolicy]
$cenumFromTo :: ReturnPolicy -> ReturnPolicy -> [ReturnPolicy]
enumFromThen :: ReturnPolicy -> ReturnPolicy -> [ReturnPolicy]
$cenumFromThen :: ReturnPolicy -> ReturnPolicy -> [ReturnPolicy]
enumFrom :: ReturnPolicy -> [ReturnPolicy]
$cenumFrom :: ReturnPolicy -> [ReturnPolicy]
fromEnum :: ReturnPolicy -> Int
$cfromEnum :: ReturnPolicy -> Int
toEnum :: Int -> ReturnPolicy
$ctoEnum :: Int -> ReturnPolicy
pred :: ReturnPolicy -> ReturnPolicy
$cpred :: ReturnPolicy -> ReturnPolicy
succ :: ReturnPolicy -> ReturnPolicy
$csucc :: ReturnPolicy -> ReturnPolicy
Enum, ReturnPolicy
ReturnPolicy -> ReturnPolicy -> Bounded ReturnPolicy
forall a. a -> a -> Bounded a
maxBound :: ReturnPolicy
$cmaxBound :: ReturnPolicy
minBound :: ReturnPolicy
$cminBound :: ReturnPolicy
Bounded)

-- | Insert a value based on the return policy.
applyReturnPolicy :: ReturnPolicy -> a -> Seq.Seq a -> Seq.Seq a
applyReturnPolicy :: ReturnPolicy -> a -> Seq a -> Seq a
applyReturnPolicy ReturnPolicy
policy a
value Seq a
seq =
  case ReturnPolicy
policy of
    ReturnPolicy
ReturnToFront -> a
value a -> Seq a -> Seq a
forall a. a -> Seq a -> Seq a
Seq.<| Seq a
seq
    ReturnPolicy
ReturnToBack -> Seq a
seq Seq a -> a -> Seq a
forall a. Seq a -> a -> Seq a
Seq.|> a
value
    ReturnPolicy
ReturnToMiddle -> Int -> a -> Seq a -> Seq a
forall a. Int -> a -> Seq a -> Seq a
Seq.insertAt Int
middleIndex a
value Seq a
seq
  where
    middleIndex :: Int
middleIndex
      | Int -> Bool
forall a. Integral a => a -> Bool
even (Seq a -> Int
forall a. Seq a -> Int
Seq.length Seq a
seq) = Int -> Int -> Int
forall a. Integral a => a -> a -> a
div (Seq a -> Int
forall a. Seq a -> Int
Seq.length Seq a
seq) Int
2
      | Bool
otherwise = Int -> Int -> Int
forall a. Integral a => a -> a -> a
div (Seq a -> Int
forall a. Seq a -> Int
Seq.length Seq a
seq) Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1

-- | Lets you configure certain behaviours of the pool
--
-- @since 0.1.0
data Settings = PoolSettings
  { Settings -> NominalDiffTime
settings_idleTimeout :: Time.NominalDiffTime
  -- ^ Maximum idle time after which a resource is destroyed
  --
  -- @since 0.1.0
  , Settings -> ReturnPolicy
settings_returnPolicy :: ReturnPolicy
  }

-- | Default pool settings
--
-- @since 0.1.0
defaultSettings :: Settings
defaultSettings :: Settings
defaultSettings = PoolSettings :: NominalDiffTime -> ReturnPolicy -> Settings
PoolSettings
  { settings_idleTimeout :: NominalDiffTime
settings_idleTimeout = NominalDiffTime
60 -- 60 seconds
  , settings_returnPolicy :: ReturnPolicy
settings_returnPolicy = ReturnPolicy
ReturnToMiddle
  }

-- | Pool of resources
--
-- @since 0.0.0
data Pool m a = Pool
  { Pool m a -> m a
pool_acquire :: m a
  , Pool m a -> a -> m ()
pool_return :: a -> m ()
  , Pool m a -> a -> m ()
pool_destroy :: a -> m ()
  , Pool m a -> m (Metrics Natural)
pool_metrics :: m (Metrics Natural)
  }

-- | Lift a natural transformation @m ~> n@ to @Pool m ~> Pool n@.
--
-- @since 0.0.0
mapPool
  :: (forall x. m x -> n x)
  -> Pool m a
  -> Pool n a
mapPool :: (forall x. m x -> n x) -> Pool m a -> Pool n a
mapPool forall x. m x -> n x
to Pool m a
pool = Pool :: forall (m :: * -> *) a.
m a
-> (a -> m ()) -> (a -> m ()) -> m (Metrics Natural) -> Pool m a
Pool
  { pool_acquire :: n a
pool_acquire = m a -> n a
forall x. m x -> n x
to (m a -> n a) -> m a -> n a
forall a b. (a -> b) -> a -> b
$ Pool m a -> m a
forall (m :: * -> *) a. Pool m a -> m a
pool_acquire Pool m a
pool
  , pool_return :: a -> n ()
pool_return = m () -> n ()
forall x. m x -> n x
to (m () -> n ()) -> (a -> m ()) -> a -> n ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pool m a -> a -> m ()
forall (m :: * -> *) a. Pool m a -> a -> m ()
pool_return Pool m a
pool
  , pool_destroy :: a -> n ()
pool_destroy = m () -> n ()
forall x. m x -> n x
to (m () -> n ()) -> (a -> m ()) -> a -> n ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pool m a -> a -> m ()
forall (m :: * -> *) a. Pool m a -> a -> m ()
pool_destroy Pool m a
pool
  , pool_metrics :: n (Metrics Natural)
pool_metrics = m (Metrics Natural) -> n (Metrics Natural)
forall x. m x -> n x
to (m (Metrics Natural) -> n (Metrics Natural))
-> m (Metrics Natural) -> n (Metrics Natural)
forall a b. (a -> b) -> a -> b
$ Pool m a -> m (Metrics Natural)
forall (m :: * -> *) a. Pool m a -> m (Metrics Natural)
pool_metrics Pool m a
pool
  }

{-# INLINE mapPool #-}

-- | Pool resource
data Resource a =
  Resource
    Time.UTCTime
    -- ^ Last use time
    a
    -- ^ The resource item

-- | Create a new pool that has no limit on how many resources it may create and hold.
--
-- @since 0.1.0
newUnlimitedPool
  :: (Concurrent.MonadConc m, MonadIO m)
  => m a
  -- ^ Resource creation
  -> (a -> m ())
  -- ^ Resource destruction
  -> Settings
  -- ^ Pool settings
  -> m (Pool m a)
newUnlimitedPool :: m a -> (a -> m ()) -> Settings -> m (Pool m a)
newUnlimitedPool m a
create a -> m ()
destroy Settings
settings = do
  IORef m (Seq (Resource a))
leftOversRef <- String -> Seq (Resource a) -> m (IORef m (Seq (Resource a)))
forall (m :: * -> *) a. MonadConc m => String -> a -> m (IORef m a)
Concurrent.newIORefN String
"leftOvers" Seq (Resource a)
forall a. Seq a
Seq.empty

  IORef m Natural
createdRef <- String -> Natural -> m (IORef m Natural)
forall (m :: * -> *) a. MonadConc m => String -> a -> m (IORef m a)
Concurrent.newIORefN String
"created" Natural
0
  IORef m Natural
destroyedRef <- String -> Natural -> m (IORef m Natural)
forall (m :: * -> *) a. MonadConc m => String -> a -> m (IORef m a)
Concurrent.newIORefN String
"destroyed" Natural
0
  IORef m Natural
maxLiveRef <- String -> Natural -> m (IORef m Natural)
forall (m :: * -> *) a. MonadConc m => String -> a -> m (IORef m a)
Concurrent.newIORefN String
"maxLive" Natural
0

  let
    getMetrics :: m (Metrics Natural)
getMetrics = do
      Natural
created <- IORef m Natural -> m Natural
forall (m :: * -> *) a. MonadConc m => IORef m a -> m a
Concurrent.readIORef IORef m Natural
createdRef
      Natural
destroyed <- IORef m Natural -> m Natural
forall (m :: * -> *) a. MonadConc m => IORef m a -> m a
Concurrent.readIORef IORef m Natural
destroyedRef
      Natural
maxLive <- IORef m Natural -> m Natural
forall (m :: * -> *) a. MonadConc m => IORef m a -> m a
Concurrent.readIORef IORef m Natural
maxLiveRef
      Seq (Resource a)
leftOvers <- IORef m (Seq (Resource a)) -> m (Seq (Resource a))
forall (m :: * -> *) a. MonadConc m => IORef m a -> m a
Concurrent.readIORef IORef m (Seq (Resource a))
leftOversRef

      Metrics Natural -> m (Metrics Natural)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Metrics :: forall a. a -> a -> a -> a -> Metrics a
Metrics
        { metrics_createdResources :: Natural
metrics_createdResources = Natural
created
        , metrics_destroyedResources :: Natural
metrics_destroyedResources = Natural
destroyed
        , metrics_maxLiveResources :: Natural
metrics_maxLiveResources = Natural
maxLive
        , metrics_idleResources :: Natural
metrics_idleResources = Int -> Natural
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Seq (Resource a) -> Int
forall a. Seq a -> Int
Seq.length Seq (Resource a)
leftOvers)
        }

    wrappedCreate :: m a
wrappedCreate = do
      a
value <- m a
create
      IORef m Natural -> m ()
forall (m :: * -> *) a. (MonadConc m, Enum a) => IORef m a -> m ()
succIORef IORef m Natural
createdRef
      a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
value

    wrappedDestroy :: a -> m ()
wrappedDestroy a
resource =
      a -> m ()
destroy a
resource m () -> m () -> m ()
forall (m :: * -> *) a b. MonadMask m => m a -> m b -> m a
`Catch.finally` IORef m Natural -> m ()
forall (m :: * -> *) a. (MonadConc m, Enum a) => IORef m a -> m ()
succIORef IORef m Natural
destroyedRef

    acquireResource :: m a
acquireResource = do
      Maybe a
mbResource <- IORef m (Seq (Resource a))
-> (Seq (Resource a) -> (Seq (Resource a), Maybe a)) -> m (Maybe a)
forall (m :: * -> *) a b.
MonadConc m =>
IORef m a -> (a -> (a, b)) -> m b
Concurrent.atomicModifyIORef' IORef m (Seq (Resource a))
leftOversRef ((Seq (Resource a) -> (Seq (Resource a), Maybe a)) -> m (Maybe a))
-> (Seq (Resource a) -> (Seq (Resource a), Maybe a)) -> m (Maybe a)
forall a b. (a -> b) -> a -> b
$ \Seq (Resource a)
leftOvers ->
        case Seq (Resource a)
leftOvers of
          Resource UTCTime
_ a
head Seq.:<| Seq (Resource a)
tail -> (Seq (Resource a)
tail, a -> Maybe a
forall a. a -> Maybe a
Just a
head)
          Seq (Resource a)
_empty -> (Seq (Resource a)
leftOvers, Maybe a
forall a. Maybe a
Nothing)

      a
resource <- m a -> (a -> m a) -> Maybe a -> m a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe m a
wrappedCreate a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
mbResource

      Natural
numDestroyed <- IORef m Natural -> m Natural
forall (m :: * -> *) a. MonadConc m => IORef m a -> m a
Concurrent.readIORef IORef m Natural
destroyedRef
      Natural
numCreated <- IORef m Natural -> m Natural
forall (m :: * -> *) a. MonadConc m => IORef m a -> m a
Concurrent.readIORef IORef m Natural
createdRef
      IORef m Natural -> Natural -> m ()
forall (m :: * -> *) a.
(MonadConc m, Ord a) =>
IORef m a -> a -> m ()
maxIORef IORef m Natural
maxLiveRef (Natural
numCreated Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
- Natural
numDestroyed)

      a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
resource

    returnResource :: a -> m ()
returnResource a
value = do
      UTCTime
now <- IO UTCTime -> m UTCTime
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
Time.getCurrentTime
      IORef m (Seq (Resource a))
-> (Seq (Resource a) -> (Seq (Resource a), ())) -> m ()
forall (m :: * -> *) a b.
MonadConc m =>
IORef m a -> (a -> (a, b)) -> m b
Concurrent.atomicModifyIORef' IORef m (Seq (Resource a))
leftOversRef ((Seq (Resource a) -> (Seq (Resource a), ())) -> m ())
-> (Seq (Resource a) -> (Seq (Resource a), ())) -> m ()
forall a b. (a -> b) -> a -> b
$ \Seq (Resource a)
leftOvers ->
        ( ReturnPolicy -> Resource a -> Seq (Resource a) -> Seq (Resource a)
forall a. ReturnPolicy -> a -> Seq a -> Seq a
applyReturnPolicy (Settings -> ReturnPolicy
settings_returnPolicy Settings
settings) (UTCTime -> a -> Resource a
forall a. UTCTime -> a -> Resource a
Resource UTCTime
now a
value) Seq (Resource a)
leftOvers
        , ()
        )

  Async m Any
_reaperThread <- String -> ((forall b. m b -> m b) -> m Any) -> m (Async m Any)
forall (m :: * -> *) a.
MonadConc m =>
String -> ((forall b. m b -> m b) -> m a) -> m (Async m a)
Async.asyncWithUnmaskN String
"reaperThread" (((forall b. m b -> m b) -> m Any) -> m (Async m Any))
-> ((forall b. m b -> m b) -> m Any) -> m (Async m Any)
forall a b. (a -> b) -> a -> b
$ \forall b. m b -> m b
unmask -> m Any -> m Any
forall b. m b -> m b
unmask (m Any -> m Any) -> m Any -> m Any
forall a b. (a -> b) -> a -> b
$ m () -> m Any
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (m () -> m Any) -> m () -> m Any
forall a b. (a -> b) -> a -> b
$ do
    UTCTime
now <- IO UTCTime -> m UTCTime
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
Time.getCurrentTime

    let
      isStillGood :: Resource a -> Bool
isStillGood (Resource UTCTime
lastUse a
_) =
        UTCTime -> UTCTime -> NominalDiffTime
Time.diffUTCTime UTCTime
now UTCTime
lastUse NominalDiffTime -> NominalDiffTime -> Bool
forall a. Ord a => a -> a -> Bool
<= Settings -> NominalDiffTime
settings_idleTimeout Settings
settings

    Seq (Resource a)
oldResource <- IORef m (Seq (Resource a))
-> (Seq (Resource a) -> (Seq (Resource a), Seq (Resource a)))
-> m (Seq (Resource a))
forall (m :: * -> *) a b.
MonadConc m =>
IORef m a -> (a -> (a, b)) -> m b
Concurrent.atomicModifyIORef' IORef m (Seq (Resource a))
leftOversRef ((Resource a -> Bool)
-> Seq (Resource a) -> (Seq (Resource a), Seq (Resource a))
forall a. (a -> Bool) -> Seq a -> (Seq a, Seq a)
Seq.partition Resource a -> Bool
forall a. Resource a -> Bool
isStillGood)

    Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Seq (Resource a) -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Seq (Resource a)
oldResource) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ m (Async m ()) -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m (Async m ()) -> m ()) -> m (Async m ()) -> m ()
forall a b. (a -> b) -> a -> b
$
      String -> m () -> m (Async m ())
forall (m :: * -> *) a.
MonadConc m =>
String -> m a -> m (Async m a)
Async.asyncN String
"destructionThread" (m () -> m (Async m ())) -> m () -> m (Async m ())
forall a b. (a -> b) -> a -> b
$
        Seq (Resource a)
-> (Resource a -> m (Either SomeException ())) -> m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Seq (Resource a)
oldResource ((Resource a -> m (Either SomeException ())) -> m ())
-> (Resource a -> m (Either SomeException ())) -> m ()
forall a b. (a -> b) -> a -> b
$ \(Resource UTCTime
_ a
value) ->
          forall a.
(MonadCatch m, Exception SomeException) =>
m a -> m (Either SomeException a)
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> m (Either e a)
Catch.try @_ @Catch.SomeException (m () -> m (Either SomeException ()))
-> m () -> m (Either SomeException ())
forall a b. (a -> b) -> a -> b
$ a -> m ()
wrappedDestroy a
value

    Int -> m ()
forall (m :: * -> *). MonadConc m => Int -> m ()
Concurrent.threadDelay Int
1_000_000

  Pool m a -> m (Pool m a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Pool :: forall (m :: * -> *) a.
m a
-> (a -> m ()) -> (a -> m ()) -> m (Metrics Natural) -> Pool m a
Pool
    { pool_acquire :: m a
pool_acquire = m a
acquireResource
    , pool_return :: a -> m ()
pool_return = a -> m ()
returnResource
    , pool_destroy :: a -> m ()
pool_destroy = a -> m ()
wrappedDestroy
    , pool_metrics :: m (Metrics Natural)
pool_metrics = m (Metrics Natural)
getMetrics
    }

-- | Similar to 'newUnlimitedPool' but allows you to limit the number of resources that will exist
-- at the same time. When all resources are currently in use, further resource acquisition will
-- block until one is no longer in use.
--
-- @since 0.1.0
newPool
  :: (Concurrent.MonadConc m, MonadIO m, MonadFail m)
  => m a
  -- ^ Resource creation
  -> (a -> m ())
  -- ^ Resource destruction
  -> Int
  -- ^ Maximum number of resources to exist at the same time
  -> Settings
  -- ^ Pool settings
  -> m (Pool m a)
newPool :: m a -> (a -> m ()) -> Int -> Settings -> m (Pool m a)
newPool m a
create a -> m ()
destroy Int
maxElems Settings
settings = do
  Pool m a
basePool <- m a -> (a -> m ()) -> Settings -> m (Pool m a)
forall (m :: * -> *) a.
(MonadConc m, MonadIO m) =>
m a -> (a -> m ()) -> Settings -> m (Pool m a)
newUnlimitedPool m a
create a -> m ()
destroy Settings
settings
  QSem m
maxElemBarrier <- Int -> m (QSem m)
forall (m :: * -> *).
(MonadConc m, MonadFail m) =>
Int -> m (QSem m)
Concurrent.newQSem Int
maxElems

  let
    acquireResource :: m a
acquireResource = ((forall a. m a -> m a) -> m a) -> m a
forall (m :: * -> *) b.
MonadMask m =>
((forall a. m a -> m a) -> m b) -> m b
Catch.mask (((forall a. m a -> m a) -> m a) -> m a)
-> ((forall a. m a -> m a) -> m a) -> m a
forall a b. (a -> b) -> a -> b
$ \forall a. m a -> m a
restore -> do
      QSem m -> m ()
forall (m :: * -> *). MonadConc m => QSem m -> m ()
Concurrent.waitQSem QSem m
maxElemBarrier
      m a -> m a
forall a. m a -> m a
restore (Pool m a -> m a
forall (m :: * -> *) a. Pool m a -> m a
pool_acquire Pool m a
basePool)
        m a -> m () -> m a
forall (m :: * -> *) a b. MonadMask m => m a -> m b -> m a
`Catch.onError` QSem m -> m ()
forall (m :: * -> *). MonadConc m => QSem m -> m ()
Concurrent.signalQSem QSem m
maxElemBarrier

    giveBackResource :: (Pool m a -> t -> m b) -> t -> m b
giveBackResource Pool m a -> t -> m b
f t
value = ((forall a. m a -> m a) -> m b) -> m b
forall (m :: * -> *) b.
MonadMask m =>
((forall a. m a -> m a) -> m b) -> m b
Catch.mask (((forall a. m a -> m a) -> m b) -> m b)
-> ((forall a. m a -> m a) -> m b) -> m b
forall a b. (a -> b) -> a -> b
$ \forall a. m a -> m a
restore ->
      m b -> m b
forall a. m a -> m a
restore (Pool m a -> t -> m b
f Pool m a
basePool t
value)
        m b -> m () -> m b
forall (m :: * -> *) a b. MonadMask m => m a -> m b -> m a
`Catch.finally` QSem m -> m ()
forall (m :: * -> *). MonadConc m => QSem m -> m ()
Concurrent.signalQSem QSem m
maxElemBarrier

  Pool m a -> m (Pool m a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Pool :: forall (m :: * -> *) a.
m a
-> (a -> m ()) -> (a -> m ()) -> m (Metrics Natural) -> Pool m a
Pool
    { pool_acquire :: m a
pool_acquire = m a
acquireResource
    , pool_return :: a -> m ()
pool_return = (Pool m a -> a -> m ()) -> a -> m ()
forall t b. (Pool m a -> t -> m b) -> t -> m b
giveBackResource Pool m a -> a -> m ()
forall (m :: * -> *) a. Pool m a -> a -> m ()
pool_return
    , pool_destroy :: a -> m ()
pool_destroy = (Pool m a -> a -> m ()) -> a -> m ()
forall t b. (Pool m a -> t -> m b) -> t -> m b
giveBackResource Pool m a -> a -> m ()
forall (m :: * -> *) a. Pool m a -> a -> m ()
pool_destroy
    , pool_metrics :: m (Metrics Natural)
pool_metrics = Pool m a -> m (Metrics Natural)
forall (m :: * -> *) a. Pool m a -> m (Metrics Natural)
pool_metrics Pool m a
basePool
    }

-- | Use a resource from the pool. Once the continuation returns, the resource will be returned to
-- the pool. If the given continuation throws an error then the acquired resource will be destroyed
-- instead.
--
-- @since 0.0.0
withResource :: Catch.MonadMask m => Pool m a -> (a -> m r) -> m r
withResource :: Pool m a -> (a -> m r) -> m r
withResource Pool m a
pool a -> m r
f =
  ((forall a. m a -> m a) -> m r) -> m r
forall (m :: * -> *) b.
MonadMask m =>
((forall a. m a -> m a) -> m b) -> m b
Catch.mask (((forall a. m a -> m a) -> m r) -> m r)
-> ((forall a. m a -> m a) -> m r) -> m r
forall a b. (a -> b) -> a -> b
$ \forall a. m a -> m a
restore -> do
    a
resource <- m a -> m a
forall a. m a -> m a
restore (Pool m a -> m a
forall (m :: * -> *) a. Pool m a -> m a
pool_acquire Pool m a
pool)
    r
result <- m r -> m r
forall a. m a -> m a
restore (a -> m r
f a
resource) m r -> m () -> m r
forall (m :: * -> *) a b. MonadMask m => m a -> m b -> m a
`Catch.onError` Pool m a -> a -> m ()
forall (m :: * -> *) a. Pool m a -> a -> m ()
pool_destroy Pool m a
pool a
resource
    Pool m a -> a -> m ()
forall (m :: * -> *) a. Pool m a -> a -> m ()
pool_return Pool m a
pool a
resource
    r -> m r
forall (f :: * -> *) a. Applicative f => a -> f a
pure r
result

{-# INLINE withResource #-}

-- | Acquire a resource.
--
-- @since 0.1.0
acquireResource :: Pool m a -> m a
acquireResource :: Pool m a -> m a
acquireResource = Pool m a -> m a
forall (m :: * -> *) a. Pool m a -> m a
pool_acquire

{-# INLINE acquireResource #-}

-- | Return a resource to the pool.
--
-- @since 0.1.0
returnResource :: Pool m a -> a -> m ()
returnResource :: Pool m a -> a -> m ()
returnResource = Pool m a -> a -> m ()
forall (m :: * -> *) a. Pool m a -> a -> m ()
pool_return

{-# INLINE returnResource #-}

-- | Destroy a resource.
--
-- @since 0.1.0
destroyResource :: Pool m a -> a -> m ()
destroyResource :: Pool m a -> a -> m ()
destroyResource = Pool m a -> a -> m ()
forall (m :: * -> *) a. Pool m a -> a -> m ()
pool_destroy

{-# INLINE destroyResource #-}

-- | Fetch pool metrics.
--
-- @since 0.0.0
poolMetrics :: Pool m a -> m (Metrics Natural)
poolMetrics :: Pool m a -> m (Metrics Natural)
poolMetrics = Pool m a -> m (Metrics Natural)
forall (m :: * -> *) a. Pool m a -> m (Metrics Natural)
pool_metrics

{-# INLINE poolMetrics #-}

---

-- | Pool metrics
--
-- @since 0.0.0
data Metrics a = Metrics
  { Metrics a -> a
metrics_createdResources :: a
  -- ^ Total number of resources created
  --
  -- @since 0.0.0
  , Metrics a -> a
metrics_destroyedResources :: a
  -- ^ Total number of resources destroyed
  --
  -- @since 0.0.0
  , Metrics a -> a
metrics_maxLiveResources :: a
  -- ^ Maximum number of resources that were alive simultaneously
  --
  -- @since 0.0.0
  , Metrics a -> a
metrics_idleResources :: a
  -- ^ Number of resources currently idle
  --
  -- @since 0.1.0
  }
  deriving stock (Int -> Metrics a -> ShowS
[Metrics a] -> ShowS
Metrics a -> String
(Int -> Metrics a -> ShowS)
-> (Metrics a -> String)
-> ([Metrics a] -> ShowS)
-> Show (Metrics a)
forall a. Show a => Int -> Metrics a -> ShowS
forall a. Show a => [Metrics a] -> ShowS
forall a. Show a => Metrics a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Metrics a] -> ShowS
$cshowList :: forall a. Show a => [Metrics a] -> ShowS
show :: Metrics a -> String
$cshow :: forall a. Show a => Metrics a -> String
showsPrec :: Int -> Metrics a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> Metrics a -> ShowS
Show, ReadPrec [Metrics a]
ReadPrec (Metrics a)
Int -> ReadS (Metrics a)
ReadS [Metrics a]
(Int -> ReadS (Metrics a))
-> ReadS [Metrics a]
-> ReadPrec (Metrics a)
-> ReadPrec [Metrics a]
-> Read (Metrics a)
forall a. Read a => ReadPrec [Metrics a]
forall a. Read a => ReadPrec (Metrics a)
forall a. Read a => Int -> ReadS (Metrics a)
forall a. Read a => ReadS [Metrics a]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Metrics a]
$creadListPrec :: forall a. Read a => ReadPrec [Metrics a]
readPrec :: ReadPrec (Metrics a)
$creadPrec :: forall a. Read a => ReadPrec (Metrics a)
readList :: ReadS [Metrics a]
$creadList :: forall a. Read a => ReadS [Metrics a]
readsPrec :: Int -> ReadS (Metrics a)
$creadsPrec :: forall a. Read a => Int -> ReadS (Metrics a)
Read, Metrics a -> Metrics a -> Bool
(Metrics a -> Metrics a -> Bool)
-> (Metrics a -> Metrics a -> Bool) -> Eq (Metrics a)
forall a. Eq a => Metrics a -> Metrics a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Metrics a -> Metrics a -> Bool
$c/= :: forall a. Eq a => Metrics a -> Metrics a -> Bool
== :: Metrics a -> Metrics a -> Bool
$c== :: forall a. Eq a => Metrics a -> Metrics a -> Bool
Eq, Eq (Metrics a)
Eq (Metrics a)
-> (Metrics a -> Metrics a -> Ordering)
-> (Metrics a -> Metrics a -> Bool)
-> (Metrics a -> Metrics a -> Bool)
-> (Metrics a -> Metrics a -> Bool)
-> (Metrics a -> Metrics a -> Bool)
-> (Metrics a -> Metrics a -> Metrics a)
-> (Metrics a -> Metrics a -> Metrics a)
-> Ord (Metrics a)
Metrics a -> Metrics a -> Bool
Metrics a -> Metrics a -> Ordering
Metrics a -> Metrics a -> Metrics a
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall a. Ord a => Eq (Metrics a)
forall a. Ord a => Metrics a -> Metrics a -> Bool
forall a. Ord a => Metrics a -> Metrics a -> Ordering
forall a. Ord a => Metrics a -> Metrics a -> Metrics a
min :: Metrics a -> Metrics a -> Metrics a
$cmin :: forall a. Ord a => Metrics a -> Metrics a -> Metrics a
max :: Metrics a -> Metrics a -> Metrics a
$cmax :: forall a. Ord a => Metrics a -> Metrics a -> Metrics a
>= :: Metrics a -> Metrics a -> Bool
$c>= :: forall a. Ord a => Metrics a -> Metrics a -> Bool
> :: Metrics a -> Metrics a -> Bool
$c> :: forall a. Ord a => Metrics a -> Metrics a -> Bool
<= :: Metrics a -> Metrics a -> Bool
$c<= :: forall a. Ord a => Metrics a -> Metrics a -> Bool
< :: Metrics a -> Metrics a -> Bool
$c< :: forall a. Ord a => Metrics a -> Metrics a -> Bool
compare :: Metrics a -> Metrics a -> Ordering
$ccompare :: forall a. Ord a => Metrics a -> Metrics a -> Ordering
$cp1Ord :: forall a. Ord a => Eq (Metrics a)
Ord, a -> Metrics b -> Metrics a
(a -> b) -> Metrics a -> Metrics b
(forall a b. (a -> b) -> Metrics a -> Metrics b)
-> (forall a b. a -> Metrics b -> Metrics a) -> Functor Metrics
forall a b. a -> Metrics b -> Metrics a
forall a b. (a -> b) -> Metrics a -> Metrics b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> Metrics b -> Metrics a
$c<$ :: forall a b. a -> Metrics b -> Metrics a
fmap :: (a -> b) -> Metrics a -> Metrics b
$cfmap :: forall a b. (a -> b) -> Metrics a -> Metrics b
Functor, Metrics a -> Bool
(a -> m) -> Metrics a -> m
(a -> b -> b) -> b -> Metrics a -> b
(forall m. Monoid m => Metrics m -> m)
-> (forall m a. Monoid m => (a -> m) -> Metrics a -> m)
-> (forall m a. Monoid m => (a -> m) -> Metrics a -> m)
-> (forall a b. (a -> b -> b) -> b -> Metrics a -> b)
-> (forall a b. (a -> b -> b) -> b -> Metrics a -> b)
-> (forall b a. (b -> a -> b) -> b -> Metrics a -> b)
-> (forall b a. (b -> a -> b) -> b -> Metrics a -> b)
-> (forall a. (a -> a -> a) -> Metrics a -> a)
-> (forall a. (a -> a -> a) -> Metrics a -> a)
-> (forall a. Metrics a -> [a])
-> (forall a. Metrics a -> Bool)
-> (forall a. Metrics a -> Int)
-> (forall a. Eq a => a -> Metrics a -> Bool)
-> (forall a. Ord a => Metrics a -> a)
-> (forall a. Ord a => Metrics a -> a)
-> (forall a. Num a => Metrics a -> a)
-> (forall a. Num a => Metrics a -> a)
-> Foldable Metrics
forall a. Eq a => a -> Metrics a -> Bool
forall a. Num a => Metrics a -> a
forall a. Ord a => Metrics a -> a
forall m. Monoid m => Metrics m -> m
forall a. Metrics a -> Bool
forall a. Metrics a -> Int
forall a. Metrics a -> [a]
forall a. (a -> a -> a) -> Metrics a -> a
forall m a. Monoid m => (a -> m) -> Metrics a -> m
forall b a. (b -> a -> b) -> b -> Metrics a -> b
forall a b. (a -> b -> b) -> b -> Metrics a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Int)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
product :: Metrics a -> a
$cproduct :: forall a. Num a => Metrics a -> a
sum :: Metrics a -> a
$csum :: forall a. Num a => Metrics a -> a
minimum :: Metrics a -> a
$cminimum :: forall a. Ord a => Metrics a -> a
maximum :: Metrics a -> a
$cmaximum :: forall a. Ord a => Metrics a -> a
elem :: a -> Metrics a -> Bool
$celem :: forall a. Eq a => a -> Metrics a -> Bool
length :: Metrics a -> Int
$clength :: forall a. Metrics a -> Int
null :: Metrics a -> Bool
$cnull :: forall a. Metrics a -> Bool
toList :: Metrics a -> [a]
$ctoList :: forall a. Metrics a -> [a]
foldl1 :: (a -> a -> a) -> Metrics a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> Metrics a -> a
foldr1 :: (a -> a -> a) -> Metrics a -> a
$cfoldr1 :: forall a. (a -> a -> a) -> Metrics a -> a
foldl' :: (b -> a -> b) -> b -> Metrics a -> b
$cfoldl' :: forall b a. (b -> a -> b) -> b -> Metrics a -> b
foldl :: (b -> a -> b) -> b -> Metrics a -> b
$cfoldl :: forall b a. (b -> a -> b) -> b -> Metrics a -> b
foldr' :: (a -> b -> b) -> b -> Metrics a -> b
$cfoldr' :: forall a b. (a -> b -> b) -> b -> Metrics a -> b
foldr :: (a -> b -> b) -> b -> Metrics a -> b
$cfoldr :: forall a b. (a -> b -> b) -> b -> Metrics a -> b
foldMap' :: (a -> m) -> Metrics a -> m
$cfoldMap' :: forall m a. Monoid m => (a -> m) -> Metrics a -> m
foldMap :: (a -> m) -> Metrics a -> m
$cfoldMap :: forall m a. Monoid m => (a -> m) -> Metrics a -> m
fold :: Metrics m -> m
$cfold :: forall m. Monoid m => Metrics m -> m
Foldable, Functor Metrics
Foldable Metrics
Functor Metrics
-> Foldable Metrics
-> (forall (f :: * -> *) a b.
    Applicative f =>
    (a -> f b) -> Metrics a -> f (Metrics b))
-> (forall (f :: * -> *) a.
    Applicative f =>
    Metrics (f a) -> f (Metrics a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> Metrics a -> m (Metrics b))
-> (forall (m :: * -> *) a.
    Monad m =>
    Metrics (m a) -> m (Metrics a))
-> Traversable Metrics
(a -> f b) -> Metrics a -> f (Metrics b)
forall (t :: * -> *).
Functor t
-> Foldable t
-> (forall (f :: * -> *) a b.
    Applicative f =>
    (a -> f b) -> t a -> f (t b))
-> (forall (f :: * -> *) a. Applicative f => t (f a) -> f (t a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> t a -> m (t b))
-> (forall (m :: * -> *) a. Monad m => t (m a) -> m (t a))
-> Traversable t
forall (m :: * -> *) a. Monad m => Metrics (m a) -> m (Metrics a)
forall (f :: * -> *) a.
Applicative f =>
Metrics (f a) -> f (Metrics a)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Metrics a -> m (Metrics b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Metrics a -> f (Metrics b)
sequence :: Metrics (m a) -> m (Metrics a)
$csequence :: forall (m :: * -> *) a. Monad m => Metrics (m a) -> m (Metrics a)
mapM :: (a -> m b) -> Metrics a -> m (Metrics b)
$cmapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Metrics a -> m (Metrics b)
sequenceA :: Metrics (f a) -> f (Metrics a)
$csequenceA :: forall (f :: * -> *) a.
Applicative f =>
Metrics (f a) -> f (Metrics a)
traverse :: (a -> f b) -> Metrics a -> f (Metrics b)
$ctraverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Metrics a -> f (Metrics b)
$cp2Traversable :: Foldable Metrics
$cp1Traversable :: Functor Metrics
Traversable)

-- | Increase a value held by an IORef by one.
succIORef :: (Concurrent.MonadConc m, Enum a) => Concurrent.IORef m a -> m ()
succIORef :: IORef m a -> m ()
succIORef IORef m a
ref = IORef m a -> (a -> (a, ())) -> m ()
forall (m :: * -> *) a b.
MonadConc m =>
IORef m a -> (a -> (a, b)) -> m b
Concurrent.atomicModifyIORef' IORef m a
ref (\a
x -> (a -> a
forall a. Enum a => a -> a
succ a
x, ()))

-- | Replace the value in an IORef with the given value if the latter is greater.
maxIORef :: (Concurrent.MonadConc m, Ord a) => Concurrent.IORef m a -> a -> m ()
maxIORef :: IORef m a -> a -> m ()
maxIORef IORef m a
ref a
y = IORef m a -> (a -> (a, ())) -> m ()
forall (m :: * -> *) a b.
MonadConc m =>
IORef m a -> (a -> (a, b)) -> m b
Concurrent.atomicModifyIORef' IORef m a
ref (\a
x -> (a -> a -> a
forall a. Ord a => a -> a -> a
max a
x a
y, ()))