diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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 diff --git a/System/TimeManager.hs b/System/TimeManager.hs --- a/System/TimeManager.hs +++ b/System/TimeManager.hs @@ -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 ---------------------------------------------------------------- diff --git a/System/TimeManager/Internal.hs b/System/TimeManager/Internal.hs --- a/System/TimeManager/Internal.hs +++ b/System/TimeManager/Internal.hs @@ -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 diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -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 diff --git a/time-manager.cabal b/time-manager.cabal --- a/time-manager.cabal +++ b/time-manager.cabal @@ -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