From ec59d33b76ad0184e84998eaf31a563546abfb1f Mon Sep 17 00:00:00 2001 From: Stefan Matting Date: Wed, 23 Jun 2021 17:26:53 +0200 Subject: [PATCH] Handle LH policy conflicts in group conversations (#1595) * Import removeTeam to Galley.API.LegalHold without import cycles. (will be needed shortly.) * iterateConversations. (Copied from https://github.com/wireapp/wire-server/pull/1507, which has meanwhile been reverted in https://github.com/wireapp/wire-server/pull/1549.) * Make removeMember device id argument optional. * handleGroupConvPolicyConflicts [wip] * test stub * mapcon * fix bug in handleGroupConvPolicyConflicts * add 2 test cases: who is admin? who gets removed? * Add group conv logic [wip] * move lh helpers to utils * fixup add members * fixup tests * use Conversation from galley to include self * implement anyLHConsentMissing * Move check*Event funs from Teams to Utils * update first * adjust test to new setting & adjust case when peer is admin * hi ci * Add checks for leave events * add testNoConsentCannotBeInvited * add failing test case * Add guards (test succeeds) * refactor: rename guard functions * comment wording * anyLegalholdActivated: make true to the name * adjust testNoConsentRemoveFromGroupConv * inviting conflicting users: adjust and rename test * remove futurework (wont do) and add comments * remove test marker * spell out the tests * add FUTUREWORKs for test structure * comment wording * add test for v2 endpoint * add additional safeguard * Cleanup. * Add two missing test case stubs. * Eliminate redundant negation in function name. * Boolean blindness. only the first line changed, rest is ormolu noise. * Fix call side. * Changed my mind about whether boolean blindness is a good thing. * Fixup. * Cleanup (move source comment to inner block). * Tweak detail. * Remove dubious claim. https://github.com/wireapp/wire-server/pull/1595#issuecomment-864922213 * Simplify. * Move code around. * LH consent: guarantee that all conflicting conv members are removed. * Taking back e16a0bc9a3569f5a8f60c341dac133e345eacb52. (I thought I had spotted a difference in database load, but I think i was wrong, and the original code is more straight-forward.) * Fixup. * Change test cases & descriptions. * fix syntax * All -> Some (explanation in message) Why 1) Because "Some" is the negation of "None" 2) This is consistent with testGroup "Legalhold is activated for user A in a group conversation" * add failing test case * Refactor: factor out new fn getLHStatusForUsers * Update business logic * Remove NoConsentingAdmins test case * Add test case: mixed invitees * Refactor: group tests regarding invite together * assertion (it's non-trivial, but easy enough to convince ourselves that it'll pass fine, so no error handling needed.) * Language. Co-authored-by: Matthias Fischmann --- services/galley/src/Galley/API/Create.hs | 13 +- services/galley/src/Galley/API/LegalHold.hs | 82 ++++-- services/galley/src/Galley/API/Query.hs | 23 +- services/galley/src/Galley/API/Teams.hs | 1 - services/galley/src/Galley/API/Update.hs | 60 ++++- services/galley/src/Galley/API/Util.hs | 79 +++++- services/galley/test/integration/API/Teams.hs | 77 ------ .../test/integration/API/Teams/LegalHold.hs | 251 ++++++++++++++++-- services/galley/test/integration/API/Util.hs | 88 +++++- 9 files changed, 538 insertions(+), 136 deletions(-) diff --git a/services/galley/src/Galley/API/Create.hs b/services/galley/src/Galley/API/Create.hs index e075123e50f..a8928c0db6b 100644 --- a/services/galley/src/Galley/API/Create.hs +++ b/services/galley/src/Galley/API/Create.hs @@ -29,7 +29,8 @@ import Control.Lens hiding ((??)) import Control.Monad.Catch import Data.Id import Data.List1 (list1) -import Data.Qualified (Qualified (..), partitionRemoteOrLocalIds') +import Data.Misc (FutureWork (FutureWork)) +import Data.Qualified (Qualified (..), Remote, partitionRemoteOrLocalIds') import Data.Range import qualified Data.Set as Set import Data.Time @@ -53,6 +54,7 @@ import qualified Servant import Servant.API (Union) import qualified Wire.API.Conversation as Public import Wire.API.Routes.Public.Galley (ConversationResponses) +import Wire.API.Team.LegalHold (LegalholdProtectee (LegalholdPlusFederationNotImplemented)) -- Servant helpers ------------------------------------------------------ @@ -93,6 +95,13 @@ internalCreateManagedConversation zusr zcon (NewConvManaged body) = do Nothing -> throwM internalError Just tinfo -> createTeamGroupConv zusr zcon tinfo body +ensureNoLegalholdConflicts :: [Remote UserId] -> [UserId] -> Galley () +ensureNoLegalholdConflicts remotes locals = do + let FutureWork _remotes = FutureWork @'LegalholdPlusFederationNotImplemented remotes + whenM (anyLegalholdActivated locals) $ + unlessM (allLegalholdConsentGiven locals) $ + throwM missingLegalholdConsent + -- | A helper for creating a regular (non-team) group conversation. createRegularGroupConv :: UserId -> ConnId -> NewConvUnmanaged -> Galley ConversationResponse createRegularGroupConv zusr zcon (NewConvUnmanaged body) = do @@ -106,6 +115,7 @@ createRegularGroupConv zusr zcon (NewConvUnmanaged body) = do let (remotes, locals) = fromConvSize checkedPartitionedUsers ensureConnected zusr locals checkRemoteUsersExist remotes + ensureNoLegalholdConflicts remotes locals -- FUTUREWORK: Implement (3) per comments for Update.addMembers. (also for createTeamGroupConv) c <- Data.createConversation @@ -167,6 +177,7 @@ createTeamGroupConv zusr zcon tinfo body = do ensureConnectedToLocals zusr (notTeamMember localUserIds (catMaybes convLocalMemberships)) pure checkedPartitionedUsers checkRemoteUsersExist remotes + ensureNoLegalholdConflicts remotes localUserIds -- FUTUREWORK: Implement (3) per comments for Update.addMembers. conv <- Data.createConversation diff --git a/services/galley/src/Galley/API/LegalHold.hs b/services/galley/src/Galley/API/LegalHold.hs index 39c63af4709..125b30e4b4d 100644 --- a/services/galley/src/Galley/API/LegalHold.hs +++ b/services/galley/src/Galley/API/LegalHold.hs @@ -37,15 +37,19 @@ import Brig.Types.Connection (UpdateConnectionsInternal (..)) import Brig.Types.Intra (ConnectionStatus (..)) import Brig.Types.Provider import Brig.Types.Team.LegalHold hiding (userId) +import Control.Exception (assert) import Control.Lens (view, (^.)) import Control.Monad.Catch import Data.ByteString.Conversion (toByteString, toByteString') import Data.Id import Data.LegalHold (UserLegalHoldStatus (..), defUserLegalHoldStatus) import Data.List.Split (chunksOf) -import qualified Data.Map.Strict as Map import Data.Misc +import Data.Proxy (Proxy (Proxy)) +import Data.Range (toRange) import Galley.API.Error +import Galley.API.Query (iterateConversations) +import Galley.API.Update (removeMember) import Galley.API.Util import Galley.App import qualified Galley.Data as Data @@ -56,6 +60,7 @@ import qualified Galley.External.LegalHoldService as LHService import qualified Galley.Intra.Client as Client import Galley.Intra.User (getConnections, putConnectionInternal) import qualified Galley.Options as Opts +import Galley.Types (LocalMember, memConvRoleName, memId) import Galley.Types.Teams as Team import Imports import Network.HTTP.Types (status200, status404) @@ -65,7 +70,10 @@ import Network.Wai.Predicate hiding (or, result, setStatus, _3) import Network.Wai.Utilities as Wai import qualified System.Logger.Class as Log import UnliftIO.Async (pooledMapConcurrentlyN_) +import Wire.API.Conversation (ConvType (..)) +import Wire.API.Conversation.Role (roleNameWireAdmin) import qualified Wire.API.Team.Feature as Public +import Wire.API.Team.LegalHold (LegalholdProtectee (LegalholdPlusFederationNotImplemented)) import qualified Wire.API.Team.LegalHold as Public assertLegalHoldEnabledForTeam :: TeamId -> Galley () @@ -365,14 +373,6 @@ disableForUser zusr tid uid (Public.DisableLegalHoldForUserRequest mPassword) = -- https://github.com/wireapp/wire-server/pull/802#pullrequestreview-262280386) changeLegalholdStatus tid uid userLHStatus UserLegalHoldDisabled --- | If not enabled nor pending, then it's disabled -userLHEnabled :: UserLegalHoldStatus -> Bool -userLHEnabled = \case - UserLegalHoldEnabled -> True - UserLegalHoldPending -> True - UserLegalHoldDisabled -> False - UserLegalHoldNoConsent -> False - -- | Allow no-consent => consent without further changes. If LH device is requested, enabled, -- or disabled, make sure the affected connections are screened for policy conflict (anybody -- with no-consent), and put those connections in the appropriate blocked state. @@ -405,13 +405,15 @@ changeLegalholdStatus tid uid old new = do where update = LegalHoldData.setUserLegalHoldStatus tid uid new removeblocks = void $ putConnectionInternal (RemoveLHBlocksInvolving uid) - addblocks = blockConnectionsFrom1on1s uid + addblocks = do + blockNonConsentingConnections uid + handleGroupConvPolicyConflicts uid new noop = pure () illegal = throwM userLegalHoldIllegalOperation -- FUTUREWORK: make this async? -blockConnectionsFrom1on1s :: UserId -> Galley () -blockConnectionsFrom1on1s uid = do +blockNonConsentingConnections :: UserId -> Galley () +blockNonConsentingConnections uid = do conns <- getConnections [uid] Nothing Nothing errmsgs <- do conflicts <- mconcat <$> findConflicts conns @@ -428,7 +430,7 @@ blockConnectionsFrom1on1s uid = do -- FUTUREWORK: Handle remoteUsers here when federation is implemented for (chunksOf 32 localUids) $ \others -> do teamsOfUsers <- Data.usersTeams others - filterM (shouldBlock teamsOfUsers) others + filterM (fmap (== ConsentNotGiven) . checkConsent teamsOfUsers) others blockConflicts :: UserId -> [UserId] -> Galley [String] blockConflicts _ [] = pure [] @@ -436,15 +438,6 @@ blockConnectionsFrom1on1s uid = do status <- putConnectionInternal (BlockForMissingLHConsent userLegalhold othersToBlock) pure $ ["blocking users failed: " <> show (status, othersToBlock) | status /= status200] - shouldBlock :: Map UserId TeamId -> UserId -> Galley Bool - shouldBlock teamsOfUsers other = - (== UserLegalHoldNoConsent) - <$> case Map.lookup other teamsOfUsers of - Nothing -> pure defUserLegalHoldStatus - Just team -> do - mMember <- Data.teamMember team other - pure $ maybe defUserLegalHoldStatus (view legalHoldStatus) mMember - setTeamLegalholdWhitelisted :: TeamId -> Galley () setTeamLegalholdWhitelisted tid = do LegalHoldData.setTeamLegalholdWhitelisted tid @@ -473,3 +466,48 @@ getTeamLegalholdWhitelistedH tid = do if lhEnabled then setStatus status200 empty else setStatus status404 empty + +-- | Make sure that enough people are removed from all conversations that contain user `uid` +-- that no policy conflict arises. +-- +-- It is guaranteed that no group will ever end up without a group admin because of a policy +-- conflict: If at least one group admin has 'ConsentGiven', non-consenting users are removed. +-- Otherwise, we assume that the group is dominated by people not interested in giving +-- consent, and users carrying LH devices are removed instead. +-- +-- The first argument to this function needs explaining: in order to guarantee that this +-- function terminates before we set the LH of user `uid` on pending, we need to call it +-- first. This means that user `uid` has outdated LH status while this function is running, +-- which may cause wrong behavior. In order to guarantee correct behavior, the first argument +-- contains the hypothetical new LH status of `uid`'s so it can be consulted instead of the +-- one from the database. +handleGroupConvPolicyConflicts :: UserId -> UserLegalHoldStatus -> Galley () +handleGroupConvPolicyConflicts uid hypotheticalLHStatus = + void $ + iterateConversations uid (toRange (Proxy @500)) $ \convs -> do + for_ (filter ((== RegularConv) . Data.convType) convs) $ \conv -> do + let FutureWork _convRemoteMembers' = FutureWork @'LegalholdPlusFederationNotImplemented Data.convRemoteMembers + + membersAndLHStatus :: [(LocalMember, UserLegalHoldStatus)] <- do + let mems = Data.convLocalMembers conv + uidsLHStatus <- getLHStatusForUsers (memId <$> mems) + pure $ + zipWith + ( \mem (mid, status) -> + assert (memId mem == mid) $ + if memId mem == uid + then (mem, hypotheticalLHStatus) + else (mem, status) + ) + mems + uidsLHStatus + + if any + ((== ConsentGiven) . consentGiven . snd) + (filter ((== roleNameWireAdmin) . memConvRoleName . fst) membersAndLHStatus) + then do + for_ (filter ((== ConsentNotGiven) . consentGiven . snd) membersAndLHStatus) $ \(memberNoConsent, _) -> do + removeMember (memId memberNoConsent) Nothing (Data.convId conv) (memId memberNoConsent) + else do + for_ (filter (userLHEnabled . snd) membersAndLHStatus) $ \(legalholder, _) -> do + removeMember (memId legalholder) Nothing (Data.convId conv) (memId legalholder) diff --git a/services/galley/src/Galley/API/Query.hs b/services/galley/src/Galley/API/Query.hs index 31f179e924a..569a069dd2d 100644 --- a/services/galley/src/Galley/API/Query.hs +++ b/services/galley/src/Galley/API/Query.hs @@ -22,6 +22,7 @@ module Galley.API.Query getConversationRoles, getConversationIds, getConversations, + iterateConversations, getSelfH, internalGetMemberH, getConversationMetaH, @@ -120,6 +121,11 @@ getConversationIds zusr start msize = do getConversations :: UserId -> Maybe (Range 1 32 (CommaSeparatedList ConvId)) -> Maybe ConvId -> Maybe (Range 1 500 Int32) -> Galley (Public.ConversationList Public.Conversation) getConversations user mids mstart msize = do + ConversationList cs more <- getConversationsInternal user mids mstart msize + flip ConversationList more <$> mapM (Mapping.conversationView user) cs + +getConversationsInternal :: UserId -> Maybe (Range 1 32 (CommaSeparatedList ConvId)) -> Maybe ConvId -> Maybe (Range 1 500 Int32) -> Galley (Public.ConversationList Data.Conversation) +getConversationsInternal user mids mstart msize = do (more, ids) <- getIds mids let localConvIds = ids -- FUTUREWORK(federation, #1273): fetch remote conversations from other backend @@ -127,7 +133,7 @@ getConversations user mids mstart msize = do Data.conversations localConvIds >>= filterM removeDeleted >>= filterM (pure . isMember user . Data.convLocalMembers) - flip Public.ConversationList more <$> mapM (Mapping.conversationView user) cs + pure $ Public.ConversationList cs more where size = fromMaybe (toRange (Proxy @32)) msize @@ -146,6 +152,21 @@ getConversations user mids mstart msize = do | Data.isConvDeleted c = Data.deleteConversation (Data.convId c) >> pure False | otherwise = pure True +iterateConversations :: forall a. UserId -> Range 1 500 Int32 -> ([Data.Conversation] -> Galley a) -> Galley [a] +iterateConversations uid pageSize handleConvs = go Nothing + where + go :: Maybe ConvId -> Galley [a] + go mbConv = do + convResult <- getConversationsInternal uid Nothing mbConv (Just pageSize) + resultHead <- handleConvs (convList convResult) + resultTail <- case convList convResult of + (conv : rest) -> + if convHasMore convResult + then go (Just (maximum (Data.convId <$> (conv : rest)))) + else pure [] + _ -> pure [] + pure $ resultHead : resultTail + getSelfH :: UserId ::: ConvId -> Galley Response getSelfH (zusr ::: cnv) = do json <$> getSelf zusr cnv diff --git a/services/galley/src/Galley/API/Teams.hs b/services/galley/src/Galley/API/Teams.hs index 829b2d782b1..d717bdade28 100644 --- a/services/galley/src/Galley/API/Teams.hs +++ b/services/galley/src/Galley/API/Teams.hs @@ -48,7 +48,6 @@ module Galley.API.Teams uncheckedGetTeamMemberH, uncheckedGetTeamMembersH, uncheckedDeleteTeamMember, - withBindingTeam, userIsTeamOwnerH, canUserJoinTeamH, internalDeleteBindingTeamWithOneMemberH, diff --git a/services/galley/src/Galley/API/Update.hs b/services/galley/src/Galley/API/Update.hs index 3d828f9af47..29253506c07 100644 --- a/services/galley/src/Galley/API/Update.hs +++ b/services/galley/src/Galley/API/Update.hs @@ -38,6 +38,7 @@ module Galley.API.Update updateSelfMemberH, updateOtherMemberH, removeMemberH, + removeMember, -- * Servant UpdateResponses, @@ -72,11 +73,11 @@ import Data.Code import Data.Domain (Domain) import Data.Id import Data.Json.Util (toUTCTimeMillis) -import Data.LegalHold (UserLegalHoldStatus (UserLegalHoldNoConsent), defUserLegalHoldStatus) +import Data.LegalHold (UserLegalHoldStatus (..), defUserLegalHoldStatus) import Data.List.Extra (nubOrd) import Data.List1 import qualified Data.Map.Strict as Map -import Data.Misc (FutureWork (..)) +import Data.Misc (FutureWork (FutureWork)) import Data.Qualified import Data.Range import qualified Data.Set as Set @@ -84,7 +85,6 @@ import qualified Data.Text.Encoding as Text import Data.Time import Galley.API.Error import Galley.API.Mapping -import qualified Galley.API.Teams as Teams import Galley.API.Util import Galley.App import Galley.Data (teamMember) @@ -116,6 +116,7 @@ import qualified System.Logger.Class as Log import Wire.API.Conversation (InviteQualified (invQRoleName)) import qualified Wire.API.Conversation as Public import qualified Wire.API.Conversation.Code as Public +import Wire.API.Conversation.Role (roleNameWireAdmin) import qualified Wire.API.ErrorDescription as Public import qualified Wire.API.Event.Conversation as Public import Wire.API.Federation.Error (federationNotImplemented) @@ -515,6 +516,8 @@ addMembers zusr zcon convId invite = do ensureConvRoleNotElevated self (invQRoleName invite) checkLocals conv (Data.convTeam conv) newLocals checkRemoteUsersExist newRemotes + checkLHPolicyConflictsLocal conv newLocals + checkLHPolicyConflictsRemote (FutureWork newRemotes) addToConversation mems rMems (zusr, memConvRoleName self) zcon ((,invQRoleName invite) <$> newLocals) ((,invQRoleName invite) <$> newRemotes) conv where userIsMember u = (^. userId . to (== u)) @@ -532,6 +535,40 @@ addMembers zusr zcon convId invite = do ensureAccessRole (Data.convAccessRole conv) (zip newUsers $ repeat Nothing) ensureConnectedOrSameTeam zusr newUsers + checkLHPolicyConflictsLocal :: Data.Conversation -> [UserId] -> Galley () + checkLHPolicyConflictsLocal conv newUsers = do + let convUsers = Data.convLocalMembers conv + + allNewUsersGaveConsent <- allLegalholdConsentGiven newUsers + + whenM (anyLegalholdActivated (memId <$> convUsers)) $ + unless allNewUsersGaveConsent $ + throwM missingLegalholdConsent + + whenM (anyLegalholdActivated newUsers) $ do + unless allNewUsersGaveConsent $ + throwM missingLegalholdConsent + + convUsersLHStatus <- do + uidsStatus <- getLHStatusForUsers (memId <$> convUsers) + pure $ zipWith (\mem (_, status) -> (mem, status)) convUsers uidsStatus + + if any + ( \(mem, status) -> + memConvRoleName mem == roleNameWireAdmin + && consentGiven status == ConsentGiven + ) + convUsersLHStatus + then do + for_ convUsersLHStatus $ \(mem, status) -> do + when (consentGiven status == ConsentNotGiven) $ + void $ removeMember (memId mem) Nothing (Data.convId conv) (memId mem) + else do + throwM missingLegalholdConsent + + checkLHPolicyConflictsRemote :: FutureWork 'LegalholdPlusFederationNotImplemented [Remote UserId] -> Galley () + checkLHPolicyConflictsRemote _remotes = pure () + updateSelfMemberH :: UserId ::: ConnId ::: ConvId ::: JsonRequest Public.MemberUpdate -> Galley Response updateSelfMemberH (zusr ::: zcon ::: cid ::: req) = do update <- fromJsonBody req @@ -565,9 +602,9 @@ updateOtherMember zusr zcon cid victim update = do removeMemberH :: UserId ::: ConnId ::: ConvId ::: UserId -> Galley Response removeMemberH (zusr ::: zcon ::: cid ::: victim) = do - handleUpdateResult <$> removeMember zusr zcon cid victim + handleUpdateResult <$> removeMember zusr (Just zcon) cid victim -removeMember :: UserId -> ConnId -> ConvId -> UserId -> Galley UpdateResult +removeMember :: UserId -> Maybe ConnId -> ConvId -> UserId -> Galley UpdateResult removeMember zusr zcon convId victim = do localDomain <- viewFederationDomain -- FUTUREWORK(federation, #1274): forward request to conversation's backend. @@ -583,7 +620,7 @@ removeMember zusr zcon convId victim = do event <- Data.removeLocalMembers localDomain conv zusr (singleton victim) -- FUTUREWORK(federation, #1274): users can be on other backend, how to notify it? for_ (newPush ListComplete zusr (ConvEvent event) (recipient <$> users)) $ \p -> - push1 $ p & pushConn ?~ zcon + push1 $ p & pushConn .~ zcon void . forkIO $ void $ External.deliver (bots `zip` repeat event) pure $ Updated event else pure Unchanged @@ -1039,7 +1076,7 @@ withValidOtrBroadcastRecipients :: UTCTime -> ([(LocalMember, ClientId, Text)] -> Galley ()) -> Galley OtrResult -withValidOtrBroadcastRecipients usr clt rcps val now go = Teams.withBindingTeam usr $ \tid -> do +withValidOtrBroadcastRecipients usr clt rcps val now go = withBindingTeam usr $ \tid -> do limit <- fromIntegral . fromRange <$> fanoutLimit -- If we are going to fan this out to more than limit, we want to fail early unless (Map.size (userClientMap (otrRecipientsMap rcps)) <= limit) $ @@ -1299,3 +1336,12 @@ guardLegalholdPolicyConflictsUid self otherClients = do -- We add this check here as an extra failsafe. Log.debug $ Log.msg ("guardLegalholdPolicyConflicts[3]: consent missing" :: Text) throwM missingLegalholdConsent + +-- Copied from 'Galley.API.Team' to break import cycles +withBindingTeam :: UserId -> (TeamId -> Galley b) -> Galley b +withBindingTeam zusr callback = do + tid <- Data.oneUserTeam zusr >>= ifNothing teamNotFound + binding <- Data.teamBinding tid >>= ifNothing teamNotFound + case binding of + Binding -> callback tid + NonBinding -> throwM nonBindingTeam diff --git a/services/galley/src/Galley/API/Util.hs b/services/galley/src/Galley/API/Util.hs index f5a597eafbf..75441a8dbc4 100644 --- a/services/galley/src/Galley/API/Util.hs +++ b/services/galley/src/Galley/API/Util.hs @@ -25,10 +25,12 @@ import Control.Error (ExceptT) import Control.Lens (set, view, (.~), (^.)) import Control.Monad.Catch import Control.Monad.Except (runExceptT) +import Control.Monad.Extra (allM, anyM) import Data.ByteString.Conversion import Data.Domain (Domain) import Data.Id as Id -import Data.List.Extra (nubOrd) +import Data.LegalHold (UserLegalHoldStatus (..), defUserLegalHoldStatus) +import Data.List.Extra (chunksOf, nubOrd) import qualified Data.Map as Map import Data.Misc (PlainTextPassword (..)) import Data.Qualified (Qualified (..), Remote, partitionQualified) @@ -39,12 +41,13 @@ import Data.Time import Galley.API.Error import Galley.App import qualified Galley.Data as Data +import Galley.Data.LegalHold (isTeamLegalholdWhitelisted) import Galley.Data.Services (BotMember, newBotMember) import qualified Galley.Data.Types as DataTypes import qualified Galley.External as External import Galley.Intra.Push import Galley.Intra.User -import Galley.Options (optSettings, setFederationDomain) +import Galley.Options (optSettings, setFeatureFlags, setFederationDomain) import Galley.Types import Galley.Types.Conversations.Members (RemoteMember (..)) import qualified Galley.Types.Conversations.Members as Members @@ -551,3 +554,75 @@ catMembers :: catMembers localDomain ls rs = map (((`Qualified` localDomain) . memId) &&& memConvRoleName) ls <> map ((unTagged . rmId) &&& rmConvRoleName) rs + +-------------------------------------------------------------------------------- +-- Legalhold + +userLHEnabled :: UserLegalHoldStatus -> Bool +userLHEnabled = \case + UserLegalHoldEnabled -> True + UserLegalHoldPending -> True + UserLegalHoldDisabled -> False + UserLegalHoldNoConsent -> False + +data ConsentGiven = ConsentGiven | ConsentNotGiven + deriving (Eq, Ord, Show) + +consentGiven :: UserLegalHoldStatus -> ConsentGiven +consentGiven = \case + UserLegalHoldDisabled -> ConsentGiven + UserLegalHoldPending -> ConsentGiven + UserLegalHoldEnabled -> ConsentGiven + UserLegalHoldNoConsent -> ConsentNotGiven + +checkConsent :: Map UserId TeamId -> UserId -> Galley ConsentGiven +checkConsent teamsOfUsers other = do + consentGiven <$> getLHStatus (Map.lookup other teamsOfUsers) other + +-- Get legalhold status of user. Defaults to 'defUserLegalHoldStatus' if user +-- doesn't belong to a team. +getLHStatus :: Maybe TeamId -> UserId -> Galley UserLegalHoldStatus +getLHStatus teamOfUser other = do + case teamOfUser of + Nothing -> pure defUserLegalHoldStatus + Just team -> do + mMember <- Data.teamMember team other + pure $ maybe defUserLegalHoldStatus (view legalHoldStatus) mMember + +anyLegalholdActivated :: [UserId] -> Galley Bool +anyLegalholdActivated uids = do + view (options . optSettings . setFeatureFlags . flagLegalHold) >>= \case + FeatureLegalHoldDisabledPermanently -> pure False + FeatureLegalHoldDisabledByDefault -> check + FeatureLegalHoldWhitelistTeamsAndImplicitConsent -> check + where + check = do + flip anyM (chunksOf 32 uids) $ \uidsPage -> do + teamsOfUsers <- Data.usersTeams uidsPage + anyM (\uid -> userLHEnabled <$> getLHStatus (Map.lookup uid teamsOfUsers) uid) uidsPage + +allLegalholdConsentGiven :: [UserId] -> Galley Bool +allLegalholdConsentGiven uids = do + view (options . optSettings . setFeatureFlags . flagLegalHold) >>= \case + FeatureLegalHoldDisabledPermanently -> pure False + FeatureLegalHoldDisabledByDefault -> do + flip allM (chunksOf 32 uids) $ \uidsPage -> do + teamsOfUsers <- Data.usersTeams uidsPage + allM (\uid -> (== ConsentGiven) . consentGiven <$> getLHStatus (Map.lookup uid teamsOfUsers) uid) uidsPage + FeatureLegalHoldWhitelistTeamsAndImplicitConsent -> do + -- For this feature the implementation is more efficient. Being part of + -- a whitelisted team is equivalent to have given consent to be in a + -- conversation with user under legalhold. + flip allM (chunksOf 32 uids) $ \uidsPage -> do + teamsPage <- nub . Map.elems <$> Data.usersTeams uidsPage + allM isTeamLegalholdWhitelisted teamsPage + +-- | Add to every uid the legalhold status +getLHStatusForUsers :: [UserId] -> Galley [(UserId, UserLegalHoldStatus)] +getLHStatusForUsers uids = + mconcat + <$> ( for (chunksOf 32 uids) $ \uidsChunk -> do + teamsOfUsers <- Data.usersTeams uidsChunk + for uidsChunk $ \uid -> do + (uid,) <$> getLHStatus (Map.lookup uid teamsOfUsers) uid + ) diff --git a/services/galley/test/integration/API/Teams.hs b/services/galley/test/integration/API/Teams.hs index fccc6065b2c..040854abbd6 100644 --- a/services/galley/test/integration/API/Teams.hs +++ b/services/galley/test/integration/API/Teams.hs @@ -34,7 +34,6 @@ import Control.Lens hiding ((#), (.=)) import Control.Monad.Catch import Control.Retry import Data.Aeson hiding (json) -import Data.Aeson.Lens import Data.ByteString.Conversion import Data.ByteString.Lazy (fromStrict) import Data.Csv (FromNamedRecord (..), decodeByName) @@ -56,7 +55,6 @@ import qualified Data.Vector as V import qualified Galley.App as Galley import Galley.Options (optSettings, setEnableIndexedBillingTeamMembers, setFeatureFlags, setMaxConvSize, setMaxFanoutSize) import Galley.Types hiding (EventData (..), EventType (..), MemberUpdate (..)) -import qualified Galley.Types as Conv import Galley.Types.Conversations.Roles import Galley.Types.Teams import Galley.Types.Teams.Intra @@ -1655,81 +1653,6 @@ testUpdateTeamStatus = do const 403 === statusCode const "invalid-team-status-update" === (Error.label . responseJsonUnsafeWithMsg "error label") -checkUserUpdateEvent :: HasCallStack => UserId -> WS.WebSocket -> TestM () -checkUserUpdateEvent uid w = WS.assertMatch_ timeout w $ \notif -> do - let j = Object $ List1.head (ntfPayload notif) - let etype = j ^? key "type" . _String - let euser = j ^?! key "user" ^? key "id" . _String - etype @?= Just "user.update" - euser @?= Just (UUID.toText (toUUID uid)) - -checkUserDeleteEvent :: HasCallStack => UserId -> WS.WebSocket -> TestM () -checkUserDeleteEvent uid w = WS.assertMatch_ timeout w $ \notif -> do - let j = Object $ List1.head (ntfPayload notif) - let etype = j ^? key "type" . _String - let euser = j ^? key "id" . _String - etype @?= Just "user.delete" - euser @?= Just (UUID.toText (toUUID uid)) - -checkTeamMemberJoin :: HasCallStack => TeamId -> UserId -> WS.WebSocket -> TestM () -checkTeamMemberJoin tid uid w = WS.awaitMatch_ timeout w $ \notif -> do - ntfTransient notif @?= False - let e = List1.head (WS.unpackPayload notif) - e ^. eventType @?= MemberJoin - e ^. eventTeam @?= tid - e ^. eventData @?= Just (EdMemberJoin uid) - -checkTeamMemberLeave :: HasCallStack => TeamId -> UserId -> WS.WebSocket -> TestM () -checkTeamMemberLeave tid usr w = WS.assertMatch_ timeout w $ \notif -> do - ntfTransient notif @?= False - let e = List1.head (WS.unpackPayload notif) - e ^. eventType @?= MemberLeave - e ^. eventTeam @?= tid - e ^. eventData @?= Just (EdMemberLeave usr) - -checkTeamUpdateEvent :: (HasCallStack, MonadIO m, MonadCatch m) => TeamId -> TeamUpdateData -> WS.WebSocket -> m () -checkTeamUpdateEvent tid upd w = WS.assertMatch_ timeout w $ \notif -> do - ntfTransient notif @?= False - let e = List1.head (WS.unpackPayload notif) - e ^. eventType @?= TeamUpdate - e ^. eventTeam @?= tid - e ^. eventData @?= Just (EdTeamUpdate upd) - -checkConvCreateEvent :: HasCallStack => ConvId -> WS.WebSocket -> TestM () -checkConvCreateEvent cid w = WS.assertMatch_ timeout w $ \notif -> do - ntfTransient notif @?= False - let e = List1.head (WS.unpackPayload notif) - evtType e @?= Conv.ConvCreate - case evtData e of - Conv.EdConversation x -> cnvId x @?= cid - other -> assertFailure $ "Unexpected event data: " <> show other - -checkTeamDeleteEvent :: HasCallStack => TeamId -> WS.WebSocket -> TestM () -checkTeamDeleteEvent tid w = WS.assertMatch_ timeout w $ \notif -> do - ntfTransient notif @?= False - let e = List1.head (WS.unpackPayload notif) - e ^. eventType @?= TeamDelete - e ^. eventTeam @?= tid - e ^. eventData @?= Nothing - -checkConvDeleteEvent :: HasCallStack => Qualified ConvId -> WS.WebSocket -> TestM () -checkConvDeleteEvent cid w = WS.assertMatch_ timeout w $ \notif -> do - ntfTransient notif @?= False - let e = List1.head (WS.unpackPayload notif) - evtType e @?= Conv.ConvDelete - evtConv e @?= cid - evtData e @?= Conv.EdConvDelete - -checkConvMemberLeaveEvent :: HasCallStack => Qualified ConvId -> UserId -> WS.WebSocket -> TestM () -checkConvMemberLeaveEvent cid usr w = WS.assertMatch_ timeout w $ \notif -> do - ntfTransient notif @?= False - let e = List1.head (WS.unpackPayload notif) - evtConv e @?= cid - evtType e @?= Conv.MemberLeave - case evtData e of - Conv.EdMembersLeave mm -> mm @?= Conv.UserIdList [usr] - other -> assertFailure $ "Unexpected event data: " <> show other - postCryptoBroadcastMessageJson :: TestM () postCryptoBroadcastMessageJson = do localDomain <- viewFederationDomain diff --git a/services/galley/test/integration/API/Teams/LegalHold.hs b/services/galley/test/integration/API/Teams/LegalHold.hs index 8a1e09c999d..bc88cc85ea3 100644 --- a/services/galley/test/integration/API/Teams/LegalHold.hs +++ b/services/galley/test/integration/API/Teams/LegalHold.hs @@ -52,11 +52,13 @@ import Data.ByteString.Conversion import Data.Id import Data.Json.Util (toUTCTimeMillis) import Data.LegalHold +import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.List.NonEmpty as NonEmpty import qualified Data.List1 as List1 import qualified Data.Map.Strict as Map import Data.Misc (PlainTextPassword) import Data.PEM +import Data.Qualified (Qualified (Qualified)) import Data.Range import qualified Data.Set as Set import Data.String.Conversions (LBS, cs) @@ -87,6 +89,7 @@ import TestHelpers import TestSetup import Wire.API.Connection (UserConnection) import qualified Wire.API.Connection as Conn +import Wire.API.Conversation.Role (roleNameWireAdmin, roleNameWireMember) import qualified Wire.API.Message as Msg import qualified Wire.API.Team.Feature as Public import Wire.API.User (UserProfile (..)) @@ -138,8 +141,8 @@ testsPublic s = -} testGroup - "settings.legalholdEnabledTeams" - [ testGroup + "settings.legalholdEnabledTeams" -- FUTUREWORK: ungroup this level + [ testGroup -- FUTUREWORK: ungroup this level "teams listed" [ test s "happy flow" testInWhitelist, test s "handshake between LH device and user with old clients is blocked" testOldClientsBlockDeviceHandshake, @@ -147,10 +150,31 @@ testsPublic s = flip fmap [(a, b, c, d) | a <- [minBound ..], b <- [minBound ..], c <- [minBound ..], d <- [minBound ..]] $ \args@(a, b, c, d) -> test s (show args) $ testNoConsentBlockOne2OneConv a b c d, - test - s - "If LH is activated for other user in group conv, this user gets removed with helpful message" - testNoConsentBlockGroupConv, + testGroup + "Legalhold is activated for user A in a group conversation" + [ test s "All admins are consenting: all non-consenters get removed from conversation" (onlyIfLhWhitelisted (testNoConsentRemoveFromGroupConv LegalholderIsAdmin)), + test s "Some admins are consenting: all non-consenters get removed from conversation" (onlyIfLhWhitelisted (testNoConsentRemoveFromGroupConv BothAreAdmins)), + test s "No admins are consenting: all LH activated/pending users get removed from conversation" (onlyIfLhWhitelisted (testNoConsentRemoveFromGroupConv PeerIsAdmin)) + ], + testGroup + "Users are invited to a group conversation." + [ testGroup + "At least one invited user has activated legalhold. At least one admin of the group has given consent." + [ test + s + "If all all users in the invite have given consent then the invite succeeds and all non-consenters from the group get removed" + (onlyIfLhWhitelisted (testGroupConvInvitationHandlesLHConflicts InviteOnlyConsenters)), + test + s + "If any user in the invite has not given consent then the invite fails" + (onlyIfLhWhitelisted (testGroupConvInvitationHandlesLHConflicts InviteAlsoNonConsenters)) + ], + testGroup + "The group conversation contains legalhold activated users." + [ test s "If any user in the invite has not given consent then the invite fails" (onlyIfLhWhitelisted testNoConsentCannotBeInvited) + ] + ], + test s "Cannot create conversation with both LH activated and non-consenting users" (onlyIfLhWhitelisted testCannotCreateGroupWithUsersInConflict), test s "bench hack" testBenchHack, test s "User cannot fetch prekeys of LH users if consent is missing" (testClaimKeys TCKConsentMissing), test s "User cannot fetch prekeys of LH users: if user has old client" (testClaimKeys TCKOldClient), @@ -773,16 +797,6 @@ testOldClientsBlockDeviceHandshake = do -- legalholder2 LH device missing ] - errWith :: (HasCallStack, Typeable a, FromJSON a) => Int -> (a -> Bool) -> ResponseLBS -> TestM () - errWith wantStatus wantBody rsp = liftIO $ do - assertEqual "" wantStatus (statusCode rsp) - assertBool - (show $ responseBody rsp) - ( case responseJsonMaybe rsp of - Nothing -> False - Just bdy -> wantBody bdy - ) - -- LH devices are treated as clients that have the ClientSupportsLegalholdImplicitConsent -- capability (so LH doesn't break for users who have LH devices; it sounds silly, but -- it's good to test this, since it did require adding a few lines of production code in @@ -917,11 +931,196 @@ testNoConsentBlockOne2OneConv connectFirst teamPeer approveLH testPendingConnect postConnection legalholder peer !!! do testResponse 412 (Just "missing-legalhold-consent") postConnection peer legalholder !!! do testResponse 412 (Just "missing-legalhold-consent") -testNoConsentBlockGroupConv :: TestM () -testNoConsentBlockGroupConv = do - -- "If LH is activated for other user in group conv, this user gets removed with helpful message" - -- tracked here: https://wearezeta.atlassian.net/browse/SQSERVICES-428 - pure () +data GroupConvAdmin + = LegalholderIsAdmin + | PeerIsAdmin + | BothAreAdmins + deriving (Show, Eq, Ord, Bounded, Enum) + +testNoConsentRemoveFromGroupConv :: GroupConvAdmin -> HasCallStack => TestM () +testNoConsentRemoveFromGroupConv whoIsAdmin = do + (legalholder :: UserId, tid) <- createBindingTeam + (peer :: UserId, teamPeer) <- createBindingTeam + galley <- view tsGalley + + let enableLHForLegalholder :: HasCallStack => TestM () + enableLHForLegalholder = do + requestLegalHoldDevice legalholder legalholder tid !!! testResponse 201 Nothing + approveLegalHoldDevice (Just defPassword) legalholder legalholder tid !!! testResponse 200 Nothing + UserLegalHoldStatusResponse userStatus _ _ <- getUserStatusTyped' galley legalholder tid + liftIO $ assertEqual "approving should change status" UserLegalHoldEnabled userStatus + + cannon <- view tsCannon + + putLHWhitelistTeam tid !!! const 200 === statusCode + WS.bracketR2 cannon legalholder peer $ \(legalholderWs, peerWs) -> withDummyTestServiceForTeam legalholder tid $ \_chan -> do + ensureQueueEmpty + + postConnection legalholder peer !!! const 201 === statusCode + void $ putConnection peer legalholder Conn.Accepted (legalholder, tid, peer, roleNameWireMember) + PeerIsAdmin -> (peer, teamPeer, legalholder, roleNameWireMember) + BothAreAdmins -> (legalholder, tid, peer, roleNameWireAdmin) + + convId <- createTeamConvWithRole inviter tidInviter [invitee] (Just "group chat with external peer") Nothing Nothing inviteeRole + mapM_ (assertConvMemberWithRole roleNameWireAdmin convId) ([inviter] <> [invitee | whoIsAdmin == BothAreAdmins]) + mapM_ (assertConvMemberWithRole roleNameWireMember convId) [invitee | whoIsAdmin /= BothAreAdmins] + pure convId + + checkConvCreateEvent convId legalholderWs + checkConvCreateEvent convId peerWs + + assertConvMember legalholder convId + assertConvMember peer convId + + void enableLHForLegalholder + + localdomain <- viewFederationDomain + + case whoIsAdmin of + LegalholderIsAdmin -> do + assertConvMember legalholder convId + assertNotConvMember peer convId + checkConvMemberLeaveEvent (Qualified convId localdomain) peer legalholderWs + checkConvMemberLeaveEvent (Qualified convId localdomain) peer peerWs + PeerIsAdmin -> do + assertConvMember peer convId + assertNotConvMember legalholder convId + checkConvMemberLeaveEvent (Qualified convId localdomain) legalholder legalholderWs + checkConvMemberLeaveEvent (Qualified convId localdomain) legalholder peerWs + BothAreAdmins -> do + assertConvMember legalholder convId + assertNotConvMember peer convId + checkConvMemberLeaveEvent (Qualified convId localdomain) peer legalholderWs + checkConvMemberLeaveEvent (Qualified convId localdomain) peer peerWs + +data GroupConvInvCase = InviteOnlyConsenters | InviteAlsoNonConsenters + deriving (Show, Eq, Ord, Bounded, Enum) + +testGroupConvInvitationHandlesLHConflicts :: HasCallStack => GroupConvInvCase -> TestM () +testGroupConvInvitationHandlesLHConflicts inviteCase = do + -- team that is legalhold whitelisted + (legalholder :: UserId, tid) <- createBindingTeam + userWithConsent <- (^. userId) <$> addUserToTeam legalholder tid + userWithConsent2 <- (^. userId) <$> addUserToTeam legalholder tid + ensureQueueEmpty + putLHWhitelistTeam tid !!! const 200 === statusCode + + -- team without legalhold + (peer :: UserId, teamPeer) <- createBindingTeam + peer2 <- (^. userId) <$> addUserToTeam peer teamPeer + ensureQueueEmpty + + do + postConnection userWithConsent peer !!! const 201 === statusCode + void $ putConnection peer userWithConsent Conn.Accepted do + -- conversation with 1) userWithConsent and 2) peer + convId <- createTeamConvWithRole userWithConsent tid [peer] (Just "corp + us") Nothing Nothing roleNameWireAdmin + + -- activate legalhold for legalholder + do + galley <- view tsGalley + requestLegalHoldDevice legalholder legalholder tid !!! testResponse 201 Nothing + approveLegalHoldDevice (Just defPassword) legalholder legalholder tid !!! testResponse 200 Nothing + UserLegalHoldStatusResponse userStatus _ _ <- getUserStatusTyped' galley legalholder tid + liftIO $ assertEqual "approving should change status" UserLegalHoldEnabled userStatus + + case inviteCase of + InviteOnlyConsenters -> do + API.Util.postMembers userWithConsent (List1.list1 legalholder [userWithConsent2]) convId + !!! const 200 === statusCode + + assertConvMember legalholder convId + assertConvMember userWithConsent2 convId + assertNotConvMember peer convId + InviteAlsoNonConsenters -> do + API.Util.postMembers userWithConsent (List1.list1 legalholder [peer2]) convId + >>= errWith 412 (\err -> Error.label err == "missing-legalhold-consent") + +testNoConsentCannotBeInvited :: HasCallStack => TestM () +testNoConsentCannotBeInvited = do + -- team that is legalhold whitelisted + (legalholder :: UserId, tid) <- createBindingTeam + userLHNotActivated <- (^. userId) <$> addUserToTeam legalholder tid + ensureQueueEmpty + putLHWhitelistTeam tid !!! const 200 === statusCode + + -- team without legalhold + (peer :: UserId, teamPeer) <- createBindingTeam + peer2 <- (^. userId) <$> addUserToTeam peer teamPeer + ensureQueueEmpty + + do + postConnection userLHNotActivated peer !!! const 201 === statusCode + void $ putConnection peer userLHNotActivated Conn.Accepted do + convId <- createTeamConvWithRole userLHNotActivated tid [legalholder] (Just "corp + us") Nothing Nothing roleNameWireAdmin + + API.Util.postMembers userLHNotActivated (List1.list1 peer []) convId + !!! const 200 === statusCode + + -- activate legalhold for legalholder + do + galley <- view tsGalley + requestLegalHoldDevice legalholder legalholder tid !!! testResponse 201 Nothing + approveLegalHoldDevice (Just defPassword) legalholder legalholder tid !!! testResponse 200 Nothing + UserLegalHoldStatusResponse userStatus _ _ <- getUserStatusTyped' galley legalholder tid + liftIO $ assertEqual "approving should change status" UserLegalHoldEnabled userStatus + + API.Util.postMembers userLHNotActivated (List1.list1 peer2 []) convId + >>= errWith 412 (\err -> Error.label err == "missing-legalhold-consent") + + localdomain <- viewFederationDomain + API.Util.postQualifiedMembers userLHNotActivated ((Qualified peer2 localdomain) :| []) convId + >>= errWith 412 (\err -> Error.label err == "missing-legalhold-consent") + +testCannotCreateGroupWithUsersInConflict :: HasCallStack => TestM () +testCannotCreateGroupWithUsersInConflict = do + -- team that is legalhold whitelisted + (legalholder :: UserId, tid) <- createBindingTeam + userLHNotActivated <- (^. userId) <$> addUserToTeam legalholder tid + ensureQueueEmpty + putLHWhitelistTeam tid !!! const 200 === statusCode + + -- team without legalhold + (peer :: UserId, teamPeer) <- createBindingTeam + peer2 <- (^. userId) <$> addUserToTeam peer teamPeer + ensureQueueEmpty + + do + postConnection userLHNotActivated peer !!! const 201 === statusCode + void $ putConnection peer userLHNotActivated Conn.Accepted do + createTeamConvAccessRaw userLHNotActivated tid [peer, legalholder] (Just "corp + us") Nothing Nothing Nothing (Just roleNameWireMember) + !!! const 201 === statusCode + + -- activate legalhold for legalholder + do + galley <- view tsGalley + requestLegalHoldDevice legalholder legalholder tid !!! testResponse 201 Nothing + approveLegalHoldDevice (Just defPassword) legalholder legalholder tid !!! testResponse 200 Nothing + UserLegalHoldStatusResponse userStatus _ _ <- getUserStatusTyped' galley legalholder tid + liftIO $ assertEqual "approving should change status" UserLegalHoldEnabled userStatus + + createTeamConvAccessRaw userLHNotActivated tid [peer2, legalholder] (Just "corp + us") Nothing Nothing Nothing (Just roleNameWireMember) + >>= errWith 412 (\err -> Error.label err == "missing-legalhold-consent") data TestClaimKeys = TCKConsentMissing @@ -1613,3 +1812,13 @@ deleteLHWhitelistTeam' g tid = do ( g . paths ["i", "legalhold", "whitelisted-teams", toByteString' tid] ) + +errWith :: (HasCallStack, Typeable a, FromJSON a) => Int -> (a -> Bool) -> ResponseLBS -> TestM () +errWith wantStatus wantBody rsp = liftIO $ do + assertEqual "" wantStatus (statusCode rsp) + assertBool + (show $ responseBody rsp) + ( case responseJsonMaybe rsp of + Nothing -> False + Just bdy -> wantBody bdy + ) diff --git a/services/galley/test/integration/API/Util.hs b/services/galley/test/integration/API/Util.hs index f471cd87047..ba5ed1116b1 100644 --- a/services/galley/test/integration/API/Util.hs +++ b/services/galley/test/integration/API/Util.hs @@ -66,7 +66,8 @@ import Data.UUID.V4 import Galley.Intra.User (chunkify) import qualified Galley.Options as Opts import qualified Galley.Run as Run -import Galley.Types hiding (InternalMember (..)) +import Galley.Types hiding (InternalMember, MemberJoin, MemberLeave, memConvRoleName, memId, memOtrArchived, memOtrArchivedRef, memOtrMuted, memOtrMutedRef) +import qualified Galley.Types as Conv import Galley.Types.Conversations.Roles hiding (DeleteConversation) import Galley.Types.Teams hiding (Event, EventType (..)) import qualified Galley.Types.Teams as Team @@ -97,6 +98,7 @@ import Util.Options import Web.Cookie import qualified Wire.API.Conversation as Public import Wire.API.Conversation.Member (Member (..)) +import Wire.API.Event.Team (EventType (MemberJoin, MemberLeave, TeamDelete, TeamUpdate)) import qualified Wire.API.Event.Team as TE import Wire.API.Federation.GRPC.Types (FederatedRequest, OutwardResponse (..)) import qualified Wire.API.Federation.GRPC.Types as F @@ -1223,7 +1225,7 @@ wsAssertMemberJoinWithRole conv usr new role n = do let e = List1.head (WS.unpackPayload n) ntfTransient n @?= False evtConv e @?= conv - evtType e @?= MemberJoin + evtType e @?= Conv.MemberJoin evtFrom e @?= usr evtData e @?= EdMembersJoin (SimpleMembers (fmap (`SimpleMember` role) new)) @@ -1235,7 +1237,7 @@ wsAssertMemberUpdateWithRole conv usr target role n = do evtType e @?= MemberStateUpdate evtFrom e @?= usr case evtData e of - Galley.Types.EdMemberUpdate mis -> do + Conv.EdMemberUpdate mis -> do assertEqual "target" (Just target) (misTarget mis) assertEqual "conversation_role" (Just role) (misConvRoleName mis) x -> assertFailure $ "Unexpected event data: " ++ show x @@ -1263,7 +1265,7 @@ wsAssertMemberLeave conv usr old n = do let e = List1.head (WS.unpackPayload n) ntfTransient n @?= False evtConv e @?= conv - evtType e @?= MemberLeave + evtType e @?= Conv.MemberLeave evtFrom e @?= usr sorted (evtData e) @?= sorted (EdMembersLeave (UserIdList old)) where @@ -1946,3 +1948,81 @@ aFewTimesAssertBool :: HasCallStack => String -> (a -> Bool) -> TestM a -> TestM aFewTimesAssertBool msg good action = do result <- aFewTimes action good liftIO $ assertBool msg (good result) + +checkUserUpdateEvent :: HasCallStack => UserId -> WS.WebSocket -> TestM () +checkUserUpdateEvent uid w = WS.assertMatch_ checkTimeout w $ \notif -> do + let j = Object $ List1.head (ntfPayload notif) + let etype = j ^? key "type" . _String + let euser = j ^?! key "user" ^? key "id" . _String + etype @?= Just "user.update" + euser @?= Just (UUID.toText (toUUID uid)) + +checkUserDeleteEvent :: HasCallStack => UserId -> WS.WebSocket -> TestM () +checkUserDeleteEvent uid w = WS.assertMatch_ checkTimeout w $ \notif -> do + let j = Object $ List1.head (ntfPayload notif) + let etype = j ^? key "type" . _String + let euser = j ^? key "id" . _String + etype @?= Just "user.delete" + euser @?= Just (UUID.toText (toUUID uid)) + +checkTeamMemberJoin :: HasCallStack => TeamId -> UserId -> WS.WebSocket -> TestM () +checkTeamMemberJoin tid uid w = WS.awaitMatch_ checkTimeout w $ \notif -> do + ntfTransient notif @?= False + let e = List1.head (WS.unpackPayload notif) + e ^. eventType @?= MemberJoin + e ^. eventTeam @?= tid + e ^. eventData @?= Just (EdMemberJoin uid) + +checkTeamMemberLeave :: HasCallStack => TeamId -> UserId -> WS.WebSocket -> TestM () +checkTeamMemberLeave tid usr w = WS.assertMatch_ checkTimeout w $ \notif -> do + ntfTransient notif @?= False + let e = List1.head (WS.unpackPayload notif) + e ^. eventType @?= MemberLeave + e ^. eventTeam @?= tid + e ^. eventData @?= Just (EdMemberLeave usr) + +checkTeamUpdateEvent :: (HasCallStack, MonadIO m, MonadCatch m) => TeamId -> TeamUpdateData -> WS.WebSocket -> m () +checkTeamUpdateEvent tid upd w = WS.assertMatch_ checkTimeout w $ \notif -> do + ntfTransient notif @?= False + let e = List1.head (WS.unpackPayload notif) + e ^. eventType @?= TeamUpdate + e ^. eventTeam @?= tid + e ^. eventData @?= Just (EdTeamUpdate upd) + +checkConvCreateEvent :: HasCallStack => ConvId -> WS.WebSocket -> TestM () +checkConvCreateEvent cid w = WS.assertMatch_ checkTimeout w $ \notif -> do + ntfTransient notif @?= False + let e = List1.head (WS.unpackPayload notif) + evtType e @?= Conv.ConvCreate + case evtData e of + Conv.EdConversation x -> cnvId x @?= cid + other -> assertFailure $ "Unexpected event data: " <> show other + +checkTeamDeleteEvent :: HasCallStack => TeamId -> WS.WebSocket -> TestM () +checkTeamDeleteEvent tid w = WS.assertMatch_ checkTimeout w $ \notif -> do + ntfTransient notif @?= False + let e = List1.head (WS.unpackPayload notif) + e ^. eventType @?= TeamDelete + e ^. eventTeam @?= tid + e ^. eventData @?= Nothing + +checkConvDeleteEvent :: HasCallStack => Qualified ConvId -> WS.WebSocket -> TestM () +checkConvDeleteEvent cid w = WS.assertMatch_ checkTimeout w $ \notif -> do + ntfTransient notif @?= False + let e = List1.head (WS.unpackPayload notif) + evtType e @?= Conv.ConvDelete + evtConv e @?= cid + evtData e @?= Conv.EdConvDelete + +checkConvMemberLeaveEvent :: HasCallStack => Qualified ConvId -> UserId -> WS.WebSocket -> TestM () +checkConvMemberLeaveEvent cid usr w = WS.assertMatch_ checkTimeout w $ \notif -> do + ntfTransient notif @?= False + let e = List1.head (WS.unpackPayload notif) + evtConv e @?= cid + evtType e @?= Conv.MemberLeave + case evtData e of + Conv.EdMembersLeave mm -> mm @?= Conv.UserIdList [usr] + other -> assertFailure $ "Unexpected event data: " <> show other + +checkTimeout :: WS.Timeout +checkTimeout = 3 # Second