web-encodings 0.0.1 → 0.2.0

raw patch · 9 files changed

+686/−359 lines, 9 filesdep +HUnitdep +QuickCheckdep +convertibledep −bytestring-classdep ~bytestringdep ~old-localedep ~timenew-component:exe:runtestsPVP ok

version bump matches the API change (PVP)

Dependencies added: HUnit, QuickCheck, convertible, failure, safe, test-framework, test-framework-hunit, test-framework-quickcheck, text

Dependencies removed: bytestring-class

Dependency ranges changed: bytestring, old-locale, time

API changes (from Hackage documentation)

Files

• Data/ByteString/Lazy/Util.hs +0/−89
• Data/Mime/Header.hs +0/−69
• Data/String/Util.hs +0/−55
• Test.hs +153/−0
• Web/Encodings.hs +210/−138
• Web/Encodings/ListHelper.hs +4/−0
• Web/Encodings/MimeHeader.hs +82/−0
• Web/Encodings/StringLike.hs +205/−0
• web-encodings.cabal +32/−8

@@ -1,89 +0,0 @@------------------------------------------------------------- |--- Module        : Data.ByteString.Lazy.Util--- Copyright     : Michael Snoyman--- License       : BSD3------ Maintainer    : Michael Snoyman <michael@snoyman.com>--- Stability     : Unstable--- Portability   : portable------ Various utilities to assist in dealing with lazy bytestrings.---------------------------------------------------------------module Data.ByteString.Lazy.Util-    ( ord-    , stripPrefix-    , breakAt-    , breakAtString-    , takeLine-    , chompBS-    , takeUntilBlank-    ) where--import qualified Data.ByteString.Lazy as BS-import qualified Data.Char as C-import Data.Word (Word8)---- | Get the ASCII value of character. Differers from regular ord in that--- it returns an Integral, so it is automatically cast to eg a Word8.-ord :: Integral a => Char -> a-ord = fromInteger . toInteger . C.ord---- | Strip a prefix from a bytestring if it's there.-stripPrefix :: Word8 -> BS.ByteString -> BS.ByteString-stripPrefix p bs-    | BS.null bs = bs-    | BS.head bs == p = BS.tail bs-    | otherwise = bs---- | Break a bytestring into two at the first occurence of the given 'Word8'.--- That 'Word8' should not appear in either piece.-breakAt :: Word8 -> BS.ByteString -> (BS.ByteString, BS.ByteString)-breakAt p bs =-    let (x, y) = BS.span (/= p) bs-        y' = stripPrefix p y-     in (x, y')---- | Same as 'breakAt', but use a bytestring instead of a 'Word8'.-breakAtString :: BS.ByteString-              -> BS.ByteString-              -> (BS.ByteString, BS.ByteString)-breakAtString p c-    | BS.null c = (BS.empty, BS.empty)-    | p `BS.isPrefixOf` c = (BS.empty, BS.drop (BS.length p) c)-    | otherwise =-        let x = BS.head c-            xs = BS.tail c-            (next, rest) = breakAtString p xs-        in (BS.cons' x next, rest)---- | Take a single line from a bytestring.-takeLine :: BS.ByteString -> (BS.ByteString, BS.ByteString)-takeLine bs =-    let (x, y) = BS.span (/= ord '\n') bs-        x' = if not (BS.null x) && BS.last x == ord '\r' then BS.init x else x-        y' = if not (BS.null y) && BS.head y == ord '\n' then BS.tail y else y-     in (x', y')---- | Removes newline characters from the end of a string.-chompBS :: BS.ByteString -> BS.ByteString-chompBS s-    | BS.null s = s-    | BS.last s == ord '\n' =-        if BS.length s == 1 || BS.last (BS.init s) /= ord '\r'-            then BS.init s-            else BS.init (BS.init s)-    | BS.last s == ord '\r' = BS.init s-    | otherwise = s---- | Take each line until the first blank line and return as first.--- The rest of the content is returned as second.-takeUntilBlank :: BS.ByteString -> ([BS.ByteString], BS.ByteString)-takeUntilBlank bs =-    let (next, rest) = takeLine bs-     in if BS.null next-            then ([], rest)-            else let (nexts, rest') = takeUntilBlank rest-                  in (next : nexts, rest')

@@ -1,69 +0,0 @@------------------------------------------------------------- |--- Module        : Data.Mime.Header--- Copyright     : Michael Snoyman--- License       : BSD3------ Maintainer    : Michael Snoyman <michael@snoyman.com>--- Stability     : Unstable--- Portability   : portable------ Functions for parsing MIME headers (Key: value; k1=v1; k2=v2)---------------------------------------------------------------module Data.Mime.Header-    ( Header-    , parseHeader-    , lookupHeader-    , lookupHeaderAttr-    ) where--import Data.String.Util-import Data.ByteString.Class-import qualified Data.ByteString.Lazy as BS--type SMap = [(String, String)]---- | A single MIME header.-type Header = (String, String, SMap)---- | Parse a header line in the format--- Name: value; attkey=attval; attkey2=attval2.-parseHeader :: BS.ByteString -> Header-parseHeader bs =-    let s = fromLazyByteString bs-        (k, rest) = span (/= ':') s-        (v, attrs) = parseRest rest-     in (k, v, attrs) where-    parseRest :: String -> (String, SMap)-    parseRest s =-        let (v, rest) = span (/= ';') s-            attrs = parseAttrs rest-         in (dropPrefix ": " v, attrs)-    parseAttrs :: String -> SMap-    parseAttrs [] = []-    parseAttrs s =-        let s' = dropPrefix "; " s-            (next, rest) = span (/= ';') s'-            (k, v) = span (/= '=') next-            v' = dropPrefix "=" v-            v'' = dropQuotes v'-         in (k, v'') : parseAttrs rest--lookupHeaderAttr :: Monad m => String -> String -> [Header] -> m String-lookupHeaderAttr k1 k2 [] =-    fail $ "Could not find header when looking for attr: " ++ -           k1 ++ ":" ++ k2-lookupHeaderAttr k1 k2 ((key, _, vals):rest)-    | k1 == key = case lookup k2 vals of-                    Nothing -> fail $ "Could not find header attr "-                                      ++ k1 ++ ":" ++ k2-                    Just v -> return v-    | otherwise = lookupHeaderAttr k1 k2 rest--lookupHeader :: Monad m => String -> [Header] -> m String-lookupHeader k [] = fail $ "Header " ++ k ++ " not found"-lookupHeader k ((key, val, _):rest)-    | k == key = return val-    | otherwise = lookupHeader k rest

@@ -1,55 +0,0 @@------------------------------------------------------------- |--- Module        : Data.String.Util--- Copyright     : Michael Snoyman--- License       : BSD3------ Maintainer    : Michael Snoyman <michael@snoyman.com>--- Stability     : Unstable--- Portability   : portable------ Various utilities to assist in dealing with Strings.---------------------------------------------------------------module Data.String.Util-    ( chomp-    , dropPrefix-    , dropQuotes-    , splitList-    ) where--import Data.List (isPrefixOf)---- | Removes newline characters from the end of a string.-chomp :: String -> String-chomp s-    | null s = s-    | last s == '\n' =-        if length s == 1 || last (init s) /= '\r'-            then init s-            else init (init s)-    | last s == '\r' = init s-    | otherwise = s---- | Drop a string from the beginning of another, if present.-dropPrefix :: Eq a => [a] -> [a] -> [a]-dropPrefix x y-    | x `isPrefixOf` y = drop (length x) y-    | otherwise = y---- | Drop surrounding quotes, if present.-dropQuotes :: String -> String-dropQuotes s-    | length s > 2 && head s == '"' && last s == '"' = tail $ init s-    | otherwise = s---- | Split up a list into sublists at every occurence of the split--- element. That element is thrown away.-splitList :: Eq a => a -> [a] -> [[a]]-splitList c s = helper s [[]] where-    helper [] res = filter (not . null) $ reverse $ map reverse res-    helper (x:xs) (y:ys)-        | x == c = helper xs ([]:y:ys)-        | otherwise = helper xs ((x:y):ys)-    helper _ [] = error "This case should never be"

@@ -0,0 +1,153 @@+{-# 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+-}

@@ -1,4 +1,4 @@-{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FlexibleContexts #-} --------------------------------------------------------- -- | -- Module        : Web.Encodings@@ -6,7 +6,7 @@ -- License       : BSD3 -- -- Maintainer    : Michael Snoyman <michael@snoyman.com>--- Stability     : Unstable+-- Stability     : Stable -- Portability   : portable -- -- Various web encodings.@@ -20,9 +20,10 @@     , decodeUrl       -- ** HTML (entity encoding)     , encodeHtml--- FIXME    , decodeHtml+    , decodeHtml       -- ** JSON     , encodeJson+    , decodeJson       -- * HTTP level encoding.       -- ** Query string- pairs of percentage encoding     , encodeUrlPairs@@ -37,67 +38,67 @@     , formatW3     ) where -import Data.ByteString.Class-import qualified Data.ByteString.Lazy as BS-import Text.Printf (printf)-import Data.Word (Word8) import Numeric (showHex) import Data.List (isPrefixOf)-import Data.ByteString.Lazy.Util hiding (ord)-import Data.Mime.Header+import Web.Encodings.MimeHeader import Data.Maybe (fromMaybe)  import Data.Time.Clock import System.Locale import Data.Time.Format +import Web.Encodings.StringLike (StringLike)+import qualified Web.Encodings.StringLike as SL+import Control.Failure+import Safe+import Data.Char (ord, isControl)+ -- | Encode all but unreserved characters with percentage encoding. -- -- Assumes use of UTF-8 character encoding.-encodeUrl :: (LazyByteString x, LazyByteString y) => x -> y-encodeUrl = fromLazyByteString-          . BS.concatMap encodeUrlByte-          . toLazyByteString--ord :: Integral i => Char -> i-ord = fromIntegral . fromEnum+encodeUrl :: StringLike s => s -> s+encodeUrl = SL.concatMap encodeUrlChar -encodeUrlByte :: Word8 -> BS.ByteString-encodeUrlByte w+encodeUrlChar :: Char -> String+encodeUrlChar c     -- List of unreserved characters per RFC 3986     -- Gleaned from http://en.wikipedia.org/wiki/Percent-encoding-    | ord 'A' <= w && w <= ord 'Z' = BS.singleton w-    | ord 'a' <= w && w <= ord 'z' = BS.singleton w-    | ord '0' <= w && w <= ord '9' = BS.singleton w-    | ord '-' == w = BS.singleton w-    | ord '_' == w = BS.singleton w-    | ord '.' == w = BS.singleton w-    | ord '~' == w = BS.singleton w-    | otherwise = toLazyByteString $ (printf "%%%02x" w :: String)+    | 'A' <= c && c <= 'Z' = [c]+    | 'a' <= c && c <= 'z' = [c]+    | '0' <= c && c <= '9' = [c]+encodeUrlChar c@'-' = [c]+encodeUrlChar c@'_' = [c]+encodeUrlChar c@'.' = [c]+encodeUrlChar c@'~' = [c]+encodeUrlChar y =+    let (a, c) = fromEnum y `divMod` 16+        b = a `mod` 16+        showHex' x -- FIXME just use Numeric version?+            | x < 10 = toEnum $ x + (fromEnum '0')+            | x < 16 = toEnum $ x - 10 + (fromEnum 'A')+            | otherwise = error $ "Invalid argument to showHex: " ++ show x+     in ['%', showHex' b, showHex' c]  -- | Decode percentage encoding. Assumes use of UTF-8 character encoding.-decodeUrl :: (LazyByteString x, LazyByteString y) => x -> y-decodeUrl = fromLazyByteString . BS.pack . decodeUrlList . BS.unpack . toLazyByteString+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 $ a `SL.cons` decodeUrl s' -decodeUrlList :: [Word8] -> [Word8]--- note: percent sign is 37-decodeUrlList (37:x:y:rest) = (fromHex x) * 16 + (fromHex y)-                            : decodeUrlList rest-decodeUrlList (x:rest)-    | x == 43 = 32 : decodeUrlList rest -- convert plus to space-    | otherwise = x : decodeUrlList rest-decodeUrlList [] = []+getHex :: Char -> Char -> Char+getHex x y = toEnum $ (fromHex x) * 16 + fromHex y -fromHex :: Word8 -> Word8-fromHex x-    | 48 <= x && x <= 57 = x - 48 -- 0 - 9-    | 65 <= x && x <= 70 = x - 65 + 10 -- A - F-    | 97 <= x && x <= 102 = x - 97 + 10 -- a - f-    | otherwise = 0 -- FIXME+fromHex :: Char -> Int+fromHex = fromMaybe 0 . hexVal -- FIXME this fromMaybe is rather bad...  -- | Escape special HTML characters.-encodeHtml :: String -> String-encodeHtml = concatMap encodeHtmlChar+encodeHtml :: StringLike s => s -> s+encodeHtml = SL.concatMap encodeHtmlChar  encodeHtmlChar :: Char -> String encodeHtmlChar '<' = "&lt;"@@ -107,87 +108,152 @@ encodeHtmlChar '\'' = "&#39;" encodeHtmlChar c = [c] +-- | Decode HTML-encoded content into plain content.+--+-- Note: this does not support all HTML entities available. It also swallows+-- all failures.+decodeHtml :: StringLike s => s -> s+decodeHtml s = case SL.uncons s of+    Nothing -> SL.empty+    Just ('&', xs) -> fromMaybe ('&' `SL.cons` decodeHtml xs) $ do+        (before, after) <- SL.breakCharMaybe ';' xs+        c <- case SL.unpack before of -- this are small enough that unpack is ok+            "lt" -> return '<'+            "gt" -> return '>'+            "amp" -> return '&'+            "quot" -> return '"'+            '#' : 'x' : hex -> readHexChar hex+            '#' : 'X' : hex -> readHexChar hex+            '#' : dec -> readDecChar dec+            _ -> Nothing -- just to shut up a warning+        return $ c `SL.cons` decodeHtml after+    Just (x, xs) -> x `SL.cons` decodeHtml xs++readHexChar :: String -> Maybe Char+readHexChar s = helper 0 s where+    helper i "" = return $ toEnum i+    helper i (c:cs) = do+        c' <- hexVal c+        helper (i * 16 + c') cs++hexVal :: Char -> Maybe Int+hexVal c+    | '0' <= c && c <= '9' = Just $ ord c - ord '0'+    | 'A' <= c && c <= 'F' = Just $ ord c - ord 'A' + 10+    | 'a' <= c && c <= 'f' = Just $ ord c - ord 'a' + 10+    | otherwise = Nothing++readDecChar :: String -> Maybe Char+readDecChar s = do+    i <- readMay s :: Maybe Int+    return $ toEnum i+ -- | Convert into key-value pairs. Strips the leading ? if necesary.-decodeUrlPairs :: (LazyByteString x, LazyByteString y, LazyByteString z)-               => x-               -> [(y, z)]+decodeUrlPairs :: StringLike s+               => s+               -> [(s, s)] decodeUrlPairs = map decodeUrlPair-               . BS.split (ord '&')-               . BS.dropWhile (== ord '?')-               . toLazyByteString+               . 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+-} -decodeUrlPair :: (LazyByteString a, LazyByteString b)-              => BS.ByteString-              -> (a, b)+decodeUrlPair :: StringLike s+              => s+              -> (s, s) decodeUrlPair b =-    let (x, y) = BS.break (== ord '=') b-        y' = BS.dropWhile (== ord '=') y-     in (decodeUrl x, decodeUrl y')+    let (x, y) = SL.breakChar '=' b+     in (decodeUrl x, decodeUrl y)  -- | Convert a list of key-values pairs into a query string. -- Does not include the question mark at the beginning.-encodeUrlPairs :: (LazyByteString x, LazyByteString y, LazyByteString z)-               => [(x, y)]-               -> z-encodeUrlPairs = fromLazyByteString-               . BS.intercalate (BS.singleton $ ord '&')+encodeUrlPairs :: StringLike s+               => [(s, s)]+               -> s+encodeUrlPairs = SL.intercalate (SL.pack "&")                . map encodeUrlPair -encodeUrlPair :: (LazyByteString x, LazyByteString y)-               => (x, y)-               -> BS.ByteString-encodeUrlPair (x, y) = BS.concat-                     [ encodeUrl x-                     , BS.singleton $ ord '='-                     , encodeUrl y-                     ]+encodeUrlPair :: StringLike s+               => (s, s)+               -> s+encodeUrlPair (x, y) = encodeUrl x `SL.append` ('=' `SL.cons` encodeUrl y)  -- | Perform JSON-encoding on a string. Does not wrap in quotation marks.-encodeJson :: LazyByteString x => String -> x-encodeJson = fromLazyByteString . toLazyByteString . encJSString+-- Taken from json package by Sigbjorn Finne.+encodeJson :: StringLike s => s -> s+encodeJson = SL.concatMap encodeJsonChar --- | Taken from json package by Sigbjorn Finne.-encJSString :: String -> String-encJSString jss = go jss-  where-  go s1 =-    case s1 of-      (x   :xs) | x < '\x20' -> '\\' : encControl x (go xs)-      ('"' :xs)              -> '\\' : '"'  : go xs-      ('\\':xs)              -> '\\' : '\\' : go xs-      (x   :xs)              -> x    : go xs-      ""                     -> ""+encodeJsonChar :: Char -> String+encodeJsonChar '\b' = "\\b"+encodeJsonChar '\f' = "\\f"+encodeJsonChar '\n' = "\\n"+encodeJsonChar '\r' = "\\r"+encodeJsonChar '\t' = "\\t"+encodeJsonChar '"' = "\\\""+encodeJsonChar '\\' = "\\\\"+encodeJsonChar c+    | not $ isControl c = [c]+    | c < '\x10'   = '\\' : 'u' : '0' : '0' : '0' : hexxs+    | c < '\x100'  = '\\' : 'u' : '0' : '0' : hexxs+    | c < '\x1000' = '\\' : 'u' : '0' : hexxs+    where hexxs = showHex (fromEnum c) "" -- FIXME+encodeJsonChar c = [c] -  encControl x xs = case x of-    '\b' -> 'b' : xs-    '\f' -> 'f' : xs-    '\n' -> 'n' : xs-    '\r' -> 'r' : xs-    '\t' -> 't' : xs-    _ | x < '\x10'   -> 'u' : '0' : '0' : '0' : hexxs-      | x < '\x100'  -> 'u' : '0' : '0' : hexxs-      | x < '\x1000' -> 'u' : '0' : hexxs-      | otherwise    -> 'u' : hexxs-      where hexxs = showHex (fromEnum x) xs+decodeJson :: StringLike s => s -> s+decodeJson s = case SL.uncons s of+    Nothing -> SL.empty+    Just ('\\', xs) -> fromMaybe ('\\' `SL.cons` decodeJson xs) $ do+        (x, xs') <- SL.uncons xs+        if x == 'u'+            then do+                (a, e) <- SL.uncons xs'+                (b, f) <- SL.uncons e+                (c, g) <- SL.uncons f+                (d, h) <- SL.uncons g+                res <- readHexChar [a, b, c, d]+                return $ res `SL.cons` decodeJson h+            else do+                c <- case x of+                        'b' -> return '\b'+                        'f' -> return '\f'+                        'n' -> return '\n'+                        'r' -> return '\r'+                        't' -> return '\t'+                        '"' -> return '"'+                        '\'' -> return '\''+                        '\\' -> return '\\'+                        _ -> Nothing+                return $ c `SL.cons` decodeJson xs'+    Just (x, xs) -> x `SL.cons` decodeJson xs  -- | Information on an uploaded file.-data FileInfo = FileInfo-    { fileName :: String-    , fileContentType :: String-    , fileContent :: BS.ByteString+data FileInfo s c = FileInfo+    { fileName :: s+    , fileContentType :: s+    , fileContent :: c     }-instance Show FileInfo where-    show (FileInfo fn ct _) = "FileInfo: " ++ fn ++ " (" ++ ct ++ ")"+instance Show s => Show (FileInfo s a) where+    show (FileInfo fn ct _) =+        "FileInfo: " ++ show fn ++ " (" ++ show ct ++ ")"  -- | Parse a multipart form into parameters and files.-parseMultipart :: LazyByteString lbs-               => lbs -- ^ boundary-               -> BS.ByteString -- ^ content-               -> ([(String, String)], [(String, FileInfo)])-parseMultipart boundary' content =-    let boundary :: String-        boundary = fromLazyByteString $ toLazyByteString boundary'-        pieces = getPieces boundary content+parseMultipart :: StringLike s+               => String -- ^ boundary+               -> s -- ^ content+               -> ([(s, s)], [(s, FileInfo s s)])+parseMultipart boundary content =+    let pieces = getPieces boundary content         getJusts [] = []         getJusts (Nothing:rest) = getJusts rest         getJusts ((Just x):rest) = x : getJusts rest@@ -201,24 +267,30 @@      in (getLefts pieces', getRights pieces')  -- | Parse a single segment of a multipart/form-data POST.-parsePiece :: Monad m-           => BS.ByteString-           -> m (Either (String, String) (String, FileInfo))+parsePiece :: (StringLike s, MonadFailure (AttributeNotFound s) m)+           => s+           -> m (Either (s, s) (s, FileInfo s s)) parsePiece b = do-    let (headers', content) = takeUntilBlank b+    let (headers', content) = SL.takeUntilBlank b         headers = map parseHeader headers'-    name <- lookupHeaderAttr "Content-Disposition" "name" headers-    let filename = lookupHeaderAttr "Content-Disposition" "filename" headers-    let ctype = fromMaybe "" $ lookupHeader "Content-Type" headers+    name <- lookupHeaderAttr (SL.pack "Content-Disposition")+                             (SL.pack "name")+                             headers+    let filename = lookupHeaderAttr (SL.pack "Content-Disposition")+                                    (SL.pack "filename")+                                    headers+    let ctype = fromMaybe SL.empty $ lookupHeader (SL.pack "Content-Type")+                                                  headers     -- charset = lookupHeaderAttr "Content-Type" "charset" headers     return $ case filename of-        Nothing -> Left (name, (fromLazyByteString $ chompBS content))+        Nothing -> Left (name, SL.chomp content)         Just f -> Right (name, FileInfo f ctype content)  -- | Split up a bytestring along the given boundary.-getPieces :: String -- ^ boundary-          -> BS.ByteString -- ^ content-          -> [BS.ByteString]+getPieces :: StringLike s+          => String -- ^ boundary+          -> s -- ^ content+          -> [s] {- FIXME this would be nice... getPieces b c =     let fullBound = ord '-' `BS.cons'` (ord '-' `BS.cons'` b)@@ -227,41 +299,41 @@         filter (not . BS.null) $         map chompBS pieces -}-getPieces b c-    | BS.null c = []-    | otherwise =-        let fullBound = toLazyByteString ('-':'-':b)-            (next, rest) = breakAtString fullBound c+getPieces _ c | SL.null c = []+getPieces b c =+        let fullBound = SL.pack $ '-' `SL.cons` ('-' `SL.cons` b)+            (next, rest) = SL.breakString fullBound c             rest' = checkRest rest             rest'' = getPieces b rest'-         in if BS.null next then rest'' else chompBS next : rest''+         in if SL.null next then rest'' else SL.chomp next : rest''     where-        br = ord '\r'-        bn = ord '\n'-        dash = ord '-'+        br = '\r'+        bn = '\n'+        dash = '-'         checkRest bs-            | BS.length bs < 2 = BS.empty-            | BS.head bs == bn = BS.tail bs-            | BS.head bs == br && BS.head (BS.tail bs) == bn =-                BS.tail $ BS.tail bs-            | BS.head bs == dash && BS.head (BS.tail bs) == dash = BS.empty-            | otherwise = BS.empty -- FIXME+            | SL.lengthLT 2 bs = SL.empty+            | SL.head bs == bn = SL.tail bs+            | SL.head bs == br && SL.head (SL.tail bs) == bn =+                SL.tail $ SL.tail bs+            | SL.head bs == dash && SL.head (SL.tail bs) == dash = SL.empty+            | otherwise = SL.empty -- FIXME  -- | Parse a post request. This function determines the correct decoding -- function to use.-parsePost :: String -- ^ content type+parsePost :: StringLike s+          => String -- ^ content type           -> String -- ^ content length-          -> BS.ByteString -- ^ body of the post-          -> ([(String, String)], [(String, FileInfo)])+          -> s -- ^ body of the post+          -> ([(s, s)], [(s, FileInfo s s)]) parsePost ctype clength body-    | urlenc `isPrefixOf` ctype = (decodeUrlPairs content, [])+    | urlenc `SL.isPrefixOf` ctype = (decodeUrlPairs content, [])     | formBound `isPrefixOf` ctype = parseMultipart boundProcessed content     | otherwise = ([], [])     where         len = case reads clength of             ((x, _):_) -> x             [] -> 0-        content = BS.take len body+        content = SL.take len body         urlenc = "application/x-www-form-urlencoded"         formBound = "multipart/form-data; boundary="         boundProcessed = drop (length formBound) ctype

@@ -0,0 +1,4 @@+module Web.Encodings.ListHelper (cons) where++cons :: a -> [a] -> [a]+cons = (:)

@@ -0,0 +1,82 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleContexts #-}+---------------------------------------------------------+-- Copyright     : Michael Snoyman+-- License       : BSD3+-- Maintainer    : Michael Snoyman <michael@snoyman.com>+---------------------------------------------------------++-- | Functions for parsing MIME headers (Key: value; k1=v1; k2=v2)+module Web.Encodings.MimeHeader+    ( Header+    , parseHeader+    , lookupHeader+    , lookupHeaderAttr+    , AttributeNotFound (..)+    , HeaderNotFound (..)+    ) where++--import Data.String.Util+import qualified Web.Encodings.StringLike as SL+import Web.Encodings.StringLike (StringLike)+import Control.Failure+import Control.Exception (Exception)+import Data.Typeable (Typeable)++type SomeMap a = [(a, a)]++-- | A single MIME header.+--type Header = (B8.ByteString, B8.ByteString, BSMap)+type Header a = (a, a, SomeMap a)++-- | Parse a header line in the format:+--+-- Name: value; attkey=attval; attkey2=attval2.+parseHeader :: StringLike a => a -> Header a+parseHeader s =+    let (k, rest) = SL.span (/= ':') s+        (v, attrs) = parseRest rest+     in (k, v, attrs) where+    parseRest :: StringLike a => a -> (a, SomeMap a)+    parseRest s' =+        let (v, rest) = SL.span (/= ';') s'+            attrs = parseAttrs rest+         in (SL.dropPrefix' (SL.pack ": ") v, attrs)+    parseAttrs :: StringLike a => a -> SomeMap a+    parseAttrs a | SL.null a = []+    parseAttrs a =+        let s' = SL.dropPrefix' (SL.pack "; ") a+            (next, rest) = SL.span (/= ';') s'+            (k, v) = SL.span (/= '=') next+            v' = SL.dropPrefix' (SL.pack "=") v+            v'' = SL.dropQuotes v'+         in (k, v'') : parseAttrs rest++data AttributeNotFound s = AttributeNotFound s s+    deriving (Show, Typeable)+instance (Typeable s, Show s) => Exception (AttributeNotFound s)+lookupHeaderAttr :: ( MonadFailure (AttributeNotFound s) m, StringLike s+                    , Eq s)+                 => s+                 -> s+                 -> [Header s]+                 -> m s+lookupHeaderAttr k1 k2 [] = failure $ AttributeNotFound k1 k2+lookupHeaderAttr k1 k2 ((key, _, vals):rest)+    | k1 == key = case lookup k2 vals of+                    Nothing -> failure $ AttributeNotFound k1 k2+                    Just v -> return v+    | otherwise = lookupHeaderAttr k1 k2 rest++data HeaderNotFound s = HeaderNotFound s+    deriving (Typeable, Show)+instance (Show s, Typeable s) => Exception (HeaderNotFound s)++lookupHeader :: (StringLike s, MonadFailure (HeaderNotFound s) m, Eq s)+             => s+             -> [Header s]+             -> m s+lookupHeader k [] = failure $ HeaderNotFound k+lookupHeader k ((key, val, _):rest)+    | k == key = return val+    | otherwise = lookupHeader k rest

@@ -0,0 +1,205 @@+{-# LANGUAGE FlexibleInstances #-}+module Web.Encodings.StringLike+    ( StringLike (..)+    ) where++import Prelude (Char, Bool (..), String, Int, Eq (..), Show, ($), (.),+                (<=), (-), otherwise, Maybe (..), (&&), not)+import qualified Prelude as P+import qualified Data.List as L+import qualified Web.Encodings.ListHelper as LH+import qualified Data.ByteString.Char8 as BS+import qualified Data.ByteString.Lazy.Char8 as BL+import qualified Data.Monoid as M+import qualified Data.Text as TS+import qualified Data.Text.Lazy as TL+import Data.Maybe (fromMaybe)++class (Eq a, Show a) => StringLike a where+    span :: (Char -> Bool) -> a -> (a, a)+    null :: a -> Bool+    concatMap :: (Char -> String) -> a -> a+    dropWhile :: (Char -> Bool) -> a -> a+    break :: (Char -> Bool) -> a -> (a, a)+    cons :: Char -> a -> a+    uncons :: a -> Maybe (Char, a)+    append :: a -> a -> a+    intercalate :: a -> [a] -> a+    isPrefixOf :: a -> a -> Bool+    take :: Int -> a -> a+    head :: a -> Char+    tail :: a -> a+    init :: a -> a+    last :: a -> Char+    empty :: a++    pack :: String -> a+    unpack :: a -> String++    dropPrefix :: a -> a -> Maybe a+    dropPrefix porig sorig = helper porig sorig where+        helper p s+            | null p && null s = Just empty+            | null p = Just s+            | null s = Nothing+            | head p == head s = helper (tail p) (tail s)+            | otherwise = Nothing+    dropPrefix' :: a -> a -> a+    dropPrefix' p c = case dropPrefix p c of+        Just x -> x+        Nothing -> c+    dropQuotes :: a -> a+    dropQuotes s+        | lengthGE 2 s && head s == '"' && last s == '"' = tail $ init s+        | otherwise = s+    chomp :: a -> a+    chomp s | null s = s+    chomp s = case last s of+                '\n' -> chomp $ init s+                '\r' -> chomp $ init s+                _ -> s+    split :: Char -> a -> [a]+    split c s =+        let (next, rest) = breakChar c s+         in if null next+                then (if null rest then [] else [rest])+                else next : split c rest+    breakCharMaybe :: Char -> a -> Maybe (a, a)+    breakCharMaybe c s+        | null s = Nothing+        | c == head s = Just (empty, tail s)+        | otherwise = do+            (next, rest) <- breakCharMaybe c (tail s)+            Just (cons (head s) next, rest)+    breakChar :: Char -> a -> (a, a)+    breakChar c s = fromMaybe (s, empty) $ breakCharMaybe c s+    breakString :: a -> a -> (a, a)+    breakString _ c | null c = (empty, empty)+    breakString p c = case dropPrefix p c of+        Just x -> (empty, x)+        Nothing ->+            let x = head c+                xs = tail c+                (next, rest) = breakString p xs+             in (cons x next, rest)+    takeLine :: a -> (a, a)+    takeLine a =+        let (x, y) = breakChar '\n' a+            x' = chomp x+         in (x', y)+    takeUntilBlank :: a -> ([a], a)+    takeUntilBlank a =+        let (next, rest) = takeLine a+         in if null next+                then ([], rest)+                else let (nexts, rest') = takeUntilBlank rest+                      in (next : nexts, rest')++    lengthLT :: Int -> a -> Bool+    lengthLT i _ | i <= 0 = False+    lengthLT i a+        | null a = True+        | otherwise = lengthLT (i - 1) $ tail a+    lengthGE :: Int -> a -> Bool+    lengthGE i = not . lengthLT i++instance StringLike [Char] where+    intercalate = L.intercalate+    null = P.null+    concatMap = P.concatMap+    tail = P.tail+    head = P.head+    cons = LH.cons+    uncons [] = Nothing+    uncons (x:xs) = Just (x, xs)+    span = P.span+    dropWhile = P.dropWhile+    break = P.break+    append = M.mappend+    isPrefixOf = L.isPrefixOf+    take = P.take+    empty = M.mempty+    pack = P.id+    unpack = P.id+    init = P.init+    last = P.last++instance StringLike BS.ByteString where+    span = BS.span+    null = BS.null+    concatMap f = BS.concatMap $ pack . f+    dropWhile = BS.dropWhile+    break = BS.break+    cons = BS.cons+    uncons = BS.uncons+    append = BS.append+    intercalate = BS.intercalate+    isPrefixOf = BS.isPrefixOf+    take = BS.take+    head = BS.head+    tail = BS.tail+    empty = BS.empty+    pack = BS.pack+    unpack = BS.unpack+    init = BS.init+    last = BS.last++instance StringLike BL.ByteString where+    span = BL.span+    null = BL.null+    concatMap f = BL.concatMap $ pack . f+    dropWhile = BL.dropWhile+    break = BL.break+    cons = BL.cons+    uncons = BL.uncons+    append = BL.append+    intercalate = BL.intercalate+    isPrefixOf = BL.isPrefixOf+    take i = BL.take $ P.fromIntegral i+    head = BL.head+    tail = BL.tail+    empty = BL.empty+    pack = BL.pack+    unpack = BL.unpack+    init = BL.init+    last = BL.last++instance StringLike TS.Text where+    span = TS.spanBy+    null = TS.null+    concatMap f = TS.concatMap $ pack . f+    dropWhile = TS.dropWhile+    break = TS.breakBy+    cons = TS.cons+    uncons = TS.uncons+    append = TS.append+    intercalate = TS.intercalate+    isPrefixOf = TS.isPrefixOf+    take i = TS.take $ P.fromIntegral i+    head = TS.head+    tail = TS.tail+    empty = TS.empty+    pack = TS.pack+    unpack = TS.unpack+    init = TS.init+    last = TS.last++instance StringLike TL.Text where+    span = TL.spanBy+    null = TL.null+    concatMap f = TL.concatMap $ pack . f+    dropWhile = TL.dropWhile+    break = TL.breakBy+    cons = TL.cons+    uncons = TL.uncons+    append = TL.append+    intercalate = TL.intercalate+    isPrefixOf = TL.isPrefixOf+    take i = TL.take $ P.fromIntegral i+    head = TL.head+    tail = TL.tail+    empty = TL.empty+    pack = TL.pack+    unpack = TL.unpack+    init = TL.init+    last = TL.last

@@ -1,5 +1,5 @@ name:            web-encodings-version:         0.0.1+version:         0.2.0 license:         BSD3 license-file:    LICENSE author:          Michael Snoyman <michael@snoyman.com>@@ -12,14 +12,38 @@ build-type:      Simple homepage:        http://github.com/snoyberg/web-encodings/tree/master +flag buildtests+  description: Build the executable to run unit tests+  default: False+ library+    if flag(buildtests)+        Buildable: False+    else+        Buildable: True     build-depends:   base >=4 && <5,-                     bytestring,-                     bytestring-class,-                     time >= 1.1,-                     old-locale+                     time >= 1.1.2.4 && < 1.2,+                     old-locale >= 1.0.0.1 && < 1.1,+                     bytestring >= 0.9.1.4 && < 0.10,+                     text >= 0.5 && < 0.6,+                     failure >= 0.0.0 && < 0.1,+                     safe >= 0.2 && < 0.3     exposed-modules: Web.Encodings-    other-modules:   Data.Mime.Header,-                     Data.ByteString.Lazy.Util,-                     Data.String.Util+                     Web.Encodings.MimeHeader,+                     Web.Encodings.StringLike,+                     Web.Encodings.ListHelper     ghc-options:     -Wall++executable           runtests+    if flag(buildtests)+        Buildable: True+        build-depends:   test-framework,+                         test-framework-quickcheck,+                         test-framework-hunit,+                         HUnit,+                         QuickCheck >= 1 && < 2,+                         convertible >= 1.2.0 && < 1.3+    else+        Buildable: False+    ghc-options:     -Wall+    main-is:         Test.hs