diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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`. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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. diff --git a/System/ThreadManager.hs b/System/ThreadManager.hs new file mode 100644 --- /dev/null +++ b/System/ThreadManager.hs @@ -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 diff --git a/System/TimeManager.hs b/System/TimeManager.hs --- a/System/TimeManager.hs +++ b/System/TimeManager.hs @@ -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" #-} diff --git a/System/TimeManager/Internal.hs b/System/TimeManager/Internal.hs new file mode 100644 --- /dev/null +++ b/System/TimeManager/Internal.hs @@ -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 diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -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 diff --git a/time-manager.cabal b/time-manager.cabal --- a/time-manager.cabal +++ b/time-manager.cabal @@ -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