{-# LANGUAGE BangPatterns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} module Snap.Internal.Http.Parser.Tests ( tests ) where import qualified Control.Exception as E import Control.Exception hiding (try, assert) import Control.Monad import Control.Monad.Identity import Control.Parallel.Strategies import Data.Attoparsec hiding (Result(..)) import Data.ByteString (ByteString) import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L import Data.ByteString.Internal (c2w) import Data.IORef import Data.Iteratee.WrappedByteString import Data.List import qualified Data.Map as Map import Data.Maybe (isNothing) import Test.Framework import Test.Framework.Providers.HUnit import Test.Framework.Providers.QuickCheck2 import Test.QuickCheck import qualified Test.QuickCheck.Monadic as QC import Test.QuickCheck.Monadic hiding (run, assert) import Test.HUnit hiding (Test, path) import Text.Printf import Snap.Internal.Http.Parser import Snap.Internal.Http.Types hiding (Enumerator) import Snap.Iteratee hiding (foldl') import Snap.Test.Common() tests :: [Test] tests = [ testShow , testCookie , testChunked , testBothChunked , testBothChunkedBuffered1 , testBothChunkedBuffered2 , testBothChunkedPipelined , testBothChunkedEmpty , testP2I , testNull , testPartial , testIterateeError , testIterateeError2 , testParseError , testFormEncoded ] emptyParser :: Parser ByteString emptyParser = option "foo" $ string "bar" testShow :: Test testShow = testCase "show" $ do let i = IRequest GET "/" (1,1) [] let !b = show i `using` rdeepseq return $ b `seq` () testP2I :: Test testP2I = testCase "parserToIteratee" $ do i <- enumBS "z" (parserToIteratee emptyParser) l <- run i assertEqual "should be foo" "foo" l forceErr :: SomeException -> IO () forceErr e = f `seq` (return ()) where !f = show e testNull :: Test testNull = testCase "short parse" $ do f <- run (parseRequest) assertBool "should be Nothing" $ isNothing f testPartial :: Test testPartial = testCase "partial parse" $ do i <- enumBS "GET / " parseRequest f <- E.try $ run i case f of (Left e) -> forceErr e (Right x) -> assertFailure $ "expected exception, got " ++ show x testParseError :: Test testParseError = testCase "parse error" $ do i <- enumBS "ZZZZZZZZZZ" parseRequest f <- E.try $ run i case f of (Left e) -> forceErr e (Right x) -> assertFailure $ "expected exception, got " ++ show x introduceError :: (Monad m) => Enumerator m a introduceError iter = return $ IterateeG $ \_ -> runIter iter (EOF (Just (Err "EOF"))) testIterateeError :: Test testIterateeError = testCase "iteratee error" $ do i <- liftM liftI $ runIter parseRequest (EOF (Just (Err "foo"))) f <- E.try $ run i case f of (Left e) -> forceErr e (Right x) -> assertFailure $ "expected exception, got " ++ show x testIterateeError2 :: Test testIterateeError2 = testCase "iteratee error 2" $ do i <- (enumBS "GET / " >. introduceError) parseRequest f <- E.try $ run i case f of (Left e) -> forceErr e (Right x) -> assertFailure $ "expected exception, got " ++ show x -- | 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 $ map c2w $ printf "%x" $ S.length s f l = L.concat $ (map toChunk l ++ ["0\r\n\r\n"]) -- | ensure that running the 'readChunkedTransferEncoding' iteratee against -- 'transferEncodingChunked' returns the original string testChunked :: Test testChunked = testProperty "chunked transfer encoding" prop_chunked where prop_chunked :: L.ByteString -> Bool prop_chunked s = runIdentity (run iter) == s where enum = enumLBS (transferEncodingChunked s) iter :: Iteratee Identity L.ByteString iter = runIdentity $ do i <- (readChunkedTransferEncoding stream2stream) >>= enum return $ liftM fromWrap i testBothChunked :: Test testBothChunked = testProperty "chunk . unchunk == id" $ monadicIO $ forAllM arbitrary prop where prop s = do buf <- QC.run mkIterateeBuffer bs <- QC.run $ writeChunkedTransferEncoding buf (enumBS s) stream2stream >>= run >>= return . unWrap let enum = enumBS bs iter <- do i <- (readChunkedTransferEncoding stream2stream) >>= enum return $ liftM unWrap i x <- run iter QC.assert $ s == x testBothChunkedBuffered1 :: Test testBothChunkedBuffered1 = testProperty "testBothChunkedBuffered1" $ monadicIO prop where prop = do sz <- QC.pick (choose (1000,4000)) s' <- QC.pick $ resize sz arbitrary ntimes <- QC.pick (choose (4,7)) let e = enumLBS s' buf <- QC.run mkIterateeBuffer enums <- QC.run $ replicateM ntimes (mkIterateeBuffer >>= return . flip writeChunkedTransferEncoding e) let mothra = foldl' (>.) (enumBS "") enums ---------------------------------------------------------------------- -- first go, buffer, no cancellation (inputIter1,_) <- QC.run $ bufferIteratee stream2stream bs1 <- QC.run $ mothra inputIter1 >>= run >>= return . unWrap let e1 = enumBS bs1 let pcrlf = \s -> parserToIteratee $ string "\r\n" >> return s iters <- QC.run $ replicateM ntimes $ readChunkedTransferEncoding stream2stream let godzilla = sequence $ map (>>= pcrlf) iters outiter1 <- QC.run $ e1 godzilla x1 <- QC.run $ liftM (map unWrap) $ run outiter1 QC.assert $ (map (L.fromChunks . (:[])) x1) == (replicate ntimes s') testBothChunkedBuffered2 :: Test testBothChunkedBuffered2 = testProperty "testBothChunkedBuffered2" $ monadicIO prop where prop = do sz <- QC.pick (choose (1000,4000)) s' <- QC.pick $ resize sz arbitrary ntimes <- QC.pick (choose (4,7)) let e = enumLBS s' buf <- QC.run mkIterateeBuffer enums <- QC.run $ replicateM ntimes (mkIterateeBuffer >>= return . flip writeChunkedTransferEncoding e) let mothra = foldl' (>.) (enumBS "") enums ---------------------------------------------------------------------- -- 2nd pass, cancellation let pcrlf = \s -> parserToIteratee $ string "\r\n" >> return s (inputIter2,esc) <- QC.run $ bufferIteratee stream2stream QC.run $ writeIORef esc True bs2 <- QC.run $ mothra inputIter2 >>= run >>= return . unWrap let e2 = enumBS bs2 iters' <- QC.run $ replicateM ntimes $ readChunkedTransferEncoding stream2stream let godzilla2 = sequence $ map (>>= pcrlf) iters' outiter2 <- QC.run $ e2 godzilla2 x2 <- QC.run $ liftM (map unWrap) $ run outiter2 QC.assert $ (map (L.fromChunks . (:[])) x2) == (replicate ntimes s') testBothChunkedPipelined :: Test testBothChunkedPipelined = testProperty "testBothChunkedPipelined" $ monadicIO prop where prop = do sz <- QC.pick (choose (1000,4000)) s' <- QC.pick $ resize sz arbitrary ntimes <- QC.pick (choose (4,7)) --let s' = L.take 2000 $ L.fromChunks $ repeat s let e = enumLBS s' buf <- QC.run mkIterateeBuffer enums <- QC.run $ replicateM ntimes (mkIterateeBuffer >>= return . flip writeChunkedTransferEncoding e) let mothra = foldl' (>.) (enumBS "") enums (bufi,_) <- QC.run $ bufferIteratee stream2stream bs <- QC.run $ mothra bufi >>= run >>= return . unWrap let e2 = enumBS bs let pcrlf = \s -> parserToIteratee $ string "\r\n" >> return s iters <- QC.run $ replicateM ntimes $ readChunkedTransferEncoding stream2stream let godzilla = sequence $ map (>>= pcrlf) iters iter <- QC.run $ e2 godzilla x <- QC.run $ liftM (map unWrap) $ run iter QC.assert $ (map (L.fromChunks . (:[])) x) == (replicate ntimes s') testBothChunkedEmpty :: Test testBothChunkedEmpty = testCase "testBothChunkedEmpty" prop where prop = do let s' = "" let e = enumLBS s' let ntimes = 5 buf <- mkIterateeBuffer enums <- replicateM ntimes (mkIterateeBuffer >>= return . flip writeChunkedTransferEncoding e) let mothra = foldl' (>.) (enumBS "") enums bs <- mothra stream2stream >>= run >>= return . unWrap let e2 = enumBS bs let pcrlf = \s -> parserToIteratee $ string "\r\n" >> return s iters <- replicateM ntimes $ readChunkedTransferEncoding stream2stream let godzilla = sequence $ map (>>= pcrlf) iters iter <- e2 godzilla x <- liftM (map unWrap) $ run iter assertBool "empty chunked transfer" $ (map (L.fromChunks . (:[])) x) == (replicate ntimes s') testCookie :: Test testCookie = testCase "parseCookie" $ do assertEqual "cookie parsing" (Just [cv]) cv2 where cv = Cookie nm v Nothing Nothing Nothing cv2 = parseCookie ct nm = "foo" v = "bar" ct = S.concat [ nm , "=" , v ] testFormEncoded :: Test testFormEncoded = testCase "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