{-# LANGUAGE OverloadedStrings #-}
module Data.RFC5322.Address.Text
(
mailbox
, address
, renderMailbox
, renderMailboxes
) where
import Control.Applicative ((<|>), optional)
import Data.Foldable (fold)
import Data.Semigroup ((<>))
import Data.List (intersperse)
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import qualified Data.Text.Lazy as LT
import qualified Data.Text.Internal.Builder as Builder
import qualified Data.ByteString as B
import Data.Attoparsec.Text as A hiding (parse, take)
import Data.List.NonEmpty (intersperse)
import Data.MIME.Charset (decodeLenient)
import Data.RFC5322.Address.Types
import Data.RFC5322.Internal
renderMailboxes :: [Mailbox] -> T.Text
renderMailboxes = LT.toStrict . Builder.toLazyText . buildMailboxes
buildMailboxes :: [Mailbox] -> Builder.Builder
buildMailboxes = fold . Data.List.intersperse ", " . fmap buildMailbox
renderMailbox :: Mailbox -> T.Text
renderMailbox = LT.toStrict . Builder.toLazyText . buildMailbox
buildMailbox :: Mailbox -> Builder.Builder
buildMailbox (Mailbox n a) =
maybe a' (\n' -> "\"" <> Builder.fromText n' <> "\" " <> "<" <> a' <> ">") n
where
a' = renderAddressSpec a
renderAddressSpec :: AddrSpec -> Builder.Builder
renderAddressSpec (AddrSpec lp (DomainDotAtom b))
| " " `B.isInfixOf` lp = "\"" <> buildLP <> "\"" <> rest
| otherwise = buildLP <> rest
where
buildLP = Builder.fromText $ decodeLenient lp
rest = "@" <> foldMap Builder.fromText (decodeLenient <$> Data.List.NonEmpty.intersperse "." b)
renderAddressSpec (AddrSpec lp (DomainLiteral b)) =
foldMap Builder.fromText [decodeLenient lp, "@", decodeLenient b]
mailbox :: Parser Mailbox
mailbox = Mailbox <$> optional displayName <*> angleAddr
<|> Mailbox Nothing <$> addressSpec
displayName :: Parser T.Text
displayName = phrase
mailboxList :: Parser [Mailbox]
mailboxList = mailbox `sepBy` char ','
group :: Parser Address
group = Group <$> displayName <* char ':' <*> mailboxList <* char ';' <* optionalCFWS
address :: Parser Address
address = group <|> Single <$> mailbox
angleAddr :: Parser AddrSpec
angleAddr = optionalCFWS *>
char '<' *> addressSpec <* char '>'
<* optionalCFWS
addressSpec :: Parser AddrSpec
addressSpec = AddrSpec <$> (T.encodeUtf8 <$> localPart) <*> (char '@' *> domain)
domain :: Parser Domain
domain = (DomainDotAtom <$> (pure . T.encodeUtf8 <$> dotAtom))
<|> (DomainLiteral <$> (T.encodeUtf8 <$> domainLiteral))