diff --git a/src/Network/Mail/Parse/Parsers/HeaderFields.hs b/src/Network/Mail/Parse/Parsers/HeaderFields.hs index 1abfa6e..7801da0 100644 --- a/src/Network/Mail/Parse/Parsers/HeaderFields.hs +++ b/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 diff --git a/src/Network/Mail/Parse/Parsers/Message.hs b/src/Network/Mail/Parse/Parsers/Message.hs index 6d82d85..8fbbc3e 100644 --- a/src/Network/Mail/Parse/Parsers/Message.hs +++ b/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 >>= diff --git a/src/Network/Mail/Parse/Parsers/Utils.hs b/src/Network/Mail/Parse/Parsers/Utils.hs index e5b7a98..74608b9 100644 --- a/src/Network/Mail/Parse/Parsers/Utils.hs +++ b/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 diff --git a/src/Network/Mail/Parse/Types.hs b/src/Network/Mail/Parse/Types.hs index 8664d2d..99d983f 100644 --- a/src/Network/Mail/Parse/Types.hs +++ b/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 diff --git a/src/Network/Mail/Parse/Utils.hs b/src/Network/Mail/Parse/Utils.hs index 2fb0283..98fba95 100644 --- a/src/Network/Mail/Parse/Utils.hs +++ b/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