diff --git a/Test.hs b/Test.hs deleted file mode 100644 --- a/Test.hs +++ /dev/null @@ -1,153 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} -{-# LANGUAGE ScopedTypeVariables #-} -import Test.Framework -import Test.Framework.Providers.HUnit -import Test.Framework.Providers.QuickCheck - -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 - , testCase "hunit query string" $ huQueryString s - , testCase "hunit encode json" $ huEncodeJson s - -- FIXME , testCase "parse post" huParsePost - ] - -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 - -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 Char where - arbitrary = choose (32,255) >>= \n -> return (chr n) - coarbitrary n = variant (ord n) - -instance Arbitrary BS.ByteString where - arbitrary = fmap SL.pack arbitrary - coarbitrary = undefined - -instance Arbitrary BL.ByteString where - arbitrary = fmap SL.pack arbitrary - coarbitrary = undefined - -instance Arbitrary TS.Text where - arbitrary = fmap SL.pack arbitrary - coarbitrary = undefined - -instance Arbitrary TL.Text where - arbitrary = fmap SL.pack arbitrary - coarbitrary = undefined - -{- 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 --} diff --git a/Web/Encodings.hs b/Web/Encodings.hs --- a/Web/Encodings.hs +++ b/Web/Encodings.hs @@ -70,6 +70,7 @@ encodeUrlChar c@'_' = [c] encodeUrlChar c@'.' = [c] encodeUrlChar c@'~' = [c] +encodeUrlChar ' ' = "+" encodeUrlChar y = let (a, c) = fromEnum y `divMod` 16 b = a `mod` 16 @@ -88,6 +89,7 @@ (b, s'') <- SL.uncons s' (c, s''') <- SL.uncons s'' return $ getHex b c `SL.cons` decodeUrl s''' + '+' -> return $ ' ' `SL.cons` decodeUrl s' _ -> return $ a `SL.cons` decodeUrl s' getHex :: Char -> Char -> Char diff --git a/runtests.hs b/runtests.hs new file mode 100644 --- /dev/null +++ b/runtests.hs @@ -0,0 +1,160 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE ScopedTypeVariables #-} +import Test.Framework +import Test.Framework.Providers.HUnit +import Test.Framework.Providers.QuickCheck + +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 + , testCase "hunit query string" $ huQueryString s + , testCase "hunit encode json" $ huEncodeJson s + , testCase "decode URL pairs" $ caseDecodeUrlPairs s + -- FIXME , testCase "parse post" huParsePost + ] + +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 + +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 Char where + arbitrary = choose (32,255) >>= \n -> return (chr n) + coarbitrary n = variant (ord n) + +instance Arbitrary BS.ByteString where + arbitrary = fmap SL.pack arbitrary + coarbitrary = undefined + +instance Arbitrary BL.ByteString where + arbitrary = fmap SL.pack arbitrary + coarbitrary = undefined + +instance Arbitrary TS.Text where + arbitrary = fmap SL.pack arbitrary + coarbitrary = undefined + +instance Arbitrary TL.Text where + arbitrary = fmap SL.pack arbitrary + coarbitrary = undefined + +{- 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 diff --git a/web-encodings.cabal b/web-encodings.cabal --- a/web-encodings.cabal +++ b/web-encodings.cabal @@ -1,5 +1,5 @@ name: web-encodings -version: 0.2.0 +version: 0.2.0.1 license: BSD3 license-file: LICENSE author: Michael Snoyman @@ -17,11 +17,7 @@ default: False library - if flag(buildtests) - Buildable: False - else - Buildable: True - build-depends: base >=4 && <5, + build-depends: base >= 4 && <5, time >= 1.1.2.4 && < 1.2, old-locale >= 1.0.0.1 && < 1.1, bytestring >= 0.9.1.4 && < 0.10, @@ -41,9 +37,8 @@ test-framework-quickcheck, test-framework-hunit, HUnit, - QuickCheck >= 1 && < 2, - convertible >= 1.2.0 && < 1.3 + QuickCheck >= 1 && < 2 else Buildable: False ghc-options: -Wall - main-is: Test.hs + main-is: runtests.hs