-- This file is part of purebred-email
-- Copyright (C) 2018-2021  Róman Joost and Fraser Tweedale
--
-- purebred-email is free software: you can redistribute it and/or modify
-- it under the terms of the GNU Affero General Public License as published by
-- the Free Software Foundation, either version 3 of the License, or
-- (at your option) any later version.
--
-- This program is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-- GNU Affero General Public License for more details.
--
-- You should have received a copy of the GNU Affero General Public License
-- along with this program.  If not, see <http://www.gnu.org/licenses/>.

{-# LANGUAGE OverloadedStrings #-}
{- |

@Text@ parsers and printers for mailbox and address types.

-}
module Data.IMF.Text
  (
    mailbox
  , mailboxList
  , readMailbox
  , address
  , addressList
  -- * Pretty printing
  , 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

-- | Printing function to "pretty print" the mailbox for display purposes
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


-- §3.4 Address Specification
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

-- | Parse a (whole) string, returning an error @String@ or a 'Mailbox'.
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

-- | Version of 'phrase' that does not process encoded-word
-- (we are parsing Text so will assume that the input does not
-- contain encoded words.  TODO this is probably wrong :)
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)