time-manager 0.1.3 → 0.3.2
raw patch · 7 files changed
Files
- ChangeLog.md +63/−0
- README.md +13/−0
- System/ThreadManager.hs +277/−0
- System/TimeManager.hs +123/−109
- System/TimeManager/Internal.hs +55/−0
- test/Spec.hs +165/−0
- time-manager.cabal +47/−20
ChangeLog.md view
@@ -1,5 +1,68 @@ # 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`.+* Providing emptyHandle.++## 0.2.3++* Exporting defaultManager.++## 0.2.2++* `initialize` with non positive integer creates a time manager+ which does not maintain timeout.+ [#1017](https://github.com/yesodweb/wai/pull/1017)++## 0.2.1++* Export KilledByThreadManager exception+ [#1016](https://github.com/yesodweb/wai/pull/1016)++## 0.2.0++* Providing `System.ThreadManager`.+* `withHandle` catches `TimeoutThread` internally.+ It returns `Nothing` on timeout.+ ## 0.1.3 * Providing `withHandle` and `withHandleKillThread`.
+ 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
@@ -0,0 +1,277 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- | 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+ forkManaged,+ forkManagedFinally,+ forkManagedUnmask,+ forkManagedTimeout,+ forkManagedTimeoutFinally,++ -- * Synchronization+ waitUntilAllGone,+ isAllGone,++ -- * Re-exports+ T.Manager,+ withHandle,+ T.Handle,+ T.tickle,+ T.pause,+ T.resume,+) where++import Control.Concurrent+import Control.Concurrent.STM+import Control.Exception (Exception (..), SomeException (..))+import qualified Control.Exception as E+import Control.Monad (unless, void)+import Data.Foldable (forM_)+import Data.IORef (IORef, atomicModifyIORef', newIORef)+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map+import Data.Word (Word64)+import GHC.Conc.Sync (labelThread)+#if __GLASGOW_HASKELL__ >= 908+import GHC.Conc.Sync (fromThreadId)+#endif+import System.Mem.Weak (Weak, deRefWeak)+import qualified System.TimeManager as T++----------------------------------------------------------------++-- | Manager to manage the thread and the timer.+data ThreadManager = ThreadManager T.Manager (TVar ManagedThreads)++type Key = Word64+type ManagedThreads = Map Key ManagedThread++----------------------------------------------------------------++-- 'IORef' prevents race between WAI TimeManager (TimeoutThread)+-- and stopAfter (KilledByThreadManager).+-- It is initialized with 'False' and turned into 'True' when locked.+-- The winner can throw an asynchronous exception.+data ManagedThread = ManagedThread (Weak ThreadId) (IORef Bool)++----------------------------------------------------------------++-- | 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++----------------------------------------------------------------++-- | An exception used internally to kill a managed thread.+data KilledByThreadManager = KilledByThreadManager (Maybe SomeException)+ deriving (Show)++instance Exception KilledByThreadManager where+ toException = E.asyncExceptionToException+ fromException = E.asyncExceptionFromException++-- | 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 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+ m0 <- readTVar var+ writeTVar var Map.empty+ return m0+ let ths = Map.elems m+ er = either Just (const Nothing) ma+ ex = KilledByThreadManager er+ forM_ ths $ \(ManagedThread wtid ref) -> lockAndKill wtid ref ex+ cleanup ma++----------------------------------------------------------------++-- | Fork a managed thread.+--+-- This guarantees that the thread ID is added to the manager's queue before+-- the thread starts, and is removed again when the thread terminates+-- (normally or abnormally).+forkManaged+ :: ThreadManager+ -> String+ -- ^ Thread name+ -> IO ()+ -- ^ Action+ -> IO ()+forkManaged mgr label io =+ forkManagedUnmask mgr label $ \unmask -> unmask io++-- | Like 'forkManaged', but run action with exceptions masked+forkManagedUnmask+ :: 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+ -- ^ Thread name+ -> (T.Handle -> IO ())+ -- ^ Action with timeout handle+ -> IO ()+forkManagedTimeout (ThreadManager timmgr var) label io =+ void $ forkIO $ do+ labelMe label+ E.bracket (setup var) (clear var) $ \(_n, wtid, ref) ->+ 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+ -- ^ 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+ -- ^ 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++setup :: TVar (Map Key ManagedThread) -> IO (Key, Weak ThreadId, IORef Bool)+setup var = do+ (wtid, n) <- myWeakThreadId+ ref <- newIORef False+ let ent = ManagedThread wtid ref+ -- asking to throw KilledByThreadManager to me+ atomically $ modifyTVar' var $ Map.insert n ent+ return (n, wtid, ref)++lockAndKill :: Exception e => Weak ThreadId -> IORef Bool -> e -> IO ()+lockAndKill wtid ref e = do+ alreadyLocked <- atomicModifyIORef' ref (\b -> (True, b)) -- try to lock+ unless alreadyLocked $ do+ mtid <- deRefWeak wtid+ case mtid of+ Nothing -> return ()+ Just tid -> E.throwTo tid e++clear+ :: TVar (Map Key ManagedThread)+ -> (Key, Weak ThreadId, IORef Bool)+ -> IO ()+clear var (n, _, _) = atomically $ modifyTVar' var $ Map.delete n++ignore :: KilledByThreadManager -> IO ()+ignore (KilledByThreadManager _) = return ()++-- | Wait until all managed threads are finished.+waitUntilAllGone :: ThreadManager -> IO ()+waitUntilAllGone tm =+ atomically $+ isAllGone tm >>= check++-- | STM action that checks if all managed threads are finished.+isAllGone :: ThreadManager -> STM Bool+isAllGone (ThreadManager _timmgr var) =+ Map.null <$> readTVar var++----------------------------------------------------------------++myWeakThreadId :: IO (Weak ThreadId, Key)+myWeakThreadId = do+ tid <- myThreadId+ wtid <- mkWeakThreadId tid+ let n = fromThreadId tid+ return (wtid, n)++labelMe :: String -> IO ()+labelMe l = do+ 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 a+withHandle (ThreadManager timmgr _) = T.withHandle timmgr++#if __GLASGOW_HASKELL__ < 908+fromThreadId :: ThreadId -> Word64+fromThreadId tid = read (drop 9 $ show tid)+#endif
System/TimeManager.hs view
@@ -1,11 +1,25 @@-{-# 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,+ defaultManager, TimeoutAction, Handle,+ emptyHandle, -- ** Manager initialize,@@ -18,7 +32,7 @@ withHandle, withHandleKillThread, - -- ** Control+ -- ** Control timeout tickle, pause, resume,@@ -32,124 +46,150 @@ TimeoutThread (..), ) where -import Control.Concurrent (mkWeakThreadId, myThreadId)+import Control.Concurrent (forkIO, mkWeakThreadId, myThreadId) import qualified Control.Exception as E-import Control.Reaper-import Data.IORef (IORef)+import Control.Monad (void) import qualified Data.IORef as I-import Data.Typeable (Typeable)-import GHC.Weak (deRefWeak)+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-type Manager = Reaper [Handle] Handle+---------------------------------------------------------------- --- | An action to be performed on timeout.-type TimeoutAction = IO ()+-- | A manager whose timeout value is 0 (no callbacks are fired).+defaultManager :: Manager+defaultManager = Manager 0 --- | A handle used by 'Manager'-data Handle = Handle Manager !(IORef TimeoutAction) !(IORef State)+---------------------------------------------------------------- -data State- = Active -- Manager turns it to Inactive.- | Inactive -- Manager removes it with timeout action.- | Paused -- Manager does not change it.+-- | Dummy 'Handle'.+emptyHandle :: Handle+emptyHandle =+ Handle+ { handleTimeout = 0+ , handleAction = pure ()+ , handleKeyRef = error "time-manager: Handle.handleKeyRef not set"+ , handleState = error "time-manager: Handle.handleState not set"+ } ---------------------------------------------------------------- --- | Creating timeout manager which works every N micro seconds--- 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 =- mkReaper- defaultReaperSettings- { reaperAction = mkListAction prune- , reaperDelay = timeout- , reaperThreadName = "WAI timeout manager (Reaper)"- }- where- prune m@(Handle _ actionRef stateRef) = do- state <- I.atomicModifyIORef' stateRef (\x -> (inactivate x, x))- case state of- Inactive -> do- onTimeout <- I.readIORef actionRef- onTimeout `E.catch` ignoreAll- 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 mgr = E.mask_ (reaperStop mgr >>= mapM_ fire)- where- fire (Handle _ actionRef _) = do- onTimeout <- I.readIORef actionRef- onTimeout `E.catch` ignoreAll--ignoreAll :: E.SomeException -> IO ()-ignoreAll _ = return ()+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 = reaperKill+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. withHandle :: Manager -> TimeoutAction -> (Handle -> IO a) -> IO a-withHandle mgr onTimeout action =- E.bracket (register mgr onTimeout) cancel action+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 handler $ 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- handler TimeoutThread = return ()+ ignore TimeoutThread = pure () ---------------------------------------------------------------- -- | Registering a timeout action. register :: Manager -> TimeoutAction -> IO Handle-register mgr !onTimeout = do- actionRef <- I.newIORef onTimeout- stateRef <- I.newIORef Active- let h = Handle mgr actionRef 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 mgr _ stateRef) = do- _ <- reaperModify mgr filt- return ()- 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 _ _ stateRef') : hs)- | stateRef == stateRef' = 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" @@ -159,57 +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 _ _ stateRef) = I.writeIORef stateRef Active---- | Setting the state to paused.--- 'Manager' does not change the value.-pause :: Handle -> IO ()-pause (Handle _ _ stateRef) = I.writeIORef stateRef 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+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,21 +1,48 @@-Name: time-manager-Version: 0.1.3-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.-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- Default-Language: Haskell2010- Exposed-modules: System.TimeManager- 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