chore(email): option to keep sender fixed and use replyto instead

config/settings.yml

@@ -19,6 +19,7 @@ mail-from:
   name:         "_env:MAILFROM_NAME:Uni2work"
   email:        "_env:MAILFROM_EMAIL:uniworx@localhost"
 mail-object-domain: "_env:MAILOBJECT_DOMAIN:localhost"
+mail-sender-fixed: "_env:MAILSENDER_FIXED:True"
 #mail-verp:
 #  separator:    "_env:VERP_SEPARATOR:+"
 #  prefix:       "_env:VERP_PREFIX:bounce"

src/Foundation/Instances.hs

@@ -174,9 +174,10 @@ instance YesodAuthPersist UniWorX where
 
     
 instance YesodMail UniWorX where
-  defaultFromAddress = getsYesod $ view _appMailFrom
+  defaultFromAddress  = getsYesod $ view _appMailFrom
   envelopeFromAddress = getsYesod $ view _appMailEnvelopeFrom
-  mailObjectIdDomain = getsYesod $ view _appMailObjectDomain
+  mailObjectIdDomain  = getsYesod $ view _appMailObjectDomain
+  fixedSenderInDomain = getsYesod $ view _appMailFixedDomainSender
   mailDateTZ = return appTZ
   mailSmtp act = do
     pool <- maybe (throwM MailNotAvailable) return =<< getsYesod appSmtpPool

src/Jobs/Handler/SendCourseCommunication.hs

@@ -31,7 +31,7 @@ dispatchJobSendCourseCommunication jRecipientEmail jAllRecipientAddresses jCours
     MsgRenderer mr <- getMailMsgRenderer
 
     void $ setMailObjectUUID jMailObjectUUID
-    _mailReplyTo .= userAddressFrom sender
+    _mailFrom .= userAddressFrom sender
     addMailHeader "Cc" [st|#{mr MsgCommUndisclosedRecipients}:;|]
     addMailHeader "Auto-Submitted" "no"
     setSubjectI . prependCourseTitle courseTerm courseSchool courseShorthand $ maybe (SomeMessage MsgCommCourseSubject) SomeMessage jSubject

src/Mail.hs

@@ -49,6 +49,7 @@ import qualified Network.Mail.Mime as Mime (addPart)
 import Settings.Mime
 
 import Data.Monoid (Last(..))
+-- import Control.Monad.Trans.Maybe (MaybeT(..))
 import Control.Monad.Trans.RWS (RWST(..))
 import Control.Monad.Trans.State (StateT(..), execStateT, mapStateT)
 import Control.Monad.Trans.Writer (execWriter, execWriterT, Writer)
@@ -71,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)
+import Utils (MsgRendererS(..), MonadSecretBox(..), YamlValue, maybeMonoid, insertAssoc, maybeT, guardM)
 import Utils.Lens.TH
 
 import Control.Lens hiding (from)
@@ -144,7 +145,7 @@ _mailReplyTo' = _mailHeaders . _headerReplyTo'
 
 _headerReplyTo' :: Lens' Headers Text 
 --  Functor f => (Text -> f Text) -> [(ByteString, Text)] -> f [(ByteString, Text)]
-_headerReplyTo' f hdrs = (\x -> insertAssoc (replyto,x) hdrs) <$> f (maybeMonoid $ lookup replyto hdrs)
+_headerReplyTo' f hdrs = (\x -> insertAssoc (replyto, x) hdrs) <$> f (maybeMonoid $ lookup replyto hdrs)
   where 
     replyto = "Reply-To"        
 
@@ -153,7 +154,7 @@ _mailReplyTo = _mailHeaders . _headerReplyTo
 
 _headerReplyTo :: Lens' Headers Address
 --  Functor f => (Address -> f Address) -> [(ByteString, Text)] -> f [(ByteString, Text)]
-_headerReplyTo f hdrs = (\x -> insertAssoc (replyto,renderAddress x) hdrs) <$> f (fromString $ unpack $ maybeMonoid $ lookup replyto hdrs)
+_headerReplyTo f hdrs = (\x -> insertAssoc (replyto, renderAddress x) hdrs) <$> f (fromString $ unpack $ maybeMonoid $ lookup replyto hdrs)
   where 
     replyto = "Reply-To"        
     -- _addressEmail :: Lens' Address Text might help to simplify this code?
@@ -248,12 +249,17 @@ instance Exception MailException
 class Yesod site => YesodMail site where
   defaultFromAddress :: (MonadHandler m, HandlerSite m ~ site) => m Address
   defaultFromAddress = Address Nothing . ("yesod@" <>) . pack <$> liftIO getHostName
+  
   envelopeFromAddress :: (MonadHandler m, HandlerSite m ~ site) => m Text
   envelopeFromAddress = addressEmail <$> defaultFromAddress
 
   mailObjectIdDomain :: (MonadHandler m, HandlerSite m ~ site) => m Text
   mailObjectIdDomain = pack <$> liftIO getHostName
 
+  -- | Use replyTo instead for all senders within mailObjectIdDomain
+  fixedSenderInDomain :: (MonadHandler m, HandlerSite m ~ site) => m Bool
+  fixedSenderInDomain = return False
+
   mailDateTZ :: (MonadHandler m, HandlerSite m ~ site) => m TZ
   mailDateTZ = return utcTZ
 
@@ -308,8 +314,18 @@ defMailT :: ( MonadHandler m
 defMailT ls (MailT mailC) = do
   fromAddress <- defaultFromAddress  
   (ret, mail, smtpData) <- runRWST mailC ls (emptyMail fromAddress)  
-  mail' <- liftIO $ LBS.toStrict <$> renderMail' mail
+  
-  -- logDebugS "Mail" $ "Rendered mail:\n" <> decodeUtf8 mail'
+  mail' <- maybeT (return mail) $ do
+    guardM fixedSenderInDomain -- if sender must be fixed within ObjectIdDomain, use replyTo instead
+    let sender = mail ^. _mailFrom 
+    domain <- lift mailObjectIdDomain
+    guard $ domain `Text.isSuffixOf` (sender ^. _addressEmail) -- allowing foreign senders might be Fraport specific; maybe remove this guard
+    return $ mail
+      & _mailFrom     .~ fromAddress
+      & _mailReplyTo  .~ sender            
+
+  mail'' <- liftIO $ LBS.toStrict <$> renderMail' mail'
+  -- logDebugS "Mail" $ "Rendered mail:\n" <> decodeUtf8 mail''
   ret <$ case smtpData of
     MailSmtpData{ smtpEnvelopeFrom = Last Nothing } -> throwM MailNoSenderSpecified
     MailSmtpData{ smtpRecipients }
@@ -321,7 +337,7 @@ defMailT ls (MailT mailC) = do
       liftIO $ SMTP.sendMail
         returnPath
         recipients
-        mail'
+        mail''
         conn
 
 
@@ -335,7 +351,6 @@ instance Semigroup (PrioritisedAlternatives m) where
 
 instance Monoid (PrioritisedAlternatives m) where
   mempty = memptydefault  
-  mappend = (<>)
 
 class YesodMail site => ToMailPart site a where
   type MailPartReturn site a :: Type

src/Settings.hs

@@ -126,6 +126,7 @@ data AppSettings = AppSettings
     , appMailFrom
     , appMailSender    
     , appMailSupport            :: Address
+    , appMailFixedDomainSender  :: Bool
     , appJobWorkers             :: Natural
     , appJobFlushInterval       :: Maybe NominalDiffTime
     , appJobCronInterval        :: Maybe NominalDiffTime
@@ -556,10 +557,12 @@ instance FromJSON AppSettings where
         appMailFrom               <- o .: "mail-from"
         appMailEnvelopeFrom       <- o .:? "mail-envelope-from" .!= addressEmail appMailFrom
         appMailSender             <- o .:? "mail-sender" .!= appMailFrom
-        appMailSupport            <- o .: "mail-support"
         appMailObjectDomain       <- o .: "mail-object-domain"
+        appMailFixedDomainSender  <- o .: "mail-sender-fixed" .!= True
+        
         appMailVerp               <- fromMaybe VerpNone . join <$> (o .:? "mail-verp" <|> pure Nothing)
         appMailRetainSent         <- o .: "mail-retain-sent"
+        appMailSupport            <- o .: "mail-support"
 
         appJobWorkers             <- o .:  "job-workers"
         appJobFlushInterval       <- o .:? "job-flush-interval"