{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PackageImports #-} {-# LANGUAGE ScopedTypeVariables #-} module Snap.Internal.Http.Server.Tests ( tests ) where import Blaze.ByteString.Builder import Blaze.ByteString.Builder.Enumerator import Control.Concurrent import Control.Exception (Exception, SomeException, bracket, catch, finally, throwIO, try) import Control.Monad import Control.Monad.Trans import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as S import Data.ByteString.Internal (c2w) import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Lazy.Char8 as LC import qualified Data.CaseInsensitive as CI import Data.Char import qualified Data.Enumerator as E import qualified Data.Enumerator.List as EL import Data.Int import Data.IORef import Data.List (foldl', sort) import Data.Maybe (fromJust, isJust) import Data.Time.Calendar import Data.Time.Clock import Data.Typeable import qualified Network.HTTP.Conduit as HTTP import qualified Network.Socket.ByteString as N import Prelude hiding (catch, 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.Core import Snap.Internal.Debug import Snap.Internal.Http.Server import Snap.Internal.Http.Server.Backend import Snap.Internal.Http.Types import Snap.Iteratee hiding (map) import qualified Snap.Iteratee as I import Snap.Test.Common import qualified Snap.Types.Headers as H data TestException = TestException deriving (Show, Typeable) instance Exception TestException tests :: [Test] tests = [ testHttpRequest1 , testMultiRequest , testHttpRequest2 , testHttpRequest3 , testHttpRequest3' , testHttpResponse1 , testHttpResponse2 , testHttpResponse3 , testHttpResponse4 , testHttpResponseCookies , testHttp1 , testHttp2 , testHttp100 , test411 , testEscapeHttp , testExpectGarbage , testPartialParse , testMethodParsing , testServerStartupShutdown , testServerShutdownWithOpenConns , testChunkOn1_0 , testSendFile , testTrivials] testTrivials :: Test testTrivials = testCase "server/trivials" $ do let !v = Svr.snapServerVersion return $! v `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" ] sampleRequest411 :: ByteString sampleRequest411 = S.concat [ "\r\nPOST /foo/bar.html?param1=abc¶m2=def%20+¶m1=abc HTTP/1.1\r\n" , "Host: www.zabble.com:7777\r\n" , "X-Random-Other-Header: foo\r\n bar\r\n" , "Cookie: foo=\"bar\\\"\"\r\n" , "\r\n" ] 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, PATCH , Method "COPY", Method "MOVE" ] dummyIter :: Iteratee ByteString IO () dummyIter = consume >> return () testReceiveRequest :: Iteratee ByteString IO (Request,L.ByteString) testReceiveRequest = do r <- liftM fromJust $ rsm $ receiveRequest dummyIter se <- liftIO $ readIORef (rqBody r) let (SomeEnumerator e) = se it <- liftM e $ lift $ runIteratee copyingStream2Stream b <- it return (r,b) testReceiveRequestIter :: ByteString -> IO (Iteratee ByteString IO (Request,L.ByteString)) testReceiveRequestIter req = liftM (enumBS req) $ runIteratee testReceiveRequest testHttpRequest1 :: Test testHttpRequest1 = testCase "server/HttpRequest1" $ do iter <- testReceiveRequestIter sampleRequest (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 False False] (rqCookies req) assertEqual "continued headers" (Just ["foo bar"]) $ H.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 let clientIter = do (r1,b1) <- testReceiveRequest (r2,b2) <- testReceiveRequest return (r1,b1,r2,b2) iter <- liftM (enumBS sampleRequest >==> enumBS sampleRequest) $ runIteratee clientIter (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 step <- runIteratee $ liftM fromJust $ rsm $ receiveRequest dummyIter let iter = enumLBS txt step req <- run_ iter assertEqual "method" m $ rqMethod req where txt = methodTestText m sampleShortRequest :: ByteString sampleShortRequest = "GET /fo" testPartialParse :: Test testPartialParse = testCase "server/short" $ do step <- runIteratee $ liftM fromJust $ rsm $ receiveRequest dummyIter let iter = enumBS sampleShortRequest step expectException $ run_ iter methodTestText :: Method -> L.ByteString methodTestText m = L.concat [ mbs m , " / HTTP/1.1\r\nContent-Length: 0\r\n\r\n" ] where mbs (Method b) = L.fromChunks [b] mbs b = L.pack $ map c2w $ show b 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 <- testReceiveRequestIter sampleRequest2 (_,body) <- run_ iter assertEqual "parse body" "01234567890123" body testHttpRequest3 :: Test testHttpRequest3 = testCase "server/HttpRequest3" $ do iter <- testReceiveRequestIter sampleRequest3 (req,body) <- run_ iter assertEqual "no cookies" [] $ rqCookies req assertEqual "multiheader" (Just ["1","2"]) $ H.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 <- testReceiveRequestIter sampleRequest3' (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 ByteString IO a rsm = runServerMonad "localhost" (SessionInfo "127.0.0.1" 80 "127.0.0.1" 58382 False) alog elog where alog = const . const . return $ () elog = const $ return () testHttpResponse1 :: Test testHttpResponse1 = testCase "server/HttpResponse1" $ do buf <- allocBuffer 16384 b <- run_ $ rsm $ sendResponse rsp1 buf copyingStream2Stream testOnSendFile >>= return . snd assertBool "http response" (b == text1 || b == text2) where text1 = L.concat [ "HTTP/1.0 600 Test\r\n" , "Content-Length: 10\r\n" , "Foo: Bar\r\n\r\n" , "0123456789" ] text2 = L.concat [ "HTTP/1.0 600 Test\r\n" , "Foo: Bar\r\n" , "Content-Length: 10\r\n\r\n" , "0123456789" ] rsp1 = updateHeaders (H.insert "Foo" "Bar") $ setContentLength' 10 $ setResponseStatus 600 "Test" $ modifyResponseBody (>==> (enumBuilder $ fromByteString "0123456789")) $ setResponseBody returnI $ emptyResponse { rspHttpVersion = (1,0) } strToHeaders :: L.ByteString -> H.Headers strToHeaders s = foldl' mkHeader H.empty lns where lns = LC.lines s mkHeader hdrs x = hdrs' where (a0,b0) = LC.break (== ':') x a = CI.mk $ S.concat $ LC.toChunks a0 b = S.concat $ LC.toChunks $ LC.drop 2 b0 hdrs' = H.insert a b hdrs testOnSendFile :: FilePath -> Int64 -> Int64 -> IO L.ByteString testOnSendFile f st sz = do sstep <- runIteratee copyingStream2Stream run_ $ enumFilePartial f (st,st+sz) sstep testHttpResponse2 :: Test testHttpResponse2 = testCase "server/HttpResponse2" $ do buf <- allocBuffer 16384 b2 <- liftM (S.concat . L.toChunks) $ run_ $ rsm $ sendResponse rsp2 buf copyingStream2Stream testOnSendFile >>= return . snd assertBool "http prefix" ("HTTP/1.0 600 Test\r\n" `S.isPrefixOf` b2) assertBool "connection close" ("Connection: close\r\n" `S.isInfixOf` b2) assertBool "foo: bar" ("Foo: Bar\r\n" `S.isInfixOf` b2) assertBool "body" ("\r\n\r\n0123456789" `S.isSuffixOf` b2) where rsp1 = updateHeaders (H.insert "Foo" "Bar") $ setContentLength' 10 $ setResponseStatus 600 "Test" $ modifyResponseBody (>==> (enumBuilder $ fromByteString "0123456789")) $ setResponseBody returnI $ emptyResponse { rspHttpVersion = (1,0) } rsp2 = rsp1 { rspContentLength = Nothing } testHttpResponse3 :: Test testHttpResponse3 = testCase "server/HttpResponse3" $ do buf <- allocBuffer 16384 b3 <- run_ $ rsm $ sendResponse rsp3 buf copyingStream2Stream testOnSendFile >>= return . snd let lns = LC.lines b3 let ok = case lns of ([ "HTTP/1.1 600 Test\r" , h1, h2, h3 , "\r" , "000A\r" , "0123456789\r" , "0\r" , "\r"]) -> check $ LC.unlines [h1,h2,h3] _ -> False when (not ok) $ LC.putStrLn $ LC.concat ["***testHttpResponse3: b3 was:\n", b3] assertBool "http response" ok where check s = (H.lookup "Content-Type" hdrs == Just ["text/plain\r"]) && (H.lookup "Foo" hdrs == Just ["Bar\r"]) && (H.lookup "Transfer-Encoding" hdrs == Just ["chunked\r"]) where hdrs = strToHeaders s rsp1 = updateHeaders (H.insert "Foo" "Bar") $ setContentLength' 10 $ setResponseStatus 600 "Test" $ modifyResponseBody (>==> (enumBuilder $ fromByteString "0123456789")) $ setResponseBody returnI $ emptyResponse { rspHttpVersion = (1,0) } rsp2 = deleteHeader "Content-Length" $ rsp1 { rspContentLength = Nothing } rsp3 = setContentType "text/plain" $ (rsp2 { rspHttpVersion = (1,1) }) testHttpResponse4 :: Test testHttpResponse4 = testCase "server/HttpResponse4" $ do buf <- allocBuffer 16384 b <- run_ $ rsm $ sendResponse rsp1 buf copyingStream2Stream testOnSendFile >>= return . 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" $ setContentLength' 0 $ emptyResponse { rspHttpVersion = (1,0) } testHttpResponseCookies :: Test testHttpResponseCookies = testCase "server/HttpResponseCookies" $ do buf <- allocBuffer 16384 b <- run_ $ rsm $ sendResponse rsp2 buf copyingStream2Stream testOnSendFile >>= return . snd let lns = LC.lines b let ok = case lns of ([ "HTTP/1.0 304 Test\r" , h1, h2, h3, h4 , "\r"]) -> check $ LC.unlines [h1,h2,h3,h4] _ -> False when (not ok) $ LC.putStrLn $ LC.concat ["*** testHttpResponseCookies: b was:\n", b] assertBool "http response" ok where check s = (H.lookup "Connection" hdrs == Just ["close\r"]) && (ch $ H.lookup "Set-Cookie" hdrs) where hdrs = strToHeaders s ch Nothing = False ch (Just l) = sort l == [ "ck1=bar; path=/; expires=Sat, 30-Jan-2010 00:00:00 GMT; domain=.foo.com; Secure\r" , "ck2=bar; path=/; expires=Sat, 30-Jan-2010 00:00:00 GMT; domain=.foo.com; HttpOnly\r" , "ck3=bar\r" ] rsp1 = setResponseStatus 304 "Test" $ emptyResponse { rspHttpVersion = (1,0) } rsp2 = addResponseCookie cook3 . addResponseCookie cook2 . addResponseCookie cook $ rsp1 utc = UTCTime (ModifiedJulianDay 55226) 0 cook = Cookie "ck1" "bar" (Just utc) (Just ".foo.com") (Just "/") True False cook2 = Cookie "ck2" "bar" (Just utc) (Just ".foo.com") (Just "/") False True cook3 = Cookie "ck3" "bar" Nothing Nothing Nothing False False echoServer :: (ByteString -> IO ()) -> ((Int -> Int) -> IO ()) -> Request -> Iteratee ByteString IO (Request,Response) echoServer _ _ req = do se <- liftIO $ readIORef (rqBody req) let (SomeEnumerator enum) = se i <- liftM enum $ lift $ runIteratee copyingStream2Stream b <- i let cl = L.length b liftIO $ writeIORef (rqBody req) (SomeEnumerator $ joinI . I.take 0) return (req, rsp b cl) where rsp s cl = setContentLength' cl $ emptyResponse { rspBody = Enum $ enumBuilder (fromLazyByteString s) } echoServer2 :: ServerHandler echoServer2 _ _ req = do (rq,rsp) <- echoServer (const $ return ()) (const $ return ()) req return (rq, addResponseCookie cook rsp) where cook = Cookie "foo" "bar" (Just utc) (Just ".foo.com") (Just "/") False False utc = UTCTime (ModifiedJulianDay 55226) 0 testHttp1 :: Test testHttp1 = testCase "server/httpSession" $ do let enumBody = enumBS sampleRequest >==> enumBS sampleRequest2 ref <- newIORef "" let (iter,onSendFile) = mkIter ref runHTTP 60 Nothing Nothing echoServer "localhost" (SessionInfo "127.0.0.1" 80 "127.0.0.1" 58384 False) enumBody iter onSendFile (const $ return ()) s <- readIORef ref let lns = LC.lines s let ok = case lns of ([ "HTTP/1.1 200 OK\r" , h1 , h2 , h3 , "\r" , "0123456789HTTP/1.1 200 OK\r" , g1 , g2 , g3 , "\r" , "01234567890123" ]) -> (check1 $ LC.unlines [h1,h2,h3]) && (check2 $ LC.unlines [g1,g2,g3]) _ -> False when (not ok) $ do putStrLn "server/httpSession fail!!!! got:" LC.putStrLn s assertBool "pipelined responses" ok where check1 s = (H.lookup "Content-Length" hdrs == Just ["10\r"]) && (isJust $ H.lookup "Server" hdrs) && (isJust $ H.lookup "Date" hdrs) where hdrs = strToHeaders s check2 s = (H.lookup "Content-Length" hdrs == Just ["14\r"]) && (isJust $ H.lookup "Server" hdrs) && (isJust $ H.lookup "Date" hdrs) where hdrs = strToHeaders s mkIter :: IORef L.ByteString -> (Iteratee ByteString 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 x onF f st sz i = do step <- runIteratee i let it = enumFilePartial f (st,st+sz) step run_ it testChunkOn1_0 :: Test testChunkOn1_0 = testCase "server/transfer-encoding chunked" $ do let enumBody = enumBS sampleRequest1_0 ref <- newIORef "" let (iter,onSendFile) = mkIter ref done <- newEmptyMVar forkIO (runHTTP 60 Nothing Nothing f "localhost" (SessionInfo "127.0.0.1" 80 "127.0.0.1" 58384 False) enumBody iter onSendFile (const $ return ()) `finally` putMVar done ()) takeMVar done -- 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 = enumBuilder $ fromLazyByteString 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/connectionClose" $ do let enumBody = enumBS sampleRequest4 >==> enumBS sampleRequest2 ref <- newIORef "" let (iter,onSendFile) = mkIter ref done <- newEmptyMVar forkIO (runHTTP 60 Nothing Nothing echoServer2 "localhost" (SessionInfo "127.0.0.1" 80 "127.0.0.1" 58384 False) enumBody iter onSendFile (const $ return ()) `finally` putMVar done ()) takeMVar done s <- readIORef ref let lns = LC.lines s let ok = case lns of ([ "HTTP/1.1 200 OK\r" , h1 , h2 , h3 , h4 , h5 , "\r" , "0123456789" ]) -> (check $ LC.unlines [h1,h2,h3,h4,h5]) _ -> False assertBool "connection: close" ok where check s = (H.lookup "Content-Length" hdrs == Just ["10\r"]) && (H.lookup "Connection" hdrs == Just ["close\r"]) && (H.lookup "Set-Cookie" hdrs == Just [ "foo=bar; path=/; expires=Sat, 30-Jan-2010 00:00:00 GMT; domain=.foo.com\r" ]) && (isJust $ H.lookup "Server" hdrs) && (isJust $ H.lookup "Date" hdrs) where hdrs = strToHeaders s testHttp100 :: Test testHttp100 = testCase "server/expect100" $ do let enumBody = enumBS sampleRequestExpectContinue ref <- newIORef "" let (iter,onSendFile) = mkIter ref runHTTP 60 Nothing Nothing echoServer2 "localhost" (SessionInfo "127.0.0.1" 80 "127.0.0.1" 58384 False) enumBody iter onSendFile (const $ return ()) 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" , h1 , h2 , h3 , h4 , "\r" , "0123456789" ]) -> (check $ LC.unlines [h1,h2,h3,h4]) _ -> False when (not ok) $ do putStrLn "expect100 fail! got:" LC.putStrLn s assertBool "100 Continue" ok where check s = (H.lookup "Content-Length" hdrs == Just ["10\r"]) && (H.lookup "Set-Cookie" hdrs == Just [ "foo=bar; path=/; expires=Sat, 30-Jan-2010 00:00:00 GMT; domain=.foo.com\r" ]) && (isJust $ H.lookup "Server" hdrs) && (isJust $ H.lookup "Date" hdrs) where hdrs = strToHeaders s test411 :: Test test411 = testCase "server/expect411" $ do let enumBody = enumBS sampleRequest411 ref <- newIORef "" let (iter,onSendFile) = mkIter ref runHTTP 60 Nothing Nothing echoServer2 "localhost" (SessionInfo "127.0.0.1" 80 "127.0.0.1" 58384 False) enumBody iter onSendFile (const $ return ()) s <- readIORef ref let lns = LC.lines s let ok = case lns of ("HTTP/1.1 411 Length Required\r":_) -> True _ -> False when (not ok) $ do putStrLn "expect411 fail! got:" LC.putStrLn s assertBool "411 Length Required" ok testEscapeHttp :: Test testEscapeHttp = testCase "server/escapeHttp" $ do ref <- newIORef "" let (iter,onSendFile) = mkIter ref runHTTP 60 Nothing Nothing escapeServer "localhost" (SessionInfo "127.0.0.1" 80 "127.0.0.1" 58384 False) (enumBS sampleRequest) iter onSendFile (const $ return ()) s <- readIORef ref assertEqual "escapeHttp" "0123456789" s where -- Escape HTTP traffic. Read one ByteString and send it back. escapeServer = runSnap $ escapeHttp $ \_ sendIter -> do Just bs <- EL.head liftIO $ E.run_ $ E.enumList 1 [bs] $$ sendIter testExpectGarbage :: Test testExpectGarbage = testCase "server/expectGarbage" $ do let enumBody = enumBS sampleRequestExpectGarbage ref <- newIORef "" let (iter,onSendFile) = mkIter ref runHTTP 60 Nothing Nothing echoServer2 "localhost" (SessionInfo "127.0.0.1" 80 "127.0.0.1" 58384 False) enumBody iter onSendFile (const $ return ()) s <- readIORef ref let lns = LC.lines s let ok = case lns of ([ "HTTP/1.1 200 OK\r" , h1 , h2 , h3 , h4 , "\r" , "0123456789" ]) -> (check $ LC.unlines [h1,h2,h3,h4]) _ -> False assertBool "random expect: header" ok where check s = (H.lookup "Content-Length" hdrs == Just ["10\r"]) && (H.lookup "Set-Cookie" hdrs == Just [ "foo=bar; path=/; expires=Sat, 30-Jan-2010 00:00:00 GMT; domain=.foo.com\r" ]) && (isJust $ H.lookup "Server" hdrs) && (isJust $ H.lookup "Date" hdrs) where hdrs = strToHeaders s pongServer :: Snap () pongServer = modifyResponse $ setResponseBody enum . setContentType "text/plain" . setContentLength' 4 where enum = enumBuilder $ fromByteString "PONG" sendFileFoo :: Snap () sendFileFoo = sendFile "data/fileServe/foo.html" testSendFile :: Test testSendFile = testCase "server/sendFile" $ do bracket (forkIO serve) (killThread) (\tid -> do m <- timeout (120 * seconds) $ go tid maybe (assertFailure "timeout") (const $ return ()) m) where serve = (httpServe 60 [HttpPort "*" port] "localhost" Nothing Nothing (const $ return ()) $ runSnap sendFileFoo) `catch` \(_::SomeException) -> return () go tid = do waitabit doc <- HTTP.simpleHttp "http://127.0.0.1:8123/" 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 20 [HttpPort "*" port] "localhost" (Just $ const (return ())) -- dummy logging (Just $ const (return ())) -- dummy logging (const $ return ()) (runSnap pongServer)) (killThread) (\tid -> do m <- timeout (120 * seconds) $ go tid maybe (assertFailure "timeout") (const $ return ()) m) where go tid = do debug $ "testServerStartupShutdown: waiting a bit" waitabit debug $ "testServerStartupShutdown: sending http request" doc <- HTTP.simpleHttp "http://127.0.0.1:8145/" assertEqual "server" "PONG" doc debug $ "testServerStartupShutdown: killing thread" killThread tid debug $ "testServerStartupShutdown: kill signal sent to thread" waitabit expectException $ HTTP.simpleHttp "http://127.0.0.1:8145/" return () waitabit = threadDelay $ 2*((10::Int)^(6::Int)) port = 8145 testServerShutdownWithOpenConns :: Test testServerShutdownWithOpenConns = testCase "server/shutdown-open-conns" $ do tid <- forkIO $ httpServe 20 [HttpPort "*" port] "localhost" Nothing Nothing (const $ return ()) (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 TestException 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 = 8149 seconds :: Int seconds = (10::Int) ^ (6::Int) copyingStream2Stream :: (Monad m) => Iteratee ByteString m L.ByteString copyingStream2Stream = go [] where go l = do mbx <- I.head maybe (return $ L.fromChunks $ reverse l) (\x -> let !z = S.copy x in go (z:l)) mbx setContentLength' :: Int64 -> Response -> Response setContentLength' cl = setHeader "Content-Length" (S.pack $ show cl) . setContentLength cl