diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,8 @@ +# ChangeLog for time-manager + +## 0.1.0 + +* [#986](https://github.com/yesodweb/wai/pull/986) + * Change behavior of `cancel` to immediately remove the `Handle` from the + reaper's workload, rather than waiting for timeout. + * Using auto-update v0.2.0. diff --git a/System/TimeManager.hs b/System/TimeManager.hs --- a/System/TimeManager.hs +++ b/System/TimeManager.hs @@ -1,34 +1,39 @@ {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE BangPatterns #-} module System.TimeManager ( - -- ** Types - Manager - , TimeoutAction - , Handle - -- ** Manager - , initialize - , stopManager - , killManager - , withManager - , withManager' - -- ** Registration - , register - , registerKillThread - -- ** Control - , tickle - , cancel - , pause - , resume - -- ** Exceptions - , TimeoutThread (..) - ) where + -- ** Types + Manager, + TimeoutAction, + Handle, + -- ** Manager + initialize, + stopManager, + killManager, + withManager, + withManager', + + -- ** Registration + register, + registerKillThread, + + -- ** Control + tickle, + cancel, + pause, + resume, + + -- ** Exceptions + TimeoutThread (..), +) where + import Control.Concurrent (myThreadId) -import qualified UnliftIO.Exception as E import Control.Reaper -import Data.Typeable (Typeable) import Data.IORef (IORef) import qualified Data.IORef as I +import Data.Typeable (Typeable) +import qualified UnliftIO.Exception as E ---------------------------------------------------------------- @@ -39,32 +44,33 @@ type TimeoutAction = IO () -- | A handle used by 'Manager' -data Handle = Handle !(IORef TimeoutAction) !(IORef State) +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. - | Canceled -- Manager removes it without timeout action. +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 micro seconds -- where N is the first argument. initialize :: Int -> IO Manager -initialize timeout = mkReaper defaultReaperSettings - { reaperAction = mkListAction prune - , reaperDelay = timeout - } +initialize timeout = + mkReaper + defaultReaperSettings + { reaperAction = mkListAction prune + , reaperDelay = timeout + } where - prune m@(Handle actionRef stateRef) = do + 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 - Canceled -> return Nothing - _ -> return $ Just m + _ -> return $ Just m inactivate Active = Inactive inactivate x = x @@ -75,7 +81,7 @@ stopManager :: Manager -> IO () stopManager mgr = E.mask_ (reaperStop mgr >>= mapM_ fire) where - fire (Handle actionRef _) = do + fire (Handle _ actionRef _) = do onTimeout <- I.readIORef actionRef onTimeout `E.catch` ignoreAll @@ -90,10 +96,10 @@ -- | Registering a timeout action. register :: Manager -> TimeoutAction -> IO Handle -register mgr onTimeout = do +register mgr !onTimeout = do actionRef <- I.newIORef onTimeout - stateRef <- I.newIORef Active - let h = Handle actionRef stateRef + stateRef <- I.newIORef Active + let h = Handle mgr actionRef stateRef reaperAdd mgr h return h @@ -110,7 +116,7 @@ register m $ onTimeout `E.finally` E.throwTo tid TimeoutThread data TimeoutThread = TimeoutThread - deriving Typeable + deriving (Typeable) instance E.Exception TimeoutThread where toException = E.asyncExceptionToException fromException = E.asyncExceptionFromException @@ -122,19 +128,28 @@ -- | Setting the state to active. -- 'Manager' turns active to inactive repeatedly. tickle :: Handle -> IO () -tickle (Handle _ stateRef) = I.writeIORef stateRef Active +tickle (Handle _ _ stateRef) = I.writeIORef stateRef Active --- | Setting the state to canceled. --- 'Manager' eventually removes this without timeout action. +-- | Removing the 'Handle' from the 'Manager' immediately. cancel :: Handle -> IO () -cancel (Handle actionRef stateRef) = do - I.writeIORef actionRef (return ()) -- ensuring to release ThreadId - I.writeIORef stateRef Canceled +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' -- | Setting the state to paused. -- 'Manager' does not change the value. pause :: Handle -> IO () -pause (Handle _ stateRef) = I.writeIORef stateRef Paused +pause (Handle _ _ stateRef) = I.writeIORef stateRef Paused -- | Setting the paused state to active. -- This is an alias to 'tickle'. @@ -145,18 +160,26 @@ -- | 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 + :: Int + -- ^ timeout in microseconds + -> (Manager -> IO a) + -> IO a +withManager timeout f = + E.bracket + (initialize timeout) + stopManager + f -- | Call the inner function with a timeout manager. -- 'killManager' is used after that. -withManager' :: Int -- ^ timeout in microseconds - -> (Manager -> IO a) - -> IO a -withManager' timeout f = E.bracket (initialize timeout) - killManager - f +withManager' + :: Int + -- ^ timeout in microseconds + -> (Manager -> IO a) + -> IO a +withManager' timeout f = + E.bracket + (initialize timeout) + killManager + f diff --git a/time-manager.cabal b/time-manager.cabal --- a/time-manager.cabal +++ b/time-manager.cabal @@ -1,5 +1,5 @@ Name: time-manager -Version: 0.0.1 +Version: 0.1.0 Synopsis: Scalable timer License: MIT License-file: LICENSE @@ -11,10 +11,11 @@ Cabal-Version: >=1.10 Stability: Stable Description: Scalable timer functions provided by a timer manager. +Extra-Source-Files: ChangeLog.md Library Build-Depends: base >= 4.12 && < 5 - , auto-update + , auto-update >= 0.2 && < 0.3 , unliftio Default-Language: Haskell2010 Exposed-modules: System.TimeManager