diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,16 @@ # ChangeLog for time-manager +## 0.3.1 + +BUGFIXES: + +* `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 * New architecture. The backend is switched from the designated thread diff --git a/System/TimeManager.hs b/System/TimeManager.hs --- a/System/TimeManager.hs +++ b/System/TimeManager.hs @@ -1,13 +1,17 @@ -{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE StrictData #-} --- | Timeout manager. Since v0.3.0, timeout manager is a wrapper of +-- | Timeout manager. Since @v0.3.0@, timeout manager is a wrapper of -- GHC System TimerManager. -- --- Users of old version should check the current semantics. +-- 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, @@ -41,11 +45,12 @@ TimeoutThread (..), ) where -import Control.Concurrent (mkWeakThreadId, myThreadId) +import Control.Concurrent (forkIO, mkWeakThreadId, myThreadId) import qualified Control.Exception as E -import Data.IORef (IORef) +import Control.Monad (void) import qualified Data.IORef as I import System.Mem.Weak (deRefWeak) +import System.TimeManager.Internal #if defined(mingw32_HOST_OS) import qualified GHC.Event.Windows as EV @@ -55,43 +60,22 @@ ---------------------------------------------------------------- --- | A timeout manager -newtype Manager = Manager Int - -- | A manager whose timeout value is 0 (no callbacks are fired). defaultManager :: Manager defaultManager = Manager 0 -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) - } - -- | Dummy 'Handle'. emptyHandle :: Handle emptyHandle = Handle { handleTimeout = 0 - , handleAction = return () + , handleAction = pure () , handleKeyRef = error "time-manager: Handle.handleKeyRef not set" + , handleState = error "time-manager: Handle.handleState not set" } -isEmptyHandle :: Handle -> Bool -isEmptyHandle Handle{..} = handleTimeout == 0 - ---------------------------------------------------------------- -- | Creating timeout manager with a timeout value in microseconds. @@ -106,13 +90,13 @@ -- | Obsoleted since version 0.3.0 -- Is now equivalent to @pure ()@. stopManager :: Manager -> IO () -stopManager _ = return () +stopManager _ = pure () {-# DEPRECATED stopManager "This function does nothing since version 0.3.0" #-} -- | Obsoleted since version 0.3.0 -- Is now equivalent to @pure ()@. killManager :: Manager -> IO () -killManager _ = return () +killManager _ = pure () {-# DEPRECATED killManager "This function does nothing since version 0.3.0" #-} ---------------------------------------------------------------- @@ -132,38 +116,41 @@ | 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 mgr@(Manager timeout) onTimeout - | isNoManager mgr = return emptyHandle + | 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 } - return h + pure h -- | Unregistering the timeout. cancel :: Handle -> IO () -cancel hd | isEmptyHandle hd = return () -cancel Handle{..} = do +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 | isEmptyHandle h = return () -tickle Handle{..} = do +tickle h@Handle{..} = withNonEmptyHandle h $ do mgr <- getTimerManager key <- I.readIORef handleKeyRef #if defined(mingw32_HOST_OS) @@ -179,12 +166,18 @@ pause = cancel -- | Resuming the timeout. +-- +-- Works like 'tickle' if the 'Handle' wasn't 'pause'd or 'cancel'ed. resume :: Handle -> IO () -resume h | isEmptyHandle h = return () -resume Handle{..} = do - mgr <- getTimerManager - key <- EV.registerTimeout mgr handleTimeout handleAction - I.writeIORef handleKeyRef key +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 ---------------------------------------------------------------- @@ -205,16 +198,14 @@ -- 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 () - -- FIXME: forkIO to prevent blocking TimerManger - Just tid' -> E.throwTo tid' TimeoutThread + Nothing -> pure () + Just tid' -> void . forkIO $ E.throwTo tid' TimeoutThread ---------------------------------------------------------------- @@ -235,11 +226,3 @@ -> IO a withManager' = withManager {-# DEPRECATED withManager' "This function is the same as 'withManager' since version 0.3.0" #-} - -#if defined(mingw32_HOST_OS) -getTimerManager :: IO EV.Manager -getTimerManager = EV.getSystemManager -#else -getTimerManager :: IO EV.TimerManager -getTimerManager = EV.getSystemTimerManager -#endif 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,6 +1,6 @@ cabal-version: >=1.10 name: time-manager -version: 0.3.0 +version: 0.3.1 license: MIT license-file: LICENSE maintainer: kazu@iij.ad.jp @@ -21,6 +21,8 @@ exposed-modules: System.TimeManager System.ThreadManager + other-modules: + System.TimeManager.Internal default-language: Haskell2010 default-extensions: Strict StrictData @@ -29,3 +31,17 @@ 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