{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Data.KeyedPool
( KeyedPool
, createKeyedPool
, takeKeyedPool
, Managed
, managedResource
, managedReused
, managedRelease
, keepAlive
, Reuse (..)
, dummyManaged
) where
import Control.Concurrent (forkIOWithUnmask, threadDelay)
import Control.Concurrent.STM
import Control.Exception (mask_, catch, SomeException)
import Control.Monad (join, unless, void)
import Data.Map (Map)
import Data.Maybe (isJust)
import qualified Data.Map.Strict as Map
import Data.Time (UTCTime, getCurrentTime, addUTCTime)
import Data.IORef (IORef, newIORef, mkWeakIORef, readIORef)
import qualified Data.Foldable as F
import GHC.Conc (unsafeIOToSTM)
import System.IO.Unsafe (unsafePerformIO)
data KeyedPool key resource = KeyedPool
{ KeyedPool key resource -> key -> IO resource
kpCreate :: !(key -> IO resource)
, KeyedPool key resource -> resource -> IO ()
kpDestroy :: !(resource -> IO ())
, KeyedPool key resource -> Int
kpMaxPerKey :: !Int
, KeyedPool key resource -> Int
kpMaxTotal :: !Int
, KeyedPool key resource -> TVar (PoolMap key resource)
kpVar :: !(TVar (PoolMap key resource))
, KeyedPool key resource -> IORef ()
kpAlive :: !(IORef ())
}
data PoolMap key resource
= PoolClosed
| PoolOpen
{-# UNPACK #-} !Int
!(Map key (PoolList resource))
deriving PoolMap key a -> Bool
(a -> m) -> PoolMap key a -> m
(a -> b -> b) -> b -> PoolMap key a -> b
(forall m. Monoid m => PoolMap key m -> m)
-> (forall m a. Monoid m => (a -> m) -> PoolMap key a -> m)
-> (forall m a. Monoid m => (a -> m) -> PoolMap key a -> m)
-> (forall a b. (a -> b -> b) -> b -> PoolMap key a -> b)
-> (forall a b. (a -> b -> b) -> b -> PoolMap key a -> b)
-> (forall b a. (b -> a -> b) -> b -> PoolMap key a -> b)
-> (forall b a. (b -> a -> b) -> b -> PoolMap key a -> b)
-> (forall a. (a -> a -> a) -> PoolMap key a -> a)
-> (forall a. (a -> a -> a) -> PoolMap key a -> a)
-> (forall a. PoolMap key a -> [a])
-> (forall a. PoolMap key a -> Bool)
-> (forall a. PoolMap key a -> Int)
-> (forall a. Eq a => a -> PoolMap key a -> Bool)
-> (forall a. Ord a => PoolMap key a -> a)
-> (forall a. Ord a => PoolMap key a -> a)
-> (forall a. Num a => PoolMap key a -> a)
-> (forall a. Num a => PoolMap key a -> a)
-> Foldable (PoolMap key)
forall a. Eq a => a -> PoolMap key a -> Bool
forall a. Num a => PoolMap key a -> a
forall a. Ord a => PoolMap key a -> a
forall m. Monoid m => PoolMap key m -> m
forall a. PoolMap key a -> Bool
forall a. PoolMap key a -> Int
forall a. PoolMap key a -> [a]
forall a. (a -> a -> a) -> PoolMap key a -> a
forall key a. Eq a => a -> PoolMap key a -> Bool
forall key a. Num a => PoolMap key a -> a
forall key a. Ord a => PoolMap key a -> a
forall m a. Monoid m => (a -> m) -> PoolMap key a -> m
forall key m. Monoid m => PoolMap key m -> m
forall key a. PoolMap key a -> Bool
forall key a. PoolMap key a -> Int
forall key a. PoolMap key a -> [a]
forall b a. (b -> a -> b) -> b -> PoolMap key a -> b
forall a b. (a -> b -> b) -> b -> PoolMap key a -> b
forall key a. (a -> a -> a) -> PoolMap key a -> a
forall key m a. Monoid m => (a -> m) -> PoolMap key a -> m
forall key b a. (b -> a -> b) -> b -> PoolMap key a -> b
forall key a b. (a -> b -> b) -> b -> PoolMap key 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 :: PoolMap key a -> a
$cproduct :: forall key a. Num a => PoolMap key a -> a
sum :: PoolMap key a -> a
$csum :: forall key a. Num a => PoolMap key a -> a
minimum :: PoolMap key a -> a
$cminimum :: forall key a. Ord a => PoolMap key a -> a
maximum :: PoolMap key a -> a
$cmaximum :: forall key a. Ord a => PoolMap key a -> a
elem :: a -> PoolMap key a -> Bool
$celem :: forall key a. Eq a => a -> PoolMap key a -> Bool
length :: PoolMap key a -> Int
$clength :: forall key a. PoolMap key a -> Int
null :: PoolMap key a -> Bool
$cnull :: forall key a. PoolMap key a -> Bool
toList :: PoolMap key a -> [a]
$ctoList :: forall key a. PoolMap key a -> [a]
foldl1 :: (a -> a -> a) -> PoolMap key a -> a
$cfoldl1 :: forall key a. (a -> a -> a) -> PoolMap key a -> a
foldr1 :: (a -> a -> a) -> PoolMap key a -> a
$cfoldr1 :: forall key a. (a -> a -> a) -> PoolMap key a -> a
foldl' :: (b -> a -> b) -> b -> PoolMap key a -> b
$cfoldl' :: forall key b a. (b -> a -> b) -> b -> PoolMap key a -> b
foldl :: (b -> a -> b) -> b -> PoolMap key a -> b
$cfoldl :: forall key b a. (b -> a -> b) -> b -> PoolMap key a -> b
foldr' :: (a -> b -> b) -> b -> PoolMap key a -> b
$cfoldr' :: forall key a b. (a -> b -> b) -> b -> PoolMap key a -> b
foldr :: (a -> b -> b) -> b -> PoolMap key a -> b
$cfoldr :: forall key a b. (a -> b -> b) -> b -> PoolMap key a -> b
foldMap' :: (a -> m) -> PoolMap key a -> m
$cfoldMap' :: forall key m a. Monoid m => (a -> m) -> PoolMap key a -> m
foldMap :: (a -> m) -> PoolMap key a -> m
$cfoldMap :: forall key m a. Monoid m => (a -> m) -> PoolMap key a -> m
fold :: PoolMap key m -> m
$cfold :: forall key m. Monoid m => PoolMap key m -> m
F.Foldable
data PoolList a
= One a {-# UNPACK #-} !UTCTime
| Cons
a
{-# UNPACK #-} !Int
{-# UNPACK #-} !UTCTime
!(PoolList a)
deriving PoolList a -> Bool
(a -> m) -> PoolList a -> m
(a -> b -> b) -> b -> PoolList a -> b
(forall m. Monoid m => PoolList m -> m)
-> (forall m a. Monoid m => (a -> m) -> PoolList a -> m)
-> (forall m a. Monoid m => (a -> m) -> PoolList a -> m)
-> (forall a b. (a -> b -> b) -> b -> PoolList a -> b)
-> (forall a b. (a -> b -> b) -> b -> PoolList a -> b)
-> (forall b a. (b -> a -> b) -> b -> PoolList a -> b)
-> (forall b a. (b -> a -> b) -> b -> PoolList a -> b)
-> (forall a. (a -> a -> a) -> PoolList a -> a)
-> (forall a. (a -> a -> a) -> PoolList a -> a)
-> (forall a. PoolList a -> [a])
-> (forall a. PoolList a -> Bool)
-> (forall a. PoolList a -> Int)
-> (forall a. Eq a => a -> PoolList a -> Bool)
-> (forall a. Ord a => PoolList a -> a)
-> (forall a. Ord a => PoolList a -> a)
-> (forall a. Num a => PoolList a -> a)
-> (forall a. Num a => PoolList a -> a)
-> Foldable PoolList
forall a. Eq a => a -> PoolList a -> Bool
forall a. Num a => PoolList a -> a
forall a. Ord a => PoolList a -> a
forall m. Monoid m => PoolList m -> m
forall a. PoolList a -> Bool
forall a. PoolList a -> Int
forall a. PoolList a -> [a]
forall a. (a -> a -> a) -> PoolList a -> a
forall m a. Monoid m => (a -> m) -> PoolList a -> m
forall b a. (b -> a -> b) -> b -> PoolList a -> b
forall a b. (a -> b -> b) -> b -> PoolList 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 :: PoolList a -> a
$cproduct :: forall a. Num a => PoolList a -> a
sum :: PoolList a -> a
$csum :: forall a. Num a => PoolList a -> a
minimum :: PoolList a -> a
$cminimum :: forall a. Ord a => PoolList a -> a
maximum :: PoolList a -> a
$cmaximum :: forall a. Ord a => PoolList a -> a
elem :: a -> PoolList a -> Bool
$celem :: forall a. Eq a => a -> PoolList a -> Bool
length :: PoolList a -> Int
$clength :: forall a. PoolList a -> Int
null :: PoolList a -> Bool
$cnull :: forall a. PoolList a -> Bool
toList :: PoolList a -> [a]
$ctoList :: forall a. PoolList a -> [a]
foldl1 :: (a -> a -> a) -> PoolList a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> PoolList a -> a
foldr1 :: (a -> a -> a) -> PoolList a -> a
$cfoldr1 :: forall a. (a -> a -> a) -> PoolList a -> a
foldl' :: (b -> a -> b) -> b -> PoolList a -> b
$cfoldl' :: forall b a. (b -> a -> b) -> b -> PoolList a -> b
foldl :: (b -> a -> b) -> b -> PoolList a -> b
$cfoldl :: forall b a. (b -> a -> b) -> b -> PoolList a -> b
foldr' :: (a -> b -> b) -> b -> PoolList a -> b
$cfoldr' :: forall a b. (a -> b -> b) -> b -> PoolList a -> b
foldr :: (a -> b -> b) -> b -> PoolList a -> b
$cfoldr :: forall a b. (a -> b -> b) -> b -> PoolList a -> b
foldMap' :: (a -> m) -> PoolList a -> m
$cfoldMap' :: forall m a. Monoid m => (a -> m) -> PoolList a -> m
foldMap :: (a -> m) -> PoolList a -> m
$cfoldMap :: forall m a. Monoid m => (a -> m) -> PoolList a -> m
fold :: PoolList m -> m
$cfold :: forall m. Monoid m => PoolList m -> m
F.Foldable
plistToList :: PoolList a -> [(UTCTime, a)]
plistToList :: PoolList a -> [(UTCTime, a)]
plistToList (One a
a UTCTime
t) = [(UTCTime
t, a
a)]
plistToList (Cons a
a Int
_ UTCTime
t PoolList a
plist) = (UTCTime
t, a
a) (UTCTime, a) -> [(UTCTime, a)] -> [(UTCTime, a)]
forall a. a -> [a] -> [a]
: PoolList a -> [(UTCTime, a)]
forall a. PoolList a -> [(UTCTime, a)]
plistToList PoolList a
plist
plistFromList :: [(UTCTime, a)] -> Maybe (PoolList a)
plistFromList :: [(UTCTime, a)] -> Maybe (PoolList a)
plistFromList [] = Maybe (PoolList a)
forall a. Maybe a
Nothing
plistFromList [(UTCTime
t, a
a)] = PoolList a -> Maybe (PoolList a)
forall a. a -> Maybe a
Just (a -> UTCTime -> PoolList a
forall a. a -> UTCTime -> PoolList a
One a
a UTCTime
t)
plistFromList [(UTCTime, a)]
xs =
PoolList a -> Maybe (PoolList a)
forall a. a -> Maybe a
Just (PoolList a -> Maybe (PoolList a))
-> ([(UTCTime, a)] -> PoolList a)
-> [(UTCTime, a)]
-> Maybe (PoolList a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, PoolList a) -> PoolList a
forall a b. (a, b) -> b
snd ((Int, PoolList a) -> PoolList a)
-> ([(UTCTime, a)] -> (Int, PoolList a))
-> [(UTCTime, a)]
-> PoolList a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(UTCTime, a)] -> (Int, PoolList a)
forall a. [(UTCTime, a)] -> (Int, PoolList a)
go ([(UTCTime, a)] -> Maybe (PoolList a))
-> [(UTCTime, a)] -> Maybe (PoolList a)
forall a b. (a -> b) -> a -> b
$ [(UTCTime, a)]
xs
where
go :: [(UTCTime, a)] -> (Int, PoolList a)
go [] = [Char] -> (Int, PoolList a)
forall a. HasCallStack => [Char] -> a
error [Char]
"plistFromList.go []"
go [(UTCTime
t, a
a)] = (Int
2, a -> UTCTime -> PoolList a
forall a. a -> UTCTime -> PoolList a
One a
a UTCTime
t)
go ((UTCTime
t, a
a):[(UTCTime, a)]
rest) =
let (Int
i, PoolList a
rest') = [(UTCTime, a)] -> (Int, PoolList a)
go [(UTCTime, a)]
rest
i' :: Int
i' = Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
in Int
i' Int -> (Int, PoolList a) -> (Int, PoolList a)
`seq` (Int
i', a -> Int -> UTCTime -> PoolList a -> PoolList a
forall a. a -> Int -> UTCTime -> PoolList a -> PoolList a
Cons a
a Int
i UTCTime
t PoolList a
rest')
createKeyedPool
:: Ord key
=> (key -> IO resource)
-> (resource -> IO ())
-> Int
-> Int
-> (SomeException -> IO ())
-> IO (KeyedPool key resource)
createKeyedPool :: (key -> IO resource)
-> (resource -> IO ())
-> Int
-> Int
-> (SomeException -> IO ())
-> IO (KeyedPool key resource)
createKeyedPool key -> IO resource
create resource -> IO ()
destroy Int
maxPerKey Int
maxTotal SomeException -> IO ()
onReaperException = do
TVar (PoolMap key resource)
var <- PoolMap key resource -> IO (TVar (PoolMap key resource))
forall a. a -> IO (TVar a)
newTVarIO (PoolMap key resource -> IO (TVar (PoolMap key resource)))
-> PoolMap key resource -> IO (TVar (PoolMap key resource))
forall a b. (a -> b) -> a -> b
$ Int -> Map key (PoolList resource) -> PoolMap key resource
forall key resource.
Int -> Map key (PoolList resource) -> PoolMap key resource
PoolOpen Int
0 Map key (PoolList resource)
forall k a. Map k a
Map.empty
IORef ()
alive <- () -> IO (IORef ())
forall a. a -> IO (IORef a)
newIORef ()
IO (Weak (IORef ())) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Weak (IORef ())) -> IO ()) -> IO (Weak (IORef ())) -> IO ()
forall a b. (a -> b) -> a -> b
$ IORef () -> IO () -> IO (Weak (IORef ()))
forall a. IORef a -> IO () -> IO (Weak (IORef a))
mkWeakIORef IORef ()
alive (IO () -> IO (Weak (IORef ()))) -> IO () -> IO (Weak (IORef ()))
forall a b. (a -> b) -> a -> b
$ (resource -> IO ()) -> TVar (PoolMap key resource) -> IO ()
forall resource key.
(resource -> IO ()) -> TVar (PoolMap key resource) -> IO ()
destroyKeyedPool' resource -> IO ()
destroy TVar (PoolMap key resource)
var
ThreadId
_ <- ((forall a. IO a -> IO a) -> IO ()) -> IO ThreadId
forkIOWithUnmask (((forall a. IO a -> IO a) -> IO ()) -> IO ThreadId)
-> ((forall a. IO a -> IO a) -> IO ()) -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ \forall a. IO a -> IO a
restore -> IO () -> IO ()
forall a. IO a -> IO a
keepRunning (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> IO ()
forall a. IO a -> IO a
restore (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ (resource -> IO ()) -> TVar (PoolMap key resource) -> IO ()
forall key resource.
Ord key =>
(resource -> IO ()) -> TVar (PoolMap key resource) -> IO ()
reap resource -> IO ()
destroy TVar (PoolMap key resource)
var
KeyedPool key resource -> IO (KeyedPool key resource)
forall (m :: * -> *) a. Monad m => a -> m a
return KeyedPool :: forall key resource.
(key -> IO resource)
-> (resource -> IO ())
-> Int
-> Int
-> TVar (PoolMap key resource)
-> IORef ()
-> KeyedPool key resource
KeyedPool
{ kpCreate :: key -> IO resource
kpCreate = key -> IO resource
create
, kpDestroy :: resource -> IO ()
kpDestroy = resource -> IO ()
destroy
, kpMaxPerKey :: Int
kpMaxPerKey = Int
maxPerKey
, kpMaxTotal :: Int
kpMaxTotal = Int
maxTotal
, kpVar :: TVar (PoolMap key resource)
kpVar = TVar (PoolMap key resource)
var
, kpAlive :: IORef ()
kpAlive = IORef ()
alive
}
where
keepRunning :: IO a -> IO a
keepRunning IO a
action =
IO a
loop
where
loop :: IO a
loop = IO a
action IO a -> (SomeException -> IO a) -> IO a
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` \SomeException
e -> SomeException -> IO ()
onReaperException SomeException
e IO () -> IO a -> IO a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO a
loop
destroyKeyedPool' :: (resource -> IO ())
-> TVar (PoolMap key resource)
-> IO ()
destroyKeyedPool' :: (resource -> IO ()) -> TVar (PoolMap key resource) -> IO ()
destroyKeyedPool' resource -> IO ()
destroy TVar (PoolMap key resource)
var = do
PoolMap key resource
m <- STM (PoolMap key resource) -> IO (PoolMap key resource)
forall a. STM a -> IO a
atomically (STM (PoolMap key resource) -> IO (PoolMap key resource))
-> STM (PoolMap key resource) -> IO (PoolMap key resource)
forall a b. (a -> b) -> a -> b
$ TVar (PoolMap key resource)
-> PoolMap key resource -> STM (PoolMap key resource)
forall a. TVar a -> a -> STM a
swapTVar TVar (PoolMap key resource)
var PoolMap key resource
forall key resource. PoolMap key resource
PoolClosed
(resource -> IO ()) -> PoolMap key resource -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
F.mapM_ (IO () -> IO ()
ignoreExceptions (IO () -> IO ()) -> (resource -> IO ()) -> resource -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. resource -> IO ()
destroy) PoolMap key resource
m
reap :: forall key resource.
Ord key
=> (resource -> IO ())
-> TVar (PoolMap key resource)
-> IO ()
reap :: (resource -> IO ()) -> TVar (PoolMap key resource) -> IO ()
reap resource -> IO ()
destroy TVar (PoolMap key resource)
var =
IO ()
loop
where
loop :: IO ()
loop = do
Int -> IO ()
threadDelay (Int
5 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1000 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1000)
IO (IO ()) -> IO ()
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (IO (IO ()) -> IO ()) -> IO (IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ STM (IO ()) -> IO (IO ())
forall a. STM a -> IO a
atomically (STM (IO ()) -> IO (IO ())) -> STM (IO ()) -> IO (IO ())
forall a b. (a -> b) -> a -> b
$ do
PoolMap key resource
m'' <- TVar (PoolMap key resource) -> STM (PoolMap key resource)
forall a. TVar a -> STM a
readTVar TVar (PoolMap key resource)
var
case PoolMap key resource
m'' of
PoolMap key resource
PoolClosed -> IO () -> STM (IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return (() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())
PoolOpen Int
idleCount Map key (PoolList resource)
m
| Map key (PoolList resource) -> Bool
forall k a. Map k a -> Bool
Map.null Map key (PoolList resource)
m -> STM (IO ())
forall a. STM a
retry
| Bool
otherwise -> do
(PoolMap key resource
m', [resource]
toDestroy) <- Int
-> Map key (PoolList resource)
-> STM (PoolMap key resource, [resource])
findStale Int
idleCount Map key (PoolList resource)
m
TVar (PoolMap key resource) -> PoolMap key resource -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar (PoolMap key resource)
var PoolMap key resource
m'
IO () -> STM (IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return (IO () -> STM (IO ())) -> IO () -> STM (IO ())
forall a b. (a -> b) -> a -> b
$ do
IO () -> IO ()
forall a. IO a -> IO a
mask_ ((resource -> IO ()) -> [resource] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (IO () -> IO ()
ignoreExceptions (IO () -> IO ()) -> (resource -> IO ()) -> resource -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. resource -> IO ()
destroy) [resource]
toDestroy)
IO ()
loop
findStale :: Int
-> Map key (PoolList resource)
-> STM (PoolMap key resource, [resource])
findStale :: Int
-> Map key (PoolList resource)
-> STM (PoolMap key resource, [resource])
findStale Int
idleCount Map key (PoolList resource)
m = do
UTCTime
now <- IO UTCTime -> STM UTCTime
forall a. IO a -> STM a
unsafeIOToSTM IO UTCTime
getCurrentTime
let isNotStale :: UTCTime -> Bool
isNotStale UTCTime
time = NominalDiffTime
30 NominalDiffTime -> UTCTime -> UTCTime
`addUTCTime` UTCTime
time UTCTime -> UTCTime -> Bool
forall a. Ord a => a -> a -> Bool
>= UTCTime
now
let findStale' :: ([(a, PoolList a)] -> [(k, a)])
-> ([a] -> b) -> [(a, PoolList a)] -> (Map k a, b)
findStale' [(a, PoolList a)] -> [(k, a)]
toKeep [a] -> b
toDestroy [] =
([(k, a)] -> Map k a
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(a, PoolList a)] -> [(k, a)]
toKeep []), [a] -> b
toDestroy [])
findStale' [(a, PoolList a)] -> [(k, a)]
toKeep [a] -> b
toDestroy ((a
key, PoolList a
plist):[(a, PoolList a)]
rest) =
([(a, PoolList a)] -> [(k, a)])
-> ([a] -> b) -> [(a, PoolList a)] -> (Map k a, b)
findStale' [(a, PoolList a)] -> [(k, a)]
toKeep' [a] -> b
toDestroy' [(a, PoolList a)]
rest
where
([(UTCTime, a)]
notStale, [(UTCTime, a)]
stale) = ((UTCTime, a) -> Bool)
-> [(UTCTime, a)] -> ([(UTCTime, a)], [(UTCTime, a)])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (UTCTime -> Bool
isNotStale (UTCTime -> Bool)
-> ((UTCTime, a) -> UTCTime) -> (UTCTime, a) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UTCTime, a) -> UTCTime
forall a b. (a, b) -> a
fst) ([(UTCTime, a)] -> ([(UTCTime, a)], [(UTCTime, a)]))
-> [(UTCTime, a)] -> ([(UTCTime, a)], [(UTCTime, a)])
forall a b. (a -> b) -> a -> b
$ PoolList a -> [(UTCTime, a)]
forall a. PoolList a -> [(UTCTime, a)]
plistToList PoolList a
plist
toDestroy' :: [a] -> b
toDestroy' = [a] -> b
toDestroy ([a] -> b) -> ([a] -> [a]) -> [a] -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (((UTCTime, a) -> a) -> [(UTCTime, a)] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map (UTCTime, a) -> a
forall a b. (a, b) -> b
snd [(UTCTime, a)]
stale[a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++)
toKeep' :: [(a, PoolList a)] -> [(k, a)]
toKeep' =
case [(UTCTime, a)] -> Maybe (PoolList a)
forall a. [(UTCTime, a)] -> Maybe (PoolList a)
plistFromList [(UTCTime, a)]
notStale of
Maybe (PoolList a)
Nothing -> [(a, PoolList a)] -> [(k, a)]
toKeep
Just PoolList a
x -> [(a, PoolList a)] -> [(k, a)]
toKeep ([(a, PoolList a)] -> [(k, a)])
-> ([(a, PoolList a)] -> [(a, PoolList a)])
-> [(a, PoolList a)]
-> [(k, a)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((a
key, PoolList a
x)(a, PoolList a) -> [(a, PoolList a)] -> [(a, PoolList a)]
forall a. a -> [a] -> [a]
:)
let (Map key (PoolList resource)
toKeep, [resource]
toDestroy) = ([(key, PoolList resource)] -> [(key, PoolList resource)])
-> ([resource] -> [resource])
-> [(key, PoolList resource)]
-> (Map key (PoolList resource), [resource])
forall k a a a b.
Ord k =>
([(a, PoolList a)] -> [(k, a)])
-> ([a] -> b) -> [(a, PoolList a)] -> (Map k a, b)
findStale' [(key, PoolList resource)] -> [(key, PoolList resource)]
forall a. a -> a
id [resource] -> [resource]
forall a. a -> a
id (Map key (PoolList resource) -> [(key, PoolList resource)]
forall k a. Map k a -> [(k, a)]
Map.toList Map key (PoolList resource)
m)
let idleCount' :: Int
idleCount' = Int
idleCount Int -> Int -> Int
forall a. Num a => a -> a -> a
- [resource] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [resource]
toDestroy
(PoolMap key resource, [resource])
-> STM (PoolMap key resource, [resource])
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Map key (PoolList resource) -> PoolMap key resource
forall key resource.
Int -> Map key (PoolList resource) -> PoolMap key resource
PoolOpen Int
idleCount' Map key (PoolList resource)
toKeep, [resource]
toDestroy)
takeKeyedPool :: Ord key => KeyedPool key resource -> key -> IO (Managed resource)
takeKeyedPool :: KeyedPool key resource -> key -> IO (Managed resource)
takeKeyedPool KeyedPool key resource
kp key
key = IO (Managed resource) -> IO (Managed resource)
forall a. IO a -> IO a
mask_ (IO (Managed resource) -> IO (Managed resource))
-> IO (Managed resource) -> IO (Managed resource)
forall a b. (a -> b) -> a -> b
$ IO (IO (Managed resource)) -> IO (Managed resource)
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (IO (IO (Managed resource)) -> IO (Managed resource))
-> IO (IO (Managed resource)) -> IO (Managed resource)
forall a b. (a -> b) -> a -> b
$ STM (IO (Managed resource)) -> IO (IO (Managed resource))
forall a. STM a -> IO a
atomically (STM (IO (Managed resource)) -> IO (IO (Managed resource)))
-> STM (IO (Managed resource)) -> IO (IO (Managed resource))
forall a b. (a -> b) -> a -> b
$ do
(PoolMap key resource
m, Maybe resource
mresource) <- (PoolMap key resource -> (PoolMap key resource, Maybe resource))
-> STM (PoolMap key resource)
-> STM (PoolMap key resource, Maybe resource)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PoolMap key resource -> (PoolMap key resource, Maybe resource)
forall a. PoolMap key a -> (PoolMap key a, Maybe a)
go (STM (PoolMap key resource)
-> STM (PoolMap key resource, Maybe resource))
-> STM (PoolMap key resource)
-> STM (PoolMap key resource, Maybe resource)
forall a b. (a -> b) -> a -> b
$ TVar (PoolMap key resource) -> STM (PoolMap key resource)
forall a. TVar a -> STM a
readTVar (KeyedPool key resource -> TVar (PoolMap key resource)
forall key resource.
KeyedPool key resource -> TVar (PoolMap key resource)
kpVar KeyedPool key resource
kp)
TVar (PoolMap key resource) -> PoolMap key resource -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar (KeyedPool key resource -> TVar (PoolMap key resource)
forall key resource.
KeyedPool key resource -> TVar (PoolMap key resource)
kpVar KeyedPool key resource
kp) (PoolMap key resource -> STM ()) -> PoolMap key resource -> STM ()
forall a b. (a -> b) -> a -> b
$! PoolMap key resource
m
IO (Managed resource) -> STM (IO (Managed resource))
forall (m :: * -> *) a. Monad m => a -> m a
return (IO (Managed resource) -> STM (IO (Managed resource)))
-> IO (Managed resource) -> STM (IO (Managed resource))
forall a b. (a -> b) -> a -> b
$ do
resource
resource <- IO resource
-> (resource -> IO resource) -> Maybe resource -> IO resource
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (KeyedPool key resource -> key -> IO resource
forall key resource. KeyedPool key resource -> key -> IO resource
kpCreate KeyedPool key resource
kp key
key) resource -> IO resource
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe resource
mresource
IORef ()
alive <- () -> IO (IORef ())
forall a. a -> IO (IORef a)
newIORef ()
TVar Bool
isReleasedVar <- Bool -> IO (TVar Bool)
forall a. a -> IO (TVar a)
newTVarIO Bool
False
let release :: Reuse -> IO ()
release Reuse
action = IO () -> IO ()
forall a. IO a -> IO a
mask_ (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
Bool
isReleased <- STM Bool -> IO Bool
forall a. STM a -> IO a
atomically (STM Bool -> IO Bool) -> STM Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ TVar Bool -> Bool -> STM Bool
forall a. TVar a -> a -> STM a
swapTVar TVar Bool
isReleasedVar Bool
True
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
isReleased (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
case Reuse
action of
Reuse
Reuse -> KeyedPool key resource -> key -> resource -> IO ()
forall key resource.
Ord key =>
KeyedPool key resource -> key -> resource -> IO ()
putResource KeyedPool key resource
kp key
key resource
resource
Reuse
DontReuse -> IO () -> IO ()
ignoreExceptions (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ KeyedPool key resource -> resource -> IO ()
forall key resource. KeyedPool key resource -> resource -> IO ()
kpDestroy KeyedPool key resource
kp resource
resource
Weak (IORef ())
_ <- IORef () -> IO () -> IO (Weak (IORef ()))
forall a. IORef a -> IO () -> IO (Weak (IORef a))
mkWeakIORef IORef ()
alive (IO () -> IO (Weak (IORef ()))) -> IO () -> IO (Weak (IORef ()))
forall a b. (a -> b) -> a -> b
$ Reuse -> IO ()
release Reuse
DontReuse
Managed resource -> IO (Managed resource)
forall (m :: * -> *) a. Monad m => a -> m a
return Managed :: forall resource.
resource
-> Bool -> (Reuse -> IO ()) -> IORef () -> Managed resource
Managed
{ _managedResource :: resource
_managedResource = resource
resource
, _managedReused :: Bool
_managedReused = Maybe resource -> Bool
forall a. Maybe a -> Bool
isJust Maybe resource
mresource
, _managedRelease :: Reuse -> IO ()
_managedRelease = Reuse -> IO ()
release
, _managedAlive :: IORef ()
_managedAlive = IORef ()
alive
}
where
go :: PoolMap key a -> (PoolMap key a, Maybe a)
go PoolMap key a
PoolClosed = (PoolMap key a
forall key resource. PoolMap key resource
PoolClosed, Maybe a
forall a. Maybe a
Nothing)
go pcOrig :: PoolMap key a
pcOrig@(PoolOpen Int
idleCount Map key (PoolList a)
m) =
case key -> Map key (PoolList a) -> Maybe (PoolList a)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup key
key Map key (PoolList a)
m of
Maybe (PoolList a)
Nothing -> (PoolMap key a
pcOrig, Maybe a
forall a. Maybe a
Nothing)
Just (One a
a UTCTime
_) ->
(Int -> Map key (PoolList a) -> PoolMap key a
forall key resource.
Int -> Map key (PoolList resource) -> PoolMap key resource
PoolOpen (Int
idleCount Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) (key -> Map key (PoolList a) -> Map key (PoolList a)
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete key
key Map key (PoolList a)
m), a -> Maybe a
forall a. a -> Maybe a
Just a
a)
Just (Cons a
a Int
_ UTCTime
_ PoolList a
rest) ->
(Int -> Map key (PoolList a) -> PoolMap key a
forall key resource.
Int -> Map key (PoolList resource) -> PoolMap key resource
PoolOpen (Int
idleCount Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) (key -> PoolList a -> Map key (PoolList a) -> Map key (PoolList a)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert key
key PoolList a
rest Map key (PoolList a)
m), a -> Maybe a
forall a. a -> Maybe a
Just a
a)
putResource :: Ord key => KeyedPool key resource -> key -> resource -> IO ()
putResource :: KeyedPool key resource -> key -> resource -> IO ()
putResource KeyedPool key resource
kp key
key resource
resource = do
UTCTime
now <- IO UTCTime
getCurrentTime
IO (IO ()) -> IO ()
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (IO (IO ()) -> IO ()) -> IO (IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ STM (IO ()) -> IO (IO ())
forall a. STM a -> IO a
atomically (STM (IO ()) -> IO (IO ())) -> STM (IO ()) -> IO (IO ())
forall a b. (a -> b) -> a -> b
$ do
(PoolMap key resource
m, IO ()
action) <- (PoolMap key resource -> (PoolMap key resource, IO ()))
-> STM (PoolMap key resource) -> STM (PoolMap key resource, IO ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (UTCTime -> PoolMap key resource -> (PoolMap key resource, IO ())
go UTCTime
now) (TVar (PoolMap key resource) -> STM (PoolMap key resource)
forall a. TVar a -> STM a
readTVar (KeyedPool key resource -> TVar (PoolMap key resource)
forall key resource.
KeyedPool key resource -> TVar (PoolMap key resource)
kpVar KeyedPool key resource
kp))
TVar (PoolMap key resource) -> PoolMap key resource -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar (KeyedPool key resource -> TVar (PoolMap key resource)
forall key resource.
KeyedPool key resource -> TVar (PoolMap key resource)
kpVar KeyedPool key resource
kp) (PoolMap key resource -> STM ()) -> PoolMap key resource -> STM ()
forall a b. (a -> b) -> a -> b
$! PoolMap key resource
m
IO () -> STM (IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return IO ()
action
where
go :: UTCTime -> PoolMap key resource -> (PoolMap key resource, IO ())
go UTCTime
_ PoolMap key resource
PoolClosed = (PoolMap key resource
forall key resource. PoolMap key resource
PoolClosed, KeyedPool key resource -> resource -> IO ()
forall key resource. KeyedPool key resource -> resource -> IO ()
kpDestroy KeyedPool key resource
kp resource
resource)
go UTCTime
now pc :: PoolMap key resource
pc@(PoolOpen Int
idleCount Map key (PoolList resource)
m)
| Int
idleCount Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= KeyedPool key resource -> Int
forall key resource. KeyedPool key resource -> Int
kpMaxTotal KeyedPool key resource
kp = (PoolMap key resource
pc, KeyedPool key resource -> resource -> IO ()
forall key resource. KeyedPool key resource -> resource -> IO ()
kpDestroy KeyedPool key resource
kp resource
resource)
| Bool
otherwise = case key -> Map key (PoolList resource) -> Maybe (PoolList resource)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup key
key Map key (PoolList resource)
m of
Maybe (PoolList resource)
Nothing ->
let cnt' :: Int
cnt' = Int
idleCount Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
m' :: PoolMap key resource
m' = Int -> Map key (PoolList resource) -> PoolMap key resource
forall key resource.
Int -> Map key (PoolList resource) -> PoolMap key resource
PoolOpen Int
cnt' (key
-> PoolList resource
-> Map key (PoolList resource)
-> Map key (PoolList resource)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert key
key (resource -> UTCTime -> PoolList resource
forall a. a -> UTCTime -> PoolList a
One resource
resource UTCTime
now) Map key (PoolList resource)
m)
in (PoolMap key resource
m', () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())
Just PoolList resource
l ->
let (PoolList resource
l', Maybe resource
mx) = UTCTime
-> Int
-> resource
-> PoolList resource
-> (PoolList resource, Maybe resource)
forall a.
UTCTime -> Int -> a -> PoolList a -> (PoolList a, Maybe a)
addToList UTCTime
now (KeyedPool key resource -> Int
forall key resource. KeyedPool key resource -> Int
kpMaxPerKey KeyedPool key resource
kp) resource
resource PoolList resource
l
cnt' :: Int
cnt' = Int
idleCount Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int -> (resource -> Int) -> Maybe resource -> Int
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Int
1 (Int -> resource -> Int
forall a b. a -> b -> a
const Int
0) Maybe resource
mx
m' :: PoolMap key resource
m' = Int -> Map key (PoolList resource) -> PoolMap key resource
forall key resource.
Int -> Map key (PoolList resource) -> PoolMap key resource
PoolOpen Int
cnt' (key
-> PoolList resource
-> Map key (PoolList resource)
-> Map key (PoolList resource)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert key
key PoolList resource
l' Map key (PoolList resource)
m)
in (PoolMap key resource
m', IO () -> (resource -> IO ()) -> Maybe resource -> IO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) (KeyedPool key resource -> resource -> IO ()
forall key resource. KeyedPool key resource -> resource -> IO ()
kpDestroy KeyedPool key resource
kp) Maybe resource
mx)
addToList :: UTCTime -> Int -> a -> PoolList a -> (PoolList a, Maybe a)
addToList :: UTCTime -> Int -> a -> PoolList a -> (PoolList a, Maybe a)
addToList UTCTime
_ Int
i a
x PoolList a
l | Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
1 = (PoolList a
l, a -> Maybe a
forall a. a -> Maybe a
Just a
x)
addToList UTCTime
now Int
_ a
x l :: PoolList a
l@One{} = (a -> Int -> UTCTime -> PoolList a -> PoolList a
forall a. a -> Int -> UTCTime -> PoolList a -> PoolList a
Cons a
x Int
2 UTCTime
now PoolList a
l, Maybe a
forall a. Maybe a
Nothing)
addToList UTCTime
now Int
maxCount a
x l :: PoolList a
l@(Cons a
_ Int
currCount UTCTime
_ PoolList a
_)
| Int
maxCount Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
currCount = (a -> Int -> UTCTime -> PoolList a -> PoolList a
forall a. a -> Int -> UTCTime -> PoolList a -> PoolList a
Cons a
x (Int
currCount Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) UTCTime
now PoolList a
l, Maybe a
forall a. Maybe a
Nothing)
| Bool
otherwise = (PoolList a
l, a -> Maybe a
forall a. a -> Maybe a
Just a
x)
data Managed resource = Managed
{ Managed resource -> resource
_managedResource :: !resource
, Managed resource -> Bool
_managedReused :: !Bool
, Managed resource -> Reuse -> IO ()
_managedRelease :: !(Reuse -> IO ())
, Managed resource -> IORef ()
_managedAlive :: !(IORef ())
}
managedResource :: Managed resource -> resource
managedResource :: Managed resource -> resource
managedResource = Managed resource -> resource
forall resource. Managed resource -> resource
_managedResource
managedReused :: Managed resource -> Bool
managedReused :: Managed resource -> Bool
managedReused = Managed resource -> Bool
forall resource. Managed resource -> Bool
_managedReused
managedRelease :: Managed resource -> Reuse -> IO ()
managedRelease :: Managed resource -> Reuse -> IO ()
managedRelease = Managed resource -> Reuse -> IO ()
forall resource. Managed resource -> Reuse -> IO ()
_managedRelease
data Reuse = Reuse | DontReuse
dummyManaged :: resource -> Managed resource
dummyManaged :: resource -> Managed resource
dummyManaged resource
resource = Managed :: forall resource.
resource
-> Bool -> (Reuse -> IO ()) -> IORef () -> Managed resource
Managed
{ _managedResource :: resource
_managedResource = resource
resource
, _managedReused :: Bool
_managedReused = Bool
False
, _managedRelease :: Reuse -> IO ()
_managedRelease = IO () -> Reuse -> IO ()
forall a b. a -> b -> a
const (() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())
, _managedAlive :: IORef ()
_managedAlive = IO (IORef ()) -> IORef ()
forall a. IO a -> a
unsafePerformIO (() -> IO (IORef ())
forall a. a -> IO (IORef a)
newIORef ())
}
ignoreExceptions :: IO () -> IO ()
ignoreExceptions :: IO () -> IO ()
ignoreExceptions IO ()
f = IO ()
f IO () -> (SomeException -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` \(SomeException
_ :: SomeException) -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
keepAlive :: Managed resource -> IO ()
keepAlive :: Managed resource -> IO ()
keepAlive = IORef () -> IO ()
forall a. IORef a -> IO a
readIORef (IORef () -> IO ())
-> (Managed resource -> IORef ()) -> Managed resource -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Managed resource -> IORef ()
forall resource. Managed resource -> IORef ()
_managedAlive