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)
import Data.Attoparsec.Text
import qualified Data.Text as T
import qualified Data.Text.Read as TR
import qualified Data.Attoparsec.Text as AP
import Data.Text.Encoding (encodeUtf8)
import Control.Applicative
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 Control.Monad (join, liftM)
nameAddrParser :: Parser EmailAddress
nameAddrParser = do
label <- AP.takeWhile (/= '<')
_ <- char '<'
address <- AP.takeWhile1 (/= '>')
_ <- char '>'
return $ EmailAddress address (Just . T.strip $ label)
addrSpecParser :: Parser EmailAddress
addrSpecParser = do
address <- AP.takeWhile1 (\c -> c /= '\r' && c /= ',' && c /= ' ')
if isJust $ T.find (== '@') address
then return $ EmailAddress address Nothing
else fail "no @ in the address"
emailAddressParser :: Parser EmailAddress
emailAddressParser = nameAddrParser <|> addrSpecParser
eatWhitespace :: Parser T.Text
eatWhitespace = AP.takeWhile (\c -> c == ',' || c == ' ')
emailAddressListParser :: Parser [EmailAddress]
emailAddressListParser =
(eatWhitespace *> emailAddressParser) `sepBy'` char ','
messageIdParser :: Parser MessageId
messageIdParser = parseWrappedMsgId <|> takeText
parseWrappedMsgId :: Parser MessageId
parseWrappedMsgId = do
_ <- char '<'
msgId <- AP.takeWhile1 (/= '>')
_ <- char '>'
return msgId
minutesAndHoursToTZ :: Int -> Either T.Text (Int, T.Text) ->
(Int, T.Text) -> Either T.Text TimeZone
minutesAndHoursToTZ direction minutes hours =
Right $ minutesToTimeZone timezoneMins
where knownMinutes = if isRight minutes
then fst . fromRight $ minutes
else 0
h = fst hours
timezoneMins = direction * (h * 60 + knownMinutes)
zoneToOffset :: T.Text -> Either ErrorMessage TimeZone
zoneToOffset offset = if offsetH == '+' || offsetH == '-'
then hours >>= (minutesAndHoursToTZ direction minutes)
else Right $ minutesToTimeZone . (*60) $ case offset of
"UT" -> 0
"GMT" -> 0
"EST" -> -5
"EDT" -> -4
"CST" -> -6
"CDT" -> -5
"MST" -> -7
"MDT" -> -6
"PST" -> -8
"PDT" -> -7
_ -> 0
where offsetH = T.head offset
direction = if offsetH == '+' then 1 else -1
splitOffset = T.splitAt 2 $ T.tail offset
hours = mapLeft T.pack $ TR.decimal . fst $ splitOffset
minutes = mapLeft T.pack $ TR.decimal . snd $ splitOffset
timeToLocalTime :: (T.Text, T.Text, T.Text, [T.Text]) -> Maybe LocalTime
timeToLocalTime (day, month, year, timeOfDay@(hours:minutes:_)) =
liftM fst (strptime "%d %b %Y %T" dateString)
where dateString = T.intercalate " " [day, month, year, timeString]
seconds = if length timeOfDay < 3 then "0" else last timeOfDay
timeString = T.intercalate ":" [hours, minutes, seconds]
timeParser :: Parser (Either ErrorMessage ZonedTime)
timeParser =
do
day <- AP.takeWhile1 C.isDigit
AP.takeWhile (== ' ')
month <- AP.takeWhile1 C.isLetter
AP.takeWhile (== ' ')
year <- AP.takeWhile1 C.isDigit
AP.takeWhile (== ' ')
timeOfDay <- (AP.takeWhile (== ':') *> AP.takeWhile1 C.isDigit) `sepBy` char ':'
AP.takeWhile (== ' ')
zone <- AP.takeWhile1 (/= ' ')
let localTime = timeToLocalTime (day, month, year, timeOfDay)
let timeZone = zoneToOffset zone
let result = if isJust localTime && isRight timeZone
then Right $ ZonedTime (fromJust localTime) (fromRight timeZone)
else mapBoth (const "cannot decode timezone") (const defaultZT) timeZone
return result
parseTime :: T.Text -> Either ErrorMessage ZonedTime
parseTime dateString = join . mapLeft T.pack $ parseOnly timeParser withoutDoW
where withoutDoW = T.strip . last $ T.splitOn "," dateString
parseMessageId :: T.Text -> Either ErrorMessage MessageId
parseMessageId = mapLeft T.pack . parseOnly messageIdParser
parseEmailAddress :: T.Text -> Either ErrorMessage EmailAddress
parseEmailAddress = mapLeft T.pack . parseOnly emailAddressParser
parseEmailAddressList :: T.Text -> Either ErrorMessage [EmailAddress]
parseEmailAddressList = mapLeft T.pack . parseOnly emailAddressListParser
untilEndSection :: Char -> Char -> Maybe Char
untilEndSection prev current =
if prev == '?' && current == '='
then Nothing
else Just current
untilStartSection :: Char -> Char -> Maybe Char
untilStartSection prev current =
if prev == '=' && current == '?'
then Nothing
else Just current
parseInlineEncoding :: Parser (Either ErrorMessage T.Text)
parseInlineEncoding = do
charset <- AP.takeWhile1 (/= '?')
char '?'
encoding <- AP.takeWhile1 (/= '?')
char '?'
matchedText <- AP.scan ' ' untilEndSection
char '='
let text = encodeUtf8 $ T.init matchedText
let decoded = mapLeft (const "Count not decode encoding") (transferDecode text encoding) >>= return . (`encodingToUtf` charset)
if T.toLower encoding == "q"
then return $ liftM (T.replace "_" " ") decoded
else return decoded
parseTextBlock :: Parser (Either ErrorMessage T.Text)
parseTextBlock = do
before <- AP.scan ' ' untilStartSection
endReached <- atEnd
decoded <- if not endReached
then char '?' >> parseInlineEncoding
else return . Right $ T.empty
let didDecode = isRight decoded && (not . T.null . fromRight $ decoded)
let normalizedBefore = if didDecode then T.init before else before
return $ liftM (T.append normalizedBefore) decoded
untilEOF :: Parser (Either ErrorMessage T.Text) -> Parser [Either ErrorMessage T.Text]
untilEOF parser = do
parsed <- parser
endReached <- atEnd
if endReached
then return [parsed]
else liftM (parsed:) (untilEOF parser)
parseText' :: Parser (Either ErrorMessage T.Text)
parseText' = do
blocks <- untilEOF parseTextBlock
return $ liftM T.concat (mapM id blocks)
parseText :: T.Text -> Either ErrorMessage T.Text
parseText = join . mapLeft T.pack . parseOnly parseText'
parseTextList :: T.Text -> T.Text -> Either ErrorMessage [T.Text]
parseTextList splitChar t = mapM parseText $ T.splitOn splitChar t