This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "snap-server".
The branch, master has been updated
via d0783a072d3730e5ca19aab7858dbf91f3d838ff (commit)
from 0a4102ab961911136a683471d6dea9ac110734a3 (commit)
Summary of changes:
src/Snap/Internal/Http/Server/TimeoutManager.hs | 170 ++++++++++++++++++++
.../Internal/Http/Server/TimeoutManager/Tests.hs | 76 +++++++++
2 files changed, 246 insertions(+), 0 deletions(-)
create mode 100644 src/Snap/Internal/Http/Server/TimeoutManager.hs
create mode 100644 test/suite/Snap/Internal/Http/Server/TimeoutManager/Tests.hs
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.
- Log -----------------------------------------------------------------
commit d0783a072d3730e5ca19aab7858dbf91f3d838ff
Author: Gregory Collins <[email protected]>
Date: Sun Mar 20 19:15:03 2011 +0100
...it helps if you actually check in the files
diff --git a/src/Snap/Internal/Http/Server/TimeoutManager.hs
b/src/Snap/Internal/Http/Server/TimeoutManager.hs
new file mode 100644
index 0000000..dee1093
--- /dev/null
+++ b/src/Snap/Internal/Http/Server/TimeoutManager.hs
@@ -0,0 +1,170 @@
+{-# LANGUAGE BangPatterns #-}
+
+module Snap.Internal.Http.Server.TimeoutManager
+ ( TimeoutManager
+ , TimeoutHandle
+ , initialize
+ , stop
+ , register
+ , tickle
+ , cancel
+ ) where
+
+------------------------------------------------------------------------------
+import Control.Concurrent
+import Control.Exception
+import Control.Monad
+import Data.IORef
+import Foreign.C.Types
+
+------------------------------------------------------------------------------
+data State = Deadline !CTime
+ | Canceled
+
+
+------------------------------------------------------------------------------
+data TimeoutHandle = TimeoutHandle {
+ _killAction :: !(IO ())
+ , _state :: !(IORef State)
+ , _hGetTime :: !(IO CTime)
+ }
+
+
+------------------------------------------------------------------------------
+data TimeoutManager = TimeoutManager {
+ _defaultTimeout :: !Int
+ , _getTime :: !(IO CTime)
+ , _connections :: !(IORef [TimeoutHandle])
+ , _inactivity :: !(IORef Bool)
+ , _morePlease :: !(MVar ())
+ , _managerThread :: !(MVar ThreadId)
+ }
+
+
+------------------------------------------------------------------------------
+-- | Create a new TimeoutManager.
+initialize :: Int -- ^ default timeout
+ -> IO CTime -- ^ function to get current time
+ -> IO TimeoutManager
+initialize defaultTimeout getTime = do
+ conns <- newIORef []
+ inact <- newIORef False
+ mp <- newEmptyMVar
+ mthr <- newEmptyMVar
+
+ let tm = TimeoutManager defaultTimeout getTime conns inact mp mthr
+
+ thr <- forkIO $ managerThread tm
+ putMVar mthr thr
+ return tm
+
+
+------------------------------------------------------------------------------
+-- | Stop a TimeoutManager.
+stop :: TimeoutManager -> IO ()
+stop tm = readMVar (_managerThread tm) >>= killThread
+
+
+------------------------------------------------------------------------------
+-- | Register a new connection with the TimeoutManager.
+register :: IO () -- ^ action to run when the timeout deadline is
+ -- exceeded.
+ -> TimeoutManager -- ^ manager to register with.
+ -> IO TimeoutHandle
+register killAction tm = do
+ now <- getTime
+ let !state = Deadline $ now + toEnum defaultTimeout
+ stateRef <- newIORef state
+
+ let !h = TimeoutHandle killAction stateRef getTime
+ atomicModifyIORef connections $ \x -> (h:x, ())
+
+ inact <- readIORef inactivity
+ when inact $ do
+ -- wake up manager thread
+ writeIORef inactivity False
+ _ <- tryPutMVar morePlease ()
+ return ()
+ return h
+
+ where
+ getTime = _getTime tm
+ inactivity = _inactivity tm
+ morePlease = _morePlease tm
+ connections = _connections tm
+ defaultTimeout = _defaultTimeout tm
+
+
+------------------------------------------------------------------------------
+-- | Tickle the timeout on a connection to be N seconds into the future.
+tickle :: TimeoutHandle -> Int -> IO ()
+tickle th n = do
+ now <- getTime
+
+ let state = Deadline $ now + toEnum n
+ writeIORef stateRef state
+
+ where
+ getTime = _hGetTime th
+ stateRef = _state th
+
+
+------------------------------------------------------------------------------
+-- | Cancel a timeout.
+cancel :: TimeoutHandle -> IO ()
+cancel h = writeIORef (_state h) Canceled
+
+
+------------------------------------------------------------------------------
+managerThread :: TimeoutManager -> IO ()
+managerThread tm = loop `finally` (readIORef connections >>= destroyAll)
+ where
+ --------------------------------------------------------------------------
+ connections = _connections tm
+ getTime = _getTime tm
+ inactivity = _inactivity tm
+ morePlease = _morePlease tm
+ waitABit = threadDelay 5000000
+
+ --------------------------------------------------------------------------
+ loop = do
+ waitABit
+ handles <- atomicModifyIORef connections (\x -> ([],x))
+
+ if null handles
+ then do
+ -- we're inactive, go to sleep until we get new threads
+ writeIORef inactivity True
+ takeMVar morePlease
+ else do
+ now <- getTime
+ dlist <- processHandles now handles id
+ atomicModifyIORef connections (\x -> (dlist x, ()))
+
+ loop
+
+ --------------------------------------------------------------------------
+ processHandles !now handles initDlist = go handles initDlist
+ where
+ go [] !dlist = return dlist
+
+ go (x:xs) !dlist = do
+ state <- readIORef $ _state x
+ !dlist' <- case state of
+ Canceled -> return dlist
+ Deadline t -> if t <= now
+ then do
+ _killAction x
+ return dlist
+ else return (dlist . (x:))
+ go xs dlist'
+
+ --------------------------------------------------------------------------
+ destroyAll = mapM_ diediedie
+
+ --------------------------------------------------------------------------
+ diediedie x = do
+ state <- readIORef $ _state x
+ case state of
+ Canceled -> return ()
+ _ -> _killAction x
diff --git a/test/suite/Snap/Internal/Http/Server/TimeoutManager/Tests.hs
b/test/suite/Snap/Internal/Http/Server/TimeoutManager/Tests.hs
new file mode 100644
index 0000000..d90f6cb
--- /dev/null
+++ b/test/suite/Snap/Internal/Http/Server/TimeoutManager/Tests.hs
@@ -0,0 +1,76 @@
+module Snap.Internal.Http.Server.TimeoutManager.Tests
+ ( tests ) where
+
+import Control.Concurrent
+import Data.IORef
+import Data.Maybe
+import System.PosixCompat.Time
+import System.Timeout
+import Test.Framework
+import Test.Framework.Providers.HUnit
+import Test.HUnit hiding (Test, path)
+
+import qualified Snap.Internal.Http.Server.TimeoutManager as TM
+
+tests :: [Test]
+tests = [ testOneTimeout
+ , testOneTimeoutAfterInactivity
+ , testCancel
+ , testTickle ]
+
+
+testOneTimeout :: Test
+testOneTimeout = testCase "timeout/oneTimeout" $ do
+ mgr <- TM.initialize 3 epochTime
+ oneTimeout mgr
+
+
+testOneTimeoutAfterInactivity :: Test
+testOneTimeoutAfterInactivity =
+ testCase "timeout/oneTimeoutAfterInactivity" $ do
+ mgr <- TM.initialize 3 epochTime
+ threadDelay $ 7 * seconds
+ oneTimeout mgr
+
+oneTimeout :: TM.TimeoutManager -> IO ()
+oneTimeout mgr = do
+ mv <- newEmptyMVar
+ _ <- TM.register (putMVar mv ()) mgr
+ m <- timeout (6*seconds) $ takeMVar mv
+ assertBool "timeout fired" $ isJust m
+ TM.stop mgr
+
+
+testTickle :: Test
+testTickle = testCase "timeout/tickle" $ do
+ mgr <- TM.initialize 8 epochTime
+ ref <- newIORef (0 :: Int)
+ h <- TM.register (writeIORef ref 1) mgr
+ threadDelay $ 5 * seconds
+ b0 <- readIORef ref
+ assertEqual "b0" 0 b0
+ TM.tickle h 8
+ threadDelay $ 5 * seconds
+ b1 <- readIORef ref
+ assertEqual "b1" 0 b1
+ threadDelay $ 8 * seconds
+ b2 <- readIORef ref
+ assertEqual "b2" 1 b2
+ TM.stop mgr
+
+
+testCancel :: Test
+testCancel = testCase "timeout/cancel" $ do
+ mgr <- TM.initialize 3 epochTime
+ ref <- newIORef (0 :: Int)
+ h <- TM.register (writeIORef ref 1) mgr
+ threadDelay $ 1 * seconds
+ TM.cancel h
+ threadDelay $ 5 * seconds
+ b0 <- readIORef ref
+ assertEqual "b0" 0 b0
+ TM.stop mgr
+
+
+seconds :: Int
+seconds = (10::Int) ^ (6::Int)
-----------------------------------------------------------------------
hooks/post-receive
--
snap-server
_______________________________________________
Snap mailing list
[email protected]
http://mailman-mail5.webfaction.com/listinfo/snap
