{-# OPTIONS_GHC -fno-warn-orphans #-}

-- |
--
-- Copyright:
--   This file is part of the package addy. It is subject to the license
--   terms in the LICENSE file found in the top-level directory of this
--   distribution and at:
--
--     https://code.devalot.com/open/addy
--
--   No part of this package, including this file, may be copied,
--   modified, propagated, or distributed except according to the terms
--   contained in the LICENSE file.
--
-- License: BSD-2-Clause
--
-- Internal functions to render an 'EmailAddr' to a 'TB.Builder'.
module Addy.Internal.Render
  ( Mode (..),
    render,
    renderToText,
    renderAddrSpec,
    renderDisplayName,
    renderComments,
  )
where

import Addy.Internal.Char
import Addy.Internal.Types
import qualified Data.Text as Text
import qualified Data.Text.Lazy.Builder as TB
import qualified Net.IP as IP
import Text.Show (Show (..), showParen, showString)
import Prelude hiding (show)

-- | Render mode.
--
-- @since 0.1.0.0
data Mode
  = -- | Render the entire email address, including the optional
    -- display name and comments.
    Full
  | -- | Only render the simplest form of the email address.  Only the
    -- 'LocalPart' and 'Domain' are rendered in this mode.
    Short

-- | Render an email address.
--
-- @since 0.1.0.0
render :: Mode -> EmailAddr -> TB.Builder
render :: Mode -> EmailAddr -> Builder
render = \case
  Mode
Short ->
    Mode -> EmailAddr -> Builder
renderAddrSpec Mode
Short
  Mode
Full -> \addr :: EmailAddr
addr@EmailAddr {[Comment]
Maybe DisplayName
Domain
LocalPart
_comments :: EmailAddr -> [Comment]
_domain :: EmailAddr -> Domain
_localPart :: EmailAddr -> LocalPart
_displayName :: EmailAddr -> Maybe DisplayName
_comments :: [Comment]
_domain :: Domain
_localPart :: LocalPart
_displayName :: Maybe DisplayName
..} ->
    case Maybe DisplayName
_displayName of
      Maybe DisplayName
Nothing ->
        Mode -> EmailAddr -> Builder
renderAddrSpec Mode
Full EmailAddr
addr
          Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Mode -> CommentLoc -> [Comment] -> Builder
renderComments Mode
Full CommentLoc
AfterAddress [Comment]
_comments
      Just DisplayName
name ->
        [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat
          [ Mode -> CommentLoc -> [Comment] -> Builder
renderComments Mode
Full CommentLoc
BeforeDisplayName [Comment]
_comments,
            DisplayName -> Builder
renderDisplayName DisplayName
name Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Char -> Builder
TB.singleton Char
' ',
            Mode -> CommentLoc -> [Comment] -> Builder
renderComments Mode
Full CommentLoc
AfterDisplayName [Comment]
_comments,
            Char -> Builder
TB.singleton Char
'<' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Mode -> EmailAddr -> Builder
renderAddrSpec Mode
Full EmailAddr
addr Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Char -> Builder
TB.singleton Char
'>',
            Mode -> CommentLoc -> [Comment] -> Builder
renderComments Mode
Full CommentLoc
AfterAddress [Comment]
_comments
          ]

-- | Render an email address in @addr-spec@ format.
--
-- @since 0.1.0.0
renderAddrSpec :: Mode -> EmailAddr -> TB.Builder
renderAddrSpec :: Mode -> EmailAddr -> Builder
renderAddrSpec Mode
mode EmailAddr {[Comment]
Maybe DisplayName
Domain
LocalPart
_comments :: [Comment]
_domain :: Domain
_localPart :: LocalPart
_displayName :: Maybe DisplayName
_comments :: EmailAddr -> [Comment]
_domain :: EmailAddr -> Domain
_localPart :: EmailAddr -> LocalPart
_displayName :: EmailAddr -> Maybe DisplayName
..} =
  [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat
    [ Mode -> CommentLoc -> [Comment] -> Builder
renderComments Mode
mode CommentLoc
BeforeLocalPart [Comment]
_comments,
      LocalPart -> Builder
lp LocalPart
_localPart Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Char -> Builder
TB.singleton Char
'@' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Domain -> Builder
dn Domain
_domain,
      Mode -> CommentLoc -> [Comment] -> Builder
renderComments Mode
mode CommentLoc
AfterDomain [Comment]
_comments
    ]
  where
    lp :: LocalPart -> TB.Builder
    lp :: LocalPart -> Builder
lp (LP Text
t)
      | Text -> Bool
mustQuoteLocalPart Text
t = Char -> Char -> Text -> Builder
wrap Char
'"' Char
'"' Text
t
      | Bool
otherwise = Text -> Builder
TB.fromText Text
t
    dn :: Domain -> TB.Builder
    dn :: Domain -> Builder
dn = \case
      Domain (DN Text
t) ->
        Text -> Builder
TB.fromText Text
t
      DomainLiteral AddressLiteral
lit ->
        Char -> Char -> Text -> Builder
wrap Char
'[' Char
']' (Text -> Builder) -> Text -> Builder
forall a b. (a -> b) -> a -> b
$ case AddressLiteral
lit of
          IpAddressLiteral IP
ip ->
            if IP -> Bool
IP.isIPv6 IP
ip
              then Text
"IPv6:" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> IP -> Text
IP.encode IP
ip
              else IP -> Text
IP.encode IP
ip
          TaggedAddressLiteral (AT Text
tag) (Lit Text
body) ->
            Text
tag Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
":" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
body
          AddressLiteral (Lit Text
body) ->
            Text
body

-- | Render a display name.
--
-- @since 0.1.0.0
renderDisplayName :: DisplayName -> TB.Builder
renderDisplayName :: DisplayName -> Builder
renderDisplayName (DP Text
t)
  | (Char -> Bool) -> Text -> Bool
Text.all (\Char
c -> Char -> Bool
atext Char
c Bool -> Bool -> Bool
|| Char -> Bool
wsp Char
c) Text
t =
    Text -> Builder
TB.fromText Text
t
  | Bool
otherwise =
    Char -> Char -> Text -> Builder
wrap Char
'"' Char
'"' Text
t

-- | Render comments that have the given 'CommentLoc'.  The comment
-- location is also used to decide where to introduce white space.
--
-- @since 0.1.0.0
renderComments :: Mode -> CommentLoc -> [Comment] -> TB.Builder
renderComments :: Mode -> CommentLoc -> [Comment] -> Builder
renderComments Mode
Short CommentLoc
_ [Comment]
_ = Builder
forall a. Monoid a => a
mempty
renderComments Mode
Full CommentLoc
loc [Comment]
cs =
  case (CommentLoc -> Bool) -> [Comment] -> Maybe Builder
go (CommentLoc -> CommentLoc -> Bool
forall a. Eq a => a -> a -> Bool
== CommentLoc
loc) [Comment]
cs of
    Maybe Builder
Nothing -> Builder
forall a. Monoid a => a
mempty
    Just Builder
tb -> case CommentLoc
loc of
      CommentLoc
BeforeDisplayName -> Char -> Builder
TB.singleton Char
' ' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
tb
      CommentLoc
AfterDisplayName -> Builder
tb Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Char -> Builder
TB.singleton Char
' '
      CommentLoc
BeforeLocalPart -> Builder
tb Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Char -> Builder
TB.singleton Char
' '
      CommentLoc
AfterDomain -> Char -> Builder
TB.singleton Char
' ' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
tb
      CommentLoc
AfterAddress -> Char -> Builder
TB.singleton Char
' ' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
tb
  where
    go :: (CommentLoc -> Bool) -> [Comment] -> Maybe TB.Builder
    go :: (CommentLoc -> Bool) -> [Comment] -> Maybe Builder
go CommentLoc -> Bool
f [Comment]
cs =
      (Comment -> Bool) -> [Comment] -> [Comment]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(Comment CommentLoc
loc (CC Text
t)) -> CommentLoc -> Bool
f CommentLoc
loc Bool -> Bool -> Bool
&& Bool -> Bool
not (Text -> Bool
Text.null Text
t)) [Comment]
cs
        [Comment] -> ([Comment] -> [Text]) -> [Text]
forall a b. a -> (a -> b) -> b
& (Comment -> Text) -> [Comment] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (\(Comment CommentLoc
_ (CC Text
t)) -> Text
t)
        [Text] -> ([Text] -> Text) -> Text
forall a b. a -> (a -> b) -> b
& Text -> [Text] -> Text
Text.intercalate Text
" "
        Text -> (Text -> Maybe Builder) -> Maybe Builder
forall a b. a -> (a -> b) -> b
& \Text
t ->
          if Text -> Bool
Text.null Text
t
            then Maybe Builder
forall a. Maybe a
Nothing
            else Builder -> Maybe Builder
forall a. a -> Maybe a
Just (Builder -> Maybe Builder) -> Builder -> Maybe Builder
forall a b. (a -> b) -> a -> b
$ Char -> Char -> Text -> Builder
wrap Char
'(' Char
')' Text
t

-- | Render the given address as text.
--
-- @since 0.1.0.0
renderToText :: Mode -> EmailAddr -> Text
renderToText :: Mode -> EmailAddr -> Text
renderToText Mode
m =
  Mode -> EmailAddr -> Builder
render Mode
m
    (EmailAddr -> Builder) -> (Builder -> Text) -> EmailAddr -> Text
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> Builder -> Text
TB.toLazyText
    (Builder -> Text) -> (Text -> Text) -> Builder -> Text
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> Text -> Text
forall l s. LazyStrict l s => l -> s
toStrict

-- | Wrap and quote some text.
--
-- @since 0.1.0.0
wrap :: Char -> Char -> Text -> TB.Builder
wrap :: Char -> Char -> Text -> Builder
wrap Char
lh Char
rh Text
t =
  [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat
    [ Char -> Builder
TB.singleton Char
lh,
      (Builder -> Char -> Builder) -> Builder -> Text -> Builder
forall a. (a -> Char -> a) -> a -> Text -> a
Text.foldl' Builder -> Char -> Builder
escape Builder
forall a. Monoid a => a
mempty Text
t,
      Char -> Builder
TB.singleton Char
rh
    ]
  where
    escape :: TB.Builder -> Char -> TB.Builder
    escape :: Builder -> Char -> Builder
escape Builder
tb Char
c
      | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
lh Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
rh Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\\' =
        Builder
tb Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Char -> Builder
TB.singleton Char
'\\' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Char -> Builder
TB.singleton Char
c
      | Bool
otherwise =
        Builder
tb Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Char -> Builder
TB.singleton Char
c

-- | 'True' if the give text, when used as the @local-part@ of an
-- email address must be wrapped in quotation marks.
--
-- @since 0.1.0.0
mustQuoteLocalPart :: Text -> Bool
mustQuoteLocalPart :: Text -> Bool
mustQuoteLocalPart Text
name =
  (Char -> Bool) -> Text -> Bool
Text.any
    ( \Char
c ->
        Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'"'
          Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\\'
          Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
')'
          Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'('
          Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'@'
          Bool -> Bool -> Bool
|| Char -> Bool
wsp Char
c
    )
    Text
name
    Bool -> Bool -> Bool
|| Text -> Text -> Bool
Text.isPrefixOf Text
"." Text
name
    Bool -> Bool -> Bool
|| Text -> Text -> Bool
Text.isSuffixOf Text
"." Text
name
    Bool -> Bool -> Bool
|| Text -> Text -> Bool
Text.isInfixOf Text
".." Text
name
    Bool -> Bool -> Bool
|| Text -> Bool
Text.null Text
name -- Yes, this is totally legit.

-- Orphan instance that renders the email address.
instance Show EmailAddr where
  showsPrec :: Int -> EmailAddr -> ShowS
showsPrec Int
d EmailAddr
addr =
    Bool -> ShowS -> ShowS
showParen (Int
d Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
10) (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$
      String -> ShowS
showString String
"EmailAddr " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Builder -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
d (Mode -> EmailAddr -> Builder
render Mode
Full EmailAddr
addr)