fix(mail): mail-reroute-to now changes envelope-recipients as expected

config/settings.yml

@@ -24,6 +24,9 @@ mail-from:
   email:        "_env:MAILFROM_EMAIL:uniworx@localhost"
 mail-object-domain: "_env:MAILOBJECT_DOMAIN:localhost"
 mail-use-replyto-instead-sender: "_env:MAIL_USES_REPLYTO:true"
+#mail-reroute-to: 
+#  name:         "_env:MAIL_REROUTE_TO_NAME:"
+#  email:        "_env:MAIL_REROUTE_TO_EMAL:"
 #mail-verp:
 #  separator:    "_env:VERP_SEPARATOR:+"
 #  prefix:       "_env:VERP_PREFIX:bounce"

messages/uniworx/categories/admin/de-de-formal.msg

@@ -43,6 +43,7 @@ StudySubTermsChildKey: Kind
 StudySubTermsChildName: Kindname
 MailTestFormEmail: E-Mail-Adresse
 MailTestFormLanguages: Spracheinstellungen
+MailRerouteTo dev@Address: Alle Emails werden nicht an die eigentlichen Empfänger versendet, sondern umgeleitet zu _{dev}
 TestDownload: Download-Test
 BearerTokenUsageWarning: Mit diesem Interface können quesi beliebige Rechte als Tokens kodiert und somit ohne wesentliche weitere Beschränkung frei übertragen werden. Benutzen Sie dieses Interface nur, wenn Sie von einem erfahrenen Entwickler/einer erfahrenen Entwicklerin über die Auswirkungen des konkreten Tokens, dass sie ausstellen möchten, beraten wurden!
 BearerTokenAuthorityGroups: Token-Authorität (Gruppen)

messages/uniworx/categories/admin/en-eu.msg

@@ -43,6 +43,7 @@ StudySubTermsChildKey: Child
 StudySubTermsChildName: Child-Name
 MailTestFormEmail: Email address
 MailTestFormLanguages: Language settings
+MailRerouteTo dev: All email will not be sent to the intended recipients, but rerouted to _{dev}
 TestDownload: Download test
 BearerTokenUsageWarning: Using this interface you are able to encode essentially arbitrary permissions into bearer tokens. This allows you to freely hand permissions off arbitrarily and without relevant restrictions. Only use this interface if you have discussed the consequences of the specific token, that you want to issue, with an experienced developer!
 BearerTokenAuthorityGroups: Authority (groups)

src/Foundation/I18n.hs

@@ -550,3 +550,7 @@ unRenderMessageLenient = unRenderMessage' cmp
 
 instance Default DateTimeFormatter where
   def = mkDateTimeFormatter (getTimeLocale' []) def appTZ
+
+instance RenderMessage UniWorX Address where 
+  renderMessage s l a@Address{addressName = Just aname} = aname <> cons ' ' (renderMessage s l a{addressName=Nothing})
+  renderMessage _ _   Address{addressEmail = mail} = "<" <> mail <> ">"

src/Handler/Admin.hs

@@ -73,9 +73,11 @@ getAdminProblemsR = do
       flagNonZero :: Int -> Widget
       flagNonZero n | n <= 0    = flagError True
                     | otherwise = messageTooltip =<< handlerToWidget (messageI Error (MsgProblemsDriverSynch n))                                    
-      
+  
+  rerouteMail <- getsYesod $ view _appMailRerouteTo
+
   siteLayoutMsg MsgProblemsHeading $ do
-    setTitleI   MsgProblemsHeading    
+    setTitleI   MsgProblemsHeading
     $(widgetFile "admin-problems")
 
 

src/Mail.hs

@@ -78,7 +78,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, maybeM, maybeT, guardM, adjustAssoc)
+import Utils (MsgRendererS(..), MonadSecretBox(..), YamlValue, maybeMonoid, insertAssoc, maybeT, guardM, adjustAssoc)
 import Utils.Lens.TH
 
 import Control.Lens hiding (from)
@@ -328,7 +328,7 @@ defMailT :: ( MonadHandler m
               -> m a
 defMailT ls (MailT mailC) = do
   fromAddress <- defaultFromAddress  
-  (ret, mail0, smtpData) <- runRWST mailC ls (emptyMail fromAddress)  
+  (ret, mail0, smtpData0) <- runRWST mailC ls (emptyMail fromAddress)  
   mail1 <- maybeT (return mail0) $ do
     guardM useReplyToInstead -- if sender must be fixed within ObjectIdDomain, use replyTo instead
     domain <- mailObjectIdDomain
@@ -339,20 +339,20 @@ defMailT ls (MailT mailC) = do
     return $ mail0
       & _mailFrom     .~ fromAddress
       & _mailReplyTo  .~ sender
-  let switchRecipient rerouteTo = return $ mail1
+  mailRerouteTo' <- mailRerouteTo
-        & _mailTo     .~ [rerouteTo]
+  let (mail2, smtpData1) = maybe (mail1,smtpData0) switchRecipient mailRerouteTo'   -- switch receiver on enveloper, if rerouting is active
-        & Mime.addPart [plainPart $ LT.fromStrict $ "Due to setting 'mail-reroute-to', this mail was diverted; it would have been sent to: " <> tshow (mail1 ^. _mailTo)]
+      switchRecipient rerouteTo = (Mime.addPart switchInfo mail1, smtpData0 { smtpRecipients = Set.singleton rerouteTo } )
-  mail2 <- maybeM (return mail1) switchRecipient mailRerouteTo
+      switchInfo = [plainPart $ LT.fromStrict $ "Due to setting 'mail-reroute-to', this mail was diverted; it was intended to be sent to: " <> tshow (smtpRecipients smtpData0)]
   mail3 <- liftIO $ LBS.toStrict <$> renderMail' mail2
   $logDebugS "Mail" $ "Rendered mail:\n" <> decodeUtf8 mail3
-  ret <$ case smtpData of
+  ret <$ case smtpData1 of
     MailSmtpData{ smtpEnvelopeFrom = Last Nothing } -> throwM MailNoSenderSpecified
     MailSmtpData{ smtpRecipients }
       | Set.null smtpRecipients -> throwM MailNoRecipientsSpecified
     MailSmtpData{ smtpEnvelopeFrom = Last (Just (unpack -> returnPath))
                 , smtpRecipients = (map (unpack . addressEmail) . toList -> recipients)
                 } -> mailSmtp $ \conn -> do
-      $logInfoS "Mail" $ "Submitting email: " <> tshow smtpData
+      $logInfoS "Mail" $ "Submitting email: " <> tshow smtpData1
       liftIO $ SMTP.sendMail
         returnPath
         recipients

templates/admin-problems.hamlet

@@ -44,3 +44,7 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
 
     <dt .deflist__dt>^{flagError noStalePrintJobs}
     <dd .deflist__dd>^{simpleLinkI (MsgProblemsNoStalePrintJobs cutOffPrintDays) PrintCenterR}
+
+    $maybe reroute <- rerouteMail
+      <dt .deflist__dt>^{flagWarning False}
+      <dd .deflist__dd>_{MsgMailRerouteTo reroute}