fraport/fradrive-old
Archived
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

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

Browse Source
This commit is contained in:
Steffen Jost 2022-01-07 17:45:14 +01:00
parent ddb1a15c18
commit 3453fc3459
1 changed files with 12 additions and 4 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

14
src/Mail.hs
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.Lazy as LBS
import qualified Data.ByteString as BS 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 Utils.Lens.TH
import Control.Lens hiding (from) import Control.Lens hiding (from)
@ -314,7 +314,7 @@ defMailT :: ( MonadHandler m
defMailT ls (MailT mailC) = do defMailT ls (MailT mailC) = do
fromAddress <- defaultFromAddress fromAddress <- defaultFromAddress
(ret, mail, smtpData) <- runRWST mailC ls (emptyMail fromAddress) (ret, mail, smtpData) <- runRWST mailC ls (emptyMail fromAddress)
{- -- Doesn't work somehow
mail' <- maybeT (return mail) $ do mail' <- maybeT (return mail) $ do
guardM useReplyToInstead -- if sender must be fixed within ObjectIdDomain, use replyTo instead guardM useReplyToInstead -- if sender must be fixed within ObjectIdDomain, use replyTo instead
let sender = mail ^. _mailFrom let sender = mail ^. _mailFrom
@ -323,9 +323,17 @@ defMailT ls (MailT mailC) = do
return $ mail return $ mail
& _mailFrom .~ fromAddress & _mailFrom .~ fromAddress
& _mailReplyTo .~ sender & _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' mail'' <- liftIO $ LBS.toStrict <$> renderMail' mail'
-- logDebugS "Mail" $ "Rendered mail:\n" <> decodeUtf8 mail'' $logDebugS "Mail" $ "Rendered mail:\n" <> decodeUtf8 mail''
ret <$ case smtpData of ret <$ case smtpData of
MailSmtpData{ smtpEnvelopeFrom = Last Nothing } -> throwM MailNoSenderSpecified MailSmtpData{ smtpEnvelopeFrom = Last Nothing } -> throwM MailNoSenderSpecified
MailSmtpData{ smtpRecipients } MailSmtpData{ smtpRecipients }