{-# 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.Char (chr, ord)
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 ((***))
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
-- FIXME , testCase "parse post" huParsePost
, 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)
]
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
{- FIXME
huParsePost = t where
content2 = BSLU.fromString $
"--AaB03x\n" ++
"Content-Disposition: form-data; name=\"document\"; filename=\"b.txt\"\n" ++
"Content-Type: text/plain; charset=iso-8859-1\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" ++
"A File\n" ++
"--AaB03x\n" ++
"Content-Disposition: form-data; name=\"summary\"\n" ++
"Content-Type: text/plain; charset=iso-8859-1\n" ++
"This is my file\n" ++
"file test\n" ++
"--AaB03x--\n"
t = do
let content1 = BSLU.fromString "foo=bar&baz=bin"
let len1 = BSLU.fromString $ show $ BS.length content1
let ctype1 = BSLU.fromString "application/x-www-form-urlencoded"
let result1 = parsePost ctype1 len1 content1
assertEqual "parsing post x-www-form-urlencoded"
([("foo", "bar"), ("baz", "bin")], [])
result1
let ctype2 = BSLU.fromString "multipart/form-data; boundary=AaB03x"
let len2 = BSLU.fromString $ show $ BS.length content2
let result2 = parsePost ctype2 len2 content2
let expectedsmap2 =
[ ("title", "A File")
, ("summary", "This is my file\nfile test")
]
let expectedfile2 =
[ ("document", "b.txt", "text/plain", BSLU.fromString $
"This is a file.\nIt has two lines.\n") ]
let expected2 = (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