control-timeout 0.1 → 0.1.1

raw patch · 2 files changed

+34/−13 lines, 2 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• Control/Timeout.hs +32/−10
• control-timeout.cabal +2/−3

@@ -6,6 +6,7 @@ -- The number of threads used is constant. module Control.Timeout (      addTimeout+   , addTimeoutAtomic    , cancelTimeout    , TimeoutTag) where @@ -119,17 +120,38 @@ addTimeout :: Float  -- ^ the number of seconds in the future to perform the action            -> (IO ())  -- ^ the action to perform            -> IO TimeoutTag-addTimeout delta action = do+addTimeout delta action =+  addTimeoutAtomic delta action >>= atomically++-- | Similar in function to addTimeout above, this call splits the IO and STM+--   parts of the process so that a timeout can be added atomically. Consider+--   the following code:+--+--      * We add a timeout with an action which reads from a global TVar+--+--      * We add the TimeoutTag (in case we wish to handle the timeout) and+--        some bookkeeping data to the global TVar and trigger some external+--        action (i.e. a network request)+--+--  In this case, the timeout could occur before the bookkeeping is added. Now+--  the timeout code won't find the correct state. If we switch the two actions+--  then we don't have the TimeoutTag to add to the bookkeeping structure and we+--  would need another TVar, or some such, to fill in later.+addTimeoutAtomic :: Float  -- ^ the number of seconds in the future to perform the action+                 -> (IO ())  -- ^ the action to perform+                 -> IO (STM TimeoutTag)  -- ^ an action to add the timeout and return the tag+addTimeoutAtomic delta action = do   currentTime <- getPOSIXTime   let future = currentTime + (fromRational $ toRational delta)-  tag <- atomically (do-    m <- readTVar timeouts-    case Map.lookup future m of-         Nothing -> do writeTVar timeouts $ Map.insert future [(0, action)] m-                       return $ TimeoutTag (future, 0)-         Just xs -> do let magic = 1 + (maximum $ map fst xs)-                       writeTVar timeouts $ Map.insert future ((magic, action) : xs) m-                       return $ TimeoutTag (future, magic))+      stmAction :: STM TimeoutTag+      stmAction = do+        m <- readTVar timeouts+        case Map.lookup future m of+             Nothing -> do writeTVar timeouts $ Map.insert future [(0, action)] m+                           return $ TimeoutTag (future, 0)+             Just xs -> do let magic = 1 + (maximum $ map fst xs)+                           writeTVar timeouts $ Map.insert future ((magic, action) : xs) m+                           return $ TimeoutTag (future, magic)   -- If the manager thread isn't running, start it now.   startp <- atomically (do     started <- readTVar managerThreadStarted@@ -137,7 +159,7 @@     return $ not started)   when startp $ forkIO (timeoutManagerThread timeouts signal 0 Nothing) >> return () -  return tag+  return stmAction  -- | Remove a timeout. This function never fails, but will return False if the --   given timeout couldn't be found. This may be because cancelTimeout has

@@ -1,5 +1,5 @@ name:            control-timeout-version:         0.1+version:         0.1.1 license:         BSD3 license-file:    LICENSE author:          Adam Langley <agl@imperialviolet.org>@@ -8,7 +8,6 @@ category:        Control build-depends:   base, containers, time, stm stability:       provisional-tested-with:     GHC == 6.8.1+tested-with:     GHC == 6.8.2 exposed-modules: Control.Timeout-ghc-options:     -O2 extra-source-files: test/TimeoutTest.hs