diff --git a/Data/ByteString/Lazy/Util.hs b/Data/ByteString/Lazy/Util.hs deleted file mode 100644 --- a/Data/ByteString/Lazy/Util.hs +++ /dev/null @@ -1,89 +0,0 @@ ---------------------------------------------------------- --- | --- Module : Data.ByteString.Lazy.Util --- Copyright : Michael Snoyman --- License : BSD3 --- --- Maintainer : Michael Snoyman --- 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') diff --git a/Data/Mime/Header.hs b/Data/Mime/Header.hs deleted file mode 100644 --- a/Data/Mime/Header.hs +++ /dev/null @@ -1,69 +0,0 @@ ---------------------------------------------------------- --- | --- Module : Data.Mime.Header --- Copyright : Michael Snoyman --- License : BSD3 --- --- Maintainer : Michael Snoyman --- 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 diff --git a/Data/String/Util.hs b/Data/String/Util.hs deleted file mode 100644 --- a/Data/String/Util.hs +++ /dev/null @@ -1,55 +0,0 @@ ---------------------------------------------------------- --- | --- Module : Data.String.Util --- Copyright : Michael Snoyman --- License : BSD3 --- --- Maintainer : Michael Snoyman --- 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" diff --git a/Test.hs b/Test.hs new file mode 100644 --- /dev/null +++ b/Test.hs @@ -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 +-} diff --git a/Web/Encodings.hs b/Web/Encodings.hs --- a/Web/Encodings.hs +++ b/Web/Encodings.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleContexts #-} --------------------------------------------------------- -- | -- Module : Web.Encodings @@ -6,7 +6,7 @@ -- License : BSD3 -- -- Maintainer : Michael Snoyman --- 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 '<' = "<" @@ -107,87 +108,152 @@ encodeHtmlChar '\'' = "'" 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 diff --git a/Web/Encodings/ListHelper.hs b/Web/Encodings/ListHelper.hs new file mode 100644 --- /dev/null +++ b/Web/Encodings/ListHelper.hs @@ -0,0 +1,4 @@ +module Web.Encodings.ListHelper (cons) where + +cons :: a -> [a] -> [a] +cons = (:) diff --git a/Web/Encodings/MimeHeader.hs b/Web/Encodings/MimeHeader.hs new file mode 100644 --- /dev/null +++ b/Web/Encodings/MimeHeader.hs @@ -0,0 +1,82 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +--------------------------------------------------------- +-- Copyright : Michael Snoyman +-- License : BSD3 +-- Maintainer : Michael Snoyman +--------------------------------------------------------- + +-- | 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 diff --git a/Web/Encodings/StringLike.hs b/Web/Encodings/StringLike.hs new file mode 100644 --- /dev/null +++ b/Web/Encodings/StringLike.hs @@ -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 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.0.1 +version: 0.2.0 license: BSD3 license-file: LICENSE author: Michael Snoyman @@ -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