From 27cf0123cee27d96dbf6954797793f3619e7b34a Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Mon, 18 May 2026 19:25:27 +0200 Subject: [PATCH 1/8] Changelog. --- ...end-emails-to-team-admins-on-app-creation-_-update-_-deletion | 1 + 1 file changed, 1 insertion(+) create mode 100644 changelog.d/2-features/WPB-18127-send-emails-to-team-admins-on-app-creation-_-update-_-deletion diff --git a/changelog.d/2-features/WPB-18127-send-emails-to-team-admins-on-app-creation-_-update-_-deletion b/changelog.d/2-features/WPB-18127-send-emails-to-team-admins-on-app-creation-_-update-_-deletion new file mode 100644 index 0000000000..3924726d00 --- /dev/null +++ b/changelog.d/2-features/WPB-18127-send-emails-to-team-admins-on-app-creation-_-update-_-deletion @@ -0,0 +1 @@ +Send emails to team admins on app creation / update / deletion. From 7c0584064be0c12002bb4984d2d8162a459f4d14 Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Mon, 6 Jul 2026 10:36:48 +0200 Subject: [PATCH 2/8] WIP --- .../src/Wire/AppSubsystem/Interpreter.hs | 64 +++- .../src/Wire/EmailSubsystem.hs | 18 ++ .../src/Wire/EmailSubsystem/Interpreter.hs | 59 ++++ .../src/Wire/EmailSubsystem/Template.hs | 7 + .../src/Wire/EmailSubsystem/Templates/Team.hs | 11 +- .../en/team/email/app-event-subject.txt | 1 + .../templates/en/team/email/app-event.html | 1 + .../templates/en/team/email/app-event.txt | 15 + .../unit/Wire/AppSubsystem/InterpreterSpec.hs | 277 ++++++++++++++++++ .../unit/Wire/MockInterpreters/AppStore.hs | 7 +- .../Wire/MockInterpreters/EmailSubsystem.hs | 14 +- .../Wire/MockInterpreters/UserSubsystem.hs | 2 +- libs/wire-subsystems/wire-subsystems.cabal | 1 + 13 files changed, 463 insertions(+), 14 deletions(-) create mode 100644 libs/wire-subsystems/templates/en/team/email/app-event-subject.txt create mode 100644 libs/wire-subsystems/templates/en/team/email/app-event.html create mode 100644 libs/wire-subsystems/templates/en/team/email/app-event.txt create mode 100644 libs/wire-subsystems/test/unit/Wire/AppSubsystem/InterpreterSpec.hs diff --git a/libs/wire-subsystems/src/Wire/AppSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/AppSubsystem/Interpreter.hs index 513deff6bf..bd66d2d262 100644 --- a/libs/wire-subsystems/src/Wire/AppSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/AppSubsystem/Interpreter.hs @@ -17,6 +17,7 @@ module Wire.AppSubsystem.Interpreter where +import Control.Lens ((^..)) import Data.ByteString.Conversion import Data.Default import Data.Id @@ -46,6 +47,8 @@ import Wire.AppSubsystem import Wire.AuthenticationSubsystem import Wire.AuthenticationSubsystem.Cookie (revokeAllCookies) import Wire.AuthenticationSubsystem.ZAuth +import Wire.EmailSubsystem (EmailSubsystem) +import Wire.EmailSubsystem qualified as Email import Wire.Events import Wire.GalleyAPIAccess import Wire.NotificationSubsystem @@ -59,17 +62,18 @@ import Wire.UserStore qualified as Store import Wire.UserSubsystem (UserSubsystem, internalUpdateSearchIndex) runAppSubsystem :: - ( Member UserStore r, - Member TinyLog r, + ( Member AppStore r, + Member EmailSubsystem r, Member (Error AppSubsystemError) r, - Member (Input AppSubsystemConfig) r, + Member Events r, Member GalleyAPIAccess r, - Member AppStore r, - Member Now r, - Member TeamSubsystem r, + Member (Input AppSubsystemConfig) r, Member NotificationSubsystem r, + Member Now r, Member Random r, - Member Events r + Member TeamSubsystem r, + Member TinyLog r, + Member UserStore r ) => InterpreterFor UserSubsystem (AuthenticationSubsystem ': r) -> InterpreterFor AuthenticationSubsystem r -> @@ -95,6 +99,7 @@ createAppImpl :: Member Now r, Member TeamSubsystem r, Member NotificationSubsystem r, + Member EmailSubsystem r, Member AuthenticationSubsystem r, Member UserSubsystem r, Member Random r @@ -134,6 +139,8 @@ createAppImpl lusr tid newApp = do -- generate a team event generateTeamEvents creator.id tid [EdMemberJoin u.id] + notifyAdmins tid (tUnqualified lusr) "created" (fromName newApp.name) u.id + c :: Cookie (Token U) <- newCookie u.id Nothing PersistentCookie Nothing RevokeSameLabel pure CreatedApp @@ -199,8 +206,10 @@ updateAppImpl :: Member (Error AppSubsystemError) r, Member Events r, Member GalleyAPIAccess r, + Member TeamSubsystem r, + Member UserStore r, Member UserSubsystem r, - Member UserStore r + Member EmailSubsystem r ) => Local UserId -> TeamId -> @@ -222,6 +231,11 @@ updateAppImpl lusr tid appid upd = do eupAccentId = upd.accentId, eupAssets = upd.assets } + appName <- + fromName <$> case upd.name of + Just n -> pure n + Nothing -> (.name) <$> (Store.getUser appid >>= note AppSubsystemErrorNoApp) + notifyAdmins tid (tUnqualified lusr) "updated" appName appid refreshAppCookieImpl :: ( Member AuthenticationSubsystem r, @@ -287,10 +301,40 @@ appNewStoredUser creator new = do defAppSupportedProtocols :: Set BaseProtocolTag defAppSupportedProtocols = Set.singleton BaseProtocolMLSTag +-- | Send an app-event email to every team admin/owner. +-- 'action' should be "created", "updated", or "deleted". +-- Admins without an email address are silently skipped. +notifyAdmins :: + ( Member TeamSubsystem r, + Member UserStore r, + Member EmailSubsystem r + ) => + TeamId -> + UserId -> + Text -> + Text -> + UserId -> + Sem r () +notifyAdmins tid actorId action appName appId = do + admins <- internalGetTeamAdmins tid + let adminUids = admins ^.. T.teamMembers . traverse . T.userId + adminUsers <- Store.getUsers adminUids + forM_ adminUsers $ \u -> + for_ u.email $ \email -> + Email.sendAppEventEmail email u.name action appName appId tid actorId u.locale + deleteAppImpl :: - (Member AppStore r) => + ( Member AppStore r, + Member UserStore r, + Member TeamSubsystem r, + Member EmailSubsystem r + ) => TeamId -> UserId -> Sem r () -deleteAppImpl teamId appId = +deleteAppImpl teamId appId = do + appName <- maybe "" (fromName . (.name)) <$> Store.getUser appId + mbStoredApp <- Store.getApp appId teamId + let actorId = maybe appId (.creator) mbStoredApp Store.deleteApp appId teamId + notifyAdmins teamId actorId "deleted" appName appId diff --git a/libs/wire-subsystems/src/Wire/EmailSubsystem.hs b/libs/wire-subsystems/src/Wire/EmailSubsystem.hs index 0ab910e724..55f55629fe 100644 --- a/libs/wire-subsystems/src/Wire/EmailSubsystem.hs +++ b/libs/wire-subsystems/src/Wire/EmailSubsystem.hs @@ -61,5 +61,23 @@ data EmailSubsystem m a where Maybe URI -> Maybe Locale -> EmailSubsystem m () + SendAppEventEmail :: + -- | sender email + EmailAddress -> + -- | sender name + Name -> + -- | action (one of ["created", "updated", "deleted"]) + Text -> + -- | appName + Text -> + -- | appId + UserId -> + -- | tid + TeamId -> + -- | actorId + UserId -> + -- | mLocale + Maybe Locale -> + EmailSubsystem m () makeSem ''EmailSubsystem diff --git a/libs/wire-subsystems/src/Wire/EmailSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/EmailSubsystem/Interpreter.hs index 5a9b54fa14..d8514fa278 100644 --- a/libs/wire-subsystems/src/Wire/EmailSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/EmailSubsystem/Interpreter.hs @@ -76,6 +76,8 @@ emailSubsystemInterpreter userTpls teamTpls branding = interpret \case SendNewTeamOwnerWelcomeEmail email tid teamName loc name -> sendNewTeamOwnerWelcomeEmailImpl teamTpls branding email tid teamName loc name 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 + SendAppEventEmail email name action appName appId tid actorId mLocale -> + sendAppEventEmailImpl teamTpls branding email name action appName appId tid actorId mLocale ------------------------------------------------------------------------------- -- Verification Email for @@ -698,6 +700,63 @@ renderIdPConfigChangeEmail email IdPConfigChangeEmailTemplate {..} branding adde & Map.insert "subject" (T.pack d.subject) & Map.insert "issuer" (T.pack d.issuer) +------------------------------------------------------------------------------- +-- App Event Email + +sendAppEventEmailImpl :: + (Member EmailSending r, Member TinyLog r) => + Localised TeamTemplates -> + Map Text Text -> + EmailAddress -> + Name -> + Text -> + Text -> + UserId -> + TeamId -> + UserId -> + Maybe Locale -> + Sem r () +sendAppEventEmailImpl teamTemplates branding email name action appName appId tid actorId mLocale = do + let tpl = appEventEmail . snd $ forLocale mLocale teamTemplates + mail <- logEmailRenderErrors "app event email" $ renderAppEventEmail email name action appName appId tid actorId tpl branding + sendMail mail + +renderAppEventEmail :: + (Member (Output Text) r) => + EmailAddress -> + Name -> + Text -> + Text -> + UserId -> + TeamId -> + UserId -> + AppEventEmailTemplate -> + Map Text Text -> + Sem r Mail +renderAppEventEmail email name action appName appId tid actorId AppEventEmailTemplate {..} branding = do + let replace = + branding + & Map.insert "action" action + & Map.insert "app_name" appName + & Map.insert "app_id" (idToText appId) + & Map.insert "team_id" (idToText tid) + & Map.insert "actor_id" (idToText actorId) + txt <- renderTextWithBrandingSem appEventEmailBodyText replace + html <- renderHtmlWithBrandingSem appEventEmailBodyHtml replace + subj <- renderTextWithBrandingSem appEventEmailSubject replace + pure + (emptyMail from) + { mailTo = [to], + mailHeaders = + [ ("Subject", toStrict subj), + ("X-Zeta-Purpose", "AppEvent") + ], + mailParts = [[plainPart txt, htmlPart html]] + } + where + from = Address (Just appEventEmailSenderName) (fromEmail appEventEmailSender) + to = mkMimeAddress name email + ------------------------------------------------------------------------------- -- MIME Conversions diff --git a/libs/wire-subsystems/src/Wire/EmailSubsystem/Template.hs b/libs/wire-subsystems/src/Wire/EmailSubsystem/Template.hs index 2a2550cfd3..2717d628e5 100644 --- a/libs/wire-subsystems/src/Wire/EmailSubsystem/Template.hs +++ b/libs/wire-subsystems/src/Wire/EmailSubsystem/Template.hs @@ -247,6 +247,13 @@ loadTeamTemplates tOptions templatesDir defLocale sender = readLocalesDir defLoc <*> pure sender <*> readText' fp "email/sender.txt" ) + <*> ( AppEventEmailTemplate + <$> readTemplate' fp "email/app-event-subject.txt" + <*> readTemplate' fp "email/app-event.txt" + <*> readTemplate' fp "email/app-event.html" + <*> pure sender + <*> readText' fp "email/sender.txt" + ) where tUrl = template tOptions.tInvitationUrl tExistingUrl = template tOptions.tExistingUserInvitationUrl diff --git a/libs/wire-subsystems/src/Wire/EmailSubsystem/Templates/Team.hs b/libs/wire-subsystems/src/Wire/EmailSubsystem/Templates/Team.hs index 6833e6dae5..426c8a1466 100644 --- a/libs/wire-subsystems/src/Wire/EmailSubsystem/Templates/Team.hs +++ b/libs/wire-subsystems/src/Wire/EmailSubsystem/Templates/Team.hs @@ -62,10 +62,19 @@ data IdPConfigChangeEmailTemplate = IdPConfigChangeEmailTemplate senderName :: !Text } +data AppEventEmailTemplate = AppEventEmailTemplate + { appEventEmailSubject :: !Template, + appEventEmailBodyText :: !Template, + appEventEmailBodyHtml :: !Template, + appEventEmailSender :: !EmailAddress, + appEventEmailSenderName :: !Text + } + data TeamTemplates = TeamTemplates { invitationEmail :: !InvitationEmailTemplate, existingUserInvitationEmail :: !InvitationEmailTemplate, memberWelcomeEmail :: !MemberWelcomeEmailTemplate, newTeamOwnerWelcomeEmail :: !NewTeamOwnerWelcomeEmailTemplate, - idpConfigChangeEmail :: !IdPConfigChangeEmailTemplate + idpConfigChangeEmail :: !IdPConfigChangeEmailTemplate, + appEventEmail :: !AppEventEmailTemplate } diff --git a/libs/wire-subsystems/templates/en/team/email/app-event-subject.txt b/libs/wire-subsystems/templates/en/team/email/app-event-subject.txt new file mode 100644 index 0000000000..18188d5b58 --- /dev/null +++ b/libs/wire-subsystems/templates/en/team/email/app-event-subject.txt @@ -0,0 +1 @@ +App ${action} in your team \ No newline at end of file diff --git a/libs/wire-subsystems/templates/en/team/email/app-event.html b/libs/wire-subsystems/templates/en/team/email/app-event.html new file mode 100644 index 0000000000..1c33df2c72 --- /dev/null +++ b/libs/wire-subsystems/templates/en/team/email/app-event.html @@ -0,0 +1 @@ +App ${action} in your team

${brand_label_url}

App ${action} in your team

The app ${app_name} (ID: ${app_id}) was ${action} in your team.

Team ID:
${team_id}

Performed by user ID:
${actor_id}

If you did not expect this change, please review your team settings.

Privacy Policy and Terms of Use · Report misuse
${copyright}. All rights reserved.

                                                           
\ No newline at end of file diff --git a/libs/wire-subsystems/templates/en/team/email/app-event.txt b/libs/wire-subsystems/templates/en/team/email/app-event.txt new file mode 100644 index 0000000000..ca31d8857a --- /dev/null +++ b/libs/wire-subsystems/templates/en/team/email/app-event.txt @@ -0,0 +1,15 @@ +[${brand_logo}] + +${brand_label_url} [${brand_url}] + +APP ${action} IN YOUR TEAM +The app "${app_name}" (ID: ${app_id}) was ${action} in your team by ${actor_handle}. + + +-------------------------------------------------------------------------------- + +If you did not expect this change, please review your team settings. +[${support}] + +Privacy Policy and Terms of Use [${legal}]ยท Report misuse [${misuse}] +${copyright}. All rights reserved. diff --git a/libs/wire-subsystems/test/unit/Wire/AppSubsystem/InterpreterSpec.hs b/libs/wire-subsystems/test/unit/Wire/AppSubsystem/InterpreterSpec.hs new file mode 100644 index 0000000000..821584fe68 --- /dev/null +++ b/libs/wire-subsystems/test/unit/Wire/AppSubsystem/InterpreterSpec.hs @@ -0,0 +1,277 @@ +{-# OPTIONS_GHC -Wno-ambiguous-fields #-} + +-- 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 . + +module Wire.AppSubsystem.InterpreterSpec (spec) where + +import Data.Default (def) +import Data.Id +import Data.LegalHold (UserLegalHoldStatus (..)) +import Data.Map qualified as Map +import Data.Qualified +import Data.Range +import Data.Tagged (Tagged) +import Imports +import Polysemy +import Polysemy.Error +import Polysemy.Input +import Polysemy.Internal +import Polysemy.State +import Polysemy.TinyLog (TinyLog) +import Test.Hspec +import Test.Hspec.QuickCheck +import Test.QuickCheck +import Wire.API.Error (ErrorS) +import Wire.API.Error.Galley (GalleyError (TeamMemberNotFound, TeamNotFound)) +import Wire.API.Team.Member +import Wire.API.Team.Permission (fullPermissions) +import Wire.API.User +import Wire.AppStore hiding (deleteApp, updateApp) +import Wire.AppSubsystem +import Wire.AppSubsystem.Interpreter +import Wire.AuthenticationSubsystem +import Wire.EmailSubsystem +import Wire.Events (Events) +import Wire.GalleyAPIAccess +import Wire.MockInterpreters +import Wire.NotificationSubsystem +import Wire.Sem.Now (Now) +import Wire.Sem.Random (Random) +import Wire.StoredUser (StoredUser (..)) +import Wire.TeamSubsystem +import Wire.TeamSubsystem.GalleyAPI (interpretTeamSubsystemToGalleyAPI) +import Wire.UserKeyStore +import Wire.UserStore +import Wire.UserSubsystem + +type LowerAppEffects = + '[ Now, + Random, + TinyLog, + Input AppSubsystemConfig, + State [Push], + State [MiniEvent], + State (Map EmailAddress [SentMail]), + State [StoredApp], + Error AppSubsystemError, + ErrorS 'TeamMemberNotFound, + ErrorS 'TeamNotFound + ] + +-- | I wonder if we should do this everywhere? +(.<) :: (a -> b) -> (b -> c) -> a -> c +f .< g = g . f + +infixr 9 .< + +runLowerAppEffects :: + [StoredApp] -> + Sem (LowerAppEffects `Append` r) a -> + Sem r (Either AppSubsystemError (a, Map EmailAddress [SentMail])) +runLowerAppEffects initialApps = + interpretNowConst defaultTime + .< runRandomPure + .< noopLogger + .< runInputConst def + .< evalState @[Push] [] + .< evalState @[MiniEvent] [] + .< runState @(Map EmailAddress [SentMail]) mempty + .< evalState @[StoredApp] initialApps + .< runError @AppSubsystemError + .< runError @(Tagged 'TeamMemberNotFound ()) + .< runError @(Tagged 'TeamNotFound ()) + .< fmap (either (error . show) (either (error . show) (fmap swap))) + +-- | Run a single AppSubsystem operation and return the emails that were sent. +-- UserSubsystem and AuthenticationSubsystem are stubs: they crash loudly if invoked. +runAppEffects :: + [StoredUser] -> + [StoredApp] -> + Map TeamId [TeamMember] -> + Sem + ( '[ AppSubsystem, + TeamSubsystem, + GalleyAPIAccess, + UserStore, + UserKeyStore, + AppStore, + EmailSubsystem, + NotificationSubsystem, + Events + ] + `Append` LowerAppEffects + ) + a -> + Either AppSubsystemError (a, Map EmailAddress [SentMail]) +runAppEffects initialUsers initialApps teams action = + run + . ( runAppSubsystem stubUserSubsystem stubAuthSubsystem + .< interpretTeamSubsystemToGalleyAPI + .< miniGalleyAPIAccess teams def + .< runInMemoryUserStoreInterpreter initialUsers mempty + .< runInMemoryUserKeyStoreIntepreterWithStoredUsers initialUsers + .< inMemoryAppStoreInterpreter + .< inMemoryEmailSubsystemInterpreter + .< inMemoryNotificationSubsystemInterpreter + .< miniEventInterpreter + .< runLowerAppEffects initialApps + ) + $ action + where + stubAuthSubsystem :: forall r. InterpreterFor AuthenticationSubsystem r + stubAuthSubsystem = interpret $ \case + _ -> error "AuthenticationSubsystem: unexpected call in AppSubsystem unit test" + + stubUserSubsystem :: forall r. (Member UserStore r, Member UserKeyStore r) => InterpreterFor UserSubsystem (AuthenticationSubsystem ': r) + stubUserSubsystem = + -- :: (Member UserStore r, Member UserKeyStore r) => InterpreterFor UserSubsystem r + inMemoryUserSubsystemInterpreter + + stubUserSubsystem' :: forall r. InterpreterFor UserSubsystem (AuthenticationSubsystem ': r) + stubUserSubsystem' = interpret $ \case + _ -> error "UserSubsystem: unexpected call in AppSubsystem unit test" -- ?? + +-- | Minimal StoredUser with only the fields we care about set. +mkStoredUser :: UserId -> Name -> Maybe EmailAddress -> Maybe TeamId -> StoredUser +mkStoredUser uid uname email tid = + StoredUser + { id = uid, + userType = Nothing, + name = uname, + textStatus = Nothing, + pict = Nothing, + email = email, + emailUnvalidated = Nothing, + ssoId = Nothing, + accentId = ColourId 0, + assets = Nothing, + activated = True, + status = Just Active, + expires = Nothing, + language = Nothing, + country = Nothing, + providerId = Nothing, + serviceId = Nothing, + handle = Nothing, + teamId = tid, + managedBy = Nothing, + supportedProtocols = Nothing, + searchable = Nothing + } + +-- | A team member with full (owner) permissions, so they pass both CreateApp +-- and isAdminOrOwner checks. +mkOwnerMember :: UserId -> TeamMember +mkOwnerMember uid = mkTeamMember uid fullPermissions Nothing UserLegalHoldDisabled + +-- | A minimal StoredApp. +mkStoredApp :: UserId -> TeamId -> UserId -> StoredApp +mkStoredApp appId tid creatorId = + StoredApp + { id = appId, + teamId = tid, + meta = mempty, + category = Category "other", + description = unsafeRange "", + creator = creatorId + } + +spec :: Spec +spec = focus . describe "AppSubsystem" $ do + describe "deleteApp" $ do + prop "sends an email to each team admin that has an email address" $ + \(tid :: TeamId) (appId :: UserId) (creatorId :: UserId) (adminId :: UserId) (adminEmail :: EmailAddress) (appName :: Name) -> + let appUser = mkStoredUser appId appName Nothing (Just tid) + admin = mkStoredUser adminId (Name "Admin") (Just adminEmail) (Just tid) + storedApp = mkStoredApp appId tid creatorId + teams = Map.singleton tid [mkOwnerMember adminId] + result = runAppEffects [appUser, admin] [storedApp] teams $ deleteApp tid appId + in case result of + Left err -> counterexample (show err) False + Right ((), sentEmails) -> + Map.lookup adminEmail sentEmails + === Just + [ SentMail + Nothing + AppEventMail + { aeAction = "deleted", + aeAppName = fromName appName, + aeAppId = appId, + aeTeamId = tid, + aeActorId = creatorId + } + ] + + prop "skips admins without an email address" $ + \(tid :: TeamId) (appId :: UserId) (creatorId :: UserId) (adminId :: UserId) -> + let appUser = mkStoredUser appId (Name "App") Nothing (Just tid) + adminNoEmail = mkStoredUser adminId (Name "Admin") Nothing (Just tid) + storedApp = mkStoredApp appId tid creatorId + teams = Map.singleton tid [mkOwnerMember adminId] + result = runAppEffects [appUser, adminNoEmail] [storedApp] teams $ deleteApp tid appId + in case result of + Left err -> counterexample (show err) False + Right ((), sentEmails) -> sentEmails === mempty + + prop "sends to all admins in the team" $ + \(tid :: TeamId) (appId :: UserId) (creatorId :: UserId) (admin1Id :: UserId) (admin1Email :: EmailAddress) (admin2Id :: UserId) (admin2Email :: EmailAddress) -> + admin1Id /= admin2Id && admin1Email /= admin2Email ==> + let appUser = mkStoredUser appId (Name "App") Nothing (Just tid) + admin1 = mkStoredUser admin1Id (Name "Admin1") (Just admin1Email) (Just tid) + admin2 = mkStoredUser admin2Id (Name "Admin2") (Just admin2Email) (Just tid) + storedApp = mkStoredApp appId tid creatorId + teams = Map.singleton tid [mkOwnerMember admin1Id, mkOwnerMember admin2Id] + result = runAppEffects [appUser, admin1, admin2] [storedApp] teams $ deleteApp tid appId + in case result of + Left err -> counterexample (show err) False + Right ((), sentEmails) -> + counterexample (show sentEmails) $ + Map.size sentEmails === 2 + + describe "updateApp" $ do + prop "sends an email to each team admin that has an email address" $ + \(tid :: TeamId) (appId :: UserId) (actorId :: UserId) (adminId :: UserId) (adminEmail :: EmailAddress) (newName :: Name) -> + appId /= actorId && actorId /= adminId ==> + let lusr = toLocalUnsafe testDomain actorId + actor = mkStoredUser actorId (Name "Actor") Nothing (Just tid) + appUser = mkStoredUser appId (Name "App") Nothing (Just tid) + admin = mkStoredUser adminId (Name "Admin") (Just adminEmail) (Just tid) + storedApp = mkStoredApp appId tid actorId + teams = Map.singleton tid [mkOwnerMember actorId, mkOwnerMember adminId] + upd = PutApp {name = Just newName, assets = Nothing, accentId = Nothing, category = Nothing, description = Nothing} + result = runAppEffects [actor, appUser, admin] [storedApp] teams $ updateApp lusr tid appId upd + in case result of + Left err -> counterexample (show err) False + Right ((), sentEmails) -> + counterexample (show sentEmails) $ + Map.member adminEmail sentEmails === True + + prop "skips admins without an email address" $ + \(tid :: TeamId) (appId :: UserId) (actorId :: UserId) (adminId :: UserId) (newName :: Name) -> + appId /= actorId && actorId /= adminId ==> + let lusr = toLocalUnsafe testDomain actorId + actor = mkStoredUser actorId (Name "Actor") Nothing (Just tid) + appUser = mkStoredUser appId (Name "App") Nothing (Just tid) + adminNoEmail = mkStoredUser adminId (Name "Admin") Nothing (Just tid) + storedApp = mkStoredApp appId tid actorId + teams = Map.singleton tid [mkOwnerMember actorId, mkOwnerMember adminId] + upd = PutApp {name = Just newName, assets = Nothing, accentId = Nothing, category = Nothing, description = Nothing} + result = runAppEffects [actor, appUser, adminNoEmail] [storedApp] teams $ updateApp lusr tid appId upd + in case result of + Left err -> counterexample (show err) False + Right ((), sentEmails) -> sentEmails === mempty diff --git a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/AppStore.hs b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/AppStore.hs index cfad2f156f..c4c99afe84 100644 --- a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/AppStore.hs +++ b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/AppStore.hs @@ -23,6 +23,7 @@ import Imports import Polysemy import Polysemy.State import Wire.AppStore +import Wire.AppStore qualified as Store inMemoryAppStoreInterpreter :: forall r. @@ -32,5 +33,9 @@ inMemoryAppStoreInterpreter = interpret $ \case CreateApp app -> modify (app :) GetApp uid tid -> gets $ find $ \app -> app.id == uid && app.teamId == tid GetApps tid -> gets $ filter $ \app -> app.teamId == tid - UpdateApp _owner _app _upd -> error $ "inMemoryAppStoreInterpreter: UpdateApp" + UpdateApp _teamId appId _upd -> + gets $ \apps -> + if any (\a -> a.id == appId) apps + then Right () + else Left Store.NotFound DeleteApp uid tid -> modify $ filter $ \app -> not (app.id == uid && app.teamId == tid) diff --git a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/EmailSubsystem.hs b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/EmailSubsystem.hs index 305bebed55..848b60b674 100644 --- a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/EmailSubsystem.hs +++ b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/EmailSubsystem.hs @@ -17,6 +17,7 @@ module Wire.MockInterpreters.EmailSubsystem where +import Data.Id import Data.Map qualified as Map import Imports import Polysemy @@ -30,12 +31,22 @@ data SentMail = SentMail } deriving (Show, Eq) -data SentMailContent = PasswordResetMail PasswordResetPair +data SentMailContent + = PasswordResetMail PasswordResetPair + | AppEventMail + { aeAction :: Text, + aeAppName :: Text, + aeAppId :: UserId, + aeTeamId :: TeamId, + aeActorId :: UserId + } deriving (Show, Eq) inMemoryEmailSubsystemInterpreter :: (Member (State (Map EmailAddress [SentMail])) r) => InterpreterFor EmailSubsystem r inMemoryEmailSubsystemInterpreter = interpret \case SendPasswordResetMail email keyCodePair mLocale -> modify $ Map.insertWith (<>) email [SentMail mLocale $ PasswordResetMail keyCodePair] + SendAppEventEmail email _name action appName appId tid actorId mLocale -> + modify $ Map.insertWith (<>) email [SentMail mLocale $ AppEventMail action appName appId tid actorId] _ -> error "inMemoryEmailSubsystemInterpreter: implement on demand" getEmailsSentTo :: (Member (State (Map EmailAddress [SentMail])) r) => EmailAddress -> Sem r [SentMail] @@ -58,3 +69,4 @@ noopEmailSubsystemInterpreter = interpret \case SendMemberWelcomeEmail {} -> pure () SendNewTeamOwnerWelcomeEmail {} -> pure () SendSAMLIdPChanged {} -> pure () + SendAppEventEmail {} -> pure () diff --git a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/UserSubsystem.hs b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/UserSubsystem.hs index c5feaeae03..7d9509131d 100644 --- a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/UserSubsystem.hs +++ b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/UserSubsystem.hs @@ -86,7 +86,7 @@ inMemoryUserSubsystemInterpreter = BlockListInsert _ -> error "BlockListInsert: implement on demand (userSubsystemInterpreter)" UpdateTeamSearchVisibilityInbound _ -> error "UpdateTeamSearchVisibilityInbound: implement on demand (userSubsystemInterpreter)" AcceptTeamInvitation {} -> error "AcceptTeamInvitation: implement on demand (userSubsystemInterpreter)" - InternalUpdateSearchIndex _ -> error "InternalUpdateSearchIndex: implement on demand (userSubsystemInterpreter)" + InternalUpdateSearchIndex _ -> pure () -- error "InternalUpdateSearchIndex: implement on demand (userSubsystemInterpreter)" InternalFindTeamInvitation {} -> error "InternalFindTeamInvitation: implement on demand (userSubsystemInterpreter)" GetUserExportData _ -> error "GetUserExportData: implement on demand (userSubsystemInterpreter)" RemoveEmailEither _ -> error "RemoveEmailEither: implement on demand (userSubsystemInterpreter)" diff --git a/libs/wire-subsystems/wire-subsystems.cabal b/libs/wire-subsystems/wire-subsystems.cabal index 680a8e7151..6ecea75a7b 100644 --- a/libs/wire-subsystems/wire-subsystems.cabal +++ b/libs/wire-subsystems/wire-subsystems.cabal @@ -579,6 +579,7 @@ test-suite wire-subsystems-tests other-modules: Spec Wire.ActivationCodeStore.InterpreterSpec + Wire.AppSubsystem.InterpreterSpec Wire.AuthenticationSubsystem.InterpreterSpec Wire.BrigAPIAccess.RpcSpec Wire.ClientSubsystem.InterpreterSpec From e1bb849a5d04870639009732201a7951e127cf62 Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Thu, 9 Jul 2026 12:33:24 +0200 Subject: [PATCH 3/8] ... --- .../src/Wire/AppSubsystem/Interpreter.hs | 110 +++++++++++++++--- .../src/Wire/EmailSubsystem.hs | 60 ++++++++-- .../src/Wire/EmailSubsystem/Interpreter.hs | 46 +++++--- .../unit/Wire/AppSubsystem/InterpreterSpec.hs | 47 ++++---- .../Wire/MockInterpreters/EmailSubsystem.hs | 10 +- 5 files changed, 203 insertions(+), 70 deletions(-) diff --git a/libs/wire-subsystems/src/Wire/AppSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/AppSubsystem/Interpreter.hs index bd66d2d262..7f21f72783 100644 --- a/libs/wire-subsystems/src/Wire/AppSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/AppSubsystem/Interpreter.hs @@ -40,6 +40,7 @@ import Wire.API.Team.Member qualified as T import Wire.API.Team.Role qualified as R import Wire.API.User import Wire.API.User.Auth +import Wire.API.User.EmailAddress (emailAddressText) import Wire.API.UserEvent hiding (UserLegalHoldDisabled) import Wire.AppStore (AppStore, StoredApp (..)) import Wire.AppStore qualified as Store @@ -47,7 +48,7 @@ import Wire.AppSubsystem import Wire.AuthenticationSubsystem import Wire.AuthenticationSubsystem.Cookie (revokeAllCookies) import Wire.AuthenticationSubsystem.ZAuth -import Wire.EmailSubsystem (EmailSubsystem) +import Wire.EmailSubsystem (AppEvent (..), EmailSubsystem) import Wire.EmailSubsystem qualified as Email import Wire.Events import Wire.GalleyAPIAccess @@ -139,7 +140,14 @@ createAppImpl lusr tid newApp = do -- generate a team event generateTeamEvents creator.id tid [EdMemberJoin u.id] - notifyAdmins tid (tUnqualified lusr) "created" (fromName newApp.name) u.id + appCreatedAt <- get + notifyAdmins tid u.id $ + NewAppCreated + { actorName = creator.name, + actorEmail = creator.email, + appName = fromName newApp.name, + appCreatedAt = appCreatedAt + } c :: Cookie (Token U) <- newCookie u.id Nothing PersistentCookie Nothing RevokeSameLabel pure @@ -206,6 +214,7 @@ updateAppImpl :: Member (Error AppSubsystemError) r, Member Events r, Member GalleyAPIAccess r, + Member Now r, Member TeamSubsystem r, Member UserStore r, Member UserSubsystem r, @@ -217,8 +226,9 @@ updateAppImpl :: PutApp -> Sem r () updateAppImpl lusr tid appid upd = do - (_updater, umem) <- ensureTeamMember lusr tid + (updater, umem) <- ensureTeamMember lusr tid note AppSubsystemErrorNoPerm $ guard (T.hasPermission umem T.CreateApp) + oldApp <- Store.getUser appid >>= note AppSubsystemErrorNoApp Store.updateApp tid appid (Store.MkStoredAppUpdate {category = upd.category, description = upd.description}) >>= \case Right () -> pure () Left Store.NotFound -> throw AppSubsystemErrorNoApp @@ -231,18 +241,29 @@ updateAppImpl lusr tid appid upd = do eupAccentId = upd.accentId, eupAssets = upd.assets } - appName <- - fromName <$> case upd.name of - Just n -> pure n - Nothing -> (.name) <$> (Store.getUser appid >>= note AppSubsystemErrorNoApp) - notifyAdmins tid (tUnqualified lusr) "updated" appName appid + let oldAppName = fromName oldApp.name + newAppName = maybe oldAppName fromName upd.name + changedAt <- get + notifyAdmins tid appid $ + DetailsChangedForApp + { actorName = updater.name, + actorEmail = updater.email, + newAppName = newAppName, + newAppCreatedAt = changedAt, + oldAppName = oldAppName, + oldAppCreatedAt = changedAt + } refreshAppCookieImpl :: ( Member AuthenticationSubsystem r, Member AppStore r, Member (Error RetryAfter) r, Member (Error AppSubsystemError) r, - Member GalleyAPIAccess r + Member GalleyAPIAccess r, + Member TeamSubsystem r, + Member UserStore r, + Member EmailSubsystem r, + Member Now r ) => Local UserId -> TeamId -> @@ -261,6 +282,18 @@ refreshAppCookieImpl (tUnqualified -> uid) tid appId mbPassword = do c :: Cookie (Token U) <- newCookieLimited appId Nothing PersistentCookie Nothing RevokeSameLabel >>= either throw pure + + appName <- maybe "" (fromName . (.name)) <$> Store.getUser appId + (actorName, actorEmail) <- appEventActor uid + updatedAt <- get + notifyAdmins tid appId $ + AppTokenUpdated + { actorName = actorName, + actorEmail = actorEmail, + newAppName = appName, + newAppCreatedAt = updatedAt + } + pure $ mkSomeToken c.cookieValue appNewStoredUser :: @@ -301,8 +334,7 @@ appNewStoredUser creator new = do defAppSupportedProtocols :: Set BaseProtocolTag defAppSupportedProtocols = Set.singleton BaseProtocolMLSTag --- | Send an app-event email to every team admin/owner. --- 'action' should be "created", "updated", or "deleted". +-- | Send the notification email for an 'AppEvent' to every team admin/owner. -- Admins without an email address are silently skipped. notifyAdmins :: ( Member TeamSubsystem r, @@ -311,23 +343,57 @@ notifyAdmins :: ) => TeamId -> UserId -> - Text -> - Text -> - UserId -> + AppEvent -> Sem r () -notifyAdmins tid actorId action appName appId = do +notifyAdmins tid appId event = do admins <- internalGetTeamAdmins tid let adminUids = admins ^.. T.teamMembers . traverse . T.userId adminUsers <- Store.getUsers adminUids forM_ adminUsers $ \u -> for_ u.email $ \email -> - Email.sendAppEventEmail email u.name action appName appId tid actorId u.locale + Email.sendAppEventEmail email u.name tid appId event u.locale + +-- | Best-effort actor identity for an 'AppEvent'. +appEventActor :: (Member UserStore r) => UserId -> Sem r (Maybe Name, Maybe EmailAddress) +appEventActor actorId = do + mu <- Store.getUser actorId + pure (mu >>= (.name), mu >>= (.email)) + +unknownActorEmail :: EmailAddress +unknownActorEmail = + fromMaybe (error "unknownActorEmail: invalid literal") (emailAddressText "unknown@wire.com") + +-- | TODO: no operation toggles app availability yet. This helper wires the +-- 'AppAvailabilityChanged' event end-to-end; call it from the availability +-- toggle once that operation exists. +notifyAppAvailabilityChanged :: + ( Member TeamSubsystem r, + Member UserStore r, + Member EmailSubsystem r, + Member Now r + ) => + TeamId -> + UserId -> + UserId -> + Sem r () +notifyAppAvailabilityChanged tid appId actorId = do + appName <- maybe "" (fromName . (.name)) <$> Store.getUser appId + (actorName, actorEmail) <- appEventActor actorId + changedAt <- get + notifyAdmins tid appId $ + AppAvailabilityChanged + { actorName = actorName, + actorEmail = actorEmail, + newAppName = appName, + newAppCreatedAt = changedAt + } deleteAppImpl :: ( Member AppStore r, Member UserStore r, Member TeamSubsystem r, - Member EmailSubsystem r + Member EmailSubsystem r, + Member Now r ) => TeamId -> UserId -> @@ -336,5 +402,13 @@ deleteAppImpl teamId appId = do appName <- maybe "" (fromName . (.name)) <$> Store.getUser appId mbStoredApp <- Store.getApp appId teamId let actorId = maybe appId (.creator) mbStoredApp + (actorName, actorEmail) <- appEventActor actorId Store.deleteApp appId teamId - notifyAdmins teamId actorId "deleted" appName appId + deletedAt <- get + notifyAdmins teamId appId $ + AppDeleted + { actorName = actorName, + actorEmail = actorEmail, + newAppName = appName, + newAppCreatedAt = deletedAt + } diff --git a/libs/wire-subsystems/src/Wire/EmailSubsystem.hs b/libs/wire-subsystems/src/Wire/EmailSubsystem.hs index 55f55629fe..52acef523f 100644 --- a/libs/wire-subsystems/src/Wire/EmailSubsystem.hs +++ b/libs/wire-subsystems/src/Wire/EmailSubsystem.hs @@ -1,4 +1,5 @@ {-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -Wno-partial-fields #-} -- This file is part of the Wire Server implementation. -- @@ -21,6 +22,7 @@ module Wire.EmailSubsystem where import Data.Code qualified as Code import Data.Id +import Data.Time.Clock (UTCTime) import Data.X509.Extended (CertDescription) import Imports import Polysemy @@ -31,6 +33,46 @@ import Wire.API.User import Wire.API.User.Activation (ActivationCode, ActivationKey) import Wire.API.User.Client (Client (..)) +-- | A typed description of something that happened to an app in a team. Each +-- constructor corresponds to a distinct admin-notification email (and template). +-- +-- See https://www.figma.com/design/AMNqFhTUElOZDJfbUYnMmJ/Apps--Services----Integrations?node-id=431-2452 +data AppEvent + = NewAppCreated + { actorName :: Name, + actorEmail :: Maybe EmailAddress, + appName :: Text, + appCreatedAt :: UTCTime + {- TODO: appPermissions :: AppPermissions -} + } + | DetailsChangedForApp + { actorName :: Name, + actorEmail :: Maybe EmailAddress, + newAppName :: Text, + newAppCreatedAt :: UTCTime, + oldAppName :: Text, + oldAppCreatedAt :: UTCTime + } + | AppTokenUpdated + { actorName :: Name, + actorEmail :: Maybe EmailAddress, + newAppName :: Text, + newAppCreatedAt :: UTCTime + } + | AppDeleted + { actorName :: Name, + actorEmail :: Maybe EmailAddress, + newAppName :: Text, + newAppCreatedAt :: UTCTime + } + | AppAvailabilityChanged + { actorName :: Name, + actorEmail :: Maybe EmailAddress, + newAppName :: Text, + newAppCreatedAt :: UTCTime + } + deriving (Eq, Show) + data EmailSubsystem m a where SendPasswordResetMail :: EmailAddress -> PasswordResetPair -> Maybe Locale -> EmailSubsystem m () SendVerificationMail :: EmailAddress -> ActivationKey -> ActivationCode -> Maybe Locale -> EmailSubsystem m () @@ -62,21 +104,17 @@ data EmailSubsystem m a where Maybe Locale -> EmailSubsystem m () SendAppEventEmail :: - -- | sender email + -- | recipient email EmailAddress -> - -- | sender name + -- | recipient name Name -> - -- | action (one of ["created", "updated", "deleted"]) - Text -> - -- | appName - Text -> - -- | appId - UserId -> - -- | tid + -- | team the app belongs to TeamId -> - -- | actorId + -- | app id UserId -> - -- | mLocale + -- | the event that occurred + AppEvent -> + -- | recipient locale Maybe Locale -> EmailSubsystem m () diff --git a/libs/wire-subsystems/src/Wire/EmailSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/EmailSubsystem/Interpreter.hs index d8514fa278..84895df7e1 100644 --- a/libs/wire-subsystems/src/Wire/EmailSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/EmailSubsystem/Interpreter.hs @@ -76,8 +76,8 @@ emailSubsystemInterpreter userTpls teamTpls branding = interpret \case SendNewTeamOwnerWelcomeEmail email tid teamName loc name -> sendNewTeamOwnerWelcomeEmailImpl teamTpls branding email tid teamName loc name 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 - SendAppEventEmail email name action appName appId tid actorId mLocale -> - sendAppEventEmailImpl teamTpls branding email name action appName appId tid actorId mLocale + SendAppEventEmail email name tid appId event mLocale -> + sendAppEventEmailImpl teamTpls branding email name tid appId event mLocale ------------------------------------------------------------------------------- -- Verification Email for @@ -703,44 +703,62 @@ renderIdPConfigChangeEmail email IdPConfigChangeEmailTemplate {..} branding adde ------------------------------------------------------------------------------- -- App Event Email +-- https://www.figma.com/design/AMNqFhTUElOZDJfbUYnMmJ/Apps--Services----Integrations?node-id=431-2452&p=f&t=PVFSkjqPlWKxbHUw-0 + +-- | The action label substituted into the (currently single, mocked) app-event +-- template. This is where the per-'AppEvent' template selection happens; once +-- real per-event templates exist, dispatch on the constructor here instead. +appEventAction :: AppEvent -> Text +appEventAction = \case + NewAppCreated {} -> "created" + DetailsChangedForApp {} -> "details_changed" + AppTokenUpdated {} -> "token_updated" + AppDeleted {} -> "deleted" + AppAvailabilityChanged {} -> "availability_changed" + +appEventAppName :: AppEvent -> Text +appEventAppName = \case + NewAppCreated {appName = n} -> n + DetailsChangedForApp {newAppName = n} -> n + AppTokenUpdated {newAppName = n} -> n + AppDeleted {newAppName = n} -> n + AppAvailabilityChanged {newAppName = n} -> n + sendAppEventEmailImpl :: (Member EmailSending r, Member TinyLog r) => Localised TeamTemplates -> Map Text Text -> EmailAddress -> Name -> - Text -> - Text -> - UserId -> TeamId -> UserId -> + AppEvent -> Maybe Locale -> Sem r () -sendAppEventEmailImpl teamTemplates branding email name action appName appId tid actorId mLocale = do +sendAppEventEmailImpl teamTemplates branding email name tid appId event mLocale = do let tpl = appEventEmail . snd $ forLocale mLocale teamTemplates - mail <- logEmailRenderErrors "app event email" $ renderAppEventEmail email name action appName appId tid actorId tpl branding + mail <- logEmailRenderErrors "app event email" $ renderAppEventEmail email name tid appId event tpl branding sendMail mail renderAppEventEmail :: (Member (Output Text) r) => EmailAddress -> Name -> - Text -> - Text -> - UserId -> TeamId -> UserId -> + AppEvent -> AppEventEmailTemplate -> Map Text Text -> Sem r Mail -renderAppEventEmail email name action appName appId tid actorId AppEventEmailTemplate {..} branding = do +renderAppEventEmail email name tid appId event AppEventEmailTemplate {..} branding = do let replace = branding - & Map.insert "action" action - & Map.insert "app_name" appName + & Map.insert "action" (appEventAction event) + & Map.insert "app_name" (appEventAppName event) & Map.insert "app_id" (idToText appId) & Map.insert "team_id" (idToText tid) - & Map.insert "actor_id" (idToText actorId) + & Map.insert "actor_name" (fromName event.actorName) + & maybe id (Map.insert "actor_email" . fromEmail) event.actorEmail txt <- renderTextWithBrandingSem appEventEmailBodyText replace html <- renderHtmlWithBrandingSem appEventEmailBodyHtml replace subj <- renderTextWithBrandingSem appEventEmailSubject replace diff --git a/libs/wire-subsystems/test/unit/Wire/AppSubsystem/InterpreterSpec.hs b/libs/wire-subsystems/test/unit/Wire/AppSubsystem/InterpreterSpec.hs index 821584fe68..b42609f54b 100644 --- a/libs/wire-subsystems/test/unit/Wire/AppSubsystem/InterpreterSpec.hs +++ b/libs/wire-subsystems/test/unit/Wire/AppSubsystem/InterpreterSpec.hs @@ -195,27 +195,32 @@ spec :: Spec spec = focus . describe "AppSubsystem" $ do describe "deleteApp" $ do prop "sends an email to each team admin that has an email address" $ - \(tid :: TeamId) (appId :: UserId) (creatorId :: UserId) (adminId :: UserId) (adminEmail :: EmailAddress) (appName :: Name) -> - let appUser = mkStoredUser appId appName Nothing (Just tid) - admin = mkStoredUser adminId (Name "Admin") (Just adminEmail) (Just tid) - storedApp = mkStoredApp appId tid creatorId - teams = Map.singleton tid [mkOwnerMember adminId] - result = runAppEffects [appUser, admin] [storedApp] teams $ deleteApp tid appId - in case result of - Left err -> counterexample (show err) False - Right ((), sentEmails) -> - Map.lookup adminEmail sentEmails - === Just - [ SentMail - Nothing - AppEventMail - { aeAction = "deleted", - aeAppName = fromName appName, - aeAppId = appId, - aeTeamId = tid, - aeActorId = creatorId - } - ] + \(tid :: TeamId) (appId :: UserId) (creatorId :: UserId) (creatorEmail :: EmailAddress) (adminId :: UserId) (adminEmail :: EmailAddress) (appName :: Name) -> + appId /= creatorId && creatorId /= adminId && appId /= adminId ==> + let appUser = mkStoredUser appId appName Nothing (Just tid) + creator = mkStoredUser creatorId (Name "Creator") (Just creatorEmail) (Just tid) + admin = mkStoredUser adminId (Name "Admin") (Just adminEmail) (Just tid) + storedApp = mkStoredApp appId tid creatorId + teams = Map.singleton tid [mkOwnerMember adminId] + result = runAppEffects [appUser, creator, admin] [storedApp] teams $ deleteApp tid appId + in case result of + Left err -> counterexample (show err) False + Right ((), sentEmails) -> + Map.lookup adminEmail sentEmails + === Just + [ SentMail + Nothing + ( AppEventMail + tid + appId + AppDeleted + { actorName = Name "Creator", + actorEmail = creatorEmail, + newAppName = fromName appName, + newAppCreatedAt = defaultTime + } + ) + ] prop "skips admins without an email address" $ \(tid :: TeamId) (appId :: UserId) (creatorId :: UserId) (adminId :: UserId) -> diff --git a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/EmailSubsystem.hs b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/EmailSubsystem.hs index 848b60b674..c3ad91ef3d 100644 --- a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/EmailSubsystem.hs +++ b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/EmailSubsystem.hs @@ -34,19 +34,17 @@ data SentMail = SentMail data SentMailContent = PasswordResetMail PasswordResetPair | AppEventMail - { aeAction :: Text, - aeAppName :: Text, + { aeTeamId :: TeamId, aeAppId :: UserId, - aeTeamId :: TeamId, - aeActorId :: UserId + aeEvent :: AppEvent } deriving (Show, Eq) inMemoryEmailSubsystemInterpreter :: (Member (State (Map EmailAddress [SentMail])) r) => InterpreterFor EmailSubsystem r inMemoryEmailSubsystemInterpreter = interpret \case SendPasswordResetMail email keyCodePair mLocale -> modify $ Map.insertWith (<>) email [SentMail mLocale $ PasswordResetMail keyCodePair] - SendAppEventEmail email _name action appName appId tid actorId mLocale -> - modify $ Map.insertWith (<>) email [SentMail mLocale $ AppEventMail action appName appId tid actorId] + SendAppEventEmail email _name tid appId event mLocale -> + modify $ Map.insertWith (<>) email [SentMail mLocale $ AppEventMail tid appId event] _ -> error "inMemoryEmailSubsystemInterpreter: implement on demand" getEmailsSentTo :: (Member (State (Map EmailAddress [SentMail])) r) => EmailAddress -> Sem r [SentMail] From 23c8f7598b202c65b7b02e229d92d257a0d82e87 Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Thu, 9 Jul 2026 12:56:13 +0200 Subject: [PATCH 4/8] ... --- .../src/Wire/AppSubsystem/Interpreter.hs | 24 +++++++++---------- 1 file changed, 12 insertions(+), 12 deletions(-) diff --git a/libs/wire-subsystems/src/Wire/AppSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/AppSubsystem/Interpreter.hs index 7f21f72783..57a5c6b93f 100644 --- a/libs/wire-subsystems/src/Wire/AppSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/AppSubsystem/Interpreter.hs @@ -143,10 +143,10 @@ createAppImpl lusr tid newApp = do appCreatedAt <- get notifyAdmins tid u.id $ NewAppCreated - { actorName = creator.name, + { actorName = Just creator.name, actorEmail = creator.email, - appName = fromName newApp.name, - appCreatedAt = appCreatedAt + newAppName = Just newApp.name, + newAppCreatedAt = appCreatedAt } c :: Cookie (Token U) <- newCookie u.id Nothing PersistentCookie Nothing RevokeSameLabel @@ -241,16 +241,16 @@ updateAppImpl lusr tid appid upd = do eupAccentId = upd.accentId, eupAssets = upd.assets } - let oldAppName = fromName oldApp.name - newAppName = maybe oldAppName fromName upd.name + let oldAppName = oldApp.name + newAppName = fromMaybe oldAppName upd.name changedAt <- get notifyAdmins tid appid $ DetailsChangedForApp - { actorName = updater.name, + { actorName = Just updater.name, actorEmail = updater.email, - newAppName = newAppName, + newAppName = Just newAppName, newAppCreatedAt = changedAt, - oldAppName = oldAppName, + oldAppName = Just oldAppName, oldAppCreatedAt = changedAt } @@ -283,7 +283,7 @@ refreshAppCookieImpl (tUnqualified -> uid) tid appId mbPassword = do newCookieLimited appId Nothing PersistentCookie Nothing RevokeSameLabel >>= either throw pure - appName <- maybe "" (fromName . (.name)) <$> Store.getUser appId + appName <- (.name) <$$> Store.getUser appId (actorName, actorEmail) <- appEventActor uid updatedAt <- get notifyAdmins tid appId $ @@ -357,7 +357,7 @@ notifyAdmins tid appId event = do appEventActor :: (Member UserStore r) => UserId -> Sem r (Maybe Name, Maybe EmailAddress) appEventActor actorId = do mu <- Store.getUser actorId - pure (mu >>= (.name), mu >>= (.email)) + pure ((.name) <$> mu, (.email) =<< mu) unknownActorEmail :: EmailAddress unknownActorEmail = @@ -377,7 +377,7 @@ notifyAppAvailabilityChanged :: UserId -> Sem r () notifyAppAvailabilityChanged tid appId actorId = do - appName <- maybe "" (fromName . (.name)) <$> Store.getUser appId + appName <- (.name) <$$> Store.getUser appId (actorName, actorEmail) <- appEventActor actorId changedAt <- get notifyAdmins tid appId $ @@ -399,7 +399,7 @@ deleteAppImpl :: UserId -> Sem r () deleteAppImpl teamId appId = do - appName <- maybe "" (fromName . (.name)) <$> Store.getUser appId + appName <- (.name) <$$> Store.getUser appId mbStoredApp <- Store.getApp appId teamId let actorId = maybe appId (.creator) mbStoredApp (actorName, actorEmail) <- appEventActor actorId From 3c2b1e2445c6420a0d9428a55cf4ec8556f6b9fa Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Thu, 9 Jul 2026 12:56:47 +0200 Subject: [PATCH 5/8] ... --- .../src/Wire/EmailSubsystem.hs | 24 +++++++++---------- .../src/Wire/EmailSubsystem/Interpreter.hs | 14 +++-------- .../unit/Wire/AppSubsystem/InterpreterSpec.hs | 17 ++++--------- .../Wire/MockInterpreters/EmailSubsystem.hs | 2 ++ 4 files changed, 21 insertions(+), 36 deletions(-) diff --git a/libs/wire-subsystems/src/Wire/EmailSubsystem.hs b/libs/wire-subsystems/src/Wire/EmailSubsystem.hs index 52acef523f..88910d9681 100644 --- a/libs/wire-subsystems/src/Wire/EmailSubsystem.hs +++ b/libs/wire-subsystems/src/Wire/EmailSubsystem.hs @@ -39,36 +39,36 @@ import Wire.API.User.Client (Client (..)) -- See https://www.figma.com/design/AMNqFhTUElOZDJfbUYnMmJ/Apps--Services----Integrations?node-id=431-2452 data AppEvent = NewAppCreated - { actorName :: Name, + { actorName :: Maybe Name, actorEmail :: Maybe EmailAddress, - appName :: Text, - appCreatedAt :: UTCTime + newAppName :: Maybe Name, + newAppCreatedAt :: UTCTime {- TODO: appPermissions :: AppPermissions -} } | DetailsChangedForApp - { actorName :: Name, + { actorName :: Maybe Name, actorEmail :: Maybe EmailAddress, - newAppName :: Text, + newAppName :: Maybe Name, newAppCreatedAt :: UTCTime, - oldAppName :: Text, + oldAppName :: Maybe Name, oldAppCreatedAt :: UTCTime } | AppTokenUpdated - { actorName :: Name, + { actorName :: Maybe Name, actorEmail :: Maybe EmailAddress, - newAppName :: Text, + newAppName :: Maybe Name, newAppCreatedAt :: UTCTime } | AppDeleted - { actorName :: Name, + { actorName :: Maybe Name, actorEmail :: Maybe EmailAddress, - newAppName :: Text, + newAppName :: Maybe Name, newAppCreatedAt :: UTCTime } | AppAvailabilityChanged - { actorName :: Name, + { actorName :: Maybe Name, actorEmail :: Maybe EmailAddress, - newAppName :: Text, + newAppName :: Maybe Name, newAppCreatedAt :: UTCTime } deriving (Eq, Show) diff --git a/libs/wire-subsystems/src/Wire/EmailSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/EmailSubsystem/Interpreter.hs index 84895df7e1..bb8c1a62ae 100644 --- a/libs/wire-subsystems/src/Wire/EmailSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/EmailSubsystem/Interpreter.hs @@ -716,14 +716,6 @@ appEventAction = \case AppDeleted {} -> "deleted" AppAvailabilityChanged {} -> "availability_changed" -appEventAppName :: AppEvent -> Text -appEventAppName = \case - NewAppCreated {appName = n} -> n - DetailsChangedForApp {newAppName = n} -> n - AppTokenUpdated {newAppName = n} -> n - AppDeleted {newAppName = n} -> n - AppAvailabilityChanged {newAppName = n} -> n - sendAppEventEmailImpl :: (Member EmailSending r, Member TinyLog r) => Localised TeamTemplates -> @@ -754,11 +746,11 @@ renderAppEventEmail email name tid appId event AppEventEmailTemplate {..} brandi let replace = branding & Map.insert "action" (appEventAction event) - & Map.insert "app_name" (appEventAppName event) + & Map.insert "app_name" (maybe "-/-" fromName event.newAppName) & Map.insert "app_id" (idToText appId) & Map.insert "team_id" (idToText tid) - & Map.insert "actor_name" (fromName event.actorName) - & maybe id (Map.insert "actor_email" . fromEmail) event.actorEmail + & Map.insert "actor_name" (maybe "-/-" fromName event.actorName) + & Map.insert "actor_email" (maybe "-/-" fromEmail event.actorEmail) txt <- renderTextWithBrandingSem appEventEmailBodyText replace html <- renderHtmlWithBrandingSem appEventEmailBodyHtml replace subj <- renderTextWithBrandingSem appEventEmailSubject replace diff --git a/libs/wire-subsystems/test/unit/Wire/AppSubsystem/InterpreterSpec.hs b/libs/wire-subsystems/test/unit/Wire/AppSubsystem/InterpreterSpec.hs index b42609f54b..67952126aa 100644 --- a/libs/wire-subsystems/test/unit/Wire/AppSubsystem/InterpreterSpec.hs +++ b/libs/wire-subsystems/test/unit/Wire/AppSubsystem/InterpreterSpec.hs @@ -120,7 +120,7 @@ runAppEffects :: Either AppSubsystemError (a, Map EmailAddress [SentMail]) runAppEffects initialUsers initialApps teams action = run - . ( runAppSubsystem stubUserSubsystem stubAuthSubsystem + . ( runAppSubsystem inMemoryUserSubsystemInterpreter stubAuthSubsystem .< interpretTeamSubsystemToGalleyAPI .< miniGalleyAPIAccess teams def .< runInMemoryUserStoreInterpreter initialUsers mempty @@ -137,15 +137,6 @@ runAppEffects initialUsers initialApps teams action = stubAuthSubsystem = interpret $ \case _ -> error "AuthenticationSubsystem: unexpected call in AppSubsystem unit test" - stubUserSubsystem :: forall r. (Member UserStore r, Member UserKeyStore r) => InterpreterFor UserSubsystem (AuthenticationSubsystem ': r) - stubUserSubsystem = - -- :: (Member UserStore r, Member UserKeyStore r) => InterpreterFor UserSubsystem r - inMemoryUserSubsystemInterpreter - - stubUserSubsystem' :: forall r. InterpreterFor UserSubsystem (AuthenticationSubsystem ': r) - stubUserSubsystem' = interpret $ \case - _ -> error "UserSubsystem: unexpected call in AppSubsystem unit test" -- ?? - -- | Minimal StoredUser with only the fields we care about set. mkStoredUser :: UserId -> Name -> Maybe EmailAddress -> Maybe TeamId -> StoredUser mkStoredUser uid uname email tid = @@ -214,9 +205,9 @@ spec = focus . describe "AppSubsystem" $ do tid appId AppDeleted - { actorName = Name "Creator", - actorEmail = creatorEmail, - newAppName = fromName appName, + { actorName = Just (Name "Creator"), + actorEmail = Just creatorEmail, + newAppName = Just appName, newAppCreatedAt = defaultTime } ) diff --git a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/EmailSubsystem.hs b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/EmailSubsystem.hs index c3ad91ef3d..409ee16bbb 100644 --- a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/EmailSubsystem.hs +++ b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/EmailSubsystem.hs @@ -1,3 +1,5 @@ +{-# OPTIONS_GHC -Wno-partial-fields #-} + -- This file is part of the Wire Server implementation. -- -- Copyright (C) 2025 Wire Swiss GmbH From 87f457551521cc1c5935f6cb9ef8d527fad34dff Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Thu, 9 Jul 2026 13:08:27 +0200 Subject: [PATCH 6/8] ... --- .../src/Wire/AppSubsystem/Interpreter.hs | 19 ++++++------------- .../src/Wire/EmailSubsystem.hs | 13 ++++++------- .../unit/Wire/AppSubsystem/InterpreterSpec.hs | 2 +- 3 files changed, 13 insertions(+), 21 deletions(-) diff --git a/libs/wire-subsystems/src/Wire/AppSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/AppSubsystem/Interpreter.hs index 57a5c6b93f..ee718d332e 100644 --- a/libs/wire-subsystems/src/Wire/AppSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/AppSubsystem/Interpreter.hs @@ -40,7 +40,6 @@ import Wire.API.Team.Member qualified as T import Wire.API.Team.Role qualified as R import Wire.API.User import Wire.API.User.Auth -import Wire.API.User.EmailAddress (emailAddressText) import Wire.API.UserEvent hiding (UserLegalHoldDisabled) import Wire.AppStore (AppStore, StoredApp (..)) import Wire.AppStore qualified as Store @@ -146,7 +145,7 @@ createAppImpl lusr tid newApp = do { actorName = Just creator.name, actorEmail = creator.email, newAppName = Just newApp.name, - newAppCreatedAt = appCreatedAt + appCreatedAt = appCreatedAt } c :: Cookie (Token U) <- newCookie u.id Nothing PersistentCookie Nothing RevokeSameLabel @@ -214,7 +213,6 @@ updateAppImpl :: Member (Error AppSubsystemError) r, Member Events r, Member GalleyAPIAccess r, - Member Now r, Member TeamSubsystem r, Member UserStore r, Member UserSubsystem r, @@ -243,15 +241,13 @@ updateAppImpl lusr tid appid upd = do } let oldAppName = oldApp.name newAppName = fromMaybe oldAppName upd.name - changedAt <- get notifyAdmins tid appid $ DetailsChangedForApp { actorName = Just updater.name, actorEmail = updater.email, newAppName = Just newAppName, - newAppCreatedAt = changedAt, - oldAppName = Just oldAppName, - oldAppCreatedAt = changedAt + appCreatedAt = todo, + oldAppName = Just oldAppName } refreshAppCookieImpl :: @@ -285,13 +281,12 @@ refreshAppCookieImpl (tUnqualified -> uid) tid appId mbPassword = do appName <- (.name) <$$> Store.getUser appId (actorName, actorEmail) <- appEventActor uid - updatedAt <- get notifyAdmins tid appId $ AppTokenUpdated { actorName = actorName, actorEmail = actorEmail, newAppName = appName, - newAppCreatedAt = updatedAt + appCreatedAt = todo } pure $ mkSomeToken c.cookieValue @@ -379,13 +374,12 @@ notifyAppAvailabilityChanged :: notifyAppAvailabilityChanged tid appId actorId = do appName <- (.name) <$$> Store.getUser appId (actorName, actorEmail) <- appEventActor actorId - changedAt <- get notifyAdmins tid appId $ AppAvailabilityChanged { actorName = actorName, actorEmail = actorEmail, newAppName = appName, - newAppCreatedAt = changedAt + appCreatedAt = todo } deleteAppImpl :: @@ -404,11 +398,10 @@ deleteAppImpl teamId appId = do let actorId = maybe appId (.creator) mbStoredApp (actorName, actorEmail) <- appEventActor actorId Store.deleteApp appId teamId - deletedAt <- get notifyAdmins teamId appId $ AppDeleted { actorName = actorName, actorEmail = actorEmail, newAppName = appName, - newAppCreatedAt = deletedAt + appCreatedAt = todo } diff --git a/libs/wire-subsystems/src/Wire/EmailSubsystem.hs b/libs/wire-subsystems/src/Wire/EmailSubsystem.hs index 88910d9681..00aac5fff6 100644 --- a/libs/wire-subsystems/src/Wire/EmailSubsystem.hs +++ b/libs/wire-subsystems/src/Wire/EmailSubsystem.hs @@ -42,34 +42,33 @@ data AppEvent { actorName :: Maybe Name, actorEmail :: Maybe EmailAddress, newAppName :: Maybe Name, - newAppCreatedAt :: UTCTime + appCreatedAt :: UTCTime {- TODO: appPermissions :: AppPermissions -} } | DetailsChangedForApp { actorName :: Maybe Name, actorEmail :: Maybe EmailAddress, newAppName :: Maybe Name, - newAppCreatedAt :: UTCTime, - oldAppName :: Maybe Name, - oldAppCreatedAt :: UTCTime + appCreatedAt :: UTCTime, + oldAppName :: Maybe Name } | AppTokenUpdated { actorName :: Maybe Name, actorEmail :: Maybe EmailAddress, newAppName :: Maybe Name, - newAppCreatedAt :: UTCTime + appCreatedAt :: UTCTime } | AppDeleted { actorName :: Maybe Name, actorEmail :: Maybe EmailAddress, newAppName :: Maybe Name, - newAppCreatedAt :: UTCTime + appCreatedAt :: UTCTime } | AppAvailabilityChanged { actorName :: Maybe Name, actorEmail :: Maybe EmailAddress, newAppName :: Maybe Name, - newAppCreatedAt :: UTCTime + appCreatedAt :: UTCTime } deriving (Eq, Show) diff --git a/libs/wire-subsystems/test/unit/Wire/AppSubsystem/InterpreterSpec.hs b/libs/wire-subsystems/test/unit/Wire/AppSubsystem/InterpreterSpec.hs index 67952126aa..08ffff9d9b 100644 --- a/libs/wire-subsystems/test/unit/Wire/AppSubsystem/InterpreterSpec.hs +++ b/libs/wire-subsystems/test/unit/Wire/AppSubsystem/InterpreterSpec.hs @@ -208,7 +208,7 @@ spec = focus . describe "AppSubsystem" $ do { actorName = Just (Name "Creator"), actorEmail = Just creatorEmail, newAppName = Just appName, - newAppCreatedAt = defaultTime + appCreatedAt = defaultTime } ) ] From abe0f76d77e5baa64c19279bca4c42774237550e Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Thu, 9 Jul 2026 17:08:16 +0200 Subject: [PATCH 7/8] ... --- .../src/Wire/AppSubsystem/Interpreter.hs | 134 +++++++++++++----- .../src/Wire/EmailSubsystem.hs | 15 +- .../unit/Wire/AppSubsystem/InterpreterSpec.hs | 23 ++- 3 files changed, 121 insertions(+), 51 deletions(-) diff --git a/libs/wire-subsystems/src/Wire/AppSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/AppSubsystem/Interpreter.hs index ee718d332e..55f9ec080e 100644 --- a/libs/wire-subsystems/src/Wire/AppSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/AppSubsystem/Interpreter.hs @@ -17,7 +17,7 @@ module Wire.AppSubsystem.Interpreter where -import Control.Lens ((^..)) +import Control.Lens import Data.ByteString.Conversion import Data.Default import Data.Id @@ -139,14 +139,7 @@ createAppImpl lusr tid newApp = do -- generate a team event generateTeamEvents creator.id tid [EdMemberJoin u.id] - appCreatedAt <- get - notifyAdmins tid u.id $ - NewAppCreated - { actorName = Just creator.name, - actorEmail = creator.email, - newAppName = Just newApp.name, - appCreatedAt = appCreatedAt - } + createAppSendEmail creator tid u.id newApp c :: Cookie (Token U) <- newCookie u.id Nothing PersistentCookie Nothing RevokeSameLabel pure @@ -159,24 +152,51 @@ createAppImpl lusr tid newApp = do cookie = mkSomeToken c.cookieValue } +-- | Everything needed solely to notify team admins that an app was created. +-- Values retrieved or computed by 'createAppImpl' and reused here are passed +-- in: @creator@ (the actor, from the permission check) and @appId@ (the newly +-- created app user's id). +createAppSendEmail :: + ( Member TeamSubsystem r, + Member UserStore r, + Member EmailSubsystem r + ) => + StoredUser -> + TeamId -> + UserId -> + NewApp -> + Sem r () +createAppSendEmail creator tid appId newApp = do + appCreatedAt <- internalGetTeamMember appId tid <&> (>>= memberToAppCreatedAt) + notifyAdmins tid appId $ + NewAppCreated + { actorName = Just creator.name, + actorEmail = creator.email, + newAppName = Just newApp.name, + appCreatedAt = appCreatedAt + } + +memberToAppCreatedAt :: T.TeamMember -> Maybe UTCTimeMillis +memberToAppCreatedAt = (^? T.newTeamMember . T.nInvitation . _Just . _2) + -- | Check that @lusr@ is member of team with @tid@. ensureTeamMember :: - ( Member UserStore r, - Member (Error AppSubsystemError) r, - Member GalleyAPIAccess r + ( Member TeamSubsystem r, + Member UserStore r, + Member (Error AppSubsystemError) r ) => Local UserId -> TeamId -> Sem r (StoredUser, T.TeamMember) ensureTeamMember lusr tid = do storedUser <- Store.getUser (tUnqualified lusr) >>= note AppSubsystemErrorNoUser - teamMember <- getTeamMember storedUser.id tid >>= note AppSubsystemErrorNoPerm + teamMember <- internalGetTeamMember storedUser.id tid >>= note AppSubsystemErrorNoPerm pure (storedUser, teamMember) getAppImpl :: ( Member AppStore r, + Member TeamSubsystem r, Member (Error AppSubsystemError) r, - Member GalleyAPIAccess r, Member UserStore r ) => Local UserId -> @@ -197,8 +217,8 @@ storedAppToAppInfo app = getAppsImpl :: ( Member AppStore r, + Member TeamSubsystem r, Member (Error AppSubsystemError) r, - Member GalleyAPIAccess r, Member UserStore r ) => Local UserId -> @@ -212,7 +232,6 @@ updateAppImpl :: ( Member AppStore r, Member (Error AppSubsystemError) r, Member Events r, - Member GalleyAPIAccess r, Member TeamSubsystem r, Member UserStore r, Member UserSubsystem r, @@ -239,6 +258,21 @@ updateAppImpl lusr tid appid upd = do eupAccentId = upd.accentId, eupAssets = upd.assets } + updateAppSendEmail updater oldApp tid appid upd + +updateAppSendEmail :: + ( Member TeamSubsystem r, + Member UserStore r, + Member EmailSubsystem r + ) => + StoredUser -> + StoredUser -> + TeamId -> + UserId -> + PutApp -> + Sem r () +updateAppSendEmail updater oldApp tid appid upd = do + appCreatedAt <- internalGetTeamMember appid tid <&> (>>= memberToAppCreatedAt) let oldAppName = oldApp.name newAppName = fromMaybe oldAppName upd.name notifyAdmins tid appid $ @@ -246,7 +280,7 @@ updateAppImpl lusr tid appid upd = do { actorName = Just updater.name, actorEmail = updater.email, newAppName = Just newAppName, - appCreatedAt = todo, + appCreatedAt = appCreatedAt, oldAppName = Just oldAppName } @@ -255,11 +289,9 @@ refreshAppCookieImpl :: Member AppStore r, Member (Error RetryAfter) r, Member (Error AppSubsystemError) r, - Member GalleyAPIAccess r, Member TeamSubsystem r, Member UserStore r, - Member EmailSubsystem r, - Member Now r + Member EmailSubsystem r ) => Local UserId -> TeamId -> @@ -270,7 +302,7 @@ refreshAppCookieImpl (tUnqualified -> uid) tid appId mbPassword = do reauthenticateEither uid mbPassword >>= either (const $ throw AppSubsystemErrorMissingAuth) (const $ pure ()) - mem <- getTeamMember uid tid >>= note AppSubsystemErrorNoPerm + mem <- internalGetTeamMember uid tid >>= note AppSubsystemErrorNoPerm note AppSubsystemErrorNoPerm $ guard (T.hasPermission mem T.ManageApps) void $ Store.getApp appId tid >>= note AppSubsystemErrorNoApp @@ -278,19 +310,33 @@ refreshAppCookieImpl (tUnqualified -> uid) tid appId mbPassword = do c :: Cookie (Token U) <- newCookieLimited appId Nothing PersistentCookie Nothing RevokeSameLabel >>= either throw pure + refreshAppCookieSendEmail mem uid tid appId + pure $ mkSomeToken c.cookieValue +-- | Everything needed solely to notify team admins that an app's token was +-- refreshed. Only the identifiers known to 'refreshAppCookieImpl' are passed +-- in: @actorId@ (the caller), @tid@ and @appId@. +refreshAppCookieSendEmail :: + ( Member TeamSubsystem r, + Member UserStore r, + Member EmailSubsystem r + ) => + T.TeamMember -> + UserId -> + TeamId -> + UserId -> + Sem r () +refreshAppCookieSendEmail mem actorId tid appId = do appName <- (.name) <$$> Store.getUser appId - (actorName, actorEmail) <- appEventActor uid + (actorName, actorEmail) <- appEventActor actorId notifyAdmins tid appId $ AppTokenUpdated { actorName = actorName, actorEmail = actorEmail, newAppName = appName, - appCreatedAt = todo + appCreatedAt = memberToAppCreatedAt mem } - pure $ mkSomeToken c.cookieValue - appNewStoredUser :: (Member (Input AppSubsystemConfig) r, Member Random r) => StoredUser -> @@ -354,18 +400,13 @@ appEventActor actorId = do mu <- Store.getUser actorId pure ((.name) <$> mu, (.email) =<< mu) -unknownActorEmail :: EmailAddress -unknownActorEmail = - fromMaybe (error "unknownActorEmail: invalid literal") (emailAddressText "unknown@wire.com") - -- | TODO: no operation toggles app availability yet. This helper wires the -- 'AppAvailabilityChanged' event end-to-end; call it from the availability -- toggle once that operation exists. notifyAppAvailabilityChanged :: ( Member TeamSubsystem r, Member UserStore r, - Member EmailSubsystem r, - Member Now r + Member EmailSubsystem r ) => TeamId -> UserId -> @@ -373,35 +414,52 @@ notifyAppAvailabilityChanged :: Sem r () notifyAppAvailabilityChanged tid appId actorId = do appName <- (.name) <$$> Store.getUser appId + appCreatedAt <- internalGetTeamMember appId tid <&> (>>= memberToAppCreatedAt) (actorName, actorEmail) <- appEventActor actorId notifyAdmins tid appId $ AppAvailabilityChanged { actorName = actorName, actorEmail = actorEmail, newAppName = appName, - appCreatedAt = todo + appCreatedAt = appCreatedAt } deleteAppImpl :: ( Member AppStore r, Member UserStore r, Member TeamSubsystem r, - Member EmailSubsystem r, - Member Now r + Member EmailSubsystem r ) => TeamId -> UserId -> Sem r () deleteAppImpl teamId appId = do - appName <- (.name) <$$> Store.getUser appId mbStoredApp <- Store.getApp appId teamId let actorId = maybe appId (.creator) mbStoredApp - (actorName, actorEmail) <- appEventActor actorId Store.deleteApp appId teamId - notifyAdmins teamId appId $ + deleteAppSendEmail actorId teamId appId + +-- | Everything needed solely to notify team admins that an app was deleted. +-- @actorId@ is resolved from the app record (which must be read before the app +-- is deleted) and passed in; the app user itself is not deleted, so its name +-- and the actor's details can still be looked up here. +deleteAppSendEmail :: + ( Member TeamSubsystem r, + Member UserStore r, + Member EmailSubsystem r + ) => + UserId -> + TeamId -> + UserId -> + Sem r () +deleteAppSendEmail actorId tid appId = do + appName <- (.name) <$$> Store.getUser appId + appCreatedAt <- internalGetTeamMember appId tid <&> (>>= memberToAppCreatedAt) + (actorName, actorEmail) <- appEventActor actorId + notifyAdmins tid appId $ AppDeleted { actorName = actorName, actorEmail = actorEmail, newAppName = appName, - appCreatedAt = todo + appCreatedAt = appCreatedAt } diff --git a/libs/wire-subsystems/src/Wire/EmailSubsystem.hs b/libs/wire-subsystems/src/Wire/EmailSubsystem.hs index 00aac5fff6..5906a5b879 100644 --- a/libs/wire-subsystems/src/Wire/EmailSubsystem.hs +++ b/libs/wire-subsystems/src/Wire/EmailSubsystem.hs @@ -22,7 +22,7 @@ module Wire.EmailSubsystem where import Data.Code qualified as Code import Data.Id -import Data.Time.Clock (UTCTime) +import Data.Json.Util import Data.X509.Extended (CertDescription) import Imports import Polysemy @@ -36,39 +36,42 @@ import Wire.API.User.Client (Client (..)) -- | A typed description of something that happened to an app in a team. Each -- constructor corresponds to a distinct admin-notification email (and template). -- +-- Most of the `Maybe`s are implausible or impossible corner cases, +-- Nothing is handled in `renderAppEventEmail`. +-- -- See https://www.figma.com/design/AMNqFhTUElOZDJfbUYnMmJ/Apps--Services----Integrations?node-id=431-2452 data AppEvent = NewAppCreated { actorName :: Maybe Name, actorEmail :: Maybe EmailAddress, newAppName :: Maybe Name, - appCreatedAt :: UTCTime + appCreatedAt :: Maybe UTCTimeMillis {- TODO: appPermissions :: AppPermissions -} } | DetailsChangedForApp { actorName :: Maybe Name, actorEmail :: Maybe EmailAddress, newAppName :: Maybe Name, - appCreatedAt :: UTCTime, + appCreatedAt :: Maybe UTCTimeMillis, oldAppName :: Maybe Name } | AppTokenUpdated { actorName :: Maybe Name, actorEmail :: Maybe EmailAddress, newAppName :: Maybe Name, - appCreatedAt :: UTCTime + appCreatedAt :: Maybe UTCTimeMillis } | AppDeleted { actorName :: Maybe Name, actorEmail :: Maybe EmailAddress, newAppName :: Maybe Name, - appCreatedAt :: UTCTime + appCreatedAt :: Maybe UTCTimeMillis } | AppAvailabilityChanged { actorName :: Maybe Name, actorEmail :: Maybe EmailAddress, newAppName :: Maybe Name, - appCreatedAt :: UTCTime + appCreatedAt :: Maybe UTCTimeMillis } deriving (Eq, Show) diff --git a/libs/wire-subsystems/test/unit/Wire/AppSubsystem/InterpreterSpec.hs b/libs/wire-subsystems/test/unit/Wire/AppSubsystem/InterpreterSpec.hs index 08ffff9d9b..07f2000de2 100644 --- a/libs/wire-subsystems/test/unit/Wire/AppSubsystem/InterpreterSpec.hs +++ b/libs/wire-subsystems/test/unit/Wire/AppSubsystem/InterpreterSpec.hs @@ -21,7 +21,8 @@ module Wire.AppSubsystem.InterpreterSpec (spec) where import Data.Default (def) import Data.Id -import Data.LegalHold (UserLegalHoldStatus (..)) +import Data.Json.Util +import Data.LegalHold (UserLegalHoldStatus (..), defUserLegalHoldStatus) import Data.Map qualified as Map import Data.Qualified import Data.Range @@ -39,7 +40,8 @@ import Test.QuickCheck import Wire.API.Error (ErrorS) import Wire.API.Error.Galley (GalleyError (TeamMemberNotFound, TeamNotFound)) import Wire.API.Team.Member -import Wire.API.Team.Permission (fullPermissions) +import Wire.API.Team.Permission +import Wire.API.Team.Role import Wire.API.User import Wire.AppStore hiding (deleteApp, updateApp) import Wire.AppSubsystem @@ -57,7 +59,6 @@ import Wire.TeamSubsystem import Wire.TeamSubsystem.GalleyAPI (interpretTeamSubsystemToGalleyAPI) import Wire.UserKeyStore import Wire.UserStore -import Wire.UserSubsystem type LowerAppEffects = '[ Now, @@ -183,7 +184,7 @@ mkStoredApp appId tid creatorId = } spec :: Spec -spec = focus . describe "AppSubsystem" $ do +spec = describe "AppSubsystem" $ do describe "deleteApp" $ do prop "sends an email to each team admin that has an email address" $ \(tid :: TeamId) (appId :: UserId) (creatorId :: UserId) (creatorEmail :: EmailAddress) (adminId :: UserId) (adminEmail :: EmailAddress) (appName :: Name) -> @@ -192,8 +193,16 @@ spec = focus . describe "AppSubsystem" $ do creator = mkStoredUser creatorId (Name "Creator") (Just creatorEmail) (Just tid) admin = mkStoredUser adminId (Name "Admin") (Just adminEmail) (Just tid) storedApp = mkStoredApp appId tid creatorId - teams = Map.singleton tid [mkOwnerMember adminId] - result = runAppEffects [appUser, creator, admin] [storedApp] teams $ deleteApp tid appId + teams :: Map TeamId [TeamMember] = + Map.singleton + tid + [ mkOwnerMember adminId, + let perms = rolePermissions RoleMember + info = Just (creatorId, (toUTCTimeMillis defaultTime)) + in mkTeamMember appId perms info defUserLegalHoldStatus + ] + result = runAppEffects [appUser, creator, admin] [storedApp] teams $ do + deleteApp tid appId in case result of Left err -> counterexample (show err) False Right ((), sentEmails) -> @@ -208,7 +217,7 @@ spec = focus . describe "AppSubsystem" $ do { actorName = Just (Name "Creator"), actorEmail = Just creatorEmail, newAppName = Just appName, - appCreatedAt = defaultTime + appCreatedAt = Just (toUTCTimeMillis defaultTime) } ) ] From 1916ecf1b557049cf3e0bf9ea4d5bf48ece4ade9 Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Thu, 9 Jul 2026 17:37:19 +0200 Subject: [PATCH 8/8] ... --- libs/wire-subsystems/src/Wire/AppSubsystem.hs | 15 +++++---- .../src/Wire/AppSubsystem/Interpreter.hs | 33 ++++++++++--------- 2 files changed, 27 insertions(+), 21 deletions(-) diff --git a/libs/wire-subsystems/src/Wire/AppSubsystem.hs b/libs/wire-subsystems/src/Wire/AppSubsystem.hs index ed16ba5bfa..3cab079ca8 100644 --- a/libs/wire-subsystems/src/Wire/AppSubsystem.hs +++ b/libs/wire-subsystems/src/Wire/AppSubsystem.hs @@ -42,9 +42,10 @@ instance Default AppSubsystemConfig where data AppSubsystemError = AppSubsystemErrorNoPerm | AppSubsystemErrorMissingAuth - | AppSubsystemErrorNoUser -- The user having created the app not found - | AppSubsystemErrorAppUserNotFound -- The user used to "enact" the app not found - | AppSubsystemErrorNoApp + | AppSubsystemErrorNoCreator + | AppSubsystemErrorNoAppData + | AppSubsystemErrorNoAppUser + | AppSubsystemErrorNoAppTeamMember deriving (Eq, Show) instance Exception AppSubsystemError @@ -54,9 +55,11 @@ appSubsystemErrorToHttpError = StdError . \case AppSubsystemErrorNoPerm -> Wai.mkError status403 "app-no-permission" "User does not have permission to create or manage apps" AppSubsystemErrorMissingAuth -> Wai.mkError status403 "missing-auth" "Re-authentication via password required" - AppSubsystemErrorNoUser -> Wai.mkError status403 "create-app-no-user" "App owner not found" - AppSubsystemErrorAppUserNotFound -> Wai.mkError status403 "app-user-not-found" "App user not found" - AppSubsystemErrorNoApp -> Wai.mkError status404 "app-not-found" "App not found" + -- TODO(fisx): announce these changes. + AppSubsystemErrorNoCreator -> Wai.mkError status403 "no-app-creator" "App owner not found" + AppSubsystemErrorNoAppData -> Wai.mkError status404 "app-not-found" "App not found (metadata record)" + AppSubsystemErrorNoAppUser -> Wai.mkError status404 "app-not-found" "App not found (user record)" + AppSubsystemErrorNoAppTeamMember -> Wai.mkError status404 "app-not-found" "App not found (team member record)" data AppSubsystem m a where CreateApp :: Local UserId -> TeamId -> NewApp -> AppSubsystem m CreatedApp diff --git a/libs/wire-subsystems/src/Wire/AppSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/AppSubsystem/Interpreter.hs index 55f9ec080e..5370c54e62 100644 --- a/libs/wire-subsystems/src/Wire/AppSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/AppSubsystem/Interpreter.hs @@ -159,6 +159,7 @@ createAppImpl lusr tid newApp = do createAppSendEmail :: ( Member TeamSubsystem r, Member UserStore r, + Member (Error AppSubsystemError) r, Member EmailSubsystem r ) => StoredUser -> @@ -167,13 +168,13 @@ createAppSendEmail :: NewApp -> Sem r () createAppSendEmail creator tid appId newApp = do - appCreatedAt <- internalGetTeamMember appId tid <&> (>>= memberToAppCreatedAt) + appTeamMember <- internalGetTeamMember appId tid >>= note AppSubsystemErrorNoAppTeamMember notifyAdmins tid appId $ NewAppCreated { actorName = Just creator.name, actorEmail = creator.email, newAppName = Just newApp.name, - appCreatedAt = appCreatedAt + appCreatedAt = memberToAppCreatedAt appTeamMember } memberToAppCreatedAt :: T.TeamMember -> Maybe UTCTimeMillis @@ -189,7 +190,7 @@ ensureTeamMember :: TeamId -> Sem r (StoredUser, T.TeamMember) ensureTeamMember lusr tid = do - storedUser <- Store.getUser (tUnqualified lusr) >>= note AppSubsystemErrorNoUser + storedUser <- Store.getUser (tUnqualified lusr) >>= note AppSubsystemErrorNoCreator teamMember <- internalGetTeamMember storedUser.id tid >>= note AppSubsystemErrorNoPerm pure (storedUser, teamMember) @@ -205,7 +206,7 @@ getAppImpl :: Sem r AppInfo getAppImpl lusr tid uid = do void $ ensureTeamMember lusr tid - storedApp <- Store.getApp uid tid >>= note AppSubsystemErrorNoApp + storedApp <- Store.getApp uid tid >>= note AppSubsystemErrorNoAppData pure $ storedAppToAppInfo storedApp storedAppToAppInfo :: StoredApp -> AppInfo @@ -245,10 +246,10 @@ updateAppImpl :: updateAppImpl lusr tid appid upd = do (updater, umem) <- ensureTeamMember lusr tid note AppSubsystemErrorNoPerm $ guard (T.hasPermission umem T.CreateApp) - oldApp <- Store.getUser appid >>= note AppSubsystemErrorNoApp + oldApp <- Store.getUser appid >>= note AppSubsystemErrorNoAppUser Store.updateApp tid appid (Store.MkStoredAppUpdate {category = upd.category, description = upd.description}) >>= \case Right () -> pure () - Left Store.NotFound -> throw AppSubsystemErrorNoApp + Left Store.NotFound -> throw AppSubsystemErrorNoAppData Store.updateUser appid (def {Store.name = upd.name, Store.assets = upd.assets, Store.accentId = upd.accentId}) internalUpdateSearchIndex appid generateUserEvent appid Nothing $ @@ -262,6 +263,7 @@ updateAppImpl lusr tid appid upd = do updateAppSendEmail :: ( Member TeamSubsystem r, + Member (Error AppSubsystemError) r, Member UserStore r, Member EmailSubsystem r ) => @@ -272,7 +274,7 @@ updateAppSendEmail :: PutApp -> Sem r () updateAppSendEmail updater oldApp tid appid upd = do - appCreatedAt <- internalGetTeamMember appid tid <&> (>>= memberToAppCreatedAt) + appTeamMember <- internalGetTeamMember appid tid >>= note AppSubsystemErrorNoAppTeamMember let oldAppName = oldApp.name newAppName = fromMaybe oldAppName upd.name notifyAdmins tid appid $ @@ -280,7 +282,7 @@ updateAppSendEmail updater oldApp tid appid upd = do { actorName = Just updater.name, actorEmail = updater.email, newAppName = Just newAppName, - appCreatedAt = appCreatedAt, + appCreatedAt = memberToAppCreatedAt appTeamMember, oldAppName = Just oldAppName } @@ -304,7 +306,7 @@ refreshAppCookieImpl (tUnqualified -> uid) tid appId mbPassword = do mem <- internalGetTeamMember uid tid >>= note AppSubsystemErrorNoPerm note AppSubsystemErrorNoPerm $ guard (T.hasPermission mem T.ManageApps) - void $ Store.getApp appId tid >>= note AppSubsystemErrorNoApp + void $ Store.getApp appId tid >>= note AppSubsystemErrorNoAppData revokeAllCookies appId c :: Cookie (Token U) <- @@ -319,6 +321,7 @@ refreshAppCookieImpl (tUnqualified -> uid) tid appId mbPassword = do refreshAppCookieSendEmail :: ( Member TeamSubsystem r, Member UserStore r, + Member (Error AppSubsystemError) r, Member EmailSubsystem r ) => T.TeamMember -> @@ -327,13 +330,13 @@ refreshAppCookieSendEmail :: UserId -> Sem r () refreshAppCookieSendEmail mem actorId tid appId = do - appName <- (.name) <$$> Store.getUser appId + appUser <- Store.getUser appId >>= note AppSubsystemErrorNoAppUser (actorName, actorEmail) <- appEventActor actorId notifyAdmins tid appId $ AppTokenUpdated { actorName = actorName, actorEmail = actorEmail, - newAppName = appName, + newAppName = Just appUser.name, appCreatedAt = memberToAppCreatedAt mem } @@ -428,16 +431,16 @@ deleteAppImpl :: ( Member AppStore r, Member UserStore r, Member TeamSubsystem r, - Member EmailSubsystem r + Member EmailSubsystem r, + Member (Error AppSubsystemError) r ) => TeamId -> UserId -> Sem r () deleteAppImpl teamId appId = do - mbStoredApp <- Store.getApp appId teamId - let actorId = maybe appId (.creator) mbStoredApp + storedApp <- Store.getApp appId teamId >>= note AppSubsystemErrorNoAppData Store.deleteApp appId teamId - deleteAppSendEmail actorId teamId appId + deleteAppSendEmail storedApp.creator teamId appId -- | Everything needed solely to notify team admins that an app was deleted. -- @actorId@ is resolved from the app record (which must be read before the app