From a69310f3199ac2845e72044ceece47aede5911d1 Mon Sep 17 00:00:00 2001 From: Gautier DI FOLCO Date: Fri, 14 Aug 2026 17:57:02 +0200 Subject: [PATCH 1/7] WPB-27255: move email sending to background-worker --- .../wpb-27255-email-background-worker.md | 14 + .../background-worker/configmap.yaml | 16 ++ .../background-worker/deployment.yaml | 14 + .../templates/background-worker/secret.yaml | 7 + charts/wire-server/values.yaml | 22 ++ .../src/developer/reference/config-options.md | 63 +++++ hack/helm_vars/wire-server/values.yaml.gotmpl | 8 + libs/wire-api/src/Wire/API/BackgroundJobs.hs | 9 +- .../src/Wire/API/BackgroundJobs/Email.hs | 251 ++++++++++++++++++ libs/wire-api/wire-api.cabal | 1 + .../Wire/BackgroundJobsRunner/Interpreter.hs | 11 + .../src/Wire/EmailSending/Queueing.hs | 240 +++++++++++++++++ .../unit/Wire/EmailSendingQueueingSpec.hs | 248 +++++++++++++++++ libs/wire-subsystems/wire-subsystems.cabal | 2 + .../background-worker/background-worker.cabal | 2 + .../background-worker.integration.yaml | 6 + services/background-worker/default.nix | 4 + .../src/Wire/BackgroundWorker/Env.hs | 25 +- .../Wire/BackgroundWorker/Jobs/Registry.hs | 17 +- .../src/Wire/BackgroundWorker/Options.hs | 4 +- .../background-worker/src/Wire/Effects.hs | 19 +- .../Wire/BackendNotificationPusherSpec.hs | 2 + .../background-worker/test/Test/Wire/Util.hs | 1 + services/brig/src/Brig/App.hs | 18 +- .../brig/src/Brig/CanonicalInterpreter.hs | 11 +- 25 files changed, 981 insertions(+), 34 deletions(-) create mode 100644 changelog.d/0-release-notes/wpb-27255-email-background-worker.md create mode 100644 libs/wire-api/src/Wire/API/BackgroundJobs/Email.hs create mode 100644 libs/wire-subsystems/src/Wire/EmailSending/Queueing.hs create mode 100644 libs/wire-subsystems/test/unit/Wire/EmailSendingQueueingSpec.hs diff --git a/changelog.d/0-release-notes/wpb-27255-email-background-worker.md b/changelog.d/0-release-notes/wpb-27255-email-background-worker.md new file mode 100644 index 00000000000..b68ec82b16b --- /dev/null +++ b/changelog.d/0-release-notes/wpb-27255-email-background-worker.md @@ -0,0 +1,14 @@ +Outbound email delivery has moved from **brig** to the **background-worker**. +brig no longer sends email directly: it enqueues every outbound +message (verification, activation, password-reset, invitation, new-client, +account-deletion, SAML IdP-change, provider and enterprise-audit mail) on the +existing `background-jobs` RabbitMQ queue, and the background-worker performs +the actual SMTP/SES send. Operators must configure the new +`background-worker.config.email` block (SES **or** SMTP, the same shape as +brig's `emailSMS.email`) and, for SES, the worker's AWS region and +credentials (`AWS_REGION` and `AWS_ACCESS_KEY_ID`/`AWS_SECRET_ACCESS_KEY`). +The `background-jobs` queue is a durable quorum queue, so transient +background-worker downtime does not lose mail: undelivered jobs are +requeued until a worker picks them up. When rolling out, deploy the updated +background-worker before (or alongside) the updated brig so that the new +`send-email` jobs are consumed as soon as they appear. diff --git a/charts/wire-server/templates/background-worker/configmap.yaml b/charts/wire-server/templates/background-worker/configmap.yaml index d4fe2a63202..571174228b8 100644 --- a/charts/wire-server/templates/background-worker/configmap.yaml +++ b/charts/wire-server/templates/background-worker/configmap.yaml @@ -80,6 +80,22 @@ data: {{- end }} {{- end }} + email: + {{- if .useSES }} + sesQueue: {{ required "Missing value: background-worker.config.aws.sesQueue" .aws.sesQueue }} + sesEndpoint: {{ .aws.sesEndpoint | quote }} + {{- else }} + smtpEndpoint: + host: {{ .smtp.host }} + port: {{ .smtp.port }} + smtpConnType: {{ .smtp.connType }} + {{- if .smtp.username }} + smtpCredentials: + smtpUsername: {{ .smtp.username }} + smtpPassword: {{ .smtp.passwordFile }} + {{- end }} + {{- end }} + migrateConversations: {{ .migrateConversations }} migrateConversationCodes: {{ .migrateConversationCodes }} migrateTeamFeatures: {{ .migrateTeamFeatures }} diff --git a/charts/wire-server/templates/background-worker/deployment.yaml b/charts/wire-server/templates/background-worker/deployment.yaml index f91ccb5ee17..344c1a97bdd 100644 --- a/charts/wire-server/templates/background-worker/deployment.yaml +++ b/charts/wire-server/templates/background-worker/deployment.yaml @@ -109,6 +109,20 @@ spec: {{ toYaml .Values.additionalVolumeMounts | nindent 10 }} {{- end }} env: + {{- if hasKey $backgroundWorker.secrets "awsKeyId" }} + - name: AWS_ACCESS_KEY_ID + valueFrom: + secretKeyRef: + name: background-worker + key: awsKeyId + - name: AWS_SECRET_ACCESS_KEY + valueFrom: + secretKeyRef: + name: background-worker + key: awsSecretKey + {{- end }} + - name: AWS_REGION + value: "{{ $backgroundWorker.config.aws.region }}" - name: RABBITMQ_USERNAME valueFrom: secretKeyRef: diff --git a/charts/wire-server/templates/background-worker/secret.yaml b/charts/wire-server/templates/background-worker/secret.yaml index 1efb48f2cfa..fc7e61e316e 100644 --- a/charts/wire-server/templates/background-worker/secret.yaml +++ b/charts/wire-server/templates/background-worker/secret.yaml @@ -14,6 +14,13 @@ data: for_helm_linting: {{ required "No .secrets found in configuration. Did you forget to helm -f path/to/secrets.yaml ?" $backgroundWorker.secrets | quote | b64enc | quote }} {{- with $backgroundWorker.secrets }} + {{- if .awsKeyId }} + awsKeyId: {{ .awsKeyId | b64enc | quote }} + awsSecretKey: {{ .awsSecretKey | b64enc | quote }} + {{- end }} + {{- if (not $backgroundWorker.config.useSES) }} + smtp-password.txt: {{ .smtpPassword | b64enc | quote }} + {{- end }} rabbitmqUsername: {{ .rabbitmq.username | b64enc | quote }} rabbitmqPassword: {{ .rabbitmq.password | b64enc | quote }} {{- end }} diff --git a/charts/wire-server/values.yaml b/charts/wire-server/values.yaml index 5bb0b276eb6..be8443f4412 100644 --- a/charts/wire-server/values.yaml +++ b/charts/wire-server/values.yaml @@ -1075,6 +1075,28 @@ background-worker: # Cron schedule for the cleanup job (0 * * * * = every hour) schedule: "0 * * * *" + # Email transport for the background-worker (delivers the email jobs + # enqueued by brig). Same SES/SMTP shape as brig's emailSMS.email. + # `useSES` selects the transport: when true, the worker sends via AWS SES + # using `aws.sesQueue`/`aws.sesEndpoint` together with the AWS_ACCESS_KEY_ID + # / AWS_SECRET_ACCESS_KEY secrets and the AWS_REGION below. When false, it + # sends via SMTP using the `smtp.*` settings. + useSES: true + aws: + region: "eu-west-1" + sesEndpoint: https://email.eu-west-1.amazonaws.com + # sesQueue is required when useSES is true (deployment-specific), e.g.: + # sesQueue: wire-brig-events + # SMTP transport (used when useSES is false). The ConfigMap renders these + # into the `email` block; mirrors brig's `smtp` settings. + smtp: + passwordFile: /etc/wire/background-worker/secrets/smtp-password.txt + + # Optional secret keys (see templates/background-worker/secret.yaml): + # awsKeyId: # required for SES; rendered as AWS_ACCESS_KEY_ID + # awsSecretKey: # required for SES; rendered as AWS_SECRET_ACCESS_KEY + # smtpPassword: # mounted at /etc/wire/background-worker/secrets/smtp-password.txt; + # # consumed via config.smtp.passwordFile (mirrors brig/galley) secrets: {} podSecurityContext: diff --git a/docs/src/developer/reference/config-options.md b/docs/src/developer/reference/config-options.md index cf86ee7681c..53a5d28a2d6 100644 --- a/docs/src/developer/reference/config-options.md +++ b/docs/src/developer/reference/config-options.md @@ -2448,3 +2448,66 @@ Notes - `jobs.workerThreads` controls the number of worker threads in each job queue. The default is `1`; increasing it allows jobs in that queue to run in parallel when their group keys permit it. - Both job queues share the same PostgreSQL pool. Increasing `jobs.workerThreads` can increase the number of connections needed when more jobs run concurrently, but it does not create a permanently dedicated connection per thread or queue. - The job runner is poll-only and does not require an additional PostgreSQL listener connection. + +## Background worker: Email sending + +The background-worker delivers the email jobs enqueued by brig. It requires an +`email` transport (AWS SES or SMTP), the same shape brig uses for +`emailSMS.email`. Configuration is supplied via Helm under +`background-worker.config` and rendered into the `email` block of +`background-worker.yaml`. + +The transport is selected by `background-worker.config.useSES`: + +- `useSES: true` (default) renders an SES block. `aws.sesQueue` is required and + `aws.sesEndpoint` selects the SES endpoint. The worker also needs the + `AWS_REGION`, `AWS_ACCESS_KEY_ID`, and `AWS_SECRET_ACCESS_KEY` environment + variables, injected from `background-worker.config.aws.region` and the + `awsKeyId`/`awsSecretKey` secrets (the same pattern brig uses). +- `useSES: false` renders an SMTP block using the `smtp.*` settings. The SMTP + password is read from the file named by `smtp.passwordFile` (mounted from the + `smtpPassword` secret). + +Rendered config (`background-worker.yaml`): + +```yaml +# SES: +email: + sesQueue: wire-brig-events + sesEndpoint: https://email.eu-west-1.amazonaws.com +# SMTP (xor SES): +# email: +# smtpEndpoint: { host: smtp.example.com, port: 587 } +# smtpConnType: tls +# smtpCredentials: +# smtpUsername: wire +# smtpPassword: /etc/wire/background-worker/secrets/smtp-password.txt +``` + +Helm values (under `background-worker`): + +```yaml +config: + useSES: true + aws: + region: "eu-west-1" + sesEndpoint: https://email.eu-west-1.amazonaws.com + sesQueue: wire-brig-events # required when useSES is true + smtp: + passwordFile: /etc/wire/background-worker/secrets/smtp-password.txt +secrets: + awsKeyId: # SES only + awsSecretKey: # SES only + smtpPassword: # SMTP only +``` + +Notes + +- `email` is required: the worker fails to start without a transport. +- For SES, the worker reads `AWS_REGION` from `config.aws.region` and the AWS + credentials from the `awsKeyId`/`awsSecretKey` secrets, mirroring brig. +- For SMTP, the password is mounted at + `/etc/wire/background-worker/secrets/smtp-password.txt` (from the + `smtpPassword` secret); `config.smtp.passwordFile` must point at it. +- The `background-jobs` queue is durable, so transient worker downtime does not + lose email jobs; an updated worker picks up messages an older one requeued. diff --git a/hack/helm_vars/wire-server/values.yaml.gotmpl b/hack/helm_vars/wire-server/values.yaml.gotmpl index b0309380b56..b2cbfeb8bca 100644 --- a/hack/helm_vars/wire-server/values.yaml.gotmpl +++ b/hack/helm_vars/wire-server/values.yaml.gotmpl @@ -710,7 +710,15 @@ background-worker: tlsCaSecretRef: name: "rabbitmq-certificate" key: "ca.crt" + # Email transport: the worker sends email via SES in CI (mirrors brig). + useSES: true + aws: + region: "eu-west-1" + sesEndpoint: http://fake-aws-ses:4569 + sesQueue: integration-brig-events secrets: + awsKeyId: dummykey + awsSecretKey: dummysecret rabbitmq: username: {{ .Values.rabbitmqUsername }} password: {{ .Values.rabbitmqPassword }} diff --git a/libs/wire-api/src/Wire/API/BackgroundJobs.hs b/libs/wire-api/src/Wire/API/BackgroundJobs.hs index b96f2cd7505..d79c36876a9 100644 --- a/libs/wire-api/src/Wire/API/BackgroundJobs.hs +++ b/libs/wire-api/src/Wire/API/BackgroundJobs.hs @@ -30,11 +30,13 @@ import Data.Schema import Imports import Network.AMQP qualified as Q import Network.AMQP.Types qualified as QT +import Wire.API.BackgroundJobs.Email (SendEmailJob) import Wire.Arbitrary (Arbitrary (..), GenericUniform (..)) data BackgroundJobPayload = BackgroundJobSyncUserGroupAndChannel SyncUserGroupAndChannel | BackgroundJobSyncUserGroup SyncUserGroup + | BackgroundJobSendEmail !SendEmailJob deriving stock (Eq, Show, Generic) deriving (Arbitrary) via GenericUniform BackgroundJobPayload @@ -42,10 +44,12 @@ backgroundJobPayloadLabel :: BackgroundJobPayload -> Text backgroundJobPayloadLabel p = case backgroundJobPayloadTag p of BackgroundJobSyncUserGroupAndChannelTag -> "sync-user-group-and-channel" BackgroundJobSyncUserGroupTag -> "sync-user-group" + BackgroundJobSendEmailTag -> "send-email" data BackgroundJobPayloadTag = BackgroundJobSyncUserGroupAndChannelTag | BackgroundJobSyncUserGroupTag + | BackgroundJobSendEmailTag deriving stock (Eq, Ord, Bounded, Enum, Show, Generic) deriving (Arbitrary) via GenericUniform BackgroundJobPayloadTag @@ -54,7 +58,8 @@ instance ToSchema BackgroundJobPayloadTag where enum @Text $ mconcat [ element "sync-user-group-and-channel" BackgroundJobSyncUserGroupAndChannelTag, - element "sync-user-group" BackgroundJobSyncUserGroupTag + element "sync-user-group" BackgroundJobSyncUserGroupTag, + element "send-email" BackgroundJobSendEmailTag ] backgroundJobPayloadTag :: BackgroundJobPayload -> BackgroundJobPayloadTag @@ -62,6 +67,7 @@ backgroundJobPayloadTag = \case BackgroundJobSyncUserGroupAndChannel {} -> BackgroundJobSyncUserGroupAndChannelTag BackgroundJobSyncUserGroup {} -> BackgroundJobSyncUserGroupTag + BackgroundJobSendEmail {} -> BackgroundJobSendEmailTag backgroundJobPayloadTagSchema :: ObjectSchema SwaggerDoc BackgroundJobPayloadTag backgroundJobPayloadTagSchema = field "type" schema @@ -116,6 +122,7 @@ backgroundJobPayloadObjectSchema = backgroundJobPayloadDataSchema = \case BackgroundJobSyncUserGroupAndChannelTag -> tag _BackgroundJobSyncUserGroupAndChannel (field "payload" schema) BackgroundJobSyncUserGroupTag -> tag _BackgroundJobSyncUserGroup (field "payload" schema) + BackgroundJobSendEmailTag -> tag _BackgroundJobSendEmail (field "payload" schema) instance ToSchema BackgroundJobPayload where schema = object backgroundJobPayloadObjectSchema diff --git a/libs/wire-api/src/Wire/API/BackgroundJobs/Email.hs b/libs/wire-api/src/Wire/API/BackgroundJobs/Email.hs new file mode 100644 index 00000000000..a4c63b8d10e --- /dev/null +++ b/libs/wire-api/src/Wire/API/BackgroundJobs/Email.hs @@ -0,0 +1,251 @@ +{-# LANGUAGE StrictData #-} +{-# LANGUAGE TemplateHaskell #-} + +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2025 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +-- | Email job payload types (WPB-27255). +-- +-- Email delivery is queued to the background-worker as a 'BackgroundJobSendEmail' +-- job. The actual SMTP/SES send happens in the worker; brig only enqueues. +-- +-- @wire-api@ cannot depend on @mime-mail@, so a mail is serialised as the plain +-- records below. The @Mail@ <-> record conversion lives in @wire-subsystems@ +-- ("Wire.EmailSending.Queueing"). Flat part content is stored as base64-encoded +-- 'Text'; nested alternative groups are modelled recursively via +-- 'SerializablePartContent'. +module Wire.API.BackgroundJobs.Email where + +import Control.Arrow ((&&&)) +import Control.Lens (makePrisms) +import Data.Aeson qualified as Aeson +import Data.Schema +import Imports +import Test.QuickCheck qualified as QC +import Wire.Arbitrary (Arbitrary (..), GenericUniform (..)) + +data SerializableMailAddress = SerializableMailAddress + { smaName :: !(Maybe Text), + smaEmail :: !Text + } + deriving stock (Eq, Show, Generic) + deriving (Aeson.ToJSON, Aeson.FromJSON) via (Schema SerializableMailAddress) + deriving (Arbitrary) via GenericUniform SerializableMailAddress + +instance ToSchema SerializableMailAddress where + schema = + object $ + SerializableMailAddress + <$> (.smaName) .= maybe_ (optField "name" schema) + <*> (.smaEmail) .= field "email" schema + +data SerializableMailHeader = SerializableMailHeader + { smhName :: !Text, + smhValue :: !Text + } + deriving stock (Eq, Show, Generic) + deriving (Aeson.ToJSON, Aeson.FromJSON) via (Schema SerializableMailHeader) + deriving (Arbitrary) via GenericUniform SerializableMailHeader + +instance ToSchema SerializableMailHeader where + schema = + object $ + SerializableMailHeader + <$> (.smhName) .= field "name" schema + <*> (.smhValue) .= field "value" schema + +data SerializableEncoding + = SerializableEncodingNone + | SerializableEncodingBase64 + | SerializableEncodingQuotedPrintableBinary + | SerializableEncodingQuotedPrintableText + deriving stock (Eq, Ord, Bounded, Enum, Show, Generic) + deriving (Aeson.ToJSON, Aeson.FromJSON) via (Schema SerializableEncoding) + deriving (Arbitrary) via GenericUniform SerializableEncoding + +instance ToSchema SerializableEncoding where + schema = + enum @Text $ + mconcat + [ element "none" SerializableEncodingNone, + element "base64" SerializableEncodingBase64, + element "quoted-printable-binary" SerializableEncodingQuotedPrintableBinary, + element "quoted-printable-text" SerializableEncodingQuotedPrintableText + ] + +data SerializableDisposition = SerializableDisposition + { smdType :: !SerializableDispositionType, + smdFilename :: !Text + } + deriving stock (Eq, Show, Generic) + deriving (Aeson.ToJSON, Aeson.FromJSON) via (Schema SerializableDisposition) + deriving (Arbitrary) via GenericUniform SerializableDisposition + +instance ToSchema SerializableDisposition where + schema = + object $ + SerializableDisposition + <$> (.smdType) .= field "type" schema + <*> (.smdFilename) .= field "filename" schema + +data SerializableDispositionType + = SerializableDispositionDefault + | SerializableDispositionInline + | SerializableDispositionAttachment + deriving stock (Eq, Ord, Bounded, Enum, Show, Generic) + deriving (Aeson.ToJSON, Aeson.FromJSON) via (Schema SerializableDispositionType) + deriving (Arbitrary) via GenericUniform SerializableDispositionType + +instance ToSchema SerializableDispositionType where + schema = + enum @Text $ + mconcat + [ element "default" SerializableDispositionDefault, + element "inline" SerializableDispositionInline, + element "attachment" SerializableDispositionAttachment + ] + +-- | Mutually recursive with 'SerializableMailPart': a part's content is either +-- flat bytes or a nested alternative group of parts. Both types must be +-- declared before the @makePrisms@ splice below, so 'SerializableMailPart' gets +-- its schema/arbitrary instances after it. +data SerializableMailPart = SerializableMailPart + { smpType :: !Text, + smpEncoding :: !SerializableEncoding, + smpDisposition :: !SerializableDisposition, + smpHeaders :: ![SerializableMailHeader], + smpContent :: !SerializablePartContent + } + deriving stock (Eq, Show, Generic) + +data SerializablePartContent + = -- | base64-encoded part content + SerializablePartContentText !Text + | SerializablePartContentNestedParts ![SerializableMailPart] + deriving stock (Eq, Show, Generic) + +data SerializablePartContentTag + = SerializablePartContentTextTag + | SerializablePartContentNestedPartsTag + deriving stock (Eq, Ord, Bounded, Enum, Show, Generic) + deriving (Arbitrary) via GenericUniform SerializablePartContentTag + +instance ToSchema SerializablePartContentTag where + schema = + enum @Text $ + mconcat + [ element "text" SerializablePartContentTextTag, + element "nested-parts" SerializablePartContentNestedPartsTag + ] + +serializablePartContentTag :: SerializablePartContent -> SerializablePartContentTag +serializablePartContentTag = + \case + SerializablePartContentText {} -> SerializablePartContentTextTag + SerializablePartContentNestedParts {} -> SerializablePartContentNestedPartsTag + +makePrisms ''SerializablePartContent + +-- NB: this schema is recursive (nested parts reference 'SerializableMailPart', +-- whose schema references this one), so it must never be inlined into an +-- OpenApi document (the bridge inlines properties and would loop); it exists +-- for the Aeson derivation only. +instance ToSchema SerializablePartContent where + schema = object serializablePartContentObjectSchema + +serializablePartContentObjectSchema :: ObjectSchema SwaggerDoc SerializablePartContent +serializablePartContentObjectSchema = + snd + <$> (serializablePartContentTag &&& id) + .= bind + (fst .= field "type" schema) + (snd .= dispatch serializablePartContentDataSchema) + where + serializablePartContentDataSchema :: SerializablePartContentTag -> ObjectSchema SwaggerDoc SerializablePartContent + serializablePartContentDataSchema = \case + SerializablePartContentTextTag -> + tag _SerializablePartContentText (field "content" schema) + SerializablePartContentNestedPartsTag -> + tag _SerializablePartContentNestedParts (field "content" (array schema)) + +deriving via (Schema SerializablePartContent) instance Aeson.ToJSON SerializablePartContent + +deriving via (Schema SerializablePartContent) instance Aeson.FromJSON SerializablePartContent + +instance Arbitrary SerializablePartContent where + arbitrary = + QC.sized $ \n -> + if n <= 0 + then SerializablePartContentText <$> arbitrary + else + QC.oneof + [ SerializablePartContentText <$> arbitrary, + SerializablePartContentNestedParts . getGenericUniform <$> QC.resize (n `div` 4) arbitrary + ] + shrink = QC.genericShrink + +deriving via (Schema SerializableMailPart) instance Aeson.ToJSON SerializableMailPart + +deriving via (Schema SerializableMailPart) instance Aeson.FromJSON SerializableMailPart + +deriving via GenericUniform SerializableMailPart instance Arbitrary SerializableMailPart + +instance ToSchema SerializableMailPart where + schema = + object $ + SerializableMailPart + <$> (.smpType) .= field "type" schema + <*> (.smpEncoding) .= field "encoding" schema + <*> (.smpDisposition) .= field "disposition" schema + <*> (.smpHeaders) .= field "headers" (array schema) + <*> (.smpContent) .= field "content" schema + +data SerializableMail = SerializableMail + { smFrom :: !SerializableMailAddress, + smTo :: ![SerializableMailAddress], + smCc :: ![SerializableMailAddress], + smBcc :: ![SerializableMailAddress], + smHeaders :: ![SerializableMailHeader], + smParts :: ![[SerializableMailPart]] + } + deriving stock (Eq, Show, Generic) + deriving (Aeson.ToJSON, Aeson.FromJSON) via (Schema SerializableMail) + deriving (Arbitrary) via GenericUniform SerializableMail + +instance ToSchema SerializableMail where + schema = + object $ + SerializableMail + <$> (.smFrom) .= field "from" schema + <*> (.smTo) .= field "to" (array schema) + <*> (.smCc) .= field "cc" (array schema) + <*> (.smBcc) .= field "bcc" (array schema) + <*> (.smHeaders) .= field "headers" (array schema) + <*> (.smParts) .= field "parts" (array (array schema)) + +data SendEmailJob = SendEmailJob + { sejMail :: !SerializableMail + } + deriving stock (Eq, Show, Generic) + deriving (Aeson.ToJSON, Aeson.FromJSON) via (Schema SendEmailJob) + deriving (Arbitrary) via GenericUniform SendEmailJob + +instance ToSchema SendEmailJob where + schema = + object $ + SendEmailJob + <$> (.sejMail) .= field "mail" schema diff --git a/libs/wire-api/wire-api.cabal b/libs/wire-api/wire-api.cabal index e7f4e0886e0..6129e0ec934 100644 --- a/libs/wire-api/wire-api.cabal +++ b/libs/wire-api/wire-api.cabal @@ -72,6 +72,7 @@ library Wire.API.ApplyMods Wire.API.Asset Wire.API.BackgroundJobs + Wire.API.BackgroundJobs.Email Wire.API.Bot Wire.API.Bot.Service Wire.API.Call.Config diff --git a/libs/wire-subsystems/src/Wire/BackgroundJobsRunner/Interpreter.hs b/libs/wire-subsystems/src/Wire/BackgroundJobsRunner/Interpreter.hs index 8fc5abdc680..d86fca527f1 100644 --- a/libs/wire-subsystems/src/Wire/BackgroundJobsRunner/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/BackgroundJobsRunner/Interpreter.hs @@ -45,6 +45,8 @@ import Wire.BackgroundJobsPublisher import Wire.BackgroundJobsRunner (BackgroundJobRunner (..)) import Wire.ConversationStore (ConversationStore, upsertMembers) import Wire.ConversationSubsystem +import Wire.EmailSending (EmailSending, sendMail) +import Wire.EmailSending.Queueing (fromSerializableMail) import Wire.Sem.Random import Wire.StoredConversation import Wire.UserGroupStore (UserGroupStore, getUserGroup, getUserGroupChannels) @@ -53,6 +55,7 @@ import Wire.UserList (toUserList) interpretBackgroundJobRunner :: ( Member UserGroupStore r, Member BackgroundJobPublisher r, + Member EmailSending r, Member (Input (Local ())) r, Member ConversationStore r, Member ConversationSubsystem r, @@ -66,6 +69,7 @@ interpretBackgroundJobRunner = interpret $ \case runBackgroundJob :: ( Member UserGroupStore r, Member BackgroundJobPublisher r, + Member EmailSending r, Member (Input (Local ())) r, Member ConversationStore r, Member ConversationSubsystem r, @@ -77,6 +81,13 @@ runBackgroundJob :: runBackgroundJob job = case job.payload of BackgroundJobSyncUserGroupAndChannel payload -> runSyncUserGroupAndChannel payload BackgroundJobSyncUserGroup payload -> runSyncUserGroup payload + BackgroundJobSendEmail payload -> case fromSerializableMail payload of + Left err -> + Log.warn $ + field "job_id" (toByteString job.jobId) + . field "error" err + . msg (val "Rejecting malformed email job") + Right mail -> sendMail mail runSyncUserGroupAndChannel :: ( Member UserGroupStore r, diff --git a/libs/wire-subsystems/src/Wire/EmailSending/Queueing.hs b/libs/wire-subsystems/src/Wire/EmailSending/Queueing.hs new file mode 100644 index 00000000000..f76ceeb4ec7 --- /dev/null +++ b/libs/wire-subsystems/src/Wire/EmailSending/Queueing.hs @@ -0,0 +1,240 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2026 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +-- | Queueing interpreter for the 'EmailSending' effect. +-- +-- Instead of sending mail directly (SMTP\/SES), this interpreter enqueues a +-- 'BackgroundJobSendEmail' job on the shared @background-jobs@ queue. The +-- actual send is performed by the background-worker (see +-- "Wire.BackgroundJobsRunner.Interpreter"). +-- +-- This is the single seam for *all* email sending in brig: every mail flows +-- through 'EmailSending', so interpreting it to a queue covers verification, +-- activation, password-reset, invitation, new-client, deletion, SAML IdP-change, +-- provider and enterprise-audit emails with one constructor. +module Wire.EmailSending.Queueing + ( emailViaQueueInterpreter, + toSerializableMail, + fromSerializableMail, + ) +where + +import Data.ByteString.Base64.Lazy qualified as B64 +import Data.ByteString.Lazy qualified as BL +import Data.Id (RequestId, randomId) +import Data.Text qualified as T +import Data.Text.Encoding qualified as Text +import Imports +import Network.AMQP qualified as Q +import Network.Mail.Mime + ( Address (..), + Disposition (..), + Encoding (..), + Mail (..), + Part (..), + PartContent (..), + ) +import Polysemy +import Wire.API.BackgroundJobs +import Wire.API.BackgroundJobs.Email +import Wire.BackgroundJobsPublisher.RabbitMQ qualified as Publisher +import Wire.EmailSending (EmailSending (SendMail)) + +-- | Interpret 'EmailSending' by enqueuing a 'BackgroundJobSendEmail' job. +-- +-- The job id is minted with 'randomId' and the message is published directly to +-- the @background-jobs@ queue via the channel-level 'Publisher.publishJob'. This +-- keeps the interpreter's only effect requirement 'Embed' 'IO', so it drops into +-- the producer's effect stack exactly where the old direct-send interpreter sat +-- (it needs neither 'Random' nor 'BackgroundJobPublisher' to be present at that +-- point in the stack). +emailViaQueueInterpreter :: + (Member (Embed IO) r) => + RequestId -> + MVar Q.Channel -> + InterpreterFor EmailSending r +emailViaQueueInterpreter requestId channelMVar = + interpret \case + SendMail mail -> do + channel <- embed (readMVar channelMVar) + jobId <- embed (randomId @IO) + Publisher.publishJob requestId channel jobId (BackgroundJobSendEmail (toSerializableMail mail)) + +-------------------------------------------------------------------------------- +-- Mail <-> record conversion +-------------------------------------------------------------------------------- + +toSerializableMail :: Mail -> SendEmailJob +toSerializableMail mail = SendEmailJob {sejMail = fromMail mail} + +-- | Reconstruct a 'Mail' from a deserialized job. +-- +-- The job comes off an internal queue, but this is defense in depth: rather +-- than trusting it, the conversion rejects jobs whose part nesting exceeds +-- 'maxPartNesting', whose flat content is not strictly valid base64, or whose +-- header-rendered fields contain CR\/LF\/NUL (header injection). Anything +-- produced by 'toSerializableMail' always decodes. +fromSerializableMail :: SendEmailJob -> Either Text Mail +fromSerializableMail job = toMail job.sejMail + +fromMail :: Mail -> SerializableMail +fromMail m = + SerializableMail + { smFrom = fromAddress m.mailFrom, + smTo = fromAddress <$> m.mailTo, + smCc = fromAddress <$> m.mailCc, + smBcc = fromAddress <$> m.mailBcc, + smHeaders = fromHeader <$> m.mailHeaders, + smParts = (fromPart <$>) <$> m.mailParts + } + +toMail :: SerializableMail -> Either Text Mail +toMail m = do + mailFrom <- toAddress m.smFrom + mailTo <- traverse toAddress m.smTo + mailCc <- traverse toAddress m.smCc + mailBcc <- traverse toAddress m.smBcc + mailHeaders <- traverse toHeader m.smHeaders + mailParts <- traverse (traverse (toPart 0)) m.smParts + pure + Mail + { mailFrom = mailFrom, + mailTo = mailTo, + mailCc = mailCc, + mailBcc = mailBcc, + mailHeaders = mailHeaders, + mailParts = mailParts + } + +fromAddress :: Address -> SerializableMailAddress +fromAddress a = + SerializableMailAddress {smaName = a.addressName, smaEmail = a.addressEmail} + +toAddress :: SerializableMailAddress -> Either Text Address +toAddress a = do + addressName <- traverse (validateHeaderField "address name") a.smaName + addressEmail <- validateHeaderField "address email" a.smaEmail + pure Address {addressName = addressName, addressEmail = addressEmail} + +-- | mime-mail headers are @[(ByteString, Text)]@: the name is a (ASCII) +-- ByteString, the value is already 'Text'. +fromHeader :: (ByteString, Text) -> SerializableMailHeader +fromHeader (name, value) = + SerializableMailHeader {smhName = Text.decodeUtf8 name, smhValue = value} + +toHeader :: SerializableMailHeader -> Either Text (ByteString, Text) +toHeader h = do + name <- validateHeaderField "header name" h.smhName + value <- validateHeaderField "header value" h.smhValue + pure (Text.encodeUtf8 name, value) + +fromPart :: Part -> SerializableMailPart +fromPart p = + SerializableMailPart + { smpType = p.partType, + smpEncoding = fromEncoding p.partEncoding, + smpDisposition = fromDisposition p.partDisposition, + smpHeaders = fromHeader <$> p.partHeaders, + smpContent = encodeContent p.partContent + } + +toPart :: Int -> SerializableMailPart -> Either Text Part +toPart depth p + | depth > maxPartNesting = Left "part nesting deeper than the maximum" + | otherwise = do + partType <- validateHeaderField "part type" p.smpType + partDisposition <- toDisposition p.smpDisposition + partHeaders <- traverse toHeader p.smpHeaders + partContent <- decodeContent depth p.smpContent + pure + Part + { partType = partType, + partEncoding = toEncoding p.smpEncoding, + partDisposition = partDisposition, + partHeaders = partHeaders, + partContent = partContent + } + +fromEncoding :: Encoding -> SerializableEncoding +fromEncoding = \case + None -> SerializableEncodingNone + Base64 -> SerializableEncodingBase64 + QuotedPrintableBinary -> SerializableEncodingQuotedPrintableBinary + QuotedPrintableText -> SerializableEncodingQuotedPrintableText + +toEncoding :: SerializableEncoding -> Encoding +toEncoding = \case + SerializableEncodingNone -> None + SerializableEncodingBase64 -> Base64 + SerializableEncodingQuotedPrintableBinary -> QuotedPrintableBinary + SerializableEncodingQuotedPrintableText -> QuotedPrintableText + +fromDisposition :: Disposition -> SerializableDisposition +fromDisposition = \case + DefaultDisposition -> + SerializableDisposition {smdType = SerializableDispositionDefault, smdFilename = ""} + InlineDisposition filename -> + SerializableDisposition {smdType = SerializableDispositionInline, smdFilename = filename} + AttachmentDisposition filename -> + SerializableDisposition {smdType = SerializableDispositionAttachment, smdFilename = filename} + +toDisposition :: SerializableDisposition -> Either Text Disposition +toDisposition d = case d.smdType of + -- The filename is dropped by DefaultDisposition (never rendered), but it is + -- validated anyway to keep every Text field on a SerializableMail* free of + -- CR/LF/NUL, uniformly. + SerializableDispositionDefault -> + DefaultDisposition <$ validateHeaderField "disposition filename" d.smdFilename + SerializableDispositionInline -> + InlineDisposition <$> validateHeaderField "disposition filename" d.smdFilename + SerializableDispositionAttachment -> + AttachmentDisposition <$> validateHeaderField "disposition filename" d.smdFilename + +-- | Encode a part's content for serialization. Flat byte content becomes +-- base64 'Text'; nested alternative groups recurse via 'fromPart'. The +-- conversion is total, so any 'Mail' round-trips through the jobs queue. +encodeContent :: PartContent -> SerializablePartContent +encodeContent = \case + PartContent bs -> SerializablePartContentText (Text.decodeUtf8 . BL.toStrict $ B64.encode bs) + NestedParts ps -> SerializablePartContentNestedParts (fromPart <$> ps) + +-- | Inverse of 'encodeContent'. Nested alternative groups recurse one level +-- deeper (bounded by 'maxPartNesting' via 'toPart'); flat content must decode +-- as strict base64, which anything produced by 'encodeContent' is. +decodeContent :: Int -> SerializablePartContent -> Either Text PartContent +decodeContent depth = \case + SerializablePartContentText t -> case B64.decode (BL.fromStrict (Text.encodeUtf8 t)) of + Left err -> Left ("invalid base64 in part content: " <> T.pack err) + Right bs -> Right (PartContent bs) + SerializablePartContentNestedParts ps -> NestedParts <$> traverse (toPart (depth + 1)) ps + +-- | Maximum nesting depth of parts (0 = top-level) accepted by 'toPart'. +-- Mails built with the mime-mail smart constructors nest at most two or three +-- levels; anything deeper on the queue is malformed or adversarial. +maxPartNesting :: Int +maxPartNesting = 10 + +-- | Validate a field that mime-mail renders into an RFC 5322 header position +-- (address names\/emails, header names\/values, part type, disposition +-- filename). CR, LF or NUL would allow a malformed job to inject additional +-- headers or body parts. Producers never emit these; checking is defense in +-- depth for jobs read off the queue. +validateHeaderField :: Text -> Text -> Either Text Text +validateHeaderField fieldName value + | T.any (\c -> c == '\r' || c == '\n' || c == '\0') value = + Left (fieldName <> " contains CR/LF/NUL") + | otherwise = Right value diff --git a/libs/wire-subsystems/test/unit/Wire/EmailSendingQueueingSpec.hs b/libs/wire-subsystems/test/unit/Wire/EmailSendingQueueingSpec.hs new file mode 100644 index 00000000000..81697608b56 --- /dev/null +++ b/libs/wire-subsystems/test/unit/Wire/EmailSendingQueueingSpec.hs @@ -0,0 +1,248 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2025 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +-- | Unit tests for the email queueing conversion ('Wire.EmailSending.Queueing') +-- and the 'SendEmailJob' payload serialization. +-- +-- These cover the data path shared by the producer (brig enqueues a +-- 'BackgroundJobSendEmail') and the consumer (the background-worker reconstructs +-- the 'Mail' and sends it): the @Mail@ <-> 'SendEmailJob' conversion must be a +-- round-trip, and the job must survive JSON encoding/decoding through the +-- @background-jobs@ queue. +module Wire.EmailSendingQueueingSpec (spec) where + +import Data.Aeson qualified as Aeson +import Data.Text.Lazy qualified as LT +import Imports +import Network.Mail.Mime + ( Address (..), + Mail (..), + Part (..), + PartContent (..), + emptyMail, + htmlPart, + plainPart, + ) +import Test.Hspec +import Test.QuickCheck +import Wire.API.BackgroundJobs.Email +import Wire.EmailSending.Queueing + +spec :: Spec +spec = do + describe "toSerializableMail / fromSerializableMail" $ do + it "round-trips Mail -> SerializableMail -> Mail -> SerializableMail" $ do + let job = toSerializableMail sampleMail + toSerializableMail <$> fromSerializableMail job `shouldBe` Right job + + it "preserves all address lists, headers and parts" $ do + let sm = (toSerializableMail sampleMail).sejMail + sm.smFrom `shouldBe` smaFrom + sm.smTo `shouldBe` [smaTo] + sm.smCc `shouldBe` [SerializableMailAddress Nothing "cc@example.com"] + sm.smBcc `shouldBe` [] + sm.smHeaders + `shouldBe` [ SerializableMailHeader "Subject" "Verify your email", + SerializableMailHeader "X-Foo" "bar" + ] + length sm.smParts `shouldBe` 1 + length (concat sm.smParts) `shouldBe` 2 + + -- Exercises the non-default disposition branches (Inline/Attachment carry a + -- filename) via the public conversion API, since brig's render path only + -- produces DefaultDisposition. + it "round-trips Inline/Attachment dispositions and all encodings" $ do + toSerializableMail <$> fromSerializableMail variantJob `shouldBe` Right variantJob + + it "round-trips nested parts (NestedParts) through Mail and JSON" $ do + let job = toSerializableMail nestedMail + toSerializableMail <$> fromSerializableMail job `shouldBe` Right job + Aeson.decode (Aeson.encode job) `shouldBe` Just job + + it "decodes a job nested to the maximum allowed depth" $ do + fromSerializableMail (nestedJobAtDepth 10) `shouldSatisfy` isRight + + -- Defense in depth at the worker boundary: anything malformed read off + -- the queue is rejected instead of rendered and sent. + it "rejects a job nested deeper than the maximum" $ do + fromSerializableMail (nestedJobAtDepth 11) `shouldSatisfy` isLeft + + it "rejects flat content that is not valid base64" $ do + let job = SendEmailJob {sejMail = sampleJob.sejMail {smParts = [[partWithContent (SerializablePartContentText "not base64!!!")]]}} + fromSerializableMail job `shouldSatisfy` isLeft + + -- One case per call site of 'validateHeaderField', so a future refactor + -- that drops one (e.g. a missing 'traverse' over 'smaName') fails here. + it "rejects NUL in every header-rendered field" $ do + let base = sampleJob.sejMail + okPart = partWithContent (SerializablePartContentText "aGk=") + withMail mail = SendEmailJob {sejMail = mail} + jobs :: [SendEmailJob] + jobs = + [ withMail base {smFrom = base.smFrom {smaName = Just "Wire\0"}}, + withMail base {smTo = [base.smFrom {smaEmail = "evil\0@example.com"}]}, + withMail base {smParts = [[okPart {smpType = "text/plain\0"}]]}, + withMail + base + { smParts = + [ [ okPart + { smpDisposition = + SerializableDisposition {smdType = SerializableDispositionInline, smdFilename = "evil\0.txt"} + } + ] + ] + }, + withMail + base + { smParts = + [ [ okPart + { smpDisposition = + SerializableDisposition {smdType = SerializableDispositionDefault, smdFilename = "evil\0.txt"} + } + ] + ] + } + ] + mapM_ (\job -> fromSerializableMail job `shouldSatisfy` isLeft) jobs + + it "rejects CR/LF in header-rendered fields" $ do + let job = + SendEmailJob + { sejMail = + sampleJob.sejMail + { smHeaders = [SerializableMailHeader "Subject" "hi\r\nBcc: evil@example.com"] + } + } + fromSerializableMail job `shouldSatisfy` isLeft + + describe "SendEmailJob JSON serialization" $ do + it "round-trips the sample job through Aeson" $ do + let job = toSerializableMail sampleMail + Aeson.decode (Aeson.encode job) `shouldBe` Just job + + it "decoding a serialized job yields a job that round-trips back to itself" $ do + let job = toSerializableMail sampleMail + decoded = Aeson.decode (Aeson.encode job) :: Maybe SendEmailJob + (fmap toSerializableMail . fromSerializableMail <$> decoded) `shouldBe` Just (Right job) + + -- Exercises the wire-api schema machinery (record fields, nested lists, + -- and the encoding/disposition enums) for arbitrary payloads. + it "encode . decode = id for arbitrary SendEmailJob" $ + property $ \(job :: SendEmailJob) -> + Aeson.decode @SendEmailJob (Aeson.encode job) === Just job + +-- | A mail shaped exactly like the ones brig builds (see +-- 'Wire.EmailSubsystem.Interpreter'): one alternative with a plain and an html +-- part, @to@/@cc@ addresses, and a couple of headers. +sampleMail :: Mail +sampleMail = + (emptyMail smaFromMail) + { mailTo = [smaToMail], + mailCc = [Address Nothing "cc@example.com"], + mailBcc = [], + mailHeaders = + [ ("Subject", "Verify your email"), + ("X-Foo", "bar") + ], + mailParts = + [ [ plainPart (LT.pack "Please verify your email."), + htmlPart (LT.fromStrict "

Please verify your email.

") + ] + ] + } + where + smaFromMail = Address (Just "Wire") "noreply@example.com" + smaToMail = Address (Just "Alice") "alice@example.com" + +-- | A mail whose single part carries nested sub-parts — the structure +-- 'encodeContent' must now handle instead of erroring. +nestedMail :: Mail +nestedMail = sampleMail {mailParts = [[nestedPart]]} + where + nestedPart = + (plainPart (LT.pack "outer")) + { partContent = NestedParts [plainPart (LT.pack "inner plain"), htmlPart (LT.pack "

inner html

")] + } + +sampleJob :: SendEmailJob +sampleJob = toSerializableMail sampleMail + +-- | A job whose single part's content is nested @n@ levels deep (n +-- 'SerializablePartContentNestedParts' wrappers around base64 text). +nestedJobAtDepth :: Int -> SendEmailJob +nestedJobAtDepth n = + SendEmailJob {sejMail = sampleJob.sejMail {smParts = [[partAtDepth n]]}} + where + partAtDepth :: Int -> SerializableMailPart + partAtDepth 0 = partWithContent (SerializablePartContentText "aGk=") + partAtDepth k = partWithContent (SerializablePartContentNestedParts [partAtDepth (k - 1)]) + +partWithContent :: SerializablePartContent -> SerializableMailPart +partWithContent content = + SerializableMailPart + { smpType = "text/plain", + smpEncoding = SerializableEncodingNone, + smpDisposition = SerializableDisposition {smdType = SerializableDispositionDefault, smdFilename = ""}, + smpHeaders = [], + smpContent = content + } + +-- | A job with non-default dispositions (Inline/Attachment, which carry a +-- filename) and encodings other than the default, to exercise those branches. +variantJob :: SendEmailJob +variantJob = + SendEmailJob + { sejMail = + SerializableMail + { smFrom = smaFrom, + smTo = [smaTo], + smCc = [], + smBcc = [], + smHeaders = [SerializableMailHeader "Subject" "Attachments"], + smParts = + [ [ SerializableMailPart + { smpType = "image/png", + smpEncoding = SerializableEncodingBase64, + smpDisposition = + SerializableDisposition + { smdType = SerializableDispositionInline, + smdFilename = "logo.png" + }, + smpHeaders = [], + smpContent = SerializablePartContentText "iVBORw0KGgo=" + }, + SerializableMailPart + { smpType = "application/pdf", + smpEncoding = SerializableEncodingQuotedPrintableText, + smpDisposition = + SerializableDisposition + { smdType = SerializableDispositionAttachment, + smdFilename = "doc.pdf" + }, + smpHeaders = [SerializableMailHeader "Content-ID" ""], + smpContent = SerializablePartContentText "JVBERi0=" + } + ] + ] + } + } + +smaFrom :: SerializableMailAddress +smaFrom = SerializableMailAddress {smaName = Just "Wire", smaEmail = "noreply@example.com"} + +smaTo :: SerializableMailAddress +smaTo = SerializableMailAddress {smaName = Just "Alice", smaEmail = "alice@example.com"} diff --git a/libs/wire-subsystems/wire-subsystems.cabal b/libs/wire-subsystems/wire-subsystems.cabal index 42196d6e18c..78535b38f28 100644 --- a/libs/wire-subsystems/wire-subsystems.cabal +++ b/libs/wire-subsystems/wire-subsystems.cabal @@ -332,6 +332,7 @@ library Wire.DomainVerificationChallengeStore.Postgres Wire.EmailSending Wire.EmailSending.Options + Wire.EmailSending.Queueing Wire.EmailSending.SES Wire.EmailSending.SMTP Wire.EmailSubsystem @@ -636,6 +637,7 @@ test-suite wire-subsystems-tests Wire.ConversationSubsystem.InterpreterSpec Wire.ConversationSubsystem.MessageSpec Wire.ConversationSubsystem.One2OneSpec + Wire.EmailSendingQueueingSpec Wire.EmailSubsystem.TemplateFixtures Wire.EmailSubsystem.TemplateSpec Wire.EnterpriseLoginSubsystem.InterpreterSpec diff --git a/services/background-worker/background-worker.cabal b/services/background-worker/background-worker.cabal index a43796a4ca7..48fb2dd49e0 100644 --- a/services/background-worker/background-worker.cabal +++ b/services/background-worker/background-worker.cabal @@ -36,6 +36,8 @@ library build-depends: aeson + , amazonka + , amazonka-ses , amqp , arbiter-core , arbiter-worker diff --git a/services/background-worker/background-worker.integration.yaml b/services/background-worker/background-worker.integration.yaml index e264ce14016..635528bd7f4 100644 --- a/services/background-worker/background-worker.integration.yaml +++ b/services/background-worker/background-worker.integration.yaml @@ -45,6 +45,12 @@ rabbitmq: caCert: test/resources/rabbitmq-ca.pem insecureSkipVerifyTls: false +# Email transport for the background-worker (same shape as brig's emailSMS.email). +# SES takes precedence over SMTP when both are configured. +email: + sesQueue: integration-brig-events + sesEndpoint: http://localhost:4569 # https://email.eu-west-1.amazonaws.com + backendNotificationPusher: pushBackoffMinWait: 1000 # 1ms pushBackoffMaxWait: 1000000 # 1s diff --git a/services/background-worker/default.nix b/services/background-worker/default.nix index acf79b6e195..a98c39287a0 100644 --- a/services/background-worker/default.nix +++ b/services/background-worker/default.nix @@ -4,6 +4,8 @@ # dependencies are added or removed. { mkDerivation , aeson +, amazonka +, amazonka-ses , amqp , arbiter-core , arbiter-worker @@ -67,6 +69,8 @@ mkDerivation { isExecutable = true; libraryHaskellDepends = [ aeson + amazonka + amazonka-ses amqp arbiter-core arbiter-worker diff --git a/services/background-worker/src/Wire/BackgroundWorker/Env.hs b/services/background-worker/src/Wire/BackgroundWorker/Env.hs index ed784a33db9..bebfc6abbc4 100644 --- a/services/background-worker/src/Wire/BackgroundWorker/Env.hs +++ b/services/background-worker/src/Wire/BackgroundWorker/Env.hs @@ -20,6 +20,8 @@ module Wire.BackgroundWorker.Env where +import Amazonka qualified +import Amazonka.SES qualified as SES import Cassandra (ClientState) import Cassandra.Util (defInitCassandra) import Control.Monad.Base @@ -51,6 +53,8 @@ import Wire.API.Conversation.Protocol (ProtocolTag) import Wire.API.Team.Feature (LegalholdConfig, npProject) import Wire.API.Team.FeatureFlags (FanoutLimit, FeatureFlags) import Wire.BackgroundWorker.Options +import Wire.EmailSending.Options qualified as EmailOpt +import Wire.EmailSending.SMTP qualified as SMTP import Wire.JobSubsystem.Migrations (mkArbiterConnectionString) import Wire.Options.Galley (GuestLinkTTLSeconds, conversationCodeURISettings) import Wire.Options.Galley qualified as Galley @@ -73,6 +77,10 @@ workerName = \case DeadUserNotificationWatcher -> "dead-user-notification-watcher" BackgroundJobConsumer -> "background-job-consumer" +-- | The configured outbound email transport. Exactly one is built from +-- 'Opts.email' (a required sum), so the "no transport" state is unrepresentable. +data EmailTransport = EmailTransportSMTP !SMTP.SMTP | EmailTransportSES !Amazonka.Env + data Env = Env { http2Manager :: Http2Manager, rabbitmqAdminClient :: Maybe (RabbitMqAdmin.AdminAPI (Servant.AsClientT IO)), @@ -113,7 +121,8 @@ data Env = Env passwordHashingOptions :: !PasswordHashingOptions, checkGroupInfo :: !(Maybe Bool), convCodeURI :: Either HttpsUrl (Map Domain HttpsUrl), - passwordHashingRateLimitEnv :: RateLimitEnv + passwordHashingRateLimitEnv :: RateLimitEnv, + emailTransport :: EmailTransport } data BackendNotificationMetrics = BackendNotificationMetrics @@ -217,6 +226,20 @@ mkEnv opts galleyOpts = do listClientsUsingBrig = galleyOpts._settings._intraListing } passwordHashingRateLimitEnv <- newRateLimitEnv galleyOpts._settings._passwordHashingRateLimit + emailTransport <- case opts.email of + EmailOpt.EmailSMTP s -> do + let smtpHost = s.smtpEndpoint.host + smtpPort = Just (fromIntegral s.smtpEndpoint.port) + smtpCredentials <- case EmailOpt.smtpCredentials s of + Just (EmailOpt.EmailSMTPCredentials u pwd) -> + Just . (SMTP.Username u,) . SMTP.Password <$> initCredentials pwd + _ -> pure Nothing + EmailTransportSMTP <$> SMTP.initSMTP logger smtpHost smtpPort smtpCredentials s.smtpConnType + EmailOpt.EmailAWS aws -> do + let AWSEndpoint {..} = aws.sesEndpoint + sesEndpoint = + Amazonka.setEndpoint _awsSecure _awsHost _awsPort SES.defaultService + EmailTransportSES <$> (Amazonka.newEnv Amazonka.discover <&> Amazonka.configureService sesEndpoint) Log.info logger $ Log.msg @Text "Environment initialized" pure Env {..} diff --git a/services/background-worker/src/Wire/BackgroundWorker/Jobs/Registry.hs b/services/background-worker/src/Wire/BackgroundWorker/Jobs/Registry.hs index abb737a95a0..04ab9bf1022 100644 --- a/services/background-worker/src/Wire/BackgroundWorker/Jobs/Registry.hs +++ b/services/background-worker/src/Wire/BackgroundWorker/Jobs/Registry.hs @@ -20,6 +20,8 @@ module Wire.BackgroundWorker.Jobs.Registry ) where +import Control.Exception (try) +import Data.Text qualified as T import Imports import Wire.API.BackgroundJobs (BackgroundJob (..)) import Wire.BackgroundJobsPublisher.RabbitMQ (interpretBackgroundJobPublisherRabbitMQ) @@ -34,8 +36,13 @@ dispatchJob job = do env <- ask @Env let disableTlsV1 = True extEnv <- liftIO (initExtEnv disableTlsV1) - liftIO - $ runBackgroundWorkerEffects env extEnv job.requestId (Just job.jobId) - . interpretBackgroundJobPublisherRabbitMQ job.requestId env.amqpJobsPublisherChannel - . interpretBackgroundJobRunner - $ runJob job + liftIO $ + try @SomeException + ( runBackgroundWorkerEffects env extEnv job.requestId (Just job.jobId) + . interpretBackgroundJobPublisherRabbitMQ job.requestId env.amqpJobsPublisherChannel + . interpretBackgroundJobRunner + $ runJob job + ) + >>= \case + Right r -> pure r + Left e -> pure (Left (T.pack (displayException e))) diff --git a/services/background-worker/src/Wire/BackgroundWorker/Options.hs b/services/background-worker/src/Wire/BackgroundWorker/Options.hs index 61df5d5d14f..5434e4f13e7 100644 --- a/services/background-worker/src/Wire/BackgroundWorker/Options.hs +++ b/services/background-worker/src/Wire/BackgroundWorker/Options.hs @@ -30,6 +30,7 @@ import Network.AMQP.Extended import System.Cron (CronSchedule, parseCronSchedule) import System.Logger.Extended import Util.Options +import Wire.EmailSending.Options (EmailOpts) import Wire.Migration import Wire.PostgresMigrationOpts @@ -57,7 +58,8 @@ data Opts = Opts migrateDomainRegistration :: !Bool, jobs :: JobConfig, meetingsCleanup :: MeetingsCleanupConfig, - backgroundJobs :: BackgroundJobsConfig + backgroundJobs :: BackgroundJobsConfig, + email :: !EmailOpts } deriving (Show, Generic) deriving (FromJSON) via Generically Opts diff --git a/services/background-worker/src/Wire/Effects.hs b/services/background-worker/src/Wire/Effects.hs index 66dbee09c56..1b54f616b27 100644 --- a/services/background-worker/src/Wire/Effects.hs +++ b/services/background-worker/src/Wire/Effects.hs @@ -64,7 +64,7 @@ import Wire.API.Team.Feature (AllTeamFeatures, LegalholdConfig) import Wire.API.Team.FeatureFlags (FanoutLimit, FeatureDefaults, FeatureFlags, currentFanoutLimit) import Wire.BackendNotificationQueueAccess (BackendNotificationQueueAccess) import Wire.BackendNotificationQueueAccess.RabbitMq qualified as BackendNotificationQueueAccess -import Wire.BackgroundWorker.Env (Env (..)) +import Wire.BackgroundWorker.Env (EmailTransport (..), Env (..)) import Wire.BrigAPIAccess (BrigAPIAccess) import Wire.BrigAPIAccess.Rpc import Wire.ClientSubsystem.Error (ClientError) @@ -76,6 +76,9 @@ import Wire.ConversationStore (ConversationStore, MLSCommitLockStore) import Wire.ConversationStore.Cassandra (MigrationError (..), interpretConversationStoreByMigration, interpretMLSCommitLockStoreToCassandra) import Wire.ConversationSubsystem (ConversationSubsystem) import Wire.ConversationSubsystem.Interpreter (ConversationSubsystemError, GroupInfoCheckEnabled (..), IntraListing (..), interpretConversationSubsystem) +import Wire.EmailSending (EmailSending) +import Wire.EmailSending.SES (emailViaSESInterpreter) +import Wire.EmailSending.SMTP (emailViaSMTPInterpreter) import Wire.ExternalAccess (ExternalAccess) import Wire.ExternalAccess.External import Wire.FeaturesConfigSubsystem (FeaturesConfigSubsystem, getAllTeamFeaturesForServer) @@ -192,7 +195,8 @@ makeVerifiedRequestFreshManagerIO logger fpr url reqBuilder = do makeVerifiedRequestWithManagerIO logger mgr verifyFingerprints fpr url reqBuilder type BackgroundWorkerEffects = - '[ ConversationSubsystem, + '[ EmailSending, + ConversationSubsystem, MeetingNotifier, TeamCollaboratorsSubsystem, Input AllTeamFeatures, @@ -370,6 +374,7 @@ runBackgroundWorkerEffects env extEnv requestId mJobId = . interpretTeamCollaboratorsSubsystem (interpretBrigAccess env.brigEndpoint) . discardMeetingNotifier . interpretConversationSubsystem + . emailSendingInterpreter env where interpretTeamFeatureStore = case env.postgresMigration.teamFeatures of CassandraStorage -> interpretTeamFeatureStoreToCassandra @@ -413,3 +418,13 @@ runBackgroundWorkerEffects env extEnv requestId mJobId = case mJobId of Nothing -> field "request" (unRequestId requestId) Just jId -> field "request" (unRequestId requestId) . field "job" (idToText jId) + +-- | Interpret 'EmailSending' for the background-worker: SMTP or SES, whichever +-- transport 'mkEnv' built from the required @email@ config (a sum, so the +-- "no transport" state is unrepresentable). Send failures are raised as IO +-- exceptions and are converted to @'Left' 'Text'@ at the 'dispatchJob' +-- boundary, so they flow through the consumer's bounded retry and DLQ. +emailSendingInterpreter :: (Member (Embed IO) r) => Env -> InterpreterFor EmailSending r +emailSendingInterpreter env = case env.emailTransport of + EmailTransportSMTP smtp -> emailViaSMTPInterpreter env.logger smtp + EmailTransportSES ses -> emailViaSESInterpreter ses diff --git a/services/background-worker/test/Test/Wire/BackendNotificationPusherSpec.hs b/services/background-worker/test/Test/Wire/BackendNotificationPusherSpec.hs index 7222120d93a..4e289bc6c78 100644 --- a/services/background-worker/test/Test/Wire/BackendNotificationPusherSpec.hs +++ b/services/background-worker/test/Test/Wire/BackendNotificationPusherSpec.hs @@ -364,6 +364,7 @@ spec = do hasqlPool = undefined amqpJobsPublisherChannel = undefined amqpBackendNotificationsChannel = undefined + emailTransport = undefined federationDomain = Domain "local" postgresMigration = PostgresMigrationOpts @@ -428,6 +429,7 @@ spec = do hasqlPool = undefined amqpJobsPublisherChannel = undefined amqpBackendNotificationsChannel = undefined + emailTransport = undefined federationDomain = Domain "local" postgresMigration = PostgresMigrationOpts diff --git a/services/background-worker/test/Test/Wire/Util.hs b/services/background-worker/test/Test/Wire/Util.hs index 5d89532bfec..b966812dc0f 100644 --- a/services/background-worker/test/Test/Wire/Util.hs +++ b/services/background-worker/test/Test/Wire/Util.hs @@ -70,6 +70,7 @@ testEnv = do } hasqlPool = undefined amqpJobsPublisherChannel = undefined + emailTransport = undefined amqpBackendNotificationsChannel = undefined federationDomain = Domain "local" gundeckEndpoint = undefined diff --git a/services/brig/src/Brig/App.hs b/services/brig/src/Brig/App.hs index 27812d06b47..88e0b582a6d 100644 --- a/services/brig/src/Brig/App.hs +++ b/services/brig/src/Brig/App.hs @@ -44,7 +44,6 @@ module Brig.App wireServerEnterpriseEndpointLens, casClientLens, hasqlPoolLens, - smtpEnvLens, emailSenderLens, awsEnvLens, appLoggerLens, @@ -171,7 +170,6 @@ import Wire.API.User.Identity import Wire.AuthenticationSubsystem.Config (ZAuthEnv) import Wire.AuthenticationSubsystem.Config qualified as AuthenticationSubsystem import Wire.EmailSending.Options qualified as EmailOpt -import Wire.EmailSending.SMTP qualified as SMTP import Wire.EmailSubsystem.Template (Localised, TemplateBranding, forLocale) import Wire.EmailSubsystem.Templates.User import Wire.ExternalAccess.External @@ -201,7 +199,6 @@ data Env = Env wireServerEnterpriseEndpoint :: Maybe Endpoint, casClient :: Cas.ClientState, hasqlPool :: HasqlPool.Pool, - smtpEnv :: Maybe SMTP.SMTP, emailSender :: EmailAddress, awsEnv :: AWS.Env, appLogger :: Logger, @@ -270,7 +267,7 @@ newEnv opts = do ttp <- loadTeamTemplatesWithBrigOpts opts let branding = genTemplateBranding . Opt.templateBranding . Opt.general . Opt.emailSMS $ opts brandingAsMap = genTemplateBrandingMap . Opt.templateBranding . Opt.general . Opt.emailSMS $ opts - (emailAWSOpts, emailSMTP) <- emailConn lgr $ Opt.email (Opt.emailSMS opts) + emailAWSOpts <- emailConn $ Opt.email (Opt.emailSMS opts) aws <- AWS.mkEnv lgr (Opt.aws opts) emailAWSOpts mgr zau <- initZAuth opts clock <- mkAutoUpdate defaultUpdateSettings {updateAction = getCurrentTime} @@ -320,7 +317,6 @@ newEnv opts = do wireServerEnterpriseEndpoint = opts.wireServerEnterprise, casClient = cas, hasqlPool = hasqlPool, - smtpEnv = emailSMTP, emailSender = opts.emailSMS.general.emailSender, awsEnv = aws, -- used by `journalEvent` directly appLogger = lgr, @@ -354,16 +350,8 @@ newEnv opts = do postgresMigration = opts.postgresMigration } where - emailConn _ (EmailOpt.EmailAWS aws) = pure (Just aws, Nothing) - emailConn lgr (EmailOpt.EmailSMTP s) = do - let h = s.smtpEndpoint.host - p = Just . fromInteger . toInteger $ s.smtpEndpoint.port - smtpCredentials <- case EmailOpt.smtpCredentials s of - Just (EmailOpt.EmailSMTPCredentials u p') -> do - Just . (SMTP.Username u,) . SMTP.Password <$> initCredentials p' - _ -> pure Nothing - smtp <- SMTP.initSMTP lgr h p smtpCredentials (EmailOpt.smtpConnType s) - pure (Nothing, Just smtp) + emailConn (EmailOpt.EmailAWS aws) = pure (Just aws) + emailConn (EmailOpt.EmailSMTP _) = pure Nothing mkEndpoint service = RPC.host (encodeUtf8 service.host) . RPC.port service.port $ RPC.empty mkIndexEnv :: ElasticSearchOpts -> Logger -> Endpoint -> Manager -> IO IndexEnv diff --git a/services/brig/src/Brig/CanonicalInterpreter.hs b/services/brig/src/Brig/CanonicalInterpreter.hs index 4414567c910..f462fff180d 100644 --- a/services/brig/src/Brig/CanonicalInterpreter.hs +++ b/services/brig/src/Brig/CanonicalInterpreter.hs @@ -89,8 +89,7 @@ import Wire.DomainVerificationChallengeStore.Cassandra import Wire.DomainVerificationChallengeStore.DualWrite (interpretDomainVerificationChallengeStoreToCassandraAndPostgres) import Wire.DomainVerificationChallengeStore.Postgres (interpretDomainVerificationChallengeStoreToPostgres) import Wire.EmailSending -import Wire.EmailSending.SES -import Wire.EmailSending.SMTP +import Wire.EmailSending.Queueing (emailViaQueueInterpreter) import Wire.EmailSubsystem import Wire.EmailSubsystem.Interpreter import Wire.EnterpriseLoginSubsystem @@ -451,7 +450,7 @@ runBrigToIO e (AppT ma) = do . interpretClientToIO e.casClient . runMetricsToIO . runRpcWithHttp e.httpManager e.requestId - . emailSendingInterpreter e + . emailViaQueueInterpreter e.requestId e.amqpJobsPublisherChannel . interpretSparAPIAccessToRpc e.sparEndpoint . interpretGalleyAPIAccessToRpc e.disabledVersions e.galleyEndpoint . passwordResetCodeStoreToCassandra @Cas.Client @@ -559,9 +558,3 @@ rethrowHttpErrorIO act = do case eithError of Left err -> embedToFinal $ throwM $ err Right a -> pure a - -emailSendingInterpreter :: (Member (Embed IO) r) => Env -> InterpreterFor EmailSending r -emailSendingInterpreter e = do - case e.smtpEnv of - Just smtp -> emailViaSMTPInterpreter e.appLogger smtp - Nothing -> emailViaSESInterpreter (e.awsEnv ^. amazonkaEnv) From 3a7730d0cfd45603bb0e6337d898236f4bd2fb83 Mon Sep 17 00:00:00 2001 From: Gautier DI FOLCO Date: Tue, 25 Aug 2026 17:50:37 +0200 Subject: [PATCH 2/7] WPB-27255: queue email jobs via Arbiter instead of RabbitMQ Rework of the email background-worker move: brig now inserts send-email jobs into the new `emails` Arbiter queue (PostgreSQL, default Arbiter schema) instead of publishing BackgroundJobSendEmail messages to the RabbitMQ `background-jobs` queue. - Wire.API.Jobs: new `emails` queue with EmailsJobPayload/SendEmailJobPayload (request id + SerializableMail), added to JobRegistry; the RabbitMQ BackgroundJobPayload loses its send-email variant and the SendEmailJob wrapper type is dropped. - Wire.EmailSending.Queueing: the EmailSending interpreter now runs ArbiterCore.insertJob against the shared hasql pool (self-contained, Embed IO only; maxAttempts = 3). - brig: wires the Arbiter-backed interpreter and runs the Arbiter job migrations at startup, mirroring galley. - background-worker: new emails worker pool (Wire.EmailJobsWorker) sends the mail via the configured SES/SMTP transport; malformed payloads are rejected with a warning, send failures rethrow as retryable so Arbiter retry/backoff and the DLQ apply. The RabbitMQ runner's email handling and its exception wrapper are reverted. - docs/changelog updated for the Arbiter semantics, including rollout ordering and the at-rest sensitivity of the emails/DLQ tables. --- .../wpb-27255-email-background-worker.md | 40 +++-- .../src/developer/reference/config-options.md | 19 +- libs/wire-api/src/Wire/API/BackgroundJobs.hs | 9 +- .../src/Wire/API/BackgroundJobs/Email.hs | 20 +-- libs/wire-api/src/Wire/API/Jobs.hs | 74 +++++++- .../Wire/BackgroundJobsRunner/Interpreter.hs | 11 -- .../src/Wire/EmailSending/Queueing.hs | 86 +++++---- .../unit/Wire/EmailSendingQueueingSpec.hs | 168 +++++++++--------- .../background-worker/background-worker.cabal | 1 + .../Wire/BackgroundWorker/Jobs/Registry.hs | 17 +- .../src/Wire/BackgroundWorker/Workers.hs | 41 ++++- .../background-worker/src/Wire/Effects.hs | 6 +- .../src/Wire/EmailJobsWorker.hs | 56 ++++++ services/brig/brig.cabal | 1 + services/brig/default.nix | 2 + .../brig/src/Brig/CanonicalInterpreter.hs | 2 +- services/brig/src/Brig/Run.hs | 7 + 17 files changed, 359 insertions(+), 201 deletions(-) create mode 100644 services/background-worker/src/Wire/EmailJobsWorker.hs diff --git a/changelog.d/0-release-notes/wpb-27255-email-background-worker.md b/changelog.d/0-release-notes/wpb-27255-email-background-worker.md index b68ec82b16b..32190243e96 100644 --- a/changelog.d/0-release-notes/wpb-27255-email-background-worker.md +++ b/changelog.d/0-release-notes/wpb-27255-email-background-worker.md @@ -1,14 +1,28 @@ Outbound email delivery has moved from **brig** to the **background-worker**. -brig no longer sends email directly: it enqueues every outbound -message (verification, activation, password-reset, invitation, new-client, -account-deletion, SAML IdP-change, provider and enterprise-audit mail) on the -existing `background-jobs` RabbitMQ queue, and the background-worker performs -the actual SMTP/SES send. Operators must configure the new -`background-worker.config.email` block (SES **or** SMTP, the same shape as -brig's `emailSMS.email`) and, for SES, the worker's AWS region and -credentials (`AWS_REGION` and `AWS_ACCESS_KEY_ID`/`AWS_SECRET_ACCESS_KEY`). -The `background-jobs` queue is a durable quorum queue, so transient -background-worker downtime does not lose mail: undelivered jobs are -requeued until a worker picks them up. When rolling out, deploy the updated -background-worker before (or alongside) the updated brig so that the new -`send-email` jobs are consumed as soon as they appear. +brig no longer sends email directly: it inserts every outbound message +(verification, activation, password-reset, invitation, new-client, +account-deletion, SAML IdP-change, provider and enterprise-audit mail) as a +`send_email` job on the `emails` Arbiter queue (a PostgreSQL table in the +default Arbiter schema), and the background-worker performs the actual +SMTP/SES send. The queue is not routed through RabbitMQ. Operators must +configure the new `background-worker.config.email` block (SES **or** SMTP, the +same shape as brig's `emailSMS.email`) and, for SES, the worker's AWS region +and credentials (`AWS_REGION` and `AWS_ACCESS_KEY_ID`/`AWS_SECRET_ACCESS_KEY`). +Failed sends are retried by Arbiter with bounded exponential backoff and +eventually land in the queue's dead-letter table, so transient +background-worker downtime does not lose mail: jobs stay in the `emails` table +until a worker picks them up. + +When rolling out, deploy the updated background-worker before (or alongside) +the updated brig so that the new `send_email` jobs are consumed as soon as they +appear; both services run the Arbiter migrations that create the `emails` +table at startup. This ordering assumes no intermediate build that queued email +on RabbitMQ is still running: `send-email` messages on the `background-jobs` +queue are requeued forever by an updated worker (which no longer understands +them). If such a build ran anywhere, drain or delete residual `send-email` +messages from the `background-jobs` queue before upgrading the worker. + +Note: the `emails` queue and its dead-letter table live in the shared +PostgreSQL database and contain full email content (including one-time codes +and reset links, for jobs that were never delivered). Access to the database +should therefore be least-privileged, and DLQ growth should be monitored. diff --git a/docs/src/developer/reference/config-options.md b/docs/src/developer/reference/config-options.md index 53a5d28a2d6..26321ae6067 100644 --- a/docs/src/developer/reference/config-options.md +++ b/docs/src/developer/reference/config-options.md @@ -2451,10 +2451,10 @@ Notes ## Background worker: Email sending -The background-worker delivers the email jobs enqueued by brig. It requires an -`email` transport (AWS SES or SMTP), the same shape brig uses for -`emailSMS.email`. Configuration is supplied via Helm under -`background-worker.config` and rendered into the `email` block of +The background-worker delivers the email jobs enqueued by brig on the `emails` +Arbiter queue (PostgreSQL). It requires an `email` transport (AWS SES or SMTP), +the same shape brig uses for `emailSMS.email`. Configuration is supplied via +Helm under `background-worker.config` and rendered into the `email` block of `background-worker.yaml`. The transport is selected by `background-worker.config.useSES`: @@ -2509,5 +2509,12 @@ Notes - For SMTP, the password is mounted at `/etc/wire/background-worker/secrets/smtp-password.txt` (from the `smtpPassword` secret); `config.smtp.passwordFile` must point at it. -- The `background-jobs` queue is durable, so transient worker downtime does not - lose email jobs; an updated worker picks up messages an older one requeued. +- Email jobs are inserted by brig into the `emails` table of the default + Arbiter schema (created at startup by the Arbiter migrations). Failed sends + are retried with bounded exponential backoff and eventually moved to the + queue's dead-letter queue, so transient worker downtime does not lose email + jobs. +- The `emails` queue and its dead-letter table live in the shared PostgreSQL + database and contain full email content (including one-time codes and reset + links for jobs that were never delivered). Keep database access + least-privileged and monitor DLQ growth. diff --git a/libs/wire-api/src/Wire/API/BackgroundJobs.hs b/libs/wire-api/src/Wire/API/BackgroundJobs.hs index d79c36876a9..b96f2cd7505 100644 --- a/libs/wire-api/src/Wire/API/BackgroundJobs.hs +++ b/libs/wire-api/src/Wire/API/BackgroundJobs.hs @@ -30,13 +30,11 @@ import Data.Schema import Imports import Network.AMQP qualified as Q import Network.AMQP.Types qualified as QT -import Wire.API.BackgroundJobs.Email (SendEmailJob) import Wire.Arbitrary (Arbitrary (..), GenericUniform (..)) data BackgroundJobPayload = BackgroundJobSyncUserGroupAndChannel SyncUserGroupAndChannel | BackgroundJobSyncUserGroup SyncUserGroup - | BackgroundJobSendEmail !SendEmailJob deriving stock (Eq, Show, Generic) deriving (Arbitrary) via GenericUniform BackgroundJobPayload @@ -44,12 +42,10 @@ backgroundJobPayloadLabel :: BackgroundJobPayload -> Text backgroundJobPayloadLabel p = case backgroundJobPayloadTag p of BackgroundJobSyncUserGroupAndChannelTag -> "sync-user-group-and-channel" BackgroundJobSyncUserGroupTag -> "sync-user-group" - BackgroundJobSendEmailTag -> "send-email" data BackgroundJobPayloadTag = BackgroundJobSyncUserGroupAndChannelTag | BackgroundJobSyncUserGroupTag - | BackgroundJobSendEmailTag deriving stock (Eq, Ord, Bounded, Enum, Show, Generic) deriving (Arbitrary) via GenericUniform BackgroundJobPayloadTag @@ -58,8 +54,7 @@ instance ToSchema BackgroundJobPayloadTag where enum @Text $ mconcat [ element "sync-user-group-and-channel" BackgroundJobSyncUserGroupAndChannelTag, - element "sync-user-group" BackgroundJobSyncUserGroupTag, - element "send-email" BackgroundJobSendEmailTag + element "sync-user-group" BackgroundJobSyncUserGroupTag ] backgroundJobPayloadTag :: BackgroundJobPayload -> BackgroundJobPayloadTag @@ -67,7 +62,6 @@ backgroundJobPayloadTag = \case BackgroundJobSyncUserGroupAndChannel {} -> BackgroundJobSyncUserGroupAndChannelTag BackgroundJobSyncUserGroup {} -> BackgroundJobSyncUserGroupTag - BackgroundJobSendEmail {} -> BackgroundJobSendEmailTag backgroundJobPayloadTagSchema :: ObjectSchema SwaggerDoc BackgroundJobPayloadTag backgroundJobPayloadTagSchema = field "type" schema @@ -122,7 +116,6 @@ backgroundJobPayloadObjectSchema = backgroundJobPayloadDataSchema = \case BackgroundJobSyncUserGroupAndChannelTag -> tag _BackgroundJobSyncUserGroupAndChannel (field "payload" schema) BackgroundJobSyncUserGroupTag -> tag _BackgroundJobSyncUserGroup (field "payload" schema) - BackgroundJobSendEmailTag -> tag _BackgroundJobSendEmail (field "payload" schema) instance ToSchema BackgroundJobPayload where schema = object backgroundJobPayloadObjectSchema diff --git a/libs/wire-api/src/Wire/API/BackgroundJobs/Email.hs b/libs/wire-api/src/Wire/API/BackgroundJobs/Email.hs index a4c63b8d10e..1273c6a46f2 100644 --- a/libs/wire-api/src/Wire/API/BackgroundJobs/Email.hs +++ b/libs/wire-api/src/Wire/API/BackgroundJobs/Email.hs @@ -18,10 +18,11 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . --- | Email job payload types (WPB-27255). +-- | Serializable email types (WPB-27255). -- --- Email delivery is queued to the background-worker as a 'BackgroundJobSendEmail' --- job. The actual SMTP/SES send happens in the worker; brig only enqueues. +-- Outbound email is queued to the background-worker as a 'SendEmail' job on +-- the Arbiter @emails@ queue (see "Wire.API.Jobs"). The actual SMTP\/SES send +-- happens in the worker; brig only enqueues. -- -- @wire-api@ cannot depend on @mime-mail@, so a mail is serialised as the plain -- records below. The @Mail@ <-> record conversion lives in @wire-subsystems@ @@ -236,16 +237,3 @@ instance ToSchema SerializableMail where <*> (.smBcc) .= field "bcc" (array schema) <*> (.smHeaders) .= field "headers" (array schema) <*> (.smParts) .= field "parts" (array (array schema)) - -data SendEmailJob = SendEmailJob - { sejMail :: !SerializableMail - } - deriving stock (Eq, Show, Generic) - deriving (Aeson.ToJSON, Aeson.FromJSON) via (Schema SendEmailJob) - deriving (Arbitrary) via GenericUniform SendEmailJob - -instance ToSchema SendEmailJob where - schema = - object $ - SendEmailJob - <$> (.sejMail) .= field "mail" schema diff --git a/libs/wire-api/src/Wire/API/Jobs.hs b/libs/wire-api/src/Wire/API/Jobs.hs index f60d60ca74f..4a97dafe98d 100644 --- a/libs/wire-api/src/Wire/API/Jobs.hs +++ b/libs/wire-api/src/Wire/API/Jobs.hs @@ -36,6 +36,7 @@ import Data.Text as Text import GHC.TypeLits import Imports import Test.QuickCheck (oneof) +import Wire.API.BackgroundJobs.Email (SerializableMail) import Wire.Arbitrary (Arbitrary (..), GenericUniform (..)) -- | The queue/table for jobs that operate on meetings. @@ -50,6 +51,12 @@ type ConversationsQueueName = "conversations" conversationsQueueName :: Text conversationsQueueName = Text.pack $ symbolVal (Proxy @ConversationsQueueName) +-- | The queue/table for jobs that send outbound email. +type EmailsQueueName = "emails" + +emailsQueueName :: Text +emailsQueueName = Text.pack $ symbolVal (Proxy @EmailsQueueName) + -- | Empty payload because the schedule itself carries all execution context. data MeetingsCleanupJob = MeetingsCleanupJob deriving stock (Eq, Generic, Show) @@ -247,8 +254,73 @@ deriving via (Schema ConversationsJobPayload) instance S.ToSchema ConversationsJ instance Arbitrary ConversationsJobPayload where arbitrary = oneof [AdminlessDeletion <$> arbitrary, AdminlessReminder <$> arbitrary] +-- | Payload persisted in the emails queue. Arbiter persists these payloads and +-- workers decode them later, so changes to field names or shapes require a +-- coordinated rollout. The mail itself is the 'SerializableMail' record from +-- "Wire.API.BackgroundJobs.Email"; the request id of the brig request that +-- queued the mail is captured for logging/tracing in the worker. +data SendEmailJobPayload = SendEmailJobPayload + { sendEmailJobRequestId :: !RequestId, + sendEmailJobMail :: !SerializableMail + } + deriving stock (Eq, Generic, Show) + deriving (ToJSON, FromJSON, S.ToSchema) via (Schema SendEmailJobPayload) + +instance ToSchema SendEmailJobPayload where + schema = + object $ + SendEmailJobPayload + <$> (.sendEmailJobRequestId) .= field "request_id" schema + <*> (.sendEmailJobMail) .= field "mail" schema + +instance Arbitrary SendEmailJobPayload where + arbitrary = SendEmailJobPayload <$> arbitrary <*> arbitrary + +data EmailsJobPayload + = SendEmail !SendEmailJobPayload + deriving stock (Eq, Generic, Show) + +data EmailsJobPayloadTag + = SendEmailTag + deriving stock (Eq, Ord, Bounded, Enum, Show, Generic) + deriving (Arbitrary) via GenericUniform EmailsJobPayloadTag + +instance ToSchema EmailsJobPayloadTag where + schema = + enum @Text $ + mconcat + [ element "send_email" SendEmailTag + ] + +makePrisms ''EmailsJobPayload + +emailsJobPayloadObjectSchema :: ObjectSchema SwaggerDoc EmailsJobPayload +emailsJobPayloadObjectSchema = taggedJobPayloadObjectSchema toTag toSchema + where + toTag :: EmailsJobPayload -> EmailsJobPayloadTag + toTag = + \case + SendEmail {} -> SendEmailTag + + toSchema :: EmailsJobPayloadTag -> ObjectSchema SwaggerDoc EmailsJobPayload + toSchema = \case + SendEmailTag -> tag _SendEmail (field "data" schema) + +instance ToSchema EmailsJobPayload where + schema = object emailsJobPayloadObjectSchema + +deriving via (Schema EmailsJobPayload) instance FromJSON EmailsJobPayload + +deriving via (Schema EmailsJobPayload) instance ToJSON EmailsJobPayload + +deriving via (Schema EmailsJobPayload) instance S.ToSchema EmailsJobPayload + +instance Arbitrary EmailsJobPayload where + arbitrary = SendEmail <$> arbitrary + -- | Registry for the jobs we expose via Arbiter. type JobRegistry = '[ Queue MeetingsQueueName MeetingsJobPayload, - Queue ConversationsQueueName ConversationsJobPayload + Queue ConversationsQueueName ConversationsJobPayload, + Queue EmailsQueueName EmailsJobPayload ] diff --git a/libs/wire-subsystems/src/Wire/BackgroundJobsRunner/Interpreter.hs b/libs/wire-subsystems/src/Wire/BackgroundJobsRunner/Interpreter.hs index d86fca527f1..8fc5abdc680 100644 --- a/libs/wire-subsystems/src/Wire/BackgroundJobsRunner/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/BackgroundJobsRunner/Interpreter.hs @@ -45,8 +45,6 @@ import Wire.BackgroundJobsPublisher import Wire.BackgroundJobsRunner (BackgroundJobRunner (..)) import Wire.ConversationStore (ConversationStore, upsertMembers) import Wire.ConversationSubsystem -import Wire.EmailSending (EmailSending, sendMail) -import Wire.EmailSending.Queueing (fromSerializableMail) import Wire.Sem.Random import Wire.StoredConversation import Wire.UserGroupStore (UserGroupStore, getUserGroup, getUserGroupChannels) @@ -55,7 +53,6 @@ import Wire.UserList (toUserList) interpretBackgroundJobRunner :: ( Member UserGroupStore r, Member BackgroundJobPublisher r, - Member EmailSending r, Member (Input (Local ())) r, Member ConversationStore r, Member ConversationSubsystem r, @@ -69,7 +66,6 @@ interpretBackgroundJobRunner = interpret $ \case runBackgroundJob :: ( Member UserGroupStore r, Member BackgroundJobPublisher r, - Member EmailSending r, Member (Input (Local ())) r, Member ConversationStore r, Member ConversationSubsystem r, @@ -81,13 +77,6 @@ runBackgroundJob :: runBackgroundJob job = case job.payload of BackgroundJobSyncUserGroupAndChannel payload -> runSyncUserGroupAndChannel payload BackgroundJobSyncUserGroup payload -> runSyncUserGroup payload - BackgroundJobSendEmail payload -> case fromSerializableMail payload of - Left err -> - Log.warn $ - field "job_id" (toByteString job.jobId) - . field "error" err - . msg (val "Rejecting malformed email job") - Right mail -> sendMail mail runSyncUserGroupAndChannel :: ( Member UserGroupStore r, diff --git a/libs/wire-subsystems/src/Wire/EmailSending/Queueing.hs b/libs/wire-subsystems/src/Wire/EmailSending/Queueing.hs index f76ceeb4ec7..15a7f2fb1fb 100644 --- a/libs/wire-subsystems/src/Wire/EmailSending/Queueing.hs +++ b/libs/wire-subsystems/src/Wire/EmailSending/Queueing.hs @@ -17,10 +17,10 @@ -- | Queueing interpreter for the 'EmailSending' effect. -- --- Instead of sending mail directly (SMTP\/SES), this interpreter enqueues a --- 'BackgroundJobSendEmail' job on the shared @background-jobs@ queue. The --- actual send is performed by the background-worker (see --- "Wire.BackgroundJobsRunner.Interpreter"). +-- Instead of sending mail directly (SMTP\/SES), this interpreter inserts a +-- 'SendEmail' job into the Arbiter @emails@ queue (a PostgreSQL table managed +-- by Arbiter). The actual send is performed by the background-worker's emails +-- worker pool (see "Wire.EmailJobsWorker"). -- -- This is the single seam for *all* email sending in brig: every mail flows -- through 'EmailSending', so interpreting it to a queue covers verification, @@ -33,13 +33,14 @@ module Wire.EmailSending.Queueing ) where +import Arbiter.Core qualified as ArbiterCore import Data.ByteString.Base64.Lazy qualified as B64 import Data.ByteString.Lazy qualified as BL -import Data.Id (RequestId, randomId) +import Data.Id (RequestId) import Data.Text qualified as T import Data.Text.Encoding qualified as Text +import Hasql.Pool.Extended qualified as HasqlPoolExt import Imports -import Network.AMQP qualified as Q import Network.Mail.Mime ( Address (..), Disposition (..), @@ -49,50 +50,50 @@ import Network.Mail.Mime PartContent (..), ) import Polysemy -import Wire.API.BackgroundJobs import Wire.API.BackgroundJobs.Email -import Wire.BackgroundJobsPublisher.RabbitMQ qualified as Publisher +import Wire.API.Jobs (EmailsJobPayload (SendEmail), JobRegistry, SendEmailJobPayload (..)) import Wire.EmailSending (EmailSending (SendMail)) +import Wire.JobSubsystem.ArbiterAdapter (WireArbiter, mkNewWireArbiterEnv, runWireArbiter) --- | Interpret 'EmailSending' by enqueuing a 'BackgroundJobSendEmail' job. +-- | Interpret 'EmailSending' by inserting a 'SendEmail' job into the Arbiter +-- @emails@ queue. -- --- The job id is minted with 'randomId' and the message is published directly to --- the @background-jobs@ queue via the channel-level 'Publisher.publishJob'. This --- keeps the interpreter's only effect requirement 'Embed' 'IO', so it drops into --- the producer's effect stack exactly where the old direct-send interpreter sat --- (it needs neither 'Random' nor 'BackgroundJobPublisher' to be present at that --- point in the stack). +-- The interpreter is self-contained: it runs Arbiter against the producer's +-- shared PostgreSQL pool, so its only effect requirement is 'Embed' 'IO' and it +-- drops into the producer's effect stack exactly where the old direct-send +-- interpreter sat. The table is created by 'runJobMigrations' (run at startup +-- by every service that schedules or executes jobs). emailViaQueueInterpreter :: (Member (Embed IO) r) => RequestId -> - MVar Q.Channel -> + HasqlPoolExt.Pool -> InterpreterFor EmailSending r -emailViaQueueInterpreter requestId channelMVar = - interpret \case - SendMail mail -> do - channel <- embed (readMVar channelMVar) - jobId <- embed (randomId @IO) - Publisher.publishJob requestId channel jobId (BackgroundJobSendEmail (toSerializableMail mail)) +emailViaQueueInterpreter requestId pool = interpret \case + SendMail mail -> do + let payload = + SendEmailJobPayload + { sendEmailJobRequestId = requestId, + sendEmailJobMail = toSerializableMail mail + } + -- Bounded attempts: the send is retried by Arbiter with exponential + -- backoff, and after these attempts the job is moved to the queue's + -- dead-letter table. + job = + (ArbiterCore.defaultJob (SendEmail payload)) + { ArbiterCore.maxAttempts = Just 3 + } + embed @IO . void $ + runWireArbiter arbiterEnv $ + ArbiterCore.insertJob @EmailsJobPayload @(WireArbiter JobRegistry) job + where + arbiterEnv = mkNewWireArbiterEnv ArbiterCore.defaultSchemaName pool -------------------------------------------------------------------------------- -- Mail <-> record conversion -------------------------------------------------------------------------------- -toSerializableMail :: Mail -> SendEmailJob -toSerializableMail mail = SendEmailJob {sejMail = fromMail mail} - --- | Reconstruct a 'Mail' from a deserialized job. --- --- The job comes off an internal queue, but this is defense in depth: rather --- than trusting it, the conversion rejects jobs whose part nesting exceeds --- 'maxPartNesting', whose flat content is not strictly valid base64, or whose --- header-rendered fields contain CR\/LF\/NUL (header injection). Anything --- produced by 'toSerializableMail' always decodes. -fromSerializableMail :: SendEmailJob -> Either Text Mail -fromSerializableMail job = toMail job.sejMail - -fromMail :: Mail -> SerializableMail -fromMail m = +toSerializableMail :: Mail -> SerializableMail +toSerializableMail m = SerializableMail { smFrom = fromAddress m.mailFrom, smTo = fromAddress <$> m.mailTo, @@ -102,8 +103,15 @@ fromMail m = smParts = (fromPart <$>) <$> m.mailParts } -toMail :: SerializableMail -> Either Text Mail -toMail m = do +-- | Reconstruct a 'Mail' from a deserialized job payload. +-- +-- The job comes off an internal queue, but this is defense in depth: rather +-- than trusting it, the conversion rejects payloads whose part nesting exceeds +-- 'maxPartNesting', whose flat content is not strictly valid base64, or whose +-- header-rendered fields contain CR\/LF\/NUL (header injection). Anything +-- produced by 'toSerializableMail' always decodes. +fromSerializableMail :: SerializableMail -> Either Text Mail +fromSerializableMail m = do mailFrom <- toAddress m.smFrom mailTo <- traverse toAddress m.smTo mailCc <- traverse toAddress m.smCc diff --git a/libs/wire-subsystems/test/unit/Wire/EmailSendingQueueingSpec.hs b/libs/wire-subsystems/test/unit/Wire/EmailSendingQueueingSpec.hs index 81697608b56..e6dcf73f56d 100644 --- a/libs/wire-subsystems/test/unit/Wire/EmailSendingQueueingSpec.hs +++ b/libs/wire-subsystems/test/unit/Wire/EmailSendingQueueingSpec.hs @@ -16,13 +16,14 @@ -- with this program. If not, see . -- | Unit tests for the email queueing conversion ('Wire.EmailSending.Queueing') --- and the 'SendEmailJob' payload serialization. +-- and the 'SendEmailJobPayload' serialization. -- --- These cover the data path shared by the producer (brig enqueues a --- 'BackgroundJobSendEmail') and the consumer (the background-worker reconstructs --- the 'Mail' and sends it): the @Mail@ <-> 'SendEmailJob' conversion must be a --- round-trip, and the job must survive JSON encoding/decoding through the --- @background-jobs@ queue. +-- These cover the data path shared by the producer (brig inserts a +-- 'SendEmail' job into the Arbiter @emails@ queue) and the consumer (the +-- background-worker reconstructs the 'Mail' and sends it): the +-- @Mail@ <-> 'SerializableMail' conversion must be a round-trip, and the job +-- payload must survive JSON encoding/decoding through the queue's JSONB +-- column. module Wire.EmailSendingQueueingSpec (spec) where import Data.Aeson qualified as Aeson @@ -40,17 +41,18 @@ import Network.Mail.Mime import Test.Hspec import Test.QuickCheck import Wire.API.BackgroundJobs.Email +import Wire.API.Jobs (EmailsJobPayload (..)) import Wire.EmailSending.Queueing spec :: Spec spec = do describe "toSerializableMail / fromSerializableMail" $ do it "round-trips Mail -> SerializableMail -> Mail -> SerializableMail" $ do - let job = toSerializableMail sampleMail - toSerializableMail <$> fromSerializableMail job `shouldBe` Right job + let sm = toSerializableMail sampleMail + toSerializableMail <$> fromSerializableMail sm `shouldBe` Right sm it "preserves all address lists, headers and parts" $ do - let sm = (toSerializableMail sampleMail).sejMail + let sm = toSerializableMail sampleMail sm.smFrom `shouldBe` smaFrom sm.smTo `shouldBe` [smaTo] sm.smCc `shouldBe` [SerializableMailAddress Nothing "cc@example.com"] @@ -82,68 +84,68 @@ spec = do fromSerializableMail (nestedJobAtDepth 11) `shouldSatisfy` isLeft it "rejects flat content that is not valid base64" $ do - let job = SendEmailJob {sejMail = sampleJob.sejMail {smParts = [[partWithContent (SerializablePartContentText "not base64!!!")]]}} + let job = sampleJob {smParts = [[partWithContent (SerializablePartContentText "not base64!!!")]]} fromSerializableMail job `shouldSatisfy` isLeft -- One case per call site of 'validateHeaderField', so a future refactor -- that drops one (e.g. a missing 'traverse' over 'smaName') fails here. it "rejects NUL in every header-rendered field" $ do - let base = sampleJob.sejMail + let base = sampleJob okPart = partWithContent (SerializablePartContentText "aGk=") - withMail mail = SendEmailJob {sejMail = mail} - jobs :: [SendEmailJob] + jobs :: [SerializableMail] jobs = - [ withMail base {smFrom = base.smFrom {smaName = Just "Wire\0"}}, - withMail base {smTo = [base.smFrom {smaEmail = "evil\0@example.com"}]}, - withMail base {smParts = [[okPart {smpType = "text/plain\0"}]]}, - withMail - base - { smParts = - [ [ okPart - { smpDisposition = - SerializableDisposition {smdType = SerializableDispositionInline, smdFilename = "evil\0.txt"} - } - ] + [ base {smFrom = base.smFrom {smaName = Just "Wire\0"}}, + base {smTo = [base.smFrom {smaEmail = "evil\0@example.com"}]}, + base {smParts = [[okPart {smpType = "text/plain\0"}]]}, + base + { smParts = + [ [ okPart + { smpDisposition = + SerializableDisposition {smdType = SerializableDispositionInline, smdFilename = "evil\0.txt"} + } ] - }, - withMail - base - { smParts = - [ [ okPart - { smpDisposition = - SerializableDisposition {smdType = SerializableDispositionDefault, smdFilename = "evil\0.txt"} - } - ] + ] + }, + base + { smParts = + [ [ okPart + { smpDisposition = + SerializableDisposition {smdType = SerializableDispositionDefault, smdFilename = "evil\0.txt"} + } ] - } + ] + } ] mapM_ (\job -> fromSerializableMail job `shouldSatisfy` isLeft) jobs it "rejects CR/LF in header-rendered fields" $ do let job = - SendEmailJob - { sejMail = - sampleJob.sejMail - { smHeaders = [SerializableMailHeader "Subject" "hi\r\nBcc: evil@example.com"] - } + sampleJob + { smHeaders = [SerializableMailHeader "Subject" "hi\r\nBcc: evil@example.com"] } fromSerializableMail job `shouldSatisfy` isLeft - - describe "SendEmailJob JSON serialization" $ do - it "round-trips the sample job through Aeson" $ do + describe "SerializableMail / EmailsJobPayload JSON serialization" $ do + it "round-trips the sample mail through Aeson" $ do let job = toSerializableMail sampleMail Aeson.decode (Aeson.encode job) `shouldBe` Just job - it "decoding a serialized job yields a job that round-trips back to itself" $ do + it "decoding a serialized mail yields a mail that round-trips back to itself" $ do let job = toSerializableMail sampleMail - decoded = Aeson.decode (Aeson.encode job) :: Maybe SendEmailJob + decoded = Aeson.decode (Aeson.encode job) :: Maybe SerializableMail (fmap toSerializableMail . fromSerializableMail <$> decoded) `shouldBe` Just (Right job) -- Exercises the wire-api schema machinery (record fields, nested lists, -- and the encoding/disposition enums) for arbitrary payloads. - it "encode . decode = id for arbitrary SendEmailJob" $ - property $ \(job :: SendEmailJob) -> - Aeson.decode @SendEmailJob (Aeson.encode job) === Just job + it "encode . decode = id for arbitrary SerializableMail" $ + property $ \(job :: SerializableMail) -> + Aeson.decode @SerializableMail (Aeson.encode job) === Just job + + -- The Arbiter @emails@ queue envelope: the tagged payload sum and the + -- payload record (request id + mail) must round-trip through the queue's + -- JSONB column. + it "encode . decode = id for arbitrary EmailsJobPayload" $ + property $ \(job :: EmailsJobPayload) -> + Aeson.decode @EmailsJobPayload (Aeson.encode job) === Just job -- | A mail shaped exactly like the ones brig builds (see -- 'Wire.EmailSubsystem.Interpreter'): one alternative with a plain and an html @@ -178,14 +180,13 @@ nestedMail = sampleMail {mailParts = [[nestedPart]]} { partContent = NestedParts [plainPart (LT.pack "inner plain"), htmlPart (LT.pack "

inner html

")] } -sampleJob :: SendEmailJob +sampleJob :: SerializableMail sampleJob = toSerializableMail sampleMail -- | A job whose single part's content is nested @n@ levels deep (n -- 'SerializablePartContentNestedParts' wrappers around base64 text). -nestedJobAtDepth :: Int -> SendEmailJob -nestedJobAtDepth n = - SendEmailJob {sejMail = sampleJob.sejMail {smParts = [[partAtDepth n]]}} +nestedJobAtDepth :: Int -> SerializableMail +nestedJobAtDepth n = sampleJob {smParts = [[partAtDepth n]]} where partAtDepth :: Int -> SerializableMailPart partAtDepth 0 = partWithContent (SerializablePartContentText "aGk=") @@ -203,42 +204,39 @@ partWithContent content = -- | A job with non-default dispositions (Inline/Attachment, which carry a -- filename) and encodings other than the default, to exercise those branches. -variantJob :: SendEmailJob +variantJob :: SerializableMail variantJob = - SendEmailJob - { sejMail = - SerializableMail - { smFrom = smaFrom, - smTo = [smaTo], - smCc = [], - smBcc = [], - smHeaders = [SerializableMailHeader "Subject" "Attachments"], - smParts = - [ [ SerializableMailPart - { smpType = "image/png", - smpEncoding = SerializableEncodingBase64, - smpDisposition = - SerializableDisposition - { smdType = SerializableDispositionInline, - smdFilename = "logo.png" - }, - smpHeaders = [], - smpContent = SerializablePartContentText "iVBORw0KGgo=" + SerializableMail + { smFrom = smaFrom, + smTo = [smaTo], + smCc = [], + smBcc = [], + smHeaders = [SerializableMailHeader "Subject" "Attachments"], + smParts = + [ [ SerializableMailPart + { smpType = "image/png", + smpEncoding = SerializableEncodingBase64, + smpDisposition = + SerializableDisposition + { smdType = SerializableDispositionInline, + smdFilename = "logo.png" }, - SerializableMailPart - { smpType = "application/pdf", - smpEncoding = SerializableEncodingQuotedPrintableText, - smpDisposition = - SerializableDisposition - { smdType = SerializableDispositionAttachment, - smdFilename = "doc.pdf" - }, - smpHeaders = [SerializableMailHeader "Content-ID" ""], - smpContent = SerializablePartContentText "JVBERi0=" - } - ] - ] - } + smpHeaders = [], + smpContent = SerializablePartContentText "iVBORw0KGgo=" + }, + SerializableMailPart + { smpType = "application/pdf", + smpEncoding = SerializableEncodingQuotedPrintableText, + smpDisposition = + SerializableDisposition + { smdType = SerializableDispositionAttachment, + smdFilename = "doc.pdf" + }, + smpHeaders = [SerializableMailHeader "Content-ID" ""], + smpContent = SerializablePartContentText "JVBERi0=" + } + ] + ] } smaFrom :: SerializableMailAddress diff --git a/services/background-worker/background-worker.cabal b/services/background-worker/background-worker.cabal index 48fb2dd49e0..c2465265698 100644 --- a/services/background-worker/background-worker.cabal +++ b/services/background-worker/background-worker.cabal @@ -24,6 +24,7 @@ library Wire.BackgroundWorker.Workers Wire.DeadUserNotificationWatcher Wire.Effects + Wire.EmailJobsWorker Wire.MeetingsCleanupWorker Wire.PostgresMigrations diff --git a/services/background-worker/src/Wire/BackgroundWorker/Jobs/Registry.hs b/services/background-worker/src/Wire/BackgroundWorker/Jobs/Registry.hs index 04ab9bf1022..abb737a95a0 100644 --- a/services/background-worker/src/Wire/BackgroundWorker/Jobs/Registry.hs +++ b/services/background-worker/src/Wire/BackgroundWorker/Jobs/Registry.hs @@ -20,8 +20,6 @@ module Wire.BackgroundWorker.Jobs.Registry ) where -import Control.Exception (try) -import Data.Text qualified as T import Imports import Wire.API.BackgroundJobs (BackgroundJob (..)) import Wire.BackgroundJobsPublisher.RabbitMQ (interpretBackgroundJobPublisherRabbitMQ) @@ -36,13 +34,8 @@ dispatchJob job = do env <- ask @Env let disableTlsV1 = True extEnv <- liftIO (initExtEnv disableTlsV1) - liftIO $ - try @SomeException - ( runBackgroundWorkerEffects env extEnv job.requestId (Just job.jobId) - . interpretBackgroundJobPublisherRabbitMQ job.requestId env.amqpJobsPublisherChannel - . interpretBackgroundJobRunner - $ runJob job - ) - >>= \case - Right r -> pure r - Left e -> pure (Left (T.pack (displayException e))) + liftIO + $ runBackgroundWorkerEffects env extEnv job.requestId (Just job.jobId) + . interpretBackgroundJobPublisherRabbitMQ job.requestId env.amqpJobsPublisherChannel + . interpretBackgroundJobRunner + $ runJob job diff --git a/services/background-worker/src/Wire/BackgroundWorker/Workers.hs b/services/background-worker/src/Wire/BackgroundWorker/Workers.hs index e28c1e92d14..0d663cdaf28 100644 --- a/services/background-worker/src/Wire/BackgroundWorker/Workers.hs +++ b/services/background-worker/src/Wire/BackgroundWorker/Workers.hs @@ -40,6 +40,7 @@ import Wire.AdminlessJobsWorker (runAdminlessDeletionJob, runAdminlessReminderJo import Wire.BackgroundWorker.Env (AppT, Env (..), runAppT) import Wire.BackgroundWorker.Options (JobConfig (..), JobJitter (..), MeetingsCleanupConfig (..)) import Wire.BackgroundWorker.Util +import Wire.EmailJobsWorker (runSendEmailJob) import Wire.ExternalAccess.External import Wire.JobSubsystem.ArbiterAdapter import Wire.JobSubsystem.Migrations (runJobMigrations) @@ -119,10 +120,10 @@ toJobJitter = \case -- | Start the worker pools for the job queues. -- -- Each domain queue has its own Arbiter table and worker pool. The meetings --- pool owns the recurring cleanup cron job, while the conversations pool owns --- the adminless one-off jobs. Both pools are supervised by Arbiter's --- multi-pool runner, so they share the process lifecycle without sharing a --- payload type or queue. +-- pool owns the recurring cleanup cron job, the conversations pool owns the +-- adminless one-off jobs, and the emails pool sends the outbound mail queued +-- by brig. All pools are supervised by Arbiter's multi-pool runner, so they +-- share the process lifecycle without sharing a payload type or queue. runJobRunner :: Env -> ExtEnv -> @@ -132,7 +133,7 @@ runJobRunner :: runJobRunner env extEnv runnerConfig cleanupConfig = do Log.info runnerConfig.jobRunnerLogger $ Log.msg (Log.val "Starting job worker") - . Log.field "queue_names" (T.intercalate "," [meetingsQueueName, conversationsQueueName]) + . Log.field "queue_names" (T.intercalate "," [meetingsQueueName, conversationsQueueName, emailsQueueName]) . Log.field "schedule" (show runnerConfig.jobRunnerSchedule) let arbiterEnv = mkNewWireArbiterEnv runnerConfig.jobRunnerSchemaName env.hasqlPool @@ -154,6 +155,14 @@ runJobRunner env extEnv runnerConfig cleanupConfig = do AdminlessDeletion payload -> runAppT env $ runAdminlessDeletionJob extEnv (mapJobPayload (const payload) job) AdminlessReminder payload -> runAppT env $ runAdminlessReminderJob extEnv (mapJobPayload (const payload) job) + emailsWorkerHandler _conn job = liftIO $ do + Log.info runnerConfig.jobRunnerLogger $ + Log.msg (Log.val "Running job") + . Log.field "queue_name" emailsQueueName + . Log.field "payload_type" (emailsJobPayloadTypeName job.payload) + case job.payload of + SendEmail payload -> runAppT env $ runSendEmailJob extEnv (mapJobPayload (const payload) job) + cronJob <- case ArbiterWorkerCron.cronJob "meetings-cleanup" (serializeCronSchedule runnerConfig.jobRunnerSchedule) @@ -189,6 +198,17 @@ runJobRunner env extEnv runnerConfig cleanupConfig = do ) ) + emailsWorkerConfig <- + ( ArbiterWorker.transactionalWorkerConfig + runnerConfig.jobRunnerSettings.jobWorkerThreads + emailsWorkerHandler :: + IO + ( ArbiterWorker.WorkerConfig + (WireArbiter JobRegistry) + EmailsJobPayload + ) + ) + let meetingsWorkerConfig' = applyExplicitDefaults runnerConfig.jobRunnerSettings @@ -199,9 +219,14 @@ runJobRunner env extEnv runnerConfig cleanupConfig = do applyExplicitDefaults runnerConfig.jobRunnerSettings conversationsWorkerConfig + emailsWorkerConfig' = + applyExplicitDefaults + runnerConfig.jobRunnerSettings + emailsWorkerConfig workerPools = [ ArbiterWorker.namedWorkerPool meetingsWorkerConfig', - ArbiterWorker.namedWorkerPool conversationsWorkerConfig' + ArbiterWorker.namedWorkerPool conversationsWorkerConfig', + ArbiterWorker.namedWorkerPool emailsWorkerConfig' ] workerAsync <- @@ -223,6 +248,10 @@ conversationsJobPayloadTypeName = \case AdminlessDeletion _ -> "adminless_deletion" AdminlessReminder _ -> "adminless_reminder" +emailsJobPayloadTypeName :: EmailsJobPayload -> Text +emailsJobPayloadTypeName = \case + SendEmail _ -> "send_email" + mapJobPayload :: (a -> b) -> ArbiterCore.JobRead a -> ArbiterCore.JobRead b mapJobPayload f job = ArbiterCore.Job diff --git a/services/background-worker/src/Wire/Effects.hs b/services/background-worker/src/Wire/Effects.hs index 1b54f616b27..9498e27068e 100644 --- a/services/background-worker/src/Wire/Effects.hs +++ b/services/background-worker/src/Wire/Effects.hs @@ -421,9 +421,9 @@ runBackgroundWorkerEffects env extEnv requestId mJobId = -- | Interpret 'EmailSending' for the background-worker: SMTP or SES, whichever -- transport 'mkEnv' built from the required @email@ config (a sum, so the --- "no transport" state is unrepresentable). Send failures are raised as IO --- exceptions and are converted to @'Left' 'Text'@ at the 'dispatchJob' --- boundary, so they flow through the consumer's bounded retry and DLQ. +-- "no transport" state is unrepresentable). Used by the Arbiter @emails@ worker +-- pool ("Wire.EmailJobsWorker"); send failures are retried by Arbiter's +-- bounded retry/backoff and eventually land in the queue's DLQ. emailSendingInterpreter :: (Member (Embed IO) r) => Env -> InterpreterFor EmailSending r emailSendingInterpreter env = case env.emailTransport of EmailTransportSMTP smtp -> emailViaSMTPInterpreter env.logger smtp diff --git a/services/background-worker/src/Wire/EmailJobsWorker.hs b/services/background-worker/src/Wire/EmailJobsWorker.hs new file mode 100644 index 00000000000..27fb7785fc4 --- /dev/null +++ b/services/background-worker/src/Wire/EmailJobsWorker.hs @@ -0,0 +1,56 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2026 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Wire.EmailJobsWorker + ( runSendEmailJob, + ) +where + +import Arbiter.Core.Exceptions (throwRetryable) +import Arbiter.Core.Job.Types (JobRead, notVisibleUntil, payload) +import Imports +import System.Logger qualified as Log +import Wire.API.Jobs (SendEmailJobPayload (..)) +import Wire.BackgroundWorker.Env (AppT, Env (..)) +import Wire.Effects (runBackgroundWorkerEffects) +import Wire.EmailSending (sendMail) +import Wire.EmailSending.Queueing (fromSerializableMail) +import Wire.ExternalAccess.External (ExtEnv) + +-- | Send one outbound email queued by brig on the Arbiter @emails@ queue. +-- +-- The mail record is not trusted: a payload that fails 'fromSerializableMail' +-- is malformed (or adversarial) and is rejected with a warning instead of +-- retried. A failing send surfaces as @'Left' 'Text'@ from +-- 'runBackgroundWorkerEffects' and is rethrown as retryable so Arbiter's +-- bounded retry/backoff (and, eventually, the DLQ) applies. +runSendEmailJob :: ExtEnv -> JobRead SendEmailJobPayload -> AppT IO () +runSendEmailJob extEnv job = do + env <- ask + Log.debug env.logger $ + Log.msg (Log.val "Running send-email job") + . Log.field "request_id" (show job.payload.sendEmailJobRequestId) + . Log.field "scheduled_for" (show job.notVisibleUntil) + case fromSerializableMail job.payload.sendEmailJobMail of + Left err -> + Log.warn env.logger $ + Log.msg (Log.val "Rejecting malformed email job") + . Log.field "request_id" (show job.payload.sendEmailJobRequestId) + . Log.field "error" err + Right mail -> do + result <- liftIO $ runBackgroundWorkerEffects env extEnv job.payload.sendEmailJobRequestId Nothing $ sendMail mail + either (liftIO . throwRetryable) pure result diff --git a/services/brig/brig.cabal b/services/brig/brig.cabal index 89b1d88f7a7..ce3c7181a1a 100644 --- a/services/brig/brig.cabal +++ b/services/brig/brig.cabal @@ -208,6 +208,7 @@ library , amazonka-ses >=2 , amazonka-sqs >=2 , amqp + , arbiter-core , async >=2.1 , auto-update >=0.1 , base >=4 && <5 diff --git a/services/brig/default.nix b/services/brig/default.nix index e431f9c93db..a556d7ad7cc 100644 --- a/services/brig/default.nix +++ b/services/brig/default.nix @@ -9,6 +9,7 @@ , amazonka-ses , amazonka-sqs , amqp +, arbiter-core , async , attoparsec , auto-update @@ -161,6 +162,7 @@ mkDerivation { amazonka-ses amazonka-sqs amqp + arbiter-core async auto-update base diff --git a/services/brig/src/Brig/CanonicalInterpreter.hs b/services/brig/src/Brig/CanonicalInterpreter.hs index f462fff180d..09633558597 100644 --- a/services/brig/src/Brig/CanonicalInterpreter.hs +++ b/services/brig/src/Brig/CanonicalInterpreter.hs @@ -450,7 +450,7 @@ runBrigToIO e (AppT ma) = do . interpretClientToIO e.casClient . runMetricsToIO . runRpcWithHttp e.httpManager e.requestId - . emailViaQueueInterpreter e.requestId e.amqpJobsPublisherChannel + . emailViaQueueInterpreter e.requestId e.hasqlPool . interpretSparAPIAccessToRpc e.sparEndpoint . interpretGalleyAPIAccessToRpc e.disabledVersions e.galleyEndpoint . passwordResetCodeStoreToCassandra @Cas.Client diff --git a/services/brig/src/Brig/Run.hs b/services/brig/src/Brig/Run.hs index 7cc07fc7f2d..6e75c762fc4 100644 --- a/services/brig/src/Brig/Run.hs +++ b/services/brig/src/Brig/Run.hs @@ -18,6 +18,7 @@ module Brig.Run (run, mkApp, migratePostgres) where import AWS.Util (readAuthExpiration) +import Arbiter.Core qualified as ArbiterCore import Brig.API.Federation import Brig.API.Handler import Brig.API.Internal qualified as IAPI @@ -69,6 +70,7 @@ import Wire.API.Routes.Version import Wire.API.Routes.Version.Wai import Wire.API.User (AccountStatus (PendingInvitation)) import Wire.DeleteQueue +import Wire.JobSubsystem.Migrations (mkArbiterConnectionString, runJobMigrations) import Wire.OpenTelemetry (withTracer) import Wire.PostgresMigrations import Wire.Sem.Paging qualified as P @@ -84,6 +86,11 @@ run :: Opts -> IO () run opts = withTracer \tracer -> do (app, e) <- mkApp opts runAllMigrations e.hasqlPool.rawPool e.appLogger + arbiterConnStr <- + mkArbiterConnectionString + opts.postgresql + opts.postgresqlPassword + runJobMigrations arbiterConnStr ArbiterCore.defaultSchemaName let s = Server.newSettings (server e) internalEventListener <- Async.async $ From cd1942e5cae9896fc6f2e3e01c1f0f1966f32892 Mon Sep 17 00:00:00 2001 From: Gautier DI FOLCO Date: Tue, 25 Aug 2026 19:19:51 +0200 Subject: [PATCH 3/7] fix: copyright date --- libs/wire-subsystems/test/unit/Wire/EmailSendingQueueingSpec.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/libs/wire-subsystems/test/unit/Wire/EmailSendingQueueingSpec.hs b/libs/wire-subsystems/test/unit/Wire/EmailSendingQueueingSpec.hs index e6dcf73f56d..c02e0f24e34 100644 --- a/libs/wire-subsystems/test/unit/Wire/EmailSendingQueueingSpec.hs +++ b/libs/wire-subsystems/test/unit/Wire/EmailSendingQueueingSpec.hs @@ -1,6 +1,6 @@ -- This file is part of the Wire Server implementation. -- --- Copyright (C) 2025 Wire Swiss GmbH +-- Copyright (C) 2026 Wire Swiss GmbH -- -- This program is free software: you can redistribute it and/or modify it under -- the terms of the GNU Affero General Public License as published by the Free From d55dcb7038b936d9d4617a016641fa12fd3b9f12 Mon Sep 17 00:00:00 2001 From: Gautier DI FOLCO Date: Wed, 26 Aug 2026 18:00:49 +0200 Subject: [PATCH 4/7] WPB-27255: queue the composing payload and compose emails in the background-worker --- .../wpb-27255-email-background-worker.md | 46 +- .../background-worker/configmap.yaml | 7 + .../wire-server/templates/brig/configmap.yaml | 39 -- charts/wire-server/values.yaml | 57 +- .../src/developer/reference/config-options.md | 51 +- hack/helm_vars/wire-server/values.yaml.gotmpl | 25 +- integration/test/Testlib/ModService.hs | 3 +- .../src/Wire/API/BackgroundJobs/Email.hs | 644 +++++++++++++----- libs/wire-api/src/Wire/API/Jobs.hs | 30 +- .../src/Wire/EmailSending/Composer.hs | 283 ++++++++ .../src/Wire/EmailSending/Queueing.hs | 216 +----- .../src/Wire/EmailSubsystem.hs | 4 +- .../src/Wire/EmailSubsystem/Interpreter.hs | 336 +++------ .../src/Wire/EmailSubsystem/Template.hs | 91 +++ .../Wire/EmailSubsystem/Templates/Provider.hs | 49 +- .../EnterpriseLoginSubsystem/Interpreter.hs | 71 +- .../TeamInvitationSubsystem/Interpreter.hs | 32 +- .../unit/Wire/EmailSending/ComposerSpec.hs | 136 ++++ .../unit/Wire/EmailSendingQueueingSpec.hs | 246 ------- .../Wire/EmailSubsystem/TemplateFixtures.hs | 33 +- .../Wire/MockInterpreters/EmailSubsystem.hs | 4 +- .../SAMLEmailSubsystem/InterpreterSpec.hs | 65 +- .../InterpreterSpec.hs | 16 +- libs/wire-subsystems/wire-subsystems.cabal | 4 +- nix/wire-server.nix | 2 +- .../background-worker.integration.yaml | 38 +- .../src/Wire/BackgroundWorker/Env.hs | 5 +- .../src/Wire/BackgroundWorker/Options.hs | 4 +- .../src/Wire/EmailJobsWorker.hs | 28 +- .../Wire/BackendNotificationPusherSpec.hs | 2 + .../background-worker/test/Test/Wire/Util.hs | 1 + services/brig/brig.cabal | 5 - services/brig/brig.integration.yaml | 23 - services/brig/default.nix | 1 - services/brig/src/Brig/API/Public.hs | 6 +- services/brig/src/Brig/App.hs | 54 +- .../brig/src/Brig/CanonicalInterpreter.hs | 9 +- services/brig/src/Brig/Options.hs | 55 +- services/brig/src/Brig/Provider/API.hs | 12 +- services/brig/src/Brig/Provider/Email.hs | 166 +---- services/brig/src/Brig/Team/API.hs | 2 +- services/brig/src/Brig/Team/Template.hs | 39 -- services/brig/src/Brig/Template.hs | 72 -- services/brig/src/Brig/User/Template.hs | 40 -- 44 files changed, 1544 insertions(+), 1508 deletions(-) create mode 100644 libs/wire-subsystems/src/Wire/EmailSending/Composer.hs rename services/brig/src/Brig/Provider/Template.hs => libs/wire-subsystems/src/Wire/EmailSubsystem/Templates/Provider.hs (73%) create mode 100644 libs/wire-subsystems/test/unit/Wire/EmailSending/ComposerSpec.hs delete mode 100644 libs/wire-subsystems/test/unit/Wire/EmailSendingQueueingSpec.hs delete mode 100644 services/brig/src/Brig/Team/Template.hs delete mode 100644 services/brig/src/Brig/Template.hs delete mode 100644 services/brig/src/Brig/User/Template.hs diff --git a/changelog.d/0-release-notes/wpb-27255-email-background-worker.md b/changelog.d/0-release-notes/wpb-27255-email-background-worker.md index 32190243e96..c05d31b4ddc 100644 --- a/changelog.d/0-release-notes/wpb-27255-email-background-worker.md +++ b/changelog.d/0-release-notes/wpb-27255-email-background-worker.md @@ -1,13 +1,32 @@ -Outbound email delivery has moved from **brig** to the **background-worker**. -brig no longer sends email directly: it inserts every outbound message -(verification, activation, password-reset, invitation, new-client, -account-deletion, SAML IdP-change, provider and enterprise-audit mail) as a -`send_email` job on the `emails` Arbiter queue (a PostgreSQL table in the -default Arbiter schema), and the background-worker performs the actual -SMTP/SES send. The queue is not routed through RabbitMQ. Operators must -configure the new `background-worker.config.email` block (SES **or** SMTP, the -same shape as brig's `emailSMS.email`) and, for SES, the worker's AWS region -and credentials (`AWS_REGION` and `AWS_ACCESS_KEY_ID`/`AWS_SECRET_ACCESS_KEY`). +Outbound email delivery has moved from **brig** to the **background-worker**, +and the queue now carries the *composing payload* instead of a finished mail: +brig no longer renders templates or builds MIME mail. It enqueues every +outbound email (verification, activation, password-reset, invitation, +new-client, account-deletion, SAML IdP-change, provider and enterprise-audit +mail) as a `send_email` job on the `emails` Arbiter queue (a PostgreSQL table +in the default Arbiter schema), carrying only the email type, locale and +structured inputs (recipient, keys/codes, team names, certificate summaries, +...). The background-worker composes the email — locale template selection, +placeholder rendering, MIME building — from the localized templates bundled in +its image (`/usr/share/wire/templates`) right before performing the actual +SMTP/SES send. The queue is not routed through RabbitMQ. + +Operators must configure two blocks on the background-worker: + +- `background-worker.config.email` — the transport (SES **or** SMTP, the same + shape as brig's former `emailSMS.email`); for SES also the worker's AWS + region and credentials (`AWS_REGION` and + `AWS_ACCESS_KEY_ID`/`AWS_SECRET_ACCESS_KEY`). +- `background-worker.config.emailTemplates` — the template directory, default + locale, sender address, branding and the user/team/provider URL templates. + These were previously brig's `emailSMS` template/URL/branding settings + (`emailSMS.general.templateDir`, `emailSMS.general.templateBranding`, + `emailSMS.user.{activation,passwordReset,deletion}Url` and + `emailSMS.provider`); those brig keys are gone, and the worker values must + match what brig used to configure so emails render with the same URLs and + branding as before. The templates directory now ships in the + background-worker image. + Failed sends are retried by Arbiter with bounded exponential backoff and eventually land in the queue's dead-letter table, so transient background-worker downtime does not lose mail: jobs stay in the `emails` table @@ -23,6 +42,7 @@ them). If such a build ran anywhere, drain or delete residual `send-email` messages from the `background-jobs` queue before upgrading the worker. Note: the `emails` queue and its dead-letter table live in the shared -PostgreSQL database and contain full email content (including one-time codes -and reset links, for jobs that were never delivered). Access to the database -should therefore be least-privileged, and DLQ growth should be monitored. +PostgreSQL database and contain the queued request data (including one-time +codes, recipient addresses and reset URLs, for jobs that were never delivered). +Access to the database should therefore be least-privileged, and DLQ growth +should be monitored. diff --git a/charts/wire-server/templates/background-worker/configmap.yaml b/charts/wire-server/templates/background-worker/configmap.yaml index 571174228b8..d7f893fcdb5 100644 --- a/charts/wire-server/templates/background-worker/configmap.yaml +++ b/charts/wire-server/templates/background-worker/configmap.yaml @@ -96,6 +96,13 @@ data: {{- end }} {{- end }} + # Email templates used to compose the emails queued by brig. + # These values must match what brig used to configure. + {{- with .emailTemplates }} + emailTemplates: +{{ toYaml . | indent 6 }} + {{- end }} + migrateConversations: {{ .migrateConversations }} migrateConversationCodes: {{ .migrateConversationCodes }} migrateTeamFeatures: {{ .migrateTeamFeatures }} diff --git a/charts/wire-server/templates/brig/configmap.yaml b/charts/wire-server/templates/brig/configmap.yaml index ad9ee08bf8f..f9688c7fdab 100644 --- a/charts/wire-server/templates/brig/configmap.yaml +++ b/charts/wire-server/templates/brig/configmap.yaml @@ -144,53 +144,14 @@ data: {{- end }} {{- end }} general: - templateDir: /usr/share/wire/templates emailSender: {{ .emailSMS.general.emailSender }} smsSender: {{ .emailSMS.general.smsSender | quote }} - templateBranding: - {{- with .emailSMS.general.templateBranding }} - brand: {{ .brand }} - brandUrl: {{ .brandUrl }} - brandLabelUrl: {{ .brandLabelUrl }} - brandLogoUrl: {{ .brandLogoUrl }} - brandService: {{ .brandService }} - copyright: {{ .copyright }} - misuse: {{ .misuse }} - legal: {{ .legal }} - forgot: {{ .forgot }} - support: {{ .support }} - {{- end }} user: {{- if .emailSMS.user }} - activationUrl: {{ .emailSMS.user.activationUrl }} smsActivationUrl: {{ .emailSMS.user.smsActivationUrl }} - passwordResetUrl: {{ .emailSMS.user.passwordResetUrl }} - {{- if .emailSMS.user.invitationUrl }} - invitationUrl: {{ .emailSMS.user.invitationUrl }} - {{- end }} - deletionUrl: {{ .emailSMS.user.deletionUrl }} {{- else }} - activationUrl: {{ .externalUrls.nginz }}/activate?key=${key}&code=${code} smsActivationUrl: {{ .externalUrls.nginz }}/v/${code} - passwordResetUrl: {{ .externalUrls.nginz }}/password-reset/${key}?code=${code} - invitationUrl: {{ .externalUrls.nginz }}/register?invitation_code=${code} - deletionUrl: {{ .externalUrls.nginz }}/users/delete?key=${key}&code=${code} - {{- end }} - - provider: - {{- if .emailSMS.provider }} - homeUrl: {{ .emailSMS.provider.homeUrl }} - providerActivationUrl: {{ .emailSMS.provider.providerActivationUrl }} - approvalUrl: {{ .emailSMS.provider.approvalUrl }} - approvalTo: {{ .emailSMS.provider.approvalTo }} - providerPwResetUrl: {{ .emailSMS.provider.providerPwResetUrl }} - {{- else }} - homeUrl: https://provider.localhost/ - providerActivationUrl: {{ .externalUrls.nginz }}/provider/activate?key=${key}&code=${code} - approvalUrl: {{ .externalUrls.nginz }}/provider/approve?key=${key}&code=${code} - approvalTo: success@simulator.amazonses.com - providerPwResetUrl: {{ .externalUrls.nginz }}/provider/password-reset?key=\${key}\&code=\${code} {{- end }} team: diff --git a/charts/wire-server/values.yaml b/charts/wire-server/values.yaml index be8443f4412..b1d75c82c72 100644 --- a/charts/wire-server/values.yaml +++ b/charts/wire-server/values.yaml @@ -372,8 +372,7 @@ galley: seccompProfile: type: RuntimeDefault tests: - config: - {} + config: {} # uploadXml: # baseUrl: s3://bucket/path/ @@ -1087,11 +1086,49 @@ background-worker: sesEndpoint: https://email.eu-west-1.amazonaws.com # sesQueue is required when useSES is true (deployment-specific), e.g.: # sesQueue: wire-brig-events + # SMTP transport (used when useSES is false). The ConfigMap renders these # into the `email` block; mirrors brig's `smtp` settings. smtp: passwordFile: /etc/wire/background-worker/secrets/smtp-password.txt + # Email templates used to compose the emails queued by brig. + # The background-worker composes all outbound email from these localized + # templates (bundled in the image at templateDir); brig no longer has any + # template/URL/branding settings, so these values must match what brig + # used to configure. + emailTemplates: + templateDir: /usr/share/wire/templates + emailSender: backend@wire.com + templateBranding: + brand: Wire + brandUrl: https://wire.com + brandLabelUrl: wire.com + brandLogoUrl: https://wire.com/p/img/email/logo-email-black.png + brandService: Wire Service Provider + copyright: © WIRE SWISS GmbH + misuse: misuse@wire.com + legal: https://wire.com/legal/ + forgot: https://wire.com/forgot/ + support: https://support.wire.com/ + user: + activationUrl: https:///activate?key=${key}&code=${code} + teamActivationUrl: https:///register?team=${team}&team_code=${code} + passwordResetUrl: https:///password-reset/${key}?code=${code} + deletionUrl: https:///users/delete?key=${key}&code=${code} + team: + tInvitationUrl: https:///register?team=${team}&team_code=${code} + tExistingUserInvitationUrl: https:///register?invitation_code=${code} + tActivationUrl: https:///register?team=${team}&team_code=${code} + tCreatorWelcomeUrl: https://example.com/login + tMemberWelcomeUrl: https://example.com/download + provider: + homeUrl: https://provider.localhost/ + providerActivationUrl: https:///provider/activate?key=${key}&code=${code} + approvalUrl: https:///provider/approve?key=${key}&code=${code} + approvalTo: success@simulator.amazonses.com + providerPwResetUrl: https:///provider/password-reset?key=${key}&code=${code} + # Optional secret keys (see templates/background-worker/secret.yaml): # awsKeyId: # required for SES; rendered as AWS_ACCESS_KEY_ID # awsSecretKey: # required for SES; rendered as AWS_SECRET_ACCESS_KEY @@ -1214,19 +1251,6 @@ brig: acquisitionTimeout: 10s idlenessTimeout: 10m - emailSMS: - general: - templateBranding: - brand: Wire - brandUrl: https://wire.com - brandLabelUrl: wire.com - brandLogoUrl: https://wire.com/p/img/email/logo-email-black.png - brandService: Wire Service Provider - copyright: © WIRE SWISS GmbH - misuse: misuse@wire.com - legal: https://wire.com/legal/ - forgot: https://wire.com/forgot/ - support: https://support.wire.com/ authSettings: keyIndex: 1 userTokenTimeout: 4838400 @@ -1346,8 +1370,7 @@ brig: seccompProfile: type: RuntimeDefault tests: - config: - {} + config: {} # uploadXml: # baseUrl: s3://bucket/path/ diff --git a/docs/src/developer/reference/config-options.md b/docs/src/developer/reference/config-options.md index 26321ae6067..2fe1586d466 100644 --- a/docs/src/developer/reference/config-options.md +++ b/docs/src/developer/reference/config-options.md @@ -2451,6 +2451,7 @@ Notes ## Background worker: Email sending + The background-worker delivers the email jobs enqueued by brig on the `emails` Arbiter queue (PostgreSQL). It requires an `email` transport (AWS SES or SMTP), the same shape brig uses for `emailSMS.email`. Configuration is supplied via @@ -2515,6 +2516,50 @@ Notes queue's dead-letter queue, so transient worker downtime does not lose email jobs. - The `emails` queue and its dead-letter table live in the shared PostgreSQL - database and contain full email content (including one-time codes and reset - links for jobs that were never delivered). Keep database access - least-privileged and monitor DLQ growth. + database and contain the queued request data (including one-time codes, + recipient addresses and reset URLs for jobs that were never delivered). Keep + database access least-privileged and monitor DLQ growth. + +## Background worker: Email templates + +The background-worker does not only deliver email, it **composes** it: brig +enqueues the composing payload (email type, locale and inputs such as +recipient, keys/codes, team names) as `send_email` jobs, and the worker +selects the localized template, renders the placeholders and builds the MIME +mail right before sending. The templates directory ships in the +background-worker image at `/usr/share/wire/templates`. + +Configure it via Helm under `background-worker.config.emailTemplates` +(rendered into the `emailTemplates` block of `background-worker.yaml`). These +settings were previously brig's `emailSMS` template/URL/branding settings; +brig no longer has them, so deployments must carry them on the worker instead +(they must match what brig used to configure, or emails will render with +different URLs/branding than before): + +```yaml +config: + emailTemplates: + templateDir: /usr/share/wire/templates + # defaultLocale: en # optional; falls back to en + emailSender: backend@wire.com + templateBranding: # the 10 branding placeholders + brand: Wire + brandUrl: https://wire.com + # ... + user: # user email URL templates + activationUrl: https:///activate?key=${key}&code=${code} + teamActivationUrl: https:///register?team=${team}&team_code=${code} + passwordResetUrl: https:///password-reset/${key}?code=${code} + deletionUrl: https:///users/delete?key=${key}&code=${code} + team: # team email URL templates + tInvitationUrl: https:///register?team=${team}&team_code=${code} + # ... + provider: # provider email URL templates + homeUrl: https://provider.example.com/ + # ... +``` + +brig still configures `emailSMS.general.emailSender` (used for SCIM +invitations and the enterprise audit email configuration) and the team +invitation URL templates (`emailSMS.team`, rendered into API responses); +everything else email-related lives on the worker. diff --git a/hack/helm_vars/wire-server/values.yaml.gotmpl b/hack/helm_vars/wire-server/values.yaml.gotmpl index b2cbfeb8bca..69c7dcbc2df 100644 --- a/hack/helm_vars/wire-server/values.yaml.gotmpl +++ b/hack/helm_vars/wire-server/values.yaml.gotmpl @@ -161,10 +161,7 @@ brig: emailSender: backend-integrationk8s@wire.com smsSender: dummy user: - activationUrl: https://example.com/verify/?key=${key}&code=${code} smsActivationUrl: https://example.com/v/${code} - passwordResetUrl: https://example.com/reset/?key=${key}&code=${code} - deletionUrl: https://example.com/d/?key=${key}&code=${code} team: tInvitationUrl: https://example.com/join/?team-code=${code} tExistingUserInvitationUrl: https://example.com/accept-invitation/?team-code=${code} @@ -685,6 +682,28 @@ background-worker: cleanOlderThanHours: 0.0014 batchSize: 100 schedule: "* * * * *" + # Email templates for composing the emails queued by brig; + # mirrors the values brig used to configure. + emailTemplates: + templateDir: /usr/share/wire/templates + emailSender: backend-integrationk8s@wire.com + user: + activationUrl: https://example.com/verify/?key=${key}&code=${code} + teamActivationUrl: https://example.com/verify/?key=${key}&code=${code} + passwordResetUrl: https://example.com/reset/?key=${key}&code=${code} + deletionUrl: https://example.com/d/?key=${key}&code=${code} + team: + tInvitationUrl: https://example.com/join/?team-code=${code} + tExistingUserInvitationUrl: https://example.com/accept-invitation/?team-code=${code} + tActivationUrl: https://example.com/verify/?key=${key}&code=${code} + tCreatorWelcomeUrl: https://example.com/login + tMemberWelcomeUrl: https://example.com/download + provider: + homeUrl: https://example.com/ + providerActivationUrl: https://example.com/provider-activate/?key=${key}&code=${code} + approvalUrl: https://example.com/provider-approve/?key=${key}&code=${code} + approvalTo: backend-integrationk8s@wire.com + providerPwResetUrl: https://example.com/provider-reset/?key=${key}&code=${code} # Cassandra clusters used by background-worker cassandra: host: {{ .Values.cassandraHost }} diff --git a/integration/test/Testlib/ModService.hs b/integration/test/Testlib/ModService.hs index a02f921639a..a6729cfdb15 100644 --- a/integration/test/Testlib/ModService.hs +++ b/integration/test/Testlib/ModService.hs @@ -227,7 +227,8 @@ defaultOverrides resource = setField "federatorInternal.port" resource.berFederatorInternal >=> setField "federatorInternal.host" ("127.0.0.1" :: String) >=> setField "federationDomain" resource.berDomain - >=> setField "rabbitmq.vHost" resource.berVHost, + >=> setField "rabbitmq.vHost" resource.berVHost + >=> setField "emailTemplates.emailSender" resource.berEmailSMSEmailSender, federatorInternalCfg = setField "federatorInternal.port" resource.berFederatorInternal >=> setField "federatorExternal.port" resource.berFederatorExternal diff --git a/libs/wire-api/src/Wire/API/BackgroundJobs/Email.hs b/libs/wire-api/src/Wire/API/BackgroundJobs/Email.hs index 1273c6a46f2..a899295d18a 100644 --- a/libs/wire-api/src/Wire/API/BackgroundJobs/Email.hs +++ b/libs/wire-api/src/Wire/API/BackgroundJobs/Email.hs @@ -1,9 +1,10 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE StrictData #-} {-# LANGUAGE TemplateHaskell #-} -- This file is part of the Wire Server implementation. -- --- Copyright (C) 2025 Wire Swiss GmbH +-- Copyright (C) 2026 Wire Swiss GmbH -- -- This program is free software: you can redistribute it and/or modify it under -- the terms of the GNU Affero General Public License as published by the Free @@ -18,222 +19,541 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . --- | Serializable email types (WPB-27255). +-- | Composing payload for outbound email. -- -- Outbound email is queued to the background-worker as a 'SendEmail' job on --- the Arbiter @emails@ queue (see "Wire.API.Jobs"). The actual SMTP\/SES send --- happens in the worker; brig only enqueues. --- --- @wire-api@ cannot depend on @mime-mail@, so a mail is serialised as the plain --- records below. The @Mail@ <-> record conversion lives in @wire-subsystems@ --- ("Wire.EmailSending.Queueing"). Flat part content is stored as base64-encoded --- 'Text'; nested alternative groups are modelled recursively via --- 'SerializablePartContent'. +-- the Arbiter @emails@ queue (see "Wire.API.Jobs"). Producers (brig) enqueue +-- the /composing payload/ only: the email type, locale and structured inputs +-- (recipient, keys\/codes, team names, cert summaries, ...). The +-- background-worker composes the actual email (locale template selection, +-- placeholder rendering, MIME building) right before sending. No rendered +-- email content ever crosses the queue. module Wire.API.BackgroundJobs.Email where import Control.Arrow ((&&&)) import Control.Lens (makePrisms) import Data.Aeson qualified as Aeson +import Data.Code qualified as Code +import Data.Id import Data.Schema import Imports -import Test.QuickCheck qualified as QC +import Test.QuickCheck (oneof) +import Wire.API.EnterpriseLogin (DomainRegistrationResponse, mkDomainRegistrationResponse) +import Wire.API.Locale +import Wire.API.Routes.Version (Version (V10)) +import Wire.API.User +import Wire.API.User.Activation (ActivationCode, ActivationKey) +import Wire.API.User.Client (Client) +import Wire.API.User.Password (PasswordResetCode, PasswordResetKey) import Wire.Arbitrary (Arbitrary (..), GenericUniform (..)) -data SerializableMailAddress = SerializableMailAddress - { smaName :: !(Maybe Text), - smaEmail :: !Text +-- | Fingerprint summary of an IdP certificate, as needed for the +-- IdP-configuration-change notification email. +data CertSummary = CertSummary + { algorithm :: !Text, + fingerprint :: !Text, + subject :: !Text, + issuer :: !Text } deriving stock (Eq, Show, Generic) - deriving (Aeson.ToJSON, Aeson.FromJSON) via (Schema SerializableMailAddress) - deriving (Arbitrary) via GenericUniform SerializableMailAddress + deriving (Aeson.ToJSON, Aeson.FromJSON) via (Schema CertSummary) + deriving (Arbitrary) via GenericUniform CertSummary -instance ToSchema SerializableMailAddress where +instance ToSchema CertSummary where schema = object $ - SerializableMailAddress - <$> (.smaName) .= maybe_ (optField "name" schema) - <*> (.smaEmail) .= field "email" schema + CertSummary + <$> (.algorithm) .= field "algorithm" schema + <*> (.fingerprint) .= field "fingerprint" schema + <*> (.subject) .= field "subject" schema + <*> (.issuer) .= field "issuer" schema -data SerializableMailHeader = SerializableMailHeader - { smhName :: !Text, - smhValue :: !Text +data VerificationEmail = MkVerificationEmail + { to :: !EmailAddress, + key :: !ActivationKey, + code :: !ActivationCode, + locale :: !(Maybe Locale) } deriving stock (Eq, Show, Generic) - deriving (Aeson.ToJSON, Aeson.FromJSON) via (Schema SerializableMailHeader) - deriving (Arbitrary) via GenericUniform SerializableMailHeader + deriving (Aeson.ToJSON, Aeson.FromJSON) via (Schema VerificationEmail) + deriving (Arbitrary) via GenericUniform VerificationEmail -instance ToSchema SerializableMailHeader where +instance ToSchema VerificationEmail where schema = object $ - SerializableMailHeader - <$> (.smhName) .= field "name" schema - <*> (.smhValue) .= field "value" schema + MkVerificationEmail + <$> (.to) .= field "to" schema + <*> (.key) .= field "key" schema + <*> (.code) .= field "code" schema + <*> (.locale) .= maybe_ (optField "locale" schema) -data SerializableEncoding - = SerializableEncodingNone - | SerializableEncodingBase64 - | SerializableEncodingQuotedPrintableBinary - | SerializableEncodingQuotedPrintableText - deriving stock (Eq, Ord, Bounded, Enum, Show, Generic) - deriving (Aeson.ToJSON, Aeson.FromJSON) via (Schema SerializableEncoding) - deriving (Arbitrary) via GenericUniform SerializableEncoding +data ActivationEmail = MkActivationEmail + { to :: !EmailAddress, + name :: !Name, + key :: !ActivationKey, + code :: !ActivationCode, + locale :: !(Maybe Locale) + } + deriving stock (Eq, Show, Generic) + deriving (Aeson.ToJSON, Aeson.FromJSON) via (Schema ActivationEmail) + deriving (Arbitrary) via GenericUniform ActivationEmail -instance ToSchema SerializableEncoding where +instance ToSchema ActivationEmail where schema = - enum @Text $ - mconcat - [ element "none" SerializableEncodingNone, - element "base64" SerializableEncodingBase64, - element "quoted-printable-binary" SerializableEncodingQuotedPrintableBinary, - element "quoted-printable-text" SerializableEncodingQuotedPrintableText - ] + object $ + MkActivationEmail + <$> (.to) .= field "to" schema + <*> (.name) .= field "name" schema + <*> (.key) .= field "key" schema + <*> (.code) .= field "code" schema + <*> (.locale) .= maybe_ (optField "locale" schema) -data SerializableDisposition = SerializableDisposition - { smdType :: !SerializableDispositionType, - smdFilename :: !Text +data TeamActivationEmail = MkTeamActivationEmail + { to :: !EmailAddress, + name :: !Name, + key :: !ActivationKey, + code :: !ActivationCode, + teamName :: !Text, + locale :: !(Maybe Locale) } deriving stock (Eq, Show, Generic) - deriving (Aeson.ToJSON, Aeson.FromJSON) via (Schema SerializableDisposition) - deriving (Arbitrary) via GenericUniform SerializableDisposition + deriving (Aeson.ToJSON, Aeson.FromJSON) via (Schema TeamActivationEmail) + deriving (Arbitrary) via GenericUniform TeamActivationEmail -instance ToSchema SerializableDisposition where +instance ToSchema TeamActivationEmail where schema = object $ - SerializableDisposition - <$> (.smdType) .= field "type" schema - <*> (.smdFilename) .= field "filename" schema + MkTeamActivationEmail + <$> (.to) .= field "to" schema + <*> (.name) .= field "name" schema + <*> (.key) .= field "key" schema + <*> (.code) .= field "code" schema + <*> (.teamName) .= field "team_name" schema + <*> (.locale) .= maybe_ (optField "locale" schema) -data SerializableDispositionType - = SerializableDispositionDefault - | SerializableDispositionInline - | SerializableDispositionAttachment - deriving stock (Eq, Ord, Bounded, Enum, Show, Generic) - deriving (Aeson.ToJSON, Aeson.FromJSON) via (Schema SerializableDispositionType) - deriving (Arbitrary) via GenericUniform SerializableDispositionType +data PasswordResetEmail = MkPasswordResetEmail + { to :: !EmailAddress, + key :: !PasswordResetKey, + code :: !PasswordResetCode, + locale :: !(Maybe Locale) + } + deriving stock (Eq, Show, Generic) + deriving (Aeson.ToJSON, Aeson.FromJSON) via (Schema PasswordResetEmail) + deriving (Arbitrary) via GenericUniform PasswordResetEmail -instance ToSchema SerializableDispositionType where +instance ToSchema PasswordResetEmail where schema = - enum @Text $ - mconcat - [ element "default" SerializableDispositionDefault, - element "inline" SerializableDispositionInline, - element "attachment" SerializableDispositionAttachment - ] + object $ + MkPasswordResetEmail + <$> (.to) .= field "to" schema + <*> (.key) .= field "key" schema + <*> (.code) .= field "code" schema + <*> (.locale) .= maybe_ (optField "locale" schema) --- | Mutually recursive with 'SerializableMailPart': a part's content is either --- flat bytes or a nested alternative group of parts. Both types must be --- declared before the @makePrisms@ splice below, so 'SerializableMailPart' gets --- its schema/arbitrary instances after it. -data SerializableMailPart = SerializableMailPart - { smpType :: !Text, - smpEncoding :: !SerializableEncoding, - smpDisposition :: !SerializableDisposition, - smpHeaders :: ![SerializableMailHeader], - smpContent :: !SerializablePartContent +data NewClientEmail = MkNewClientEmail + { to :: !EmailAddress, + name :: !Name, + client :: !Client, + locale :: !Locale } deriving stock (Eq, Show, Generic) + deriving (Aeson.ToJSON, Aeson.FromJSON) via (Schema NewClientEmail) + deriving (Arbitrary) via GenericUniform NewClientEmail -data SerializablePartContent - = -- | base64-encoded part content - SerializablePartContentText !Text - | SerializablePartContentNestedParts ![SerializableMailPart] +instance ToSchema NewClientEmail where + schema = + object $ + MkNewClientEmail + <$> (.to) .= field "to" schema + <*> (.name) .= field "name" schema + <*> (.client) .= field "client" schema + <*> (.locale) .= field "locale" schema + +data AccountDeletionEmail = MkAccountDeletionEmail + { to :: !EmailAddress, + name :: !Name, + key :: !Code.Key, + code :: !Code.Value, + locale :: !Locale + } deriving stock (Eq, Show, Generic) + deriving (Aeson.ToJSON, Aeson.FromJSON) via (Schema AccountDeletionEmail) + deriving (Arbitrary) via GenericUniform AccountDeletionEmail -data SerializablePartContentTag - = SerializablePartContentTextTag - | SerializablePartContentNestedPartsTag - deriving stock (Eq, Ord, Bounded, Enum, Show, Generic) - deriving (Arbitrary) via GenericUniform SerializablePartContentTag +instance ToSchema AccountDeletionEmail where + schema = + object $ + MkAccountDeletionEmail + <$> (.to) .= field "to" schema + <*> (.name) .= field "name" schema + <*> (.key) .= field "key" schema + <*> (.code) .= field "code" schema + <*> (.locale) .= field "locale" schema -instance ToSchema SerializablePartContentTag where +data SecondFactorVerificationEmail = MkSecondFactorVerificationEmail + { to :: !EmailAddress, + code :: !Code.Value, + locale :: !(Maybe Locale) + } + deriving stock (Eq, Show, Generic) + deriving (Aeson.ToJSON, Aeson.FromJSON) via (Schema SecondFactorVerificationEmail) + deriving (Arbitrary) via GenericUniform SecondFactorVerificationEmail + +instance ToSchema SecondFactorVerificationEmail where schema = - enum @Text $ - mconcat - [ element "text" SerializablePartContentTextTag, - element "nested-parts" SerializablePartContentNestedPartsTag - ] + object $ + MkSecondFactorVerificationEmail + <$> (.to) .= field "to" schema + <*> (.code) .= field "code" schema + <*> (.locale) .= maybe_ (optField "locale" schema) -serializablePartContentTag :: SerializablePartContent -> SerializablePartContentTag -serializablePartContentTag = - \case - SerializablePartContentText {} -> SerializablePartContentTextTag - SerializablePartContentNestedParts {} -> SerializablePartContentNestedPartsTag - -makePrisms ''SerializablePartContent - --- NB: this schema is recursive (nested parts reference 'SerializableMailPart', --- whose schema references this one), so it must never be inlined into an --- OpenApi document (the bridge inlines properties and would loop); it exists --- for the Aeson derivation only. -instance ToSchema SerializablePartContent where - schema = object serializablePartContentObjectSchema - -serializablePartContentObjectSchema :: ObjectSchema SwaggerDoc SerializablePartContent -serializablePartContentObjectSchema = - snd - <$> (serializablePartContentTag &&& id) - .= bind - (fst .= field "type" schema) - (snd .= dispatch serializablePartContentDataSchema) - where - serializablePartContentDataSchema :: SerializablePartContentTag -> ObjectSchema SwaggerDoc SerializablePartContent - serializablePartContentDataSchema = \case - SerializablePartContentTextTag -> - tag _SerializablePartContentText (field "content" schema) - SerializablePartContentNestedPartsTag -> - tag _SerializablePartContentNestedParts (field "content" (array schema)) +data TeamInvitationEmail = MkTeamInvitationEmail + { to :: !EmailAddress, + teamId :: !TeamId, + -- | the inviting user's email address (renders the template's + -- @${inviter}@ placeholder) + inviter :: !EmailAddress, + code :: !InvitationCode, + locale :: !(Maybe Locale) + } + deriving stock (Eq, Show, Generic) + deriving (Aeson.ToJSON, Aeson.FromJSON) via (Schema TeamInvitationEmail) + deriving (Arbitrary) via GenericUniform TeamInvitationEmail -deriving via (Schema SerializablePartContent) instance Aeson.ToJSON SerializablePartContent +instance ToSchema TeamInvitationEmail where + schema = + object $ + MkTeamInvitationEmail + <$> (.to) .= field "to" schema + <*> (.teamId) .= field "team_id" schema + <*> (.inviter) .= field "inviter" schema + <*> (.code) .= field "code" schema + <*> (.locale) .= maybe_ (optField "locale" schema) -deriving via (Schema SerializablePartContent) instance Aeson.FromJSON SerializablePartContent +data MemberWelcomeEmail = MkMemberWelcomeEmail + { to :: !EmailAddress, + teamId :: !TeamId, + teamName :: !Text, + locale :: !(Maybe Locale) + } + deriving stock (Eq, Show, Generic) + deriving (Aeson.ToJSON, Aeson.FromJSON) via (Schema MemberWelcomeEmail) + deriving (Arbitrary) via GenericUniform MemberWelcomeEmail -instance Arbitrary SerializablePartContent where - arbitrary = - QC.sized $ \n -> - if n <= 0 - then SerializablePartContentText <$> arbitrary - else - QC.oneof - [ SerializablePartContentText <$> arbitrary, - SerializablePartContentNestedParts . getGenericUniform <$> QC.resize (n `div` 4) arbitrary - ] - shrink = QC.genericShrink +instance ToSchema MemberWelcomeEmail where + schema = + object $ + MkMemberWelcomeEmail + <$> (.to) .= field "to" schema + <*> (.teamId) .= field "team_id" schema + <*> (.teamName) .= field "team_name" schema + <*> (.locale) .= maybe_ (optField "locale" schema) -deriving via (Schema SerializableMailPart) instance Aeson.ToJSON SerializableMailPart +data NewTeamOwnerWelcomeEmail = MkNewTeamOwnerWelcomeEmail + { to :: !EmailAddress, + teamId :: !TeamId, + teamName :: !Text, + profileName :: !Name, + locale :: !(Maybe Locale) + } + deriving stock (Eq, Show, Generic) + deriving (Aeson.ToJSON, Aeson.FromJSON) via (Schema NewTeamOwnerWelcomeEmail) + deriving (Arbitrary) via GenericUniform NewTeamOwnerWelcomeEmail -deriving via (Schema SerializableMailPart) instance Aeson.FromJSON SerializableMailPart +instance ToSchema NewTeamOwnerWelcomeEmail where + schema = + object $ + MkNewTeamOwnerWelcomeEmail + <$> (.to) .= field "to" schema + <*> (.teamId) .= field "team_id" schema + <*> (.teamName) .= field "team_name" schema + <*> (.profileName) .= field "profile_name" schema + <*> (.locale) .= maybe_ (optField "locale" schema) -deriving via GenericUniform SerializableMailPart instance Arbitrary SerializableMailPart +data IdpChangedEmail = MkIdpChangedEmail + { to :: !EmailAddress, + teamId :: !TeamId, + userId :: !(Maybe UserId), + addedCerts :: ![CertSummary], + removedCerts :: ![CertSummary], + idpId :: !Text, + oldIssuer :: !(Maybe Text), + oldEndpoint :: !(Maybe Text), + newIssuer :: !(Maybe Text), + newEndpoint :: !(Maybe Text), + locale :: !(Maybe Locale) + } + deriving stock (Eq, Show, Generic) + deriving (Aeson.ToJSON, Aeson.FromJSON) via (Schema IdpChangedEmail) + deriving (Arbitrary) via GenericUniform IdpChangedEmail -instance ToSchema SerializableMailPart where +instance ToSchema IdpChangedEmail where schema = object $ - SerializableMailPart - <$> (.smpType) .= field "type" schema - <*> (.smpEncoding) .= field "encoding" schema - <*> (.smpDisposition) .= field "disposition" schema - <*> (.smpHeaders) .= field "headers" (array schema) - <*> (.smpContent) .= field "content" schema + MkIdpChangedEmail + <$> (.to) .= field "to" schema + <*> (.teamId) .= field "team_id" schema + <*> (.userId) .= maybe_ (optField "user_id" schema) + <*> (.addedCerts) .= field "added_certs" (array schema) + <*> (.removedCerts) .= field "removed_certs" (array schema) + <*> (.idpId) .= field "idp_id" schema + <*> (.oldIssuer) .= maybe_ (optField "old_issuer" schema) + <*> (.oldEndpoint) .= maybe_ (optField "old_endpoint" schema) + <*> (.newIssuer) .= maybe_ (optField "new_issuer" schema) + <*> (.newEndpoint) .= maybe_ (optField "new_endpoint" schema) + <*> (.locale) .= maybe_ (optField "locale" schema) -data SerializableMail = SerializableMail - { smFrom :: !SerializableMailAddress, - smTo :: ![SerializableMailAddress], - smCc :: ![SerializableMailAddress], - smBcc :: ![SerializableMailAddress], - smHeaders :: ![SerializableMailHeader], - smParts :: ![[SerializableMailPart]] +data ProviderActivationEmail = MkProviderActivationEmail + { to :: !EmailAddress, + name :: !Name, + key :: !Code.Key, + code :: !Code.Value, + update :: !Bool } deriving stock (Eq, Show, Generic) - deriving (Aeson.ToJSON, Aeson.FromJSON) via (Schema SerializableMail) - deriving (Arbitrary) via GenericUniform SerializableMail + deriving (Aeson.ToJSON, Aeson.FromJSON) via (Schema ProviderActivationEmail) + deriving (Arbitrary) via GenericUniform ProviderActivationEmail -instance ToSchema SerializableMail where +instance ToSchema ProviderActivationEmail where schema = object $ - SerializableMail - <$> (.smFrom) .= field "from" schema - <*> (.smTo) .= field "to" (array schema) - <*> (.smCc) .= field "cc" (array schema) - <*> (.smBcc) .= field "bcc" (array schema) - <*> (.smHeaders) .= field "headers" (array schema) - <*> (.smParts) .= field "parts" (array (array schema)) + MkProviderActivationEmail + <$> (.to) .= field "to" schema + <*> (.name) .= field "name" schema + <*> (.key) .= field "key" schema + <*> (.code) .= field "code" schema + <*> (.update) .= field "update" schema + +data ProviderApprovalConfirmEmail = MkProviderApprovalConfirmEmail + { to :: !EmailAddress, + name :: !Name + } + deriving stock (Eq, Show, Generic) + deriving (Aeson.ToJSON, Aeson.FromJSON) via (Schema ProviderApprovalConfirmEmail) + deriving (Arbitrary) via GenericUniform ProviderApprovalConfirmEmail + +instance ToSchema ProviderApprovalConfirmEmail where + schema = + object $ + MkProviderApprovalConfirmEmail + <$> (.to) .= field "to" schema + <*> (.name) .= field "name" schema + +data ProviderPasswordResetEmail = MkProviderPasswordResetEmail + { to :: !EmailAddress, + key :: !Code.Key, + code :: !Code.Value + } + deriving stock (Eq, Show, Generic) + deriving (Aeson.ToJSON, Aeson.FromJSON) via (Schema ProviderPasswordResetEmail) + deriving (Arbitrary) via GenericUniform ProviderPasswordResetEmail + +instance ToSchema ProviderPasswordResetEmail where + schema = + object $ + MkProviderPasswordResetEmail + <$> (.to) .= field "to" schema + <*> (.key) .= field "key" schema + <*> (.code) .= field "code" schema + +data EnterpriseAuditEmail = MkEnterpriseAuditEmail + { from :: !EmailAddress, + to :: !EmailAddress, + subject :: !Text, + url :: !Text, + before :: !(Maybe (DomainRegistrationResponse V10)), + after :: !(Maybe (DomainRegistrationResponse V10)) + } + deriving stock (Eq, Show, Generic) + deriving (Aeson.ToJSON, Aeson.FromJSON) via (Schema EnterpriseAuditEmail) + +instance ToSchema EnterpriseAuditEmail where + schema = + object $ + MkEnterpriseAuditEmail + <$> (.from) .= field "from" schema + <*> (.to) .= field "to" schema + <*> (.subject) .= field "subject" schema + <*> (.url) .= field "url" schema + <*> (.before) .= maybe_ (optField "before" schema) + <*> (.after) .= maybe_ (optField "after" schema) + +instance Arbitrary EnterpriseAuditEmail where + arbitrary = + MkEnterpriseAuditEmail + <$> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> (fmap mkDomainRegistrationResponse <$> arbitrary) + <*> (fmap mkDomainRegistrationResponse <$> arbitrary) + +-- | The composing payload enqueued on the @emails@ queue: the email variant +-- plus its structured inputs. Keep the type tags and nested data shapes stable +-- when changing job payloads; workers decode them later, so changes require a +-- coordinated rollout. +data SendEmailRequest + = VerificationEmail !VerificationEmail + | ActivationEmail !ActivationEmail + | EmailAddressUpdateEmail !ActivationEmail + | TeamActivationEmail !TeamActivationEmail + | PasswordResetEmail !PasswordResetEmail + | NewClientEmail !NewClientEmail + | AccountDeletionEmail !AccountDeletionEmail + | LoginVerificationEmail !SecondFactorVerificationEmail + | ScimTokenVerificationEmail !SecondFactorVerificationEmail + | TeamDeletionVerificationEmail !SecondFactorVerificationEmail + | TeamInvitationEmail !TeamInvitationEmail + | TeamInvitationPersonalUserEmail !TeamInvitationEmail + | MemberWelcomeEmail !MemberWelcomeEmail + | NewTeamOwnerWelcomeEmail !NewTeamOwnerWelcomeEmail + | IdpChangedEmail !IdpChangedEmail + | ProviderActivationEmail !ProviderActivationEmail + | ProviderApprovalConfirmEmail !ProviderApprovalConfirmEmail + | ProviderPasswordResetEmail !ProviderPasswordResetEmail + | EnterpriseAuditEmail !EnterpriseAuditEmail + deriving stock (Eq, Show, Generic) + +data SendEmailRequestTag + = VerificationEmailTag + | ActivationEmailTag + | EmailAddressUpdateEmailTag + | TeamActivationEmailTag + | PasswordResetEmailTag + | NewClientEmailTag + | AccountDeletionEmailTag + | LoginVerificationEmailTag + | ScimTokenVerificationEmailTag + | TeamDeletionVerificationEmailTag + | TeamInvitationEmailTag + | TeamInvitationPersonalUserEmailTag + | MemberWelcomeEmailTag + | NewTeamOwnerWelcomeEmailTag + | IdpChangedEmailTag + | ProviderActivationEmailTag + | ProviderApprovalConfirmEmailTag + | ProviderPasswordResetEmailTag + | EnterpriseAuditEmailTag + deriving stock (Eq, Ord, Bounded, Enum, Show, Generic) + deriving (Arbitrary) via GenericUniform SendEmailRequestTag + +instance ToSchema SendEmailRequestTag where + schema = + enum @Text $ + mconcat + [ element "verification" VerificationEmailTag, + element "activation" ActivationEmailTag, + element "email_update" EmailAddressUpdateEmailTag, + element "team_activation" TeamActivationEmailTag, + element "password_reset" PasswordResetEmailTag, + element "new_client" NewClientEmailTag, + element "account_deletion" AccountDeletionEmailTag, + element "login_verification" LoginVerificationEmailTag, + element "scim_token_verification" ScimTokenVerificationEmailTag, + element "team_deletion_verification" TeamDeletionVerificationEmailTag, + element "team_invitation" TeamInvitationEmailTag, + element "team_invitation_personal_user" TeamInvitationPersonalUserEmailTag, + element "member_welcome" MemberWelcomeEmailTag, + element "new_team_owner_welcome" NewTeamOwnerWelcomeEmailTag, + element "idp_changed" IdpChangedEmailTag, + element "provider_activation" ProviderActivationEmailTag, + element "provider_approval_confirm" ProviderApprovalConfirmEmailTag, + element "provider_password_reset" ProviderPasswordResetEmailTag, + element "enterprise_audit" EnterpriseAuditEmailTag + ] + +makePrisms ''SendEmailRequest + +sendEmailRequestTag :: SendEmailRequest -> SendEmailRequestTag +sendEmailRequestTag = \case + VerificationEmail {} -> VerificationEmailTag + ActivationEmail {} -> ActivationEmailTag + EmailAddressUpdateEmail {} -> EmailAddressUpdateEmailTag + TeamActivationEmail {} -> TeamActivationEmailTag + PasswordResetEmail {} -> PasswordResetEmailTag + NewClientEmail {} -> NewClientEmailTag + AccountDeletionEmail {} -> AccountDeletionEmailTag + LoginVerificationEmail {} -> LoginVerificationEmailTag + ScimTokenVerificationEmail {} -> ScimTokenVerificationEmailTag + TeamDeletionVerificationEmail {} -> TeamDeletionVerificationEmailTag + TeamInvitationEmail {} -> TeamInvitationEmailTag + TeamInvitationPersonalUserEmail {} -> TeamInvitationPersonalUserEmailTag + MemberWelcomeEmail {} -> MemberWelcomeEmailTag + NewTeamOwnerWelcomeEmail {} -> NewTeamOwnerWelcomeEmailTag + IdpChangedEmail {} -> IdpChangedEmailTag + ProviderActivationEmail {} -> ProviderActivationEmailTag + ProviderApprovalConfirmEmail {} -> ProviderApprovalConfirmEmailTag + ProviderPasswordResetEmail {} -> ProviderPasswordResetEmailTag + EnterpriseAuditEmail {} -> EnterpriseAuditEmailTag + +instance ToSchema SendEmailRequest where + schema = object sendEmailRequestObjectSchema + +-- | Common representation for all tagged job payload envelopes: the stable +-- @{\"type\": ..., \"data\": ...}@ shape. Defined here (not in +-- "Wire.API.Jobs") because Jobs imports this module; Jobs re-uses it for its +-- own payloads. +taggedJobPayloadObjectSchema :: + forall tag payload. + (Bounded tag, Enum tag, ToSchema tag) => + (payload -> tag) -> + (tag -> ObjectSchema SwaggerDoc payload) -> + ObjectSchema SwaggerDoc payload +taggedJobPayloadObjectSchema toTag toSchema = + snd <$> (toTag &&& id) .= bind (fst .= tagObjectSchema) (snd .= dispatch toSchema) + where + tagObjectSchema :: ObjectSchema SwaggerDoc tag + tagObjectSchema = field "type" schema + +deriving via (Schema SendEmailRequest) instance Aeson.ToJSON SendEmailRequest + +deriving via (Schema SendEmailRequest) instance Aeson.FromJSON SendEmailRequest + +sendEmailRequestObjectSchema :: ObjectSchema SwaggerDoc SendEmailRequest +sendEmailRequestObjectSchema = taggedJobPayloadObjectSchema sendEmailRequestTag dataSchema + where + dataSchema :: SendEmailRequestTag -> ObjectSchema SwaggerDoc SendEmailRequest + dataSchema = \case + VerificationEmailTag -> tag _VerificationEmail (field "data" schema) + ActivationEmailTag -> tag _ActivationEmail (field "data" schema) + EmailAddressUpdateEmailTag -> tag _EmailAddressUpdateEmail (field "data" schema) + TeamActivationEmailTag -> tag _TeamActivationEmail (field "data" schema) + PasswordResetEmailTag -> tag _PasswordResetEmail (field "data" schema) + NewClientEmailTag -> tag _NewClientEmail (field "data" schema) + AccountDeletionEmailTag -> tag _AccountDeletionEmail (field "data" schema) + LoginVerificationEmailTag -> tag _LoginVerificationEmail (field "data" schema) + ScimTokenVerificationEmailTag -> tag _ScimTokenVerificationEmail (field "data" schema) + TeamDeletionVerificationEmailTag -> tag _TeamDeletionVerificationEmail (field "data" schema) + TeamInvitationEmailTag -> tag _TeamInvitationEmail (field "data" schema) + TeamInvitationPersonalUserEmailTag -> tag _TeamInvitationPersonalUserEmail (field "data" schema) + MemberWelcomeEmailTag -> tag _MemberWelcomeEmail (field "data" schema) + NewTeamOwnerWelcomeEmailTag -> tag _NewTeamOwnerWelcomeEmail (field "data" schema) + IdpChangedEmailTag -> tag _IdpChangedEmail (field "data" schema) + ProviderActivationEmailTag -> tag _ProviderActivationEmail (field "data" schema) + ProviderApprovalConfirmEmailTag -> tag _ProviderApprovalConfirmEmail (field "data" schema) + ProviderPasswordResetEmailTag -> tag _ProviderPasswordResetEmail (field "data" schema) + EnterpriseAuditEmailTag -> tag _EnterpriseAuditEmail (field "data" schema) + +instance Arbitrary SendEmailRequest where + arbitrary = + oneof + [ VerificationEmail <$> arbitrary, + ActivationEmail <$> arbitrary, + EmailAddressUpdateEmail <$> arbitrary, + TeamActivationEmail <$> arbitrary, + PasswordResetEmail <$> arbitrary, + NewClientEmail <$> arbitrary, + AccountDeletionEmail <$> arbitrary, + LoginVerificationEmail <$> arbitrary, + ScimTokenVerificationEmail <$> arbitrary, + TeamDeletionVerificationEmail <$> arbitrary, + TeamInvitationEmail <$> arbitrary, + TeamInvitationPersonalUserEmail <$> arbitrary, + MemberWelcomeEmail <$> arbitrary, + NewTeamOwnerWelcomeEmail <$> arbitrary, + IdpChangedEmail <$> arbitrary, + ProviderActivationEmail <$> arbitrary, + ProviderApprovalConfirmEmail <$> arbitrary, + ProviderPasswordResetEmail <$> arbitrary, + EnterpriseAuditEmail <$> arbitrary + ] diff --git a/libs/wire-api/src/Wire/API/Jobs.hs b/libs/wire-api/src/Wire/API/Jobs.hs index 4a97dafe98d..41d32883526 100644 --- a/libs/wire-api/src/Wire/API/Jobs.hs +++ b/libs/wire-api/src/Wire/API/Jobs.hs @@ -24,7 +24,6 @@ module Wire.API.Jobs where import Arbiter.Core.QueueRegistry (Queue) -import Control.Arrow ((&&&)) import Control.Lens (makePrisms) import Data.Aeson (FromJSON, ToJSON) import Data.Id @@ -36,7 +35,7 @@ import Data.Text as Text import GHC.TypeLits import Imports import Test.QuickCheck (oneof) -import Wire.API.BackgroundJobs.Email (SerializableMail) +import Wire.API.BackgroundJobs.Email (SendEmailRequest, taggedJobPayloadObjectSchema) import Wire.Arbitrary (Arbitrary (..), GenericUniform (..)) -- | The queue/table for jobs that operate on meetings. @@ -142,20 +141,8 @@ instance ToSchema AdminlessSetupJob where <*> (.adminlessSetupJobOrigUserId) .= maybe_ (optField "orig_user_id" schema) <*> (.adminlessSetupJobRequestId) .= field "request_id" schema --- | Common representation for all queue payload envelopes. -- The queue-specific sum supplies the type tag and its associated data schema, -- while this helper guarantees the stable {"type": ..., "data": ...} shape. -taggedJobPayloadObjectSchema :: - forall tag payload. - (Bounded tag, Enum tag, ToSchema tag) => - (payload -> tag) -> - (tag -> ObjectSchema SwaggerDoc payload) -> - ObjectSchema SwaggerDoc payload -taggedJobPayloadObjectSchema toTag toSchema = - snd <$> (toTag &&& id) .= bind (fst .= tagObjectSchema) (snd .= dispatch toSchema) - where - tagObjectSchema :: ObjectSchema SwaggerDoc tag - tagObjectSchema = field "type" schema -- | Payload persisted in the meetings queue. Keep the type tag and nested data -- shape stable when changing job payloads. The sum makes the queue @@ -254,14 +241,15 @@ deriving via (Schema ConversationsJobPayload) instance S.ToSchema ConversationsJ instance Arbitrary ConversationsJobPayload where arbitrary = oneof [AdminlessDeletion <$> arbitrary, AdminlessReminder <$> arbitrary] --- | Payload persisted in the emails queue. Arbiter persists these payloads and --- workers decode them later, so changes to field names or shapes require a --- coordinated rollout. The mail itself is the 'SerializableMail' record from --- "Wire.API.BackgroundJobs.Email"; the request id of the brig request that --- queued the mail is captured for logging/tracing in the worker. +-- | Payload persisted in the emails queue. Keep the type tag and nested data +-- shape stable when changing job payloads. The payload carries the composing +-- request (email type, locale and structured inputs) from +-- "Wire.API.BackgroundJobs.Email"; the background-worker composes the actual +-- email right before sending. The request id of the brig request that queued +-- the mail is captured for logging/tracing in the worker. data SendEmailJobPayload = SendEmailJobPayload { sendEmailJobRequestId :: !RequestId, - sendEmailJobMail :: !SerializableMail + sendEmailJobRequest :: !SendEmailRequest } deriving stock (Eq, Generic, Show) deriving (ToJSON, FromJSON, S.ToSchema) via (Schema SendEmailJobPayload) @@ -271,7 +259,7 @@ instance ToSchema SendEmailJobPayload where object $ SendEmailJobPayload <$> (.sendEmailJobRequestId) .= field "request_id" schema - <*> (.sendEmailJobMail) .= field "mail" schema + <*> (.sendEmailJobRequest) .= field "request" schema instance Arbitrary SendEmailJobPayload where arbitrary = SendEmailJobPayload <$> arbitrary <*> arbitrary diff --git a/libs/wire-subsystems/src/Wire/EmailSending/Composer.hs b/libs/wire-subsystems/src/Wire/EmailSending/Composer.hs new file mode 100644 index 00000000000..08a753bf3b8 --- /dev/null +++ b/libs/wire-subsystems/src/Wire/EmailSending/Composer.hs @@ -0,0 +1,283 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2026 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . +{-# LANGUAGE RecordWildCards #-} + +-- | Worker-side email composition. +-- +-- Producers enqueue the composing payload ('SendEmailRequest'); this module +-- turns a payload into a MIME 'Mail' right before sending: locale template +-- selection, placeholder rendering and MIME building all happen here. +module Wire.EmailSending.Composer + ( EmailTemplates (..), + loadEmailTemplates, + composeEmail, + ) +where + +import Data.Aeson.Encode.Pretty qualified as Aeson +import Data.Code qualified as Code +import Data.Default (def) +import Data.Range (fromRange) +import Data.Text (pack) +import Data.Text.Ascii qualified as Ascii +import Data.Text.Lazy qualified as Lazy +import Data.Text.Lazy.Encoding qualified as LT +import Data.Text.Template (Template) +import Imports +import Network.Mail.Mime +import Polysemy +import Polysemy.Output (Output) +import Wire.API.BackgroundJobs.Email +import Wire.API.EnterpriseLogin (DomainRegistrationResponse) +import Wire.API.Routes.Version (Version (V10)) +import Wire.API.User +import Wire.EmailSubsystem.Interpreter + ( InvitationEmail (..), + mkMimeAddress, + renderActivationMail, + renderDeletionEmail, + renderIdPConfigChangeEmail, + renderInvitationEmail, + renderMemberWelcomeMail, + renderNewClientEmail, + renderNewTeamOwnerWelcomeEmail, + renderPwResetMail, + renderSecondFactorVerificationEmail, + renderTeamActivationMail, + renderVerificationMail, + ) +import Wire.EmailSubsystem.Template +import Wire.EmailSubsystem.Templates.Provider qualified as P +import Wire.EmailSubsystem.Templates.Team +import Wire.EmailSubsystem.Templates.User qualified as U + +-- | The full set of localised templates the composer needs, plus the branding +-- in both forms used by the render functions (user\/team renders take a map, +-- provider renders take a function). +data EmailTemplates = EmailTemplates + { userTemplates :: Localised U.UserTemplates, + teamTemplates :: Localised TeamTemplates, + providerTemplates :: Localised P.ProviderTemplates, + brandingFn :: TemplateBranding, + brandingMap :: Map Text Text + } + +-- | Load all templates from the bundled templates directory. Fails fast at +-- startup if files are missing (same behaviour brig used to have). +loadEmailTemplates :: EmailTemplatesOpts -> IO EmailTemplates +loadEmailTemplates opts = do + user <- loadUserTemplates opts.user dir locale sender + team <- loadTeamTemplates opts.team dir locale sender + provider <- P.loadProviderTemplates opts.provider dir locale sender + pure + EmailTemplates + { userTemplates = user, + teamTemplates = team, + providerTemplates = provider, + brandingFn = genTemplateBranding opts.templateBranding, + brandingMap = genTemplateBrandingMap opts.templateBranding + } + where + dir = opts.templateDir + locale = fromMaybe def opts.defaultLocale + sender = opts.emailSender + +-- | Compose the email for a queued composing payload. +composeEmail :: (Member (Output Text) r) => EmailTemplates -> SendEmailRequest -> Sem r Mail +composeEmail tpls = \case + VerificationEmail (MkVerificationEmail to key code locale) -> + renderVerificationMail to key code (U.verificationEmail . snd $ forLocale locale tpls.userTemplates) tpls.brandingMap + ActivationEmail (MkActivationEmail to name key code locale) -> + renderActivationMail to name key code (U.activationEmail . snd $ forLocale locale tpls.userTemplates) tpls.brandingMap + EmailAddressUpdateEmail (MkActivationEmail to name key code locale) -> + renderActivationMail to name key code (U.activationEmailUpdate . snd $ forLocale locale tpls.userTemplates) tpls.brandingMap + TeamActivationEmail (MkTeamActivationEmail to name key code teamName locale) -> + renderTeamActivationMail to name teamName key code (U.teamActivationEmail . snd $ forLocale locale tpls.userTemplates) tpls.brandingMap + PasswordResetEmail (MkPasswordResetEmail to key code locale) -> + renderPwResetMail to key code (U.passwordResetEmail . snd $ forLocale locale tpls.userTemplates) tpls.brandingMap + NewClientEmail (MkNewClientEmail to name client locale) -> + renderNewClientEmail to name locale client (U.newClientEmail . snd $ forLocale (Just locale) tpls.userTemplates) tpls.brandingMap + AccountDeletionEmail (MkAccountDeletionEmail to name key code locale) -> + renderDeletionEmail to name key code (U.deletionEmail . snd $ forLocale (Just locale) tpls.userTemplates) tpls.brandingMap + LoginVerificationEmail (MkSecondFactorVerificationEmail to code locale) -> + renderSecondFactorVerificationEmail to code (U.verificationLoginEmail . snd $ forLocale locale tpls.userTemplates) tpls.brandingMap + ScimTokenVerificationEmail (MkSecondFactorVerificationEmail to code locale) -> + renderSecondFactorVerificationEmail to code (U.verificationScimTokenEmail . snd $ forLocale locale tpls.userTemplates) tpls.brandingMap + TeamDeletionVerificationEmail (MkSecondFactorVerificationEmail to code locale) -> + renderSecondFactorVerificationEmail to code (U.verificationTeamDeletionEmail . snd $ forLocale locale tpls.userTemplates) tpls.brandingMap + TeamInvitationEmail (MkTeamInvitationEmail {to, teamId, inviter, code, locale}) -> do + (mail, _) <- + renderInvitationEmail + (InvitationEmail to teamId code inviter) + (invitationEmail . snd $ forLocale locale tpls.teamTemplates) + tpls.brandingMap + pure mail + TeamInvitationPersonalUserEmail (MkTeamInvitationEmail {to, teamId, inviter, code, locale}) -> do + (mail, _) <- + renderInvitationEmail + (InvitationEmail to teamId code inviter) + (existingUserInvitationEmail . snd $ forLocale locale tpls.teamTemplates) + tpls.brandingMap + pure mail + MemberWelcomeEmail (MkMemberWelcomeEmail to teamId teamName locale) -> + renderMemberWelcomeMail to teamId teamName (memberWelcomeEmail . snd $ forLocale locale tpls.teamTemplates) tpls.brandingMap + NewTeamOwnerWelcomeEmail (MkNewTeamOwnerWelcomeEmail to teamId teamName profileName locale) -> + renderNewTeamOwnerWelcomeEmail to teamId teamName profileName (newTeamOwnerWelcomeEmail . snd $ forLocale locale tpls.teamTemplates) tpls.brandingMap + IdpChangedEmail payload@MkIdpChangedEmail {userId = _userId, ..} -> + renderIdPConfigChangeEmail + (idpConfigChangeEmail . snd $ forLocale locale tpls.teamTemplates) + tpls.brandingMap + payload + -- Provider emails always used the default locale, so no locale selection here. + ProviderActivationEmail (MkProviderActivationEmail to name key code update) -> do + let P.ProviderTemplates {..} = snd $ forLocale Nothing tpls.providerTemplates + tpl = if update then activationEmailUpdate else activationEmail + pure $ renderProviderActivationMail to name key code tpl tpls.brandingFn + ProviderApprovalConfirmEmail (MkProviderApprovalConfirmEmail to name) -> + pure $ + renderProviderApprovalConfirmMail + to + name + (P.approvalConfirmEmail . snd $ forLocale Nothing tpls.providerTemplates) + tpls.brandingFn + ProviderPasswordResetEmail (MkProviderPasswordResetEmail to key code) -> + pure $ + renderProviderPwResetMail + to + key + code + (P.passwordResetEmail . snd $ forLocale Nothing tpls.providerTemplates) + tpls.brandingFn + EnterpriseAuditEmail (MkEnterpriseAuditEmail {..}) -> + pure $ mkAuditMail from to subject (mkAuditBody url before after) + +-------------------------------------------------------------------------------- +-- Provider renders +-------------------------------------------------------------------------------- + +renderProviderActivationMail :: EmailAddress -> Name -> Code.Key -> Code.Value -> P.ActivationEmailTemplate -> TemplateBranding -> Mail +renderProviderActivationMail acmTo acmName acmKey acmCode P.ActivationEmailTemplate {..} branding = + (emptyMail from) + { mailTo = [to], + mailHeaders = + [ ("Subject", Lazy.toStrict subj), + ("X-Zeta-Purpose", "ProviderActivation"), + ("X-Zeta-Key", Ascii.toText (fromRange key)), + ("X-Zeta-Code", Ascii.toText (fromRange code)) + ], + mailParts = [[plainPart txt, htmlPart html]] + } + where + (Code.Key key, Code.Value code) = (acmKey, acmCode) + from = Address (Just activationEmailSenderName) (fromEmail activationEmailSender) + to = mkMimeAddress acmName acmTo + txt = renderTextWithBranding activationEmailBodyText replace branding + html = renderHtmlWithBranding activationEmailBodyHtml replace branding + subj = renderTextWithBranding activationEmailSubject replace branding + replace "url" = renderProviderActivationUrl activationEmailUrl acmKey acmCode branding + replace "email" = fromEmail acmTo + replace "name" = fromName acmName + replace x = x + +renderProviderActivationUrl :: Template -> Code.Key -> Code.Value -> TemplateBranding -> Text +renderProviderActivationUrl t (Code.Key k) (Code.Value v) branding = + Lazy.toStrict $ renderTextWithBranding t replace branding + where + replace "key" = Ascii.toText (fromRange k) + replace "code" = Ascii.toText (fromRange v) + replace x = x + +renderProviderApprovalConfirmMail :: EmailAddress -> Name -> P.ApprovalConfirmEmailTemplate -> TemplateBranding -> Mail +renderProviderApprovalConfirmMail apcTo apcName P.ApprovalConfirmEmailTemplate {..} branding = + (emptyMail from) + { mailTo = [to], + mailHeaders = + [ ("Subject", Lazy.toStrict subj), + ("X-Zeta-Purpose", "ProviderApprovalConfirm") + ], + mailParts = [[plainPart txt, htmlPart html]] + } + where + from = Address (Just approvalConfirmEmailSenderName) (fromEmail approvalConfirmEmailSender) + to = mkMimeAddress apcName apcTo + txt = renderTextWithBranding approvalConfirmEmailBodyText replace branding + html = renderHtmlWithBranding approvalConfirmEmailBodyHtml replace branding + subj = renderTextWithBranding approvalConfirmEmailSubject replace branding + replace "homeUrl" = pack $ show approvalConfirmEmailHomeUrl + replace "email" = fromEmail apcTo + replace "name" = fromName apcName + replace x = x + +renderProviderPwResetMail :: EmailAddress -> Code.Key -> Code.Value -> P.PasswordResetEmailTemplate -> TemplateBranding -> Mail +renderProviderPwResetMail pwrTo pwrKey pwrCode P.PasswordResetEmailTemplate {..} branding = + (emptyMail from) + { mailTo = [to], + mailHeaders = + [ ("Subject", Lazy.toStrict subj), + ("X-Zeta-Purpose", "ProviderPasswordReset"), + ("X-Zeta-Key", Ascii.toText (fromRange key)), + ("X-Zeta-Code", Ascii.toText (fromRange code)) + ], + mailParts = [[plainPart txt, htmlPart html]] + } + where + (Code.Key key, Code.Value code) = (pwrKey, pwrCode) + from = Address (Just passwordResetEmailSenderName) (fromEmail passwordResetEmailSender) + to = Address Nothing (fromEmail pwrTo) + txt = renderTextWithBranding passwordResetEmailBodyText replace branding + html = renderHtmlWithBranding passwordResetEmailBodyHtml replace branding + subj = renderTextWithBranding passwordResetEmailSubject replace branding + replace "url" = renderProviderPwResetUrl passwordResetEmailUrl pwrKey pwrCode branding + replace x = x + +renderProviderPwResetUrl :: Template -> Code.Key -> Code.Value -> TemplateBranding -> Text +renderProviderPwResetUrl t (Code.Key k) (Code.Value v) branding = + Lazy.toStrict $ renderTextWithBranding t replace branding + where + replace "key" = Ascii.toText (fromRange k) + replace "code" = Ascii.toText (fromRange v) + replace x = x + +-------------------------------------------------------------------------------- +-- Enterprise audit email +-------------------------------------------------------------------------------- + +-- | Audit email body: the called URL plus pretty-printed old\/new values. +mkAuditBody :: + Text -> + Maybe (DomainRegistrationResponse V10) -> + Maybe (DomainRegistrationResponse V10) -> + Lazy.Text +mkAuditBody url before after = + Lazy.fromStrict url + <> " called;\nOld value:\n" + <> pretty before + <> "\nNew value:\n" + <> pretty after + where + pretty = maybe "null" (LT.decodeUtf8 . Aeson.encodePretty) + +mkAuditMail :: EmailAddress -> EmailAddress -> Text -> Lazy.Text -> Mail +mkAuditMail from to subject bdy = + (emptyMail (Address Nothing (fromEmail from))) + { mailTo = [Address Nothing (fromEmail to)], + mailHeaders = + [ ("Subject", subject), + ("X-Zeta-Purpose", "audit") + ], + mailParts = [[plainPart bdy]] + } diff --git a/libs/wire-subsystems/src/Wire/EmailSending/Queueing.hs b/libs/wire-subsystems/src/Wire/EmailSending/Queueing.hs index 15a7f2fb1fb..03309a42297 100644 --- a/libs/wire-subsystems/src/Wire/EmailSending/Queueing.hs +++ b/libs/wire-subsystems/src/Wire/EmailSending/Queueing.hs @@ -14,48 +14,41 @@ -- -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . +{-# LANGUAGE TemplateHaskell #-} --- | Queueing interpreter for the 'EmailSending' effect. +-- | Queueing effect for outbound email. -- --- Instead of sending mail directly (SMTP\/SES), this interpreter inserts a --- 'SendEmail' job into the Arbiter @emails@ queue (a PostgreSQL table managed --- by Arbiter). The actual send is performed by the background-worker's emails --- worker pool (see "Wire.EmailJobsWorker"). --- --- This is the single seam for *all* email sending in brig: every mail flows --- through 'EmailSending', so interpreting it to a queue covers verification, --- activation, password-reset, invitation, new-client, deletion, SAML IdP-change, --- provider and enterprise-audit emails with one constructor. +-- Producers (brig) enqueue the composing payload ('SendEmailRequest': email +-- type, locale and structured inputs) as a 'SendEmail' job into the Arbiter +-- @emails@ queue (a PostgreSQL table managed by Arbiter). The +-- background-worker composes the actual email (template selection, rendering, +-- MIME building) and performs the send; see "Wire.EmailSending.Composer" and +-- "Wire.EmailJobsWorker". module Wire.EmailSending.Queueing - ( emailViaQueueInterpreter, - toSerializableMail, - fromSerializableMail, + ( EmailQueueing (..), + queueEmail, + emailViaQueueInterpreter, ) where import Arbiter.Core qualified as ArbiterCore -import Data.ByteString.Base64.Lazy qualified as B64 -import Data.ByteString.Lazy qualified as BL import Data.Id (RequestId) -import Data.Text qualified as T -import Data.Text.Encoding qualified as Text import Hasql.Pool.Extended qualified as HasqlPoolExt import Imports -import Network.Mail.Mime - ( Address (..), - Disposition (..), - Encoding (..), - Mail (..), - Part (..), - PartContent (..), - ) -import Polysemy -import Wire.API.BackgroundJobs.Email +import Polysemy (Embed, InterpreterFor, Member, embed, interpret, makeSem) +import Wire.API.BackgroundJobs.Email (SendEmailRequest) import Wire.API.Jobs (EmailsJobPayload (SendEmail), JobRegistry, SendEmailJobPayload (..)) -import Wire.EmailSending (EmailSending (SendMail)) import Wire.JobSubsystem.ArbiterAdapter (WireArbiter, mkNewWireArbiterEnv, runWireArbiter) --- | Interpret 'EmailSending' by inserting a 'SendEmail' job into the Arbiter +-- | Effect for enqueueing outbound email as a composing payload. Producers use +-- this instead of 'Wire.EmailSending.SendMail': no rendered mail exists on the +-- producer side. +data EmailQueueing m a where + QueueEmail :: SendEmailRequest -> EmailQueueing m () + +makeSem ''EmailQueueing + +-- | Interpret 'EmailQueueing' by inserting a 'SendEmail' job into the Arbiter -- @emails@ queue. -- -- The interpreter is self-contained: it runs Arbiter against the producer's @@ -67,13 +60,13 @@ emailViaQueueInterpreter :: (Member (Embed IO) r) => RequestId -> HasqlPoolExt.Pool -> - InterpreterFor EmailSending r + InterpreterFor EmailQueueing r emailViaQueueInterpreter requestId pool = interpret \case - SendMail mail -> do + QueueEmail request -> do let payload = SendEmailJobPayload { sendEmailJobRequestId = requestId, - sendEmailJobMail = toSerializableMail mail + sendEmailJobRequest = request } -- Bounded attempts: the send is retried by Arbiter with exponential -- backoff, and after these attempts the job is moved to the queue's @@ -87,162 +80,3 @@ emailViaQueueInterpreter requestId pool = interpret \case ArbiterCore.insertJob @EmailsJobPayload @(WireArbiter JobRegistry) job where arbiterEnv = mkNewWireArbiterEnv ArbiterCore.defaultSchemaName pool - --------------------------------------------------------------------------------- --- Mail <-> record conversion --------------------------------------------------------------------------------- - -toSerializableMail :: Mail -> SerializableMail -toSerializableMail m = - SerializableMail - { smFrom = fromAddress m.mailFrom, - smTo = fromAddress <$> m.mailTo, - smCc = fromAddress <$> m.mailCc, - smBcc = fromAddress <$> m.mailBcc, - smHeaders = fromHeader <$> m.mailHeaders, - smParts = (fromPart <$>) <$> m.mailParts - } - --- | Reconstruct a 'Mail' from a deserialized job payload. --- --- The job comes off an internal queue, but this is defense in depth: rather --- than trusting it, the conversion rejects payloads whose part nesting exceeds --- 'maxPartNesting', whose flat content is not strictly valid base64, or whose --- header-rendered fields contain CR\/LF\/NUL (header injection). Anything --- produced by 'toSerializableMail' always decodes. -fromSerializableMail :: SerializableMail -> Either Text Mail -fromSerializableMail m = do - mailFrom <- toAddress m.smFrom - mailTo <- traverse toAddress m.smTo - mailCc <- traverse toAddress m.smCc - mailBcc <- traverse toAddress m.smBcc - mailHeaders <- traverse toHeader m.smHeaders - mailParts <- traverse (traverse (toPart 0)) m.smParts - pure - Mail - { mailFrom = mailFrom, - mailTo = mailTo, - mailCc = mailCc, - mailBcc = mailBcc, - mailHeaders = mailHeaders, - mailParts = mailParts - } - -fromAddress :: Address -> SerializableMailAddress -fromAddress a = - SerializableMailAddress {smaName = a.addressName, smaEmail = a.addressEmail} - -toAddress :: SerializableMailAddress -> Either Text Address -toAddress a = do - addressName <- traverse (validateHeaderField "address name") a.smaName - addressEmail <- validateHeaderField "address email" a.smaEmail - pure Address {addressName = addressName, addressEmail = addressEmail} - --- | mime-mail headers are @[(ByteString, Text)]@: the name is a (ASCII) --- ByteString, the value is already 'Text'. -fromHeader :: (ByteString, Text) -> SerializableMailHeader -fromHeader (name, value) = - SerializableMailHeader {smhName = Text.decodeUtf8 name, smhValue = value} - -toHeader :: SerializableMailHeader -> Either Text (ByteString, Text) -toHeader h = do - name <- validateHeaderField "header name" h.smhName - value <- validateHeaderField "header value" h.smhValue - pure (Text.encodeUtf8 name, value) - -fromPart :: Part -> SerializableMailPart -fromPart p = - SerializableMailPart - { smpType = p.partType, - smpEncoding = fromEncoding p.partEncoding, - smpDisposition = fromDisposition p.partDisposition, - smpHeaders = fromHeader <$> p.partHeaders, - smpContent = encodeContent p.partContent - } - -toPart :: Int -> SerializableMailPart -> Either Text Part -toPart depth p - | depth > maxPartNesting = Left "part nesting deeper than the maximum" - | otherwise = do - partType <- validateHeaderField "part type" p.smpType - partDisposition <- toDisposition p.smpDisposition - partHeaders <- traverse toHeader p.smpHeaders - partContent <- decodeContent depth p.smpContent - pure - Part - { partType = partType, - partEncoding = toEncoding p.smpEncoding, - partDisposition = partDisposition, - partHeaders = partHeaders, - partContent = partContent - } - -fromEncoding :: Encoding -> SerializableEncoding -fromEncoding = \case - None -> SerializableEncodingNone - Base64 -> SerializableEncodingBase64 - QuotedPrintableBinary -> SerializableEncodingQuotedPrintableBinary - QuotedPrintableText -> SerializableEncodingQuotedPrintableText - -toEncoding :: SerializableEncoding -> Encoding -toEncoding = \case - SerializableEncodingNone -> None - SerializableEncodingBase64 -> Base64 - SerializableEncodingQuotedPrintableBinary -> QuotedPrintableBinary - SerializableEncodingQuotedPrintableText -> QuotedPrintableText - -fromDisposition :: Disposition -> SerializableDisposition -fromDisposition = \case - DefaultDisposition -> - SerializableDisposition {smdType = SerializableDispositionDefault, smdFilename = ""} - InlineDisposition filename -> - SerializableDisposition {smdType = SerializableDispositionInline, smdFilename = filename} - AttachmentDisposition filename -> - SerializableDisposition {smdType = SerializableDispositionAttachment, smdFilename = filename} - -toDisposition :: SerializableDisposition -> Either Text Disposition -toDisposition d = case d.smdType of - -- The filename is dropped by DefaultDisposition (never rendered), but it is - -- validated anyway to keep every Text field on a SerializableMail* free of - -- CR/LF/NUL, uniformly. - SerializableDispositionDefault -> - DefaultDisposition <$ validateHeaderField "disposition filename" d.smdFilename - SerializableDispositionInline -> - InlineDisposition <$> validateHeaderField "disposition filename" d.smdFilename - SerializableDispositionAttachment -> - AttachmentDisposition <$> validateHeaderField "disposition filename" d.smdFilename - --- | Encode a part's content for serialization. Flat byte content becomes --- base64 'Text'; nested alternative groups recurse via 'fromPart'. The --- conversion is total, so any 'Mail' round-trips through the jobs queue. -encodeContent :: PartContent -> SerializablePartContent -encodeContent = \case - PartContent bs -> SerializablePartContentText (Text.decodeUtf8 . BL.toStrict $ B64.encode bs) - NestedParts ps -> SerializablePartContentNestedParts (fromPart <$> ps) - --- | Inverse of 'encodeContent'. Nested alternative groups recurse one level --- deeper (bounded by 'maxPartNesting' via 'toPart'); flat content must decode --- as strict base64, which anything produced by 'encodeContent' is. -decodeContent :: Int -> SerializablePartContent -> Either Text PartContent -decodeContent depth = \case - SerializablePartContentText t -> case B64.decode (BL.fromStrict (Text.encodeUtf8 t)) of - Left err -> Left ("invalid base64 in part content: " <> T.pack err) - Right bs -> Right (PartContent bs) - SerializablePartContentNestedParts ps -> NestedParts <$> traverse (toPart (depth + 1)) ps - --- | Maximum nesting depth of parts (0 = top-level) accepted by 'toPart'. --- Mails built with the mime-mail smart constructors nest at most two or three --- levels; anything deeper on the queue is malformed or adversarial. -maxPartNesting :: Int -maxPartNesting = 10 - --- | Validate a field that mime-mail renders into an RFC 5322 header position --- (address names\/emails, header names\/values, part type, disposition --- filename). CR, LF or NUL would allow a malformed job to inject additional --- headers or body parts. Producers never emit these; checking is defense in --- depth for jobs read off the queue. -validateHeaderField :: Text -> Text -> Either Text Text -validateHeaderField fieldName value - | T.any (\c -> c == '\r' || c == '\n' || c == '\0') value = - Left (fieldName <> " contains CR/LF/NUL") - | otherwise = Right value diff --git a/libs/wire-subsystems/src/Wire/EmailSubsystem.hs b/libs/wire-subsystems/src/Wire/EmailSubsystem.hs index 0ab910e724c..3eba7f4bc73 100644 --- a/libs/wire-subsystems/src/Wire/EmailSubsystem.hs +++ b/libs/wire-subsystems/src/Wire/EmailSubsystem.hs @@ -43,9 +43,9 @@ data EmailSubsystem m a where SendTeamActivationMail :: EmailAddress -> Name -> ActivationKey -> ActivationCode -> Maybe Locale -> Text -> EmailSubsystem m () SendTeamDeletionVerificationMail :: EmailAddress -> Code.Value -> Maybe Locale -> EmailSubsystem m () -- | send invitation to an unknown email address. - SendTeamInvitationMail :: EmailAddress -> TeamId -> EmailAddress -> InvitationCode -> Maybe Locale -> EmailSubsystem m Text + SendTeamInvitationMail :: EmailAddress -> TeamId -> EmailAddress -> InvitationCode -> Maybe Locale -> EmailSubsystem m () -- | send invitation to an email address associated with a personal user account. - SendTeamInvitationMailPersonalUser :: EmailAddress -> TeamId -> EmailAddress -> InvitationCode -> Maybe Locale -> EmailSubsystem m Text + SendTeamInvitationMailPersonalUser :: EmailAddress -> TeamId -> EmailAddress -> InvitationCode -> Maybe Locale -> EmailSubsystem m () SendMemberWelcomeEmail :: EmailAddress -> TeamId -> Text -> Maybe Locale -> EmailSubsystem m () SendNewTeamOwnerWelcomeEmail :: EmailAddress -> TeamId -> Text -> Maybe Locale -> Name -> EmailSubsystem m () SendSAMLIdPChanged :: diff --git a/libs/wire-subsystems/src/Wire/EmailSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/EmailSubsystem/Interpreter.hs index 5a9b54fa14d..617c97312fd 100644 --- a/libs/wire-subsystems/src/Wire/EmailSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/EmailSubsystem/Interpreter.hs @@ -31,51 +31,87 @@ import Data.Text.Encoding qualified as T import Data.Text.Lazy (toStrict) import Data.Text.Lazy qualified as TL import Data.Text.Template -import Data.UUID (toText) +import Data.UUID qualified as UUID import Data.X509.Extended import Imports import Network.Mail.Mime import Polysemy import Polysemy.Output (Output) -import Polysemy.TinyLog (TinyLog) import SAML2.WebSSO -import URI.ByteString (URI, serializeURIRef') +import URI.ByteString (serializeURIRef') +import Wire.API.BackgroundJobs.Email import Wire.API.Locale import Wire.API.User import Wire.API.User.Activation import Wire.API.User.Client (Client (..)) import Wire.API.User.Password -import Wire.EmailSending (EmailSending, sendMail) +import Wire.EmailSending.Queueing (EmailQueueing, queueEmail) import Wire.EmailSubsystem import Wire.EmailSubsystem.Template import Wire.EmailSubsystem.Templates.Team import Wire.EmailSubsystem.Templates.User -emailSubsystemInterpreter :: - (Member EmailSending r, Member TinyLog r) => - Localised UserTemplates -> - Localised TeamTemplates -> - Map Text Text -> - InterpreterFor EmailSubsystem r -emailSubsystemInterpreter userTpls teamTpls branding = interpret \case +-- | Interpret 'EmailSubsystem' by enqueueing the composing payload for each +-- email on the Arbiter @emails@ queue (via 'EmailQueueing'). No templates or +-- branding are touched here; the background-worker composes the actual email +-- right before sending (see "Wire.EmailSending.Composer"). +emailSubsystemInterpreter :: (Member EmailQueueing r) => InterpreterFor EmailSubsystem r +emailSubsystemInterpreter = interpret \case -- USER EMAILS - 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 - SendCreateScimTokenVerificationMail email code mLocale -> sendCreateScimTokenVerificationMailImpl userTpls branding email code mLocale - SendLoginVerificationMail email code mLocale -> sendLoginVerificationMailImpl userTpls branding email code mLocale - SendActivationMail email name key code mLocale -> sendActivationMailImpl userTpls branding email name key code mLocale - SendEmailAddressUpdateMail email name key code mLocale -> sendEmailAddressUpdateMailImpl userTpls branding email name key code mLocale - 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 + SendPasswordResetMail email (key, code) mLocale -> + queueEmail $ PasswordResetEmail (MkPasswordResetEmail email key code mLocale) + SendVerificationMail email key code mLocale -> + queueEmail $ VerificationEmail (MkVerificationEmail email key code mLocale) + SendTeamDeletionVerificationMail email code mLocale -> + queueEmail $ TeamDeletionVerificationEmail (MkSecondFactorVerificationEmail email code mLocale) + SendCreateScimTokenVerificationMail email code mLocale -> + queueEmail $ ScimTokenVerificationEmail (MkSecondFactorVerificationEmail email code mLocale) + SendLoginVerificationMail email code mLocale -> + queueEmail $ LoginVerificationEmail (MkSecondFactorVerificationEmail email code mLocale) + SendActivationMail email name key code mLocale -> + queueEmail $ ActivationEmail (MkActivationEmail email name key code mLocale) + SendEmailAddressUpdateMail email name key code mLocale -> + queueEmail $ EmailAddressUpdateEmail (MkActivationEmail email name key code mLocale) + SendTeamActivationMail email name key code mLocale teamName -> + queueEmail $ TeamActivationEmail (MkTeamActivationEmail email name key code teamName mLocale) + SendNewClientEmail email name client locale -> + queueEmail $ NewClientEmail (MkNewClientEmail email name client locale) + SendAccountDeletionEmail email name key code locale -> + queueEmail $ AccountDeletionEmail (MkAccountDeletionEmail email name key code locale) -- TEAM EMAILS - 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 - SendMemberWelcomeEmail email tid teamName loc -> sendMemberWelcomeEmailImpl teamTpls branding email tid teamName loc - SendNewTeamOwnerWelcomeEmail email tid teamName loc name -> sendNewTeamOwnerWelcomeEmailImpl teamTpls branding email tid teamName loc name + SendTeamInvitationMail email tid from code loc -> + queueEmail $ TeamInvitationEmail (MkTeamInvitationEmail {to = email, teamId = tid, inviter = from, code = code, locale = loc}) + SendTeamInvitationMailPersonalUser email tid from code loc -> + queueEmail $ TeamInvitationPersonalUserEmail (MkTeamInvitationEmail {to = email, teamId = tid, inviter = from, code = code, locale = loc}) + SendMemberWelcomeEmail email tid teamName loc -> + queueEmail $ MemberWelcomeEmail (MkMemberWelcomeEmail email tid teamName loc) + SendNewTeamOwnerWelcomeEmail email tid teamName loc name -> + queueEmail $ NewTeamOwnerWelcomeEmail (MkNewTeamOwnerWelcomeEmail email tid teamName name loc) SendSAMLIdPChanged email tid mbUid addedCerts removedCerts idPId oldIssuer oldEndpoint newIssuer newEndpoint mLocale -> - sendSAMLIdPChangedImpl teamTpls branding email tid mbUid addedCerts removedCerts idPId oldIssuer oldEndpoint newIssuer newEndpoint mLocale + queueEmail . IdpChangedEmail $ + MkIdpChangedEmail + { to = email, + teamId = tid, + userId = mbUid, + addedCerts = toCertSummary <$> addedCerts, + removedCerts = toCertSummary <$> removedCerts, + idpId = UUID.toText (fromIdPId idPId), + oldIssuer = renderIssuer <$> oldIssuer, + oldEndpoint = renderUri <$> oldEndpoint, + newIssuer = renderIssuer <$> newIssuer, + newEndpoint = renderUri <$> newEndpoint, + locale = mLocale + } + where + toCertSummary d = + CertSummary + { algorithm = T.pack d.fingerprintAlgorithm, + fingerprint = T.pack d.fingerprint, + subject = T.pack d.subject, + issuer = T.pack d.issuer + } + renderIssuer = T.decodeUtf8 . serializeURIRef' . _fromIssuer + renderUri = T.decodeUtf8 . serializeURIRef' ------------------------------------------------------------------------------- -- Verification Email for @@ -83,45 +119,6 @@ emailSubsystemInterpreter userTpls teamTpls branding = interpret \case -- - Creation of ScimToken -- - Team Deletion -sendTeamDeletionVerificationMailImpl :: - (Member EmailSending r, Member TinyLog r) => - Localised UserTemplates -> - Map Text Text -> - EmailAddress -> - Code.Value -> - Maybe Locale -> - Sem r () -sendTeamDeletionVerificationMailImpl userTemplates branding email code mLocale = do - let tpl = verificationTeamDeletionEmail . snd $ forLocale mLocale userTemplates - mail <- logEmailRenderErrors "team deletion verification email" $ renderSecondFactorVerificationEmail email code tpl branding - sendMail mail - -sendCreateScimTokenVerificationMailImpl :: - (Member EmailSending r, Member TinyLog r) => - Localised UserTemplates -> - Map Text Text -> - EmailAddress -> - Code.Value -> - Maybe Locale -> - Sem r () -sendCreateScimTokenVerificationMailImpl userTemplates branding email code mLocale = do - let tpl = verificationScimTokenEmail . snd $ forLocale mLocale userTemplates - mail <- logEmailRenderErrors "scim token verification email" $ renderSecondFactorVerificationEmail email code tpl branding - sendMail mail - -sendLoginVerificationMailImpl :: - (Member EmailSending r, Member TinyLog r) => - Localised UserTemplates -> - Map Text Text -> - EmailAddress -> - Code.Value -> - Maybe Locale -> - Sem r () -sendLoginVerificationMailImpl userTemplates branding email code mLocale = do - let tpl = verificationLoginEmail . snd $ forLocale mLocale userTemplates - mail <- logEmailRenderErrors "login verification email" $ renderSecondFactorVerificationEmail email code tpl branding - sendMail mail - renderSecondFactorVerificationEmail :: (Member (Output Text) r) => EmailAddress -> @@ -155,36 +152,6 @@ renderSecondFactorVerificationEmail email codeValue SecondFactorVerificationEmai ------------------------------------------------------------------------------- -- Activation Email -sendActivationMailImpl :: - (Member EmailSending r, Member TinyLog r) => - Localised UserTemplates -> - Map Text Text -> - EmailAddress -> - Name -> - ActivationKey -> - ActivationCode -> - Maybe Locale -> - Sem r () -sendActivationMailImpl userTemplates branding email name akey acode mLocale = do - let tpl = activationEmail . snd $ forLocale mLocale userTemplates - mail <- logEmailRenderErrors "activation email" $ renderActivationMail email name akey acode tpl branding - sendMail mail - -sendEmailAddressUpdateMailImpl :: - (Member EmailSending r, Member TinyLog r) => - Localised UserTemplates -> - Map Text Text -> - EmailAddress -> - Name -> - ActivationKey -> - ActivationCode -> - Maybe Locale -> - Sem r () -sendEmailAddressUpdateMailImpl userTemplates branding email name akey acode mLocale = do - let tpl = activationEmailUpdate . snd $ forLocale mLocale userTemplates - mail <- logEmailRenderErrors "email address update email" $ renderActivationMail email name akey acode tpl branding - sendMail mail - renderActivationMail :: (Member (Output Text) r) => EmailAddress -> Name -> ActivationKey -> ActivationCode -> ActivationEmailTemplate -> Map Text Text -> Sem r Mail renderActivationMail email name akey@(ActivationKey key) acode@(ActivationCode code) ActivationEmailTemplate {..} branding = do url <- renderActivationUrl activationEmailUrl akey acode branding @@ -224,22 +191,6 @@ renderActivationUrl t (ActivationKey k) (ActivationCode c) branding = do ------------------------------------------------------------------------------- -- Team Activation Email -sendTeamActivationMailImpl :: - (Member EmailSending r, Member TinyLog r) => - Localised UserTemplates -> - Map Text Text -> - EmailAddress -> - Name -> - ActivationKey -> - ActivationCode -> - Maybe Locale -> - Text -> - Sem r () -sendTeamActivationMailImpl userTemplates branding email name akey acode mLocale teamName = do - let tpl = teamActivationEmail . snd $ forLocale mLocale userTemplates - mail <- logEmailRenderErrors "team activation email" $ renderTeamActivationMail email name teamName akey acode tpl branding - sendMail mail - renderTeamActivationMail :: (Member (Output Text) r) => EmailAddress -> Name -> Text -> ActivationKey -> ActivationCode -> TeamActivationEmailTemplate -> Map Text Text -> Sem r Mail renderTeamActivationMail email name teamName akey@(ActivationKey key) acode@(ActivationCode code) TeamActivationEmailTemplate {..} branding = do url <- renderActivationUrl teamActivationEmailUrl akey acode branding @@ -270,20 +221,6 @@ renderTeamActivationMail email name teamName akey@(ActivationKey key) acode@(Act ------------------------------------------------------------------------------- -- Verification Email -sendVerificationMailImpl :: - (Member EmailSending r, Member TinyLog r) => - Localised UserTemplates -> - Map Text Text -> - EmailAddress -> - ActivationKey -> - ActivationCode -> - Maybe Locale -> - Sem r () -sendVerificationMailImpl userTemplates branding email akey acode mLocale = do - let tpl = verificationEmail . snd $ forLocale mLocale userTemplates - mail <- logEmailRenderErrors "verification email" $ renderVerificationMail email akey acode tpl branding - sendMail mail - renderVerificationMail :: (Member (Output Text) r) => EmailAddress -> ActivationKey -> ActivationCode -> VerificationEmailTemplate -> Map Text Text -> Sem r Mail renderVerificationMail email akey acode VerificationEmailTemplate {..} branding = do let replace = @@ -313,20 +250,6 @@ renderVerificationMail email akey acode VerificationEmailTemplate {..} branding ------------------------------------------------------------------------------- -- Password Reset Email -sendPasswordResetMailImpl :: - (Member EmailSending r, Member TinyLog r) => - Localised UserTemplates -> - Map Text Text -> - EmailAddress -> - PasswordResetKey -> - PasswordResetCode -> - Maybe Locale -> - Sem r () -sendPasswordResetMailImpl userTemplates branding email pkey pcode mLocale = do - let tpl = passwordResetEmail . snd $ forLocale mLocale userTemplates - mail <- logEmailRenderErrors "password reset email" $ renderPwResetMail email pkey pcode tpl branding - sendMail mail - renderPwResetMail :: (Member (Output Text) r) => EmailAddress -> PasswordResetKey -> PasswordResetCode -> PasswordResetEmailTemplate -> Map Text Text -> Sem r Mail renderPwResetMail email pkey pcode PasswordResetEmailTemplate {..} branding = do url <- renderPwResetUrl passwordResetEmailUrl pkey pcode @@ -360,20 +283,6 @@ renderPwResetMail email pkey pcode PasswordResetEmailTemplate {..} branding = do ------------------------------------------------------------------------------- -- New Client Email -sendNewClientEmailImpl :: - (Member EmailSending r, Member TinyLog r) => - Localised UserTemplates -> - Map Text Text -> - EmailAddress -> - Name -> - Client -> - Locale -> - Sem r () -sendNewClientEmailImpl userTemplates branding email name client locale = do - let tpl = newClientEmail . snd $ forLocale (Just locale) userTemplates - mail <- logEmailRenderErrors "new client email" $ renderNewClientEmail email name locale client tpl branding - sendMail mail - renderNewClientEmail :: (Member (Output Text) r) => EmailAddress -> Name -> Locale -> Client -> NewClientEmailTemplate -> Map Text Text -> Sem r Mail renderNewClientEmail email name locale Client {..} NewClientEmailTemplate {..} branding = do let replace = @@ -406,21 +315,6 @@ renderNewClientEmail email name locale Client {..} NewClientEmailTemplate {..} b ------------------------------------------------------------------------------- -- Deletion Email -sendAccountDeletionEmailImpl :: - (Member EmailSending r, Member TinyLog r) => - Localised UserTemplates -> - Map Text Text -> - EmailAddress -> - Name -> - Code.Key -> - Code.Value -> - Locale -> - Sem r () -sendAccountDeletionEmailImpl userTemplates branding email name key code locale = do - let tpl = deletionEmail . snd $ forLocale (Just locale) userTemplates - mail <- logEmailRenderErrors "account deletion email" $ renderDeletionEmail email name key code tpl branding - sendMail mail - renderDeletionEmail :: (Member (Output Text) r) => EmailAddress -> Name -> Code.Key -> Code.Value -> DeletionEmailTemplate -> Map Text Text -> Sem r Mail renderDeletionEmail email name cKey cValue DeletionEmailTemplate {..} branding = do url <- renderDeletionUrl deletionEmailUrl cKey cValue branding @@ -460,40 +354,6 @@ renderDeletionUrl t cKey cValue branding = do ------------------------------------------------------------------------------- -- Invitation Email -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, renderedInvitationUrl) <- logEmailRenderErrors "invitation" $ renderInvitationEmail mail tpl branding - sendMail renderedMail - pure renderedInvitationUrl - -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, renderedInvitationUrl) <- logEmailRenderErrors "personal user invitation" $ renderInvitationEmail mail tpl branding - sendMail renderedMail - pure renderedInvitationUrl - data InvitationEmail = InvitationEmail { invTo :: !EmailAddress, invTeamId :: !TeamId, @@ -532,12 +392,6 @@ renderInvitationUrl t tid (InvitationCode c) = ------------------------------------------------------------------------------- -- Member Welcome Email -sendMemberWelcomeEmailImpl :: (Member EmailSending r, Member TinyLog r) => Localised TeamTemplates -> Map Text Text -> EmailAddress -> TeamId -> Text -> Maybe Locale -> Sem r () -sendMemberWelcomeEmailImpl teamTemplates branding to tid teamName loc = do - let tpl = memberWelcomeEmail . snd $ forLocale loc teamTemplates - mail <- logEmailRenderErrors "member welcome email" $ renderMemberWelcomeMail to tid teamName tpl branding - sendMail mail - renderMemberWelcomeMail :: (Member (Output Text) r) => EmailAddress -> TeamId -> Text -> MemberWelcomeEmailTemplate -> Map Text Text -> Sem r Mail renderMemberWelcomeMail emailTo tid teamName MemberWelcomeEmailTemplate {..} branding = do let replace = @@ -565,12 +419,6 @@ renderMemberWelcomeMail emailTo tid teamName MemberWelcomeEmailTemplate {..} bra ------------------------------------------------------------------------------- -- New Team Owner Welcome Email -sendNewTeamOwnerWelcomeEmailImpl :: (Member EmailSending r, Member TinyLog r) => Localised TeamTemplates -> Map Text Text -> EmailAddress -> TeamId -> Text -> Maybe Locale -> Name -> Sem r () -sendNewTeamOwnerWelcomeEmailImpl teamTemplates branding to tid teamName loc profileName = do - let tpl = newTeamOwnerWelcomeEmail . snd $ forLocale loc teamTemplates - mail <- logEmailRenderErrors "new team owner welcome email" $ renderNewTeamOwnerWelcomeEmail to tid teamName profileName tpl branding - sendMail mail - renderNewTeamOwnerWelcomeEmail :: (Member (Output Text) r) => EmailAddress -> TeamId -> Text -> Name -> NewTeamOwnerWelcomeEmailTemplate -> Map Text Text -> Sem r Mail renderNewTeamOwnerWelcomeEmail emailTo tid teamName profileName NewTeamOwnerWelcomeEmailTemplate {..} branding = do let replace = @@ -599,45 +447,13 @@ renderNewTeamOwnerWelcomeEmail emailTo tid teamName profileName NewTeamOwnerWelc ------------------------------------------------------------------------------- -- IdP change email for team admins and owners -sendSAMLIdPChangedImpl :: - (Member EmailSending r, Member TinyLog r) => - Localised TeamTemplates -> - Map Text Text -> - EmailAddress -> - TeamId -> - Maybe UserId -> - [CertDescription] -> - [CertDescription] -> - IdPId -> - Maybe Issuer -> - Maybe URI -> - Maybe Issuer -> - Maybe URI -> - Maybe Locale -> - Sem r () -sendSAMLIdPChangedImpl teamTemplates branding to tid mbUid addedCerts removedCerts idPId oldIssuer oldEndpoint newIssuer newEndpoint mLocale = do - let tpl = idpConfigChangeEmail . snd $ forLocale mLocale teamTemplates - mail <- - logEmailRenderErrors "idp config change email" $ - renderIdPConfigChangeEmail to tpl branding addedCerts removedCerts tid mbUid idPId oldIssuer oldEndpoint newIssuer newEndpoint - sendMail mail - renderIdPConfigChangeEmail :: (Member (Output Text) r) => - EmailAddress -> IdPConfigChangeEmailTemplate -> Map Text Text -> - [CertDescription] -> - [CertDescription] -> - TeamId -> - Maybe UserId -> - IdPId -> - Maybe Issuer -> - Maybe URI -> - Maybe Issuer -> - Maybe URI -> + IdpChangedEmail -> Sem r Mail -renderIdPConfigChangeEmail email IdPConfigChangeEmailTemplate {..} branding addedCerts removedCerts tid uid idPId oldIssuer oldEndpoint newIssuer newEndpoint = do +renderIdPConfigChangeEmail IdPConfigChangeEmailTemplate {..} branding MkIdpChangedEmail {to = email, teamId = tid, userId = uid, idpId = idpIdText, oldIssuer, oldEndpoint, newIssuer, newEndpoint, ..} = do idpDetailsAddedTextRendered :: Text <- (TL.toStrict . TL.unlines) <$> mapM (renderTextWithBrandingSem idpDetailsAddedText . idpDetailsToMap) addedCerts @@ -653,13 +469,13 @@ renderIdPConfigChangeEmail email IdPConfigChangeEmailTemplate {..} branding adde let replace = branding - & Map.insert "team_id" ((toText . toUUID) tid) - & Map.insert "user_id" (maybe "None" (toText . toUUID) uid) - & Map.insert "old_idp_issuer" (maybe "None" (T.decodeUtf8 . serializeURIRef' . _fromIssuer) oldIssuer) - & Map.insert "old_idp_endpoint" (maybe "None" (T.decodeUtf8 . serializeURIRef') oldEndpoint) - & Map.insert "new_idp_issuer" (maybe "None" (T.decodeUtf8 . serializeURIRef' . _fromIssuer) newIssuer) - & Map.insert "new_idp_endpoint" (maybe "None" (T.decodeUtf8 . serializeURIRef') newEndpoint) - & Map.insert "idp_id" ((toText . fromIdPId) idPId) + & Map.insert "team_id" (UUID.toText (toUUID tid)) + & Map.insert "user_id" (maybe "None" (UUID.toText . toUUID) uid) + & Map.insert "old_idp_issuer" (fromMaybe "None" oldIssuer) + & Map.insert "old_idp_endpoint" (fromMaybe "None" oldEndpoint) + & Map.insert "new_idp_issuer" (fromMaybe "None" newIssuer) + & Map.insert "new_idp_endpoint" (fromMaybe "None" newEndpoint) + & Map.insert "idp_id" idpIdText certificateDetailsHtml = (T.unlines . Imports.filter (not . T.null)) [idpDetailsAddedHtmlRendered, idpDetailsRemovedHtmlRendered] replaceHtml = @@ -690,13 +506,13 @@ renderIdPConfigChangeEmail email IdPConfigChangeEmailTemplate {..} branding adde from = Address (Just senderName) (fromEmail sender) to = Address Nothing (fromEmail email) - idpDetailsToMap :: CertDescription -> Map Text Text + idpDetailsToMap :: CertSummary -> Map Text Text idpDetailsToMap d = empty @Text @Text - & Map.insert "algorithm" (T.pack d.fingerprintAlgorithm) - & Map.insert "fingerprint" (T.pack d.fingerprint) - & Map.insert "subject" (T.pack d.subject) - & Map.insert "issuer" (T.pack d.issuer) + & Map.insert "algorithm" d.algorithm + & Map.insert "fingerprint" d.fingerprint + & Map.insert "subject" d.subject + & Map.insert "issuer" d.issuer ------------------------------------------------------------------------------- -- MIME Conversions diff --git a/libs/wire-subsystems/src/Wire/EmailSubsystem/Template.hs b/libs/wire-subsystems/src/Wire/EmailSubsystem/Template.hs index 11d36455eb2..b9fbed68e1d 100644 --- a/libs/wire-subsystems/src/Wire/EmailSubsystem/Template.hs +++ b/libs/wire-subsystems/src/Wire/EmailSubsystem/Template.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE StrictData #-} -- This file is part of the Wire Server implementation. @@ -41,6 +42,80 @@ import Wire.API.User.EmailAddress (EmailAddress) import Wire.EmailSubsystem.Templates.Team import Wire.EmailSubsystem.Templates.User +-- | Invitation URL templates (config-derived, locale-independent). Used by +-- brig to render invitation URLs for API responses, and by the composer for +-- invitation emails. +data InvitationUrlTemplates = InvitationUrlTemplates + { personalUser :: Template, + newUser :: Template + } + +-- | Customizable branding text for emails/sms/calls, mirroring the former +-- Brig configuration. +data BrandingOpts = BrandingOpts + { brand :: !Text, + brandUrl :: !Text, + brandLabelUrl :: !Text, + brandLogoUrl :: !Text, + brandService :: !Text, + copyright :: !Text, + misuse :: !Text, + legal :: !Text, + forgot :: !Text, + support :: !Text + } + deriving stock (Show, Generic) + deriving anyclass (FromJSON) + +-- | Function to be applied everywhere where email/sms/call +-- templating is used (ensures that placeholders are replaced +-- by the appropriate branding, typically Wire) +genTemplateBranding :: BrandingOpts -> TemplateBranding +genTemplateBranding BrandingOpts {..} = fn + where + fn "brand" = brand + fn "brand_url" = brandUrl + fn "brand_label_url" = brandLabelUrl + fn "brand_logo" = brandLogoUrl + fn "brand_service" = brandService + fn "copyright" = copyright + fn "misuse" = misuse + fn "legal" = legal + fn "forgot" = forgot + fn "support" = support + fn other = other + +genTemplateBrandingMap :: BrandingOpts -> Map Text Text +genTemplateBrandingMap opts = + Map.fromList + [ ("brand", opts.brand), + ("brand_url", opts.brandUrl), + ("brand_label_url", opts.brandLabelUrl), + ("brand_logo", opts.brandLogoUrl), + ("brand_service", opts.brandService), + ("copyright", opts.copyright), + ("misuse", opts.misuse), + ("legal", opts.legal), + ("forgot", opts.forgot), + ("support", opts.support) + ] + +-- | Provider settings, mirroring the former Brig configuration. +data ProviderOpts = ProviderOpts + { -- | Homepage URL + homeUrl :: !Text, + -- | Activation URL template + providerActivationUrl :: !Text, + -- | Approval URL template + approvalUrl :: !Text, + -- | Approval email recipient + approvalTo :: !EmailAddress, + -- | Password reset URL template + providerPwResetUrl :: !Text + } + deriving stock (Show, Generic) + deriving anyclass (FromJSON) + -- | Lookup a localised item from a 'Localised' structure. forLocale :: -- | 'Just' the preferred locale or 'Nothing' for @@ -268,6 +343,7 @@ data UserTemplateOpts = UserTemplateOpts deletionUrl :: !Text } deriving stock (Show, Generic) + deriving anyclass (FromJSON) loadUserTemplates :: UserTemplateOpts -> FilePath -> Locale -> EmailAddress -> IO (Localised UserTemplates) loadUserTemplates opts templatesDir defLocale sender = readLocalesDir defLocale templatesDir "user" $ \fp -> @@ -349,3 +425,18 @@ loadUserTemplates opts templatesDir defLocale sender = readLocalesDir defLocale deletionUrl = template opts.deletionUrl readTemplate' = readTemplateWithDefault templatesDir defLocale "user" readText' = readTextWithDefault templatesDir defLocale "user" + +-- | All options needed to load the full set of email templates (worker-side +-- email composition). Mirrors the email-template settings brig used to +-- configure. +data EmailTemplatesOpts = EmailTemplatesOpts + { templateDir :: !FilePath, + defaultLocale :: !(Maybe Locale), + emailSender :: !EmailAddress, + templateBranding :: !BrandingOpts, + user :: !UserTemplateOpts, + team :: !TeamOpts, + provider :: !ProviderOpts + } + deriving stock (Show, Generic) + deriving anyclass (FromJSON) diff --git a/services/brig/src/Brig/Provider/Template.hs b/libs/wire-subsystems/src/Wire/EmailSubsystem/Templates/Provider.hs similarity index 73% rename from services/brig/src/Brig/Provider/Template.hs rename to libs/wire-subsystems/src/Wire/EmailSubsystem/Templates/Provider.hs index 7de713abb89..d74947dc00d 100644 --- a/services/brig/src/Brig/Provider/Template.hs +++ b/libs/wire-subsystems/src/Wire/EmailSubsystem/Templates/Provider.hs @@ -15,7 +15,10 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Brig.Provider.Template +-- | Provider email templates, loaded from the @provider@ subtree of the +-- bundled templates directory. Moved from brig: the +-- background-worker composes provider emails, so it needs the loaders. +module Wire.EmailSubsystem.Templates.Provider ( ProviderTemplates (..), ActivationEmailTemplate (..), ApprovalRequestEmailTemplate (..), @@ -25,15 +28,14 @@ module Brig.Provider.Template ) where -import Brig.Options import Data.ByteString.Conversion (fromByteString) import Data.Misc (HttpsUrl) import Data.Text.Encoding (encodeUtf8) import Data.Text.Template import Imports -import Wire.API.User.Identity +import Wire.API.Locale (Locale) +import Wire.API.User.EmailAddress (EmailAddress) import Wire.EmailSubsystem.Template hiding (readTemplate, readText) -import Wire.EmailSubsystem.Templates.User data ProviderTemplates = ProviderTemplates { activationEmail :: !ActivationEmailTemplate, @@ -43,6 +45,15 @@ data ProviderTemplates = ProviderTemplates passwordResetEmail :: !PasswordResetEmailTemplate } +data ActivationEmailTemplate = ActivationEmailTemplate + { activationEmailUrl :: !Template, + activationEmailSubject :: !Template, + activationEmailBodyText :: !Template, + activationEmailBodyHtml :: !Template, + activationEmailSender :: !EmailAddress, + activationEmailSenderName :: !Text + } + data ApprovalRequestEmailTemplate = ApprovalRequestEmailTemplate { approvalRequestEmailUrl :: !Template, approvalRequestEmailSubject :: !Template, @@ -62,28 +73,37 @@ data ApprovalConfirmEmailTemplate = ApprovalConfirmEmailTemplate approvalConfirmEmailHomeUrl :: !HttpsUrl } -loadProviderTemplates :: Opts -> IO (Localised ProviderTemplates) -loadProviderTemplates o = readLocalesDir defLocale (templateDir gOptions) "provider" $ \fp -> +data PasswordResetEmailTemplate = PasswordResetEmailTemplate + { passwordResetEmailUrl :: !Template, + passwordResetEmailSubject :: !Template, + passwordResetEmailBodyText :: !Template, + passwordResetEmailBodyHtml :: !Template, + passwordResetEmailSender :: !EmailAddress, + passwordResetEmailSenderName :: !Text + } + +loadProviderTemplates :: ProviderOpts -> FilePath -> Locale -> EmailAddress -> IO (Localised ProviderTemplates) +loadProviderTemplates pOptions templatesDir defLocale sender = readLocalesDir defLocale templatesDir "provider" $ \fp -> ProviderTemplates <$> ( ActivationEmailTemplate activationUrl' <$> readTemplate fp "email/activation-subject.txt" <*> readTemplate fp "email/activation.txt" <*> readTemplate fp "email/activation.html" - <*> pure (emailSender gOptions) + <*> pure sender <*> readText fp "email/sender.txt" ) <*> ( ActivationEmailTemplate activationUrl' <$> readTemplate fp "email/update-subject.txt" <*> readTemplate fp "email/update.txt" <*> readTemplate fp "email/update.html" - <*> pure (emailSender gOptions) + <*> pure sender <*> readText fp "email/sender.txt" ) <*> ( ApprovalRequestEmailTemplate approvalUrl' <$> readTemplate fp "email/approval-request-subject.txt" <*> readTemplate fp "email/approval-request.txt" <*> readTemplate fp "email/approval-request.html" - <*> pure (emailSender gOptions) + <*> pure sender <*> readText fp "email/sender.txt" <*> pure (approvalTo pOptions) ) @@ -91,7 +111,7 @@ loadProviderTemplates o = readLocalesDir defLocale (templateDir gOptions) "provi <$> readTemplate fp "email/approval-confirm-subject.txt" <*> readTemplate fp "email/approval-confirm.txt" <*> readTemplate fp "email/approval-confirm.html" - <*> pure (emailSender gOptions) + <*> pure sender <*> readText fp "email/sender.txt" <*> pure (fromMaybe (error "Invalid HTTPS URL") maybeUrl) ) @@ -99,16 +119,13 @@ loadProviderTemplates o = readLocalesDir defLocale (templateDir gOptions) "provi <$> readTemplate fp "email/password-reset-subject.txt" <*> readTemplate fp "email/password-reset.txt" <*> readTemplate fp "email/password-reset.html" - <*> pure (emailSender gOptions) + <*> pure sender <*> readText fp "email/sender.txt" ) where maybeUrl = fromByteString . encodeUtf8 $ pOptions.homeUrl - gOptions = o.emailSMS.general - pOptions = o.emailSMS.provider - defLocale = defaultTemplateLocale o.settings - readTemplate = readTemplateWithDefault gOptions.templateDir defLocale "provider" - readText = readTextWithDefault gOptions.templateDir defLocale "provider" + readTemplate = readTemplateWithDefault templatesDir defLocale "provider" + readText = readTextWithDefault templatesDir defLocale "provider" -- URL templates activationUrl' = template pOptions.providerActivationUrl approvalUrl' = template pOptions.approvalUrl diff --git a/libs/wire-subsystems/src/Wire/EnterpriseLoginSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/EnterpriseLoginSubsystem/Interpreter.hs index 54539dcd495..39798b669c1 100644 --- a/libs/wire-subsystems/src/Wire/EnterpriseLoginSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/EnterpriseLoginSubsystem/Interpreter.hs @@ -30,19 +30,18 @@ where import Bilge hiding (delete) import Control.Lens ((^.), (^..), (^?)) import Data.Aeson qualified as Aeson -import Data.Aeson.Encode.Pretty qualified as Aeson import Data.ByteString.Conversion (toByteString') import Data.ByteString.Lazy qualified as BL import Data.Domain import Data.Id import Data.Qualified import Data.Text.Encoding qualified as Text -import Data.Text.Internal.Builder (fromLazyText, fromText, toLazyText) +import Data.Text.Internal.Builder (fromText, toLazyText) +import Data.Text.Lazy (toStrict) import Data.Text.Lazy.Builder (Builder) import Data.Text.Lazy.Encoding as LT import Imports hiding (lookup) import Network.HTTP.Types.Method -import Network.Mail.Mime (Address (Address), Mail (mailHeaders, mailParts, mailTo), emptyMail, plainPart) import Polysemy import Polysemy.Error (Error, note, throw) import Polysemy.Error qualified as Error @@ -52,6 +51,7 @@ import Polysemy.TinyLog qualified as Log import SAML2.WebSSO qualified as SAML import System.Logger.Message qualified as Log import Util.Options +import Wire.API.BackgroundJobs.Email import Wire.API.EnterpriseLogin import Wire.API.Routes.Public.Brig.DomainVerification import Wire.API.Routes.Version @@ -65,7 +65,7 @@ import Wire.DomainVerificationChallengeStore mkStoredDomainVerificationChallenge, ) import Wire.DomainVerificationChallengeStore qualified as Challenge -import Wire.EmailSending (EmailSending, sendMail) +import Wire.EmailSending.Queueing (EmailQueueing, queueEmail) import Wire.EnterpriseLoginSubsystem import Wire.EnterpriseLoginSubsystem.Error import Wire.GalleyAPIAccess @@ -95,7 +95,7 @@ runEnterpriseLoginSubsystemWithConfig :: Member GalleyAPIAccess r, Member SparAPIAccess r, Member TinyLog r, - Member EmailSending r, + Member EmailQueueing r, Member Random r, Member Rpc r, Member UserKeyStore r, @@ -120,7 +120,7 @@ runEnterpriseLoginSubsystem :: Member SparAPIAccess r, Member TinyLog r, Member (Input EnterpriseLoginSubsystemConfig) r, - Member EmailSending r, + Member EmailQueueing r, Member Random r, Member Rpc r, Member UserKeyStore r, @@ -308,7 +308,7 @@ deleteDomainImpl :: ( Member DomainRegistrationStore r, Member TinyLog r, Member (Input EnterpriseLoginSubsystemConfig) r, - Member EmailSending r + Member EmailQueueing r ) => Domain -> Sem r () @@ -328,7 +328,7 @@ unauthorizeImpl :: Member (Error EnterpriseLoginSubsystemError) r, Member TinyLog r, Member (Input EnterpriseLoginSubsystemConfig) r, - Member EmailSending r + Member EmailQueueing r ) => Domain -> Sem r () @@ -358,7 +358,7 @@ updateDomainRegistrationImpl :: Member (Error EnterpriseLoginSubsystemError) r, Member TinyLog r, Member (Input EnterpriseLoginSubsystemConfig) r, - Member EmailSending r + Member EmailQueueing r ) => Domain -> DomainRegistrationUpdate -> @@ -384,7 +384,7 @@ lockDomainImpl :: ( Member DomainRegistrationStore r, Member TinyLog r, Member (Input EnterpriseLoginSubsystemConfig) r, - Member EmailSending r + Member EmailQueueing r ) => Domain -> Sem r () @@ -408,7 +408,7 @@ unlockDomainImpl :: Member (Error EnterpriseLoginSubsystemError) r, Member TinyLog r, Member (Input EnterpriseLoginSubsystemConfig) r, - Member EmailSending r + Member EmailQueueing r ) => Domain -> Sem r () @@ -434,7 +434,7 @@ preAuthorizeImpl :: Member (Error EnterpriseLoginSubsystemError) r, Member TinyLog r, Member (Input EnterpriseLoginSubsystemConfig) r, - Member EmailSending r + Member EmailQueueing r ) => Domain -> Sem r () @@ -524,21 +524,10 @@ validate dr = do Backend _ _ -> when (dr.teamInvite /= NotAllowed) $ throw EnterpriseLoginSubsystemOperationForbidden _ -> pure () -mkAuditMail :: EmailAddress -> EmailAddress -> Text -> LText -> Mail -mkAuditMail from to subject bdy = - (emptyMail (Address Nothing (fromEmail from))) - { mailTo = [Address Nothing (fromEmail to)], - mailHeaders = - [ ("Subject", subject), - ("X-Zeta-Purpose", "audit") - ], - mailParts = [[plainPart bdy]] - } - sendAuditMail :: ( Member (Input EnterpriseLoginSubsystemConfig) r, Member TinyLog r, - Member EmailSending r + Member EmailQueueing r ) => Builder -> Text -> @@ -546,43 +535,33 @@ sendAuditMail :: Maybe DomainRegistration -> Sem r () sendAuditMail url subject mBefore mAfter = do - let encodeDomainRegistrationPretty = - maybe - "null" - (Aeson.encodePretty . mkDomainRegistrationResponse @V10) let encodeDomainRegistration = maybe "null" (Aeson.encode . mkDomainRegistrationResponse @V10) - let auditLog :: LText = - toLazyText $ - url - <> " called;\nOld value:\n" - <> fromLazyText - (LT.decodeUtf8 (encodeDomainRegistrationPretty mBefore)) - <> "\nNew value:\n" - <> fromLazyText - ( LT.decodeUtf8 - ( encodeDomainRegistrationPretty - mAfter - ) - ) Log.info $ Log.msg (Log.val "Domain registration audit log") . Log.field "url" (LT.encodeUtf8 $ toLazyText url) . Log.field "old_value" (encodeDomainRegistration mBefore) . Log.field "new_value" (encodeDomainRegistration mAfter) mConfig <- inputs emailConfig - for_ mConfig $ \config -> do - let mail = mkAuditMail (config.auditEmailSender) (config.auditEmailRecipient) subject auditLog - sendMail mail + for_ mConfig $ \config -> + queueEmail . EnterpriseAuditEmail $ + MkEnterpriseAuditEmail + { from = config.auditEmailSender, + to = config.auditEmailRecipient, + subject = subject, + url = toStrict (toLazyText url), + before = mkDomainRegistrationResponse @V10 <$> mBefore, + after = mkDomainRegistrationResponse @V10 <$> mAfter + } updateDomainRedirectImpl :: ( Member (Error EnterpriseLoginSubsystemError) r, Member TinyLog r, Member DomainRegistrationStore r, Member (Input EnterpriseLoginSubsystemConfig) r, - Member EmailSending r + Member EmailQueueing r ) => Token -> Domain -> @@ -614,7 +593,7 @@ updateTeamInviteImpl :: ( Member (Error EnterpriseLoginSubsystemError) r, Member (Input EnterpriseLoginSubsystemConfig) r, Member DomainRegistrationStore r, - Member EmailSending r, + Member EmailQueueing r, Member GalleyAPIAccess r, Member SparAPIAccess r, Member TinyLog r, diff --git a/libs/wire-subsystems/src/Wire/TeamInvitationSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/TeamInvitationSubsystem/Interpreter.hs index 82002248f68..6f5a004274d 100644 --- a/libs/wire-subsystems/src/Wire/TeamInvitationSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/TeamInvitationSubsystem/Interpreter.hs @@ -31,6 +31,7 @@ import Network.Wai.Utilities.Exception (displayExceptionNoBacktrace) import Polysemy import Polysemy.Error import Polysemy.Input (Input, input, runInputConst) +import Polysemy.Output (ignoreOutput) import Polysemy.TinyLog import System.Logger.Message as Log import URI.ByteString @@ -44,6 +45,8 @@ import Wire.API.Team.Role import Wire.API.User import Wire.Arbitrary import Wire.EmailSubsystem +import Wire.EmailSubsystem.Interpreter (renderInvitationUrl) +import Wire.EmailSubsystem.Template (InvitationUrlTemplates (..)) import Wire.EnterpriseLoginSubsystem import Wire.GalleyAPIAccess hiding (AddTeamMember) import Wire.GalleyAPIAccess qualified as GalleyAPIAccess @@ -83,7 +86,8 @@ runTeamInvitationSubsystem :: Member EmailSubsystem r, Member EnterpriseLoginSubsystem r, Member TeamSubsystem r, - Member UserKeyStore r + Member UserKeyStore r, + Member (Input InvitationUrlTemplates) r ) => TeamInvitationSubsystemConfig -> InterpreterFor TeamInvitationSubsystem r @@ -111,7 +115,8 @@ inviteUserImpl :: Member EnterpriseLoginSubsystem r, Member TeamSubsystem r, Member UserKeyStore r, - Member UserStore r + Member UserStore r, + Member (Input InvitationUrlTemplates) r ) => Local UserId -> TeamId -> @@ -209,6 +214,7 @@ createInvitation' :: Member Random r, Member (Input TeamInvitationSubsystemConfig) r, Member Now r, + Member (Input InvitationUrlTemplates) r, Member EmailSubsystem r, Member EnterpriseLoginSubsystem r, Member UserKeyStore r @@ -271,14 +277,20 @@ createInvitation' tid mExpectedInvId inviteeRole mbInviterUid inviterEmail invRe } in Store.insertInvitation insertInv timeout - let sendOp = case invitationFlow of - InviteExistingUser -> sendTeamInvitationMailPersonalUser - InviteNewUser -> - -- NB: this is not guarded by the `validateSAMLEmails` feature, so auto-activation - -- is not supported here. - sendTeamInvitationMail - - invitationUrl <- sendOp email tid inviterEmail code invRequest.locale + case invitationFlow of + InviteExistingUser -> sendTeamInvitationMailPersonalUser email tid inviterEmail code invRequest.locale + InviteNewUser -> + -- NB: this is not guarded by the `validateSAMLEmails` feature, so auto-activation + -- is not supported here. + sendTeamInvitationMail email tid inviterEmail code invRequest.locale + -- The invitation URL in API responses is rendered here (config-derived, + -- locale-independent); the email itself is composed by the worker. + urlTemplate <- + input @InvitationUrlTemplates + <&> case invitationFlow of + InviteExistingUser -> (.personalUser) + InviteNewUser -> (.newUser) + invitationUrl <- ignoreOutput $ renderInvitationUrl urlTemplate tid code inv <- toInvitation invitationUrl showInvitationUrl newInv pure (inv, code) where diff --git a/libs/wire-subsystems/test/unit/Wire/EmailSending/ComposerSpec.hs b/libs/wire-subsystems/test/unit/Wire/EmailSending/ComposerSpec.hs new file mode 100644 index 00000000000..ab68c361106 --- /dev/null +++ b/libs/wire-subsystems/test/unit/Wire/EmailSending/ComposerSpec.hs @@ -0,0 +1,136 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2026 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Wire.EmailSending.ComposerSpec (spec) where + +import Data.Aeson qualified as Aeson +import Data.Code qualified as Code +import Data.Id +import Data.Range (unsafeRange) +import Data.Text.Encoding (decodeUtf8) +import Data.UUID qualified as UUID +import Imports +import Network.Mail.Mime +import Polysemy +import Polysemy.Output +import Test.Hspec +import Test.QuickCheck (property, (===)) +import Wire.API.BackgroundJobs.Email +import Wire.API.Jobs (EmailsJobPayload (SendEmail), SendEmailJobPayload (..)) +import Wire.API.User +import Wire.API.User.Activation +import Wire.EmailSending.Composer +import Wire.EmailSubsystem.Interpreter (InvitationEmail (..), renderActivationMail, renderInvitationEmail, renderSecondFactorVerificationEmail) +import Wire.EmailSubsystem.Template (forLocale) +import Wire.EmailSubsystem.TemplateFixtures +import Wire.EmailSubsystem.Templates.Team (invitationEmail) +import Wire.EmailSubsystem.Templates.User qualified as U + +spec :: Spec +spec = do + templates <- runIO loadTestEmailTemplates + describe "Wire.EmailSending.Composer" $ do + describe "JSON roundtrip" $ + it "all variants roundtrip" $ + property $ \reqId req -> + let job = SendEmail (SendEmailJobPayload reqId req) + in Aeson.decode (Aeson.encode job) === Just job + describe "composition" $ do + it "activation request composes to the direct render" $ do + let (errs, composed) = + run . runOutputList @Text $ + composeEmail templates (ActivationEmail (MkActivationEmail testTo testName testKey testCode (Just defLocale))) + tpl = activationEmailTpls templates + (errs', direct) = run . runOutputList @Text $ renderActivationMail testTo testName testKey testCode tpl branding + lookupHeader "Subject" composed `shouldBe` lookupHeader "Subject" direct + composed.mailTo `shouldBe` direct.mailTo + composed.mailFrom `shouldBe` direct.mailFrom + length composed.mailParts `shouldBe` length direct.mailParts + errs `shouldBe` errs' + errs `shouldBe` [] + it "login verification composes to the direct render" $ do + let req = LoginVerificationEmail (MkSecondFactorVerificationEmail testTo testCodeValue (Just defLocale)) + (errs, composed) = run . runOutputList @Text $ composeEmail templates req + tpl = U.verificationLoginEmail . snd $ forLocale Nothing templates.userTemplates + (errs', direct) = run . runOutputList @Text $ renderSecondFactorVerificationEmail testTo testCodeValue tpl branding + composed.mailTo `shouldBe` direct.mailTo + lookupHeader "Subject" composed `shouldBe` lookupHeader "Subject" direct + errs `shouldBe` errs' + it "scim token verification composes to the direct render" $ do + let req = ScimTokenVerificationEmail (MkSecondFactorVerificationEmail testTo testCodeValue (Just defLocale)) + (errs, composed) = run . runOutputList @Text $ composeEmail templates req + tpl = U.verificationScimTokenEmail . snd $ forLocale Nothing templates.userTemplates + (errs', direct) = run . runOutputList @Text $ renderSecondFactorVerificationEmail testTo testCodeValue tpl branding + composed.mailTo `shouldBe` direct.mailTo + lookupHeader "Subject" composed `shouldBe` lookupHeader "Subject" direct + errs `shouldBe` errs' + it "team invitation composes to the direct render" $ do + let req = TeamInvitationEmail (MkTeamInvitationEmail {to = testTo, teamId = testTeamId, inviter = testInviter, code = testCode2, locale = Nothing}) + (errs, composed) = run . runOutputList @Text $ composeEmail templates req + tpl = invitationEmail . snd $ forLocale Nothing templates.teamTemplates + (errs', direct) = run . runOutputList @Text $ renderInvitationEmail (InvitationEmail testTo testTeamId testCode2 testInviter) tpl branding + composed.mailTo `shouldBe` (fst direct).mailTo + lookupHeader "Subject" composed `shouldBe` lookupHeader "Subject" (fst direct) + errs `shouldBe` errs' + it "provider password reset composes with provider sender and purpose" $ do + let (_, mail) = + run . runOutputList @Text $ + composeEmail templates (ProviderPasswordResetEmail (MkProviderPasswordResetEmail testTo testCodeKey testCodeValue)) + mail.mailFrom.addressEmail `shouldBe` fromEmail emailSender + lookupHeader "X-Zeta-Purpose" mail `shouldBe` Just "ProviderPasswordReset" + it "enterprise audit composes with recipient, subject and purpose" $ do + let (_, mail) = + run . runOutputList @Text $ + composeEmail templates (EnterpriseAuditEmail (MkEnterpriseAuditEmail emailSender testTo "audit subject" "https://example.com/url" Nothing Nothing)) + mail.mailTo `shouldBe` [Address Nothing (fromEmail testTo)] + lookupHeader "Subject" mail `shouldBe` Just "audit subject" + lookupHeader "X-Zeta-Purpose" mail `shouldBe` Just "audit" + +activationEmailTpls :: EmailTemplates -> U.ActivationEmailTemplate +activationEmailTpls templates = + (.activationEmail) . snd $ forLocale Nothing templates.userTemplates + +lookupHeader :: Text -> Mail -> Maybe Text +lookupHeader name mail = + listToMaybe [v | (k, v) <- mail.mailHeaders, decodeUtf8 k == name] + +testTo :: EmailAddress +testTo = fromJust $ emailAddressText "test@example.com" + +testName :: Name +testName = Name "Test" + +testKey :: ActivationKey +testKey = ActivationKey "testkey" + +testCode :: ActivationCode +testCode = ActivationCode "testcode" + +testTeamId :: TeamId +testTeamId = Id (fromJust (UUID.fromString "123e4567-e89b-12d3-a456-426614174000")) + +testInviter :: EmailAddress +testInviter = fromJust $ emailAddressText "inviter@example.com" + +testCode2 :: InvitationCode +testCode2 = InvitationCode "ZoMX0xs=" + +testCodeKey :: Code.Key +testCodeKey = Code.Key (unsafeRange "01234567890123456789") + +testCodeValue :: Code.Value +testCodeValue = Code.Value (unsafeRange "testcode1") diff --git a/libs/wire-subsystems/test/unit/Wire/EmailSendingQueueingSpec.hs b/libs/wire-subsystems/test/unit/Wire/EmailSendingQueueingSpec.hs deleted file mode 100644 index c02e0f24e34..00000000000 --- a/libs/wire-subsystems/test/unit/Wire/EmailSendingQueueingSpec.hs +++ /dev/null @@ -1,246 +0,0 @@ --- This file is part of the Wire Server implementation. --- --- Copyright (C) 2026 Wire Swiss GmbH --- --- This program is free software: you can redistribute it and/or modify it under --- the terms of the GNU Affero General Public License as published by the Free --- Software Foundation, either version 3 of the License, or (at your option) any --- later version. --- --- This program is distributed in the hope that it will be useful, but WITHOUT --- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS --- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more --- details. --- --- You should have received a copy of the GNU Affero General Public License along --- with this program. If not, see . - --- | Unit tests for the email queueing conversion ('Wire.EmailSending.Queueing') --- and the 'SendEmailJobPayload' serialization. --- --- These cover the data path shared by the producer (brig inserts a --- 'SendEmail' job into the Arbiter @emails@ queue) and the consumer (the --- background-worker reconstructs the 'Mail' and sends it): the --- @Mail@ <-> 'SerializableMail' conversion must be a round-trip, and the job --- payload must survive JSON encoding/decoding through the queue's JSONB --- column. -module Wire.EmailSendingQueueingSpec (spec) where - -import Data.Aeson qualified as Aeson -import Data.Text.Lazy qualified as LT -import Imports -import Network.Mail.Mime - ( Address (..), - Mail (..), - Part (..), - PartContent (..), - emptyMail, - htmlPart, - plainPart, - ) -import Test.Hspec -import Test.QuickCheck -import Wire.API.BackgroundJobs.Email -import Wire.API.Jobs (EmailsJobPayload (..)) -import Wire.EmailSending.Queueing - -spec :: Spec -spec = do - describe "toSerializableMail / fromSerializableMail" $ do - it "round-trips Mail -> SerializableMail -> Mail -> SerializableMail" $ do - let sm = toSerializableMail sampleMail - toSerializableMail <$> fromSerializableMail sm `shouldBe` Right sm - - it "preserves all address lists, headers and parts" $ do - let sm = toSerializableMail sampleMail - sm.smFrom `shouldBe` smaFrom - sm.smTo `shouldBe` [smaTo] - sm.smCc `shouldBe` [SerializableMailAddress Nothing "cc@example.com"] - sm.smBcc `shouldBe` [] - sm.smHeaders - `shouldBe` [ SerializableMailHeader "Subject" "Verify your email", - SerializableMailHeader "X-Foo" "bar" - ] - length sm.smParts `shouldBe` 1 - length (concat sm.smParts) `shouldBe` 2 - - -- Exercises the non-default disposition branches (Inline/Attachment carry a - -- filename) via the public conversion API, since brig's render path only - -- produces DefaultDisposition. - it "round-trips Inline/Attachment dispositions and all encodings" $ do - toSerializableMail <$> fromSerializableMail variantJob `shouldBe` Right variantJob - - it "round-trips nested parts (NestedParts) through Mail and JSON" $ do - let job = toSerializableMail nestedMail - toSerializableMail <$> fromSerializableMail job `shouldBe` Right job - Aeson.decode (Aeson.encode job) `shouldBe` Just job - - it "decodes a job nested to the maximum allowed depth" $ do - fromSerializableMail (nestedJobAtDepth 10) `shouldSatisfy` isRight - - -- Defense in depth at the worker boundary: anything malformed read off - -- the queue is rejected instead of rendered and sent. - it "rejects a job nested deeper than the maximum" $ do - fromSerializableMail (nestedJobAtDepth 11) `shouldSatisfy` isLeft - - it "rejects flat content that is not valid base64" $ do - let job = sampleJob {smParts = [[partWithContent (SerializablePartContentText "not base64!!!")]]} - fromSerializableMail job `shouldSatisfy` isLeft - - -- One case per call site of 'validateHeaderField', so a future refactor - -- that drops one (e.g. a missing 'traverse' over 'smaName') fails here. - it "rejects NUL in every header-rendered field" $ do - let base = sampleJob - okPart = partWithContent (SerializablePartContentText "aGk=") - jobs :: [SerializableMail] - jobs = - [ base {smFrom = base.smFrom {smaName = Just "Wire\0"}}, - base {smTo = [base.smFrom {smaEmail = "evil\0@example.com"}]}, - base {smParts = [[okPart {smpType = "text/plain\0"}]]}, - base - { smParts = - [ [ okPart - { smpDisposition = - SerializableDisposition {smdType = SerializableDispositionInline, smdFilename = "evil\0.txt"} - } - ] - ] - }, - base - { smParts = - [ [ okPart - { smpDisposition = - SerializableDisposition {smdType = SerializableDispositionDefault, smdFilename = "evil\0.txt"} - } - ] - ] - } - ] - mapM_ (\job -> fromSerializableMail job `shouldSatisfy` isLeft) jobs - - it "rejects CR/LF in header-rendered fields" $ do - let job = - sampleJob - { smHeaders = [SerializableMailHeader "Subject" "hi\r\nBcc: evil@example.com"] - } - fromSerializableMail job `shouldSatisfy` isLeft - describe "SerializableMail / EmailsJobPayload JSON serialization" $ do - it "round-trips the sample mail through Aeson" $ do - let job = toSerializableMail sampleMail - Aeson.decode (Aeson.encode job) `shouldBe` Just job - - it "decoding a serialized mail yields a mail that round-trips back to itself" $ do - let job = toSerializableMail sampleMail - decoded = Aeson.decode (Aeson.encode job) :: Maybe SerializableMail - (fmap toSerializableMail . fromSerializableMail <$> decoded) `shouldBe` Just (Right job) - - -- Exercises the wire-api schema machinery (record fields, nested lists, - -- and the encoding/disposition enums) for arbitrary payloads. - it "encode . decode = id for arbitrary SerializableMail" $ - property $ \(job :: SerializableMail) -> - Aeson.decode @SerializableMail (Aeson.encode job) === Just job - - -- The Arbiter @emails@ queue envelope: the tagged payload sum and the - -- payload record (request id + mail) must round-trip through the queue's - -- JSONB column. - it "encode . decode = id for arbitrary EmailsJobPayload" $ - property $ \(job :: EmailsJobPayload) -> - Aeson.decode @EmailsJobPayload (Aeson.encode job) === Just job - --- | A mail shaped exactly like the ones brig builds (see --- 'Wire.EmailSubsystem.Interpreter'): one alternative with a plain and an html --- part, @to@/@cc@ addresses, and a couple of headers. -sampleMail :: Mail -sampleMail = - (emptyMail smaFromMail) - { mailTo = [smaToMail], - mailCc = [Address Nothing "cc@example.com"], - mailBcc = [], - mailHeaders = - [ ("Subject", "Verify your email"), - ("X-Foo", "bar") - ], - mailParts = - [ [ plainPart (LT.pack "Please verify your email."), - htmlPart (LT.fromStrict "

Please verify your email.

") - ] - ] - } - where - smaFromMail = Address (Just "Wire") "noreply@example.com" - smaToMail = Address (Just "Alice") "alice@example.com" - --- | A mail whose single part carries nested sub-parts — the structure --- 'encodeContent' must now handle instead of erroring. -nestedMail :: Mail -nestedMail = sampleMail {mailParts = [[nestedPart]]} - where - nestedPart = - (plainPart (LT.pack "outer")) - { partContent = NestedParts [plainPart (LT.pack "inner plain"), htmlPart (LT.pack "

inner html

")] - } - -sampleJob :: SerializableMail -sampleJob = toSerializableMail sampleMail - --- | A job whose single part's content is nested @n@ levels deep (n --- 'SerializablePartContentNestedParts' wrappers around base64 text). -nestedJobAtDepth :: Int -> SerializableMail -nestedJobAtDepth n = sampleJob {smParts = [[partAtDepth n]]} - where - partAtDepth :: Int -> SerializableMailPart - partAtDepth 0 = partWithContent (SerializablePartContentText "aGk=") - partAtDepth k = partWithContent (SerializablePartContentNestedParts [partAtDepth (k - 1)]) - -partWithContent :: SerializablePartContent -> SerializableMailPart -partWithContent content = - SerializableMailPart - { smpType = "text/plain", - smpEncoding = SerializableEncodingNone, - smpDisposition = SerializableDisposition {smdType = SerializableDispositionDefault, smdFilename = ""}, - smpHeaders = [], - smpContent = content - } - --- | A job with non-default dispositions (Inline/Attachment, which carry a --- filename) and encodings other than the default, to exercise those branches. -variantJob :: SerializableMail -variantJob = - SerializableMail - { smFrom = smaFrom, - smTo = [smaTo], - smCc = [], - smBcc = [], - smHeaders = [SerializableMailHeader "Subject" "Attachments"], - smParts = - [ [ SerializableMailPart - { smpType = "image/png", - smpEncoding = SerializableEncodingBase64, - smpDisposition = - SerializableDisposition - { smdType = SerializableDispositionInline, - smdFilename = "logo.png" - }, - smpHeaders = [], - smpContent = SerializablePartContentText "iVBORw0KGgo=" - }, - SerializableMailPart - { smpType = "application/pdf", - smpEncoding = SerializableEncodingQuotedPrintableText, - smpDisposition = - SerializableDisposition - { smdType = SerializableDispositionAttachment, - smdFilename = "doc.pdf" - }, - smpHeaders = [SerializableMailHeader "Content-ID" ""], - smpContent = SerializablePartContentText "JVBERi0=" - } - ] - ] - } - -smaFrom :: SerializableMailAddress -smaFrom = SerializableMailAddress {smaName = Just "Wire", smaEmail = "noreply@example.com"} - -smaTo :: SerializableMailAddress -smaTo = SerializableMailAddress {smaName = Just "Alice", smaEmail = "alice@example.com"} diff --git a/libs/wire-subsystems/test/unit/Wire/EmailSubsystem/TemplateFixtures.hs b/libs/wire-subsystems/test/unit/Wire/EmailSubsystem/TemplateFixtures.hs index b6d744ef82c..de5a4422c3f 100644 --- a/libs/wire-subsystems/test/unit/Wire/EmailSubsystem/TemplateFixtures.hs +++ b/libs/wire-subsystems/test/unit/Wire/EmailSubsystem/TemplateFixtures.hs @@ -25,7 +25,9 @@ import Imports import Text.Email.Parser (unsafeEmailAddress) import Wire.API.Locale import Wire.API.User.EmailAddress (EmailAddress) -import Wire.EmailSubsystem.Template +import Wire.EmailSending.Composer (EmailTemplates (..)) +import Wire.EmailSubsystem.Template hiding (emailSender) +import Wire.EmailSubsystem.Templates.Provider import Wire.EmailSubsystem.Templates.Team import Wire.EmailSubsystem.Templates.User @@ -77,3 +79,32 @@ loadTestTeamTemplates = loadTeamTemplates teamOpts "templates" defLocale emailSe -- | Load the on-disk user templates. See 'loadTestTeamTemplates'. loadTestUserTemplates :: IO (Localised UserTemplates) loadTestUserTemplates = loadUserTemplates userTemplateOpts "templates" defLocale emailSender + +providerOpts :: ProviderOpts +providerOpts = + ProviderOpts + { homeUrl = "https://example.com/", + providerActivationUrl = "https://example.com/provider-activate/?key=${key}&code=${code}", + approvalUrl = "https://example.com/provider-approve/?key=${key}&code=${code}", + approvalTo = emailSender, + providerPwResetUrl = "https://example.com/provider-reset/?key=${key}&code=${code}" + } + +-- | Load the on-disk provider templates. See 'loadTestTeamTemplates'. +loadTestProviderTemplates :: IO (Localised ProviderTemplates) +loadTestProviderTemplates = loadProviderTemplates providerOpts "templates" defLocale emailSender + +-- | Load the full composer fixture set (all template bundles plus branding). +loadTestEmailTemplates :: IO EmailTemplates +loadTestEmailTemplates = do + user <- loadTestUserTemplates + team <- loadTestTeamTemplates + provider <- loadTestProviderTemplates + pure + EmailTemplates + { userTemplates = user, + teamTemplates = team, + providerTemplates = provider, + brandingFn = id, + brandingMap = branding + } diff --git a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/EmailSubsystem.hs b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/EmailSubsystem.hs index 305bebed550..3f51a0176ea 100644 --- a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/EmailSubsystem.hs +++ b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/EmailSubsystem.hs @@ -53,8 +53,8 @@ noopEmailSubsystemInterpreter = interpret \case SendAccountDeletionEmail {} -> pure () SendTeamActivationMail {} -> pure () SendTeamDeletionVerificationMail {} -> pure () - SendTeamInvitationMail {} -> pure "" - SendTeamInvitationMailPersonalUser {} -> pure "" + SendTeamInvitationMail {} -> pure () + SendTeamInvitationMailPersonalUser {} -> pure () SendMemberWelcomeEmail {} -> pure () SendNewTeamOwnerWelcomeEmail {} -> pure () SendSAMLIdPChanged {} -> pure () diff --git a/libs/wire-subsystems/test/unit/Wire/SAMLEmailSubsystem/InterpreterSpec.hs b/libs/wire-subsystems/test/unit/Wire/SAMLEmailSubsystem/InterpreterSpec.hs index 5d8363dad4f..440ee2bf6a4 100644 --- a/libs/wire-subsystems/test/unit/Wire/SAMLEmailSubsystem/InterpreterSpec.hs +++ b/libs/wire-subsystems/test/unit/Wire/SAMLEmailSubsystem/InterpreterSpec.hs @@ -33,15 +33,18 @@ import Imports import Network.Mail.Mime (Address (..), Mail (..), Part (..), PartContent (..)) import Polysemy import Polysemy.Error (runError) +import Polysemy.Output import Polysemy.State import SAML2.WebSSO import System.FilePath +import System.IO.Unsafe (unsafePerformIO) import System.Logger qualified as Logger import Test.Hspec import Test.Hspec.QuickCheck import Test.QuickCheck import Text.Email.Parser (unsafeEmailAddress) import URI.ByteString +import Wire.API.BackgroundJobs.Email (SendEmailRequest) import Wire.API.Error (ErrorS) import Wire.API.Error.Galley (GalleyError (TeamMemberNotFound, TeamNotFound)) import Wire.API.Locale @@ -52,12 +55,11 @@ import Wire.API.Team.Permission (fullPermissions) import Wire.API.Team.Role (Role (..)) import Wire.API.User.EmailAddress (fromEmail) import Wire.API.User.IdentityProvider -import Wire.EmailSending +import Wire.EmailSending.Composer (EmailTemplates (..), composeEmail) +import Wire.EmailSending.Queueing (EmailQueueing (QueueEmail)) import Wire.EmailSubsystem qualified as Email import Wire.EmailSubsystem.Interpreter -import Wire.EmailSubsystem.Template import Wire.EmailSubsystem.TemplateFixtures -import Wire.EmailSubsystem.Templates.Team import Wire.GalleyAPIAccess import Wire.MockInterpreters import Wire.SAMLEmailSubsystem @@ -68,6 +70,7 @@ import Wire.StoredUser (StoredUser (..)) import Wire.TeamSubsystem import Wire.TeamSubsystem.GalleyAPI (interpretTeamSubsystemToGalleyAPI) import Wire.UserStore +import Prelude qualified data RenderedTextParts = RenderedTextParts { created :: LText, @@ -96,7 +99,6 @@ spec = do parseLocalUnsafe = fromMaybe (error "Unknown locale") . parseLocale -- Run duplicated IO tasks here to save some time - teamTemplates :: Localised TeamTemplates <- runIO loadTestTeamTemplates newCerts <- runIO $ X509.readCertificates "test/resources/saml/certs.store" describe "SendSAMLIdPChanged" $ do @@ -113,7 +115,7 @@ spec = do storedUser' = patchStoredUser storedUser teamId userLocale uid notif = IdPCreated (Just uid) idp' - (mails, logs, _res) <- runInterpreters [storedUser'] teamMap teamTemplates $ do + (mails, logs, _res) <- runInterpreters [storedUser'] teamMap $ do sendSAMLIdPChanged notif assertNoWarnLogs logs @@ -129,7 +131,7 @@ spec = do let idp' = patchIdP idp teamId storedUser' = patchStoredUser storedUser teamId userLocale uid notif = IdPDeleted uid idp' - (mails, logs, _res) <- runInterpreters [storedUser'] teamMap teamTemplates $ do + (mails, logs, _res) <- runInterpreters [storedUser'] teamMap $ do sendSAMLIdPChanged notif assertNoWarnLogs logs @@ -162,7 +164,7 @@ spec = do ) storedUser' = patchStoredUser storedUser teamId userLocale uid notif = IdPUpdated uid idpOld' idpNew' - (mails, logs, _res) <- runInterpreters [storedUser'] teamMap teamTemplates $ do + (mails, logs, _res) <- runInterpreters [storedUser'] teamMap $ do sendSAMLIdPChanged notif assertNoWarnLogs logs @@ -181,7 +183,7 @@ spec = do teamMember :: TeamMember = mkTeamMember uid (rolePermissions role) Nothing UserLegalHoldDisabled teamMap :: Map TeamId [TeamMember] = Map.singleton teamId [teamMember] - (mails, logs, _res) <- runInterpreters [storedUser'] teamMap teamTemplates $ do + (mails, logs, _res) <- runInterpreters [storedUser'] teamMap $ do sendSAMLIdPChanged notif assertNoWarnLogs logs @@ -196,7 +198,7 @@ spec = do teamMember :: TeamMember = mkTeamMember uid (rolePermissions role) Nothing UserLegalHoldDisabled teamMap :: Map TeamId [TeamMember] = Map.singleton teamId [teamMember] - (mails, logs, _res) <- runInterpreters [storedUser'] teamMap teamTemplates $ do + (mails, logs, _res) <- runInterpreters [storedUser'] teamMap $ do sendSAMLIdPChanged notif assertNoWarnLogs logs @@ -215,7 +217,7 @@ spec = do ) users - (mails, logs, _res) <- runInterpreters (fst <$> users) teamMap teamTemplates $ do + (mails, logs, _res) <- runInterpreters (fst <$> users) teamMap $ do sendSAMLIdPChanged notif assertNoWarnLogs logs @@ -333,7 +335,6 @@ assertMailTextPartWithFile mail expectedTextPart = do runInterpreters :: [StoredUser] -> Map TeamId [TeamMember] -> - Localised TeamTemplates -> Sem '[ SAMLEmailSubsystem, TeamSubsystem, @@ -343,31 +344,59 @@ runInterpreters :: State (Map UserId Password), GalleyAPIAccess, Logger (Logger.Msg -> Logger.Msg), - EmailSending, - State [Mail], + Output SendEmailRequest, ErrorS 'TeamMemberNotFound, ErrorS 'TeamNotFound, Embed IO ] a -> IO ([Mail], [(Level, LByteString)], a) -runInterpreters users teamMap teamTemplates action = do +runInterpreters users teamMap action = do lr <- newLogRecorder - (mails, res) <- + (reqs, res) <- runM . fmap (either (error . show) (either (error . show) Imports.id)) . runError @(Tagged 'TeamNotFound ()) . runError @(Tagged 'TeamMemberNotFound ()) - . runState @[Mail] [] -- Use runState to capture and return the Mail state - . recordingEmailSendingInterpreter + . runOutputList @SendEmailRequest . recordLogs lr . miniGalleyAPIAccess teamMap def . evalState @(Map UserId Password) mempty . evalState @[StoredUser] users . inMemoryUserStoreInterpreter - . emailSubsystemInterpreter undefined teamTemplates branding + . emailSubsystemToOutput . interpretTeamSubsystemToGalleyAPI . samlEmailSubsystemInterpreter $ action logs <- readIORef lr.recordedLogs + let (errs, mails) = run . runOutputList @Text $ traverse (composeEmail emailTemplatesFixture) reqs + errs `shouldBe` [] pure (mails, logs, res) + +-- | Templates used to compose the recorded requests into mails. Loaded once +-- (the test suite runs with the package directory as working directory). +emailTemplatesFixture :: EmailTemplates +emailTemplatesFixture = unsafePerformIO $ do + user <- loadTestUserTemplates + teamTpls <- loadTestTeamTemplates + provider <- loadTestProviderTemplates + pure + EmailTemplates + { userTemplates = user, + teamTemplates = teamTpls, + providerTemplates = provider, + brandingFn = Prelude.id, + brandingMap = branding + } +{-# NOINLINE emailTemplatesFixture #-} + +-- | Interpret 'EmailSubsystem' by enqueueing into the 'Output' effect, so the +-- recorded requests can be composed to mails afterwards. +emailSubsystemToOutput :: + (Member (Output SendEmailRequest) r) => + Sem (Email.EmailSubsystem : r) a -> + Sem r a +emailSubsystemToOutput = + interpret @EmailQueueing (\case QueueEmail req -> Polysemy.Output.output req) + . emailSubsystemInterpreter + . raiseUnder @EmailQueueing diff --git a/libs/wire-subsystems/test/unit/Wire/TeamInvitationSubsystem/InterpreterSpec.hs b/libs/wire-subsystems/test/unit/Wire/TeamInvitationSubsystem/InterpreterSpec.hs index ef2f85d7657..9f60d196193 100644 --- a/libs/wire-subsystems/test/unit/Wire/TeamInvitationSubsystem/InterpreterSpec.hs +++ b/libs/wire-subsystems/test/unit/Wire/TeamInvitationSubsystem/InterpreterSpec.hs @@ -28,10 +28,12 @@ import Data.Map qualified as Map import Data.Qualified import Data.Tagged (Tagged) import Data.Text.Encoding +import Data.Text.Template (template) import Data.Time import Imports import Polysemy import Polysemy.Error +import Polysemy.Input (runInputConst) import Polysemy.State import Polysemy.TinyLog import System.Random (StdGen, mkStdGen) @@ -48,6 +50,7 @@ import Wire.API.Team.Permission import Wire.API.Team.Role (defaultRole) import Wire.API.User import Wire.EmailSubsystem +import Wire.EmailSubsystem.Template (InvitationUrlTemplates (..)) import Wire.EnterpriseLoginSubsystem import Wire.GalleyAPIAccess import Wire.InvitationStore @@ -153,11 +156,18 @@ runAllEffectsWithUserKeys initialUsers args = . discardTinyLogs . enterpriseLoginSubsystemTestInterpreter args.constGuardResult +testInvitationUrlTemplates :: InvitationUrlTemplates +testInvitationUrlTemplates = + InvitationUrlTemplates + { personalUser = template "https://example.com/accept-invitation/?team-code=${code}", + newUser = template "https://example.com/join/?team-code=${code}" + } + runInviteScenarioObserved :: InviteScenarioInput -> Either LocalErrors InviteScenarioObservation runInviteScenarioObserved input = - runAllEffectsWithUserKeys [input.inviter] args . runTeamInvitationSubsystem config $ do + runAllEffectsWithUserKeys [input.inviter] args . runInputConst testInvitationUrlTemplates . runTeamInvitationSubsystem config $ do for_ input.liveInvitations $ \inv -> void $ insertInvitation inv 3_000_000 for_ input.pendingScimUsers $ \(indexTeam, email, uid) -> deleteKey (mkEmailKey email) >> insertPendingScimUser indexTeam email uid @@ -541,7 +551,7 @@ spec = do -- run the test -- outcome :: Either LocalErrors () - outcome = runAllEffects args . runTeamInvitationSubsystem cfg $ do + outcome = runAllEffects args . runInputConst testInvitationUrlTemplates . runTeamInvitationSubsystem cfg $ do void $ inviteUser inviterLuid tid invReq -- result invariants @@ -632,6 +642,6 @@ spec = do } outcome :: Either LocalErrors () - outcome = runAllEffects interpreterArgs . runTeamInvitationSubsystem config $ do + outcome = runAllEffects interpreterArgs . runInputConst testInvitationUrlTemplates . runTeamInvitationSubsystem config $ do void $ inviteUser inviterLuid tid invitationRequest in pure $ outcome === Left (ESubsystem TeamInvitationBlockedDomain) diff --git a/libs/wire-subsystems/wire-subsystems.cabal b/libs/wire-subsystems/wire-subsystems.cabal index 78535b38f28..d65a87ee5ca 100644 --- a/libs/wire-subsystems/wire-subsystems.cabal +++ b/libs/wire-subsystems/wire-subsystems.cabal @@ -331,6 +331,7 @@ library Wire.DomainVerificationChallengeStore.DualWrite Wire.DomainVerificationChallengeStore.Postgres Wire.EmailSending + Wire.EmailSending.Composer Wire.EmailSending.Options Wire.EmailSending.Queueing Wire.EmailSending.SES @@ -338,6 +339,7 @@ library Wire.EmailSubsystem Wire.EmailSubsystem.Interpreter Wire.EmailSubsystem.Template + Wire.EmailSubsystem.Templates.Provider Wire.EmailSubsystem.Templates.Team Wire.EmailSubsystem.Templates.User Wire.EnterpriseLoginSubsystem @@ -637,7 +639,7 @@ test-suite wire-subsystems-tests Wire.ConversationSubsystem.InterpreterSpec Wire.ConversationSubsystem.MessageSpec Wire.ConversationSubsystem.One2OneSpec - Wire.EmailSendingQueueingSpec + Wire.EmailSending.ComposerSpec Wire.EmailSubsystem.TemplateFixtures Wire.EmailSubsystem.TemplateSpec Wire.EnterpriseLoginSubsystem.InterpreterSpec diff --git a/nix/wire-server.nix b/nix/wire-server.nix index c3a3010efe6..f45c76bfa1c 100644 --- a/nix/wire-server.nix +++ b/nix/wire-server.nix @@ -281,7 +281,7 @@ let # # extraContents :: Map Exe Derivation -> Map Text [Derivation] extraContents = exes: { - brig = [ brig-templates ]; + background-worker = [ brig-templates ]; brig-integration = [ brig-templates pkgs.mls-test-cli pkgs.awscli2 ]; galley-integration = [ pkgs.mls-test-cli pkgs.awscli2 ]; stern-integration = [ pkgs.awscli2 ]; diff --git a/services/background-worker/background-worker.integration.yaml b/services/background-worker/background-worker.integration.yaml index 635528bd7f4..be731a4e46f 100644 --- a/services/background-worker/background-worker.integration.yaml +++ b/services/background-worker/background-worker.integration.yaml @@ -47,6 +47,40 @@ rabbitmq: # Email transport for the background-worker (same shape as brig's emailSMS.email). # SES takes precedence over SMTP when both are configured. +# Email templates for composing the emails queued by brig; +# mirrors the values brig used to configure in its emailSMS block. +emailTemplates: + templateDir: ../../libs/wire-subsystems/templates + emailSender: backend-integration@wire.com + templateBranding: + brand: Wire + brandUrl: https://wire.com + brandLabelUrl: wire.com # This is the text in the label for the above URL + brandLogoUrl: https://wire.com/p/img/email/logo-email-black.png + brandService: Wire Service Provider + copyright: © WIRE SWISS GmbH + misuse: misuse@wire.com + legal: https://wire.com/legal/ + forgot: https://wire.com/forgot/ + support: https://support.wire.com/ + user: + activationUrl: https://example.com/verify/?key=${key}&code=${code} + teamActivationUrl: https://example.com/verify/?key=${key}&code=${code} + passwordResetUrl: https://example.com/reset/?key=${key}&code=${code} + deletionUrl: https://example.com/d/?key=${key}&code=${code} + team: + tInvitationUrl: https://example.com/join/?team-code=${code} + tExistingUserInvitationUrl: https://example.com/accept-invitation/?team-code=${code} + tActivationUrl: https://example.com/verify/?key=${key}&code=${code} + tCreatorWelcomeUrl: https://example.com/creator-welcome-website + tMemberWelcomeUrl: https://example.com/member-welcome-website + provider: + homeUrl: https://provider.localhost/ + providerActivationUrl: http://127.0.0.1:8080/verify/bot/?key=${key}&code=${code} + approvalUrl: http://127.0.0.1:8080/provider/approve?key=${key}&code=${code} + approvalTo: success@simulator.amazonses.com + providerPwResetUrl: http://127.0.0.1:8080/reset/bot/?key=${key}&code=${code} + email: sesQueue: integration-brig-events sesEndpoint: http://localhost:4569 # https://email.eu-west-1.amazonaws.com @@ -88,9 +122,9 @@ jobs: # Meetings cleanup configuration for integration meetingsCleanup: - cleanOlderThanHours: 0.0014 # Clean meetings older than ~5 seconds + cleanOlderThanHours: 0.0014 # Clean meetings older than ~5 seconds batchSize: 100 - schedule: "* * * * *" # Run every minute + schedule: "* * * * *" # Run every minute postgresMigration: conversation: postgresql diff --git a/services/background-worker/src/Wire/BackgroundWorker/Env.hs b/services/background-worker/src/Wire/BackgroundWorker/Env.hs index bebfc6abbc4..87dec8283ce 100644 --- a/services/background-worker/src/Wire/BackgroundWorker/Env.hs +++ b/services/background-worker/src/Wire/BackgroundWorker/Env.hs @@ -53,6 +53,7 @@ import Wire.API.Conversation.Protocol (ProtocolTag) import Wire.API.Team.Feature (LegalholdConfig, npProject) import Wire.API.Team.FeatureFlags (FanoutLimit, FeatureFlags) import Wire.BackgroundWorker.Options +import Wire.EmailSending.Composer (EmailTemplates, loadEmailTemplates) import Wire.EmailSending.Options qualified as EmailOpt import Wire.EmailSending.SMTP qualified as SMTP import Wire.JobSubsystem.Migrations (mkArbiterConnectionString) @@ -122,7 +123,8 @@ data Env = Env checkGroupInfo :: !(Maybe Bool), convCodeURI :: Either HttpsUrl (Map Domain HttpsUrl), passwordHashingRateLimitEnv :: RateLimitEnv, - emailTransport :: EmailTransport + emailTransport :: EmailTransport, + emailComposition :: EmailTemplates } data BackendNotificationMetrics = BackendNotificationMetrics @@ -240,6 +242,7 @@ mkEnv opts galleyOpts = do sesEndpoint = Amazonka.setEndpoint _awsSecure _awsHost _awsPort SES.defaultService EmailTransportSES <$> (Amazonka.newEnv Amazonka.discover <&> Amazonka.configureService sesEndpoint) + emailComposition <- loadEmailTemplates opts.emailTemplates Log.info logger $ Log.msg @Text "Environment initialized" pure Env {..} diff --git a/services/background-worker/src/Wire/BackgroundWorker/Options.hs b/services/background-worker/src/Wire/BackgroundWorker/Options.hs index 5434e4f13e7..14cb91b9f24 100644 --- a/services/background-worker/src/Wire/BackgroundWorker/Options.hs +++ b/services/background-worker/src/Wire/BackgroundWorker/Options.hs @@ -31,6 +31,7 @@ import System.Cron (CronSchedule, parseCronSchedule) import System.Logger.Extended import Util.Options import Wire.EmailSending.Options (EmailOpts) +import Wire.EmailSubsystem.Template (EmailTemplatesOpts) import Wire.Migration import Wire.PostgresMigrationOpts @@ -59,7 +60,8 @@ data Opts = Opts jobs :: JobConfig, meetingsCleanup :: MeetingsCleanupConfig, backgroundJobs :: BackgroundJobsConfig, - email :: !EmailOpts + email :: !EmailOpts, + emailTemplates :: !EmailTemplatesOpts } deriving (Show, Generic) deriving (FromJSON) via Generically Opts diff --git a/services/background-worker/src/Wire/EmailJobsWorker.hs b/services/background-worker/src/Wire/EmailJobsWorker.hs index 27fb7785fc4..0271094c10e 100644 --- a/services/background-worker/src/Wire/EmailJobsWorker.hs +++ b/services/background-worker/src/Wire/EmailJobsWorker.hs @@ -28,14 +28,16 @@ import Wire.API.Jobs (SendEmailJobPayload (..)) import Wire.BackgroundWorker.Env (AppT, Env (..)) import Wire.Effects (runBackgroundWorkerEffects) import Wire.EmailSending (sendMail) -import Wire.EmailSending.Queueing (fromSerializableMail) +import Wire.EmailSending.Composer (composeEmail) +import Wire.EmailSubsystem.Template (logEmailRenderErrors) import Wire.ExternalAccess.External (ExtEnv) --- | Send one outbound email queued by brig on the Arbiter @emails@ queue. +-- | Compose and send one outbound email queued by brig on the Arbiter +-- @emails@ queue. -- --- The mail record is not trusted: a payload that fails 'fromSerializableMail' --- is malformed (or adversarial) and is rejected with a warning instead of --- retried. A failing send surfaces as @'Left' 'Text'@ from +-- The payload is the composing request (email type, locale, inputs); the mail +-- itself is composed here from the bundled localized templates right before +-- sending. A failing compose or send surfaces as @'Left' 'Text'@ from -- 'runBackgroundWorkerEffects' and is rethrown as retryable so Arbiter's -- bounded retry/backoff (and, eventually, the DLQ) applies. runSendEmailJob :: ExtEnv -> JobRead SendEmailJobPayload -> AppT IO () @@ -45,12 +47,10 @@ runSendEmailJob extEnv job = do Log.msg (Log.val "Running send-email job") . Log.field "request_id" (show job.payload.sendEmailJobRequestId) . Log.field "scheduled_for" (show job.notVisibleUntil) - case fromSerializableMail job.payload.sendEmailJobMail of - Left err -> - Log.warn env.logger $ - Log.msg (Log.val "Rejecting malformed email job") - . Log.field "request_id" (show job.payload.sendEmailJobRequestId) - . Log.field "error" err - Right mail -> do - result <- liftIO $ runBackgroundWorkerEffects env extEnv job.payload.sendEmailJobRequestId Nothing $ sendMail mail - either (liftIO . throwRetryable) pure result + result <- + liftIO $ + runBackgroundWorkerEffects env extEnv job.payload.sendEmailJobRequestId Nothing $ + logEmailRenderErrors "send-email job" $ + composeEmail env.emailComposition job.payload.sendEmailJobRequest + >>= sendMail + either (liftIO . throwRetryable) pure result diff --git a/services/background-worker/test/Test/Wire/BackendNotificationPusherSpec.hs b/services/background-worker/test/Test/Wire/BackendNotificationPusherSpec.hs index 4e289bc6c78..d6f302294af 100644 --- a/services/background-worker/test/Test/Wire/BackendNotificationPusherSpec.hs +++ b/services/background-worker/test/Test/Wire/BackendNotificationPusherSpec.hs @@ -365,6 +365,7 @@ spec = do amqpJobsPublisherChannel = undefined amqpBackendNotificationsChannel = undefined emailTransport = undefined + emailComposition = undefined federationDomain = Domain "local" postgresMigration = PostgresMigrationOpts @@ -430,6 +431,7 @@ spec = do amqpJobsPublisherChannel = undefined amqpBackendNotificationsChannel = undefined emailTransport = undefined + emailComposition = undefined federationDomain = Domain "local" postgresMigration = PostgresMigrationOpts diff --git a/services/background-worker/test/Test/Wire/Util.hs b/services/background-worker/test/Test/Wire/Util.hs index b966812dc0f..5c3d608c16b 100644 --- a/services/background-worker/test/Test/Wire/Util.hs +++ b/services/background-worker/test/Test/Wire/Util.hs @@ -71,6 +71,7 @@ testEnv = do hasqlPool = undefined amqpJobsPublisherChannel = undefined emailTransport = undefined + emailComposition = undefined amqpBackendNotificationsChannel = undefined federationDomain = Domain "local" gundeckEndpoint = undefined diff --git a/services/brig/brig.cabal b/services/brig/brig.cabal index ce3c7181a1a..ecdf0f34d7f 100644 --- a/services/brig/brig.cabal +++ b/services/brig/brig.cabal @@ -125,7 +125,6 @@ library Brig.Provider.Email Brig.Provider.RPC Brig.Provider.Tag - Brig.Provider.Template Brig.Queue Brig.Queue.Stomp Brig.Queue.Types @@ -184,8 +183,6 @@ library Brig.Schema.V92_AddUserType Brig.Schema.V93_AddScimPendingUserEmail Brig.Team.API - Brig.Team.Template - Brig.Template Brig.User.API.Handle Brig.User.Auth Brig.User.Auth.Cookie @@ -193,7 +190,6 @@ library Brig.User.EJPD Brig.User.Search.Index Brig.User.Search.SearchIndex - Brig.User.Template Brig.Version hs-source-dirs: src @@ -259,7 +255,6 @@ library , metrics-core >=0.3 , metrics-wai >=0.3 , mime - , mime-mail >=0.4 , mmorph , MonadRandom >=0.5 , mtl >=2.1 diff --git a/services/brig/brig.integration.yaml b/services/brig/brig.integration.yaml index 8be11f028bd..090c50dfc77 100644 --- a/services/brig/brig.integration.yaml +++ b/services/brig/brig.integration.yaml @@ -110,33 +110,10 @@ emailSMS: # that may be used for this general: - templateDir: ../../libs/wire-subsystems/templates emailSender: backend-integration@wire.com smsSender: "+123456789" # or MG123456789... (twilio alphanumeric sender id) - templateBranding: - brand: Wire - brandUrl: https://wire.com - brandLabelUrl: wire.com # This is the text in the label for the above URL - brandLogoUrl: https://wire.com/p/img/email/logo-email-black.png - brandService: Wire Service Provider - copyright: © WIRE SWISS GmbH - misuse: misuse@wire.com - legal: https://wire.com/legal/ - forgot: https://wire.com/forgot/ - support: https://support.wire.com/ user: - activationUrl: https://example.com/verify/?key=${key}&code=${code} smsActivationUrl: https://example.com/v/${code} - passwordResetUrl: https://example.com/reset/?key=${key}&code=${code} - invitationUrl: https://example.com/register?invitation_code=${code} - deletionUrl: https://example.com/d/?key=${key}&code=${code} - - provider: - homeUrl: https://provider.localhost/ - providerActivationUrl: http://127.0.0.1:8080/verify/bot/?key=${key}&code=${code} - approvalUrl: http://127.0.0.1:8080/provider/approve?key=${key}&code=${code} - approvalTo: success@simulator.amazonses.com - providerPwResetUrl: http://127.0.0.1:8080/reset/bot/?key=${key}&code=${code} team: tInvitationUrl: https://example.com/join/?team-code=${code} diff --git a/services/brig/default.nix b/services/brig/default.nix index a556d7ad7cc..d7fdec736a4 100644 --- a/services/brig/default.nix +++ b/services/brig/default.nix @@ -213,7 +213,6 @@ mkDerivation { metrics-core metrics-wai mime - mime-mail mmorph MonadRandom mtl diff --git a/services/brig/src/Brig/API/Public.hs b/services/brig/src/Brig/API/Public.hs index dd5471760b1..78391b33723 100644 --- a/services/brig/src/Brig/API/Public.hs +++ b/services/brig/src/Brig/API/Public.hs @@ -48,7 +48,6 @@ import Brig.Effects.ConnectionStore import Brig.Options hiding (internalEvents) import Brig.Provider.API import Brig.Team.API qualified as Team -import Brig.Template (InvitationUrlTemplates) import Brig.User.API.Handle qualified as Handle import Brig.User.Auth.Cookie qualified as Auth import Brig.User.Client qualified as API @@ -162,8 +161,9 @@ import Wire.ClientSubsystem qualified as ClientSubsystem import Wire.ClientSubsystem.Error import Wire.DeleteQueue import Wire.DomainRegistrationStore (DomainRegistrationStore) -import Wire.EmailSending (EmailSending) +import Wire.EmailSending.Queueing (EmailQueueing) import Wire.EmailSubsystem +import Wire.EmailSubsystem.Template (InvitationUrlTemplates) import Wire.EnterpriseLoginSubsystem (EnterpriseLoginSubsystem) import Wire.EnterpriseLoginSubsystem qualified as EnterpriseLogin import Wire.Error @@ -365,7 +365,7 @@ servantSitemap :: Member (UserPendingActivationStore p) r, Member AuthenticationSubsystem r, Member DeleteQueue r, - Member EmailSending r, + Member EmailQueueing r, Member EmailSubsystem r, Member Events r, Member FederationConfigStore r, diff --git a/services/brig/src/Brig/App.hs b/services/brig/src/Brig/App.hs index 88e0b582a6d..0f7bb34f223 100644 --- a/services/brig/src/Brig/App.hs +++ b/services/brig/src/Brig/App.hs @@ -30,8 +30,6 @@ module Brig.App mkIndexEnv, newEnv, closeEnv, - providerTemplatesWithLocale, - teamTemplatesWithLocale, invitationUrlTemplates, cargoholdLens, galleyLens, @@ -45,15 +43,11 @@ module Brig.App casClientLens, hasqlPoolLens, emailSenderLens, + invitationUrlsLens, awsEnvLens, appLoggerLens, internalEventsLens, requestIdLens, - userTemplatesLens, - providerTemplatesLens, - teamTemplatesLens, - templateBrandingLens, - templateBrandingAsMapLens, httpManagerLens, http2ManagerLens, extGetManagerLens, @@ -110,14 +104,10 @@ import Brig.Calling qualified as Calling import Brig.DeleteQueue.Interpreter import Brig.Options (ElasticSearchOpts, Opts, Settings (..)) import Brig.Options qualified as Opt -import Brig.Provider.Template import Brig.Queue.Stomp qualified as Stomp import Brig.Queue.Types import Brig.Schema.Run qualified as Migrations -import Brig.Team.Template -import Brig.Template (InvitationUrlTemplates (..), genTemplateBranding, genTemplateBrandingMap) import Brig.User.Search.Index (IndexEnv (..), MonadIndexIO (..), runIndexIO) -import Brig.User.Template import Cassandra (runClient) import Cassandra qualified as Cas import Cassandra.Util (initCassandraForService) @@ -139,6 +129,7 @@ import Data.Text qualified as Text import Data.Text.Encoding (encodeUtf8) import Data.Text.Encoding qualified as Text import Data.Text.IO qualified as Text +import Data.Text.Template (template) import Data.Time.Clock import Database.Bloodhound qualified as ES import HTTP2.Client.Manager (Http2Manager, http2ManagerWithSSLCtx) @@ -164,14 +155,12 @@ import System.Logger.Extended qualified as Log import Util.Options import Util.SuffixNamer import Wire.API.Federation.Error (federationNotImplemented) -import Wire.API.Locale (Locale) import Wire.API.Routes.Version import Wire.API.User.Identity import Wire.AuthenticationSubsystem.Config (ZAuthEnv) import Wire.AuthenticationSubsystem.Config qualified as AuthenticationSubsystem import Wire.EmailSending.Options qualified as EmailOpt -import Wire.EmailSubsystem.Template (Localised, TemplateBranding, forLocale) -import Wire.EmailSubsystem.Templates.User +import Wire.EmailSubsystem.Template (InvitationUrlTemplates (..), TeamOpts (..)) import Wire.ExternalAccess.External import Wire.PostgresMigrationOpts import Wire.RateLimit.Interpreter @@ -200,15 +189,11 @@ data Env = Env casClient :: Cas.ClientState, hasqlPool :: HasqlPool.Pool, emailSender :: EmailAddress, + invitationUrls :: InvitationUrlTemplates, awsEnv :: AWS.Env, appLogger :: Logger, internalEvents :: QueueEnv, requestId :: RequestId, - userTemplates :: Localised UserTemplates, - providerTemplates :: Localised ProviderTemplates, - teamTemplates :: Localised TeamTemplates, - templateBranding :: TemplateBranding, - templateBrandingAsMap :: Map Text Text, httpManager :: Manager, http2Manager :: Http2Manager, extGetManager :: (Manager, [Fingerprint Rsa] -> SSL.SSL -> IO ()), @@ -262,11 +247,6 @@ newEnv opts = do mgr <- initHttpManager h2Mgr <- initHttp2Manager ext <- initExtGetManager - utp <- loadUserTemplates opts - ptp <- loadProviderTemplates opts - ttp <- loadTeamTemplatesWithBrigOpts opts - let branding = genTemplateBranding . Opt.templateBranding . Opt.general . Opt.emailSMS $ opts - brandingAsMap = genTemplateBrandingMap . Opt.templateBranding . Opt.general . Opt.emailSMS $ opts emailAWSOpts <- emailConn $ Opt.email (Opt.emailSMS opts) aws <- AWS.mkEnv lgr (Opt.aws opts) emailAWSOpts mgr zau <- initZAuth opts @@ -318,15 +298,15 @@ newEnv opts = do casClient = cas, hasqlPool = hasqlPool, emailSender = opts.emailSMS.general.emailSender, + invitationUrls = + InvitationUrlTemplates + { personalUser = template opts.emailSMS.team.tExistingUserInvitationUrl, + newUser = template opts.emailSMS.team.tInvitationUrl + }, awsEnv = aws, -- used by `journalEvent` directly appLogger = lgr, internalEvents = (eventsQueue :: QueueEnv), requestId = RequestId defRequestId, - userTemplates = utp, - providerTemplates = ptp, - teamTemplates = ttp, - templateBranding = branding, - templateBrandingAsMap = brandingAsMap, httpManager = mgr, http2Manager = h2Mgr, extGetManager = ext, @@ -463,22 +443,8 @@ initCassandra o g = (Just schemaVersion) g -teamTemplatesWithLocale :: (MonadReader Env m) => Maybe Locale -> m (Locale, TeamTemplates) -teamTemplatesWithLocale l = forLocale l <$> asks (.teamTemplates) - -providerTemplatesWithLocale :: (MonadReader Env m) => Maybe Locale -> m (Locale, ProviderTemplates) -providerTemplatesWithLocale l = forLocale l <$> asks (.providerTemplates) - invitationUrlTemplates :: (MonadReader Env m) => m InvitationUrlTemplates -invitationUrlTemplates = do - -- this works because team templates is not affected by `forLocale`; it is useful where we - -- use the `TeamTemplates` only for finding invitation url templates (those are not localized). - teamTemplates <- snd <$> teamTemplatesWithLocale Nothing - pure $ - InvitationUrlTemplates - { personalUser = teamTemplates.existingUserInvitationEmail.invitationEmailUrl, - newUser = teamTemplates.invitationEmail.invitationEmailUrl - } +invitationUrlTemplates = asks (.invitationUrls) closeEnv :: Env -> IO () closeEnv e = do diff --git a/services/brig/src/Brig/CanonicalInterpreter.hs b/services/brig/src/Brig/CanonicalInterpreter.hs index 09633558597..fe4fb71788f 100644 --- a/services/brig/src/Brig/CanonicalInterpreter.hs +++ b/services/brig/src/Brig/CanonicalInterpreter.hs @@ -25,7 +25,6 @@ import Brig.Effects.ConnectionStore.Cassandra (connectionStoreToCassandra) import Brig.IO.Intra (runEvents) import Brig.Options (Settings (consumableNotifications), federationDomainConfigs, federationStrategy) import Brig.Options qualified as Opt -import Brig.Template (InvitationUrlTemplates) import Brig.User.Search.Index (IndexEnv (..)) import Cassandra qualified as Cas import Control.Exception (ErrorCall) @@ -88,10 +87,10 @@ import Wire.DomainVerificationChallengeStore import Wire.DomainVerificationChallengeStore.Cassandra import Wire.DomainVerificationChallengeStore.DualWrite (interpretDomainVerificationChallengeStoreToCassandraAndPostgres) import Wire.DomainVerificationChallengeStore.Postgres (interpretDomainVerificationChallengeStoreToPostgres) -import Wire.EmailSending -import Wire.EmailSending.Queueing (emailViaQueueInterpreter) +import Wire.EmailSending.Queueing (EmailQueueing, emailViaQueueInterpreter) import Wire.EmailSubsystem import Wire.EmailSubsystem.Interpreter +import Wire.EmailSubsystem.Template (InvitationUrlTemplates) import Wire.EnterpriseLoginSubsystem import Wire.EnterpriseLoginSubsystem.Error (EnterpriseLoginSubsystemError, enterpriseLoginSubsystemErrorToHttpError) import Wire.EnterpriseLoginSubsystem.Interpreter @@ -272,7 +271,7 @@ type BrigLowerLevelEffects = PasswordResetCodeStore, GalleyAPIAccess, SparAPIAccess, - EmailSending, + EmailQueueing, Rpc, Metrics, Embed Cas.Client, @@ -517,7 +516,7 @@ runBrigToIO e (AppT ma) = do . runDeleteQueue e.internalEvents . interpretPropertySubsystem propertySubsystemConfig . interpretVerificationCodeSubsystem - . emailSubsystemInterpreter e.userTemplates e.teamTemplates e.templateBrandingAsMap + . emailSubsystemInterpreter . interpretAppStoreToPostgres . interpretTeamCollaboratorsStoreToPostgres . interpretTeamSubsystemToGalleyAPI diff --git a/services/brig/src/Brig/Options.hs b/services/brig/src/Brig/Options.hs index df05f68fd7d..6e3429721dd 100644 --- a/services/brig/src/Brig/Options.hs +++ b/services/brig/src/Brig/Options.hs @@ -126,74 +126,31 @@ instance FromJSON InternalEventsOpts where InternalEventsOpts <$> parseJSON (Object o) data EmailSMSGeneralOpts = EmailSMSGeneralOpts - { -- | Email, SMS, ... template directory - templateDir :: !FilePath, - -- | Email sender address + { -- | Email sender address (used by SCIM invitations and the enterprise + -- audit email; all other email is composed and sent by the + -- background-worker) emailSender :: !EmailAddress, -- | Twilio sender identifier (sender phone number in E.104 format) -- or twilio messaging sender ID - see -- https://www.twilio.com/docs/sms/send-messages#use-an-alphanumeric-sender-id - smsSender :: !Text, - -- | Customizable branding text for - -- emails/sms/calls - templateBranding :: !BrandingOpts + smsSender :: !Text } deriving (Show, Generic) instance FromJSON EmailSMSGeneralOpts -data BrandingOpts = BrandingOpts - { brand :: !Text, - brandUrl :: !Text, - brandLabelUrl :: !Text, - brandLogoUrl :: !Text, - brandService :: !Text, - copyright :: !Text, - misuse :: !Text, - legal :: !Text, - forgot :: !Text, - support :: !Text - } - deriving (Show, Generic) - -instance FromJSON BrandingOpts - data EmailUserOpts = EmailUserOpts - { -- | Activation URL template - activationUrl :: !Text, - -- | SMS activation URL template - smsActivationUrl :: !Text, - -- | Password reset URL template - passwordResetUrl :: !Text, - -- | Deletion URL template - deletionUrl :: !Text + { -- | SMS activation URL template + smsActivationUrl :: !Text } deriving (Show, Generic) instance FromJSON EmailUserOpts --- | Provider settings -data ProviderOpts = ProviderOpts - { -- | Homepage URL - homeUrl :: !Text, - -- | Activation URL template - providerActivationUrl :: !Text, - -- | Approval URL template - approvalUrl :: !Text, - -- | Approval email recipient - approvalTo :: !EmailAddress, - -- | Password reset URL template - providerPwResetUrl :: !Text - } - deriving (Show, Generic) - -instance FromJSON ProviderOpts - data EmailSMSOpts = EmailSMSOpts { email :: !EmailOpts, general :: !EmailSMSGeneralOpts, user :: !EmailUserOpts, - provider :: !ProviderOpts, team :: !TeamOpts } deriving (Show, Generic) diff --git a/services/brig/src/Brig/Provider/API.hs b/services/brig/src/Brig/Provider/API.hs index 7c5089e9f3c..ec4439b5c6d 100644 --- a/services/brig/src/Brig/Provider/API.hs +++ b/services/brig/src/Brig/Provider/API.hs @@ -125,7 +125,7 @@ import Wire.ClientStore qualified as ClientStore import Wire.ClientSubsystem as ClientSubsystem import Wire.ClientSubsystem.Error import Wire.DeleteQueue -import Wire.EmailSending (EmailSending) +import Wire.EmailSending.Queueing (EmailQueueing) import Wire.Error import Wire.GalleyAPIAccess (GalleyAPIAccess) import Wire.GalleyAPIAccess qualified as GalleyAPIAccess @@ -206,7 +206,7 @@ servicesAPI = providerAPI :: ( Member GalleyAPIAccess r, Member AuthenticationSubsystem r, - Member EmailSending r, + Member EmailQueueing r, Member HashPassword r, Member VerificationCodeSubsystem r, Member RateLimit r, @@ -242,7 +242,7 @@ internalProviderAPI = newAccount :: ( Member GalleyAPIAccess r, - Member EmailSending r, + Member EmailQueueing r, Member HashPassword r, Member VerificationCodeSubsystem r, Member RateLimit r @@ -284,7 +284,7 @@ newAccount ip new = do activateAccountKey :: ( Member GalleyAPIAccess r, - Member EmailSending r, + Member EmailQueueing r, Member VerificationCodeSubsystem r ) => Code.Key -> @@ -353,7 +353,7 @@ login l = do s <- asks (.settings) pure $ ProviderTokenCookie (ProviderToken token) (not s.cookieInsecure) -beginPasswordReset :: (Member GalleyAPIAccess r, Member EmailSending r, Member VerificationCodeSubsystem r) => Public.PasswordReset -> (Handler r) () +beginPasswordReset :: (Member GalleyAPIAccess r, Member EmailQueueing r, Member VerificationCodeSubsystem r) => Public.PasswordReset -> (Handler r) () beginPasswordReset (Public.PasswordReset target) = do guardSecondFactorDisabled Nothing pid <- wrapClientE (DB.lookupKey (mkEmailKey target)) >>= maybeBadCredentials @@ -407,7 +407,7 @@ updateAccountProfile pid upd = do updateAccountEmail :: ( Member GalleyAPIAccess r, - Member EmailSending r, + Member EmailQueueing r, Member VerificationCodeSubsystem r ) => ProviderId -> diff --git a/services/brig/src/Brig/Provider/Email.hs b/services/brig/src/Brig/Provider/Email.hs index 5d8b558dced..2088f28f077 100644 --- a/services/brig/src/Brig/Provider/Email.hs +++ b/services/brig/src/Brig/Provider/Email.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE RecordWildCards #-} - -- This file is part of the Wire Server implementation. -- -- Copyright (C) 2022 Wire Swiss GmbH @@ -25,151 +23,27 @@ module Brig.Provider.Email where import Brig.App -import Brig.Provider.Template import Data.Code qualified as Code -import Data.Range -import Data.Text (pack) -import Data.Text.Ascii qualified as Ascii -import Data.Text.Lazy qualified as LT -import Data.Text.Template import Imports -import Network.Mail.Mime import Polysemy +import Wire.API.BackgroundJobs.Email import Wire.API.User -import Wire.EmailSending -import Wire.EmailSubsystem.Interpreter (mkMimeAddress) -import Wire.EmailSubsystem.Template (TemplateBranding, renderHtmlWithBranding, renderTextWithBranding) - -------------------------------------------------------------------------------- --- Activation Email - -sendActivationMail :: (Member EmailSending r) => Name -> EmailAddress -> Code.Key -> Code.Value -> Bool -> (AppT r) () -sendActivationMail name email key code update = do - tpl <- selectTemplate update . snd <$> providerTemplatesWithLocale Nothing - branding <- asks (.templateBranding) - let mail = ActivationEmail email name key code - liftSem $ sendMail $ renderActivationMail mail tpl branding - where - selectTemplate True = activationEmailUpdate - selectTemplate False = activationEmail - -data ActivationEmail = ActivationEmail - { acmTo :: !EmailAddress, - acmName :: !Name, - acmKey :: !Code.Key, - acmCode :: !Code.Value - } - -renderActivationMail :: ActivationEmail -> ActivationEmailTemplate -> TemplateBranding -> Mail -renderActivationMail ActivationEmail {..} ActivationEmailTemplate {..} branding = - (emptyMail from) - { mailTo = [to], - mailHeaders = - [ ("Subject", LT.toStrict subj), - ("X-Zeta-Purpose", "ProviderActivation"), - ("X-Zeta-Key", Ascii.toText (fromRange key)), - ("X-Zeta-Code", Ascii.toText (fromRange code)) - ], - mailParts = [[plainPart txt, htmlPart html]] - } - where - (Code.Key key, Code.Value code) = (acmKey, acmCode) - from = Address (Just activationEmailSenderName) (fromEmail activationEmailSender) - to = mkMimeAddress acmName acmTo - txt = renderTextWithBranding activationEmailBodyText replace branding - html = renderHtmlWithBranding activationEmailBodyHtml replace branding - subj = renderTextWithBranding activationEmailSubject replace branding - replace "url" = renderActivationUrl activationEmailUrl acmKey acmCode branding - replace "email" = fromEmail acmTo - replace "name" = fromName acmName - replace x = x - -renderActivationUrl :: Template -> Code.Key -> Code.Value -> TemplateBranding -> Text -renderActivationUrl t (Code.Key k) (Code.Value v) branding = - LT.toStrict $ renderTextWithBranding t replace branding - where - replace "key" = Ascii.toText (fromRange k) - replace "code" = Ascii.toText (fromRange v) - replace x = x - --------------------------------------------------------------------------------- --- Approval Confirmation Email - -sendApprovalConfirmMail :: (Member EmailSending r) => Name -> EmailAddress -> (AppT r) () -sendApprovalConfirmMail name email = do - tpl <- approvalConfirmEmail . snd <$> providerTemplatesWithLocale Nothing - branding <- asks (.templateBranding) - let mail = ApprovalConfirmEmail email name - liftSem $ sendMail $ renderApprovalConfirmMail mail tpl branding - -data ApprovalConfirmEmail = ApprovalConfirmEmail - { apcTo :: !EmailAddress, - apcName :: !Name - } - -renderApprovalConfirmMail :: ApprovalConfirmEmail -> ApprovalConfirmEmailTemplate -> TemplateBranding -> Mail -renderApprovalConfirmMail ApprovalConfirmEmail {..} ApprovalConfirmEmailTemplate {..} branding = - (emptyMail from) - { mailTo = [to], - mailHeaders = - [ ("Subject", LT.toStrict subj), - ("X-Zeta-Purpose", "ProviderApprovalConfirm") - ], - mailParts = [[plainPart txt, htmlPart html]] - } - where - from = Address (Just approvalConfirmEmailSenderName) (fromEmail approvalConfirmEmailSender) - to = mkMimeAddress apcName apcTo - txt = renderTextWithBranding approvalConfirmEmailBodyText replace branding - html = renderHtmlWithBranding approvalConfirmEmailBodyHtml replace branding - subj = renderTextWithBranding approvalConfirmEmailSubject replace branding - replace "homeUrl" = pack $ show approvalConfirmEmailHomeUrl - replace "email" = fromEmail apcTo - replace "name" = fromName apcName - replace x = x - --------------------------------------------------------------------------------- --- Password Reset Email - -sendPasswordResetMail :: (Member EmailSending r) => EmailAddress -> Code.Key -> Code.Value -> (AppT r) () -sendPasswordResetMail to key code = do - tpl <- passwordResetEmail . snd <$> providerTemplatesWithLocale Nothing - branding <- asks (.templateBranding) - let mail = PasswordResetEmail to key code - liftSem $ sendMail $ renderPwResetMail mail tpl branding - -data PasswordResetEmail = PasswordResetEmail - { pwrTo :: !EmailAddress, - pwrKey :: !Code.Key, - pwrCode :: !Code.Value - } - -renderPwResetMail :: PasswordResetEmail -> PasswordResetEmailTemplate -> TemplateBranding -> Mail -renderPwResetMail PasswordResetEmail {..} PasswordResetEmailTemplate {..} branding = - (emptyMail from) - { mailTo = [to], - mailHeaders = - [ ("Subject", LT.toStrict subj), - ("X-Zeta-Purpose", "ProviderPasswordReset"), - ("X-Zeta-Key", Ascii.toText (fromRange key)), - ("X-Zeta-Code", Ascii.toText (fromRange code)) - ], - mailParts = [[plainPart txt, htmlPart html]] - } - where - (Code.Key key, Code.Value code) = (pwrKey, pwrCode) - from = Address (Just passwordResetEmailSenderName) (fromEmail passwordResetEmailSender) - to = Address Nothing (fromEmail pwrTo) - txt = renderTextWithBranding passwordResetEmailBodyText replace branding - html = renderHtmlWithBranding passwordResetEmailBodyHtml replace branding - subj = renderTextWithBranding passwordResetEmailSubject replace branding - replace "url" = renderPwResetUrl passwordResetEmailUrl pwrKey pwrCode branding - replace x = x - -renderPwResetUrl :: Template -> Code.Key -> Code.Value -> TemplateBranding -> Text -renderPwResetUrl t (Code.Key k) (Code.Value v) branding = - LT.toStrict $ renderTextWithBranding t replace branding - where - replace "key" = Ascii.toText (fromRange k) - replace "code" = Ascii.toText (fromRange v) - replace x = x +import Wire.EmailSending.Queueing + +sendActivationMail :: (Member EmailQueueing r) => Name -> EmailAddress -> Code.Key -> Code.Value -> Bool -> (AppT r) () +sendActivationMail name email key code update = + liftSem $ + queueEmail $ + ProviderActivationEmail (MkProviderActivationEmail email name key code update) + +sendApprovalConfirmMail :: (Member EmailQueueing r) => Name -> EmailAddress -> (AppT r) () +sendApprovalConfirmMail name email = + liftSem $ + queueEmail $ + ProviderApprovalConfirmEmail (MkProviderApprovalConfirmEmail email name) + +sendPasswordResetMail :: (Member EmailQueueing r) => EmailAddress -> Code.Key -> Code.Value -> (AppT r) () +sendPasswordResetMail to key code = + liftSem $ + queueEmail $ + ProviderPasswordResetEmail (MkProviderPasswordResetEmail to key code) diff --git a/services/brig/src/Brig/Team/API.hs b/services/brig/src/Brig/Team/API.hs index 48430fbebab..1bdc43ce306 100644 --- a/services/brig/src/Brig/Team/API.hs +++ b/services/brig/src/Brig/Team/API.hs @@ -31,7 +31,6 @@ import Brig.API.User (createUserInviteViaScim) import Brig.API.User qualified as API import Brig.API.Util (logEmail, logInvitationCode) import Brig.App as App -import Brig.Template import Control.Lens (view, (^.)) import Control.Monad.Trans.Except import Data.ByteString.Conversion (toByteString) @@ -70,6 +69,7 @@ import Wire.API.User hiding (fromEmail) import Wire.AuthenticationSubsystem import Wire.BlockListStore import Wire.EmailSubsystem.Interpreter (renderInvitationUrl) +import Wire.EmailSubsystem.Template (InvitationUrlTemplates (..)) import Wire.Error import Wire.Events (Events) import Wire.GalleyAPIAccess (GalleyAPIAccess, ShowOrHideInvitationUrl (..)) diff --git a/services/brig/src/Brig/Team/Template.hs b/services/brig/src/Brig/Team/Template.hs deleted file mode 100644 index caffd40e85d..00000000000 --- a/services/brig/src/Brig/Team/Template.hs +++ /dev/null @@ -1,39 +0,0 @@ --- This file is part of the Wire Server implementation. --- --- Copyright (C) 2022 Wire Swiss GmbH --- --- This program is free software: you can redistribute it and/or modify it under --- the terms of the GNU Affero General Public License as published by the Free --- Software Foundation, either version 3 of the License, or (at your option) any --- later version. --- --- This program is distributed in the hope that it will be useful, but WITHOUT --- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS --- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more --- details. --- --- You should have received a copy of the GNU Affero General Public License along --- with this program. If not, see . - -module Brig.Team.Template - ( TeamTemplates (..), - InvitationEmailTemplate (..), - MemberWelcomeEmailTemplate (..), - loadTeamTemplatesWithBrigOpts, - ) -where - -import Brig.Options -import Imports -import Wire.EmailSubsystem.Template -import Wire.EmailSubsystem.Templates.Team - --- FUTUREWORK: This can be inlined once the `API.Template` have been migrated --- to wire-subsystem unit tests. -loadTeamTemplatesWithBrigOpts :: Opts -> IO (Localised TeamTemplates) -loadTeamTemplatesWithBrigOpts o = - loadTeamTemplates - o.emailSMS.team - o.emailSMS.general.templateDir - (defaultTemplateLocale o.settings) - (emailSender o.emailSMS.general) diff --git a/services/brig/src/Brig/Template.hs b/services/brig/src/Brig/Template.hs deleted file mode 100644 index 0b530261d05..00000000000 --- a/services/brig/src/Brig/Template.hs +++ /dev/null @@ -1,72 +0,0 @@ -{-# LANGUAGE RecordWildCards #-} - --- This file is part of the Wire Server implementation. --- --- Copyright (C) 2022 Wire Swiss GmbH --- --- This program is free software: you can redistribute it and/or modify it under --- the terms of the GNU Affero General Public License as published by the Free --- Software Foundation, either version 3 of the License, or (at your option) any --- later version. --- --- This program is distributed in the hope that it will be useful, but WITHOUT --- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS --- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more --- details. --- --- You should have received a copy of the GNU Affero General Public License along --- with this program. If not, see . - --- | Common templating utilities. -module Brig.Template - ( InvitationUrlTemplates (..), - genTemplateBranding, - genTemplateBrandingMap, - ) -where - -import Brig.Options -import Data.Map.Strict qualified as Map -import Data.Text.Template (Template) -import Imports - -data InvitationUrlTemplates = InvitationUrlTemplates - { personalUser :: Template, - newUser :: Template - } - --- | See 'genTemplateBranding'. -type TemplateBranding = Text -> Text - --- | Function to be applied everywhere where email/sms/call --- templating is used (ensures that placeholders are replaced --- by the appropriate branding, typically Wire) -genTemplateBranding :: BrandingOpts -> TemplateBranding -genTemplateBranding BrandingOpts {..} = fn - where - fn "brand" = brand - fn "brand_url" = brandUrl - fn "brand_label_url" = brandLabelUrl - fn "brand_logo" = brandLogoUrl - fn "brand_service" = brandService - fn "copyright" = copyright - fn "misuse" = misuse - fn "legal" = legal - fn "forgot" = forgot - fn "support" = support - fn other = other - -genTemplateBrandingMap :: BrandingOpts -> Map Text Text -genTemplateBrandingMap opts = - Map.fromList - [ ("brand", opts.brand), - ("brand_url", opts.brandUrl), - ("brand_label_url", opts.brandLabelUrl), - ("brand_logo", opts.brandLogoUrl), - ("brand_service", opts.brandService), - ("copyright", opts.copyright), - ("misuse", opts.misuse), - ("legal", opts.legal), - ("forgot", opts.forgot), - ("support", opts.support) - ] diff --git a/services/brig/src/Brig/User/Template.hs b/services/brig/src/Brig/User/Template.hs deleted file mode 100644 index 9f9636f510e..00000000000 --- a/services/brig/src/Brig/User/Template.hs +++ /dev/null @@ -1,40 +0,0 @@ --- This file is part of the Wire Server implementation. --- --- Copyright (C) 2022 Wire Swiss GmbH --- --- This program is free software: you can redistribute it and/or modify it under --- the terms of the GNU Affero General Public License as published by the Free --- Software Foundation, either version 3 of the License, or (at your option) any --- later version. --- --- This program is distributed in the hope that it will be useful, but WITHOUT --- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS --- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more --- details. --- --- You should have received a copy of the GNU Affero General Public License along --- with this program. If not, see . - -module Brig.User.Template (loadUserTemplates) where - -import Brig.Options qualified as Opt -import Imports -import Wire.EmailSubsystem.Template hiding (loadUserTemplates) -import Wire.EmailSubsystem.Template qualified as EmailTemplate -import Wire.EmailSubsystem.Templates.User - -loadUserTemplates :: Opt.Opts -> IO (Localised UserTemplates) -loadUserTemplates o = - EmailTemplate.loadUserTemplates - userTemplateOpts - o.emailSMS.general.templateDir - (Opt.defaultTemplateLocale o.settings) - o.emailSMS.general.emailSender - where - userTemplateOpts = - UserTemplateOpts - { activationUrl = o.emailSMS.user.activationUrl, - teamActivationUrl = o.emailSMS.team.tActivationUrl, - passwordResetUrl = o.emailSMS.user.passwordResetUrl, - deletionUrl = o.emailSMS.user.deletionUrl - } From 4558fd11aba2ffe9edd9e58f4e799da5263f2d9a Mon Sep 17 00:00:00 2001 From: Gautier DI FOLCO Date: Wed, 26 Aug 2026 22:46:26 +0200 Subject: [PATCH 5/7] Hello CI From 12e3337e961b47dea80a83a487a07b24ce9ffc43 Mon Sep 17 00:00:00 2001 From: Gautier DI FOLCO Date: Wed, 26 Aug 2026 23:06:11 +0200 Subject: [PATCH 6/7] Hello CI From a5dc27f3c2f11e2e7bc5c2713af2df5001229dec Mon Sep 17 00:00:00 2001 From: Gautier DI FOLCO Date: Wed, 26 Aug 2026 23:11:21 +0200 Subject: [PATCH 7/7] fix: headroom drive me crazy --- hack/bin/headroom-treefmt.sh | 12 +++++++++++- 1 file changed, 11 insertions(+), 1 deletion(-) diff --git a/hack/bin/headroom-treefmt.sh b/hack/bin/headroom-treefmt.sh index 6f31cf343f5..1c5521e8f18 100755 --- a/hack/bin/headroom-treefmt.sh +++ b/hack/bin/headroom-treefmt.sh @@ -18,4 +18,14 @@ done # '-a' matches 'run-mode: add' from the config; we pass it explicitly so that # this stays add-only even if someone changes the config's default run-mode. -headroom run -a "${args[@]}" + +# headroom touches a per-user SQLite KV store (~/.headroom/cache.sqlite) on +# every startup (update check; no --no-cache flag in v0.4.3.0). Concurrent CI +# jobs on the same worker share $HOME and race on that file, and the embedded +# persistent-sqlite has no busy timeout, so the loser dies with +# "SQLite3 returned ErrorBusy ... database is locked". Point HOME at a +# throwaway dir with the update check disabled so no shared state is touched. +hr_home="$(mktemp -d)" +mkdir -p "$hr_home/.headroom" +printf 'updates:\n check-for-updates: false\n update-interval-days: 7\n' > "$hr_home/.headroom/global-config.yaml" +HOME="$hr_home" headroom run -a "${args[@]}"