time-manager-0.2.4/0000755000000000000000000000000007346545000012254 5ustar0000000000000000time-manager-0.2.4/ChangeLog.md0000644000000000000000000000171707346545000014433 0ustar0000000000000000# ChangeLog for time-manager ## 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`. ## 0.1.2 * Holding `Weak ThreadId` to prevent thread leak again [#1013](https://github.com/yesodweb/wai/pull/1013) ## 0.1.1 * Removing `unliftio`. ## 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. time-manager-0.2.4/LICENSE0000644000000000000000000000207507346545000013265 0ustar0000000000000000Copyright (c) 2012 Michael Snoyman, http://www.yesodweb.com/ Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. time-manager-0.2.4/System/0000755000000000000000000000000007346545000013540 5ustar0000000000000000time-manager-0.2.4/System/ThreadManager.hs0000644000000000000000000001615007346545000016601 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} -- | A thread manager including a time manager. -- The manager has responsibility to kill managed threads. module System.ThreadManager ( ThreadManager, newThreadManager, stopAfter, 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 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) ---------------------------------------------------------------- -- | Starting a thread manager. -- Its action is initially set to 'return ()' and should be set -- by 'setAction'. This allows that the action can include -- the manager itself. 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. -- -- 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 (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 case ma of Left err -> cleanup (Just err) >> E.throwIO err Right a -> cleanup Nothing >> return a ---------------------------------------------------------------- -- | 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 -> ((forall x. IO x -> IO x) -> IO ()) -> 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 -> (T.Handle -> IO ()) -> IO () forkManagedTimeout (ThreadManager timmgr var) label io = void $ forkIO $ E.handle ignore $ do labelMe label E.bracket (setup var) (clear var) $ \(_n, wtid, ref) -> -- 'TimeoutThread' is ignored by 'withHandle'. void $ T.withHandle timmgr (lockAndKill wtid ref T.TimeoutThread) io -- | Fork a managed thread with a cleanup function. forkManagedFinally :: ThreadManager -> String -> IO () -> IO () -> IO () forkManagedFinally mgr label io final = E.mask $ \restore -> forkManaged mgr label (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 -> (T.Handle -> IO ()) -> IO () -> 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) <- myWeakThradId 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 thread are finished. waitUntilAllGone :: ThreadManager -> IO () waitUntilAllGone (ThreadManager _timmgr var) = atomically $ do m <- readTVar var check (Map.size m == 0) isAllGone :: ThreadManager -> STM Bool isAllGone (ThreadManager _timmgr var) = do m <- readTVar var return (Map.size m == 0) ---------------------------------------------------------------- myWeakThradId :: IO (Weak ThreadId, Key) myWeakThradId = do tid <- myThreadId wtid <- mkWeakThreadId tid let n = fromThreadId tid return (wtid, n) labelMe :: String -> IO () labelMe l = do tid <- myThreadId labelThread tid l withHandle :: ThreadManager -> T.TimeoutAction -> (T.Handle -> IO a) -> IO (Maybe a) withHandle (ThreadManager timmgr _) = T.withHandle timmgr #if __GLASGOW_HASKELL__ < 908 fromThreadId :: ThreadId -> Word64 fromThreadId tid = read (drop 9 $ show tid) #endif time-manager-0.2.4/System/TimeManager.hs0000644000000000000000000001756007346545000016276 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE RecordWildCards #-} module System.TimeManager ( -- ** Types Manager, defaultManager, TimeoutAction, Handle, emptyHandle, -- ** Manager initialize, stopManager, killManager, withManager, withManager', -- ** Registering a timeout action withHandle, withHandleKillThread, -- ** Control timeout tickle, pause, resume, -- ** Low level register, registerKillThread, cancel, -- ** Exceptions TimeoutThread (..), ) where import Control.Concurrent (mkWeakThreadId, myThreadId) import qualified Control.Exception as E import Control.Monad (void) import Control.Reaper import Data.IORef (IORef) import qualified Data.IORef as I import Data.Typeable (Typeable) import System.IO.Unsafe import System.Mem.Weak (deRefWeak) ---------------------------------------------------------------- -- | A timeout manager data Manager = Manager (Reaper [Handle] Handle) | NoManager -- | No manager. defaultManager :: Manager defaultManager = NoManager -- | An action to be performed on timeout. type TimeoutAction = IO () -- | A handle used by a timeout manager. data Handle = Handle { handleManager :: Manager , handleActionRef :: IORef TimeoutAction , handleStateRef :: IORef State } {-# NOINLINE emptyAction #-} emptyAction :: IORef TimeoutAction emptyAction = unsafePerformIO $ I.newIORef (return ()) {-# NOINLINE emptyState #-} emptyState :: IORef State emptyState = unsafePerformIO $ I.newIORef Inactive emptyHandle :: Handle emptyHandle = Handle { handleManager = NoManager , handleActionRef = emptyAction , handleStateRef = emptyState } 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 microseconds -- where N is the first argument. initialize :: Int -> IO Manager initialize timeout | timeout <= 0 = return NoManager initialize timeout = Manager <$> mkReaper defaultReaperSettings { -- Data.Set cannot be used since 'partition' cannot be used -- with 'readIORef`. So, let's just use a list. reaperAction = mkListAction prune , reaperDelay = timeout , reaperThreadName = "WAI timeout manager (Reaper)" } where prune m@Handle{..} = do state <- I.atomicModifyIORef' handleStateRef (\x -> (inactivate x, x)) case state of Inactive -> do onTimeout <- I.readIORef handleActionRef onTimeout `E.catch` ignoreSync return Nothing _ -> return $ Just m inactivate Active = Inactive inactivate x = x ---------------------------------------------------------------- -- | Stopping timeout manager with onTimeout fired. stopManager :: Manager -> IO () stopManager NoManager = return () stopManager (Manager mgr) = E.mask_ (reaperStop mgr >>= mapM_ fire) where fire Handle{..} = do onTimeout <- I.readIORef handleActionRef onTimeout `E.catch` ignoreSync -- | Killing timeout manager immediately without firing onTimeout. killManager :: Manager -> IO () killManager NoManager = return () killManager (Manager mgr) = reaperKill mgr ---------------------------------------------------------------- -- | Registering a timeout action and unregister its handle -- when the body action is finished. -- 'Nothing' is returned on timeout. withHandle :: Manager -> TimeoutAction -> (Handle -> IO a) -> IO (Maybe a) withHandle mgr onTimeout action = E.handle ignore $ E.bracket (register mgr onTimeout) cancel $ \th -> Just <$> action th where ignore TimeoutThread = return Nothing -- | 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 ignore $ E.bracket (registerKillThread mgr onTimeout) cancel action where ignore TimeoutThread = return () ---------------------------------------------------------------- -- | Registering a timeout action. register :: Manager -> TimeoutAction -> IO Handle register NoManager _ = return emptyHandle register m@(Manager mgr) !onTimeout = do actionRef <- I.newIORef onTimeout stateRef <- I.newIORef Active let h = Handle { handleManager = m , handleActionRef = actionRef , handleStateRef = stateRef } reaperAdd mgr h return h -- | Removing the 'Handle' from the 'Manager' immediately. cancel :: Handle -> IO () cancel Handle{..} = case handleManager of NoManager -> return () Manager mgr -> void $ reaperModify mgr filt 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 _ _ ref) : hs) | handleStateRef == ref = hs | otherwise = let !hs' = filt hs in h : hs' ---------------------------------------------------------------- -- | 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" -- | Registering a timeout action of killing this thread. -- 'TimeoutThread' is thrown to the thread which called this -- function on timeout. Catch 'TimeoutThread' if you don't -- want to leak the asynchronous exception to GHC RTS. registerKillThread :: Manager -> TimeoutAction -> IO Handle registerKillThread m onTimeout = do tid <- myThreadId wtid <- mkWeakThreadId tid -- 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{..} = I.writeIORef handleStateRef Active -- | Setting the state to paused. -- 'Manager' does not change the value. pause :: Handle -> IO () pause Handle{..} = I.writeIORef handleStateRef Paused -- | Setting the paused state to active. -- This is an alias to 'tickle'. resume :: Handle -> IO () resume = tickle ---------------------------------------------------------------- -- | 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 -- | 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 ---------------------------------------------------------------- isAsyncException :: E.Exception e => e -> Bool isAsyncException e = case E.fromException (E.toException e) of Just (E.SomeAsyncException _) -> True Nothing -> False ignoreSync :: E.SomeException -> IO () ignoreSync se | isAsyncException se = E.throwIO se | otherwise = return () time-manager-0.2.4/time-manager.cabal0000644000000000000000000000172207346545000015610 0ustar0000000000000000Name: time-manager Version: 0.2.4 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 and thread management functions to prevent thread leak by a thread manager. Extra-Source-Files: ChangeLog.md Library Build-Depends: base >= 4.12 && < 5 , auto-update >= 0.2 && < 0.3 , containers , stm Default-Language: Haskell2010 Exposed-modules: System.TimeManager Exposed-modules: System.ThreadManager Ghc-Options: -Wall