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 de0ab6a2c056c7067681fcc9ce231c7feb91d657 (commit)
from 35a83ca1baae767d320e40ff2d3c1df33c2f7208 (commit)
Summary of changes:
src/Snap/Internal/Http/Server/LibevBackend.hs | 4 +-
src/Snap/Internal/Http/Server/SimpleBackend.hs | 4 +-
test/common/Test/Common/TestHandler.hs | 10 ++++++
test/suite/Snap/Internal/Http/Server/Tests.hs | 15 +++++++-
test/suite/Test/Blackbox.hs | 42 ++++++++++++++++--------
5 files changed, 55 insertions(+), 20 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 de0ab6a2c056c7067681fcc9ce231c7feb91d657
Author: Gregory Collins <[email protected]>
Date: Mon Sep 20 20:59:54 2010 -0400
More tests for server, especially re: blocking writes
diff --git a/src/Snap/Internal/Http/Server/LibevBackend.hs
b/src/Snap/Internal/Http/Server/LibevBackend.hs
index 7b69a77..38a67ea 100644
--- a/src/Snap/Internal/Http/Server/LibevBackend.hs
+++ b/src/Snap/Internal/Http/Server/LibevBackend.hs
@@ -9,9 +9,9 @@
module Snap.Internal.Http.Server.LibevBackend
( Backend
- , BackendTerminatedException
+ , BackendTerminatedException(..)
, Connection
- , TimeoutException
+ , TimeoutException(..)
, name
, debug
, bindIt
diff --git a/src/Snap/Internal/Http/Server/SimpleBackend.hs
b/src/Snap/Internal/Http/Server/SimpleBackend.hs
index ace900c..7324bbd 100644
--- a/src/Snap/Internal/Http/Server/SimpleBackend.hs
+++ b/src/Snap/Internal/Http/Server/SimpleBackend.hs
@@ -9,9 +9,9 @@
module Snap.Internal.Http.Server.SimpleBackend
( Backend
- , BackendTerminatedException
+ , BackendTerminatedException(..)
, Connection
- , TimeoutException
+ , TimeoutException(..)
, name
, debug
, bindIt
diff --git a/test/common/Test/Common/TestHandler.hs
b/test/common/Test/Common/TestHandler.hs
index be553fa..8707eb7 100644
--- a/test/common/Test/Common/TestHandler.hs
+++ b/test/common/Test/Common/TestHandler.hs
@@ -7,6 +7,7 @@ module Test.Common.TestHandler (testHandler) where
import Control.Monad
import qualified Data.ByteString.Char8 as B
+import qualified Data.ByteString.Lazy.Char8 as L
import Data.Iteratee.WrappedByteString
import Data.Maybe
@@ -44,6 +45,14 @@ rot13Handler = transformRequestBody $ return . f
return $ Cont (f i') Nothing
+bigResponseHandler :: Snap ()
+bigResponseHandler = do
+ let sz = 4000000
+ let s = L.take sz $ L.cycle $ L.replicate 4096 '.'
+ modifyResponse $ setContentLength sz
+ writeLBS s
+
+
responseHandler :: Snap ()
responseHandler = do
!code <- liftM (read . B.unpack . fromMaybe "503") $ getParam "code"
@@ -58,6 +67,7 @@ testHandler =
, ("rot13" , rot13Handler )
, ("echoUri" , echoUriHandler )
, ("fileserve" , fileServe "testserver/static")
+ , ("bigresponse" , bigResponseHandler )
, ("respcode/:code" , responseHandler )
]
diff --git a/test/suite/Snap/Internal/Http/Server/Tests.hs
b/test/suite/Snap/Internal/Http/Server/Tests.hs
index a9e533d..25fe6ea 100644
--- a/test/suite/Snap/Internal/Http/Server/Tests.hs
+++ b/test/suite/Snap/Internal/Http/Server/Tests.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE PackageImports #-}
@@ -38,6 +39,12 @@ import Snap.Internal.Http.Server
import Snap.Iteratee
import Snap.Types
+#ifdef LIBEV
+import qualified Snap.Internal.Http.Server.LibevBackend as Backend
+#else
+import qualified Snap.Internal.Http.Server.SimpleBackend as Backend
+#endif
+
tests :: [Test]
tests = [ testHttpRequest1
@@ -62,8 +69,12 @@ tests = [ testHttpRequest1
testTrivials :: Test
-testTrivials = testCase "server/trivials" $
- let !x = Svr.snapServerVersion in return $! x `seq` ()
+testTrivials = testCase "server/trivials" $ do
+ let !v = Svr.snapServerVersion
+ let !s1 = show Backend.BackendTerminatedException
+ let !s2 = show Backend.TimeoutException
+
+ return $! v `seq` s1 `seq` s2 `seq` ()
------------------------------------------------------------------------------
-- HTTP request tests
diff --git a/test/suite/Test/Blackbox.hs b/test/suite/Test/Blackbox.hs
index e155d73..aa27836 100644
--- a/test/suite/Test/Blackbox.hs
+++ b/test/suite/Test/Blackbox.hs
@@ -41,6 +41,7 @@ tests port = map ($ port) [ testPong
, testRot13
, testSlowLoris
, testBlockingRead
+ , testBigResponse
, testPartial ]
@@ -159,6 +160,18 @@ 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" $
@@ -177,19 +190,6 @@ testBlockingRead port = testCase
"blackbox/testBlockingRead" $
assertEqual "pong response" "PONG" s
- where
- recvAll sock = do
- d <- f D.empty sock
- return $ S.concat $ D.toList d
-
- where
- f d sk = do
- s <- N.recv sk 8192
- if S.null s
- then return d
- else f (D.snoc d s) sk
-
-
-- test server's ability to trap/recover from IO errors
testPartial :: Int -> Test
testPartial port = testCase "blackbox/testPartial" $ do
@@ -199,7 +199,21 @@ testPartial port = testCase "blackbox/testPartial" $ do
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"
+
+ let body = S.replicate 4000000 '.'
+ resp <- recvAll sock
+
+ let s = head $ ditchHeaders $ S.lines resp
+
+ assertBool "big response" $ body == s
------------------------------------------------------------------------------
-----------------------------------------------------------------------
hooks/post-receive
--
snap-server
_______________________________________________
Snap mailing list
[email protected]
http://mailman-mail5.webfaction.com/listinfo/snap
