{-|
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 :: mail -> Mail
buildMail mail
mail =
    let ?mail = mail in
    let mail' :: Mail
mail' = Address
-> Address
-> Text
-> Text
-> Text
-> [(Text, Text, ByteString)]
-> Mail
simpleMailInMemory (mail -> Address
forall mail context.
(BuildMail mail, ?context::context, ConfigProvider context) =>
mail -> Address
to mail
mail) 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 mail context.
(BuildMail mail, ?context::context, ConfigProvider context) =>
mail -> Text
text mail
mail) (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 :: [Address]
mailCc      = mail -> [Address]
forall mail context.
(BuildMail mail, ?context::context, ConfigProvider context) =>
mail -> [Address]
cc mail
mail
          , mailBcc :: [Address]
mailBcc     = mail -> [Address]
forall mail context.
(BuildMail mail, ?context::context, ConfigProvider context) =>
mail -> [Address]
bcc mail
mail
          , mailHeaders :: Headers
mailHeaders = (ByteString
"Subject", Text
forall mail. (BuildMail mail, ?mail::mail) => Text
subject) (ByteString, Text) -> Headers -> Headers
forall a. a -> [a] -> [a]
: Headers
h
          }
    where
        h :: Headers
h = case mail -> Maybe Address
forall mail context.
(BuildMail mail, ?context::context, ConfigProvider context) =>
mail -> Maybe Address
replyTo mail
mail of
            Maybe Address
Nothing      -> mail -> Headers
forall mail context.
(BuildMail mail, ?context::context, ConfigProvider context) =>
mail -> Headers
headers mail
mail
            Just Address
replyTo -> (ByteString
"Reply-To", Address -> Text
renderAddress Address
replyTo) (ByteString, Text) -> Headers -> Headers
forall a. a -> [a] -> [a]
: (mail -> Headers
forall mail context.
(BuildMail mail, ?context::context, ConfigProvider context) =>
mail -> Headers
headers mail
mail)

        attachments' :: [(Text, Text, ByteString)]
attachments' = mail
mail
                mail -> (mail -> [MailAttachment]) -> [MailAttachment]
forall t1 t2. t1 -> (t1 -> t2) -> t2
|> 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
$sel:name:MailAttachment :: MailAttachment -> Text
name :: Text
name, ByteString
$sel:content:MailAttachment :: MailAttachment -> ByteString
content :: ByteString
content, Text
$sel:contentType:MailAttachment :: MailAttachment -> Text
contentType :: 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 :: mail -> IO ()
sendMail mail
mail = MailServer -> Mail -> IO ()
sendWithMailServer ((FrameworkConfig -> MailServer) -> MailServer
forall context a.
(?context::context, ConfigProvider context) =>
(FrameworkConfig -> a) -> a
fromConfig FrameworkConfig -> MailServer
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
$sel:region:SES :: MailServer -> Text
$sel:secretKey:SES :: MailServer -> ByteString
$sel:accessKey:SES :: MailServer -> ByteString
region :: Text
secretKey :: ByteString
accessKey :: ByteString
.. } Mail
mail = do
    Manager
manager <- ManagerSettings -> IO Manager
Network.HTTP.Client.newManager ManagerSettings
Network.HTTP.Client.TLS.tlsManagerSettings
    let ses :: SES
ses = SES :: ByteString
-> [ByteString]
-> ByteString
-> ByteString
-> Maybe ByteString
-> Text
-> 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 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
$sel:category:SES :: MailServer -> Maybe Text
$sel:apiKey:SES :: MailServer -> Text
category :: Maybe Text
apiKey :: 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 :: Headers
mailHeaders = (ByteString
"X-SMTPAPI",Text
"{\"category\": \"" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
++ (Maybe Text -> Text
forall a. HasCallStack => Maybe a -> a
fromJust Maybe Text
category) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
++ Text
"\"}") (ByteString, Text) -> Headers -> Headers
forall a. a -> [a] -> [a]
: Headers
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 :: Headers
headers = Mail -> Headers
mailHeaders Mail
mail

sendWithMailServer IHP.Mail.Types.SMTP { HostName
Maybe (HostName, HostName)
PortNumber
SMTPEncryption
$sel:encryption:SES :: MailServer -> SMTPEncryption
$sel:credentials:SES :: MailServer -> Maybe (HostName, HostName)
$sel:port:SES :: MailServer -> PortNumber
$sel:host:SES :: MailServer -> HostName
encryption :: SMTPEncryption
credentials :: Maybe (HostName, HostName)
port :: PortNumber
host :: 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 (get #name user), addressEmail = get #email user }
    --
    -- __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
    -- >             get #email admin
    -- >     }
    --
    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 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 = []