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 35a83ca1baae767d320e40ff2d3c1df33c2f7208 (commit)
from bbce5a3d77a4f2bdbccf713aabbea1a2d0a74cd9 (commit)
Summary of changes:
test/suite/Snap/Internal/Http/Server/Tests.hs | 86 +++++++++++++++++++-----
test/suite/Test/Blackbox.hs | 90 +++++++++++++++++++++----
2 files changed, 146 insertions(+), 30 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 35a83ca1baae767d320e40ff2d3c1df33c2f7208
Author: Gregory Collins <[email protected]>
Date: Mon Sep 20 13:35:39 2010 -0400
A couple more tests for the server
diff --git a/test/suite/Snap/Internal/Http/Server/Tests.hs
b/test/suite/Snap/Internal/Http/Server/Tests.hs
index b68325a..a9e533d 100644
--- a/test/suite/Snap/Internal/Http/Server/Tests.hs
+++ b/test/suite/Snap/Internal/Http/Server/Tests.hs
@@ -52,6 +52,7 @@ tests = [ testHttpRequest1
, testHttp1
, testHttp2
, testHttp100
+ , testExpectGarbage
, testPartialParse
, testMethodParsing
, testServerStartupShutdown
@@ -90,6 +91,17 @@ sampleRequestExpectContinue =
, "\r\n"
, "0123456789" ]
+sampleRequestExpectGarbage :: ByteString
+sampleRequestExpectGarbage =
+ S.concat [ "\r\nGET /foo/bar.html?param1=abc¶m2=def%20+¶m1=abc
HTTP/1.1\r\n"
+ , "Host: www.zabble.com:7777\r\n"
+ , "Content-Length: 10\r\n"
+ , "Expect: wuzzawuzzawuzza\r\n"
+ , "X-Random-Other-Header: foo\r\n bar\r\n"
+ , "Cookie: foo=\"bar\\\"\"\r\n"
+ , "\r\n"
+ , "0123456789" ]
+
sampleRequest1_0 :: ByteString
sampleRequest1_0 =
S.concat [ "\r\nGET /foo/bar.html?param1=abc¶m2=def%20+¶m1=abc
HTTP/1.0\r\n"
@@ -102,7 +114,7 @@ sampleRequest1_0 =
testMethodParsing :: Test
testMethodParsing =
- testCase "method parsing" $ Prelude.mapM_ testOneMethod ms
+ testCase "server/method parsing" $ Prelude.mapM_ testOneMethod ms
where
ms = [ GET, HEAD, POST, PUT, DELETE, TRACE, OPTIONS, CONNECT ]
@@ -123,7 +135,7 @@ copyingStream2stream = IterateeG (step mempty)
testHttpRequest1 :: Test
testHttpRequest1 =
- testCase "HttpRequest1" $ do
+ testCase "server/HttpRequest1" $ do
iter <- enumBS sampleRequest $
do
r <- liftM fromJust $ rsm receiveRequest
@@ -166,7 +178,7 @@ testHttpRequest1 =
testMultiRequest :: Test
testMultiRequest =
- testCase "MultiRequest" $ do
+ testCase "server/MultiRequest" $ do
iter <- (enumBS sampleRequest >. enumBS sampleRequest) $
do
r1 <- liftM fromJust $ rsm receiveRequest
@@ -217,7 +229,7 @@ expectException m = do
testPartialParse :: Test
-testPartialParse = testCase "Short" $ do
+testPartialParse = testCase "server/short" $ do
iter <- enumBS sampleShortRequest $ liftM fromJust $ rsm receiveRequest
expectException $ run iter
@@ -243,7 +255,7 @@ sampleRequest2 =
testHttpRequest2 :: Test
testHttpRequest2 =
- testCase "HttpRequest2" $ do
+ testCase "server/HttpRequest2" $ do
iter <- enumBS sampleRequest2 $
do
r <- liftM fromJust $ rsm receiveRequest
@@ -259,7 +271,7 @@ testHttpRequest2 =
testHttpRequest3 :: Test
testHttpRequest3 =
- testCase "HttpRequest3" $ do
+ testCase "server/HttpRequest3" $ do
iter <- enumBS sampleRequest3 $
do
r <- liftM fromJust $ rsm receiveRequest
@@ -292,7 +304,7 @@ testHttpRequest3 =
testHttpRequest3' :: Test
testHttpRequest3' =
- testCase "HttpRequest3'" $ do
+ testCase "server/HttpRequest3'" $ do
iter <- enumBS sampleRequest3' $
do
r <- liftM fromJust $ rsm receiveRequest
@@ -353,7 +365,7 @@ rsm = runServerMonad "localhost" "127.0.0.1" 80 "127.0.0.1"
58382 alog elog
testHttpResponse1 :: Test
-testHttpResponse1 = testCase "HttpResponse1" $ do
+testHttpResponse1 = testCase "server/HttpResponse1" $ do
let onSendFile = \f _ -> enumFile f copyingStream2stream >>= run
b <- run $ rsm $
@@ -377,7 +389,7 @@ testHttpResponse1 = testCase "HttpResponse1" $ do
testHttpResponse2 :: Test
-testHttpResponse2 = testCase "HttpResponse2" $ do
+testHttpResponse2 = testCase "server/HttpResponse2" $ do
let onSendFile = \f _ -> enumFile f copyingStream2stream >>= run
b2 <- run $ rsm $
@@ -401,7 +413,7 @@ testHttpResponse2 = testCase "HttpResponse2" $ do
testHttpResponse3 :: Test
-testHttpResponse3 = testCase "HttpResponse3" $ do
+testHttpResponse3 = testCase "server/HttpResponse3" $ do
let onSendFile = \f _ -> enumFile f copyingStream2stream >>= run
b3 <- run $ rsm $
@@ -431,7 +443,7 @@ testHttpResponse3 = testCase "HttpResponse3" $ do
testHttpResponse4 :: Test
-testHttpResponse4 = testCase "HttpResponse4" $ do
+testHttpResponse4 = testCase "server/HttpResponse4" $ do
let onSendFile = \f _ -> enumFile f copyingStream2stream >>= run
b <- run $ rsm $
@@ -478,7 +490,7 @@ echoServer2 _ req = do
testHttp1 :: Test
-testHttp1 = testCase "http session" $ do
+testHttp1 = testCase "server/http session" $ do
let enumBody = enumBS sampleRequest >. enumBS sampleRequest2
ref <- newIORef ""
@@ -524,7 +536,7 @@ mkIter ref = (iter, \f _ -> onF f iter)
testChunkOn1_0 :: Test
-testChunkOn1_0 = testCase "transfer-encoding chunked" $ do
+testChunkOn1_0 = testCase "server/transfer-encoding chunked" $ do
let enumBody = enumBS sampleRequest1_0
ref <- newIORef ""
@@ -563,7 +575,7 @@ sampleRequest4 =
testHttp2 :: Test
-testHttp2 = testCase "connection: close" $ do
+testHttp2 = testCase "server/connection: close" $ do
let enumBody = enumBS sampleRequest4 >. enumBS sampleRequest2
ref <- newIORef ""
@@ -605,7 +617,7 @@ testHttp2 = testCase "connection: close" $ do
testHttp100 :: Test
-testHttp100 = testCase "Expect: 100-continue" $ do
+testHttp100 = testCase "server/Expect: 100-continue" $ do
let enumBody = enumBS sampleRequestExpectContinue
ref <- newIORef ""
@@ -646,6 +658,46 @@ testHttp100 = testCase "Expect: 100-continue" $ do
assertBool "100 Continue" ok
+testExpectGarbage :: Test
+testExpectGarbage = testCase "server/Expect: garbage" $ do
+ let enumBody = enumBS sampleRequestExpectGarbage
+
+ ref <- newIORef ""
+
+ let (iter,onSendFile) = mkIter ref
+
+ runHTTP "localhost"
+ "127.0.0.1"
+ 80
+ "127.0.0.1"
+ 58384
+ Nothing
+ Nothing
+ enumBody
+ iter
+ onSendFile
+ (return ())
+ echoServer2
+
+ s <- readIORef ref
+
+ let lns = LC.lines s
+
+ let ok = case lns of
+ ([ "HTTP/1.1 200 OK\r"
+ , "Content-Length: 10\r"
+ , d1
+ , s1
+ , "Set-Cookie: foo=bar; path=/; expires=Sat, 30-Jan-2010
00:00:00 GMT; domain=.foo.com\r"
+ , "\r"
+ , "0123456789" ]) -> (("Date" `L.isPrefixOf` d1) &&
+ ("Server" `L.isPrefixOf` s1))
+
+ _ -> False
+
+ assertBool "random expect: header" ok
+
+
pongServer :: Snap ()
@@ -658,7 +710,7 @@ sendFileFoo = sendFile "data/fileServe/foo.html"
testSendFile :: Test
-testSendFile = testCase "sendFile" $ do
+testSendFile = testCase "server/sendFile" $ do
tid <- forkIO $ httpServe "*" port "localhost"
Nothing Nothing $
runSnap sendFileFoo
@@ -678,7 +730,7 @@ testSendFile = testCase "sendFile" $ do
testServerStartupShutdown :: Test
-testServerStartupShutdown = testCase "startup/shutdown" $ do
+testServerStartupShutdown = testCase "server/startup/shutdown" $ do
tid <- forkIO $
httpServe "*"
port
diff --git a/test/suite/Test/Blackbox.hs b/test/suite/Test/Blackbox.hs
index 9ad2a96..e155d73 100644
--- a/test/suite/Test/Blackbox.hs
+++ b/test/suite/Test/Blackbox.hs
@@ -10,7 +10,9 @@ module Test.Blackbox
import Control.Concurrent
import Control.Monad
import Control.Monad.CatchIO
-import qualified Data.ByteString as S
+import Data.ByteString.Char8 (ByteString)
+import qualified Data.ByteString.Char8 as S
+import qualified Data.DList as D
import Data.Int
import Data.Maybe (fromJust)
import qualified Network.HTTP as HTTP
@@ -34,10 +36,12 @@ import Test.Common.TestHandler
tests :: Int -> [Test]
-tests port = [ testPong port
- , testEcho port
- , testRot13 port
- , testSlowLoris port ]
+tests port = map ($ port) [ testPong
+ , testEcho
+ , testRot13
+ , testSlowLoris
+ , testBlockingRead
+ , testPartial ]
startTestServer :: IO (ThreadId,Int)
@@ -57,13 +61,18 @@ startTestServer = do
port = 8199
-testPong :: Int -> Test
-testPong port = testCase "blackbox/pong" $ do
+doPong :: Int -> IO String
+doPong port = do
rsp <- HTTP.simpleHTTP $
HTTP.getRequest $
"http://localhost:"; ++ show port ++ "/pong"
- doc <- HTTP.getResponseBody rsp
+ HTTP.getResponseBody rsp
+
+
+testPong :: Int -> Test
+testPong port = testCase "blackbox/pong" $ do
+ doc <- doPong port
assertEqual "pong response" "PONG" doc
@@ -80,7 +89,7 @@ testEcho port = testProperty "blackbox/echo" $
let req' = (HTTP.mkRequest HTTP.POST uri) :: HTTP.Request S.ByteString
let req = HTTP.replaceHeader HTTP.HdrContentLength (show len) req'
-
+
rsp <- QC.run $ HTTP.simpleHTTP $ req { HTTP.rqBody =
(txt::S.ByteString) }
doc <- QC.run $ HTTP.getResponseBody rsp
@@ -100,15 +109,15 @@ testRot13 port = testProperty "blackbox/rot13" $
let req' = (HTTP.mkRequest HTTP.POST uri) :: HTTP.Request S.ByteString
let req = HTTP.replaceHeader HTTP.HdrContentLength (show len) req'
-
+
rsp <- QC.run $ HTTP.simpleHTTP $ req { HTTP.rqBody =
(txt::S.ByteString) }
doc <- QC.run $ HTTP.getResponseBody rsp
QC.assert $ txt == rot13 doc
-testSlowLoris :: Int -> Test
-testSlowLoris port = testCase "blackbox/slowloris" $ do
+withSock :: Int -> (Socket -> IO a) -> IO a
+withSock port go = do
addr <- liftM (addrAddress . Prelude.head) $
getAddrInfo (Just myHints)
(Just "127.0.0.1")
@@ -122,6 +131,11 @@ testSlowLoris port = testCase "blackbox/slowloris" $ do
where
myHints = defaultHints { addrFlags = [ AI_NUMERICHOST ] }
+
+testSlowLoris :: Int -> Test
+testSlowLoris port = testCase "blackbox/slowloris" $ withSock port go
+
+ where
go sock = do
N.sendAll sock "POST /echo HTTP/1.1\r\n"
N.sendAll sock "Host: 127.0.0.1\r\n"
@@ -134,10 +148,60 @@ testSlowLoris port = testCase "blackbox/slowloris" $ do
loris sock = do
N.sendAll sock "."
- threadDelay 2000000
+ waitabit
loris sock
+ditchHeaders :: [ByteString] -> [ByteString]
+ditchHeaders ("":xs) = xs
+ditchHeaders ("\r":xs) = xs
+ditchHeaders (_:xs) = ditchHeaders xs
+ditchHeaders [] = []
+
+
+
+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"
+
+ resp <- recvAll sock
+
+ let s = head $ ditchHeaders $ S.lines resp
+
+ 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
+ withSock port $ \sock ->
+ N.sendAll sock "GET /pong HTTP/1.1\r\n"
+
+ doc <- doPong port
+ assertEqual "pong response" "PONG" doc
+
+
+
+
------------------------------------------------------------------------------
waitabit :: IO ()
waitabit = threadDelay $ 2*((10::Int)^(6::Int))
-----------------------------------------------------------------------
hooks/post-receive
--
snap-server
_______________________________________________
Snap mailing list
[email protected]
http://mailman-mail5.webfaction.com/listinfo/snap
