{-# LANGUAGE BangPatterns #-}
module Network.DNS.Cache.Sync (
ConcVar
, newConcVar
, wait
, waitIncrease
, decrease
, ActiveVar
, newActiveVar
, tell
, listen
, ActiveRef
, newActiveRef
, lookupActiveRef
, insertActiveRef
, deleteActiveRef
) where
import Control.Applicative ((<$>))
import Control.Concurrent.STM
import Data.Map (Map)
import qualified Data.Map as Map
import Network.DNS.Cache.Types
import Data.IORef (newIORef, readIORef, atomicModifyIORef', IORef)
newtype ConcVar = ConcVar (TVar Int)
newConcVar :: IO ConcVar
newConcVar = ConcVar <$> newTVarIO 0
wait :: ConcVar -> (Int -> Bool) -> IO ()
wait (ConcVar var) cond = atomically $ do
x <- readTVar var
check (cond x)
waitIncrease :: ConcVar -> Int -> IO ()
waitIncrease (ConcVar var) lim = atomically $ do
x <- readTVar var
check (x < lim)
let !x' = x + 1
writeTVar var x'
decrease :: ConcVar -> IO ()
decrease (ConcVar var) = atomically $ modifyTVar' var (subtract 1)
newtype ActiveVar = ActiveVar (TMVar (Either DNSError Result))
newActiveVar :: IO ActiveVar
newActiveVar = ActiveVar <$> newEmptyTMVarIO
tell :: ActiveVar -> Either DNSError Result -> IO ()
tell (ActiveVar var) r = atomically $ putTMVar var r
listen :: ActiveVar -> IO (Either DNSError Result)
listen (ActiveVar var) = atomically $ readTMVar var
newtype ActiveRef = ActiveRef (IORef (Map Key ActiveVar))
newActiveRef :: IO ActiveRef
newActiveRef = ActiveRef <$> newIORef Map.empty
lookupActiveRef :: Key -> ActiveRef -> IO (Maybe ActiveVar)
lookupActiveRef key (ActiveRef ref) = Map.lookup key <$> readIORef ref
insertActiveRef :: Key -> ActiveVar -> ActiveRef -> IO ()
insertActiveRef key avar (ActiveRef ref) =
atomicModifyIORef' ref $ \mp -> (Map.insert key avar mp, ())
deleteActiveRef :: Key -> ActiveRef -> IO ()
deleteActiveRef key (ActiveRef ref) =
atomicModifyIORef' ref $ \mp -> (Map.delete key mp, ())