{-# 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
a t :: UTCTime
t) = [(UTCTime
t, a
a)]
plistToList (Cons a :: a
a _ t :: UTCTime
t plist :: 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 [(t :: UTCTime
t, a :: 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 xs :: [(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 "plistFromList.go []"
go [(t :: UTCTime
t, a :: a
a)] = (2, a -> UTCTime -> PoolList a
forall a. a -> UTCTime -> PoolList a
One a
a UTCTime
t)
go ((t :: UTCTime
t, a :: a
a):rest :: [(UTCTime, a)]
rest) =
let (i :: Int
i, rest' :: 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
+ 1
in Int
i' Int -> (Int, PoolList a) -> (Int, PoolList a)
forall a b. a -> b -> b
`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 create :: key -> IO resource
create destroy :: resource -> IO ()
destroy maxPerKey :: Int
maxPerKey maxTotal :: Int
maxTotal onReaperException :: 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 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
$ \restore :: 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 $WKeyedPool :: 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 action :: 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` \e :: 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' destroy :: resource -> IO ()
destroy var :: 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 destroy :: resource -> IO ()
destroy var :: TVar (PoolMap key resource)
var =
IO ()
loop
where
loop :: IO ()
loop = do
Int -> IO ()
threadDelay (5 Int -> Int -> Int
forall a. Num a => a -> a -> a
* 1000 Int -> Int -> Int
forall a. Num a => a -> a -> a
* 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
PoolClosed -> IO () -> STM (IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return (() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())
PoolOpen idleCount :: Int
idleCount m :: 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
(m' :: PoolMap key resource
m', toDestroy :: [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 idleCount :: Int
idleCount m :: 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 time :: UTCTime
time = 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' toKeep :: [(a, PoolList a)] -> [(k, a)]
toKeep toDestroy :: [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' toKeep :: [(a, PoolList a)] -> [(k, a)]
toKeep toDestroy :: [a] -> b
toDestroy ((key :: a
key, plist :: PoolList a
plist):rest :: [(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
(notStale :: [(UTCTime, a)]
notStale, stale :: [(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
Nothing -> [(a, PoolList a)] -> [(k, a)]
toKeep
Just x :: 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 (toKeep :: Map key (PoolList resource)
toKeep, toDestroy :: [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 kp :: KeyedPool key resource
kp key :: 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
(m :: PoolMap key resource
m, mresource :: 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 action :: 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 -> 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
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 $WManaged :: 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 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 idleCount :: Int
idleCount m :: 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
Nothing -> (PoolMap key a
pcOrig, Maybe a
forall a. Maybe a
Nothing)
Just (One a :: a
a _) ->
(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
- 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
a _ _ rest :: 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
- 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 kp :: KeyedPool key resource
kp key :: key
key resource :: 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
(m :: PoolMap key resource
m, action :: 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 _ 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 now :: UTCTime
now pc :: PoolMap key resource
pc@(PoolOpen idleCount :: Int
idleCount m :: 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
Nothing ->
let cnt' :: Int
cnt' = Int
idleCount Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 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 l :: PoolList resource
l ->
let (l' :: PoolList resource
l', mx :: 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 1 (Int -> resource -> Int
forall a b. a -> b -> a
const 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 _ i :: Int
i x :: a
x l :: PoolList a
l | Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= 1 = (PoolList a
l, a -> Maybe a
forall a. a -> Maybe a
Just a
x)
addToList now :: UTCTime
now _ x :: 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 2 UTCTime
now PoolList a
l, Maybe a
forall a. Maybe a
Nothing)
addToList now :: UTCTime
now maxCount :: Int
maxCount x :: a
x l :: PoolList a
l@(Cons _ currCount :: Int
currCount _ _)
| 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
+ 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
resource = $WManaged :: 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 f :: 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