{-# LANGUAGE GADTs #-}
{-# LANGUAGE OverloadedLabels #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE NoFieldSelectors #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

module WikiMusic.Smtp.MailCommandSES () where

import Data.Text qualified as T
import Network.Mail.Mime hiding (simpleMail)
import Network.Mail.SMTP hiding (htmlPart)
import Optics
import Relude
import System.Timeout
import WikiMusic.Free.MailCommand
import WikiMusic.Model.Env
import WikiMusic.Model.Mail
import WikiMusic.Protolude

instance Exec MailCommand where
  execAlgebra :: forall a. MailCommand (IO a) -> IO a
execAlgebra (SendMail Env
env MailSendRequest
req Either MailCommandError MailCommandOutcome -> IO a
next) = Env
-> MailSendRequest
-> IO (Either MailCommandError MailCommandOutcome)
forall (m :: * -> *).
MonadIO m =>
Env
-> MailSendRequest
-> m (Either MailCommandError MailCommandOutcome)
mailSend Env
env MailSendRequest
req IO (Either MailCommandError MailCommandOutcome)
-> (Either MailCommandError MailCommandOutcome -> IO a) -> IO a
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Either MailCommandError MailCommandOutcome -> IO a
next

mailSend :: (MonadIO m) => Env -> MailSendRequest -> m (Either MailCommandError MailCommandOutcome)
mailSend :: forall (m :: * -> *).
MonadIO m =>
Env
-> MailSendRequest
-> m (Either MailCommandError MailCommandOutcome)
mailSend Env
env MailSendRequest
req = do
  Maybe ()
mailSendingResult <- IO (Maybe ()) -> m (Maybe ())
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe ()) -> m (Maybe ())) -> IO (Maybe ()) -> m (Maybe ())
forall a b. (a -> b) -> a -> b
$ Int -> IO () -> IO (Maybe ())
forall a. Int -> IO a -> IO (Maybe a)
timeout Int
timeoutSeconds IO ()
doSendMail
  case Maybe ()
mailSendingResult of
    Maybe ()
Nothing -> Either MailCommandError MailCommandOutcome
-> m (Either MailCommandError MailCommandOutcome)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either MailCommandError MailCommandOutcome
 -> m (Either MailCommandError MailCommandOutcome))
-> (MailCommandError -> Either MailCommandError MailCommandOutcome)
-> MailCommandError
-> m (Either MailCommandError MailCommandOutcome)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MailCommandError -> Either MailCommandError MailCommandOutcome
forall a b. a -> Either a b
Left (MailCommandError
 -> m (Either MailCommandError MailCommandOutcome))
-> MailCommandError
-> m (Either MailCommandError MailCommandOutcome)
forall a b. (a -> b) -> a -> b
$ Text -> MailCommandError
MailError Text
""
    Just ()
_ -> Either MailCommandError MailCommandOutcome
-> m (Either MailCommandError MailCommandOutcome)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either MailCommandError MailCommandOutcome
 -> m (Either MailCommandError MailCommandOutcome))
-> Either MailCommandError MailCommandOutcome
-> m (Either MailCommandError MailCommandOutcome)
forall a b. (a -> b) -> a -> b
$ MailCommandOutcome -> Either MailCommandError MailCommandOutcome
forall a b. b -> Either a b
Right MailCommandOutcome
MailSent
  where
    mailCfg :: MailConfig
mailCfg = Env
env Env -> Optic' A_Lens NoIx Env MailConfig -> MailConfig
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic A_Lens NoIx Env Env AppConfig AppConfig
#cfg Optic A_Lens NoIx Env Env AppConfig AppConfig
-> Optic A_Lens NoIx AppConfig AppConfig MailConfig MailConfig
-> Optic' A_Lens NoIx Env MailConfig
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Optic A_Lens NoIx AppConfig AppConfig MailConfig MailConfig
#mail
    timeoutSeconds :: Int
timeoutSeconds = (MailConfig
mailCfg MailConfig -> Optic' A_Lens NoIx MailConfig Int -> Int
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic' A_Lens NoIx MailConfig Int
#sendTimeoutSeconds) Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1000000
    preparedMail :: Mail
preparedMail =
      Address
-> [Address] -> [Address] -> [Address] -> Text -> [Part] -> Mail
simpleMail
        (Maybe Text -> Text -> Address
Address (Text -> Maybe Text
forall a. a -> Maybe a
Just (MailConfig
mailCfg MailConfig -> Optic' A_Lens NoIx MailConfig Text -> Text
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic' A_Lens NoIx MailConfig Text
#senderName)) (MailConfig
mailCfg MailConfig -> Optic' A_Lens NoIx MailConfig Text -> Text
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic' A_Lens NoIx MailConfig Text
#senderMail))
        [Maybe Text -> Text -> Address
Address (MailSendRequest
req MailSendRequest
-> Optic' A_Lens NoIx MailSendRequest (Maybe Text) -> Maybe Text
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic' A_Lens NoIx MailSendRequest (Maybe Text)
#name) (MailSendRequest
req MailSendRequest -> Optic' A_Lens NoIx MailSendRequest Text -> Text
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic' A_Lens NoIx MailSendRequest Text
#email)] -- to
        [] -- cc
        [] -- bcc
        (MailSendRequest
req MailSendRequest -> Optic' A_Lens NoIx MailSendRequest Text -> Text
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic' A_Lens NoIx MailSendRequest Text
#subject)
        [ Text -> Part
htmlPart (String -> Text
forall a. IsString a => String -> a
fromString (String -> Text) -> (Text -> String) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ MailSendRequest
req MailSendRequest -> Optic' A_Lens NoIx MailSendRequest Text -> Text
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic' A_Lens NoIx MailSendRequest Text
#body)
        ] -- body
    doSendMail :: IO ()
doSendMail =
      String -> String -> String -> Mail -> IO ()
sendMailWithLoginSTARTTLS
        (Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ MailConfig
mailCfg MailConfig -> Optic' A_Lens NoIx MailConfig Text -> Text
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic' A_Lens NoIx MailConfig Text
#host)
        (String -> (Text -> String) -> Maybe Text -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" Text -> String
T.unpack (Maybe Text -> String) -> Maybe Text -> String
forall a b. (a -> b) -> a -> b
$ MailConfig
mailCfg MailConfig
-> Optic' A_Lens NoIx MailConfig (Maybe Text) -> Maybe Text
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic' A_Lens NoIx MailConfig (Maybe Text)
#user)
        (String -> (Text -> String) -> Maybe Text -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" Text -> String
T.unpack (Maybe Text -> String) -> Maybe Text -> String
forall a b. (a -> b) -> a -> b
$ MailConfig
mailCfg MailConfig
-> Optic' A_Lens NoIx MailConfig (Maybe Text) -> Maybe Text
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic' A_Lens NoIx MailConfig (Maybe Text)
#password)
        Mail
preparedMail