content: {-# 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)
  