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

fix(smtp): case-insensitive from-domain comparison for reply-to instead option

Browse Source
This commit is contained in:
Steffen Jost 2022-01-10 12:12:28 +01:00
parent a911c01c05
commit 859f5b8494
1 changed files with 7 additions and 15 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

22
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,24 +314,16 @@ 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 $ lift useReplyToInstead -- if sender must be fixed within ObjectIdDomain, use replyTo instead
let sender = mail ^. _mailFrom
domain <- lift mailObjectIdDomain domain <- lift mailObjectIdDomain
guard $ domain `Text.isSuffixOf` (sender ^. _addressEmail) -- allowing foreign senders might be Fraport specific; maybe remove this guard let sender = mail ^. _mailFrom
isdomainaddress = (Text.isInfixOf `on` Text.toCaseFold) domain (sender ^. _addressEmail) -- not sure how to use CI.mk and isInfixOf here
$logDebugS "Mail" $ "Use ReplyTo instead of Sender: " <> tshow isdomainaddress <> " From was: " <> renderAddress sender <> " From is: " <> renderAddress fromAddress
guard isdomainaddress -- allowing foreign senders might be Fraport specific; maybe remove this guard
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