{-# LANGUAGE OverloadedStrings #-}
module Data.IMF.Text
(
mailbox
, mailboxList
, readMailbox
, address
, addressList
, renderMailbox
, renderMailboxes
, renderAddress
, renderAddresses
, renderAddressSpec
) where
import Control.Applicative ((<|>), optional)
import Data.CaseInsensitive
import Data.Foldable (fold)
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 (char, parse, take)
import Data.List.NonEmpty (intersperse)
import Data.MIME.Charset (decodeLenient)
import Data.IMF (Mailbox(..), Address(..), AddrSpec(..), Domain(..))
import Data.IMF.Syntax
renderMailboxes :: [Mailbox] -> T.Text
renderMailboxes :: [Mailbox] -> Text
renderMailboxes = Text -> Text
LT.toStrict (Text -> Text) -> ([Mailbox] -> Text) -> [Mailbox] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> Text
Builder.toLazyText (Builder -> Text) -> ([Mailbox] -> Builder) -> [Mailbox] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Mailbox] -> Builder
buildMailboxes
buildMailboxes :: [Mailbox] -> Builder.Builder
buildMailboxes :: [Mailbox] -> Builder
buildMailboxes = [Builder] -> Builder
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold ([Builder] -> Builder)
-> ([Mailbox] -> [Builder]) -> [Mailbox] -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> [Builder] -> [Builder]
forall a. a -> [a] -> [a]
Data.List.intersperse Builder
", " ([Builder] -> [Builder])
-> ([Mailbox] -> [Builder]) -> [Mailbox] -> [Builder]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Mailbox -> Builder) -> [Mailbox] -> [Builder]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Mailbox -> Builder
buildMailbox
renderMailbox :: Mailbox -> T.Text
renderMailbox :: Mailbox -> Text
renderMailbox = Text -> Text
LT.toStrict (Text -> Text) -> (Mailbox -> Text) -> Mailbox -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> Text
Builder.toLazyText (Builder -> Text) -> (Mailbox -> Builder) -> Mailbox -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Mailbox -> Builder
buildMailbox
buildMailbox :: Mailbox -> Builder.Builder
buildMailbox :: Mailbox -> Builder
buildMailbox (Mailbox Maybe Text
n AddrSpec
a) =
Builder -> (Text -> Builder) -> Maybe Text -> Builder
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Builder
a' (\Text
n' -> Builder
"\"" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Builder
Builder.fromText Text
n' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"\" " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"<" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
a' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
">") Maybe Text
n
where
a' :: Builder
a' = AddrSpec -> Builder
buildAddressSpec AddrSpec
a
renderAddresses :: [Address] -> T.Text
renderAddresses :: [Address] -> Text
renderAddresses [Address]
xs = Text -> [Text] -> Text
T.intercalate Text
", " ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ Address -> Text
renderAddress (Address -> Text) -> [Address] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Address]
xs
renderAddress :: Address -> T.Text
renderAddress :: Address -> Text
renderAddress (Single Mailbox
m) = Mailbox -> Text
renderMailbox Mailbox
m
renderAddress (Group Text
name [Mailbox]
xs) = Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
":" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Mailbox] -> Text
renderMailboxes [Mailbox]
xs Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
";"
buildAddressSpec :: AddrSpec -> Builder.Builder
buildAddressSpec :: AddrSpec -> Builder
buildAddressSpec (AddrSpec ByteString
lp (DomainDotAtom NonEmpty (CI ByteString)
b))
| ByteString
" " ByteString -> ByteString -> Bool
`B.isInfixOf` ByteString
lp = Builder
"\"" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
buildLP Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"\"" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
rest
| Bool
otherwise = Builder
buildLP Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
rest
where
buildLP :: Builder
buildLP = Text -> Builder
Builder.fromText (Text -> Builder) -> Text -> Builder
forall a b. (a -> b) -> a -> b
$ ByteString -> Text
decodeLenient ByteString
lp
rest :: Builder
rest = Builder
"@" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> (CI ByteString -> Builder) -> NonEmpty (CI ByteString) -> Builder
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (Text -> Builder
Builder.fromText (Text -> Builder)
-> (CI ByteString -> Text) -> CI ByteString -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
decodeLenient (ByteString -> Text)
-> (CI ByteString -> ByteString) -> CI ByteString -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CI ByteString -> ByteString
forall s. CI s -> s
original)
(CI ByteString
-> NonEmpty (CI ByteString) -> NonEmpty (CI ByteString)
forall a. a -> NonEmpty a -> NonEmpty a
Data.List.NonEmpty.intersperse CI ByteString
"." NonEmpty (CI ByteString)
b)
buildAddressSpec (AddrSpec ByteString
lp (DomainLiteral ByteString
b)) =
(Text -> Builder) -> [Text] -> Builder
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Text -> Builder
Builder.fromText [ByteString -> Text
decodeLenient ByteString
lp, Text
"@", ByteString -> Text
decodeLenient ByteString
b]
renderAddressSpec :: AddrSpec -> T.Text
renderAddressSpec :: AddrSpec -> Text
renderAddressSpec = Text -> Text
LT.toStrict (Text -> Text) -> (AddrSpec -> Text) -> AddrSpec -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> Text
Builder.toLazyText (Builder -> Text) -> (AddrSpec -> Builder) -> AddrSpec -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AddrSpec -> Builder
buildAddressSpec
mailbox :: Parser Mailbox
mailbox :: Parser Mailbox
mailbox = Maybe Text -> AddrSpec -> Mailbox
Mailbox (Maybe Text -> AddrSpec -> Mailbox)
-> Parser Text (Maybe Text) -> Parser Text (AddrSpec -> Mailbox)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text Text -> Parser Text (Maybe Text)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional Parser Text Text
displayName Parser Text (AddrSpec -> Mailbox)
-> Parser Text AddrSpec -> Parser Mailbox
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Text AddrSpec
angleAddr
Parser Mailbox -> Parser Mailbox -> Parser Mailbox
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe Text -> AddrSpec -> Mailbox
Mailbox Maybe Text
forall a. Maybe a
Nothing (AddrSpec -> Mailbox) -> Parser Text AddrSpec -> Parser Mailbox
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text AddrSpec
addressSpec
readMailbox :: String -> Either String Mailbox
readMailbox :: String -> Either String Mailbox
readMailbox = Parser Mailbox -> Text -> Either String Mailbox
forall a. Parser a -> Text -> Either String a
parseOnly (Parser Mailbox
mailbox Parser Mailbox -> Parser Text () -> Parser Mailbox
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser Text ()
forall t. Chunk t => Parser t ()
endOfInput) (Text -> Either String Mailbox)
-> (String -> Text) -> String -> Either String Mailbox
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack
phrase :: Parser T.Text
phrase :: Parser Text Text
phrase = Text -> Parser Text Text -> Parser Text Text
forall m (f :: * -> *).
(Semigroup m, Alternative f) =>
m -> f m -> f m
foldMany1Sep (Char -> Text
forall (f :: * -> * -> *) s a. CharParsing f s a => Char -> s
singleton Char
' ') Parser Text Text
forall (f :: * -> * -> *) s a.
(Alternative (f s), CharParsing f s a, SM s) =>
f s s
word
displayName :: Parser T.Text
displayName :: Parser Text Text
displayName = Parser Text Text
phrase
mailboxList :: Parser [Mailbox]
mailboxList :: Parser [Mailbox]
mailboxList = Parser Mailbox
mailbox Parser Mailbox -> Parser Text Char -> Parser [Mailbox]
forall (f :: * -> *) a s. Alternative f => f a -> f s -> f [a]
`sepBy` Char -> Parser Text Char
forall (f :: * -> * -> *) s a. CharParsing f s a => Char -> f s a
char Char
','
addressList :: Parser [Address]
addressList :: Parser [Address]
addressList = Parser Address
address Parser Address -> Parser Text Char -> Parser [Address]
forall (f :: * -> *) a s. Alternative f => f a -> f s -> f [a]
`sepBy` Char -> Parser Text Char
forall (f :: * -> * -> *) s a. CharParsing f s a => Char -> f s a
char Char
','
group :: Parser Address
group :: Parser Address
group = Text -> [Mailbox] -> Address
Group (Text -> [Mailbox] -> Address)
-> Parser Text Text -> Parser Text ([Mailbox] -> Address)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text Text
displayName Parser Text ([Mailbox] -> Address)
-> Parser Text Char -> Parser Text ([Mailbox] -> Address)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> Parser Text Char
forall (f :: * -> * -> *) s a. CharParsing f s a => Char -> f s a
char Char
':' Parser Text ([Mailbox] -> Address)
-> Parser [Mailbox] -> Parser Address
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser [Mailbox]
mailboxList Parser Address -> Parser Text Char -> Parser Address
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> Parser Text Char
forall (f :: * -> * -> *) s a. CharParsing f s a => Char -> f s a
char Char
';' Parser Address -> Parser Text Text -> Parser Address
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser Text Text
forall (f :: * -> * -> *) s a.
(Alternative (f s), CharParsing f s a, SM s) =>
f s s
optionalCFWS
address :: Parser Address
address :: Parser Address
address = Parser Address
group Parser Address -> Parser Address -> Parser Address
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Mailbox -> Address
Single (Mailbox -> Address) -> Parser Mailbox -> Parser Address
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Mailbox
mailbox
angleAddr :: Parser AddrSpec
angleAddr :: Parser Text AddrSpec
angleAddr = Parser Text Text
forall (f :: * -> * -> *) s a.
(Alternative (f s), CharParsing f s a, SM s) =>
f s s
optionalCFWS Parser Text Text -> Parser Text Char -> Parser Text Char
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*>
Char -> Parser Text Char
forall (f :: * -> * -> *) s a. CharParsing f s a => Char -> f s a
char Char
'<' Parser Text Char -> Parser Text AddrSpec -> Parser Text AddrSpec
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Text AddrSpec
addressSpec Parser Text AddrSpec -> Parser Text Char -> Parser Text AddrSpec
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> Parser Text Char
forall (f :: * -> * -> *) s a. CharParsing f s a => Char -> f s a
char Char
'>'
Parser Text AddrSpec -> Parser Text Text -> Parser Text AddrSpec
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser Text Text
forall (f :: * -> * -> *) s a.
(Alternative (f s), CharParsing f s a, SM s) =>
f s s
optionalCFWS
addressSpec :: Parser AddrSpec
addressSpec :: Parser Text AddrSpec
addressSpec = ByteString -> Domain -> AddrSpec
AddrSpec (ByteString -> Domain -> AddrSpec)
-> Parser Text ByteString -> Parser Text (Domain -> AddrSpec)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Text -> ByteString
T.encodeUtf8 (Text -> ByteString) -> Parser Text Text -> Parser Text ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text Text
forall (f :: * -> * -> *) s a.
(Alternative (f s), CharParsing f s a, SM s) =>
f s s
localPart) Parser Text (Domain -> AddrSpec)
-> Parser Text Domain -> Parser Text AddrSpec
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Char -> Parser Text Char
forall (f :: * -> * -> *) s a. CharParsing f s a => Char -> f s a
char Char
'@' Parser Text Char -> Parser Text Domain -> Parser Text Domain
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Text Domain
domain)
domain :: Parser Domain
domain :: Parser Text Domain
domain = (NonEmpty (CI ByteString) -> Domain
DomainDotAtom (NonEmpty (CI ByteString) -> Domain)
-> (NonEmpty Text -> NonEmpty (CI ByteString))
-> NonEmpty Text
-> Domain
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> CI ByteString)
-> NonEmpty Text -> NonEmpty (CI ByteString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ByteString -> CI ByteString
forall s. FoldCase s => s -> CI s
mk (ByteString -> CI ByteString)
-> (Text -> ByteString) -> Text -> CI ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
T.encodeUtf8) (NonEmpty Text -> Domain)
-> Parser Text (NonEmpty Text) -> Parser Text Domain
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text (NonEmpty Text)
forall (f :: * -> * -> *) s a.
(Alternative (f s), CharParsing f s a, SM s) =>
f s (NonEmpty s)
dotAtom)
Parser Text Domain -> Parser Text Domain -> Parser Text Domain
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (ByteString -> Domain
DomainLiteral (ByteString -> Domain) -> (Text -> ByteString) -> Text -> Domain
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
T.encodeUtf8 (Text -> Domain) -> Parser Text Text -> Parser Text Domain
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text Text
forall (f :: * -> * -> *) s a.
(Alternative (f s), CharParsing f s a, SM s) =>
f s s
domainLiteral)