time-manager 0.2.4 → 0.3.2
raw patch · 7 files changed
Files
- ChangeLog.md +37/−0
- README.md +13/−0
- System/ThreadManager.hs +95/−36
- System/TimeManager.hs +113/−155
- System/TimeManager/Internal.hs +55/−0
- test/Spec.hs +165/−0
- time-manager.cabal +47/−25
ChangeLog.md view
@@ -1,5 +1,42 @@ # ChangeLog for time-manager +## 0.3.2++* Add `stopAfterWithResult`. [#1069](https://github.com/yesodweb/wai/pull/1069)++## 0.3.1.1++* Added `README.md` file and improved documentation of modules and functions.+ [#1057](https://github.com/yesodweb/wai/pull/1057)++## 0.3.1++BUGFIXES:++* [#1055](https://github.com/yesodweb/wai/pull/1055)+ * `resume` now acts as a `tickle` if the `Handle` isn't paused.+ This is the same behaviour as before version `0.3.0`.+ * `registerKillThread` now throws the `TimeoutThread` in a separate+ thread, so as to not block the GHC's System TimerManager.+ This does mean that `TimeoutThread` exceptions could technically+ be thrown "out of order", but they will be more prompt.+++## 0.3.0++* [#1048](https://github.com/yesodweb/wai/pull/1048)+ * New architecture. The backend is switched from the designated thread+ to GHC's System TimerManager. From this version, this library is+ just wrapper APIs of GHC's System TimerManager. Unlike v0.2 or+ earlier, callbacks are executed at the exact time. System+ TimerManager uses a PSQ (a tree) while v0.2 or earlier uses a list.+ So, this version hopefully scales better.+ * Deprecated functions: `stopManager`, `killManager` and `withManager'`.+ * `tickle` sets the specified timeout from now.+ * `pause` is now identical to `cancel`.+ * `resume` is now re-registration of timeout.+ * The signature of `withHandle` is changed.+ ## 0.2.4 * Providing `isAllGone`.
+ README.md view
@@ -0,0 +1,13 @@+## time-manager++This package provides module to let you run actions with resettable timeouts+(i.e. `System.TimeManager`) and run actions that will make sure that all+threads forked with the given `ThreadManager` will be killed when the action+finishes.++## WARNINGS++Since version `0.3.0`, **the timeout manager relies on GHC internals**.+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.
System/ThreadManager.hs view
@@ -4,10 +4,22 @@ -- | A thread manager including a time manager. -- The manager has responsibility to kill managed threads.+--+-- Because this is based on the accompanying "System.TimeManager" module,+-- the same caveats apply:+--+-- * Only works for GHC.+-- * Only works with a threaded runtime.+-- * Users of older versions should check the current semantics.+-- * 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) module System.ThreadManager ( ThreadManager, newThreadManager, stopAfter,+ stopAfterWithResult, KilledByThreadManager (..), -- * Fork@@ -36,7 +48,7 @@ import qualified Control.Exception as E import Control.Monad (unless, void) import Data.Foldable (forM_)-import Data.IORef+import Data.IORef (IORef, atomicModifyIORef', newIORef) import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import Data.Word (Word64)@@ -65,10 +77,12 @@ ---------------------------------------------------------------- --- | Starting a thread manager.--- Its action is initially set to 'return ()' and should be set--- by 'setAction'. This allows that the action can include--- the manager itself.+-- | Create a thread manager.+--+-- To create a 'ThreadManager', you will first have to create a+-- 'T.Manager' from the "System.TimeManager" module.+--+-- You can use either 'System.TimeManager.initialize' or 'System.TimeManager.withManager'. newThreadManager :: T.Manager -> IO ThreadManager newThreadManager timmgr = ThreadManager timmgr <$> newTVarIO Map.empty @@ -84,12 +98,34 @@ -- | Stopping the manager. --+-- @+-- stopAfter threadManager action cleanup+-- @+-- -- The action is run in the scope of an exception handler that catches all -- exceptions (including asynchronous ones); this allows the cleanup handler -- to cleanup in all circumstances. If an exception is caught, it is rethrown -- after the cleanup is complete. stopAfter :: ThreadManager -> IO a -> (Maybe SomeException -> IO ()) -> IO a-stopAfter (ThreadManager _timmgr var) action cleanup = do+stopAfter mgr action cleanup =+ stopAfterWithResult mgr action $ \mResult ->+ case mResult of+ Left err -> do+ cleanup (Just err)+ E.throwIO err+ Right result -> do+ cleanup Nothing+ return result++-- | Generalization of 'stopAfter' where the cleanup handler is allowed to construct the final result+--+-- Unlike in 'stopAfter', if an exception is thrown, it is not re-thrown after the cleanup+-- handler completes; the cleanup handler itself can decide to rethrow it or compute a result.+--+-- @since 0.3.2+stopAfterWithResult+ :: ThreadManager -> IO a -> (Either SomeException a -> IO b) -> IO b+stopAfterWithResult (ThreadManager _timmgr var) action cleanup = do E.mask $ \unmask -> do ma <- E.try $ unmask action m <- atomically $ do@@ -100,9 +136,7 @@ er = either Just (const Nothing) ma ex = KilledByThreadManager er forM_ ths $ \(ManagedThread wtid ref) -> lockAndKill wtid ref ex- case ma of- Left err -> cleanup (Just err) >> E.throwIO err- Right a -> cleanup Nothing >> return a+ cleanup ma ---------------------------------------------------------------- @@ -123,42 +157,65 @@ -- | Like 'forkManaged', but run action with exceptions masked forkManagedUnmask- :: ThreadManager -> String -> ((forall x. IO x -> IO x) -> IO ()) -> IO ()+ :: ThreadManager+ -> String+ -- ^ Thread name+ -> ((forall x. IO x -> IO x) -> IO ())+ -- ^ Action with unmask argument+ -> IO () forkManagedUnmask (ThreadManager _timmgr var) label io = void $ E.mask_ $ forkIOWithUnmask $ \unmask -> E.handle ignore $ do labelMe label E.bracket (setup var) (clear var) $ \_ -> io unmask -- | Fork a managed thread with a handle created by a timeout manager.-forkManagedTimeout :: ThreadManager -> String -> (T.Handle -> IO ()) -> IO ()+forkManagedTimeout+ :: ThreadManager+ -> String+ -- ^ Thread name+ -> (T.Handle -> IO ())+ -- ^ Action with timeout handle+ -> IO () forkManagedTimeout (ThreadManager timmgr var) label io =- void $ forkIO $ E.handle ignore $ do+ void $ forkIO $ do labelMe label E.bracket (setup var) (clear var) $ \(_n, wtid, ref) ->- -- 'TimeoutThread' is ignored by 'withHandle'.- void $ T.withHandle timmgr (lockAndKill wtid ref T.TimeoutThread) io+ E.handle ignore $ T.withHandle timmgr (lockAndKill wtid ref ex) io+ where+ ex = KilledByThreadManager Nothing -- | Fork a managed thread with a cleanup function.-forkManagedFinally :: ThreadManager -> String -> IO () -> IO () -> IO ()-forkManagedFinally mgr label io final = E.mask $ \restore ->- forkManaged- mgr- label- (E.try (restore io) >>= \(_ :: Either E.SomeException ()) -> final)+forkManagedFinally+ :: ThreadManager+ -> String+ -- ^ Thread name+ -> IO ()+ -- ^ Action+ -> IO ()+ -- ^ Cleanup function+ -> IO ()+forkManagedFinally mgr label io final =+ forkManagedUnmask mgr label $ \restore ->+ E.try (restore io) >>= \(_ :: Either E.SomeException ()) -> final -- | Fork a managed thread with a handle created by a timeout manager -- and with a cleanup function. forkManagedTimeoutFinally- :: ThreadManager -> String -> (T.Handle -> IO ()) -> IO () -> IO ()+ :: ThreadManager+ -> String+ -- ^ Thread name+ -> (T.Handle -> IO ())+ -- ^ Action with timeout handle+ -> IO ()+ -- ^ Cleanup function+ -> IO () forkManagedTimeoutFinally mgr label io final = E.mask $ \restore ->- forkManagedTimeout- mgr- label- (\th -> E.try (restore $ io th) >>= \(_ :: Either E.SomeException ()) -> final)+ forkManagedTimeout mgr label $ \th ->+ E.try (restore $ io th) >>= \(_ :: Either E.SomeException ()) -> final setup :: TVar (Map Key ManagedThread) -> IO (Key, Weak ThreadId, IORef Bool) setup var = do- (wtid, n) <- myWeakThradId+ (wtid, n) <- myWeakThreadId ref <- newIORef False let ent = ManagedThread wtid ref -- asking to throw KilledByThreadManager to me@@ -183,21 +240,21 @@ ignore :: KilledByThreadManager -> IO () ignore (KilledByThreadManager _) = return () --- | Wait until all managed thread are finished.+-- | Wait until all managed threads are finished. waitUntilAllGone :: ThreadManager -> IO ()-waitUntilAllGone (ThreadManager _timmgr var) = atomically $ do- m <- readTVar var- check (Map.size m == 0)+waitUntilAllGone tm =+ atomically $+ isAllGone tm >>= check +-- | STM action that checks if all managed threads are finished. isAllGone :: ThreadManager -> STM Bool-isAllGone (ThreadManager _timmgr var) = do- m <- readTVar var- return (Map.size m == 0)+isAllGone (ThreadManager _timmgr var) =+ Map.null <$> readTVar var ---------------------------------------------------------------- -myWeakThradId :: IO (Weak ThreadId, Key)-myWeakThradId = do+myWeakThreadId :: IO (Weak ThreadId, Key)+myWeakThreadId = do tid <- myThreadId wtid <- mkWeakThreadId tid let n = fromThreadId tid@@ -208,8 +265,10 @@ tid <- myThreadId labelThread tid l +-- | Registering a 'T.TimeoutAction' and unregister its 'T.Handle'+-- when the body action is finished. withHandle- :: ThreadManager -> T.TimeoutAction -> (T.Handle -> IO a) -> IO (Maybe a)+ :: ThreadManager -> T.TimeoutAction -> (T.Handle -> IO a) -> IO a withHandle (ThreadManager timmgr _) = T.withHandle timmgr #if __GLASGOW_HASKELL__ < 908
System/TimeManager.hs view
@@ -1,7 +1,18 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE CPP #-} {-# LANGUAGE RecordWildCards #-} +-- | Timeout manager. Since @v0.3.0@, timeout manager is a wrapper of+-- GHC System TimerManager.+--+-- Some caveats of using this package:+--+-- * Only works for GHC+-- * Only works with a threaded runtime+-- * Users of older versions should check the current semantics.+-- * 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) module System.TimeManager ( -- ** Types Manager,@@ -35,164 +46,150 @@ TimeoutThread (..), ) where -import Control.Concurrent (mkWeakThreadId, myThreadId)+import Control.Concurrent (forkIO, mkWeakThreadId, myThreadId) import qualified Control.Exception as E import Control.Monad (void)-import Control.Reaper-import Data.IORef (IORef) import qualified Data.IORef as I-import Data.Typeable (Typeable)-import System.IO.Unsafe import System.Mem.Weak (deRefWeak)+import System.TimeManager.Internal -----------------------------------------------------------------+#if defined(mingw32_HOST_OS)+import qualified GHC.Event.Windows as EV+#else+import qualified GHC.Event as EV+#endif --- | A timeout manager-data Manager = Manager (Reaper [Handle] Handle) | NoManager+---------------------------------------------------------------- --- | No manager.+-- | A manager whose timeout value is 0 (no callbacks are fired). defaultManager :: Manager-defaultManager = NoManager---- | An action to be performed on timeout.-type TimeoutAction = IO ()---- | A handle used by a timeout manager.-data Handle = Handle- { handleManager :: Manager- , handleActionRef :: IORef TimeoutAction- , handleStateRef :: IORef State- }--{-# NOINLINE emptyAction #-}-emptyAction :: IORef TimeoutAction-emptyAction = unsafePerformIO $ I.newIORef (return ())+defaultManager = Manager 0 -{-# NOINLINE emptyState #-}-emptyState :: IORef State-emptyState = unsafePerformIO $ I.newIORef Inactive+---------------------------------------------------------------- +-- | Dummy 'Handle'. emptyHandle :: Handle emptyHandle = Handle- { handleManager = NoManager- , handleActionRef = emptyAction- , handleStateRef = emptyState+ { handleTimeout = 0+ , handleAction = pure ()+ , handleKeyRef = error "time-manager: Handle.handleKeyRef not set"+ , handleState = error "time-manager: Handle.handleState not set" } -data State- = Active -- Manager turns it to Inactive.- | Inactive -- Manager removes it with timeout action.- | Paused -- Manager does not change it.- ---------------------------------------------------------------- --- | Creating timeout manager which works every N microseconds--- where N is the first argument.+-- | Creating timeout manager with a timeout value in microseconds.+--+-- Setting the timeout to zero or lower (<= 0) will produce a+-- `defaultManager`. initialize :: Int -> IO Manager-initialize timeout- | timeout <= 0 = return NoManager-initialize timeout =- Manager- <$> mkReaper- defaultReaperSettings- { -- Data.Set cannot be used since 'partition' cannot be used- -- with 'readIORef`. So, let's just use a list.- reaperAction = mkListAction prune- , reaperDelay = timeout- , reaperThreadName = "WAI timeout manager (Reaper)"- }- where- prune m@Handle{..} = do- state <- I.atomicModifyIORef' handleStateRef (\x -> (inactivate x, x))- case state of- Inactive -> do- onTimeout <- I.readIORef handleActionRef- onTimeout `E.catch` ignoreSync- return Nothing- _ -> return $ Just m-- inactivate Active = Inactive- inactivate x = x+initialize = pure . Manager . max 0 ---------------------------------------------------------------- --- | Stopping timeout manager with onTimeout fired.+-- | Obsoleted since version 0.3.0+-- Is now equivalent to @pure ()@. stopManager :: Manager -> IO ()-stopManager NoManager = return ()-stopManager (Manager mgr) = E.mask_ (reaperStop mgr >>= mapM_ fire)- where- fire Handle{..} = do- onTimeout <- I.readIORef handleActionRef- onTimeout `E.catch` ignoreSync+stopManager _ = pure ()+{-# DEPRECATED stopManager "This function does nothing since version 0.3.0" #-} --- | Killing timeout manager immediately without firing onTimeout.+-- | Obsoleted since version 0.3.0+-- Is now equivalent to @pure ()@. killManager :: Manager -> IO ()-killManager NoManager = return ()-killManager (Manager mgr) = reaperKill mgr+killManager _ = pure ()+{-# DEPRECATED killManager "This function does nothing since version 0.3.0" #-} ---------------------------------------------------------------- -- | Registering a timeout action and unregister its handle -- when the body action is finished.--- 'Nothing' is returned on timeout.-withHandle :: Manager -> TimeoutAction -> (Handle -> IO a) -> IO (Maybe a)-withHandle mgr onTimeout action =- E.handle ignore $ E.bracket (register mgr onTimeout) cancel $ \th ->- Just <$> action th- where- ignore TimeoutThread = return Nothing+withHandle :: Manager -> TimeoutAction -> (Handle -> IO a) -> IO a+withHandle mgr onTimeout action+ | isNoManager mgr = action emptyHandle+ | otherwise = E.bracket (register mgr onTimeout) cancel action -- | Registering a timeout action of killing this thread and -- unregister its handle when the body action is killed or finished. withHandleKillThread :: Manager -> TimeoutAction -> (Handle -> IO ()) -> IO ()-withHandleKillThread mgr onTimeout action =- E.handle ignore $ E.bracket (registerKillThread mgr onTimeout) cancel action+withHandleKillThread mgr onTimeout action+ | isNoManager mgr = action emptyHandle+ | otherwise =+ E.handle ignore $ E.bracket (registerKillThread mgr onTimeout) cancel action where- ignore TimeoutThread = return ()+ ignore TimeoutThread = pure () ---------------------------------------------------------------- -- | Registering a timeout action. register :: Manager -> TimeoutAction -> IO Handle-register NoManager _ = return emptyHandle-register m@(Manager mgr) !onTimeout = do- actionRef <- I.newIORef onTimeout- stateRef <- I.newIORef Active- let h =- Handle- { handleManager = m- , handleActionRef = actionRef- , handleStateRef = stateRef- }- reaperAdd mgr h- return h+register mgr@(Manager timeout) onTimeout+ | isNoManager mgr = pure emptyHandle+ | otherwise = do+ sysmgr <- getTimerManager+ key <- EV.registerTimeout sysmgr timeout onTimeout+ keyref <- I.newIORef key+ state <- I.newIORef Active+ let h =+ Handle+ { handleTimeout = timeout+ , handleAction = onTimeout+ , handleKeyRef = keyref+ , handleState = state+ }+ pure h --- | Removing the 'Handle' from the 'Manager' immediately.+-- | Unregistering the timeout. cancel :: Handle -> IO ()-cancel Handle{..} = case handleManager of- NoManager -> return ()- Manager mgr -> void $ reaperModify mgr filt- where- -- It's very important that this function forces the whole workload so we- -- don't retain old handles, otherwise disasterous leaks occur.- filt [] = []- filt (h@(Handle _ _ ref) : hs)- | handleStateRef == ref = hs- | otherwise =- let !hs' = filt hs- in h : hs'+cancel h@Handle{..} = withNonEmptyHandle h $ do+ mgr <- getTimerManager+ key <- I.readIORef handleKeyRef+ EV.unregisterTimeout mgr key+ I.atomicWriteIORef handleState Stopped +-- | Extending the timeout.+--+-- Careful: this does NOT reactivate an already paused 'Handle'!+tickle :: Handle -> IO ()+tickle h@Handle{..} = withNonEmptyHandle h $ do+ mgr <- getTimerManager+ key <- I.readIORef handleKeyRef+#if defined(mingw32_HOST_OS)+ EV.updateTimeout mgr key $ fromIntegral (handleTimeout `div` 1000000)+#else+ EV.updateTimeout mgr key handleTimeout+#endif++-- | This is identical to 'cancel'.+-- To resume timeout with the same 'Handle', 'resume' MUST be called.+-- Don't call 'tickle' for resumption.+pause :: Handle -> IO ()+pause = cancel++-- | 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+ ---------------------------------------------------------------- -- | The asynchronous exception thrown if a thread is registered via -- 'registerKillThread'. data TimeoutThread = TimeoutThread- deriving (Typeable) instance E.Exception TimeoutThread where toException = E.asyncExceptionToException fromException = E.asyncExceptionFromException+ instance Show TimeoutThread where show TimeoutThread = "Thread killed by timeout manager" @@ -202,70 +199,31 @@ -- want to leak the asynchronous exception to GHC RTS. registerKillThread :: Manager -> TimeoutAction -> IO Handle registerKillThread m onTimeout = do- tid <- myThreadId- wtid <- mkWeakThreadId tid+ wtid <- myThreadId >>= mkWeakThreadId -- First run the timeout action in case the child thread is masked. register m $ onTimeout `E.finally` do mtid <- deRefWeak wtid case mtid of- Nothing -> return ()- Just tid' -> E.throwTo tid' TimeoutThread---------------------------------------------------------------------- | Setting the state to active.--- 'Manager' turns active to inactive repeatedly.-tickle :: Handle -> IO ()-tickle Handle{..} = I.writeIORef handleStateRef Active---- | Setting the state to paused.--- 'Manager' does not change the value.-pause :: Handle -> IO ()-pause Handle{..} = I.writeIORef handleStateRef Paused---- | Setting the paused state to active.--- This is an alias to 'tickle'.-resume :: Handle -> IO ()-resume = tickle+ Nothing -> pure ()+ Just tid' -> void . forkIO $ E.throwTo tid' TimeoutThread ---------------------------------------------------------------- -- | Call the inner function with a timeout manager.--- 'stopManager' is used after that. withManager :: Int -- ^ timeout in microseconds -> (Manager -> IO a) -> IO a-withManager timeout f =- E.bracket- (initialize timeout)- stopManager- f+withManager timeout f = initialize timeout >>= f -- | Call the inner function with a timeout manager.--- 'killManager' is used after that.+-- This is identical to 'withManager'. withManager' :: Int -- ^ timeout in microseconds -> (Manager -> IO a) -> IO a-withManager' timeout f =- E.bracket- (initialize timeout)- killManager- f--------------------------------------------------------------------isAsyncException :: E.Exception e => e -> Bool-isAsyncException e =- case E.fromException (E.toException e) of- Just (E.SomeAsyncException _) -> True- Nothing -> False--ignoreSync :: E.SomeException -> IO ()-ignoreSync se- | isAsyncException se = E.throwIO se- | otherwise = return ()+withManager' = withManager+{-# DEPRECATED withManager' "This function is the same as 'withManager' since version 0.3.0" #-}
+ System/TimeManager/Internal.hs view
@@ -0,0 +1,55 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE StrictData #-}++module System.TimeManager.Internal where++import Data.IORef (IORef)++#if defined(mingw32_HOST_OS)+import qualified GHC.Event.Windows as EV+#else+import qualified GHC.Event as EV+#endif++----------------------------------------------------------------++-- | A timeout manager+newtype Manager = Manager Int++isNoManager :: Manager -> Bool+isNoManager (Manager 0) = True+isNoManager _ = False++----------------------------------------------------------------++-- | An action (callback) to be performed on timeout.+type TimeoutAction = IO ()++-- | A handle used by a timeout manager.+data Handle = Handle+ { handleTimeout :: Int+ , handleAction :: TimeoutAction+ , handleKeyRef :: ~(IORef EV.TimeoutKey)+ , handleState :: ~(IORef HandleState)+ }++-- | Tracking the state of a handle, to be able to have 'resume'+-- act like a 'register' or 'tickle'.+data HandleState = Active | Stopped++isEmptyHandle :: Handle -> Bool+isEmptyHandle Handle{..} = handleTimeout == 0++withNonEmptyHandle :: Handle -> IO () -> IO ()+withNonEmptyHandle h act =+ if isEmptyHandle h then pure () else act++#if defined(mingw32_HOST_OS)+getTimerManager :: IO EV.Manager+getTimerManager = EV.getSystemManager+#else+getTimerManager :: IO EV.TimerManager+getTimerManager = EV.getSystemTimerManager+#endif
+ test/Spec.hs view
@@ -0,0 +1,165 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE NumericUnderscores #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# OPTIONS_GHC -Wno-orphans #-}++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+#else+import qualified GHC.Event as EV+#endif++main :: IO ()+main = hspec $ do+ describe "TimeManager" $ do+ it "defaultManager == no manager" $+ defaultManager `shouldSatisfy` isNoManager++ it "initializes negative manager" $ do+ let check = (`shouldBe` defaultManager)+ initialize (-10) >>= check+ withManager (-5) check++ it "empty handle is correct" $+ handleTimeout emptyHandle `shouldBe` 0++ it "empty handle check is consistent" $ do+ assertBool "emptyHandle not empty" $+ isEmptyHandle emptyHandle++ it "gives emptyHandle when registering defaultManager" $ do+ hndl <- register defaultManager $ pure ()+ assertBool "got non-empty handle" $ isEmptyHandle hndl++ it "throws TimeoutThread exception" $+ throwsTimeoutThread $ do+ mngr <- initialize 1+ _hndl <- registerKillThread mngr $ pure ()+ threadDelay 100++ it "defaultManager doesn't kill thread" $ do+ _hndl <- registerKillThread defaultManager $ pure ()+ threadDelay 2000++ it "withHandle: registers timeout" $+ withHandleTest mgr1 $ \check _ -> do+ threadDelay 2000+ check True++ it "withHandle: doesn't register timeout" $+ withHandleTest defaultManager $ \check _ -> do+ threadDelay 2000+ check False++ -- We make a ref on the outside, to check that the ref is indeed+ -- set before the timeout kills the action inside.+ it "withHandleKillThread: registers timeout (and kills)" $ do+ ref <- freshRef+ withHandleKillTest (Just ref) mgr1 $ \_ _ ->+ throwsTimeoutThread $ threadDelay 100+ ref `refShouldBe` True++ it "withHandleKillThread: doesn't register timeout" $+ withHandleKillTest Nothing defaultManager $ \check _ -> do+ threadDelay 200+ check False++ it "cancel/pause works as expected" $ do+ m <- initialize 100+ let runIt f = do+ hndl <- registerKillThread m (pure ())+ _ <- f hndl+ threadDelay 1000+ throwsTimeoutThread $ runIt pure+ runIt cancel+ runIt pause++ it "tickle works as expected" $ do+ m <- initialize 10_000+ withHandleTest m $ \check hndl -> do+ forM_ [(1 :: Int) .. 20] $ \_ -> do+ threadDelay 1000+ 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+ -- Doing nothing kills the thread+ throwsTimeoutThread . runAndWaitForTimeout $ \_ -> pure ()+ -- Pausing stops the kill+ runAndWaitForTimeout $ \hndl -> do+ threadDelay 2500+ pause hndl+ -- Resuming kills the thread again+ throwsTimeoutThread . runAndWaitForTimeout $ \hndl -> do+ threadDelay 2500+ pause hndl+ threadDelay 20_000+ resume hndl++ -- "resuming" every 2.5ms 20 times+ let testResume f = do+ runIt $ \hndl -> do+ forM_ [(1 :: Int) .. 20] $ \_ -> do+ threadDelay 2500+ f hndl+ it "resume also works as tickle" $+ testResume resume++ it "resume also works as tickle with pauses" $+ testResume $ \hndl -> do+ resume hndl+ pause hndl+ resume hndl++ it "old resume did NOT work as tickle" $+ throwsTimeoutThread $+ testResume oldResume+ where+ withHandleTest = withTest withHandle Nothing+ withHandleKillTest = withTest withHandleKillThread+ -- 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++mgr1 :: Manager+mgr1 = Manager 1++freshRef :: IO (IORef Bool)+freshRef = newIORef False++refShouldBe :: IORef Bool -> Bool -> IO ()+refShouldBe ref expected =+ readIORef ref >>= (`shouldBe` expected)++throwsTimeoutThread :: IO () -> Expectation+throwsTimeoutThread t = t `shouldThrow` (const True :: TimeoutThread -> Bool)++deriving instance Eq Manager+deriving instance Show Manager++-- copied from time-manager-0.3.0 to check it actually is broken+oldResume :: Handle -> IO ()+oldResume h | isEmptyHandle h = return ()+oldResume Handle{..} = do+ mgr <- getTimerManager+ key <- EV.registerTimeout mgr handleTimeout handleAction+ I.writeIORef handleKeyRef key
time-manager.cabal view
@@ -1,26 +1,48 @@-Name: time-manager-Version: 0.2.4-Synopsis: Scalable timer-License: MIT-License-file: LICENSE-Author: Michael Snoyman and Kazu Yamamoto-Maintainer: kazu@iij.ad.jp-Homepage: http://github.com/yesodweb/wai-Category: System-Build-Type: Simple-Cabal-Version: >=1.10-Stability: Stable-Description: Scalable timer functions provided by a timer manager- and thread management functions to prevent thread- leak by a thread manager.-Extra-Source-Files: ChangeLog.md+cabal-version: >=1.10+name: time-manager+version: 0.3.2+license: MIT+license-file: LICENSE+maintainer: kazu@iij.ad.jp+author: Michael Snoyman and Kazu Yamamoto+stability: Stable+homepage: http://github.com/yesodweb/wai+synopsis: Scalable timer+description:+ Scalable timer functions provided by a timer manager+ and thread management functions to prevent thread+ leak by a thread manager. -Library- Build-Depends: base >= 4.12 && < 5- , auto-update >= 0.2 && < 0.3- , containers- , stm- Default-Language: Haskell2010- Exposed-modules: System.TimeManager- Exposed-modules: System.ThreadManager- Ghc-Options: -Wall+category: System+build-type: Simple+extra-source-files: ChangeLog.md+ README.md++library+ exposed-modules:+ System.TimeManager+ System.ThreadManager+ other-modules:+ System.TimeManager.Internal++ default-language: Haskell2010+ default-extensions: Strict StrictData+ ghc-options: -Wall+ build-depends:+ base >=4.12 && <5,+ containers,+ stm++test-suite spec+ type: exitcode-stdio-1.0+ main-is: test/Spec.hs+ other-modules:+ System.TimeManager,+ System.TimeManager.Internal+ build-depends: base+ default-language: Haskell2010+ ghc-options: -Wall -threaded+ build-depends:+ base >=4.12 && <5,+ hspec,+ HUnit