time-manager 0.3.0 → 0.3.1
raw patch · 5 files changed
+288/−58 lines, 5 filesdep +HUnitdep +hspecdep ~basenew-uploader
Dependencies added: HUnit, hspec
Dependency ranges changed: base
Files
- ChangeLog.md +11/−0
- System/TimeManager.hs +40/−57
- System/TimeManager/Internal.hs +55/−0
- test/Spec.hs +165/−0
- time-manager.cabal +17/−1
ChangeLog.md view
@@ -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
System/TimeManager.hs view
@@ -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
+ 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,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