time-manager 0.0.1 → 0.1.0
raw patch · 3 files changed
+93/−61 lines, 3 filesdep ~auto-update
Dependency ranges changed: auto-update
Files
- ChangeLog.md +8/−0
- System/TimeManager.hs +82/−59
- time-manager.cabal +3/−2
+ ChangeLog.md view
@@ -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.
System/TimeManager.hs view
@@ -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
time-manager.cabal view
@@ -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