{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE ScopedTypeVariables #-}
import Test.Framework
import Test.Framework.Providers.HUnit
import Test.Framework.Providers.QuickCheck2
import Test.HUnit
import Test.QuickCheck
import Web.Encodings
import Data.Convertible.Text (cs)
import qualified Data.ByteString.Char8 as BS
import qualified Data.ByteString.Lazy.Char8 as BL
import qualified Data.Text as TS
import qualified Data.Text.Lazy as TL
--import Debug.Trace
import qualified Web.Encodings.StringLike as SL
import Web.Encodings.StringLike (StringLike)
import Control.Arrow ((***))
import qualified Data.ByteString as B
import Network.Wai
main :: IO ()
main = defaultMain [tests]
allTests :: (Arbitrary a, StringLike a) => String -> a -> Test.Framework.Test
allTests n s = testGroup n
[ testProperty "encode/decode URL" $ qcEncodeDecodeUrl s
, testProperty "encode/decode HTML" $ qcEncodeDecodeHtml s
, testProperty "encode/decode JSON" $ qcEncodeDecodeJson s
, testProperty "encode/decode URL pairs" $ qcEncodeDecodeUrlPairs s
, testProperty "encode/decode URL pairs failure"
$ qcEncodeDecodeUrlPairsFailure s
, testCase "hunit query string" $ huQueryString s
, testCase "hunit encode json" $ huEncodeJson s
, testCase "decode URL pairs" $ caseDecodeUrlPairs s
, testCase "parse cookies" $ caseParseCookies s
, testCase "parse http accept" $ caseParseHttpAccept s
, testCase "hebrew query string encode" $ caseHebrewQueryStringEncode s
, testCase "hebrew query string decode" $ caseHebrewQueryStringDecode s
, testCase "bad query string decode" $ caseBadQueryStringDecode s
]
tests :: Test.Framework.Test
tests = testGroup "Web.Encodings"
[ allTests "String" (undefined :: String)
, allTests "Strict ByteString" (undefined :: BS.ByteString)
, allTests "Lazy ByteString" (undefined :: BL.ByteString)
, allTests "Strict Text" (undefined :: TS.Text)
, allTests "Lazy Text" (undefined :: TL.Text)
, testCase "parse post" huParsePost
, testCase "parse request body" huParseRequestBody
]
qcEncodeDecodeUrl :: StringLike a => a -> a -> Bool
qcEncodeDecodeUrl _ s = decodeUrl (encodeUrl s) == s
qcEncodeDecodeHtml :: StringLike a => a -> a -> Bool
qcEncodeDecodeHtml _ s = decodeHtml (encodeHtml s) == s
{-
qcEncodeDecodeHtml _ s =
let encoded = encodeHtml s
decoded = decodeHtml encoded
res = decoded == s
in trace ("en/de html: " ++ show (s, encoded, decoded)) res
-}
qcEncodeDecodeJson :: StringLike a => a -> a -> Bool
qcEncodeDecodeJson _ s = decodeJson (encodeJson s) == s
{-
qcEncodeDecodeJson _ s =
let encoded = encodeJson s
decoded = decodeJson encoded
res = decoded == s
in trace ("en/de json: " ++ show (s, encoded, decoded)) res
-}
qcEncodeDecodeUrlPairs :: StringLike a => a -> [(a, a)] -> Bool
qcEncodeDecodeUrlPairs _ s =
let --encoded :: String
encoded = encodeUrlPairs s
--decoded :: [(String, String)]
decoded = decodeUrlPairs encoded
--in trace ("url pairs: " ++ show (s, encoded, decoded)) $ s == decoded
in s == decoded
qcEncodeDecodeUrlPairsFailure :: StringLike a => a -> [(a, a)] -> Bool
qcEncodeDecodeUrlPairsFailure _ s =
decodeUrlPairsFailure (encodeUrlPairs s) == Just s
huQueryString :: StringLike a => a -> IO ()
huQueryString dummy = mapM_ t' [(k `asTypeOf` dummy, v)] where
--t' :: StringLike a => (a, [(a, a)]) -> IO ()
t' (s, p) = do
assertEqual (SL.unpack s) s $ encodeUrlPairs p
assertEqual (SL.unpack s) p $ decodeUrlPairs s
k = SL.pack "foo=bar&baz=bin"
v = map (SL.pack *** SL.pack) [("foo", "bar"), ("baz", "bin")]
huEncodeJson :: StringLike a => a -> IO ()
huEncodeJson dummy = do
let s = SL.pack "this is just a plain string" `asTypeOf` dummy
assertEqual "encodeJson on a plain string" s $ encodeJson s
instance Arbitrary BS.ByteString where
arbitrary = fmap SL.pack arbitrary
instance Arbitrary BL.ByteString where
arbitrary = fmap SL.pack arbitrary
instance Arbitrary TS.Text where
arbitrary = fmap SL.pack arbitrary
instance Arbitrary TL.Text where
arbitrary = fmap SL.pack arbitrary
huParsePost :: Assertion
huParsePost = t where
content2 = cs $
"--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--\n"
t = do
let content1 = cs "foo=bar&baz=bin"
let len1 = cs $ show $ BS.length content1
let ctype1 = cs "application/x-www-form-urlencoded"
let result1 = parsePost ctype1 len1 content1
assertEqual "parsing post x-www-form-urlencoded"
(map (cs *** cs) [("foo", "bar"), ("baz", "bin")], [])
result1
let ctype2 = cs "multipart/form-data; boundary=AaB03x"
let len2 = cs $ show $ BS.length content2
let result2 = parsePost ctype2 len2 content2
let expectedsmap2 =
[ ("title", "A File")
, ("summary", "This is my file\nfile test")
]
let expectedfile2 =
[(cs "document", FileInfo (cs "b.txt") (cs "text/plain") $ cs
"This is a file.\nIt has two lines.")]
let expected2 = (map (cs *** cs) expectedsmap2, expectedfile2)
assertEqual "parsing post multipart/form-data"
expected2
result2
caseDecodeUrlPairs :: StringLike a => a -> IO ()
caseDecodeUrlPairs dummy = do
let input = SL.pack "foo=bar+baz+bin&x=y" `asTypeOf` dummy
expected = [("foo", "bar baz bin"), ("x", "y")]
map (SL.pack *** SL.pack) expected @=? decodeUrlPairs input
caseParseCookies :: StringLike a => a -> IO ()
caseParseCookies dummy = do
let input = SL.pack "a=a1;b=b2; c=c3" `asTypeOf` dummy
expected = [("a", "a1"), ("b", "b2"), ("c", "c3")]
map (SL.pack *** SL.pack) expected @=? parseCookies input
caseParseHttpAccept :: StringLike a => a -> IO ()
caseParseHttpAccept dummy = do
let input =
SL.pack
"text/plain; q=0.5, text/html, text/x-dvi; q=0.8, text/x-c"
`asTypeOf` dummy
expected = ["text/html", "text/x-c", "text/x-dvi", "text/plain"]
map SL.pack expected @=? parseHttpAccept input
caseHebrewQueryStringEncode :: StringLike a => a -> IO ()
caseHebrewQueryStringEncode dummy = do
let encoded = SL.pack "%D7%A9%D7%9C%D7%95%D7%9D" `asTypeOf` dummy
decoded = SL.packUtf8 "שלום"
encoded @=? encodeUrl decoded
caseHebrewQueryStringDecode :: StringLike a => a -> IO ()
caseHebrewQueryStringDecode dummy = do
let encoded = SL.pack "%D7%A9%D7%9C%D7%95%D7%9D" `asTypeOf` dummy
decoded = SL.packUtf8 "שלום"
decoded @=? decodeUrl encoded
caseBadQueryStringDecode :: StringLike a => a -> IO ()
caseBadQueryStringDecode dummy = do
let raw = "%D7%D7%9C%D7%95%D7%9D"
bs = decodeUrl $ SL.pack raw
encoded = SL.pack raw `asTypeOf` dummy
expected = SL.unpackUtf8 bs
expected @=? decodeUrlFailure encoded
huParseRequestBody :: Assertion
huParseRequestBody = t where
content2 = cs $
"--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 = cs "------WebKitFormBoundaryB1pWXPZ6lNr8RiLh\r\nContent-Disposition: form-data; name=\"yaml\"; filename=\"README\"\r\nContent-Type: application/octet-stream\r\n\r\nPhoto blog using Hack.\n\r\n------WebKitFormBoundaryB1pWXPZ6lNr8RiLh--\r\n"
t = do
let content1 = cs "foo=bar&baz=bin"
let ctype1 = cs "application/x-www-form-urlencoded"
result1 <- parseRequestBody lbsSink $ toRequest ctype1 content1
assertEqual "parsing post x-www-form-urlencoded"
(map (cs *** cs) [("foo", "bar"), ("baz", "bin")], [])
result1
let ctype2 = cs "multipart/form-data; boundary=AaB03x"
result2 <- parseRequestBody lbsSink $ toRequest ctype2 content2
let expectedsmap2 =
[ ("title", "A File")
, ("summary", "This is my file\nfile test")
]
let expectedfile2 =
[(cs "document", FileInfo (cs "b.txt") (cs "text/plain") $ cs
"This is a file.\nIt has two lines.")]
let expected2 = (map (cs *** cs) expectedsmap2, expectedfile2)
assertEqual "parsing post multipart/form-data"
expected2
result2
let ctype3 = cs "multipart/form-data; boundary=----WebKitFormBoundaryB1pWXPZ6lNr8RiLh"
result3 <- parseRequestBody lbsSink $ toRequest ctype3 content3
let expectedsmap3 = []
let expectedfile3 = [(cs "yaml", FileInfo (cs "README") (cs "application/octet-stream") $
cs "Photo blog using Hack.\n")]
let expected3 = (expectedsmap3, expectedfile3)
assertEqual "parsing actual post multipart/form-data"
expected3
result3
result2' <- parseRequestBody lbsSink $ toRequest' ctype2 content2
assertEqual "parsing post multipart/form-data 2"
expected2
result2
putStrLn "\n\n\n\n\n"
result3' <- parseRequestBody lbsSink $ toRequest' ctype3 content3
assertEqual "parsing actual post multipart/form-data 2"
expected3
result3'
toRequest :: BS.ByteString -> BS.ByteString -> Request
toRequest ctype content = Request
{ requestHeaders = [(ReqContentType, ctype)]
, requestBody = toSource content
, requestMethod = undefined
, httpVersion = undefined
, pathInfo = undefined
, queryString = undefined
, serverName = undefined
, serverPort = undefined
, urlScheme = undefined
, errorHandler = undefined
, remoteHost = undefined
}
toRequest' :: BS.ByteString -> BS.ByteString -> Request
toRequest' ctype content = Request
{ requestHeaders = [(ReqContentType, ctype)]
, requestBody = toSource' content
, requestMethod = undefined
, httpVersion = undefined
, pathInfo = undefined
, queryString = undefined
, serverName = undefined
, serverPort = undefined
, urlScheme = undefined
, errorHandler = undefined
, remoteHost = undefined
}
toSource :: BS.ByteString -> Source
toSource bs = Source $
case B.uncons bs of
Nothing -> return Nothing
Just (x, xs) -> return $ Just (B.singleton x, toSource xs)
toSource' :: BS.ByteString -> Source
toSource' bs = Source $ return $ Just (bs, Source $ return Nothing)