diff --git a/config/settings.yml b/config/settings.yml index dbe27a59e..4ded0132e 100644 --- a/config/settings.yml +++ b/config/settings.yml @@ -18,6 +18,7 @@ mail-from: mail-object-domain: "_env:MAILOBJECT_DOMAIN:localhost" mail-verp: separator: "_env:VERP_SEPARATOR:+" + prefix: "_env:VERP_PREFIX:bounce" mail-support: name: "_env:MAILSUPPORT_NAME:" email: "_env:MAILSUPPORT:uni2work@ifi.lmu.de" diff --git a/src/Foundation/Instances.hs b/src/Foundation/Instances.hs index 4640f93e4..cf56e7b5e 100644 --- a/src/Foundation/Instances.hs +++ b/src/Foundation/Instances.hs @@ -187,6 +187,7 @@ instance YesodAuthPersist UniWorX where instance YesodMail UniWorX where defaultFromAddress = getsYesod $ view _appMailFrom + envelopeFromAddress = getsYesod $ view _appMailEnvelopeFrom mailObjectIdDomain = getsYesod $ view _appMailObjectDomain mailDateTZ = return appTZ mailSmtp act = do @@ -199,7 +200,7 @@ instance YesodMail UniWorX where void setMailObjectIdRandom sentMailSentAt <- liftIO getCurrentTime setDate sentMailSentAt - replaceMailHeader "Sender" . Just =<< getsYesod (view $ _appMailFrom . _addressEmail) + replaceMailHeader "Sender" . Just =<< getsYesod (view $ _appMailSender . to renderAddress) (mRes, smtpData) <- listen mail @@ -217,7 +218,7 @@ instance YesodMail UniWorX where -> do verpSecret <- getsYesod appVerpSecret let bounceSecret = BounceSecret . Crypto.kmacGetDigest $ kmaclazy ("bounce" :: ByteString) verpSecret $ Binary.encode mContent - verpAddr = l <> Text.singleton verpSeparator <> toPathPiece bounceSecret <> "@" <> d + verpAddr = l <> Text.singleton verpSeparator <> verpPrefix <> "." <> toPathPiece bounceSecret <> "@" <> d return ( smtpData' <> mempty { smtpEnvelopeFrom = Last $ Just verpAddr } , Just bounceSecret ) diff --git a/src/Mail.hs b/src/Mail.hs index 41e946f0d..01b062cee 100644 --- a/src/Mail.hs +++ b/src/Mail.hs @@ -70,7 +70,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(..), maybeT, YamlValue) +import Utils (MsgRendererS(..), MonadSecretBox(..), YamlValue) import Utils.Lens.TH import Control.Lens hiding (from) @@ -108,8 +108,6 @@ import Data.Universe.Instances.Reverse () import Data.Universe.Instances.Reverse.JSON () import Data.Universe.Instances.Reverse.Hashable () -import Control.Monad.Trans.Maybe (MaybeT(..)) - import Data.CaseInsensitive (CI) import qualified Data.CaseInsensitive as CI @@ -227,6 +225,8 @@ 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 @@ -542,10 +542,7 @@ setDate time = do getMailSmtpData :: (MonadHandler m, YesodMail (HandlerSite m), MonadThrow m) => MailT m MailSmtpData getMailSmtpData = execWriterT $ do - Address _ from <- lift . maybeT (throwM MailNoSenderSpecified) $ asum - [ MaybeT . preuses (_mailHeader "Sender") $ fromString . unpack - , use _mailFrom - ] + from <- envelopeFromAddress recps <- lift $ Set.fromList . concat <$> forM [_mailTo, _mailCc, _mailBcc] use tell $ mempty diff --git a/src/Model/Types/Mail.hs b/src/Model/Types/Mail.hs index 48a2fa67f..463737ce9 100644 --- a/src/Model/Types/Mail.hs +++ b/src/Model/Types/Mail.hs @@ -100,7 +100,7 @@ instance FromJSON NotificationSettings where derivePersistFieldJSON ''NotificationSettings -newtype BounceSecret = BounceSecret (Digest (SHAKE256 128)) +newtype BounceSecret = BounceSecret (Digest (SHAKE128 64)) deriving (Eq, Ord, Read, Show, Lift, Generic, Typeable) deriving newtype ( PersistField, PersistFieldSql , Hashable, NFData diff --git a/src/Settings.hs b/src/Settings.hs index b294fd7c6..b1d460115 100644 --- a/src/Settings.hs +++ b/src/Settings.hs @@ -111,10 +111,12 @@ data AppSettings = AppSettings , appSessionTokenExpiration :: Maybe NominalDiffTime , appSessionTokenEncoding :: JwtEncoding - , appMailFrom :: Address , appMailObjectDomain :: Text , appMailVerp :: VerpMode , appMailRetainSent :: Maybe NominalDiffTime + , appMailEnvelopeFrom :: Text + , appMailFrom + , appMailSender , appMailSupport :: Address , appJobWorkers :: Natural , appJobFlushInterval :: Maybe NominalDiffTime @@ -303,7 +305,7 @@ data TokenBucketConf = TokenBucketConf } deriving (Eq, Ord, Show, Generic, Typeable) data VerpMode = VerpNone - | Verp { verpSeparator :: Char } + | Verp { verpPrefix :: Text, verpSeparator :: Char } deriving (Eq, Show, Read, Generic) deriveJSON defaultOptions @@ -460,10 +462,12 @@ instance FromJSON AppSettings where appIpFromHeader <- o .: "ip-from-header" 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" 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" diff --git a/src/Settings/Cluster.hs b/src/Settings/Cluster.hs index a17fe3598..dd565b7c6 100644 --- a/src/Settings/Cluster.hs +++ b/src/Settings/Cluster.hs @@ -150,5 +150,5 @@ instance FromJSON VerpSecret where instance ClusterSetting 'ClusterVerpSecret where type ClusterSettingValue 'ClusterVerpSecret = VerpSecret - initClusterSetting _ = liftIO $ Crypto.getRandomBytes 32 + initClusterSetting _ = liftIO $ Crypto.getRandomBytes 16 knownClusterSetting _ = ClusterVerpSecret