{-# LANGUAGE UndecidableInstances #-}

module Mensam.Server.Application.Email where

import Mensam.Server.Application.Configured.Class
import Mensam.Server.Application.Email.Class
import Mensam.Server.Configuration
import Mensam.Server.Configuration.Email

import Control.Exception
import Control.Monad.Logger.CallStack
import Control.Monad.Trans
import Control.Monad.Trans.Compose
import Control.Monad.Trans.Control
import Control.Monad.Trans.Control.Identity
import Control.Monad.Trans.Reader
import Data.Kind
import Data.Text qualified as T
import Data.Text.Lazy qualified as TL
import Network.Mail.Mime
import Network.Mail.SMTP
import Text.Email.Text

type EmailT :: (Type -> Type) -> Type -> Type
newtype EmailT m a = MkEmailT {forall (m :: * -> *) a.
EmailT m a -> ReaderT (Maybe EmailConfig) m a
unEmailT :: ReaderT (Maybe EmailConfig) m a}
  deriving newtype (Functor (EmailT m)
Functor (EmailT m) =>
(forall a. a -> EmailT m a)
-> (forall a b. EmailT m (a -> b) -> EmailT m a -> EmailT m b)
-> (forall a b c.
    (a -> b -> c) -> EmailT m a -> EmailT m b -> EmailT m c)
-> (forall a b. EmailT m a -> EmailT m b -> EmailT m b)
-> (forall a b. EmailT m a -> EmailT m b -> EmailT m a)
-> Applicative (EmailT m)
forall a. a -> EmailT m a
forall a b. EmailT m a -> EmailT m b -> EmailT m a
forall a b. EmailT m a -> EmailT m b -> EmailT m b
forall a b. EmailT m (a -> b) -> EmailT m a -> EmailT m b
forall a b c.
(a -> b -> c) -> EmailT m a -> EmailT m b -> EmailT m c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
forall (m :: * -> *). Applicative m => Functor (EmailT m)
forall (m :: * -> *) a. Applicative m => a -> EmailT m a
forall (m :: * -> *) a b.
Applicative m =>
EmailT m a -> EmailT m b -> EmailT m a
forall (m :: * -> *) a b.
Applicative m =>
EmailT m a -> EmailT m b -> EmailT m b
forall (m :: * -> *) a b.
Applicative m =>
EmailT m (a -> b) -> EmailT m a -> EmailT m b
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> c) -> EmailT m a -> EmailT m b -> EmailT m c
$cpure :: forall (m :: * -> *) a. Applicative m => a -> EmailT m a
pure :: forall a. a -> EmailT m a
$c<*> :: forall (m :: * -> *) a b.
Applicative m =>
EmailT m (a -> b) -> EmailT m a -> EmailT m b
<*> :: forall a b. EmailT m (a -> b) -> EmailT m a -> EmailT m b
$cliftA2 :: forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> c) -> EmailT m a -> EmailT m b -> EmailT m c
liftA2 :: forall a b c.
(a -> b -> c) -> EmailT m a -> EmailT m b -> EmailT m c
$c*> :: forall (m :: * -> *) a b.
Applicative m =>
EmailT m a -> EmailT m b -> EmailT m b
*> :: forall a b. EmailT m a -> EmailT m b -> EmailT m b
$c<* :: forall (m :: * -> *) a b.
Applicative m =>
EmailT m a -> EmailT m b -> EmailT m a
<* :: forall a b. EmailT m a -> EmailT m b -> EmailT m a
Applicative, (forall a b. (a -> b) -> EmailT m a -> EmailT m b)
-> (forall a b. a -> EmailT m b -> EmailT m a)
-> Functor (EmailT m)
forall a b. a -> EmailT m b -> EmailT m a
forall a b. (a -> b) -> EmailT m a -> EmailT m b
forall (m :: * -> *) a b.
Functor m =>
a -> EmailT m b -> EmailT m a
forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> EmailT m a -> EmailT m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> EmailT m a -> EmailT m b
fmap :: forall a b. (a -> b) -> EmailT m a -> EmailT m b
$c<$ :: forall (m :: * -> *) a b.
Functor m =>
a -> EmailT m b -> EmailT m a
<$ :: forall a b. a -> EmailT m b -> EmailT m a
Functor, Applicative (EmailT m)
Applicative (EmailT m) =>
(forall a b. EmailT m a -> (a -> EmailT m b) -> EmailT m b)
-> (forall a b. EmailT m a -> EmailT m b -> EmailT m b)
-> (forall a. a -> EmailT m a)
-> Monad (EmailT m)
forall a. a -> EmailT m a
forall a b. EmailT m a -> EmailT m b -> EmailT m b
forall a b. EmailT m a -> (a -> EmailT m b) -> EmailT m b
forall (m :: * -> *). Monad m => Applicative (EmailT m)
forall (m :: * -> *) a. Monad m => a -> EmailT m a
forall (m :: * -> *) a b.
Monad m =>
EmailT m a -> EmailT m b -> EmailT m b
forall (m :: * -> *) a b.
Monad m =>
EmailT m a -> (a -> EmailT m b) -> EmailT m b
forall (m :: * -> *).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
$c>>= :: forall (m :: * -> *) a b.
Monad m =>
EmailT m a -> (a -> EmailT m b) -> EmailT m b
>>= :: forall a b. EmailT m a -> (a -> EmailT m b) -> EmailT m b
$c>> :: forall (m :: * -> *) a b.
Monad m =>
EmailT m a -> EmailT m b -> EmailT m b
>> :: forall a b. EmailT m a -> EmailT m b -> EmailT m b
$creturn :: forall (m :: * -> *) a. Monad m => a -> EmailT m a
return :: forall a. a -> EmailT m a
Monad)
  deriving newtype ((forall (m :: * -> *). Monad m => Monad (EmailT m)) =>
(forall (m :: * -> *) a. Monad m => m a -> EmailT m a)
-> MonadTrans EmailT
forall (m :: * -> *). Monad m => Monad (EmailT m)
forall (m :: * -> *) a. Monad m => m a -> EmailT m a
forall (t :: (* -> *) -> * -> *).
(forall (m :: * -> *). Monad m => Monad (t m)) =>
(forall (m :: * -> *) a. Monad m => m a -> t m a) -> MonadTrans t
$clift :: forall (m :: * -> *) a. Monad m => m a -> EmailT m a
lift :: forall (m :: * -> *) a. Monad m => m a -> EmailT m a
MonadTrans, MonadTrans EmailT
MonadTrans EmailT =>
(forall (m :: * -> *) a.
 Monad m =>
 (Run EmailT -> m a) -> EmailT m a)
-> (forall (m :: * -> *) a.
    Monad m =>
    m (StT EmailT a) -> EmailT m a)
-> MonadTransControl EmailT
forall (m :: * -> *) a. Monad m => m (StT EmailT a) -> EmailT m a
forall (m :: * -> *) a.
Monad m =>
(Run EmailT -> m a) -> EmailT m a
forall (t :: (* -> *) -> * -> *).
MonadTrans t =>
(forall (m :: * -> *) a. Monad m => (Run t -> m a) -> t m a)
-> (forall (m :: * -> *) a. Monad m => m (StT t a) -> t m a)
-> MonadTransControl t
$cliftWith :: forall (m :: * -> *) a.
Monad m =>
(Run EmailT -> m a) -> EmailT m a
liftWith :: forall (m :: * -> *) a.
Monad m =>
(Run EmailT -> m a) -> EmailT m a
$crestoreT :: forall (m :: * -> *) a. Monad m => m (StT EmailT a) -> EmailT m a
restoreT :: forall (m :: * -> *) a. Monad m => m (StT EmailT a) -> EmailT m a
MonadTransControl, MonadTransControl EmailT
MonadTransControl EmailT =>
(forall (m :: * -> *) a.
 Monad m =>
 ((forall x. EmailT m x -> m x) -> m a) -> EmailT m a)
-> MonadTransControlIdentity EmailT
forall (m :: * -> *) a.
Monad m =>
((forall x. EmailT m x -> m x) -> m a) -> EmailT m a
forall (t :: (* -> *) -> * -> *).
MonadTransControl t =>
(forall (m :: * -> *) a.
 Monad m =>
 ((forall x. t m x -> m x) -> m a) -> t m a)
-> MonadTransControlIdentity t
$cliftWithIdentity :: forall (m :: * -> *) a.
Monad m =>
((forall x. EmailT m x -> m x) -> m a) -> EmailT m a
liftWithIdentity :: forall (m :: * -> *) a.
Monad m =>
((forall x. EmailT m x -> m x) -> m a) -> EmailT m a
MonadTransControlIdentity)

instance (MonadIO m, MonadLogger m) => MonadEmail (EmailT m) where
  sendEmail :: Email -> EmailT m SendEmailResult
sendEmail Email
email = do
    Maybe EmailConfig
maybeEmailConfig <- ReaderT (Maybe EmailConfig) m (Maybe EmailConfig)
-> EmailT m (Maybe EmailConfig)
forall (m :: * -> *) a.
ReaderT (Maybe EmailConfig) m a -> EmailT m a
MkEmailT ReaderT (Maybe EmailConfig) m (Maybe EmailConfig)
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
    m () -> EmailT m ()
forall (m :: * -> *) a. Monad m => m a -> EmailT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> EmailT m ()) -> m () -> EmailT m ()
forall a b. (a -> b) -> a -> b
$ Text -> m ()
forall (m :: * -> *). (HasCallStack, MonadLogger m) => Text -> m ()
logDebug (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"Sending email: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (Email -> String
forall a. Show a => a -> String
show Email
email)
    let
      mimeMailFromEmailConfig :: EmailConfig -> Mail
      mimeMailFromEmailConfig :: EmailConfig -> Mail
mimeMailFromEmailConfig MkEmailConfig {String
emailUsername :: String
emailUsername :: EmailConfig -> String
emailUsername} =
        Mail
          { mailFrom :: Address
mailFrom =
              Address
                { addressName :: Maybe Text
addressName = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"Mensam"
                , addressEmail :: Text
addressEmail = String -> Text
T.pack String
emailUsername
                }
          , mailTo :: [Address]
mailTo =
              [ Address
                  { addressName :: Maybe Text
addressName = Maybe Text
forall a. Maybe a
Nothing
                  , addressEmail :: Text
addressEmail = EmailAddress -> Text
toText (EmailAddress -> Text) -> EmailAddress -> Text
forall a b. (a -> b) -> a -> b
$ Email -> EmailAddress
emailRecipient Email
email
                  }
              ]
          , mailCc :: [Address]
mailCc = []
          , mailBcc :: [Address]
mailBcc = []
          , mailHeaders :: Headers
mailHeaders = [(ByteString
"Subject", Email -> Text
emailTitle Email
email)]
          , mailParts :: [Alternatives]
mailParts = [[Text -> Part
Network.Mail.Mime.htmlPart (Text -> Part) -> Text -> Part
forall a b. (a -> b) -> a -> b
$ Text -> Text
TL.fromStrict (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Email -> Text
emailBodyHtml Email
email]]
          }
    case Maybe EmailConfig
maybeEmailConfig of
      Maybe EmailConfig
Nothing -> do
        m () -> EmailT m ()
forall (m :: * -> *) a. Monad m => m a -> EmailT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> EmailT m ()) -> m () -> EmailT m ()
forall a b. (a -> b) -> a -> b
$ Text -> m ()
forall (m :: * -> *). (HasCallStack, MonadLogger m) => Text -> m ()
logWarn Text
"A requested email was not sent."
        let
          placeholderEmailConfig :: EmailConfig
placeholderEmailConfig =
            MkEmailConfig
              { emailHostname :: String
emailHostname = String
forall a. HasCallStack => a
undefined
              , emailPort :: Word16
emailPort = Word16
forall a. HasCallStack => a
undefined
              , emailUsername :: String
emailUsername = String
"nousernamegiven@example.com"
              , emailPassword :: String
emailPassword = String
forall a. HasCallStack => a
undefined
              , emailTls :: Bool
emailTls = Bool
forall a. HasCallStack => a
undefined
              }
          mimeMail :: Mail
mimeMail = EmailConfig -> Mail
mimeMailFromEmailConfig EmailConfig
placeholderEmailConfig
        ByteString
renderedMail <- m ByteString -> EmailT m ByteString
forall (m :: * -> *) a. Monad m => m a -> EmailT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m ByteString -> EmailT m ByteString)
-> m ByteString -> EmailT m ByteString
forall a b. (a -> b) -> a -> b
$ IO ByteString -> m ByteString
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteString -> m ByteString) -> IO ByteString -> m ByteString
forall a b. (a -> b) -> a -> b
$ Mail -> IO ByteString
renderMail' Mail
mimeMail
        m () -> EmailT m ()
forall (m :: * -> *) a. Monad m => m a -> EmailT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> EmailT m ()) -> m () -> EmailT m ()
forall a b. (a -> b) -> a -> b
$ Text -> m ()
forall (m :: * -> *). (HasCallStack, MonadLogger m) => Text -> m ()
logDebug (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"Tried to send email: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (ByteString -> String
forall a. Show a => a -> String
show ByteString
renderedMail)
        SendEmailResult -> EmailT m SendEmailResult
forall a. a -> EmailT m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SendEmailResult
EmailFailedToSend
      Just EmailConfig
emailConfig -> do
        let
          port :: PortNumber
port = Int -> PortNumber
forall a. Enum a => Int -> a
toEnum (Int -> PortNumber) -> Int -> PortNumber
forall a b. (a -> b) -> a -> b
$ Word16 -> Int
forall a. Enum a => a -> Int
fromEnum (Word16 -> Int) -> Word16 -> Int
forall a b. (a -> b) -> a -> b
$ EmailConfig -> Word16
emailPort EmailConfig
emailConfig
          mimeMail :: Mail
mimeMail = EmailConfig -> Mail
mimeMailFromEmailConfig EmailConfig
emailConfig
        Either SomeException ()
sendMailResult <-
          m (Either SomeException ()) -> EmailT m (Either SomeException ())
forall (m :: * -> *) a. Monad m => m a -> EmailT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (Either SomeException ()) -> EmailT m (Either SomeException ()))
-> (IO () -> m (Either SomeException ()))
-> IO ()
-> EmailT m (Either SomeException ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO (Either SomeException ()) -> m (Either SomeException ())
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either SomeException ()) -> m (Either SomeException ()))
-> (IO () -> IO (Either SomeException ()))
-> IO ()
-> m (Either SomeException ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO () -> IO (Either SomeException ())
forall e a. Exception e => IO a -> IO (Either e a)
try (IO () -> EmailT m (Either SomeException ()))
-> IO () -> EmailT m (Either SomeException ())
forall a b. (a -> b) -> a -> b
$
            if EmailConfig -> Bool
emailTls EmailConfig
emailConfig
              then String -> PortNumber -> String -> String -> Mail -> IO ()
sendMailWithLoginTLS' (EmailConfig -> String
emailHostname EmailConfig
emailConfig) PortNumber
port (EmailConfig -> String
emailUsername EmailConfig
emailConfig) (EmailConfig -> String
emailPassword EmailConfig
emailConfig) Mail
mimeMail
              else String -> PortNumber -> String -> String -> Mail -> IO ()
sendMailWithLogin' (EmailConfig -> String
emailHostname EmailConfig
emailConfig) PortNumber
port (EmailConfig -> String
emailUsername EmailConfig
emailConfig) (EmailConfig -> String
emailPassword EmailConfig
emailConfig) Mail
mimeMail
        case Either SomeException ()
sendMailResult of
          Left (SomeException
err :: SomeException) -> do
            m () -> EmailT m ()
forall (m :: * -> *) a. Monad m => m a -> EmailT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> EmailT m ()) -> m () -> EmailT m ()
forall a b. (a -> b) -> a -> b
$ Text -> m ()
forall (m :: * -> *). (HasCallStack, MonadLogger m) => Text -> m ()
logWarn (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"Failed to actually send an email: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (SomeException -> String
forall a. Show a => a -> String
show SomeException
err)
            SendEmailResult -> EmailT m SendEmailResult
forall a. a -> EmailT m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SendEmailResult
EmailFailedToSend
          Right () -> do
            m () -> EmailT m ()
forall (m :: * -> *) a. Monad m => m a -> EmailT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> EmailT m ()) -> m () -> EmailT m ()
forall a b. (a -> b) -> a -> b
$ Text -> m ()
forall (m :: * -> *). (HasCallStack, MonadLogger m) => Text -> m ()
logInfo Text
"Sent an email."
            SendEmailResult -> EmailT m SendEmailResult
forall a. a -> EmailT m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SendEmailResult
EmailSent

deriving via
  EmailT ((t2 :: (Type -> Type) -> Type -> Type) m)
  instance
    (MonadIO (t2 m), MonadLogger (t2 m)) => MonadEmail (ComposeT EmailT t2 m)

runEmailT :: Maybe EmailConfig -> EmailT m a -> m a
runEmailT :: forall (m :: * -> *) a. Maybe EmailConfig -> EmailT m a -> m a
runEmailT Maybe EmailConfig
config EmailT m a
tma = ReaderT (Maybe EmailConfig) m a -> Maybe EmailConfig -> m a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (EmailT m a -> ReaderT (Maybe EmailConfig) m a
forall (m :: * -> *) a.
EmailT m a -> ReaderT (Maybe EmailConfig) m a
unEmailT EmailT m a
tma) Maybe EmailConfig
config

runAppEmailT :: MonadConfigured m => EmailT m a -> m a
runAppEmailT :: forall (m :: * -> *) a. MonadConfigured m => EmailT m a -> m a
runAppEmailT EmailT m a
tma = do
  Maybe EmailConfig
config <- Configuration -> Maybe EmailConfig
configEmailConfig (Configuration -> Maybe EmailConfig)
-> m Configuration -> m (Maybe EmailConfig)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m Configuration
forall (m :: * -> *). MonadConfigured m => m Configuration
configuration
  Maybe EmailConfig -> EmailT m a -> m a
forall (m :: * -> *) a. Maybe EmailConfig -> EmailT m a -> m a
runEmailT Maybe EmailConfig
config EmailT m a
tma