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".

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 _   "" = ("", "")