packages feed

stm-delay (empty) → 0.1

raw patch · 5 files changed

+420/−0 lines, 5 filesdep +basedep +stmdep +stm-delaysetup-changed

Dependencies added: base, stm, stm-delay

Files

+ Control/Concurrent/STM/Delay.hs view
@@ -0,0 +1,217 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE Rank2Types #-}+-- |+-- Module:      Control.Concurrent.STM.Delay+-- Copyright:   (c) Joseph Adams 2012+-- License:     BSD3+-- Maintainer:  joeyadams3.14159@gmail.com+-- Portability: Requires GHC 7++--+-- One-shot timer whose duration can be updated+--+-- Suppose you are managing a network connection, and want to time it out if no+-- messages are received in over five minutes.  You can do something like this:+--+-- >import Control.Concurrent.Async (race_) -- from the async package+-- >import Control.Concurrent.STM+-- >import Control.Concurrent.STM.Delay+-- >import Control.Exception+-- >import Control.Monad+-- >+-- >manageConnection :: Connection -> IO Message -> (Message -> IO a) -> IO ()+-- >manageConnection conn toSend onRecv =+-- >    bracket (newDelay five_minutes) cancelDelay $ \delay ->+-- >    foldr1 race_+-- >        [ do atomically $ waitDelay delay+-- >             fail "Connection timed out"+-- >        , forever $ toSend >>= send conn+-- >        , forever $ do+-- >            msg <- recv conn+-- >            updateDelay delay five_minutes+-- >            onRecv msg+-- >        ]+-- >  where+-- >    five_minutes = 5 * 60 * 1000000+module Control.Concurrent.STM.Delay (+    -- * Managing delays+    Delay,+    newDelay,+    updateDelay,+    cancelDelay,++    -- * Waiting for expiration+    waitDelay,+    tryWaitDelay,+) where++import Control.Applicative      ((<$>))+import Control.Concurrent+import Control.Concurrent.STM+import Control.Exception        (mask_)+import Control.Monad            (join)++#if MIN_VERSION_base(4,4,0) && !mingw32_HOST_OS+import qualified GHC.Event as Ev+#endif++-- | A 'Delay' is an updatable timer that rings only once.+data Delay = forall k.+             Delay !(TVar Bool)+                   !(DelayImpl k)+                   !k++instance Eq Delay where+    (==) (Delay a _ _) (Delay b _ _) = a == b++type TimeoutCallback = IO ()++data DelayImpl k = DelayImpl+    { delayStart  :: Int -> TimeoutCallback -> IO k+    , delayUpdate :: TimeoutCallback -> k -> Int -> IO ()+    , delayStop   :: k -> IO ()+    }++-- | Create a new 'Delay' that will ring in the given number of microseconds.+newDelay :: Int -> IO Delay+newDelay t = getDelayImpl (\impl -> newDelayWith impl t)++newDelayWith :: DelayImpl k -> Int -> IO Delay+newDelayWith impl t = do+    var <- newTVarIO False+    k   <- delayStart impl t $ atomically $ writeTVar var True+    return (Delay var impl k)++-- | Set an existing 'Delay' to ring in the given number of microseconds+-- (from the time 'updateDelay' is called), rather than when it was going to+-- ring.  If the 'Delay' has already rung, do nothing.+updateDelay :: Delay -> Int -> IO ()+updateDelay (Delay var impl k) t =+    delayUpdate impl (atomically $ writeTVar var True) k t++-- | Set a 'Delay' so it will never ring, even if 'updateDelay' is used later.+-- If the 'Delay' has already rung, do nothing.+cancelDelay :: Delay -> IO ()+cancelDelay (Delay _var impl k) =+    delayStop impl k++-- | Block until the 'Delay' rings.  If the 'Delay' has already rung,+-- return immediately.+waitDelay :: Delay -> STM ()+waitDelay delay = do+    expired <- tryWaitDelay delay+    if expired then return ()+               else retry++-- | Non-blocking version of 'waitDelay'.+-- Return 'True' if the 'Delay' has rung.+tryWaitDelay :: Delay -> STM Bool+tryWaitDelay (Delay v _ _) = readTVar v++------------------------------------------------------------------------+-- Drivers++getDelayImpl :: (forall k. DelayImpl k -> IO r) -> IO r+#if MIN_VERSION_base(4,4,0) && !mingw32_HOST_OS+getDelayImpl cont = do+    m <- Ev.getSystemEventManager+    case m of+        Nothing  -> cont implThread+        Just mgr -> cont (implEvent mgr)+#else+getDelayImpl cont = cont implThread+#endif++#if MIN_VERSION_base(4,4,0) && !mingw32_HOST_OS+-- | Use the timeout API in "GHC.Event"+implEvent :: Ev.EventManager -> DelayImpl Ev.TimeoutKey+implEvent mgr = DelayImpl+    { delayStart  = Ev.registerTimeout mgr+    , delayUpdate = \_ -> Ev.updateTimeout mgr+    , delayStop   = Ev.unregisterTimeout mgr+    }+#endif++-- | Use threads and threadDelay:+--+--  [delayStart] Fork a thread to wait the given length of time,+--               then set the TVar.+--+--  [delayUpdate] Stop the existing thread and fork a new thread.+--+--  [delayStop] Stop the existing thread.+implThread :: DelayImpl (MVar (Maybe TimeoutThread))+implThread = DelayImpl+    { delayStart  = \t io -> forkTimeoutThread t io >>= newMVar . Just+    , delayUpdate = \io mv t -> replaceThread (Just <$> forkTimeoutThread t io) mv+    , delayStop   = replaceThread (return Nothing)+    }+  where+    replaceThread new mv =+        join $ mask_ $ do+            m <- takeMVar mv+            case m of+                Nothing -> do+                    -- Don't create a new timer thread after the 'Delay' has+                    -- been canceled.  Otherwise, the behavior is inconsistent+                    -- with GHC.Event.+                    putMVar mv Nothing+                    return (return ())+                Just tt -> do+                    m' <- stopTimeoutThread tt+                    new >>= putMVar mv+                    return $ case m' of+                        Nothing   -> return ()+                        Just kill -> kill++------------------------------------------------------------------------+-- TimeoutThread++data TimeoutThread = TimeoutThread !ThreadId !(MVar ())++-- instance Eq TimeoutThread where+--     (==) (TimeoutThread a _) (TimeoutThread b _) = a == b+-- instance Ord TimeoutThread where+--     compare (TimeoutThread a _) (TimeoutThread b _) = compare a b++-- | Fork a thread to perform an action after the given number of+-- microseconds.+--+-- 'forkTimeoutThread' is non-interruptible.+forkTimeoutThread :: Int -> IO () -> IO TimeoutThread+forkTimeoutThread t io = do+    mv <- newMVar ()+    tid <- compat_forkIOUnmasked $ do+        threadDelay t+        m <- tryTakeMVar mv+        -- If m is Just, this thread will not be interrupted,+        -- so no need for a 'mask' between the tryTakeMVar and the action.+        case m of+            Nothing -> return ()+            Just _  -> io+    return (TimeoutThread tid mv)++-- | Prevent the 'TimeoutThread' from performing its action.  If it's too late,+-- return 'Nothing'.  Otherwise, return an action (namely, 'killThread') for+-- cleaning up the underlying thread.+--+-- 'stopTimeoutThread' has a nice property: it is /non-interruptible/.+-- This means that, in an exception 'mask', it will not poll for exceptions.+-- See "Control.Exception" for more info.+--+-- However, the action returned by 'stopTimeoutThread' /does/ poll for+-- exceptions.  That's why 'stopTimeoutThread' returns this action rather than+-- simply doing it.  This lets the caller do it outside of a critical section.+stopTimeoutThread :: TimeoutThread -> IO (Maybe (IO ()))+stopTimeoutThread (TimeoutThread tid mv) =+    maybe Nothing (\_ -> Just (killThread tid)) <$> tryTakeMVar mv++------------------------------------------------------------------------+-- Compatibility++compat_forkIOUnmasked :: IO () -> IO ThreadId+#if MIN_VERSION_base(4,4,0)+compat_forkIOUnmasked io = forkIOWithUnmask (\_ -> io)+#else+compat_forkIOUnmasked = forkIOUnmasked+#endif
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2012, Joseph Adams++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Joseph Adams nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ stm-delay.cabal view
@@ -0,0 +1,76 @@+name:               stm-delay+version:            0.1+synopsis:           Updatable one-shot timer polled with STM+description:+    This library lets you create a one-shot timer, poll it using STM,+    and update it to ring at a different time than initially specified.+    .+    It uses GHC event manager timeouts when available (GHC 7.2+, @-threaded@,+    non-Windows OS), yielding performance similar to @threadDelay@ and+    @registerDelay@.  Otherwise, it falls back to forked threads and+    @threadDelay@.+homepage:           https://github.com/joeyadams/haskell-stm-delay+license:            BSD3+license-file:       LICENSE+author:             Joey Adams+maintainer:         joeyadams3.14159@gmail.com+copyright:          Copyright (c) Joseph Adams 2012+category:           System+build-type:         Simple+cabal-version:      >= 1.8++source-repository head+    type:       git+    location:   git://github.com/joeyadams/haskell-stm-delay.git++library+    exposed-modules:+        Control.Concurrent.STM.Delay++    ghc-options: -Wall -fwarn-tabs++    build-depends: base >= 4.3 && < 5+                 , stm++    -- Need base >= 4.3 for:+    --+    --  * Control.Exception.mask+    --+    --  * forkIOUnmasked+    --+    --  * A threadDelay that doesn't give (-1) magic treatment.+    --    See http://hackage.haskell.org/trac/ghc/ticket/2892+    --+    --  * GHC.Event (called System.Event in base 4.3)++test-suite test+    type: exitcode-stdio-1.0++    hs-source-dirs: test+    main-is: Main.hs++    ghc-options: -Wall+                 -fno-warn-missing-signatures+                 -fno-warn-name-shadowing+                 -fno-warn-unused-do-bind+                 -fno-warn-unused-matches++    build-depends: base >= 4.3 && < 5+                 , stm+                 , stm-delay++test-suite test-threaded+    type: exitcode-stdio-1.0++    hs-source-dirs: test+    main-is: Main.hs++    ghc-options: -Wall -threaded+                 -fno-warn-missing-signatures+                 -fno-warn-name-shadowing+                 -fno-warn-unused-do-bind+                 -fno-warn-unused-matches++    build-depends: base >= 4.3 && < 5+                 , stm+                 , stm-delay
+ test/Main.hs view
@@ -0,0 +1,95 @@+{-# LANGUAGE CPP #-}++import Control.Concurrent+import Control.Concurrent.STM+import Control.Concurrent.STM.Delay++main = trivial++trivial = do+    let new t = do+            delay <- newDelay t+            return (delay, atomically $ tryWaitDelay delay)++    -- The delay times out at the right time, and after tryWaitDelay returns+    -- 'True', 'updateDelay' and 'cancelDelay' have no observable effect.+    (delay, wait) <- new 100000+    False <- wait+    threadDelay 50000+    False <- wait+    threadDelay 60000+    True <- wait+    updateDelay delay 1000000+    True <- wait+    updateDelay delay (-1)+    True <- wait+    cancelDelay delay+    True <- wait++    (delay, wait) <- new 100000+    False <- wait+    threadDelay 50000+    False <- wait+    updateDelay delay 200000+    threadDelay 60000+    False <- wait+    threadDelay 60000+    False <- wait   -- updateDelay sets the timer based on the current time,+                    -- so the threadDelay 50000 doesn't count toward our total.+    threadDelay 81000+    True <- wait++    -- 'newDelay n' where n <= 0 times out immediately,+    -- rather than never timing out.+    (delay, wait) <- new 0+    threadDelay 100+    True <- wait+    (delay, wait) <- new (-1)+    threadDelay 100+    True <- wait++    -- This fails on Windows without -threaded, as 'threadDelay minBound'+    -- blocks.  It also fails on Linux using GHC 7.0.3 without -threaded.+#if !mingw32_HOST_OS && MIN_VERSION_base(4,4,0)+    (delay, wait) <- new minBound+    threadDelay 1000+    True <- wait+#endif++    -- 'newDelay maxBound' doesn't time out any time soon,+    -- and updateDelay doesn't wait for the delay to complete.+    --+    -- Using maxBound currently fails on Linux 64-bit (see GHC ticket #7325),+    -- so use a more lenient value for now.+    --+    -- (delay, wait) <- new maxBound+    (delay, wait) <- new 2147483647+    False <- wait+    threadDelay 100000+    False <- wait+    updateDelay delay 100000+    threadDelay 90000+    False <- wait+    threadDelay 10010+    True <- wait++    -- cancelDelay causes the delay to miss its initial deadline,+    -- and a subsequent updateDelay has no effect.+    (delay, wait) <- new 100000+    False <- wait+    threadDelay 50000+    False <- wait+    cancelDelay delay+    False <- wait+    threadDelay 60000+    False <- wait+    updateDelay delay 10000+    False <- wait+    threadDelay 20000+    False <- wait+    cancelDelay delay+    False <- wait+    threadDelay 100000+    False <- wait++    return ()