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 e742e100006a8d3cfb534e88e7eaeb1b368aebd8 (commit)
from dc2dfb3219ea6281bca09532930a7fce5cff0001 (commit)
Summary of changes:
test/suite/Snap/Internal/Http/Server/Tests.hs | 93 ++++++++++++++++---------
test/suite/Test/Blackbox.hs | 77 +++++++++++++++------
2 files changed, 116 insertions(+), 54 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 e742e100006a8d3cfb534e88e7eaeb1b368aebd8
Author: Gregory Collins <[email protected]>
Date: Fri Sep 24 12:53:43 2010 -0400
Add timeouts to some of the server tests
diff --git a/test/suite/Snap/Internal/Http/Server/Tests.hs
b/test/suite/Snap/Internal/Http/Server/Tests.hs
index 247412e..7181ff7 100644
--- a/test/suite/Snap/Internal/Http/Server/Tests.hs
+++ b/test/suite/Snap/Internal/Http/Server/Tests.hs
@@ -7,7 +7,7 @@ module Snap.Internal.Http.Server.Tests
( tests ) where
import Control.Concurrent
-import Control.Exception (try, throwIO, SomeException)
+import Control.Exception (try, throwIO, bracket, SomeException)
import Control.Monad
import "monads-fd" Control.Monad.Trans
import qualified Data.ByteString.Char8 as S
@@ -29,6 +29,7 @@ import qualified Network.HTTP as HTTP
import qualified Network.Socket.ByteString as N
import Prelude hiding (take)
import qualified Prelude
+import System.Timeout
import Test.Framework
import Test.Framework.Providers.HUnit
import Test.HUnit hiding (Test, path)
@@ -726,47 +727,68 @@ sendFileFoo = sendFile "data/fileServe/foo.html"
testSendFile :: Test
testSendFile = testCase "server/sendFile" $ do
- tid <- forkIO $ httpServe "*" port "localhost"
- Nothing Nothing $
- runSnap sendFileFoo
- waitabit
-
- rsp <- HTTP.simpleHTTP (HTTP.getRequest "http://localhost:8123/";)
- doc <- HTTP.getResponseBody rsp
+ bracket (forkIO $ httpServe "*" port "localhost"
+ Nothing Nothing
+ $ runSnap sendFileFoo)
+ (killThread)
+ (\tid -> do
+ m <- timeout (120 * seconds) $ go tid
+ maybe (assertFailure "timeout")
+ (const $ return ())
+ m)
- killThread tid
- waitabit
+ where
+ go tid = do
+ waitabit
+
+ rsp <- HTTP.simpleHTTP (HTTP.getRequest "http://localhost:8123/";)
+ doc <- HTTP.getResponseBody rsp
+
+ killThread tid
+ waitabit
+
+ assertEqual "sendFile" "FOO\n" doc
- assertEqual "sendFile" "FOO\n" doc
- where
waitabit = threadDelay $ ((10::Int)^(6::Int))
+
port = 8123
testServerStartupShutdown :: Test
testServerStartupShutdown = testCase "server/startup/shutdown" $ do
- tid <- forkIO $
- httpServe "*"
- port
- "localhost"
- (Just "test-access.log")
- (Just "test-error.log")
- (runSnap pongServer)
- waitabit
+ bracket (forkIO $
+ httpServe "*"
+ port
+ "localhost"
+ (Just "test-access.log")
+ (Just "test-error.log")
+ (runSnap pongServer))
+ (killThread)
+ (\tid -> do
+ m <- timeout (120 * seconds) $ go tid
+ maybe (assertFailure "timeout")
+ (const $ return ())
+ m)
- rsp <- HTTP.simpleHTTP (HTTP.getRequest "http://localhost:8145/";)
- doc <- HTTP.getResponseBody rsp
- assertEqual "server" "PONG" doc
- killThread tid
- waitabit
+ where
+ go tid = do
+ waitabit
- expectException $ HTTP.simpleHTTP (HTTP.getRequest
"http://localhost:8145/";)
+ rsp <- HTTP.simpleHTTP (HTTP.getRequest "http://localhost:8145/";)
+ doc <- HTTP.getResponseBody rsp
+ assertEqual "server" "PONG" doc
+
+ killThread tid
+ waitabit
+
+ expectException $ HTTP.simpleHTTP
+ $ HTTP.getRequest "http://localhost:8145/";
+ return ()
- return ()
- where
waitabit = threadDelay $ 2*((10::Int)^(6::Int))
+
port = 8145
@@ -803,14 +825,21 @@ testServerShutdownWithOpenConns = testCase
"server/shutdown-open-conns" $ do
putMVar result e
- r <- takeMVar result
+ e <- timeout (75*seconds) $ takeMVar result
- case r of
- (Left (_::SomeException)) -> return ()
- (Right _) -> assertFailure "socket didn't get killed"
+ case e of
+ Nothing -> killThread tid >> assertFailure "timeout"
+ (Just r) ->
+ case r of
+ (Left (_::SomeException)) -> return ()
+ (Right _) -> assertFailure "socket didn't get
killed"
where
waitabit = threadDelay $ 2*((10::Int)^(6::Int))
port = 8146
+
+
+seconds :: Int
+seconds = (10::Int) ^ (6::Int)
diff --git a/test/suite/Test/Blackbox.hs b/test/suite/Test/Blackbox.hs
index ac827ca..550c3a2 100644
--- a/test/suite/Test/Blackbox.hs
+++ b/test/suite/Test/Blackbox.hs
@@ -20,6 +20,7 @@ import qualified Network.URI as URI
import Network.Socket
import qualified Network.Socket.ByteString as N
import Prelude hiding (take)
+import System.Timeout
import Test.Framework
import Test.Framework.Providers.HUnit
import Test.Framework.Providers.QuickCheck2
@@ -122,6 +123,12 @@ testSlowLoris port = testCase "blackbox/slowloris" $
withSock port go
where
go sock = do
+ m <- timeout (120*seconds) $ go' sock
+ maybe (assertFailure "slowloris: timeout")
+ (const $ return ())
+ m
+
+ go' sock = do
N.sendAll sock "POST /echo HTTP/1.1\r\n"
N.sendAll sock "Host: 127.0.0.1\r\n"
N.sendAll sock "Content-Length: 2500000\r\n"
@@ -140,46 +147,72 @@ testSlowLoris port = testCase "blackbox/slowloris" $
withSock port go
testBlockingRead :: Int -> Test
testBlockingRead port = testCase "blackbox/testBlockingRead" $
withSock port $ \sock -> do
- N.sendAll sock "GET /"
- 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"
+ m <- timeout (60*seconds) $ go sock
+ maybe (assertFailure "timeout")
+ (const $ return ())
+ m
+
+ where
+ go sock = do
+ N.sendAll sock "GET /"
+ 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
+ resp <- recvAll sock
- let s = head $ ditchHeaders $ S.lines resp
+ let s = head $ ditchHeaders $ S.lines resp
- assertEqual "pong response" "PONG" s
+ assertEqual "pong response" "PONG" s
-- test server's ability to trap/recover from IO errors
testPartial :: Int -> Test
testPartial port = testCase "blackbox/testPartial" $ do
- withSock port $ \sock ->
- N.sendAll sock "GET /pong HTTP/1.1\r\n"
+ m <- timeout (60*seconds) go
+ maybe (assertFailure "timeout")
+ (const $ return ())
+ m
- doc <- doPong port
- assertEqual "pong response" "PONG" doc
+
+ where
+ go = do
+ withSock port $ \sock ->
+ N.sendAll sock "GET /pong HTTP/1.1\r\n"
+
+ doc <- doPong port
+ assertEqual "pong response" "PONG" doc
testBigResponse :: Int -> Test
testBigResponse port = testCase "blackbox/testBigResponse" $
withSock port $ \sock -> do
- N.sendAll sock "GET /bigresponse 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"
+ m <- timeout (120*seconds) $ go sock
+ maybe (assertFailure "timeout")
+ (const $ return ())
+ m
+
+ where
+ go sock = do
+ N.sendAll sock "GET /bigresponse 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"
- let body = S.replicate 4000000 '.'
- resp <- recvAll sock
+ let body = S.replicate 4000000 '.'
+ resp <- recvAll sock
- let s = head $ ditchHeaders $ S.lines resp
+ let s = head $ ditchHeaders $ S.lines resp
- assertBool "big response" $ body == s
+ assertBool "big response" $ body == s
------------------------------------------------------------------------------
waitabit :: IO ()
-waitabit = threadDelay $ 2*((10::Int)^(6::Int))
+waitabit = threadDelay $ 2*seconds
+
+
+seconds :: Int
+seconds = (10::Int) ^ (6::Int)
-----------------------------------------------------------------------
hooks/post-receive
--
snap-server
_______________________________________________
Snap mailing list
[email protected]
http://mailman-mail5.webfaction.com/listinfo/snap
