module Network.Mail.Parse.Parsers.Message (messageParser) where
import Data.Attoparsec.ByteString
import Data.List (find)
import Data.Maybe
import Data.Either (isRight)
import Control.Monad (liftM)
import Network.Mail.Parse.Types
import Network.Mail.Parse.Utils
import Network.Mail.Parse.Parsers.Utils (isMIME, discoverAttachment)
import Network.Mail.Parse.Parsers.Multipart (parseMultipart)
import Network.Mail.Parse.Decoders.BodyDecoder (decodeBody, decodeTextBody)
import Network.Mail.Parse.Parsers.Header (headerParser)
import Network.Mail.Parse.Parsers.HeaderFields
import qualified Data.Text as T
import qualified Data.ByteString.Char8 as BSC
import Data.Either.Utils (maybeToEither)
import Data.Text.Encoding (encodeUtf8)
import Data.Either.Combinators (fromRight', fromRight, mapLeft)
import Codec.MIME.Parse (parseMIMEType)
import Codec.MIME.Type
import Control.Monad (join)
parseHeader :: Header -> Header
parseHeader header = fromRight header parsedHeader
where hname = headerName header
contents = headerContents header
references = parseTextList " " contents >>= mapM parseMessageId
parsedHeader = case T.toLower hname of
"date" -> Date <$> parseTime contents
"from" -> From <$> parseEmailAddress contents
"reply-to" -> ReplyTo <$> parseEmailAddress contents
"to" -> To <$> parseEmailAddressList contents
"cc" -> CC <$> parseEmailAddressList contents
"bcc" -> BCC <$> parseEmailAddressList contents
"message-id" -> MessageId <$> parseMessageId contents
"in-reply-to" -> InReplyTo <$> parseMessageId contents
"references" -> References <$> references
"subject" -> Right $ Subject contents
"comments" -> Right $ Comments contents
"keywords" -> Keywords <$> parseTextList "," contents
_ -> Right header
messageParser :: Maybe [Header]
-> Maybe [Header]
-> Parser (Either ErrorMessage EmailMessage)
messageParser headersIn helperHeadersIn = do
headers <- if isJust headersIn
then return . fromJust $ headersIn
else manyTill' headerParser $ string "\r\n"
let helperHeaders = if isJust helperHeadersIn then fromJust helperHeadersIn else []
body <- takeByteString
let parsedHeaders = map parseHeader headers
let parsedBody = if isJust $ find isMIME headers
then parseMIME (headers ++ helperHeaders) body
else Right [TextBody $ decodeTextBody (headers ++ helperHeaders) body]
return $! parsedBody >>= return . EmailMessage parsedHeaders
mimeParser :: [Header] -> Parser (Either ErrorMessage EmailBody)
mimeParser bodyHeaders = do
headers <- manyTill' headerParser $ string "\r\n"
let isAttachment = discoverAttachment headers
if isJust isAttachment
then do
body <- takeByteString
let filename = fromJust isAttachment
let decodedBody = decodeBody headers body
return . Right $ Attachment headers filename (Just decodedBody) Nothing
else (liftM . liftM) MessageBody $ messageParser (Just headers) (Just bodyHeaders)
multipartParser :: [Header] -> [BSC.ByteString] -> Either ErrorMessage [EmailBody]
multipartParser bodyHeaders parts = do
mapM (\p -> join $ mapLeft T.pack $ parseOnly (mimeParser bodyHeaders) p) parts
parseMIME :: [Header] -> BSC.ByteString -> Either ErrorMessage [EmailBody]
parseMIME headers body = if isRight msgType then
(case mimeType . fromRight' $ msgType of
Multipart _ -> multiParsed >>= multipartParser headers
Text _ -> Right decodedBody
_ -> Left "mimetype not supported")
else Right decodedBody
where msgType = findHeader "Content-Type" headers >>=
Right . parseMIMEType . headerContents >>=
maybeToEither "Couldn't parse message type"
multiParsed = msgType >>=
\x -> maybeToEither "" $ find (\p -> paramName p == "boundary") (mimeParams x) >>=
return . encodeUtf8 . paramValue >>=
\b -> eitherToMaybe $ parseOnly (parseMultipart b) body
decodedBody = [TextBody $ decodeTextBody headers body]