{-|
Module: IHP.Mail
Description: Send Emails
Copyright: (c) digitally induced GmbH, 2020
-}
module IHP.Mail
( MailServer (..)
, BuildMail (..)
, SMTPEncryption ( ..)
, sendMail
, sendWithMailServer
)
where

import IHP.Prelude
import IHP.Mail.Types
import IHP.FrameworkConfig

import           Network.Mail.Mime
import qualified Network.Mail.Mime.SES                as Mailer
import qualified Network.Mail.SMTP                    as SMTP
import qualified Network.HTTP.Client
import qualified Network.HTTP.Client.TLS
import Text.Blaze.Html5 (Html)
import qualified Text.Blaze.Html.Renderer.Text as Blaze
import qualified Data.Text as Text
import Data.Maybe

buildMail :: (BuildMail mail, ?context :: context, ConfigProvider context) => mail -> Mail
buildMail :: forall mail context.
(BuildMail mail, ?context::context, ConfigProvider context) =>
mail -> Mail
buildMail mail
mail =
    let ?mail = mail
?mail::mail
mail in
    let mail' :: Mail
mail' = Address
-> Address
-> Text
-> Text
-> Text
-> [(Text, Text, ByteString)]
-> Mail
simpleMailInMemory (mail -> Address
forall context.
(?context::context, ConfigProvider context) =>
mail -> Address
forall mail context.
(BuildMail mail, ?context::context, ConfigProvider context) =>
mail -> Address
to mail
mail) Address
forall context.
(?mail::mail, ?context::context, ConfigProvider context) =>
Address
forall mail context.
(BuildMail mail, ?mail::mail, ?context::context,
 ConfigProvider context) =>
Address
from Text
forall mail. (BuildMail mail, ?mail::mail) => Text
subject (Text -> Text
forall a b. ConvertibleStrings a b => a -> b
cs (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ mail -> Text
forall context.
(?context::context, ConfigProvider context) =>
mail -> Text
forall mail context.
(BuildMail mail, ?context::context, ConfigProvider context) =>
mail -> Text
text mail
mail) (mail -> Html
forall context.
(?context::context, ConfigProvider context) =>
mail -> Html
forall mail context.
(BuildMail mail, ?context::context, ConfigProvider context) =>
mail -> Html
html mail
mail Html -> (Html -> Text) -> Text
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> Html -> Text
Blaze.renderHtml) [(Text, Text, ByteString)]
attachments' in
    Mail
mail' { mailCc      = cc mail
          , mailBcc     = bcc mail
          , mailHeaders = ("Subject", subject) : h
          }
    where
        h :: [(ByteString, Text)]
h = case mail -> Maybe Address
forall context.
(?context::context, ConfigProvider context) =>
mail -> Maybe Address
forall mail context.
(BuildMail mail, ?context::context, ConfigProvider context) =>
mail -> Maybe Address
replyTo mail
mail of
            Maybe Address
Nothing      -> mail -> [(ByteString, Text)]
forall context.
(?context::context, ConfigProvider context) =>
mail -> [(ByteString, Text)]
forall mail context.
(BuildMail mail, ?context::context, ConfigProvider context) =>
mail -> [(ByteString, Text)]
headers mail
mail
            Just Address
replyTo -> (ByteString
"Reply-To", Address -> Text
renderAddress Address
replyTo) (ByteString, Text) -> [(ByteString, Text)] -> [(ByteString, Text)]
forall a. a -> [a] -> [a]
: (mail -> [(ByteString, Text)]
forall context.
(?context::context, ConfigProvider context) =>
mail -> [(ByteString, Text)]
forall mail context.
(BuildMail mail, ?context::context, ConfigProvider context) =>
mail -> [(ByteString, Text)]
headers mail
mail)

        attachments' :: [(Text, Text, ByteString)]
attachments' = mail
mail
                mail -> (mail -> [MailAttachment]) -> [MailAttachment]
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> mail -> [MailAttachment]
forall context.
(?context::context, ConfigProvider context) =>
mail -> [MailAttachment]
forall mail context.
(BuildMail mail, ?context::context, ConfigProvider context) =>
mail -> [MailAttachment]
attachments
                [MailAttachment]
-> ([MailAttachment] -> [(Text, Text, ByteString)])
-> [(Text, Text, ByteString)]
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> (MailAttachment -> (Text, Text, ByteString))
-> [MailAttachment] -> [(Text, Text, ByteString)]
forall a b. (a -> b) -> [a] -> [b]
map (\MailAttachment { Text
name :: Text
name :: MailAttachment -> Text
name, ByteString
content :: ByteString
content :: MailAttachment -> ByteString
content, Text
contentType :: Text
contentType :: MailAttachment -> Text
contentType } -> (Text
contentType, Text
name, ByteString
content))

-- | Sends an email
--
-- Uses the mail server provided in the controller context, configured in Config/Config.hs
sendMail :: (BuildMail mail, ?context :: context, ConfigProvider context) => mail -> IO ()
sendMail :: forall mail context.
(BuildMail mail, ?context::context, ConfigProvider context) =>
mail -> IO ()
sendMail mail
mail = MailServer -> Mail -> IO ()
sendWithMailServer context
?context::context
?context.frameworkConfig.mailServer (mail -> Mail
forall mail context.
(BuildMail mail, ?context::context, ConfigProvider context) =>
mail -> Mail
buildMail mail
mail)

sendWithMailServer :: MailServer -> Mail -> IO ()
sendWithMailServer :: MailServer -> Mail -> IO ()
sendWithMailServer SES { ByteString
Text
accessKey :: ByteString
secretKey :: ByteString
region :: Text
region :: MailServer -> Text
secretKey :: MailServer -> ByteString
accessKey :: MailServer -> ByteString
.. } Mail
mail = do
    Manager
manager <- ManagerSettings -> IO Manager
Network.HTTP.Client.newManager ManagerSettings
Network.HTTP.Client.TLS.tlsManagerSettings
    let ses :: SES
ses = Mailer.SES {
            sesFrom :: ByteString
Mailer.sesFrom = Text -> ByteString
forall a b. ConvertibleStrings a b => a -> b
cs (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ Address -> Text
addressEmail (Mail -> Address
mailFrom Mail
mail),
            sesTo :: [ByteString]
Mailer.sesTo = (Address -> ByteString) -> [Address] -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
map (Text -> ByteString
forall a b. ConvertibleStrings a b => a -> b
cs (Text -> ByteString) -> (Address -> Text) -> Address -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Address -> Text
addressEmail) (Mail -> [Address]
mailTo Mail
mail),
            sesAccessKey :: ByteString
Mailer.sesAccessKey = ByteString
accessKey,
            sesSecretKey :: ByteString
Mailer.sesSecretKey = ByteString
secretKey,
            sesSessionToken :: Maybe ByteString
Mailer.sesSessionToken = Maybe ByteString
forall a. Maybe a
Nothing,
            sesRegion :: Text
Mailer.sesRegion = Text
region
        }
    Manager -> SES -> Mail -> IO ()
forall (m :: * -> *). MonadIO m => Manager -> SES -> Mail -> m ()
Mailer.renderSendMailSES Manager
manager SES
ses Mail
mail

sendWithMailServer SendGrid { Maybe Text
Text
apiKey :: Text
category :: Maybe Text
category :: MailServer -> Maybe Text
apiKey :: MailServer -> Text
.. } Mail
mail = do
    let mail' :: Mail
mail' = if Maybe Text -> Bool
forall a. Maybe a -> Bool
isJust Maybe Text
category then Mail
mail {mailHeaders = ("X-SMTPAPI","{\"category\": \"" ++ (fromJust category) ++ "\"}") : headers} else Mail
mail
    HostName -> PortNumber -> HostName -> HostName -> Mail -> IO ()
SMTP.sendMailWithLoginSTARTTLS' HostName
"smtp.sendgrid.net" PortNumber
587 HostName
"apikey" (Text -> HostName
Text.unpack Text
apiKey) Mail
mail'
    where headers :: [(ByteString, Text)]
headers = Mail -> [(ByteString, Text)]
mailHeaders Mail
mail

sendWithMailServer IHP.Mail.Types.SMTP { HostName
Maybe (HostName, HostName)
PortNumber
SMTPEncryption
host :: HostName
port :: PortNumber
credentials :: Maybe (HostName, HostName)
encryption :: SMTPEncryption
encryption :: MailServer -> SMTPEncryption
credentials :: MailServer -> Maybe (HostName, HostName)
port :: MailServer -> PortNumber
host :: MailServer -> HostName
.. } Mail
mail
    | Maybe (HostName, HostName) -> Bool
forall a. Maybe a -> Bool
isNothing Maybe (HostName, HostName)
credentials =
          case SMTPEncryption
encryption of
              SMTPEncryption
Unencrypted -> HostName -> PortNumber -> Mail -> IO ()
SMTP.sendMail' HostName
host PortNumber
port Mail
mail
              SMTPEncryption
TLS -> HostName -> PortNumber -> Mail -> IO ()
SMTP.sendMailTLS' HostName
host PortNumber
port Mail
mail
              SMTPEncryption
STARTTLS -> HostName -> PortNumber -> Mail -> IO ()
SMTP.sendMailSTARTTLS' HostName
host PortNumber
port Mail
mail
    | Bool
otherwise =
          case SMTPEncryption
encryption of
              SMTPEncryption
Unencrypted -> HostName -> PortNumber -> HostName -> HostName -> Mail -> IO ()
SMTP.sendMailWithLogin' HostName
host PortNumber
port ((HostName, HostName) -> HostName
forall a b. (a, b) -> a
fst (HostName, HostName)
creds) ((HostName, HostName) -> HostName
forall a b. (a, b) -> b
snd (HostName, HostName)
creds) Mail
mail
              SMTPEncryption
TLS -> HostName -> PortNumber -> HostName -> HostName -> Mail -> IO ()
SMTP.sendMailWithLoginTLS' HostName
host PortNumber
port ((HostName, HostName) -> HostName
forall a b. (a, b) -> a
fst (HostName, HostName)
creds) ((HostName, HostName) -> HostName
forall a b. (a, b) -> b
snd (HostName, HostName)
creds) Mail
mail
              SMTPEncryption
STARTTLS -> HostName -> PortNumber -> HostName -> HostName -> Mail -> IO ()
SMTP.sendMailWithLoginSTARTTLS' HostName
host PortNumber
port ((HostName, HostName) -> HostName
forall a b. (a, b) -> a
fst (HostName, HostName)
creds) ((HostName, HostName) -> HostName
forall a b. (a, b) -> b
snd (HostName, HostName)
creds) Mail
mail
    where creds :: (HostName, HostName)
creds = Maybe (HostName, HostName) -> (HostName, HostName)
forall a. HasCallStack => Maybe a -> a
fromJust Maybe (HostName, HostName)
credentials

sendWithMailServer MailServer
Sendmail Mail
mail = do
    ByteString
message <- Mail -> IO ByteString
renderMail' Mail
mail
    ByteString -> IO ()
sendmail ByteString
message

class BuildMail mail where
    -- | You can use @?mail@ to make this dynamic based on the given entity
    subject :: (?mail :: mail) => Text

    -- | The email receiver
    --
    -- __Example:__
    --
    -- > to ConfirmationMail { .. } = Address { addressName = Just (user.name), addressEmail = user.email }
    --
    -- __Example:__ Send all emails to a fixed email address while in development mode
    --
    -- > to CreateAccountMail { .. } = Address
    -- >     { addressName = Just (fullName admin)
    -- >     , addressEmail =
    -- >         if isDevelopment then
    -- >             "staging@example.com"
    -- >         else
    -- >             admin.email
    -- >     }
    --
    to :: (?context :: context, ConfigProvider context) => mail -> Address

    -- | Sets an optional reply-to address
    replyTo :: (?context :: context, ConfigProvider context) => mail -> Maybe Address
    replyTo mail
mail = Maybe Address
forall a. Maybe a
Nothing

    -- | Public list of addresses to receive a copy of the mail (CC)
    cc :: (?context :: context, ConfigProvider context) => mail -> [Address]
    cc mail
mail = []

    -- | Hidden list of addresses to receive a copy of the mail (BCC)
    bcc :: (?context :: context, ConfigProvider context) => mail -> [Address]
    bcc mail
mail = []

    -- | Custom headers, excluding @from@, @to@, @cc@, @bcc@, @subject@, and @reply-to@
    --
    -- __Example:__ Add a custom X-Mailer header
    --
    -- > headers CreateAccountMail { .. } = [("X-Mailer", "mail4j 2.17.0")]
    --
    headers :: (?context :: context, ConfigProvider context) => mail -> Headers
    headers mail
mail = []

    -- | Your sender address
    --
    -- __Example:__
    --
    -- > from = Address { addressName = "Acme Inc.", addressEmail = "hi@example.com" }
    --
    from :: (?mail :: mail, ?context :: context, ConfigProvider context) => Address

    -- | Similiar to a normal html view, HSX can be used here
    html :: (?context :: context, ConfigProvider context) => mail -> Html

    -- | When no plain text version of the email is specified it falls back to using the html version but striping out all the html tags
    text :: (?context :: context, ConfigProvider context) => mail -> Text
    text mail
mail = Text -> Text
stripTags (Text -> Text
forall a b. ConvertibleStrings a b => a -> b
cs (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Html -> Text
Blaze.renderHtml (mail -> Html
forall context.
(?context::context, ConfigProvider context) =>
mail -> Html
forall mail context.
(BuildMail mail, ?context::context, ConfigProvider context) =>
mail -> Html
html mail
mail))

    -- | Optional, mail attachments
    --
    -- __Example:__
    --
    -- > attachments = [ MailAttachment { name = "attached_file.xml", contentType = "application/xml", content = "<xml><hello/></xml>" } ]
    --
    attachments :: (?context :: context, ConfigProvider context) => mail -> [MailAttachment]
    attachments mail
mail = []