{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}

module Network.Wai.ParseSpec (main, spec) where

#if __GLASGOW_HASKELL__ < 804
import Data.Monoid
#endif
import Control.Monad.Trans.Resource (runResourceT, withInternalState)
import qualified Data.ByteString as S
import qualified Data.ByteString.Char8 as S8
import qualified Data.ByteString.Lazy as L
import qualified Data.IORef as I
import qualified Data.Text as TS
import qualified Data.Text.Encoding as TE
import Data.Word8 (_e)
import Network.Wai (
    Request (requestHeaders),
    defaultRequest,
    setRequestBodyChunks,
 )
import Network.Wai.Handler.Warp (InvalidRequest (..))
import System.IO (IOMode (ReadMode), withFile)
import Test.HUnit (Assertion, (@=?), (@?=))
import Test.Hspec

import Network.Wai.Parse
import Network.Wai.Test (SRequest (SRequest))
import WaiExtraSpec (toRequest)

main :: IO ()
main = hspec spec

spec :: Spec
spec = do
    describe "parseContentType" $ do
        let go (x, y, z) = it (TS.unpack $ TE.decodeUtf8 x) $ parseContentType x `shouldBe` (y, z)
        mapM_
            go
            [ ("text/plain", "text/plain", [])
            , ("text/plain; charset=UTF-8 ", "text/plain", [("charset", "UTF-8")])
            ,
                ( "text/plain; charset=UTF-8 ; boundary = foo"
                , "text/plain"
                , [("charset", "UTF-8"), ("boundary", "foo")]
                )
            ,
                ( "text/plain; charset=UTF-8 ; boundary = \"quoted\""
                , "text/plain"
                , [("charset", "UTF-8"), ("boundary", "quoted")]
                )
            ]
    it "parseHttpAccept" caseParseHttpAccept
    describe "parseRequestBody" $ do
        caseParseRequestBody
    it "multipart with plus" caseMultipartPlus
    it "multipart with multiple attributes" caseMultipartAttrs
    it "urlencoded with plus" caseUrlEncPlus
    describe "dalvik multipart" $ do
        it "non-chunked" $ dalvikHelper True
        it "chunked" $ dalvikHelper False

caseParseHttpAccept :: Assertion
caseParseHttpAccept = do
    let input =
            "text/plain; q=0.5, text/html;charset=utf-8, text/*;q=0.8;ext=blah, text/x-dvi; q=0.8, text/x-c"
        expected = ["text/html;charset=utf-8", "text/x-c", "text/x-dvi", "text/*", "text/plain"]
    expected @=? parseHttpAccept input

parseRequestBody'
    :: BackEnd file
    -> SRequest
    -> IO ([(S.ByteString, S.ByteString)], [(S.ByteString, FileInfo file)])
parseRequestBody' sink (SRequest req bod) =
    case getRequestBodyType req of
        Nothing -> return ([], [])
        Just rbt -> do
            ref <- I.newIORef $ L.toChunks bod
            let rb = I.atomicModifyIORef ref $ \chunks ->
                    case chunks of
                        [] -> ([], S.empty)
                        x : y -> (y, x)
            sinkRequestBody sink rbt rb

caseParseRequestBody :: Spec
caseParseRequestBody = do
    it "parsing post x-www-form-urlencoded" $ do
        let content1 = "foo=bar&baz=bin"
        let ctype1 = "application/x-www-form-urlencoded"
        result1 <- parseRequestBody' lbsBackEnd $ toRequest ctype1 content1
        result1 `shouldBe` ([("foo", "bar"), ("baz", "bin")], [])

    let ctype2 = "multipart/form-data; boundary=AaB03x"
    let expectedsmap2 =
            [ ("title", "A File")
            , ("summary", "This is my file\nfile test")
            ]
    let textPlain = "text/plain; charset=iso-8859-1"
    let expectedfile2 =
            [("document", FileInfo "b.txt" textPlain "This is a file.\nIt has two lines.")]
    let expected2 = (expectedsmap2, expectedfile2)

    it "parsing post multipart/form-data" $ do
        result2 <- parseRequestBody' lbsBackEnd $ toRequest ctype2 content2
        result2 `shouldBe` expected2

    it "parsing post multipart/form-data 2" $ do
        result2' <- parseRequestBody' lbsBackEnd $ toRequest' ctype2 content2
        result2' `shouldBe` expected2

    let ctype3 = "multipart/form-data; boundary=----WebKitFormBoundaryB1pWXPZ6lNr8RiLh"
    let expectedsmap3 = []
    let expectedfile3 =
            [
                ( "yaml"
                , FileInfo "README" "application/octet-stream" "Photo blog using Hack.\n"
                )
            ]
    let expected3 = (expectedsmap3, expectedfile3)

    let def = defaultParseRequestBodyOptions
    it "parsing actual post multipart/form-data" $ do
        result3 <- parseRequestBody' lbsBackEnd $ toRequest ctype3 content3
        result3 `shouldBe` expected3

    it "parsing actual post multipart/form-data 2" $ do
        result3' <- parseRequestBody' lbsBackEnd $ toRequest' ctype3 content3
        result3' `shouldBe` expected3

    it "parsing with memory limit" $ do
        SRequest req4 _bod4 <- toRequest'' ctype3 content3
        result4' <-
            parseRequestBodyEx
                (setMaxRequestNumFiles 1 $ setMaxRequestKeyLength 14 def)
                lbsBackEnd
                req4
        result4' `shouldBe` expected3

    it "exceeding number of files" $ do
        SRequest req4 _bod4 <- toRequest'' ctype3 content3
        (parseRequestBodyEx (setMaxRequestNumFiles 0 def) lbsBackEnd req4)
            `shouldThrow` anyException

    it "exceeding parameter length" $ do
        SRequest req4 _bod4 <- toRequest'' ctype3 content3
        (parseRequestBodyEx (setMaxRequestKeyLength 2 def) lbsBackEnd req4)
            `shouldThrow` anyException

    it "exceeding file size" $ do
        SRequest req4 _bod4 <- toRequest'' ctype3 content3
        (parseRequestBodyEx (setMaxRequestFileSize 2 def) lbsBackEnd req4)
            `shouldThrow` (== PayloadTooLarge)

    it "exceeding total file size" $ do
        SRequest req4 _bod4 <- toRequest'' ctype3 content3
        (parseRequestBodyEx (setMaxRequestFilesSize 20 def) lbsBackEnd req4)
            `shouldThrow` (== PayloadTooLarge)
        SRequest req5 _bod5 <- toRequest'' ctype3 content5
        (parseRequestBodyEx (setMaxRequestFilesSize 20 def) lbsBackEnd req5)
            `shouldThrow` (== PayloadTooLarge)

    it "exceeding max parm value size" $ do
        SRequest req4 _bod4 <- toRequest'' ctype2 content2
        (parseRequestBodyEx (setMaxRequestParmsSize 10 def) lbsBackEnd req4)
            `shouldThrow` (== PayloadTooLarge)

    it "exceeding max header lines" $ do
        SRequest req4 _bod4 <- toRequest'' ctype2 content2
        (parseRequestBodyEx (setMaxHeaderLines 1 def) lbsBackEnd req4)
            `shouldThrow` anyException

    it "exceeding header line size" $ do
        SRequest req4 _bod4 <- toRequest'' ctype3 content4
        (parseRequestBodyEx (setMaxHeaderLineLength 8190 def) lbsBackEnd req4)
            `shouldThrow` (== RequestHeaderFieldsTooLarge)

    it "Testing parseRequestBodyEx with application/x-www-form-urlencoded" $ do
        let content =
                "thisisalongparameterkey=andthisbeanevenlongerparametervaluehelloworldhowareyou"
        let ctype = "application/x-www-form-urlencoded"
        SRequest req _bod <- toRequest'' ctype content
        result <- parseRequestBodyEx def lbsBackEnd req
        result
            `shouldBe` (
                           [
                               ( "thisisalongparameterkey"
                               , "andthisbeanevenlongerparametervaluehelloworldhowareyou"
                               )
                           ]
                       , []
                       )

    it "exceeding max parm value size with x-www-form-urlencoded mimetype" $ do
        let content =
                "thisisalongparameterkey=andthisbeanevenlongerparametervaluehelloworldhowareyou"
        let ctype = "application/x-www-form-urlencoded"
        SRequest req _bod <- toRequest'' ctype content
        (parseRequestBodyEx (setMaxRequestParmsSize 10 def) lbsBackEnd req)
            `shouldThrow` anyException
  where
    content2 =
        "--AaB03x\n"
            <> "Content-Disposition: form-data; name=\"document\"; filename=\"b.txt\"\n"
            <> "Content-Type: text/plain; charset=iso-8859-1\n\n"
            <> "This is a file.\n"
            <> "It has two lines.\n"
            <> "--AaB03x\n"
            <> "Content-Disposition: form-data; name=\"title\"\n"
            <> "Content-Type: text/plain; charset=iso-8859-1\n\n"
            <> "A File\n"
            <> "--AaB03x\n"
            <> "Content-Disposition: form-data; name=\"summary\"\n"
            <> "Content-Type: text/plain; charset=iso-8859-1\n\n"
            <> "This is my file\n"
            <> "file test\n"
            <> "--AaB03x--"
    content3 =
        "------WebKitFormBoundaryB1pWXPZ6lNr8RiLh\r\n"
            <> "Content-Disposition: form-data; name=\"yaml\"; filename=\"README\"\r\n"
            <> "Content-Type: application/octet-stream\r\n\r\n"
            <> "Photo blog using Hack.\n\r\n"
            <> "------WebKitFormBoundaryB1pWXPZ6lNr8RiLh--\r\n"
    content4 =
        "------WebKitFormBoundaryB1pWXPZ6lNr8RiLh\r\n"
            <> "Content-Disposition: form-data; name=\"alb\"; filename=\"README\"\r\n"
            <> "Content-Type: application/octet-stream\r\n\r\n"
            <> "Photo blog using Hack.\r\n\r\n"
            <> "------WebKitFormBoundaryB1pWXPZ6lNr8RiLh\r\n"
            <> "Content-Disposition: form-data; name=\"bla\"; filename=\"riedmi"
            <> S.replicate 8190 _e
            <> "\"\r\n"
            <> "Content-Type: application/octet-stream\r\n\r\n"
            <> "Photo blog using Hack.\r\n\r\n"
            <> "------WebKitFormBoundaryB1pWXPZ6lNr8RiLh--\r\n"
    content5 =
        "------WebKitFormBoundaryB1pWXPZ6lNr8RiLh\r\n"
            <> "Content-Disposition: form-data; name=\"yaml\"; filename=\"README\"\r\n"
            <> "Content-Type: application/octet-stream\r\n\r\n"
            <> "Photo blog using Hack.\n\r\n"
            <> "------WebKitFormBoundaryB1pWXPZ6lNr8RiLh\r\n"
            <> "Content-Disposition: form-data; name=\"yaml2\"; filename=\"MEADRE\"\r\n"
            <> "Content-Type: application/octet-stream\r\n\r\n"
            <> "Photo blog using Hack.\n\r\n"
            <> "------WebKitFormBoundaryB1pWXPZ6lNr8RiLh--\r\n"

caseMultipartPlus :: Assertion
caseMultipartPlus = do
    result <- parseRequestBody' lbsBackEnd $ toRequest ctype content
    result @?= ([("email", "has+plus")], [])
  where
    content =
        "--AaB03x\n"
            <> "Content-Disposition: form-data; name=\"email\"\n"
            <> "Content-Type: text/plain; charset=iso-8859-1\n\n"
            <> "has+plus\n"
            <> "--AaB03x--"
    ctype = "multipart/form-data; boundary=AaB03x"

caseMultipartAttrs :: Assertion
caseMultipartAttrs = do
    result <- parseRequestBody' lbsBackEnd $ toRequest ctype content
    result @?= ([("email", "has+plus")], [])
  where
    content =
        "--AaB03x\n"
            <> "Content-Disposition: form-data; name=\"email\"\n"
            <> "Content-Type: text/plain; charset=iso-8859-1\n\n"
            <> "has+plus\n"
            <> "--AaB03x--"
    ctype = "multipart/form-data; charset=UTF-8; boundary=AaB03x"

caseUrlEncPlus :: Assertion
caseUrlEncPlus = do
    result <- runResourceT $ withInternalState $ \state ->
        parseRequestBody' (tempFileBackEnd state) $ toRequest ctype content
    result @?= ([("email", "has+plus")], [])
  where
    content = "email=has%2Bplus"
    ctype = "application/x-www-form-urlencoded"

dalvikHelper :: Bool -> Assertion
dalvikHelper includeLength = do
    let headers' =
            [ ("content-type", "multipart/form-data;boundary=*****")
            , ("GATEWAY_INTERFACE", "CGI/1.1")
            , ("PATH_INFO", "/")
            , ("QUERY_STRING", "")
            , ("REMOTE_ADDR", "192.168.1.115")
            , ("REMOTE_HOST", "ganjizza")
            , ("REQUEST_URI", "http://192.168.1.115:3000/")
            , ("REQUEST_METHOD", "POST")
            , ("HTTP_CONNECTION", "Keep-Alive")
            ,
                ( "HTTP_COOKIE"
                , "_SESSION=fgUGM5J/k6mGAAW+MMXIJZCJHobw/oEbb6T17KQN0p9yNqiXn/m/ACrsnRjiCEgqtG4fogMUDI+jikoFGcwmPjvuD5d+MDz32iXvDdDJsFdsFMfivuey2H+n6IF6yFGD"
                )
            ,
                ( "HTTP_USER_AGENT"
                , "Dalvik/1.1.0 (Linux; U; Android 2.1-update1; sdk Build/ECLAIR)"
                )
            , ("HTTP_HOST", "192.168.1.115:3000")
            , ("HTTP_ACCEPT", "*, */*")
            , ("HTTP_VERSION", "HTTP/1.1")
            , ("REQUEST_PATH", "/")
            ]
        headers
            | includeLength = ("content-length", "12098") : headers'
            | otherwise = headers'
    let request' =
            defaultRequest
                { requestHeaders = headers
                }
    (params, files) <-
        case getRequestBodyType request' of
            Nothing -> return ([], [])
            Just rbt -> withFile "test/requests/dalvik-request" ReadMode $ \h ->
                sinkRequestBody lbsBackEnd rbt $ S.hGetSome h 2048
    lookup "scannedTime" params @?= Just "1.298590056748E9"
    lookup "geoLong" params @?= Just "0"
    lookup "geoLat" params @?= Just "0"
    length files @?= 1

toRequest' :: S8.ByteString -> S8.ByteString -> SRequest
toRequest' ctype content =
    SRequest
        defaultRequest
            { requestHeaders = [("Content-Type", ctype)]
            }
        (L.fromChunks $ map S.singleton $ S.unpack content)

toRequest'' :: S8.ByteString -> S8.ByteString -> IO SRequest
toRequest'' ctype content =
    mkRB content >>= \b -> do
        let req =
                setRequestBodyChunks
                    b
                    defaultRequest{requestHeaders = [("Content-Type", ctype)]}
        return $ SRequest req (L.fromChunks $ map S.singleton $ S.unpack content)

mkRB :: S8.ByteString -> IO (IO S8.ByteString)
mkRB content = do
    r <- I.newIORef content
    return $
        I.atomicModifyIORef r $
            \a -> (S8.empty, a)
