summaryrefslogtreecommitdiffstats
path: root/Codec/MIME/Parse.hs
diff options
context:
space:
mode:
authorIavor S. Diatchki <diatchki@galois.com>2012-06-01 09:30:52 -0700
committerIavor S. Diatchki <diatchki@galois.com>2012-06-01 09:30:52 -0700
commitc97baa979878145c599c057d8bba01618c223178 (patch)
tree1317ef36ae3c490195d68b72422fd41b6540eb35 /Codec/MIME/Parse.hs
parent496029fc2a0922685f372f456b44780b1df61c27 (diff)
Integrate improvements from Scrive (thanks to Magnus Carlsson!)
* Codec.MIME.Parse.parseMIMEBody: stick the header argument into the returned mime_val_headers field. * Codec.MIME.Parse.parseMIMEMessage: be more tolerant about non-standard newlines. * Codec.MIME.Parse.untilMatch: fix a bug demonstrated by input "ab" "aab".
Diffstat (limited to 'Codec/MIME/Parse.hs')
-rw-r--r--Codec/MIME/Parse.hs36
1 files changed, 21 insertions, 15 deletions
diff --git a/Codec/MIME/Parse.hs b/Codec/MIME/Parse.hs
index df3549f..6108441 100644
--- a/Codec/MIME/Parse.hs
+++ b/Codec/MIME/Parse.hs
@@ -31,18 +31,17 @@ import Data.List
import Debug.Trace ( trace )
parseMIMEBody :: [(String,String)] -> String -> MIMEValue
-parseMIMEBody headers_in body =
- case mimeType mty of
+parseMIMEBody headers_in body = result { mime_val_headers = headers }
+ where
+ result = case mimeType mty of
Multipart{} -> fst (parseMultipart mty body)
Message{} -> fst (parseMultipart mty body)
- _ -> nullMIMEValue
- { mime_val_type = mty
- , mime_val_disp = parseContentDisp headers
- , mime_val_content = Single (processBody headers body)
- }
-
- where headers = [ (map toLower k,v) | (k,v) <- headers_in ]
- mty = fromMaybe defaultType
+ _ -> nullMIMEValue { mime_val_type = mty
+ , mime_val_disp = parseContentDisp headers
+ , mime_val_content = Single (processBody headers body)
+ }
+ headers = [ (map toLower k,v) | (k,v) <- headers_in ]
+ mty = fromMaybe defaultType
(parseContentType =<< lookupField "content-type" headers)
defaultType :: Type
defaultType = Type { mimeType = Text "plain"
@@ -87,9 +86,16 @@ processBody headers body =
Nothing -> body
Just v -> decodeBody v body
+normalizeCRLF :: String -> String
+normalizeCRLF ('\r':'\n':xs) = '\r':'\n':normalizeCRLF xs
+normalizeCRLF ('\r':xs) = '\r':'\n':normalizeCRLF xs
+normalizeCRLF ('\n':xs) = '\r':'\n':normalizeCRLF xs
+normalizeCRLF (x:xs) = x:normalizeCRLF xs
+normalizeCRLF [] = []
+
parseMIMEMessage :: String -> MIMEValue
parseMIMEMessage entity =
- case parseHeaders entity of
+ case parseHeaders (normalizeCRLF entity) of
(as,bs) -> parseMIMEBody as bs
parseHeaders :: String -> ([(String,String)], String)
@@ -217,10 +223,10 @@ multipartTypes =
]
untilMatch :: String -> String -> Maybe String
-untilMatch str xs = go str xs
- where go "" rs = Just rs
- go _ "" = Nothing
- go (a:as) (b:bs) = if a == b then go as bs else go str bs
+untilMatch "" a = Just a
+untilMatch _ "" = Nothing
+untilMatch a b | a `isPrefixOf` b = Just $ drop (length a) b
+untilMatch a (_:bs) = untilMatch a bs
matchUntil :: String -> String -> (String, String)
matchUntil _ "" = ("", "")