{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE StrictData #-}
{-# LANGUAGE TypeApplications #-}
module Simpoole
( Pool
, mapPool
, 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.Coerce (coerce)
import Data.Foldable (for_)
import qualified Data.Sequence as Seq
import qualified Data.Time as Time
import Numeric.Natural (Natural)
import Simpoole.Internal (FailToIO (..), failToIO)
data ReturnPolicy
= ReturnToFront
| ReturnToBack
| ReturnToMiddle
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)
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
data Settings = Settings
{ Settings -> Maybe NominalDiffTime
settings_idleTimeout :: Maybe Time.NominalDiffTime
, Settings -> ReturnPolicy
settings_returnPolicy :: ReturnPolicy
, Settings -> Maybe Int
settings_maxLiveLimit :: Maybe Int
}
defaultSettings :: Settings
defaultSettings :: Settings
defaultSettings = Settings :: Maybe NominalDiffTime -> ReturnPolicy -> Maybe Int -> Settings
Settings
{ settings_idleTimeout :: Maybe NominalDiffTime
settings_idleTimeout = NominalDiffTime -> Maybe NominalDiffTime
forall a. a -> Maybe a
Just NominalDiffTime
60
, settings_returnPolicy :: ReturnPolicy
settings_returnPolicy = ReturnPolicy
ReturnToMiddle
, settings_maxLiveLimit :: Maybe Int
settings_maxLiveLimit = Maybe Int
forall a. Maybe a
Nothing
}
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)
}
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 #-}
data Resource a =
Resource
Time.UTCTime
a
newUnlimitedPool
:: (Concurrent.MonadConc m, MonadIO m)
=> m a
-> (a -> m ())
-> 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
, ()
)
Maybe NominalDiffTime -> (NominalDiffTime -> m ()) -> m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ (Settings -> Maybe NominalDiffTime
settings_idleTimeout Settings
settings) ((NominalDiffTime -> m ()) -> m ())
-> (NominalDiffTime -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \NominalDiffTime
idleTimeout -> m (Async m Any) -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m (Async m Any) -> m ()) -> m (Async m Any) -> m ()
forall a b. (a -> b) -> a -> b
$
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
<= NominalDiffTime
idleTimeout
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
}
newLimitedPool
:: (Concurrent.MonadConc m, MonadIO m, MonadFail m)
=> m a
-> (a -> m ())
-> Int
-> Settings
-> m (Pool m a)
newLimitedPool :: m a -> (a -> m ()) -> Int -> Settings -> m (Pool m a)
newLimitedPool 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
}
newPool
:: (Concurrent.MonadConc m, MonadIO m)
=> m a
-> (a -> m ())
-> Settings
-> m (Pool m a)
newPool :: m a -> (a -> m ()) -> Settings -> m (Pool m a)
newPool m a
create a -> m ()
destroy Settings
settings =
case Settings -> Maybe Int
settings_maxLiveLimit Settings
settings of
Just Int
maxLive -> FailToIO m (Pool m a) -> m (Pool m a)
forall (m :: * -> *) a. FailToIO m a -> m a
failToIO (FailToIO m (Pool m a) -> m (Pool m a))
-> FailToIO m (Pool m a) -> m (Pool m a)
forall a b. (a -> b) -> a -> b
$ do
Pool (FailToIO m) a
pool <- FailToIO m a
-> (a -> FailToIO m ())
-> Int
-> Settings
-> FailToIO m (Pool (FailToIO m) a)
forall (m :: * -> *) a.
(MonadConc m, MonadIO m, MonadFail m) =>
m a -> (a -> m ()) -> Int -> Settings -> m (Pool m a)
newLimitedPool (m a -> FailToIO m a
coerce m a
create) ((a -> m ()) -> a -> FailToIO m ()
coerce a -> m ()
destroy) Int
maxLive Settings
settings
Pool m a -> FailToIO m (Pool m a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((forall x. FailToIO m x -> m x) -> Pool (FailToIO m) a -> Pool m a
forall (m :: * -> *) (n :: * -> *) a.
(forall x. m x -> n x) -> Pool m a -> Pool n a
mapPool forall x. FailToIO m x -> m x
coerce Pool (FailToIO m) a
pool)
Maybe Int
Nothing -> 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
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 #-}
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 #-}
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 #-}
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 #-}
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 #-}
data Metrics a = Metrics
{ Metrics a -> a
metrics_createdResources :: a
, Metrics a -> a
metrics_destroyedResources :: a
, Metrics a -> a
metrics_maxLiveResources :: a
, Metrics a -> a
metrics_idleResources :: a
}
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)
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, ()))
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, ()))