{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE PackageImports #-} module Snap.Internal.Http.Server.Tests ( tests ) where import Control.Concurrent import Control.Exception (try, throwIO, bracket, SomeException) import Control.Monad import "monads-fd" Control.Monad.Trans 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) import Data.ByteString.Internal (c2w) 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 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) 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 import qualified Snap.Internal.Http.Server.LibevBackend as Backend #else import qualified Snap.Internal.Http.Server.SimpleBackend as Backend #endif tests :: [Test] tests = [ testHttpRequest1 , testMultiRequest , testHttpRequest2 , testHttpRequest3 , testHttpRequest3' , testHttpResponse1 , testHttpResponse2 , testHttpResponse3 , testHttpResponse4 , testHttp1 , testHttp2 , testHttp100 , testExpectGarbage , testPartialParse , testMethodParsing , testServerStartupShutdown , testServerShutdownWithOpenConns , testChunkOn1_0 , testSendFile , testTrivials] testTrivials :: Test 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 -- 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" ] 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" , "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 "server/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 mkRequest :: ByteString -> IO Request mkRequest s = do iter <- enumBS s $ liftM fromJust $ rsm receiveRequest run iter testHttpRequest1 :: Test testHttpRequest1 = testCase "server/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 "server/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 (_::SomeException) -> return () Right _ -> assertFailure "expected exception, didn't get it" testPartialParse :: Test testPartialParse = testCase "server/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 "server/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 "server/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 "server/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 "server/HttpResponse1" $ do let onSendFile = \f start sz -> enumFilePartial f (start,start+sz) copyingStream2stream >>= run req <- mkRequest sampleRequest b <- run $ rsm $ sendResponse req rsp1 copyingStream2stream 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 "server/HttpResponse2" $ do let onSendFile = \f st sz -> enumFilePartial f (st,st+sz) copyingStream2stream >>= run req <- mkRequest sampleRequest b2 <- run $ rsm $ sendResponse req rsp2 copyingStream2stream 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 "server/HttpResponse3" $ do let onSendFile = \f st sz -> enumFilePartial f (st,st+sz) copyingStream2stream >>= run req <- mkRequest sampleRequest b3 <- run $ rsm $ sendResponse req rsp3 copyingStream2stream 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 "server/HttpResponse4" $ do let onSendFile = \f st sz -> enumFilePartial f (st,st+sz) copyingStream2stream >>= run req <- mkRequest sampleRequest b <- run $ rsm $ sendResponse req rsp1 copyingStream2stream 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 "server/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 -> Int64 -> IO ()) mkIter ref = (iter, \f st sz -> onF f st sz iter) where iter = do x <- copyingStream2stream liftIO $ modifyIORef ref $ \s -> L.append s (fromWrap x) onF f st sz i = enumFilePartial f (st,st+sz) i >>= run testChunkOn1_0 :: Test testChunkOn1_0 = testCase "server/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 toLower . 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 "server/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 "server/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 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 () pongServer = modifyResponse $ setResponseBody (enumBS "PONG") . setContentType "text/plain" . setContentLength 4 sendFileFoo :: Snap () sendFileFoo = sendFile "data/fileServe/foo.html" testSendFile :: Test testSendFile = testCase "server/sendFile" $ do bracket (forkIO $ httpServe "*" port "localhost" Nothing Nothing $ runSnap sendFileFoo) (killThread) (\tid -> do m <- timeout (120 * seconds) $ go tid maybe (assertFailure "timeout") (const $ return ()) m) 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 waitabit = threadDelay $ ((10::Int)^(6::Int)) port = 8123 testServerStartupShutdown :: Test testServerStartupShutdown = testCase "server/startup/shutdown" $ do 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) where go tid = do 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 () waitabit = threadDelay $ 2*((10::Int)^(6::Int)) port = 8145 testServerShutdownWithOpenConns :: Test testServerShutdownWithOpenConns = testCase "server/shutdown-open-conns" $ do tid <- forkIO $ httpServe "127.0.0.1" 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 e <- timeout (75*seconds) $ takeMVar result 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)