module Wire.EmailSending.SES where
import Amazonka (Env)
import Amazonka.Data.Text as AWS
import Amazonka.SES qualified as SES
import Amazonka.SES.Lens qualified as SES
import Amazonka.Types qualified as AWS
import Control.Lens
import Control.Monad.Catch
import Control.Retry
import Data.ByteString.Lazy qualified as BL
import Data.Text qualified as Text
import Imports
import Network.HTTP.Types
import Network.Mail.Mime (Mail, addressEmail, mailFrom, mailTo, renderMail')
import Polysemy
import Polysemy.Input
import Wire.AWS
import Wire.EmailSending
emailViaSESInterpreter ::
(Member (Embed IO) r) =>
Amazonka.Env ->
InterpreterFor EmailSending r
emailViaSESInterpreter :: forall (r :: EffectRow).
Member (Embed IO) r =>
Env -> InterpreterFor EmailSending r
emailViaSESInterpreter Env
env =
(forall (rInitial :: EffectRow) x.
EmailSending (Sem rInitial) x -> Sem r x)
-> Sem (EmailSending : r) a -> Sem r a
forall (e :: (* -> *) -> * -> *) (r :: EffectRow) a.
FirstOrder e "interpret" =>
(forall (rInitial :: EffectRow) x. e (Sem rInitial) x -> Sem r x)
-> Sem (e : r) a -> Sem r a
interpret ((forall (rInitial :: EffectRow) x.
EmailSending (Sem rInitial) x -> Sem r x)
-> Sem (EmailSending : r) a -> Sem r a)
-> (forall (rInitial :: EffectRow) x.
EmailSending (Sem rInitial) x -> Sem r x)
-> Sem (EmailSending : r) a
-> Sem r a
forall a b. (a -> b) -> a -> b
$
Env -> Sem (Input Env : r) x -> Sem r x
forall i (r :: EffectRow) a. i -> Sem (Input i : r) a -> Sem r a
runInputConst Env
env (Sem (Input Env : r) x -> Sem r x)
-> (EmailSending (Sem rInitial) x -> Sem (Input Env : r) x)
-> EmailSending (Sem rInitial) x
-> Sem r x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. \case
SendMail Mail
mail -> Mail -> Sem (Input Env : r) ()
forall (r :: EffectRow).
(Member (Input Env) r, Member (Embed IO) r) =>
Mail -> Sem r ()
sendMailAWSImpl Mail
mail
sendMailAWSImpl ::
( Member (Input Amazonka.Env) r,
Member (Embed IO) r
) =>
Mail ->
Sem r ()
sendMailAWSImpl :: forall (r :: EffectRow).
(Member (Input Env) r, Member (Embed IO) r) =>
Mail -> Sem r ()
sendMailAWSImpl Mail
m = do
ByteString
body <- IO ByteString -> Sem r ByteString
forall a. IO a -> Sem r a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteString -> Sem r ByteString)
-> IO ByteString -> Sem r ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
BL.toStrict (ByteString -> ByteString) -> IO ByteString -> IO ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Mail -> IO ByteString
renderMail' Mail
m
let raw :: SendRawEmail
raw =
RawMessage -> SendRawEmail
SES.newSendRawEmail (ByteString -> RawMessage
SES.newRawMessage ByteString
body)
SendRawEmail -> (SendRawEmail -> SendRawEmail) -> SendRawEmail
forall a b. a -> (a -> b) -> b
& (Maybe [Text] -> Identity (Maybe [Text]))
-> SendRawEmail -> Identity SendRawEmail
Lens' SendRawEmail (Maybe [Text])
SES.sendRawEmail_destinations ((Maybe [Text] -> Identity (Maybe [Text]))
-> SendRawEmail -> Identity SendRawEmail)
-> [Text] -> SendRawEmail -> SendRawEmail
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ (Address -> Text) -> [Address] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Address -> Text
addressEmail (Mail -> [Address]
mailTo Mail
m)
SendRawEmail -> (SendRawEmail -> SendRawEmail) -> SendRawEmail
forall a b. a -> (a -> b) -> b
& (Maybe Text -> Identity (Maybe Text))
-> SendRawEmail -> Identity SendRawEmail
Lens' SendRawEmail (Maybe Text)
SES.sendRawEmail_source ((Maybe Text -> Identity (Maybe Text))
-> SendRawEmail -> Identity SendRawEmail)
-> Text -> SendRawEmail -> SendRawEmail
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ Address -> Text
addressEmail (Mail -> Address
mailFrom Mail
m)
Either Error SendRawEmailResponse
resp <- RetryPolicyM (Sem r)
-> (RetryStatus -> Either Error SendRawEmailResponse -> Sem r Bool)
-> (RetryStatus -> Sem r (Either Error SendRawEmailResponse))
-> Sem r (Either Error SendRawEmailResponse)
forall (m :: * -> *) b.
MonadIO m =>
RetryPolicyM m
-> (RetryStatus -> b -> m Bool) -> (RetryStatus -> m b) -> m b
retrying RetryPolicyM (Sem r)
forall (m :: * -> *). Monad m => RetryPolicyM m
retry5x (\RetryStatus
_ -> Bool -> Sem r Bool
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> Sem r Bool)
-> (Either Error SendRawEmailResponse -> Bool)
-> Either Error SendRawEmailResponse
-> Sem r Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either Error SendRawEmailResponse -> Bool
forall a. Either Error a -> Bool
canRetry) ((RetryStatus -> Sem r (Either Error SendRawEmailResponse))
-> Sem r (Either Error SendRawEmailResponse))
-> (RetryStatus -> Sem r (Either Error SendRawEmailResponse))
-> Sem r (Either Error SendRawEmailResponse)
forall a b. (a -> b) -> a -> b
$ Sem r (Either Error SendRawEmailResponse)
-> RetryStatus -> Sem r (Either Error SendRawEmailResponse)
forall a b. a -> b -> a
const (SendRawEmail -> Sem r (Either Error (AWSResponse SendRawEmail))
forall (r :: EffectRow) req.
(Member (Input Env) r, Member (Embed IO) r, AWSRequest req,
Typeable req, Typeable (AWSResponse req)) =>
req -> Sem r (Either Error (AWSResponse req))
sendCatch SendRawEmail
raw)
Sem r SendRawEmailResponse -> Sem r ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Sem r SendRawEmailResponse -> Sem r ())
-> (IO SendRawEmailResponse -> Sem r SendRawEmailResponse)
-> IO SendRawEmailResponse
-> Sem r ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO SendRawEmailResponse -> Sem r SendRawEmailResponse
forall (m :: * -> *) (r :: EffectRow) a.
Member (Embed m) r =>
m a -> Sem r a
embed (IO SendRawEmailResponse -> Sem r ())
-> IO SendRawEmailResponse -> Sem r ()
forall a b. (a -> b) -> a -> b
$ (Error -> IO SendRawEmailResponse)
-> (SendRawEmailResponse -> IO SendRawEmailResponse)
-> Either Error SendRawEmailResponse
-> IO SendRawEmailResponse
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Error -> IO SendRawEmailResponse
forall {m :: * -> *} {a}. MonadThrow m => Error -> m a
check SendRawEmailResponse -> IO SendRawEmailResponse
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Either Error SendRawEmailResponse
resp
where
check :: Error -> m a
check Error
x = case Error
x of
AWS.ServiceError ServiceError
se
| (ServiceError
se ServiceError -> Getting Status ServiceError Status -> Status
forall s a. s -> Getting a s a -> a
^. Getting Status ServiceError Status
Lens' ServiceError Status
AWS.serviceError_status Status -> Status -> Bool
forall a. Eq a => a -> a -> Bool
== Status
status400)
Bool -> Bool -> Bool
&& (Text
"Invalid domain name" Text -> Text -> Bool
`Text.isPrefixOf` ErrorCode -> Text
forall a. ToText a => a -> Text
AWS.toText (ServiceError
se ServiceError
-> Getting ErrorCode ServiceError ErrorCode -> ErrorCode
forall s a. s -> Getting a s a -> a
^. Getting ErrorCode ServiceError ErrorCode
Lens' ServiceError ErrorCode
AWS.serviceError_code)) ->
EmailSendingAWSError -> m a
forall e a. (HasCallStack, Exception e) => e -> m a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
throwM EmailSendingAWSError
SESInvalidDomain
Error
_ -> EmailSendingAWSError -> m a
forall e a. (HasCallStack, Exception e) => e -> m a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
throwM (Error -> EmailSendingAWSError
forall e. (Show e, AsError e) => e -> EmailSendingAWSError
EmailSendingAWSGeneralError Error
x)
data EmailSendingAWSError where
SESInvalidDomain :: EmailSendingAWSError
EmailSendingAWSGeneralError :: (Show e, AWS.AsError e) => e -> EmailSendingAWSError
deriving instance Show EmailSendingAWSError
deriving instance Typeable EmailSendingAWSError
instance Exception EmailSendingAWSError
retry5x :: (Monad m) => RetryPolicyM m
retry5x :: forall (m :: * -> *). Monad m => RetryPolicyM m
retry5x = Int -> forall (m :: * -> *). Monad m => RetryPolicyM m
limitRetries Int
5 RetryPolicyM m -> RetryPolicyM m -> RetryPolicyM m
forall a. Semigroup a => a -> a -> a
<> Int -> RetryPolicyM m
forall (m :: * -> *). Monad m => Int -> RetryPolicyM m
exponentialBackoff Int
100000