time-manager (empty) → 0.0.0

raw patch · 4 files changed

+193/−0 lines, 4 filesdep +auto-updatedep +basesetup-changed

Dependencies added: auto-update, base

Files

• LICENSE +20/−0
• Setup.hs +2/−0
• System/TimeManager.hs +152/−0
• time-manager.cabal +19/−0

@@ -0,0 +1,20 @@+Copyright (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.

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

@@ -0,0 +1,152 @@+{-# LANGUAGE DeriveDataTypeable #-}++module System.TimeManager (+  -- ** Types+    Manager+  , TimeoutAction+  , Handle+  -- ** Manager+  , initialize+  , stopManager+  , killManager+  , withManager+  -- ** Registration+  , register+  , registerKillThread+  -- ** Control+  , tickle+  , cancel+  , pause+  , resume+  -- ** Exceptions+  , TimeoutThread (..)+  ) where++import Control.Concurrent (myThreadId)+import qualified Control.Exception as E+import Control.Reaper+import Data.Typeable (Typeable)+import Data.IORef (IORef)+import qualified Data.IORef as I++----------------------------------------------------------------++-- | A timeout manager+type Manager = Reaper [Handle] Handle++-- | An action to be performed on timeout.+type TimeoutAction = IO ()++-- | A handle used by 'Manager'+data Handle = Handle !(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.++----------------------------------------------------------------++-- | 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+        }+  where+    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++    inactivate Active = Inactive+    inactivate x = x++----------------------------------------------------------------++-- | Stopping timeout manager with onTimeout fired.+stopManager :: Manager -> IO ()+stopManager mgr = E.mask_ (reaperStop mgr >>= mapM_ fire)+  where+    fire (Handle actionRef _) = do+        onTimeout <- I.readIORef actionRef+        onTimeout `E.catch` ignoreAll++ignoreAll :: E.SomeException -> IO ()+ignoreAll _ = return ()++-- | Killing timeout manager immediately without firing onTimeout.+killManager :: Manager -> IO ()+killManager = reaperKill++----------------------------------------------------------------++-- | Registering a timeout action.+register :: Manager -> TimeoutAction -> IO Handle+register mgr onTimeout = do+    actionRef <- I.newIORef onTimeout+    stateRef  <- I.newIORef Active+    let h = Handle actionRef stateRef+    reaperAdd mgr h+    return h++-- | Registering a timeout action of killing this thread.+registerKillThread :: Manager -> TimeoutAction -> IO Handle+registerKillThread m onTimeout = do+    -- If we hold ThreadId, the stack and data of the thread is leaked.+    -- If we hold Weak ThreadId, the stack is released. However, its+    -- data is still leaked probably because of a bug of GHC.+    -- So, let's just use ThreadId and release ThreadId by+    -- overriding the timeout action by "cancel".+    tid <- myThreadId+    -- First run the timeout action in case the child thread is masked.+    register m $ onTimeout `E.finally` E.throwTo tid TimeoutThread++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"++----------------------------------------------------------------++-- | Setting the state to active.+--   'Manager' turns active to inactive repeatedly.+tickle :: Handle -> IO ()+tickle (Handle _ stateRef) = I.writeIORef stateRef Active++-- | Setting the state to canceled.+--   'Manager' eventually removes this without timeout action.+cancel :: Handle -> IO ()+cancel (Handle actionRef stateRef) = do+    I.writeIORef actionRef (return ()) -- ensuring to release ThreadId+    I.writeIORef stateRef Canceled++-- | Setting the state to paused.+--   'Manager' does not change the value.+pause :: Handle -> IO ()+pause (Handle _ stateRef) = I.writeIORef stateRef 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.+withManager :: Int -- ^ timeout in microseconds+            -> (Manager -> IO a)+            -> IO a+withManager timeout f = do+    -- FIXME when stopManager is available, use it+    man <- initialize timeout+    f man

@@ -0,0 +1,19 @@+Name:                time-manager+Version:             0.0.0+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.8+Stability:           Stable+Description:         Scalable timer functions provided by a timer manager.++Library+  Build-Depends:     base                      >= 4.8        && < 5+                   , auto-update+  Exposed-modules:   System.TimeManager+  Ghc-Options:       -Wall