summaryrefslogtreecommitdiffstats
path: root/Codec
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
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')
-rw-r--r--Codec/MIME/Decode.hs2
-rw-r--r--Codec/MIME/Parse.hs36
-rw-r--r--Codec/MIME/Type.hs2
-rw-r--r--Codec/MIME/Utils.hs2
4 files changed, 24 insertions, 18 deletions
diff --git a/Codec/MIME/Decode.hs b/Codec/MIME/Decode.hs
index 364e0fb..278d6f6 100644
--- a/Codec/MIME/Decode.hs
+++ b/Codec/MIME/Decode.hs
@@ -27,7 +27,7 @@ import Codec.MIME.Base64 as Base64
decodeBody :: String -> String -> String
decodeBody enc body =
case map toLower enc of
- "base64" -> map (chr.fromIntegral) $ Base64.decode body
+ "base64" -> Base64.decodeToString body
"quoted-printable" -> QP.decode body
_ -> body
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 _ "" = ("", "")
diff --git a/Codec/MIME/Type.hs b/Codec/MIME/Type.hs
index 5b91b14..675d29e 100644
--- a/Codec/MIME/Type.hs
+++ b/Codec/MIME/Type.hs
@@ -14,7 +14,7 @@
--------------------------------------------------------------------
module Codec.MIME.Type where
-import Data.List ( concatMap, isSuffixOf )
+import Data.List ( isSuffixOf )
data Type
= Type
diff --git a/Codec/MIME/Utils.hs b/Codec/MIME/Utils.hs
index 624d433..8606342 100644
--- a/Codec/MIME/Utils.hs
+++ b/Codec/MIME/Utils.hs
@@ -26,7 +26,7 @@ findMultipartNamed nm mv =
case mime_val_content mv of
Multi ms -> msum (map (findMultipartNamed nm) ms)
Single {} -> do cd <- mime_val_disp mv
- find (withDispName nm) (dispParams cd)
+ _ <- find (withDispName nm) (dispParams cd)
return mv
where withDispName a (Name b) = a == b
withDispName _ _ = False