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, 0.2-stable has been updated
via cffe676e2f69993c1939f8493a1185f6e1bc9ee6 (commit)
via c1edb516e1c4f9a90bfb6f8b16a1d89416eb1721 (commit)
via 077eef44d017b7afd83acc1812d1a280d77a992b (commit)
via 57b0f80fffce025dfbd98ee7d514a77fcd1c439f (commit)
from d0e48d9ff63accab80c168b63e3ae7fd99d555bc (commit)
Summary of changes:
snap-server.cabal | 6 +-
src/Data/Concurrent/HashMap.hs | 3 +-
src/Snap/Internal/Http/Server/SimpleBackend.hs | 129 ++++++++++--------------
test/snap-server-testsuite.cabal | 6 +-
4 files changed, 60 insertions(+), 84 deletions(-)
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 cffe676e2f69993c1939f8493a1185f6e1bc9ee6
Author: Gregory Collins <[email protected]>
Date: Mon Oct 25 19:51:18 2010 +0200
Simple backend: move the timeout table to a higher-performance concurrent
data structure
diff --git a/src/Data/Concurrent/HashMap.hs b/src/Data/Concurrent/HashMap.hs
index 157d208..8c04abe 100644
--- a/src/Data/Concurrent/HashMap.hs
+++ b/src/Data/Concurrent/HashMap.hs
@@ -17,7 +17,8 @@ module Data.Concurrent.HashMap
, toList
, hashString
, hashBS
- , hashInt ) where
+ , hashInt
+ , nextHighestPowerOf2 ) where
------------------------------------------------------------------------------
diff --git a/src/Snap/Internal/Http/Server/SimpleBackend.hs
b/src/Snap/Internal/Http/Server/SimpleBackend.hs
index 657ddc2..739ca4c 100644
--- a/src/Snap/Internal/Http/Server/SimpleBackend.hs
+++ b/src/Snap/Internal/Http/Server/SimpleBackend.hs
@@ -1,11 +1,11 @@
-{-# LANGUAGE BangPatterns #-}
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE ForeignFunctionInterface #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE RankNTypes #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE PackageImports #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE PackageImports #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
module Snap.Internal.Http.Server.SimpleBackend
( Backend
@@ -37,23 +37,20 @@ import Control.Monad
import Data.ByteString (ByteString)
import Data.ByteString.Internal (c2w, w2c)
import qualified Data.ByteString as B
-import Data.DList (DList)
-import qualified Data.DList as D
-import Data.IORef
import Data.Iteratee.WrappedByteString
-import Data.List (foldl')
-import qualified Data.PSQueue as PSQ
-import Data.PSQueue (PSQ)
import Data.Typeable
+import Data.Word
import Foreign hiding (new)
-import Foreign.C.Types (CTime)
import GHC.Conc (labelThread, forkOnIO)
import Network.Socket
import qualified Network.Socket.ByteString as SB
import Prelude hiding (catch)
------------------------------------------------------------------------------
+import Data.Concurrent.HashMap (hashString)
import Snap.Internal.Debug
import Snap.Internal.Http.Server.Date
+import qualified Snap.Internal.Http.Server.TimeoutTable as TT
+import Snap.Internal.Http.Server.TimeoutTable (TimeoutTable)
import Snap.Iteratee hiding (foldl')
#if defined(HAS_SENDFILE)
@@ -71,26 +68,29 @@ instance Show BackendTerminatedException where
instance Exception BackendTerminatedException
-type TimeoutTable = PSQ ThreadId CTime
+------------------------------------------------------------------------------
type QueueElem = Maybe (Socket,SockAddr)
data Backend = Backend
{ _acceptSocket :: !Socket
, _acceptThread :: !ThreadId
- , _timeoutEdits :: !(IORef (DList (TimeoutTable -> TimeoutTable)))
+ , _timeoutTable :: TimeoutTable
, _timeoutThread :: !(MVar ThreadId)
, _connectionQueue :: !(Chan QueueElem)
}
-data Connection = Connection
+data Connection = Connection
{ _backend :: Backend
, _socket :: Socket
, _remoteAddr :: ByteString
, _remotePort :: Int
, _localAddr :: ByteString
, _localPort :: Int
- , _connTid :: MVar ThreadId }
+ , _connTid :: MVar ThreadId
+ , _threadHash :: MVar Word
+ }
+
{-# INLINE name #-}
name :: ByteString
@@ -157,13 +157,12 @@ new :: Socket -- ^ value you got from bindIt
new sock cpu = do
debug $ "Backend.new: listening"
- ed <- newIORef D.empty
+ tt <- TT.new
t <- newEmptyMVar
-
connq <- newChan
accThread <- forkOnIO cpu $ acceptThread sock connq
- let b = Backend sock accThread ed t connq
+ let b = Backend sock accThread tt t connq
tid <- forkIO $ timeoutThread b
putMVar t tid
@@ -173,59 +172,29 @@ new sock cpu = do
timeoutThread :: Backend -> IO ()
timeoutThread backend = do
- tref <- newIORef $ PSQ.empty
- let loop = do
- killTooOld tref
- threadDelay (5000000)
- loop
-
- loop `catch` (\(_::SomeException) -> killAll tref)
+ loop `catch` (\(_::SomeException) -> killAll)
where
- applyEdits table = do
- edits <- atomicModifyIORef tedits $ \t -> (D.empty, D.toList t)
- return $ foldl' (flip ($)) table edits
+ table = _timeoutTable backend
+
+ loop = do
+ debug "timeoutThread: waiting for activity on thread table"
+ TT.waitForActivity table
+ debug "timeoutThread: woke up, killing old connections"
+ killTooOld
+ loop
- killTooOld tref = do
- !table <- readIORef tref
- -- atomic swap edit list
- now <- getCurrentDateTime
- table' <- applyEdits table
- !t' <- killOlderThan now table'
- writeIORef tref t'
+ killTooOld = do
+ now <- getCurrentDateTime
+ TT.killOlderThan (now - tIMEOUT) table
-- timeout = 30 seconds
tIMEOUT = 30
- killAll !tref = do
+ killAll = do
debug "Backend.timeoutThread: shutdown, killing all connections"
- !table <- readIORef tref
- !table' <- applyEdits table
- go table'
- where
- go !t = maybe (return ())
- (\m -> (killThread $ PSQ.key m) >>
- (go $ PSQ.deleteMin t))
- (PSQ.findMin t)
-
- killOlderThan now !table = do
- debug "Backend.timeoutThread: killing old connections"
- let mmin = PSQ.findMin table
- maybe (return table)
- (\m -> do
- debug $ "Backend.timeoutThread: minimum value "
- ++ show (PSQ.prio m) ++ ", cutoff="
- ++ show (now - tIMEOUT)
-
- if now - PSQ.prio m >= tIMEOUT
- then do
- killThread $ PSQ.key m
- killOlderThan now $ PSQ.deleteMin table
- else return table)
- mmin
-
- tedits = _timeoutEdits backend
+ TT.killAll table
stop :: Backend -> IO ()
@@ -286,26 +255,29 @@ withConnection backend cpu proc = do
return (fromIntegral p, B.pack $ map c2w h')
x -> throwIO $ AddressNotSupportedException $ show x
- tmvar <- newEmptyMVar
+ tmvar <- newEmptyMVar
+ thrhash <- newEmptyMVar
- let c = Connection backend sock host port lhost lport tmvar
+ let c = Connection backend sock host port lhost lport tmvar thrhash
tid <- forkOnIO cpu $ do
labelMe $ "connHndl " ++ show fd
bracket (return c)
(\_ -> block $ do
debug "thread killed, closing socket"
- thr <- readMVar tmvar
+ thr <- readMVar tmvar
+ thash <- readMVar thrhash
-- remove thread from timeout table
- atomicModifyIORef (_timeoutEdits backend) $
- \es -> (D.snoc es (PSQ.delete thr), ())
+ TT.delete thash thr $ _timeoutTable backend
+
eatException $ shutdown sock ShutdownBoth
eatException $ sClose sock
)
proc
putMVar tmvar tid
+ putMVar thrhash $ hashString $ show tid
tickleTimeout c
return ()
@@ -364,24 +336,27 @@ instance Exception TimeoutException
tickleTimeout :: Connection -> IO ()
tickleTimeout conn = do
debug "Backend.tickleTimeout"
- now <- getCurrentDateTime
- tid <- readMVar $ _connTid conn
+ now <- getCurrentDateTime
+ tid <- readMVar $ _connTid conn
+ thash <- readMVar $ _threadHash conn
- atomicModifyIORef tedits $ \es -> (D.snoc es (PSQ.insert tid now), ())
+ TT.insert thash tid now table
where
- tedits = _timeoutEdits $ _backend conn
+ table = _timeoutTable $ _backend conn
_cancelTimeout :: Connection -> IO ()
_cancelTimeout conn = do
debug "Backend.cancelTimeout"
- tid <- readMVar $ _connTid conn
- atomicModifyIORef tedits $ \es -> (D.snoc es (PSQ.delete tid), ())
+ tid <- readMVar $ _connTid conn
+ thash <- readMVar $ _threadHash conn
+
+ TT.delete thash tid table
where
- tedits = _timeoutEdits $ _backend conn
+ table = _timeoutTable $ _backend conn
timeoutRecv :: Connection -> Int -> IO ByteString
-----------------------------------------------------------------------
hooks/post-receive
--
snap-server
_______________________________________________
Snap mailing list
[email protected]
http://mailman-mail5.webfaction.com/listinfo/snap
