web-encodings 0.2.2 → 0.2.3
raw patch · 4 files changed
+195/−40 lines, 4 files
Files
- Web/Encodings.hs +76/−29
- Web/Encodings/StringLike.hs +88/−1
- runtests.hs +30/−9
- web-encodings.cabal +1/−1
Web/Encodings.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE DeriveDataTypeable #-} --------------------------------------------------------- -- | -- Module : Web.Encodings@@ -18,6 +19,8 @@ -- ** URL (percentage encoding) encodeUrl , decodeUrl+ , decodeUrlFailure+ , DecodeUrlException (..) -- ** HTML (entity encoding) , encodeHtml , decodeHtml@@ -28,6 +31,7 @@ -- ** Query string- pairs of percentage encoding , encodeUrlPairs , decodeUrlPairs+ , decodeUrlPairsFailure -- ** Post parameters , FileInfo (..) , parseMultipart@@ -55,12 +59,15 @@ import Safe import Data.Char (ord, isControl) import Data.Function (on)+import Data.Typeable (Typeable)+import Control.Exception (Exception)+import qualified Data.ByteString as BS -- | Encode all but unreserved characters with percentage encoding. ----- Assumes use of UTF-8 character encoding.-encodeUrl :: StringLike s => s -> s-encodeUrl = SL.concatMap encodeUrlChar+-- This function implicitly converts the given value to a UTF-8 bytestream.+encodeUrl :: StringLike a => a -> a+encodeUrl = SL.concatMapUtf8 encodeUrlChar encodeUrlChar :: Char -> String encodeUrlChar c@@ -84,23 +91,58 @@ in ['%', showHex' b, showHex' c] -- | Decode percentage encoding. Assumes use of UTF-8 character encoding.+--+-- If there are any parse errors, this returns the original input. If you would+-- like to be alerted more directly of errors, use 'decodeUrlFailure'. decodeUrl :: StringLike s => s -> s-decodeUrl s = fromMaybe s $ do- (a, s') <- SL.uncons s- case a of- '%' -> do- (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'+decodeUrl s = fromMaybe s $ decodeUrlFailure s -getHex :: Char -> Char -> Char-getHex x y = toEnum $ (fromHex x) * 16 + fromHex y+data DecodeUrlException = InvalidPercentEncoding | InvalidUtf8Encoding+ deriving (Show, Typeable)+instance Exception DecodeUrlException -fromHex :: Char -> Int-fromHex = fromMaybe 0 . hexVal -- FIXME this fromMaybe is rather bad...+-- | Same as 'decodeUrl', but 'failure's on either invalid percent or UTF8+-- encoding.+decodeUrlFailure :: (MonadFailure DecodeUrlException m, StringLike s)+ => s -> m s+decodeUrlFailure s = do+ bs <- decodeUrlFailure' s+ case SL.unpackUtf8 bs of+ Nothing -> failure InvalidUtf8Encoding+ Just x -> return x +decodeUrlFailure' :: (MonadFailure DecodeUrlException m, StringLike s)+ => s -> m BS.ByteString+decodeUrlFailure' s = do+ case SL.uncons s of+ Nothing -> return SL.empty+ Just (a, s') ->+ case a of+ '%' -> do+ case SL.uncons s' of+ Nothing -> failure InvalidPercentEncoding+ Just (b, s'') ->+ case SL.uncons s'' of+ Nothing -> failure InvalidPercentEncoding+ Just (c, s''') ->+ case getHex b c of+ Nothing -> failure InvalidPercentEncoding+ Just h -> do+ s'''' <- decodeUrlFailure' s'''+ return $ h `SL.cons` s''''+ '+' -> do+ s'' <- decodeUrlFailure' s'+ return $ ' ' `SL.cons` s''+ _ -> do+ s'' <- decodeUrlFailure' s'+ return $ a `SL.cons` s''++getHex :: Char -> Char -> Maybe Char+getHex x y = do+ x' <- hexVal x+ y' <- hexVal y+ return $ toEnum $ x' * 16 + y'+ -- | Escape special HTML characters. encodeHtml :: StringLike s => s -> s encodeHtml = SL.concatMap encodeHtmlChar@@ -160,19 +202,24 @@ decodeUrlPairs = map decodeUrlPair . SL.split '&' . SL.dropWhile (== '?')-{--decodeUrlPairs s = unsafePerformIO $ do- putStrLn $ "Received: " ++ show s- let dropped = SL.dropWhile (== '?') s- putStrLn $ "Dropped: " ++ show dropped- let sp = SL.split '&' dropped- putStrLn $ "Split: " ++ show sp- let f = filter (not . SL.null) sp- putStrLn $ "Filtered: " ++ show f- let res = map decodeUrlPair f- putStrLn $ "Result: " ++ show res- return res--}++-- | Convert into key-value pairs. Strips the leading ? if necesary. 'failure's+-- as necesary for invalid encodings.+decodeUrlPairsFailure :: (StringLike s, MonadFailure DecodeUrlException m)+ => s+ -> m [(s, s)]+decodeUrlPairsFailure = mapM decodeUrlPairFailure+ . SL.split '&'+ . SL.dropWhile (== '?')++decodeUrlPairFailure :: (StringLike s, MonadFailure DecodeUrlException m)+ => s+ -> m (s, s)+decodeUrlPairFailure b = do+ let (x, y) = SL.breakChar '=' b+ x' <- decodeUrlFailure x+ y' <- decodeUrlFailure y+ return (x', y') decodeUrlPair :: StringLike s => s
Web/Encodings/StringLike.hs view
@@ -4,7 +4,8 @@ ) where import Prelude (Char, Bool (..), String, Int, Eq (..), Show, ($), (.),- (<=), (-), otherwise, Maybe (..), (&&), not, elem)+ (<=), (-), otherwise, Maybe (..), (&&), not, elem, (+),+ toEnum, fromEnum, map, (<), (||), (>=), fmap) import qualified Prelude as P import qualified Data.List as L import qualified Web.Encodings.ListHelper as LH@@ -14,6 +15,9 @@ import qualified Data.Text as TS import qualified Data.Text.Lazy as TL import Data.Maybe (fromMaybe)+import Data.Bits ((.|.),(.&.),shiftL,shiftR)+import Data.Word (Word8)+import qualified Data.ByteString class (Eq a, Show a) => StringLike a where span :: (Char -> Bool) -> a -> (a, a)@@ -36,6 +40,9 @@ pack :: String -> a unpack :: a -> String + packUtf8 :: String -> a+ unpackUtf8 :: BS.ByteString -> Maybe a+ dropPrefix :: a -> a -> Maybe a dropPrefix porig sorig = helper porig sorig where helper p s@@ -118,6 +125,10 @@ lengthGE :: Int -> a -> Bool lengthGE i = not . lengthLT i + -- | UTF8 encode each character before passing to concatMap, if+ -- appropriate.+ concatMapUtf8 :: (Char -> String) -> a -> a+ instance StringLike [Char] where intercalate = L.intercalate null = P.null@@ -136,8 +147,11 @@ empty = M.mempty pack = P.id unpack = P.id+ packUtf8 = pack+ unpackUtf8 = utf8Decode . Data.ByteString.unpack init = P.init last = P.last+ concatMapUtf8 f = concatMap (concatMap f . utf8EncodeChar) instance StringLike BS.ByteString where span = BS.span@@ -156,8 +170,11 @@ empty = BS.empty pack = BS.pack unpack = BS.unpack+ packUtf8 = pack . concatMap utf8EncodeChar+ unpackUtf8 = Just init = BS.init last = BS.last+ concatMapUtf8 = concatMap instance StringLike BL.ByteString where span = BL.span@@ -176,8 +193,11 @@ empty = BL.empty pack = BL.pack unpack = BL.unpack+ packUtf8 = pack . concatMap utf8EncodeChar+ unpackUtf8 bs = Just $ BL.fromChunks [bs] init = BL.init last = BL.last+ concatMapUtf8 = concatMap instance StringLike TS.Text where span = TS.spanBy@@ -196,8 +216,11 @@ empty = TS.empty pack = TS.pack unpack = TS.unpack+ packUtf8 = pack+ unpackUtf8 = fmap pack . unpackUtf8 init = TS.init last = TS.last+ concatMapUtf8 f = concatMap (concatMap f . utf8EncodeChar) instance StringLike TL.Text where span = TL.spanBy@@ -216,5 +239,69 @@ empty = TL.empty pack = TL.pack unpack = TL.unpack+ packUtf8 = pack+ unpackUtf8 = fmap pack . unpackUtf8 init = TL.init last = TL.last+ concatMapUtf8 f = concatMap (concatMap f . utf8EncodeChar)++-- | Code taken from Codec.Binary.UTF8.String.decode+utf8Decode :: [Word8] -> Maybe String+utf8Decode [] = Just ""+utf8Decode (c:cs)+ | c < 0x80 = do cs' <- utf8Decode cs+ Just $ toEnum (fromEnum c) : cs'+ | c < 0xc0 = Nothing+ | c < 0xe0 = multi1+ | c < 0xf0 = multi_byte 2 0xf 0x800+ | c < 0xf8 = multi_byte 3 0x7 0x10000+ | c < 0xfc = multi_byte 4 0x3 0x200000+ | c < 0xfe = multi_byte 5 0x1 0x4000000+ | otherwise = Nothing+ where+ multi1 = case cs of+ c1 : ds | c1 .&. 0xc0 == 0x80 ->+ let d = ((fromEnum c .&. 0x1f) `shiftL` 6) .|. fromEnum (c1 .&. 0x3f)+ in if d >= 0x000080 then (do ds' <- utf8Decode ds+ Just $ toEnum d : ds')+ else Nothing+ _ -> Nothing++ multi_byte :: Int -> Word8 -> Int -> Maybe [Char]+ multi_byte i mask overlong = aux i cs (fromEnum (c .&. mask))+ where+ aux 0 rs acc+ | overlong <= acc && acc <= 0x10ffff &&+ (acc < 0xd800 || 0xdfff < acc) &&+ (acc < 0xfffe || 0xffff < acc) = do+ rs' <- utf8Decode rs+ Just $ toEnum acc : rs'+ | otherwise = Nothing++ aux n (r:rs) acc+ | r .&. 0xc0 == 0x80 = aux (n-1) rs+ $ shiftL acc 6 .|. fromEnum (r .&. 0x3f)++ aux _ _rs _ = Nothing++utf8EncodeChar :: Char -> String+utf8EncodeChar = map toEnum . utf8EncodeInt . fromEnum++-- | Code taken from Codec.Binary.UTF8.String.encode+utf8EncodeInt :: Int -> [Int]+utf8EncodeInt c+ | c <= 0x7f = [c]++ | c <= 0x7ff = [ 0xc0 + (c `shiftR` 6)+ , 0x80 + c .&. 0x3f+ ]++ | c <= 0xffff = [ 0xe0 + (c `shiftR` 12)+ , 0x80 + ((c `shiftR` 6) .&. 0x3f)+ , 0x80 + c .&. 0x3f+ ]+ | otherwise = [ 0xf0 + (c `shiftR` 18)+ , 0x80 + ((c `shiftR` 12) .&. 0x3f)+ , 0x80 + ((c `shiftR` 6) .&. 0x3f)+ , 0x80 + c .&. 0x3f+ ]
runtests.hs view
@@ -2,7 +2,7 @@ {-# LANGUAGE ScopedTypeVariables #-} import Test.Framework import Test.Framework.Providers.HUnit-import Test.Framework.Providers.QuickCheck+import Test.Framework.Providers.QuickCheck2 import Test.HUnit import Test.QuickCheck@@ -29,12 +29,17 @@ , 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@@ -78,6 +83,10 @@ --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 ()@@ -92,25 +101,17 @@ 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@@ -175,3 +176,23 @@ `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
web-encodings.cabal view
@@ -1,5 +1,5 @@ name: web-encodings-version: 0.2.2+version: 0.2.3 license: BSD3 license-file: LICENSE author: Michael Snoyman <michael@snoyman.com>