fix(mail): add debug info why setting reply to instead of sender does not work

This commit is contained in:
Steffen Jost 2022-01-07 17:45:14 +01:00
parent ddb1a15c18
commit 3453fc3459

View File

@ -72,7 +72,7 @@ import qualified Data.Text.Lazy.Builder as LTB
import qualified Data.ByteString.Lazy as LBS
import qualified Data.ByteString as BS
import Utils (MsgRendererS(..), MonadSecretBox(..), YamlValue, maybeMonoid, insertAssoc, maybeT, guardM)
import Utils (MsgRendererS(..), MonadSecretBox(..), YamlValue, maybeMonoid, insertAssoc) -- , maybeT, guardM)
import Utils.Lens.TH
import Control.Lens hiding (from)
@ -314,7 +314,7 @@ defMailT :: ( MonadHandler m
defMailT ls (MailT mailC) = do
fromAddress <- defaultFromAddress
(ret, mail, smtpData) <- runRWST mailC ls (emptyMail fromAddress)
{- -- Doesn't work somehow
mail' <- maybeT (return mail) $ do
guardM useReplyToInstead -- if sender must be fixed within ObjectIdDomain, use replyTo instead
let sender = mail ^. _mailFrom
@ -323,9 +323,17 @@ defMailT ls (MailT mailC) = do
return $ mail
& _mailFrom .~ fromAddress
& _mailReplyTo .~ sender
-}
useReply <- useReplyToInstead
domain <- mailObjectIdDomain
let sender = mail ^. _mailFrom
mail' = mail & _mailFrom .~ fromAddress
& _mailReplyTo .~ sender
suffixFilter = domain `Text.isSuffixOf` (sender ^. _addressEmail)
$logDebugS "Mail" $ "Use ReplyTo instead of Sender: " <> tshow useReply <> ", " <> tshow suffixFilter <> " From was: " <> renderAddress sender <> " From is: " <> renderAddress fromAddress
mail'' <- liftIO $ LBS.toStrict <$> renderMail' mail'
-- logDebugS "Mail" $ "Rendered mail:\n" <> decodeUtf8 mail''
$logDebugS "Mail" $ "Rendered mail:\n" <> decodeUtf8 mail''
ret <$ case smtpData of
MailSmtpData{ smtpEnvelopeFrom = Last Nothing } -> throwM MailNoSenderSpecified
MailSmtpData{ smtpRecipients }