snap-server-1.1.2.1: test/Snap/Internal/Http/Server/Parser/Tests.hs
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Snap.Internal.Http.Server.Parser.Tests (tests) where
------------------------------------------------------------------------------
import Control.Monad (liftM)
import Control.Parallel.Strategies (rdeepseq, using)
import qualified Data.ByteString.Char8 as S
import qualified Data.ByteString.Lazy.Char8 as L
import Data.List (sort)
import qualified Data.Map as Map
import Data.Monoid (mconcat)
import Text.Printf (printf)
------------------------------------------------------------------------------
import Data.ByteString.Builder (byteString, toLazyByteString)
import Test.Framework (Test)
import Test.Framework.Providers.HUnit (testCase)
import Test.Framework.Providers.QuickCheck2 (testProperty)
import Test.HUnit (assertEqual)
import Test.QuickCheck (Arbitrary (arbitrary))
import Test.QuickCheck.Monadic (forAllM, monadicIO)
import qualified Test.QuickCheck.Monadic as QC
------------------------------------------------------------------------------
import Snap.Internal.Debug (debug)
import Snap.Internal.Http.Server.Parser (HttpParseException (..), IRequest (IRequest, iMethod, iRequestHeaders, iStdHeaders), getStdHost, parseCookie, parseRequest, parseUrlEncoded, readChunkedTransferEncoding, writeChunkedTransferEncoding)
import Snap.Internal.Http.Types (Cookie (Cookie), Method (CONNECT, DELETE, GET, HEAD, Method, OPTIONS, PATCH, POST, PUT, TRACE))
import Snap.Test.Common (coverEqInstance, coverShowInstance, coverTypeableInstance, expectException)
import qualified Snap.Types.Headers as H
import qualified System.IO.Streams as Streams
------------------------------------------------------------------------------
tests :: [Test]
tests = [ testShow
, testCookie
, testChunked
, testNull
, testPartial
, testParseError
, testFormEncoded
, testTrivials
, testMethods
, testSimpleParse
, testSimpleParseErrors
, testWriteChunkedTransferEncoding
]
------------------------------------------------------------------------------
testShow :: Test
testShow = testCase "parser/show" $ do
let i = IRequest GET "/" (1, 1) H.empty undefined
let !b = show i `using` rdeepseq
return $ b `seq` ()
------------------------------------------------------------------------------
testNull :: Test
testNull = testCase "parser/shortParse" $
expectException (Streams.fromList [] >>= parseRequest)
------------------------------------------------------------------------------
testPartial :: Test
testPartial = testCase "parser/partial" $
expectException (Streams.fromList ["GET / "] >>= parseRequest)
------------------------------------------------------------------------------
testParseError :: Test
testParseError = testCase "parser/error" $ do
expectException (Streams.fromList ["ZZZZZZZZZ"] >>= parseRequest)
expectException (Streams.fromList ["GET / HTTP/1.1"] >>= parseRequest)
expectException (Streams.fromList ["GET / HTTP/x.z\r\n\r\n"] >>=
parseRequest)
------------------------------------------------------------------------------
-- | convert a bytestring to chunked transfer encoding
transferEncodingChunked :: L.ByteString -> L.ByteString
transferEncodingChunked = f . L.toChunks
where
toChunk s = L.concat [ len, "\r\n", L.fromChunks [s], "\r\n" ]
where
len = L.pack $ printf "%x" $ S.length s
f l = L.concat $ (map toChunk l ++ ["0\r\n\r\n"])
------------------------------------------------------------------------------
-- | ensure that running 'readChunkedTransferEncoding' against
-- 'transferEncodingChunked' returns the original string
testChunked :: Test
testChunked = testProperty "parser/chunkedTransferEncoding" $
monadicIO $ forAllM arbitrary prop_chunked
where
prop_chunked s = QC.run $ do
debug "=============================="
debug $ "input is " ++ show s
debug $ "chunked is " ++ show chunked
debug "------------------------------"
out <- Streams.fromList (L.toChunks chunked) >>=
readChunkedTransferEncoding >>=
Streams.toList >>=
return . L.fromChunks
assertEqual "chunked" s out
debug "==============================\n"
where
chunked = transferEncodingChunked s
------------------------------------------------------------------------------
testWriteChunkedTransferEncoding :: Test
testWriteChunkedTransferEncoding = testCase "parser/writeChunked" $ do
(os, getList) <- Streams.listOutputStream
os' <- writeChunkedTransferEncoding os
Streams.fromList [byteString "ok"] >>= Streams.connectTo os'
Streams.write Nothing os'
s <- liftM (toLazyByteString . mconcat) getList
assertEqual "chunked" "002\r\nok\r\n0\r\n\r\n" s
------------------------------------------------------------------------------
testCookie :: Test
testCookie =
testCase "parser/parseCookie" $ do
assertEqual "cookie parsing" (Just [cv]) cv2
where
cv = Cookie nm v Nothing Nothing Nothing False False
cv2 = parseCookie ct
nm = "foo"
v = "bar"
ct = S.concat [ nm , "=" , v ]
------------------------------------------------------------------------------
testFormEncoded :: Test
testFormEncoded = testCase "parser/formEncoded" $ do
let bs = "foo1=bar1&foo2=bar2+baz2;foo3=foo%20bar"
let mp = parseUrlEncoded bs
assertEqual "foo1" (Just ["bar1"] ) $ Map.lookup "foo1" mp
assertEqual "foo2" (Just ["bar2 baz2"]) $ Map.lookup "foo2" mp
assertEqual "foo3" (Just ["foo bar"] ) $ Map.lookup "foo3" mp
------------------------------------------------------------------------------
testTrivials :: Test
testTrivials = testCase "parser/trivials" $ do
coverTypeableInstance (undefined :: HttpParseException)
coverShowInstance (HttpParseException "ok")
coverEqInstance (IRequest GET "" (0, 0) H.empty undefined)
------------------------------------------------------------------------------
testMethods :: Test
testMethods = testCase "parser/methods" $ mapM_ testOne ms
where
ms = [ GET, POST, HEAD, PUT, DELETE, TRACE, OPTIONS, CONNECT, PATCH
, Method "ZZZ" ]
mToStr (Method m) = m
mToStr m = S.pack $ show m
restOfRequest = [ " / HTTP/1.1\r\nz:b\r\nq:\r\nw\r\n", "foo: ", "bar"
, "\r\n baz\r\n\r\n" ]
testOne m = let s = mToStr m
in Streams.fromList (s:restOfRequest) >>=
parseRequest >>=
checkMethod m
checkMethod m i = do
assertEqual "method" m $ iMethod i
let expected = sort [ ("z", "b")
, ("q", "")
, ("w", "")
, ("foo", "bar baz")
]
assertEqual "hdrs" expected $ sort $ H.toList $ iRequestHeaders i
------------------------------------------------------------------------------
testSimpleParse :: Test
testSimpleParse = testCase "parser/simpleParse" $ do
Streams.fromList ["GET / HTTP/1.1\r\n\r\n"] >>=
parseRequest >>=
assertEqual "simple0" (IRequest GET "/" (1, 1) H.empty undefined)
Streams.fromList ["GET http://foo.com/ HTTP/1.1\r\n\r\n"] >>=
parseRequest >>=
assertEqual "simple1" (IRequest GET "/" (1, 1) H.empty undefined)
z <- Streams.fromList ["GET http://foo.com HTTP/1.1\r\n\r\n"] >>=
parseRequest
assertEqual "simple2" z (IRequest GET "/" (1, 1) H.empty undefined)
assertEqual "simple2-host" (Just "foo.com") (getStdHost $ iStdHeaders z)
z2 <- Streams.fromList ["GET https://foo.com/ HTTP/1.1\r\n\r\n"] >>=
parseRequest
assertEqual "simpleHttps" (IRequest GET "/" (1, 1) H.empty undefined) z2
assertEqual "simpleHttps-2" (Just "foo.com") (getStdHost $ iStdHeaders z2)
Streams.fromList ["GET / HTTP/1.1\r\nz:b\r\n", "", "\r\n"] >>=
parseRequest >>=
assertEqual "simple4" (IRequest GET "/" (1, 1)
(H.fromList [("z", "b")]) undefined)
Streams.fromList [ "GET / HTTP/1.1\r\na:a\r", "\nz:b\r\n", ""
, "\r\n" ] >>=
parseRequest >>=
assertEqual "simple5" (IRequest GET "/" (1, 1)
(H.fromList [("a", "a"), ("z", "b")]) undefined)
Streams.fromList ["GET /\r\n\r\n"] >>=
parseRequest >>=
assertEqual "simple6" (IRequest GET "/" (1, 0) H.empty undefined)
Streams.fromList ["G", "ET", " /\r", "\n\r", "", "\n"] >>=
parseRequest >>=
assertEqual "simple7" (IRequest GET "/" (1, 0) H.empty undefined)
------------------------------------------------------------------------------
testSimpleParseErrors :: Test
testSimpleParseErrors = testCase "parser/simpleParseErrors" $ do
expectException (
Streams.fromList ["\r\nGET / HTTP/1.1\r\nz:b\r\n \r\n"] >>=
parseRequest)
expectException (
Streams.fromList ["\r\nGET / HTTP/1.1\r\nz:b\r "] >>=
parseRequest)
expectException (
Streams.fromList ["\r\nGET / HTTP/1.1\r"] >>=
parseRequest)
expectException (
Streams.fromList ["\r\nGET / HTTP/1.1\r", "", "foo\nz:b\r "] >>=
parseRequest)