WPB-19804 Email template validation

libs/wire-subsystems/src/Wire/EmailSubsystem/Interpreter.hs

@@ -1,22 +1,20 @@
 {-# LANGUAGE RecordWildCards #-}
 
-module Wire.EmailSubsystem.Interpreter
-  ( emailSubsystemInterpreter,
-    mkMimeAddress,
-    renderInvitationUrl,
-  )
-where
+module Wire.EmailSubsystem.Interpreter where
 
 import Data.Code qualified as Code
 import Data.Id
 import Data.Json.Util
+import Data.Map as Map
 import Data.Range (fromRange)
 import Data.Text qualified as Text
 import Data.Text.Ascii qualified as Ascii
 import Data.Text.Lazy (toStrict)
 import Imports
 import Network.Mail.Mime
 import Polysemy
+import Polysemy.Output (Output)
+import Polysemy.TinyLog (TinyLog)
 import Wire.API.Locale
 import Wire.API.User
 import Wire.API.User.Activation
@@ -26,8 +24,13 @@ import Wire.EmailSending (EmailSending, sendMail)
 import Wire.EmailSubsystem
 import Wire.EmailSubsystem.Template
 
-emailSubsystemInterpreter :: (Member EmailSending r) => Localised UserTemplates -> Localised TeamTemplates -> TemplateBranding -> InterpreterFor EmailSubsystem r
-emailSubsystemInterpreter userTpls teamTpls branding = interpret \case
+emailSubsystemInterpreter ::
+  (Member EmailSending r, Member TinyLog r) =>
+  Localised UserTemplates ->
+  Localised TeamTemplates ->
+  Map Text Text ->
+  InterpreterFor EmailSubsystem r
+emailSubsystemInterpreter userTpls teamTpls brandingMap = interpret \case
   SendPasswordResetMail email (key, code) mLocale -> sendPasswordResetMailImpl userTpls branding email key code mLocale
   SendVerificationMail email key code mLocale -> sendVerificationMailImpl userTpls branding email key code mLocale
   SendTeamDeletionVerificationMail email code mLocale -> sendTeamDeletionVerificationMailImpl userTpls branding email code mLocale
@@ -38,8 +41,10 @@ emailSubsystemInterpreter userTpls teamTpls branding = interpret \case
   SendTeamActivationMail email name key code mLocale teamName -> sendTeamActivationMailImpl userTpls branding email name key code mLocale teamName
   SendNewClientEmail email name client locale -> sendNewClientEmailImpl userTpls branding email name client locale
   SendAccountDeletionEmail email name key code locale -> sendAccountDeletionEmailImpl userTpls branding email name key code locale
-  SendTeamInvitationMail email tid from code loc -> sendTeamInvitationMailImpl teamTpls branding email tid from code loc
-  SendTeamInvitationMailPersonalUser email tid from code loc -> sendTeamInvitationMailPersonalUserImpl teamTpls branding email tid from code loc
+  SendTeamInvitationMail email tid from code loc -> sendTeamInvitationMailImpl teamTpls brandingMap email tid from code loc
+  SendTeamInvitationMailPersonalUser email tid from code loc -> sendTeamInvitationMailPersonalUserImpl teamTpls brandingMap email tid from code loc
+  where
+    branding x = fromMaybe x (Map.lookup x brandingMap)
 
 -------------------------------------------------------------------------------
 -- Verification Email for
@@ -402,21 +407,39 @@ renderDeletionEmail email name cKey cValue DeletionEmailTemplate {..} branding =
 -------------------------------------------------------------------------------
 -- Invitation Email
 
-sendTeamInvitationMailImpl :: (Member EmailSending r) => Localised TeamTemplates -> TemplateBranding -> EmailAddress -> TeamId -> EmailAddress -> InvitationCode -> Maybe Locale -> Sem r Text
+sendTeamInvitationMailImpl ::
+  (Member EmailSending r, Member TinyLog r) =>
+  Localised TeamTemplates ->
+  Map Text Text ->
+  EmailAddress ->
+  TeamId ->
+  EmailAddress ->
+  InvitationCode ->
+  Maybe Locale ->
+  Sem r Text
 sendTeamInvitationMailImpl teamTemplates branding to tid from code loc = do
   let tpl = invitationEmail . snd $ forLocale loc teamTemplates
       mail = InvitationEmail to tid code from
-      (renderedMail, renderedInvitaitonUrl) = renderInvitationEmail mail tpl branding
+  (renderedMail, renderedInvitationUrl) <- logEmailRenderErrors "invitation" $ renderInvitationEmail mail tpl branding
   sendMail renderedMail
-  pure renderedInvitaitonUrl
+  pure renderedInvitationUrl
 
-sendTeamInvitationMailPersonalUserImpl :: (Member EmailSending r) => Localised TeamTemplates -> TemplateBranding -> EmailAddress -> TeamId -> EmailAddress -> InvitationCode -> Maybe Locale -> Sem r Text
+sendTeamInvitationMailPersonalUserImpl ::
+  (Member EmailSending r, Member TinyLog r) =>
+  Localised TeamTemplates ->
+  Map Text Text ->
+  EmailAddress ->
+  TeamId ->
+  EmailAddress ->
+  InvitationCode ->
+  Maybe Locale ->
+  Sem r Text
 sendTeamInvitationMailPersonalUserImpl teamTemplates branding to tid from code loc = do
   let tpl = existingUserInvitationEmail . snd $ forLocale loc teamTemplates
       mail = InvitationEmail to tid code from
-      (renderedMail, renderedInvitaitonUrl) = renderInvitationEmail mail tpl branding
+  (renderedMail, renderedInvitationUrl) <- logEmailRenderErrors "personal user invitation" $ renderInvitationEmail mail tpl branding
   sendMail renderedMail
-  pure renderedInvitaitonUrl
+  pure renderedInvitationUrl
 
 data InvitationEmail = InvitationEmail
   { invTo :: !EmailAddress,
@@ -425,38 +448,33 @@ data InvitationEmail = InvitationEmail
     invInviter :: !EmailAddress
   }
 
-renderInvitationEmail :: InvitationEmail -> InvitationEmailTemplate -> TemplateBranding -> (Mail, Text)
-renderInvitationEmail InvitationEmail {..} InvitationEmailTemplate {..} branding =
-  ( (emptyMail from)
-      { mailTo = [to],
-        mailHeaders =
-          [ ("Subject", toStrict subj),
-            ("X-Zeta-Purpose", "TeamInvitation"),
-            ("X-Zeta-Code", Ascii.toText code)
-          ],
-        mailParts = [[plainPart txt, htmlPart html]]
-      },
-    invitationUrl
-  )
+renderInvitationEmail :: (Member (Output Text) r) => InvitationEmail -> InvitationEmailTemplate -> Map Text Text -> Sem r (Mail, Text)
+renderInvitationEmail InvitationEmail {..} InvitationEmailTemplate {..} branding = do
+  invitationUrl <- renderInvitationUrl invitationEmailUrl invTeamId invInvCode
+  let replace = branding & Map.insert "inviter" (fromEmail invInviter) & Map.insert "url" invitationUrl
+  txt <- renderTextWithBrandingSem invitationEmailBodyText replace
+  html <- renderHtmlWithBrandingSem invitationEmailBodyHtml replace
+  subj <- renderTextWithBrandingSem invitationEmailSubject replace
+  pure
+    ( (emptyMail from)
+        { mailTo = [to],
+          mailHeaders =
+            [ ("Subject", toStrict subj),
+              ("X-Zeta-Purpose", "TeamInvitation"),
+              ("X-Zeta-Code", Ascii.toText code)
+            ],
+          mailParts = [[plainPart txt, htmlPart html]]
+        },
+      invitationUrl
+    )
   where
     (InvitationCode code) = invInvCode
     from = Address (Just invitationEmailSenderName) (fromEmail invitationEmailSender)
     to = Address Nothing (fromEmail invTo)
-    txt = renderTextWithBranding invitationEmailBodyText replace branding
-    html = renderHtmlWithBranding invitationEmailBodyHtml replace branding
-    subj = renderTextWithBranding invitationEmailSubject replace branding
-    invitationUrl = renderInvitationUrl invitationEmailUrl invTeamId invInvCode branding
-    replace "url" = invitationUrl
-    replace "inviter" = fromEmail invInviter
-    replace x = x
 
-renderInvitationUrl :: Template -> TeamId -> InvitationCode -> TemplateBranding -> Text
-renderInvitationUrl t tid (InvitationCode c) branding =
-  toStrict $ renderTextWithBranding t replace branding
-  where
-    replace "team" = idToText tid
-    replace "code" = Ascii.toText c
-    replace x = x
+renderInvitationUrl :: (Member (Output Text) r) => Template -> TeamId -> InvitationCode -> Sem r Text
+renderInvitationUrl t tid (InvitationCode c) =
+  toStrict <$> renderTextWithBrandingSem t (Map.fromList [("team", idToText tid), ("code", Ascii.toText c)])
 
 -------------------------------------------------------------------------------
 -- MIME Conversions

libs/wire-subsystems/src/Wire/EmailSubsystem/Template.hs

@@ -19,19 +19,28 @@
 
 module Wire.EmailSubsystem.Template
   ( module Wire.EmailSubsystem.Template,
+    module Wire.EmailSubsystem.Templates.User,
+    module Wire.EmailSubsystem.Templates.Team,
 
     -- * Re-exports
     Template,
   )
 where
 
 import Data.Map qualified as Map
+import Data.Text.Encoding qualified as T
 import Data.Text.Lazy qualified as Lazy
 import Data.Text.Template
 import HTMLEntities.Text qualified as HTML
 import Imports
+import Polysemy
+import Polysemy.Output
+import Polysemy.TinyLog (TinyLog)
+import Polysemy.TinyLog qualified as Log
+import System.Logger (field, msg, val)
 import Wire.API.Locale
-import Wire.API.User
+import Wire.EmailSubsystem.Templates.Team
+import Wire.EmailSubsystem.Templates.User
 
 -- | Lookup a localised item from a 'Localised' structure.
 forLocale ::
@@ -72,157 +81,28 @@ renderTextWithBranding tpl replace branding = render tpl (replace . branding)
 renderHtmlWithBranding :: Template -> (Text -> Text) -> TemplateBranding -> Lazy.Text
 renderHtmlWithBranding tpl replace branding = render tpl (HTML.text . replace . branding)
 
-data UserTemplates = UserTemplates
-  { activationSms :: ActivationSmsTemplate,
-    activationCall :: ActivationCallTemplate,
-    verificationEmail :: VerificationEmailTemplate,
-    activationEmail :: ActivationEmailTemplate,
-    activationEmailUpdate :: ActivationEmailTemplate,
-    teamActivationEmail :: TeamActivationEmailTemplate,
-    passwordResetSms :: PasswordResetSmsTemplate,
-    passwordResetEmail :: PasswordResetEmailTemplate,
-    loginSms :: LoginSmsTemplate,
-    loginCall :: LoginCallTemplate,
-    deletionSms :: DeletionSmsTemplate,
-    deletionEmail :: DeletionEmailTemplate,
-    newClientEmail :: NewClientEmailTemplate,
-    verificationLoginEmail :: SecondFactorVerificationEmailTemplate,
-    verificationScimTokenEmail :: SecondFactorVerificationEmailTemplate,
-    verificationTeamDeletionEmail :: SecondFactorVerificationEmailTemplate
-  }
-
-data ActivationSmsTemplate = ActivationSmsTemplate
-  { activationSmslUrl :: Template,
-    activationSmsText :: Template,
-    activationSmsSender :: Text
-  }
-
-data ActivationCallTemplate = ActivationCallTemplate
-  { activationCallText :: Template
-  }
-
-data VerificationEmailTemplate = VerificationEmailTemplate
-  { verificationEmailUrl :: Template,
-    verificationEmailSubject :: Template,
-    verificationEmailBodyText :: Template,
-    verificationEmailBodyHtml :: Template,
-    verificationEmailSender :: EmailAddress,
-    verificationEmailSenderName :: Text
-  }
-
-data ActivationEmailTemplate = ActivationEmailTemplate
-  { activationEmailUrl :: Template,
-    activationEmailSubject :: Template,
-    activationEmailBodyText :: Template,
-    activationEmailBodyHtml :: Template,
-    activationEmailSender :: EmailAddress,
-    activationEmailSenderName :: Text
-  }
-
-data TeamActivationEmailTemplate = TeamActivationEmailTemplate
-  { teamActivationEmailUrl :: Template,
-    teamActivationEmailSubject :: Template,
-    teamActivationEmailBodyText :: Template,
-    teamActivationEmailBodyHtml :: Template,
-    teamActivationEmailSender :: EmailAddress,
-    teamActivationEmailSenderName :: Text
-  }
-
-data DeletionEmailTemplate = DeletionEmailTemplate
-  { deletionEmailUrl :: Template,
-    deletionEmailSubject :: Template,
-    deletionEmailBodyText :: Template,
-    deletionEmailBodyHtml :: Template,
-    deletionEmailSender :: EmailAddress,
-    deletionEmailSenderName :: Text
-  }
-
-data PasswordResetEmailTemplate = PasswordResetEmailTemplate
-  { passwordResetEmailUrl :: Template,
-    passwordResetEmailSubject :: Template,
-    passwordResetEmailBodyText :: Template,
-    passwordResetEmailBodyHtml :: Template,
-    passwordResetEmailSender :: EmailAddress,
-    passwordResetEmailSenderName :: Text
-  }
-
-data PasswordResetSmsTemplate = PasswordResetSmsTemplate
-  { passwordResetSmsText :: Template,
-    passwordResetSmsSender :: Text
-  }
-
-data LoginSmsTemplate = LoginSmsTemplate
-  { loginSmsUrl :: Template,
-    loginSmsText :: Template,
-    loginSmsSender :: Text
-  }
-
-data LoginCallTemplate = LoginCallTemplate
-  { loginCallText :: Template
-  }
-
-data DeletionSmsTemplate = DeletionSmsTemplate
-  { deletionSmsUrl :: Template,
-    deletionSmsText :: Template,
-    deletionSmsSender :: Text
-  }
-
-data NewClientEmailTemplate = NewClientEmailTemplate
-  { newClientEmailSubject :: Template,
-    newClientEmailBodyText :: Template,
-    newClientEmailBodyHtml :: Template,
-    newClientEmailSender :: EmailAddress,
-    newClientEmailSenderName :: Text
-  }
-
-data SecondFactorVerificationEmailTemplate = SecondFactorVerificationEmailTemplate
-  { sndFactorVerificationEmailSubject :: Template,
-    sndFactorVerificationEmailBodyText :: Template,
-    sndFactorVerificationEmailBodyHtml :: Template,
-    sndFactorVerificationEmailSender :: EmailAddress,
-    sndFactorVerificationEmailSenderName :: Text
-  }
-
-data InvitationEmailTemplate = InvitationEmailTemplate
-  { invitationEmailUrl :: !Template,
-    invitationEmailSubject :: !Template,
-    invitationEmailBodyText :: !Template,
-    invitationEmailBodyHtml :: !Template,
-    invitationEmailSender :: !EmailAddress,
-    invitationEmailSenderName :: !Text
-  }
-
-data CreatorWelcomeEmailTemplate = CreatorWelcomeEmailTemplate
-  { creatorWelcomeEmailUrl :: !Text,
-    creatorWelcomeEmailSubject :: !Template,
-    creatorWelcomeEmailBodyText :: !Template,
-    creatorWelcomeEmailBodyHtml :: !Template,
-    creatorWelcomeEmailSender :: !EmailAddress,
-    creatorWelcomeEmailSenderName :: !Text
-  }
-
-data MemberWelcomeEmailTemplate = MemberWelcomeEmailTemplate
-  { memberWelcomeEmailUrl :: !Text,
-    memberWelcomeEmailSubject :: !Template,
-    memberWelcomeEmailBodyText :: !Template,
-    memberWelcomeEmailBodyHtml :: !Template,
-    memberWelcomeEmailSender :: !EmailAddress,
-    memberWelcomeEmailSenderName :: !Text
-  }
-
-data NewTeamOwnerWelcomeEmailTemplate = NewTeamOwnerWelcomeEmailTemplate
-  { newTeamOwnerWelcomeEmailUrl :: !Text,
-    newTeamOwnerWelcomeEmailSubject :: !Template,
-    newTeamOwnerWelcomeEmailBodyText :: !Template,
-    newTeamOwnerWelcomeEmailBodyHtml :: !Template,
-    newTeamOwnerWelcomeEmailSender :: !EmailAddress,
-    newTeamOwnerWelcomeEmailSenderName :: !Text
-  }
-
-data TeamTemplates = TeamTemplates
-  { invitationEmail :: !InvitationEmailTemplate,
-    existingUserInvitationEmail :: !InvitationEmailTemplate,
-    creatorWelcomeEmail :: !CreatorWelcomeEmailTemplate,
-    memberWelcomeEmail :: !MemberWelcomeEmailTemplate,
-    newTeamOwnerWelcomeEmail :: !NewTeamOwnerWelcomeEmailTemplate
-  }
+renderHtmlWithBrandingSem :: (Member (Output Text) r) => Template -> Map Text Text -> Sem r Lazy.Text
+renderHtmlWithBrandingSem = renderWithBrandingSem HTML.text
+
+renderTextWithBrandingSem :: (Member (Output Text) r) => Template -> Map Text Text -> Sem r Lazy.Text
+renderTextWithBrandingSem = renderWithBrandingSem id
+
+renderWithBrandingSem :: (Member (Output Text) r) => (Text -> Text) -> Template -> Map Text Text -> Sem r Lazy.Text
+renderWithBrandingSem escapeHtml tpl replace = do
+  let f x = case Map.lookup x replace of
+        Just v -> pure v
+        Nothing -> do
+          output x
+          pure x
+  renderA tpl (escapeHtml <$$> f)
+
+logEmailRenderErrors :: (Member TinyLog r) => Text -> Sem (Output Text : r) a -> Sem r a
+logEmailRenderErrors tplName =
+  runOutputSem $
+    ( \warn ->
+        do
+          Log.warn $
+            msg (val "Email template rendering failure")
+              . field "template_name" (val (T.encodeUtf8 tplName))
+              . field "unreplaced_variable" (val (T.encodeUtf8 warn))
+    )