From 859f5b8494ce326fcdf13ed8fcca9355273fb42e Mon Sep 17 00:00:00 2001
From: Steffen Jost <jost@tcs.ifi.lmu.de>
Date: Mon, 10 Jan 2022 12:12:28 +0100
Subject: [PATCH] fix(smtp): case-insensitive from-domain comparison for
 reply-to instead option

---
 src/Mail.hs | 22 +++++++---------------
 1 file changed, 7 insertions(+), 15 deletions(-)

diff --git a/src/Mail.hs b/src/Mail.hs
index d97d9df68..f1642974c 100644
--- a/src/Mail.hs
+++ b/src/Mail.hs
@@ -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,24 +314,16 @@ 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 
+    guardM $ lift useReplyToInstead -- if sender must be fixed within ObjectIdDomain, use replyTo instead
     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
       & _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
-  
+      & _mailReplyTo  .~ sender              
   mail'' <- liftIO $ LBS.toStrict <$> renderMail' mail'
   $logDebugS "Mail" $ "Rendered mail:\n" <> decodeUtf8 mail''
   ret <$ case smtpData of