diff --git a/Web/Encodings.hs b/Web/Encodings.hs --- a/Web/Encodings.hs +++ b/Web/Encodings.hs @@ -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 diff --git a/Web/Encodings/StringLike.hs b/Web/Encodings/StringLike.hs --- a/Web/Encodings/StringLike.hs +++ b/Web/Encodings/StringLike.hs @@ -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 + ] diff --git a/runtests.hs b/runtests.hs --- a/runtests.hs +++ b/runtests.hs @@ -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 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.2 +version: 0.2.3 license: BSD3 license-file: LICENSE author: Michael Snoyman