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