From 272eb7320341ece669fdd47fb61193b109c378c7 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Thu, 6 Jan 2022 13:18:34 +0100 Subject: [PATCH] chore(email): option to keep sender fixed and use replyto instead --- config/settings.yml | 1 + src/Foundation/Instances.hs | 5 +-- src/Jobs/Handler/SendCourseCommunication.hs | 2 +- src/Mail.hs | 35 +++++++++++++++------ src/Settings.hs | 9 ++++-- 5 files changed, 36 insertions(+), 16 deletions(-) diff --git a/config/settings.yml b/config/settings.yml index fb26ddb8a..05990af2e 100644 --- a/config/settings.yml +++ b/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" diff --git a/src/Foundation/Instances.hs b/src/Foundation/Instances.hs index 16cc1143d..67e1b501b 100644 --- a/src/Foundation/Instances.hs +++ b/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 diff --git a/src/Jobs/Handler/SendCourseCommunication.hs b/src/Jobs/Handler/SendCourseCommunication.hs index 2c22624ed..712fd4beb 100644 --- a/src/Jobs/Handler/SendCourseCommunication.hs +++ b/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 diff --git a/src/Mail.hs b/src/Mail.hs index ec9c93e2f..6a53571e2 100644 --- a/src/Mail.hs +++ b/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 @@ -306,10 +312,20 @@ defMailT :: ( MonadHandler m -> MailT m a -> m a 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' + fromAddress <- defaultFromAddress + (ret, mail, smtpData) <- runRWST mailC ls (emptyMail fromAddress) + + 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 @@ -334,8 +350,7 @@ instance Semigroup (PrioritisedAlternatives m) where (<>) = mappenddefault instance Monoid (PrioritisedAlternatives m) where - mempty = memptydefault - mappend = (<>) + mempty = memptydefault class YesodMail site => ToMailPart site a where type MailPartReturn site a :: Type diff --git a/src/Settings.hs b/src/Settings.hs index 39ce336c6..67676bb55 100644 --- a/src/Settings.hs +++ b/src/Settings.hs @@ -122,10 +122,11 @@ data AppSettings = AppSettings , appMailObjectDomain :: Text , appMailVerp :: VerpMode , appMailRetainSent :: Maybe NominalDiffTime - , appMailEnvelopeFrom :: Text + , appMailEnvelopeFrom :: Text , appMailFrom - , appMailSender + , 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"