time-manager 0.3.2 → 0.4.0
raw patch · 5 files changed
+492/−93 lines, 5 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
Files
- ChangeLog.md +20/−0
- System/TimeManager.hs +293/−36
- System/TimeManager/Internal.hs +69/−7
- test/Spec.hs +109/−49
- time-manager.cabal +1/−1
ChangeLog.md view
@@ -1,5 +1,22 @@ # ChangeLog for time-manager +## 0.4.0++* CHANGES IN BEHAVIOUR:+ * `tickle` is rate-limited/debounced. The renewal is skipped unless a quarter+ of the timeout (capped at one second) has passed since the timeout was last+ registered or updated. This does mean a timeout _might_ run a bit earlier+ than the last `tickle` would indicate, but never more than the maximum+ debounce period.+ * `cancel` completely stops the timeout, making it un`resume`able.+ `resume` will only resume a timeout that has been `pause`d.+ * Prior to this major version, the `Handle` could be reused to run more+ timeout actions. Now, a timeout action will only ever run, at most, once.+ After a timeout action has run, the `Handle` is turned off and won't be+ `resume`able, necessitating a call to `register` to start a new timeout.++ [#1109](https://github.com/yesodweb/wai/pull/1109)+ ## 0.3.2 * Add `stopAfterWithResult`. [#1069](https://github.com/yesodweb/wai/pull/1069)@@ -36,6 +53,9 @@ * `pause` is now identical to `cancel`. * `resume` is now re-registration of timeout. * The signature of `withHandle` is changed.++This change also means that using this package only works with the threaded runtime.+The moment a timeout is registered on a non-threaded runtime, an exception will be thrown. ## 0.2.4
System/TimeManager.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE RecordWildCards #-} -- | Timeout manager. Since @v0.3.0@, timeout manager is a wrapper of@@ -12,7 +13,7 @@ -- * Using 32-bit systems means the max timeout is @'maxBound' :: Int@ -- (2147483647) microseconds, which is less than 36 minutes. -- * Using the same 'Handle' in different threads might cause issues in some--- edge cases. (i.e. using cancel/pause in one thread, and resume in another)+-- edge cases. (i.e. using 'cancel'/'pause' in one thread, and 'resume' in another) module System.TimeManager ( -- ** Types Manager,@@ -36,20 +37,24 @@ tickle, pause, resume,+ cancel, -- ** Low level register, registerKillThread,- cancel, -- ** Exceptions TimeoutThread (..), ) where -import Control.Concurrent (forkIO, mkWeakThreadId, myThreadId)+import Control.Concurrent (forkIO, mkWeakThreadId, myThreadId, newMVar) import qualified Control.Exception as E-import Control.Monad (void)+import Control.Monad (void, when)+import Data.Bits (shiftR) import qualified Data.IORef as I+import Data.Word (Word64)+import GHC.Clock (getMonotonicTimeNSec)+import System.IO.Unsafe (unsafePerformIO) import System.Mem.Weak (deRefWeak) import System.TimeManager.Internal @@ -73,16 +78,32 @@ Handle { handleTimeout = 0 , handleAction = pure ()- , handleKeyRef = error "time-manager: Handle.handleKeyRef not set"- , handleState = error "time-manager: Handle.handleState not set"+ , handleTimerManager = mutError "handleTimerManager"+ , handleState = mutError "handleState"+ , handleLastRenewed = mutError "handleLastRenewed"+ , handleMinRenewGap = 0+ , handleLock = emptyLock }+ where+ mutError s = error $ "time-manager: Handle." <> s <> " not set" +emptyLock :: Lock+emptyLock = unsafePerformIO $ newMVar ()+{-# NOINLINE emptyLock #-}+ ---------------------------------------------------------------- -- | Creating timeout manager with a timeout value in microseconds. ----- Setting the timeout to zero or lower (<= 0) will produce a+-- Setting the timeout to zero or lower @(<= 0)@ will produce a -- `defaultManager`.+--+-- __WARNING for Windows users:__ /the precision of extending timeouts/+-- /is only full "seconds". The provided microseconds will be floored/+-- /to the first full second. (i.e. @initialize 2_500_000@ will get/+-- /extended by 2 seconds on a 'tickle')/+-- /This also means timeouts of less than one second will not be extended/+-- /when using 'tickle'./ initialize :: Int -> IO Manager initialize = pure . Manager . max 0 @@ -121,64 +142,300 @@ ---------------------------------------------------------------- +-- ============== NOTE ABOUT THREAD SAFETY ==============+--+-- The use of 'IORef's are fine in the current situation where+-- the 'TimeManager' is supposed to be used in a single thread.+--+-- The triggered action, though, is run by the Timer Manager+-- outside of the thread it was registered in.+-- This will potentially cause race conditions if we implement+-- anything that depends on the 'Handle's state.+--+-- Given the following:+-- - If run in one thread: 'register/tickle/pause/resume/cancel' never+-- overlap, making them devoid of race conditions in the general sense.+-- - We want to hit the Timer Manager as little as possible.+-- - We want to keep the 'resume/pause' surface functionality intact, while+-- not hitting the Timer Manager when we don't have to. This means not+-- cancelling the timeout on a pause, but rather mark the timeout paused.+-- - Not actually stopping the timeout on 'pause' introduces race+-- conditions, because the registered action will need to check the 'Handle'+-- state to see whether it should actually run (Active) or if it should+-- drop the action (Paused/Stopped).+-- - Not hitting the Timer Manager on a 'pause' will increase performance on+-- hot 'resume/pause' loops, like 'warp' has when using a streaming response.+-- - 'tickle' gets a sort of debounce to avoid repeated updates in hot loops.+-- - The debounce is 1/4 of the timeout, but we cap it to a maximum of 1 second.+-- - This means the registered action might run earlier than the timeout+-- would indicate; that difference going up to a maximum of 'handleMinRenewGap'.+-- - The following can happen:+-- - == The "Surprise Active" issue ==+-- A 'resume' might get called right after a 'Paused' registered action+-- starts running, and sets the state to 'Active' __before__ the action+-- inspects the 'Handle' state.+-- - == The "Dropped Active" issue ==+-- A 'resume' might get called right after a 'Paused' registered action+-- starts running, but inspects the state __before__ the action sets the+-- state to 'Stopped', and the registered action inspects the state+-- __before__ the 'resume' has set it to 'Active'. Essentially missing+-- the 'resume' completely.+-- - == The "Dropped Cancel" issue ==+-- A 'cancel' getting called right after a 'Paused' registered action+-- starts running, and cancelling __after__ the action reads the state+-- will have the registered action overwrite the state to 'Stopped',+-- when it shouldn't register a new action, but stop everything.+-- - A 'pause' should technically not be an issue, as it will only run when+-- the state is 'Active', but it is a function that changes the state, so+-- just to be cautious, we let it grab the lock.+-- - A 'tickle' in the same situation doesn't matter, as a 'tickle'+-- shouldn't activate a 'Paused' state. (and doesn't change any state)+-- - The "Surprise Active" issue can be mitigated by checking the+-- 'handleLastRenewed' time and reregistering the timeout action with the+-- remaining amount of microseconds in the case where it has not yet been+-- 'handleTimeout' amount of time.+-- - A 'tickle' could also cause this if the state was 'Active' all along,+-- but we'll accept the 'tickle' as being on time to extend the timeout.+-- - The "Dropped Active" issue is a bit more difficult to mitigate. We'll+-- need a lock to guarantee that either the activation of 'resume' is seen+-- by the registered action, or that the termination of the registered+-- action is seen by the 'resume'.+-- - The "Dropped Cancel" issue will also be avoided when using a lock.+-- - The lock will generally never be contested. It is there only for the+-- off-chance that a state-changing function runs JUST after the registered+-- action triggers. So in general, we don't expect the lock to reduce+-- performance noticeably.++----------------------------------------------------------------+ -- | Registering a timeout action. register :: Manager -> TimeoutAction -> IO Handle register mgr@(Manager timeout) onTimeout | isNoManager mgr = pure emptyHandle | otherwise = do+ -- The system timer manager is stable for the lifetime of the+ -- process (and even if it were replaced, e.g. around a fork,+ -- the key registered below would only be meaningful to the+ -- manager it was registered with). So fetch it once here and+ -- cache it in the 'Handle' instead of re-reading the global+ -- IORef on every tickle/pause/resume. sysmgr <- getTimerManager- key <- EV.registerTimeout sysmgr timeout onTimeout- keyref <- I.newIORef key- state <- I.newIORef Active+ stateRef <- I.newIORef Stopped+ lock <- newLock+ lastRenewedRef <- I.newIORef =<< getMonotonicTimeNSec let h = Handle { handleTimeout = timeout , handleAction = onTimeout- , handleKeyRef = keyref- , handleState = state+ , handleTimerManager = sysmgr+ , handleState = stateRef+ , handleLastRenewed = lastRenewedRef+ , handleMinRenewGap = minRenewGap timeout+ , handleLock = lock }+ -- Just in case the timeout is only 1 microsecond and because of thread+ -- scheduling it runs before we can change the state to 'Active'+ withLock lock $ do+ key <- registerAdjustedTimeout h timeout+ now <- getMonotonicTimeNSec+ I.writeIORef lastRenewedRef now+ I.writeIORef stateRef $ Active key pure h +-- | This function needs a separate 'timeout' argument, because we might not+-- register the full amount of time when continuing a timeout that was started+-- a bit earlier. (cf. "Surprise Active" situation)+registerAdjustedTimeout :: Handle -> Int -> IO EV.TimeoutKey+registerAdjustedTimeout h@Handle{..} timeout = do+ originalKeyRef <-+ I.newIORef $+ error "System.TimeManager.registerAdjustedTimeout: originalKeyRef not filled"+ key <-+ EV.registerTimeout handleTimerManager timeout $+ adjustOnTimeout originalKeyRef h+ I.writeIORef originalKeyRef key+ pure key++-- | Wrapper around a registered action to ensure correct handling.+--+-- We basically need the 'Handle', but this is used before making the handle, so+adjustOnTimeout :: I.IORef EV.TimeoutKey -> Handle -> TimeoutAction+adjustOnTimeout originalKeyRef h@Handle{..} = do+ let writeState = I.atomicWriteIORef handleState+ -- Lock ensures we don't get race conditions.+ -- We return a boolean so that we don't run the (potentially long) action+ -- while holding on to the lock.+ shouldRun <- withLock handleLock $ do+ st <- I.readIORef handleState+ case st of+ -- We can check the @now - handleLastRenewed@ diff+ -- and 'threadDelay' the diff to make the timing better?+ -- @if diff > 'handleTimeout - 'handleMinRenewGap' then runTimeout@+ Active key -> do+ -- set state ref to 'Active'?+ ifSameKey key $ do+ lastRenewed <- I.readIORef handleLastRenewed+ now <- getMonotonicTimeNSec+ let diff = fromIntegral $ now - lastRenewed+ if diff > handleTimeout+ -- Valid expiration of the timeout, we run the action+ then do+ -- We're going to run the action, so set the state+ -- so that it won't be resumed.+ writeState Terminated+ pure True+ -- "Surprise Active" situation+ else do+ -- We reschedule, but with only the remaining time+ let remainingTimeout = handleTimeout - diff+ k <- registerAdjustedTimeout h remainingTimeout+ writeState $ Active k+ pure False+ -- We find this action being run after it's been paused. We write+ -- the state to 'Stopped' so that 'resume' knows to reregister the+ -- timeout action.+ Paused key ->+ ifSameKey key $ do+ writeState Stopped+ pure False+ -- 'Stopped' and 'Terminated' mean the action shouldn't run.+ _ -> pure False+ when shouldRun handleAction+ where+ -- If the key in the state isn't the same as the one this action+ -- was registered with, then this action shouldn't run.+ -- (Technically, this situation shouldn't happen. but since the registered+ -- action only ever runs once, we can afford to be redundant)+ ifSameKey key f = do+ originalKey <- I.readIORef originalKeyRef+ if key == originalKey+ then f+ else pure False++-- | How long 'tickle' waits before actually renewing the timeout:+-- a quarter of the timeout, capped at one second. Skipping a renewal+-- inside this window only shortens the effective timeout by up to+-- this gap, but turns hot 'tickle' loops (one per chunk sent or+-- received) into a clock read and a comparison.+minRenewGap :: Int -> Word64+minRenewGap timeout =+ -- @shiftR 2 === divide by 4@+ min maxRenewDebounce (microToNano timeout `shiftR` 2)+ where+ microToNano = (* 1_000) . fromIntegral++-- | One second in nanoseconds+maxRenewDebounce :: Word64+maxRenewDebounce = 1_000_000_000++-- | Run 'f' if the minimum renew gap has been crossed.+whenRenew :: Handle -> IO () -> IO ()+whenRenew h f = do+ now <- getMonotonicTimeNSec+ lastRenewed <- I.readIORef $ handleLastRenewed h+ when (now - lastRenewed >= handleMinRenewGap h) f+ -- | Unregistering the timeout.+--+-- The timeout can not be 'resume'd. To "resume" the timeout, you need to+-- 'register' again. cancel :: Handle -> IO ()-cancel h@Handle{..} = withNonEmptyHandle h $ do- mgr <- getTimerManager- key <- I.readIORef handleKeyRef- EV.unregisterTimeout mgr key- I.atomicWriteIORef handleState Stopped+cancel h@Handle{..} =+ withNonEmptyHandle h $+ -- "Dropped Cancel" remedy+ --+ -- We can eat a potential mutex pause here to avoid race conditions,+ -- because we don't expect 'cancel' to be called in hot loops.+ --+ -- (The race condition being: the 'Terminated' state being overwritten+ -- because the 'cancel' runs JUST after the registered action starts+ -- running, sets the state to 'Terminated', and then the registered+ -- action finishes and overwrites it to 'Stopped')+ withLock handleLock $ do+ withTimeoutKey h $ EV.unregisterTimeout handleTimerManager+ I.atomicWriteIORef handleState Terminated -- | Extending the timeout. ----- Careful: this does NOT reactivate an already paused 'Handle'!+-- To keep frequent callers cheap, the renewal is rate-limited: it is+-- skipped unless at least a quarter of the timeout (capped at one+-- second) has passed since the timeout was last registered or updated.+--+-- Careful: this does NOT reactivate an already 'pause'd 'Handle'!+--+-- __WARNING for Windows users:__ /the precision of extending timeouts/+-- /is only full "seconds". The provided microseconds will be floored/+-- /to the first full second. (i.e. @initialize 2_500_000@ will get/+-- /extended by 2 seconds on a 'tickle')/+-- /This also means timeouts of less than one second will not be extended/+-- /when using 'tickle'./ tickle :: Handle -> IO ()-tickle h@Handle{..} = withNonEmptyHandle h $ do- mgr <- getTimerManager- key <- I.readIORef handleKeyRef+tickle h@Handle{..} =+ withNonEmptyHandle h $+ whenRenew h $+ withActiveTimeoutKey h $ \key -> do+ updateTheTimeout key+ now <- getMonotonicTimeNSec+ I.atomicWriteIORef handleLastRenewed now+ where+ -- For some reason the Windows implementation of 'updateTimeout' wants+ -- full seconds, instead of the microseconds that's used when registering...+ updateTheTimeout key =+ EV.updateTimeout handleTimerManager key #if defined(mingw32_HOST_OS)- EV.updateTimeout mgr key $ fromIntegral (handleTimeout `div` 1000000)+ (fromIntegral (handleTimeout `div` 1_000_000)) #else- EV.updateTimeout mgr key handleTimeout+ handleTimeout #endif --- | This is identical to 'cancel'.--- To resume timeout with the same 'Handle', 'resume' MUST be called.--- Don't call 'tickle' for resumption.+-- | Pauses the timeout so you can 'resume' it later. Does not stop it entirely.+-- Use 'cancel' if you want to make sure the action will not be resumed.+--+-- To resume a timeout with the same 'Handle', 'resume' MUST be called.+-- Don't call 'tickle' for resumption. pause :: Handle -> IO ()-pause = cancel+pause h@Handle{..} =+ withNonEmptyHandle h $+ withLock handleLock . withActiveTimeoutKey h $+ I.atomicWriteIORef handleState . Paused -- | Resuming the timeout. -- -- Works like 'tickle' if the 'Handle' wasn't 'pause'd or 'cancel'ed. resume :: Handle -> IO ()-resume h@Handle{..} = withNonEmptyHandle h $ do- state <- I.readIORef handleState- case state of- Active -> tickle h- Stopped -> do- mgr <- getTimerManager- key <- EV.registerTimeout mgr handleTimeout handleAction- I.atomicWriteIORef handleKeyRef key- I.atomicWriteIORef handleState Active+resume h@Handle{..} =+ withNonEmptyHandle h $+ -- we ignore the key when paused, because we recheck the state after+ -- grabbing the lock.+ checkStateWith (\_ -> onPausedOrStopped) onPausedOrStopped+ where+ -- "Dropped Active" remedy+ --+ -- Grabbing the lock ensures 'resume' runs either before or after the+ -- registered action changes the state.+ onPausedOrStopped =+ withLock handleLock $ checkStateWith pausedF stoppedF+ checkStateWith onPaused onStopped = do+ state <- I.readIORef handleState+ case state of+ -- 'tickle' doesn't introduce race conditions, so can always be run.+ Active{} -> tickle h+ -- Abort when terminated.+ Terminated -> pure ()+ Paused k -> onPaused k+ Stopped -> onStopped+ pausedF k = do+ -- Set state to 'Active' before 'tickle'ing, because+ -- 'tickle' only runs when the state is 'Active'.+ activateTimeout k+ tickle h+ stoppedF = do+ key <- registerAdjustedTimeout h handleTimeout+ now <- getMonotonicTimeNSec+ I.atomicWriteIORef handleLastRenewed now+ activateTimeout key+ activateTimeout =+ I.atomicWriteIORef handleState . Active ----------------------------------------------------------------
System/TimeManager/Internal.hs view
@@ -5,7 +5,9 @@ module System.TimeManager.Internal where -import Data.IORef (IORef)+import Control.Concurrent.MVar (MVar, modifyMVar, newMVar)+import Data.IORef (IORef, readIORef)+import Data.Word (Word64) #if defined(mingw32_HOST_OS) import qualified GHC.Event.Windows as EV@@ -31,14 +33,70 @@ data Handle = Handle { handleTimeout :: Int , handleAction :: TimeoutAction- , handleKeyRef :: ~(IORef EV.TimeoutKey)+ , handleTimerManager :: ~TimerManager+ -- ^ The system timer manager the timeout key was registered with.+ -- Cached so that per-request operations don't re-fetch it.+ , handleLock :: Lock+ -- ^ Used by 'resume', 'pause' and 'cancel' to determine race conditions.+ --+ -- /We intentionally do not use an @MVar HandleState@ for performance reasons./+ -- /The lock only has to be grabbed to avoid race conditions./ , handleState :: ~(IORef HandleState)+ -- ^ The current state. Used to decide whether a timeout is still going,+ -- paused, or completely terminated.+ --+ -- /We intentionally do not use an @MVar HandleState@ for performance reasons./+ , handleLastRenewed :: ~(IORef Word64)+ -- ^ Monotonic time (in nanoseconds) when the timeout was last+ -- registered or updated.+ , handleMinRenewGap :: Word64+ -- ^ 'tickle' is a no-op unless at least this many nanoseconds have+ -- passed since the last renewal. } --- | Tracking the state of a handle, to be able to have 'resume'--- act like a 'register' or 'tickle'.-data HandleState = Active | Stopped+-- | Makes sure the function is only run when there's a key to act on.+withTimeoutKey :: Handle -> (EV.TimeoutKey -> IO ()) -> IO ()+withTimeoutKey h keyF = do+ st <- readIORef $ handleState h+ case st of+ Paused key -> keyF key+ Active key -> keyF key+ _ -> pure () +-- | Makes sure the function is only run when the state is 'Active'.+withActiveTimeoutKey :: Handle -> (EV.TimeoutKey -> IO ()) -> IO ()+withActiveTimeoutKey h keyF = do+ st <- readIORef $ handleState h+ case st of+ Active key -> keyF key+ _ -> pure ()++-- | Used to avoid race conditions in situations when the state has to be changed.+type Lock = MVar ()++newLock :: IO Lock+newLock = newMVar ()++withLock :: Lock -> IO a -> IO a+withLock lock action =+ -- Not sure whether this should be 'modifyMVarMasked' or not.+ modifyMVar lock $ \l -> do+ a <- action+ pure (l, a)++-- | Tracking the state of a handle.+data HandleState+ = -- Timeout is primed to run+ Active EV.TimeoutKey+ | -- Timeout is paused, but still running+ -- ('resume' will set it back to 'Active' and 'tickle')+ Paused EV.TimeoutKey+ | -- Action ran, but timeout was paused, so it is resumable+ -- ('resume' will reregister the action)+ Stopped+ | -- Action was cancelled or run. 'register' is needed to start a new timeout.+ Terminated+ isEmptyHandle :: Handle -> Bool isEmptyHandle Handle{..} = handleTimeout == 0 @@ -47,9 +105,13 @@ if isEmptyHandle h then pure () else act #if defined(mingw32_HOST_OS)-getTimerManager :: IO EV.Manager+type TimerManager = EV.Manager++getTimerManager :: IO TimerManager getTimerManager = EV.getSystemManager #else-getTimerManager :: IO EV.TimerManager+type TimerManager = EV.TimerManager++getTimerManager :: IO TimerManager getTimerManager = EV.getSystemTimerManager #endif
test/Spec.hs view
@@ -6,23 +6,38 @@ module Main where -import Control.Concurrent (threadDelay)-import Control.Monad (forM_, void)-import Data.IORef as I (IORef, newIORef, readIORef, writeIORef)-import System.TimeManager-import System.TimeManager.Internal-import Test.HUnit (assertBool) import Test.Hspec #if defined(mingw32_HOST_OS)-import qualified GHC.Event.Windows as EV+-- -- Uncomment when reenabling the tests for Windows+-- import qualified GHC.Event.Windows as EV #else import qualified GHC.Event as EV #endif +#if defined(mingw32_HOST_OS) main :: IO () main = hspec $ do describe "TimeManager" $ do+ it "tests don't work on windows" $+ pendingWith "requires more testing on a Windows machine"+#else+import Control.Concurrent (threadDelay)+import Control.Monad (forM_, void)+import Data.IORef as I (+ IORef,+ atomicModifyIORef',+ newIORef,+ readIORef,+ writeIORef,+ )+import System.TimeManager+import System.TimeManager.Internal+import Test.HUnit (assertBool)++main :: IO ()+main = hspec $ do+ describe "TimeManager" $ do it "defaultManager == no manager" $ defaultManager `shouldSatisfy` isNoManager @@ -44,22 +59,22 @@ it "throws TimeoutThread exception" $ throwsTimeoutThread $ do- mngr <- initialize 1+ mngr <- initialize timeoutAmount _hndl <- registerKillThread mngr $ pure ()- threadDelay 100+ waitLong it "defaultManager doesn't kill thread" $ do _hndl <- registerKillThread defaultManager $ pure ()- threadDelay 2000+ waitShort it "withHandle: registers timeout" $ withHandleTest mgr1 $ \check _ -> do- threadDelay 2000+ waitShort check True it "withHandle: doesn't register timeout" $ withHandleTest defaultManager $ \check _ -> do- threadDelay 2000+ waitShort check False -- We make a ref on the outside, to check that the ref is indeed@@ -67,59 +82,90 @@ it "withHandleKillThread: registers timeout (and kills)" $ do ref <- freshRef withHandleKillTest (Just ref) mgr1 $ \_ _ ->- throwsTimeoutThread $ threadDelay 100+ throwsTimeoutThread waitShort ref `refShouldBe` True it "withHandleKillThread: doesn't register timeout" $ withHandleKillTest Nothing defaultManager $ \check _ -> do- threadDelay 200- check False+ waitShort >> check False it "cancel/pause works as expected" $ do- m <- initialize 100- let runIt f = do+ m <- mkTestManager+ let killUnless f = do hndl <- registerKillThread m (pure ()) _ <- f hndl- threadDelay 1000- throwsTimeoutThread $ runIt pure- runIt cancel- runIt pause+ waitLong+ throwsTimeoutThread $ killUnless pure+ killUnless cancel+ killUnless pause it "tickle works as expected" $ do- m <- initialize 10_000+ m <- mkTestManager withHandleTest m $ \check hndl -> do forM_ [(1 :: Int) .. 20] $ \_ -> do- threadDelay 1000+ waitShort tickle hndl check False - let runIt f = do- m <- initialize 10_000- void $ f =<< registerKillThread m (pure ())- it "resume works as expected" $ do- let runAndWaitForTimeout f =- runIt $ \hndl -> do- void $ f hndl- threadDelay 20_000+ let runAndWaitForTimeout f =+ runIt $ \hndl -> do+ void $ f hndl+ waitLong+ it "resume works as expected (nothing)" $ do -- Doing nothing kills the thread throwsTimeoutThread . runAndWaitForTimeout $ \_ -> pure ()+ it "resume works as expected (pause)" $ do -- Pausing stops the kill runAndWaitForTimeout $ \hndl -> do- threadDelay 2500- pause hndl+ waitShort >> pause hndl+ it "resume works as expected (pause/resume)" $ do -- Resuming kills the thread again throwsTimeoutThread . runAndWaitForTimeout $ \hndl -> do- threadDelay 2500- pause hndl- threadDelay 20_000- resume hndl+ waitShort >> pause hndl+ waitLong >> resume hndl+ it "resume works as expected (cancel/resume)" $ do+ -- Cancelling is unresumable+ runAndWaitForTimeout $ \hndl -> do+ waitShort >> cancel hndl+ waitLong >> resume hndl+ it "resume works as expected (cancel/pause/resume)" $ do+ -- Cancelling and then pausing is still unresumable+ runAndWaitForTimeout $ \hndl -> do+ waitShort >> cancel hndl+ waitShort >> pause hndl+ waitLong >> resume hndl+ -- Pausing, then cancelling doesn't change anything+ runAndWaitForTimeout $ \hndl -> do+ waitShort >> pause hndl+ waitShort >> cancel hndl+ waitLong >> resume hndl+ it "finished timeout won't resume" $ do+ -- If the timeout action runs, resume shouldn't work+ counter <- I.newIORef (0 :: Int)+ m <- mkTestManager+ let increase = I.atomicModifyIORef' counter $ \i -> (i + 1, ())+ withHandle m increase $ \h -> do+ let checkCount x = do+ i <- I.readIORef counter+ i `shouldBe` x+ timeoutOnlyRanOnce = waitLong >> checkCount 1 - -- "resuming" every 2.5ms 20 times- let testResume f = do- runIt $ \hndl -> do- forM_ [(1 :: Int) .. 20] $ \_ -> do- threadDelay 2500- f hndl+ checkCount 0+ -- waiting lets the timeout+ timeoutOnlyRanOnce+ -- resuming should not influence the counter+ resume h+ timeoutOnlyRanOnce+ -- pausing after it runs also doesn't re-arm the timeout+ pause h+ resume h+ timeoutOnlyRanOnce+ -- cancel also doesn't re-arm the timeout+ cancel h+ pause h+ resume h+ timeoutOnlyRanOnce+ it "resume also works as tickle" $ testResume resume @@ -138,17 +184,31 @@ -- Test that starts with a 'False' IORef and on timeout sets it to true withTest withF mRef m f = do ref <- maybe freshRef pure mRef- withF m (writeIORef ref True) . f $ refShouldBe ref+ withF m (I.writeIORef ref True) . f $ refShouldBe ref+ -- run with a 20ms timeout and kill+ runIt f = do+ m <- mkTestManager+ void $ f =<< registerKillThread m (pure ())+ timeoutAmount = 20_000+ mkTestManager = initialize timeoutAmount+ -- Waiting a lot less than the timeout takes+ waitShort = threadDelay $ timeoutAmount `div` 5+ -- Waiting a lot longer than the timeout takes+ waitLong = threadDelay $ timeoutAmount * 5+ -- "resuming" every 2.5ms 20 times+ testResume f = do+ runIt $ \hndl -> do+ forM_ [(1 :: Int) .. 20] $ \_ -> waitShort >> f hndl mgr1 :: Manager mgr1 = Manager 1 freshRef :: IO (IORef Bool)-freshRef = newIORef False+freshRef = I.newIORef False refShouldBe :: IORef Bool -> Bool -> IO () refShouldBe ref expected =- readIORef ref >>= (`shouldBe` expected)+ I.readIORef ref >>= (`shouldBe` expected) throwsTimeoutThread :: IO () -> Expectation throwsTimeoutThread t = t `shouldThrow` (const True :: TimeoutThread -> Bool)@@ -160,6 +220,6 @@ oldResume :: Handle -> IO () oldResume h | isEmptyHandle h = return () oldResume Handle{..} = do- mgr <- getTimerManager- key <- EV.registerTimeout mgr handleTimeout handleAction- I.writeIORef handleKeyRef key+ key <- EV.registerTimeout handleTimerManager handleTimeout handleAction+ I.writeIORef handleState $ Active key+#endif
time-manager.cabal view
@@ -1,6 +1,6 @@ cabal-version: >=1.10 name: time-manager-version: 0.3.2+version: 0.4.0 license: MIT license-file: LICENSE maintainer: kazu@iij.ad.jp