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
      -- To map rejected domain names by SES to 400 responses, in order
      -- not to trigger false 5xx alerts. Upfront domain name validation
      -- is only according to the syntax rules of RFC5322 but additional
      -- constraints may be applied by email servers (in this case SES).
      -- Since such additional constraints are neither standardised nor
      -- documented in the cases of SES, we can only handle the errors
      -- after the fact.
      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