snap-server-0.2.11: test/suite/Snap/Internal/Http/Server/Tests.hs
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE PackageImports #-}
module Snap.Internal.Http.Server.Tests
( tests ) where
import Control.Concurrent
import Control.Exception (try, SomeException)
import Control.Monad
import "monads-fd" Control.Monad.Trans
import qualified Data.ByteString as S
import qualified Data.ByteString.Lazy as L
import qualified Data.ByteString.Lazy.Char8 as LC
import Data.ByteString (ByteString)
import Data.ByteString.Internal (c2w, w2c)
import Data.Char
import Data.Int
import Data.IORef
import Data.Iteratee.WrappedByteString
import qualified Data.Map as Map
import Data.Maybe (fromJust)
import Data.Monoid
import Data.Time.Calendar
import Data.Time.Clock
import Data.Word
import qualified Network.HTTP as HTTP
import Prelude hiding (take)
import qualified Prelude
import Test.Framework
import Test.Framework.Providers.HUnit
import Test.HUnit hiding (Test, path)
import Snap.Internal.Http.Types
import Snap.Internal.Http.Server
import Snap.Iteratee
import Snap.Types
tests :: [Test]
tests = [ testHttpRequest1
, testMultiRequest
, testHttpRequest2
, testHttpRequest3
, testHttpRequest3'
, testHttpResponse1
, testHttpResponse2
, testHttpResponse3
, testHttpResponse4
, testHttp1
, testHttp2
, testHttp100
, testPartialParse
, testMethodParsing
, testServerStartupShutdown
, testChunkOn1_0
, testSendFile ]
------------------------------------------------------------------------------
-- HTTP request tests
-- note leading crlf -- test tolerance of this, some old browsers send an extra
-- crlf after a post body
sampleRequest :: ByteString
sampleRequest =
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"
, "X-Random-Other-Header: foo\r\n bar\r\n"
, "Cookie: foo=\"bar\\\"\"\r\n"
, "\r\n"
, "0123456789" ]
sampleRequestExpectContinue :: ByteString
sampleRequestExpectContinue =
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: 100-continue\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"
, "Host: www.zabble.com:7777\r\n"
, "Content-Length: 10\r\n"
, "X-Random-Other-Header: foo\r\n bar\r\n"
, "Cookie: foo=\"bar\\\"\"\r\n"
, "\r\n"
, "0123456789" ]
testMethodParsing :: Test
testMethodParsing =
testCase "method parsing" $ Prelude.mapM_ testOneMethod ms
where
ms = [ GET, HEAD, POST, PUT, DELETE, TRACE, OPTIONS, CONNECT ]
copyingStream2stream :: Iteratee IO (WrappedByteString Word8)
copyingStream2stream = IterateeG (step mempty)
where
step acc (Chunk (WrapBS ls))
| S.null ls = return $ Cont (IterateeG (step acc)) Nothing
| otherwise = do
let !ls' = S.copy ls
let !bs' = WrapBS $! ls'
return $ Cont (IterateeG (step (acc `mappend` bs')))
Nothing
step acc str = return $ Done acc str
testHttpRequest1 :: Test
testHttpRequest1 =
testCase "HttpRequest1" $ do
iter <- enumBS sampleRequest $
do
r <- liftM fromJust $ rsm receiveRequest
se <- liftIO $ readIORef (rqBody r)
let (SomeEnumerator e) = se
b <- liftM fromWrap $ joinIM $ e copyingStream2stream
return (r,b)
(req,body) <- run iter
assertEqual "not secure" False $ rqIsSecure req
assertEqual "content length" (Just 10) $ rqContentLength req
assertEqual "parse body" "0123456789" body
assertEqual "cookie" [Cookie "foo" "bar\"" Nothing Nothing Nothing] $
rqCookies req
assertEqual "continued headers" (Just ["foo bar"]) $
Map.lookup "x-random-other-header" $ rqHeaders req
assertEqual "parse URI"
"/foo/bar.html?param1=abc¶m2=def%20+¶m1=abc"
$ rqURI req
assertEqual "server port" 7777 $ rqServerPort req
assertEqual "context path" "/" $ rqContextPath req
assertEqual "pathinfo" "foo/bar.html" $ rqPathInfo req
assertEqual "query string" "param1=abc¶m2=def%20+¶m1=abc" $
rqQueryString req
assertEqual "server name" "www.zabble.com" $ rqServerName req
assertEqual "version" (1,1) $ rqVersion req
assertEqual "param1" (Just ["abc","abc"]) $
rqParam "param1" req
assertEqual "param2" (Just ["def "]) $
rqParam "param2" req
testMultiRequest :: Test
testMultiRequest =
testCase "MultiRequest" $ do
iter <- (enumBS sampleRequest >. enumBS sampleRequest) $
do
r1 <- liftM fromJust $ rsm receiveRequest
se1 <- liftIO $ readIORef (rqBody r1)
let (SomeEnumerator e1) = se1
b1 <- liftM fromWrap $ joinIM $ e1 copyingStream2stream
r2 <- liftM fromJust $ rsm receiveRequest
se2 <- liftIO $ readIORef (rqBody r2)
let (SomeEnumerator e2) = se2
b2 <- liftM fromWrap $ joinIM $ e2 copyingStream2stream
return (r1,b1,r2,b2)
(req1,body1,req2,body2) <- run iter
assertEqual "parse body 1" "0123456789" body1
assertEqual "parse body 2" "0123456789" body2
assertEqual "parse URI 1"
"/foo/bar.html?param1=abc¶m2=def%20+¶m1=abc"
$ rqURI req1
assertEqual "parse URI 2"
"/foo/bar.html?param1=abc¶m2=def%20+¶m1=abc"
$ rqURI req2
testOneMethod :: Method -> IO ()
testOneMethod m = do
iter <- enumLBS txt $ liftM fromJust $ rsm receiveRequest
req <- run iter
assertEqual "method" m $ rqMethod req
where
txt = methodTestText m
sampleShortRequest :: ByteString
sampleShortRequest = "GET /fo"
expectException :: IO a -> IO ()
expectException m = do
e <- try m
case e of
Left (z::SomeException) -> return ()
Right _ -> assertFailure "expected exception, didn't get it"
testPartialParse :: Test
testPartialParse = testCase "Short" $ do
iter <- enumBS sampleShortRequest $ liftM fromJust $ rsm receiveRequest
expectException $ run iter
methodTestText :: Method -> L.ByteString
methodTestText m = L.concat [ (L.pack $ map c2w $ show m)
, " / HTTP/1.1\r\n\r\n" ]
sampleRequest2 :: ByteString
sampleRequest2 =
S.concat [ "GET /foo/bar.html?param1=abc¶m2=def¶m1=abc HTTP/1.1\r\n"
, "Host: www.foo.com:8080\r\n"
, "Transfer-Encoding: chunked\r\n"
, "\r\n"
, "a\r\n"
, "0123456789\r\n"
, "4\r\n"
, "0123\r\n"
, "0\r\n\r\n" ]
testHttpRequest2 :: Test
testHttpRequest2 =
testCase "HttpRequest2" $ do
iter <- enumBS sampleRequest2 $
do
r <- liftM fromJust $ rsm receiveRequest
se <- liftIO $ readIORef (rqBody r)
let (SomeEnumerator e) = se
b <- liftM fromWrap $ joinIM $ e copyingStream2stream
return (r,b)
(_,body) <- run iter
assertEqual "parse body" "01234567890123" body
testHttpRequest3 :: Test
testHttpRequest3 =
testCase "HttpRequest3" $ do
iter <- enumBS sampleRequest3 $
do
r <- liftM fromJust $ rsm receiveRequest
se <- liftIO $ readIORef (rqBody r)
let (SomeEnumerator e) = se
b <- liftM fromWrap $ joinIM $ e copyingStream2stream
return (r,b)
(req,body) <- run iter
assertEqual "no cookies" [] $ rqCookies req
assertEqual "multiheader" (Just ["1","2"]) $
Map.lookup "Multiheader" (rqHeaders req)
assertEqual "host" ("localhost", 80) $
(rqServerName req, rqServerPort req)
assertEqual "post param 1"
(rqParam "postparam1" req)
(Just ["1"])
assertEqual "post param 2"
(rqParam "postparam2" req)
(Just ["2"])
-- make sure the post body is still emitted
assertEqual "parse body" (LC.fromChunks [samplePostBody3]) body
testHttpRequest3' :: Test
testHttpRequest3' =
testCase "HttpRequest3'" $ do
iter <- enumBS sampleRequest3' $
do
r <- liftM fromJust $ rsm receiveRequest
se <- liftIO $ readIORef (rqBody r)
let (SomeEnumerator e) = se
b <- liftM fromWrap $ joinIM $ e copyingStream2stream
return (r,b)
(req,body) <- run iter
assertEqual "post param 1"
(rqParam "postparam1" req)
(Just ["1"])
assertEqual "post param 2"
(rqParam "postparam2" req)
(Just ["2"])
-- make sure the post body is still emitted
assertEqual "parse body" (LC.fromChunks [samplePostBody3]) body
samplePostBody3 :: ByteString
samplePostBody3 = "postparam1=1&postparam2=2"
sampleRequest3 :: ByteString
sampleRequest3 =
S.concat [ "\r\nGET /foo/bar.html?param1=abc¶m2=def%20+¶m1=abc HTTP/1.1\r\n"
, "Content-Type: application/x-www-form-urlencoded\r\n"
, "Content-Length: 25\r\n"
, "Multiheader: 1\r\n"
, "Multiheader: 2\r\n"
, "X-Random-Other-Header: foo\r\n bar\r\n"
, "\r\n"
, samplePostBody3 ]
sampleRequest3' :: ByteString
sampleRequest3' =
S.concat [ "\r\nGET /foo/bar.html?param1=abc¶m2=def%20+¶m1=abc HTTP/1.1\r\n"
, "Content-Type: application/x-www-form-urlencoded; charset=UTF-8\r\n"
, "Content-Length: 25\r\n"
, "Multiheader: 1\r\n"
, "Multiheader: 2\r\n"
, "X-Random-Other-Header: foo\r\n bar\r\n"
, "\r\n"
, samplePostBody3 ]
rsm :: ServerMonad a -> Iteratee IO a
rsm = runServerMonad "localhost" "127.0.0.1" 80 "127.0.0.1" 58382 alog elog
where
alog = const . const . return $ ()
elog = const $ return ()
testHttpResponse1 :: Test
testHttpResponse1 = testCase "HttpResponse1" $ do
let onSendFile = \f _ -> enumFile f copyingStream2stream >>= run
buf <- mkIterateeBuffer
b <- run $ rsm $
sendResponse rsp1 copyingStream2stream buf (return ()) onSendFile >>=
return . fromWrap . snd
assertEqual "http response" (L.concat [
"HTTP/1.0 600 Test\r\n"
, "Content-Length: 10\r\n"
, "Foo: Bar\r\n\r\n"
, "0123456789"
]) b
where
rsp1 = updateHeaders (Map.insert "Foo" ["Bar"]) $
setContentLength 10 $
setResponseStatus 600 "Test" $
modifyResponseBody (>. (enumBS "0123456789")) $
setResponseBody return $
emptyResponse { rspHttpVersion = (1,0) }
testHttpResponse2 :: Test
testHttpResponse2 = testCase "HttpResponse2" $ do
let onSendFile = \f _ -> enumFile f copyingStream2stream >>= run
buf <- mkIterateeBuffer
b2 <- run $ rsm $
sendResponse rsp2 copyingStream2stream buf (return ()) onSendFile >>=
return . fromWrap . snd
assertEqual "http response" (L.concat [
"HTTP/1.0 600 Test\r\n"
, "Connection: close\r\n"
, "Foo: Bar\r\n\r\n"
, "0123456789"
]) b2
where
rsp1 = updateHeaders (Map.insert "Foo" ["Bar"]) $
setContentLength 10 $
setResponseStatus 600 "Test" $
modifyResponseBody (>. (enumBS "0123456789")) $
setResponseBody return $
emptyResponse { rspHttpVersion = (1,0) }
rsp2 = rsp1 { rspContentLength = Nothing }
testHttpResponse3 :: Test
testHttpResponse3 = testCase "HttpResponse3" $ do
let onSendFile = \f _ -> enumFile f copyingStream2stream >>= run
buf <- mkIterateeBuffer
b3 <- run $ rsm $
sendResponse rsp3 copyingStream2stream buf (return ()) onSendFile >>=
return . fromWrap . snd
assertEqual "http response" b3 $ L.concat [
"HTTP/1.1 600 Test\r\n"
, "Content-Type: text/plain\r\n"
, "Foo: Bar\r\n"
, "Transfer-Encoding: chunked\r\n\r\n"
, "a\r\n"
, "0123456789\r\n"
, "0\r\n\r\n"
]
where
rsp1 = updateHeaders (Map.insert "Foo" ["Bar"]) $
setContentLength 10 $
setResponseStatus 600 "Test" $
modifyResponseBody (>. (enumBS "0123456789")) $
setResponseBody return $
emptyResponse { rspHttpVersion = (1,0) }
rsp2 = rsp1 { rspContentLength = Nothing }
rsp3 = setContentType "text/plain" $ (rsp2 { rspHttpVersion = (1,1) })
testHttpResponse4 :: Test
testHttpResponse4 = testCase "HttpResponse4" $ do
let onSendFile = \f _ -> enumFile f copyingStream2stream >>= run
buf <- mkIterateeBuffer
b <- run $ rsm $
sendResponse rsp1 copyingStream2stream buf (return ()) onSendFile >>=
return . fromWrap . snd
assertEqual "http response" (L.concat [
"HTTP/1.0 304 Test\r\n"
, "Content-Length: 0\r\n\r\n"
]) b
where
rsp1 = setResponseStatus 304 "Test" $
emptyResponse { rspHttpVersion = (1,0) }
-- httpServe "127.0.0.1" 8080 "localhost" pongServer
echoServer :: (ByteString -> IO ())
-> Request
-> Iteratee IO (Request,Response)
echoServer _ req = do
se <- liftIO $ readIORef (rqBody req)
let (SomeEnumerator enum) = se
let i = joinIM $ enum copyingStream2stream
b <- liftM fromWrap i
let cl = L.length b
liftIO $ writeIORef (rqBody req) (SomeEnumerator $ return . joinI . take 0)
return (req, rsp b cl)
where
rsp s cl = emptyResponse { rspBody = Enum $ enumLBS s
, rspContentLength = Just $ fromIntegral cl }
echoServer2 :: ServerHandler
echoServer2 _ req = do
(rq,rsp) <- echoServer (const $ return ()) req
return (rq, addCookie cook rsp)
where
cook = Cookie "foo" "bar" (Just utc) (Just ".foo.com") (Just "/")
utc = UTCTime (ModifiedJulianDay 55226) 0
testHttp1 :: Test
testHttp1 = testCase "http session" $ do
let enumBody = enumBS sampleRequest >. enumBS sampleRequest2
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 ()) echoServer
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
, "\r"
, "0123456789HTTP/1.1 200 OK\r"
, "Content-Length: 14\r"
, d2
, s2
, "\r"
, "01234567890123" ]) -> (("Date" `L.isPrefixOf` d1) &&
("Date" `L.isPrefixOf` d2) &&
("Server" `L.isPrefixOf` s1) &&
("Server" `L.isPrefixOf` s2))
_ -> False
assertBool "pipelined responses" ok
mkIter :: IORef L.ByteString -> (Iteratee IO (), FilePath -> Int64 -> IO ())
mkIter ref = (iter, \f _ -> onF f iter)
where
iter = do
x <- copyingStream2stream
liftIO $ modifyIORef ref $ \s -> L.append s (fromWrap x)
onF f i = enumFile f i >>= run
testChunkOn1_0 :: Test
testChunkOn1_0 = testCase "transfer-encoding chunked" $ do
let enumBody = enumBS sampleRequest1_0
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 ()) f
-- this is a pretty lame way of checking whether the output was chunked,
-- but "whatever"
output <- liftM lower $ readIORef ref
assertBool "chunked output" $ not $ S.isInfixOf "chunked" output
assertBool "connection close" $ S.isInfixOf "connection: close" output
where
lower = S.map (c2w . toLower . w2c) . S.concat . L.toChunks
f :: ServerHandler
f _ req = do
let s = L.fromChunks $ Prelude.take 500 $ repeat "fldkjlfksdjlfd"
let out = enumLBS s
return (req, emptyResponse { rspBody = Enum out })
sampleRequest4 :: ByteString
sampleRequest4 =
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"
, "Connection: close\r\n"
, "X-Random-Other-Header: foo\r\n bar\r\n"
, "Cookie: foo=\"bar\\\"\"\r\n"
, "\r\n"
, "0123456789" ]
testHttp2 :: Test
testHttp2 = testCase "connection: close" $ do
let enumBody = enumBS sampleRequest4 >. enumBS sampleRequest2
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"
, "Connection: close\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 "connection: close" ok
testHttp100 :: Test
testHttp100 = testCase "Expect: 100-continue" $ do
let enumBody = enumBS sampleRequestExpectContinue
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 100 Continue\r"
, "\r"
, "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 "100 Continue" ok
pongServer :: Snap ()
pongServer = modifyResponse $ setResponseBody (enumBS "PONG") .
setContentType "text/plain" .
setContentLength 4
sendFileFoo :: Snap ()
sendFileFoo = sendFile "data/fileServe/foo.html"
testSendFile :: Test
testSendFile = testCase "sendFile" $ do
tid <- forkIO $ httpServe "*" port "localhost"
Nothing Nothing $
runSnap sendFileFoo
waitabit
rsp <- HTTP.simpleHTTP (HTTP.getRequest "http://localhost:8123/")
doc <- HTTP.getResponseBody rsp
killThread tid
waitabit
assertEqual "sendFile" "FOO\n" doc
where
waitabit = threadDelay $ ((10::Int)^(6::Int))
port = 8123
testServerStartupShutdown :: Test
testServerStartupShutdown = testCase "startup/shutdown" $ do
tid <- forkIO $
httpServe "*"
port
"localhost"
(Just "test-access.log")
(Just "test-error.log")
(runSnap pongServer)
waitabit
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 ()
where
waitabit = threadDelay $ 2*((10::Int)^(6::Int))
port = 8145