Add catchall OtherBody for unsupported mime types

src/Network/Mail/Parse/Parsers/HeaderFields.hs

@@ -1,13 +1,13 @@
-module Network.Mail.Parse.Parsers.HeaderFields (
-  emailAddressParser,
-  emailAddressListParser,
-  parseTime,
-  parseEmailAddress,
-  parseEmailAddressList,
-  parseText,
-  parseTextList,
-  parseMessageId
-) where
+module Network.Mail.Parse.Parsers.HeaderFields
+    ( emailAddressParser
+    , emailAddressListParser
+    , parseTime
+    , parseEmailAddress
+    , parseEmailAddressList
+    , parseText
+    , parseTextList
+    , parseMessageId
+    ) where
 
 import Network.Mail.Parse.Types
 import Network.Mail.Parse.Decoders.BodyDecoder (transferDecode, encodingToUtf)
@@ -22,11 +22,10 @@ import Data.Maybe
 import qualified Data.Char as C
 import Data.Either (isRight)
 import Data.Either.Combinators (mapLeft, mapBoth)
-
 import Data.Either.Unwrap (fromRight)
-
 import Data.Time.Parse (strptime)
 import Data.Time.LocalTime
+import Data.Tuple (fst)
 import Control.Monad (join, liftM)
 
 -- |Parses a name-addr formatted email
@@ -95,7 +94,7 @@ zoneToOffset offset = if offsetH == '+' || offsetH == '-'
     "PST" -> -8
     "PDT" -> -7
     _ -> 0
-  where offsetH = T.head offset
+  where offsetH = maybe ' ' fst $ T.uncons offset
         direction = if offsetH == '+' then 1 else -1
         splitOffset = T.splitAt 2 $ T.tail offset
         hours = mapLeft T.pack $ TR.decimal . fst $ splitOffset

src/Network/Mail/Parse/Parsers/Message.hs

@@ -49,10 +49,10 @@ parseHeader header = fromRight header parsedHeader
           _ -> Right header
 
 -- |Parses a single message
-messageParser :: Maybe [Header]   -- ^ Headers, if they were already parsed
-                -> Maybe [Header] -- ^ Context headers, useful is encoding is only
-                                  -- defined in the message above, for instance
-                -> Parser (Either ErrorMessage EmailMessage)
+messageParser :: Maybe [Header] -- ^ Headers, if they were already parsed
+              -> Maybe [Header] -- ^ Context headers, useful is encoding is only
+                                -- defined in the message above, for instance
+              -> Parser (Either ErrorMessage EmailMessage)
 messageParser headersIn helperHeadersIn = do
   headers <- if isJust headersIn
     then return . fromJust $ headersIn
@@ -61,11 +61,7 @@ messageParser headersIn helperHeadersIn = do
 
   body <- takeByteString
   let parsedHeaders = map parseHeader headers
-
-  -- Parse MIME if the message is in a MIME format
-  let parsedBody = if isJust $ find isMIME headers
-      then parseMIME (headers ++ helperHeaders) body
-      else Right [TextBody $ decodeTextBody (headers ++ helperHeaders) body]
+      parsedBody = parseMIME (headers ++ helperHeaders) body
 
   return $! parsedBody >>= return . EmailMessage parsedHeaders
 
@@ -95,7 +91,7 @@ parseMIME headers body = if isRight msgType then
   (case mimeType . fromRight' $ msgType of
     Multipart _ -> multiParsed >>= multipartParser headers
     Text _ -> Right decodedBody
-    _ -> Left "mimetype not supported")
+    _ -> Right [OtherBody $ decodeBody headers body])
   else Right decodedBody
   where msgType = findHeader "Content-Type" headers >>=
           Right . parseMIMEType . headerContents >>=

src/Network/Mail/Parse/Parsers/Utils.hs

@@ -3,6 +3,7 @@ module Network.Mail.Parse.Parsers.Utils where
 import Network.Mail.Parse.Types
 import Network.Mail.Parse.Utils
 
+import Data.Maybe (fromMaybe, listToMaybe)
 import qualified Data.Text as T
 import Data.List
 import Control.Monad (liftM)
@@ -24,9 +25,12 @@ findAttachmentName header =
       else liftM (T.strip . T.dropAround (== '"') . (!! 1)) filenameParam
     else Nothing
   where split = T.splitOn ";" header
-        dispType = T.toLower . T.strip . head $ split
+        dispType = T.toLower . T.strip . (fromMaybe "") $ listToMaybe split
         paramSplit = map (T.splitOn "=") (tail split)
-        filenameParam = find (\x -> T.strip (head x) == "filename") paramSplit
+        filenameParam = find ( \x -> case x of
+                                  [] -> False
+                                  x':_ -> T.strip x' == "filename"
+                             ) paramSplit
 
 -- |Decide if the header contains a valid MIME info
 isMIME :: Header -> Bool

src/Network/Mail/Parse/Types.hs

@@ -48,9 +48,10 @@ data EmailBody
   -- |Body of a MIME message part. Contains headers
   = MessageBody EmailMessage
   -- = MIMEBody { mimeHeaders :: ![Header], mimeBody :: !Text}
-  -- |If the message contained no MIME information, it's probably
-  -- just some text. Best guess decoding into UTF-8 is applied
+  -- |A raw text body
   | TextBody !Text
+  -- |Unknown body that may contain arbitrary binary
+  | OtherBody !BS.ByteString
   -- |Attachment is part of a MIME message, but a rather special
   -- one. It's decoded from whatever the transfer encoding was applied
   -- and left as a raw sollection of bytes for your enjoyment

src/Network/Mail/Parse/Utils.hs

@@ -39,9 +39,10 @@ isConsequentHeaderLine = satisfy isWhitespace *>
 commentRemover :: Text -> Text
 commentRemover contents = T.strip withoutComment
   where splitAtComment = T.split (\c -> c == '(' || c == ')') contents
-        withoutComment = if length splitAtComment > 1
-                          then T.append (head splitAtComment) (last splitAtComment)
-                          else head splitAtComment
+        withoutComment = case splitAtComment of
+            [] -> ""
+            [x] -> x
+            x:xs -> T.append x (last xs)
 
 -- |Given a header name, it will try to locate it in
 -- a list of headers, fail if it's not there