-- 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 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

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


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

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

-- | 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
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)