{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} module Snap.Internal.Http.Server.Tests ( tests ) where import Control.Concurrent import Control.Exception (try, SomeException) import Control.Monad import 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.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 import System.IO tests :: [Test] tests = [ testHttpRequest1 , testMultiRequest , testHttpRequest2 , testHttpRequest3 , testHttpResponse1 , testHttp1 , testHttp2 , 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" ] 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" $ 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"]) -- if we're www-form-encoded then we will have read the body already assertEqual "parse body" "" body 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" , "postparam1=1&postparam2=2" ] 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 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 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) }) -- 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 -> 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 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 $ ((10::Int)^(6::Int)) port = 8145