fix(mail): better separation of sender/from/envelope-from

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"

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
                      )

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
+  from <- envelopeFromAddress
-    [ MaybeT . preuses (_mailHeader "Sender") $ fromString . unpack
-    , use _mailFrom
-    ]
   recps <- lift $ Set.fromList . concat <$> forM [_mailTo, _mailCc, _mailBcc] use
 
   tell $ mempty

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

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"

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