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 d49aa1bdffa623fec97b6a0a087908382fff027d (commit)
from 1759bf85decea74b83a5d0035f7b05a5bae8e5cf (commit)
Summary of changes:
src/Snap/Internal/Http/Server/LibevBackend.hs | 86 ++++++++++++++++---------
test/common/Snap/Test/Common.hs | 43 ++++++++++++-
test/runTestsAndCoverage.sh | 5 +-
test/suite/Snap/Internal/Http/Server/Tests.hs | 55 +++++++++++++++-
test/suite/Test/Blackbox.hs | 36 ----------
5 files changed, 154 insertions(+), 71 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 d49aa1bdffa623fec97b6a0a087908382fff027d
Author: Gregory Collins <[email protected]>
Date: Tue Sep 21 14:58:30 2010 -0400
Libev backend: kill active connections properly and add a test
diff --git a/src/Snap/Internal/Http/Server/LibevBackend.hs
b/src/Snap/Internal/Http/Server/LibevBackend.hs
index 38a67ea..9e74833 100644
--- a/src/Snap/Internal/Http/Server/LibevBackend.hs
+++ b/src/Snap/Internal/Http/Server/LibevBackend.hs
@@ -79,7 +79,7 @@ data Backend = Backend
, _asyncObj :: !EvAsyncPtr
, _killCb :: !(FunPtr AsyncCallback)
, _killObj :: !EvAsyncPtr
- , _connectionThreads :: !(HashMap ThreadId ())
+ , _connectionThreads :: !(HashMap ThreadId Connection)
, _backendCPU :: !Int
, _backendFreed :: !(MVar ())
}
@@ -362,30 +362,47 @@ timerCallback loop tmr ioref tmv _ _ _ = do
evTimerAgain loop tmr
-freeConnection :: Connection -> IO ()
-freeConnection conn = ignoreException $ do
- withMVar loopLock $ \_ -> block $ do
- debug $ "freeConnection (" ++ show fd ++ ")"
+-- if you already hold the loop lock, you are entitled to destroy a connection
+destroyConnection :: Connection -> IO ()
+destroyConnection conn = do
+ debug "Backend.destroyConnection: closing socket and killing connection"
+ c_close fd
- c_close fd
+ -- stop and free timer object
+ evTimerStop loop timerObj
+ freeEvTimer timerObj
+ freeTimerCallback timerCb
- -- stop and free timer object
- evTimerStop loop timerObj
- freeEvTimer timerObj
- freeTimerCallback timerCb
+ -- stop and free i/o objects
+ evIoStop loop ioWrObj
+ freeEvIo ioWrObj
+ freeIoCallback ioWrCb
+
+ evIoStop loop ioRdObj
+ freeEvIo ioRdObj
+ freeIoCallback ioRdCb
+
+ where
+ backend = _backend conn
+ loop = _evLoop backend
- -- stop and free i/o objects
- evIoStop loop ioWrObj
- freeEvIo ioWrObj
- freeIoCallback ioWrCb
+ fd = _socketFd conn
+ ioWrObj = _connWriteIOObj conn
+ ioWrCb = _connWriteIOCallback conn
+ ioRdObj = _connReadIOObj conn
+ ioRdCb = _connReadIOCallback conn
+ timerObj = _timerObj conn
+ timerCb = _timerCallback conn
- evIoStop loop ioRdObj
- freeEvIo ioRdObj
- freeIoCallback ioRdCb
+freeConnection :: Connection -> IO ()
+freeConnection conn = ignoreException $ do
+ withMVar loopLock $ \_ -> block $ do
+ debug $ "freeConnection (" ++ show fd ++ ")"
+ destroyConnection conn
tid <- readMVar $ _connThread conn
- -- removal the thread id from the backend set
+ -- remove the thread id from the backend set
H.delete tid $ _connectionThreads backend
-- wake up the event loop so it can be apprised of the changes
@@ -396,14 +413,7 @@ freeConnection conn = ignoreException $ do
loop = _evLoop backend
loopLock = _loopLock backend
asyncObj = _asyncObj backend
-
fd = _socketFd conn
- ioWrObj = _connWriteIOObj conn
- ioWrCb = _connWriteIOCallback conn
- ioRdObj = _connReadIOObj conn
- ioRdCb = _connReadIOCallback conn
- timerObj = _timerObj conn
- timerCb = _timerCallback conn
ignoreException :: IO () -> IO ()
@@ -412,13 +422,26 @@ ignoreException = handle (\(_::SomeException) -> return
())
freeBackend :: Backend -> IO ()
freeBackend backend = ignoreException $ block $ do
- -- note: we only get here after an unloop
+ -- note: we only get here after an unloop, so we have the loop lock
+ -- here. (?)
+
-- kill everything in thread table
tset <- H.toList $ _connectionThreads backend
+
+ let nthreads = Prelude.length tset
+
+ debug $ "Backend.freeBackend: killing active connection threads"
+
+ Prelude.mapM_ (destroyConnection . snd) tset
+
+ -- kill the threads twice, they're probably getting stuck in the
+ -- freeConnection 'finally' handler
Prelude.mapM_ (killThread . fst) tset
+ Prelude.mapM_ (killThread . fst) tset
+
+ debug $ "Backend.freeBackend: " ++ show nthreads ++ " thread(s) killed"
+ debug $ "Backend.freeBackend: destroying libev resources"
- debug $ "Backend.freeBackend: all threads killed"
- debug $ "Backend.freeBackend: destroying resources"
freeEvIo acceptObj
freeIoCallback acceptCb
c_close fd
@@ -453,7 +476,10 @@ freeBackend backend = ignoreException $ block $ do
withConnection :: Backend -> Int -> (Connection -> IO ()) -> IO ()
withConnection backend cpu proc = go
where
- threadProc conn = ignoreException (proc conn) `finally` freeConnection conn
+ threadProc conn = (do
+ x <- blocked
+ debug $ "withConnection/threadProc: we are blocked? " ++ show x
+ proc conn) `finally` freeConnection conn
go = do
debug $ "withConnection: reading from chan"
@@ -542,7 +568,7 @@ withConnection backend cpu proc = go
tid <- forkOnIO cpu $ threadProc conn
- H.update tid () (_connectionThreads backend)
+ H.update tid conn (_connectionThreads backend)
putMVar thrmv tid
diff --git a/test/common/Snap/Test/Common.hs b/test/common/Snap/Test/Common.hs
index a8bbc0e..b4ddd9f 100644
--- a/test/common/Snap/Test/Common.hs
+++ b/test/common/Snap/Test/Common.hs
@@ -1,4 +1,6 @@
{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
@@ -7,16 +9,19 @@ module Snap.Test.Common where
import Control.Exception (SomeException)
import Control.Monad
import Control.Monad.CatchIO
+import Data.ByteString (ByteString)
import qualified Data.ByteString as S
import qualified Data.ByteString.Lazy as L
import Data.ByteString.Internal (c2w)
+import qualified Data.DList as D
+import Network.Socket
+import qualified Network.Socket.ByteString as N
import Prelude hiding (catch)
import Test.QuickCheck
import System.Timeout
import Snap.Internal.Iteratee.Debug ()
-import System.IO
instance Arbitrary S.ByteString where
arbitrary = liftM (S.pack . map c2w) arbitrary
@@ -45,3 +50,39 @@ expectExceptionBeforeTimeout act nsecs = do
then return False
else return True
+
+withSock :: Int -> (Socket -> IO a) -> IO a
+withSock port go = do
+ addr <- liftM (addrAddress . Prelude.head) $
+ getAddrInfo (Just myHints)
+ (Just "127.0.0.1")
+ (Just $ show port)
+
+ sock <- socket AF_INET Stream defaultProtocol
+ connect sock addr
+
+ go sock `finally` sClose sock
+
+ where
+ myHints = defaultHints { addrFlags = [ AI_NUMERICHOST ] }
+
+
+recvAll :: Socket -> IO ByteString
+recvAll sock = do
+ d <- f D.empty sock
+ return $ S.concat $ D.toList d
+
+ where
+ f d sk = do
+ s <- N.recv sk 100000
+ if S.null s
+ then return d
+ else f (D.snoc d s) sk
+
+
+ditchHeaders :: [ByteString] -> [ByteString]
+ditchHeaders ("":xs) = xs
+ditchHeaders ("\r":xs) = xs
+ditchHeaders (_:xs) = ditchHeaders xs
+ditchHeaders [] = []
+
diff --git a/test/runTestsAndCoverage.sh b/test/runTestsAndCoverage.sh
index a1687c5..d615dec 100755
--- a/test/runTestsAndCoverage.sh
+++ b/test/runTestsAndCoverage.sh
@@ -2,7 +2,10 @@
set -e
-export DEBUG=testsuite
+if [ "x$DEBUG" == "x" ]; then
+ export DEBUG=testsuite
+fi
+
SUITE=./dist/build/testsuite/testsuite
rm -f *.tix
diff --git a/test/suite/Snap/Internal/Http/Server/Tests.hs
b/test/suite/Snap/Internal/Http/Server/Tests.hs
index 25fe6ea..e3f668f 100644
--- a/test/suite/Snap/Internal/Http/Server/Tests.hs
+++ b/test/suite/Snap/Internal/Http/Server/Tests.hs
@@ -7,10 +7,10 @@ module Snap.Internal.Http.Server.Tests
( tests ) where
import Control.Concurrent
-import Control.Exception (try, SomeException)
+import Control.Exception (try, throwIO, SomeException)
import Control.Monad
import "monads-fd" Control.Monad.Trans
-import qualified Data.ByteString as S
+import qualified Data.ByteString.Char8 as S
import qualified Data.ByteString.Lazy as L
import qualified Data.ByteString.Lazy.Char8 as LC
import Data.ByteString (ByteString)
@@ -26,6 +26,7 @@ import Data.Time.Calendar
import Data.Time.Clock
import Data.Word
import qualified Network.HTTP as HTTP
+import qualified Network.Socket.ByteString as N
import Prelude hiding (take)
import qualified Prelude
import Test.Framework
@@ -34,9 +35,11 @@ import Test.HUnit hiding (Test, path)
import qualified Snap.Http.Server as Svr
+import Snap.Internal.Debug
import Snap.Internal.Http.Types
import Snap.Internal.Http.Server
import Snap.Iteratee
+import Snap.Test.Common
import Snap.Types
#ifdef LIBEV
@@ -63,6 +66,7 @@ tests = [ testHttpRequest1
, testPartialParse
, testMethodParsing
, testServerStartupShutdown
+ , testServerShutdownWithOpenConns
, testChunkOn1_0
, testSendFile
, testTrivials]
@@ -564,7 +568,7 @@ testChunkOn1_0 = testCase "server/transfer-encoding
chunked" $ do
assertBool "connection close" $ S.isInfixOf "connection: close" output
where
- lower = S.map (c2w . toLower . w2c) . S.concat . L.toChunks
+ lower = S.map toLower . S.concat . L.toChunks
f :: ServerHandler
f _ req = do
@@ -765,3 +769,48 @@ testServerStartupShutdown = testCase
"server/startup/shutdown" $ do
waitabit = threadDelay $ 2*((10::Int)^(6::Int))
port = 8145
+
+testServerShutdownWithOpenConns :: Test
+testServerShutdownWithOpenConns = testCase "server/shutdown-open-conns" $ do
+ tid <- forkIO $
+ httpServe "*"
+ port
+ "localhost"
+ Nothing
+ Nothing
+ (runSnap pongServer)
+
+ waitabit
+
+ result <- newEmptyMVar
+
+ forkIO $ do
+ e <- try $ withSock port $ \sock -> do
+ N.sendAll sock "GET /"
+ waitabit
+ killThread tid
+ waitabit
+ N.sendAll sock "pong HTTP/1.1\r\n"
+ N.sendAll sock "Host: 127.0.0.1\r\n"
+ N.sendAll sock "Content-Length: 0\r\n"
+ N.sendAll sock "Connection: close\r\n\r\n"
+
+ resp <- recvAll sock
+ when (S.null resp) $ throwIO
Backend.BackendTerminatedException
+
+ let s = S.unpack $ Prelude.head $ ditchHeaders $ S.lines resp
+ debug $ "got HTTP response " ++ s ++ ", we shouldn't be
here...."
+
+ putMVar result e
+
+ r <- takeMVar result
+
+ case r of
+ (Left (_::SomeException)) -> return ()
+ (Right _) -> assertFailure "socket didn't get killed"
+
+
+ where
+ waitabit = threadDelay $ 2*((10::Int)^(6::Int))
+ port = 8146
+
diff --git a/test/suite/Test/Blackbox.hs b/test/suite/Test/Blackbox.hs
index aa27836..ac827ca 100644
--- a/test/suite/Test/Blackbox.hs
+++ b/test/suite/Test/Blackbox.hs
@@ -117,22 +117,6 @@ testRot13 port = testProperty "blackbox/rot13" $
QC.assert $ txt == rot13 doc
-withSock :: Int -> (Socket -> IO a) -> IO a
-withSock port go = do
- addr <- liftM (addrAddress . Prelude.head) $
- getAddrInfo (Just myHints)
- (Just "127.0.0.1")
- (Just $ show port)
-
- sock <- socket AF_INET Stream defaultProtocol
- connect sock addr
-
- go sock `finally` sClose sock
-
- where
- myHints = defaultHints { addrFlags = [ AI_NUMERICHOST ] }
-
-
testSlowLoris :: Int -> Test
testSlowLoris port = testCase "blackbox/slowloris" $ withSock port go
@@ -153,26 +137,6 @@ testSlowLoris port = testCase "blackbox/slowloris" $
withSock port go
loris sock
-ditchHeaders :: [ByteString] -> [ByteString]
-ditchHeaders ("":xs) = xs
-ditchHeaders ("\r":xs) = xs
-ditchHeaders (_:xs) = ditchHeaders xs
-ditchHeaders [] = []
-
-
-recvAll :: Socket -> IO ByteString
-recvAll sock = do
- d <- f D.empty sock
- return $ S.concat $ D.toList d
-
- where
- f d sk = do
- s <- N.recv sk 100000
- if S.null s
- then return d
- else f (D.snoc d s) sk
-
-
testBlockingRead :: Int -> Test
testBlockingRead port = testCase "blackbox/testBlockingRead" $
withSock port $ \sock -> do
-----------------------------------------------------------------------
hooks/post-receive
--
snap-server
_______________________________________________
Snap mailing list
[email protected]
http://mailman-mail5.webfaction.com/listinfo/snap
