module Control.Concurrent.STM.Timer (
Timer,
newTimer,
newTimerRange,
startTimer,
resetTimer,
waitTimer,
) where
import Protolude
import Control.Concurrent.Async
import Control.Concurrent.STM
import System.Random (StdGen, randomR, mkStdGen)
import Numeric.Natural
data Timer = Timer
{ timerAsync :: TMVar (Async ())
, timerLock :: TMVar ()
, timerGen :: TVar StdGen
, timerRange :: (Natural, Natural)
}
newTimer :: Natural -> IO Timer
newTimer timeout = newTimerRange 0 (timeout, timeout)
newTimerRange :: Int -> (Natural, Natural) -> IO Timer
newTimerRange seed timeoutRange = do
(timerAsync, timerLock, timerGen) <-
atomically $ (,,) <$> newEmptyTMVar <*> newTMVar () <*> newTVar (mkStdGen seed)
pure $ Timer timerAsync timerLock timerGen timeoutRange
startTimer :: Timer -> IO Bool
startTimer timer = do
mlock <- liftIO . atomically $ tryTakeTMVar (timerLock timer)
case mlock of
Nothing -> pure False
Just () -> resetTimer timer >> pure True
resetTimer :: Timer -> IO ()
resetTimer timer = do
mta <- atomically $ tryTakeTMVar (timerAsync timer)
case mta of
Nothing -> pure ()
Just ta -> void $ async (uninterruptibleCancel ta)
ta <- async $ do
threadDelay =<< randomDelay timer
success <- atomically $ tryPutTMVar (timerLock timer) ()
when (not success) $
panic "[Failed Invariant]: Putting the timer lock back should succeed"
success <- atomically $ tryPutTMVar (timerAsync timer) ta
when (not success) $
void $ async (uninterruptibleCancel ta)
waitTimer :: Timer -> IO ()
waitTimer timer = atomically $ readTMVar (timerLock timer)
randomDelay :: Timer -> IO Int
randomDelay timer = atomically $ do
g <- readTVar (timerGen timer)
let (tmin, tmax) = timerRange timer
(n, g') = randomR (toInteger tmin, toInteger tmax) g
writeTVar (timerGen timer) g'
pure (fromIntegral n)