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

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