From 3a9ec892789c87334a922d6c1bba077961db030a Mon Sep 17 00:00:00 2001 From: Stefan Matting Date: Wed, 14 Sep 2022 15:04:29 +0200 Subject: [PATCH 1/6] Implement local and remote convs --- .../src/Wire/API/Federation/API/Galley.hs | 10 ++ services/galley/galley.cabal | 1 + services/galley/src/Galley/API/Clients.hs | 92 ++++++++++++++++++- services/galley/src/Galley/API/Federation.hs | 32 ++++++- services/galley/src/Galley/API/MLS/Removal.hs | 62 ++++++++++++- 5 files changed, 189 insertions(+), 8 deletions(-) diff --git a/libs/wire-api-federation/src/Wire/API/Federation/API/Galley.hs b/libs/wire-api-federation/src/Wire/API/Federation/API/Galley.hs index b654911291..121f182f68 100644 --- a/libs/wire-api-federation/src/Wire/API/Federation/API/Galley.hs +++ b/libs/wire-api-federation/src/Wire/API/Federation/API/Galley.hs @@ -69,6 +69,16 @@ type GalleyApi = :<|> FedEndpoint "mls-welcome" MLSWelcomeRequest EmptyResponse :<|> FedEndpoint "on-mls-message-sent" RemoteMLSMessage EmptyResponse :<|> FedEndpoint "send-mls-message" MessageSendRequest MLSMessageResponse + :<|> FedEndpoint "on-client-removed" ClientRemovedRequest EmptyResponse + +data ClientRemovedRequest = ClientRemovedRequest + { crrUser :: UserId, + crrClient :: ClientId, + crrConvs :: [ConvId] + } + deriving stock (Eq, Show, Generic) + deriving (Arbitrary) via (GenericUniform ClientRemovedRequest) + deriving (FromJSON, ToJSON) via (CustomEncoded ClientRemovedRequest) data GetConversationsRequest = GetConversationsRequest { gcrUserId :: UserId, diff --git a/services/galley/galley.cabal b/services/galley/galley.cabal index be5ca7e843..4c18ff8a8e 100644 --- a/services/galley/galley.cabal +++ b/services/galley/galley.cabal @@ -206,6 +206,7 @@ library , extra >=1.3 , galley-types >=0.65.0 , gundeck-types >=1.35.2 + , hex , HsOpenSSL >=0.11 , HsOpenSSL-x509-system >=0.1 , http-client >=0.4 diff --git a/services/galley/src/Galley/API/Clients.hs b/services/galley/src/Galley/API/Clients.hs index c4d4859a38..b314f452ed 100644 --- a/services/galley/src/Galley/API/Clients.hs +++ b/services/galley/src/Galley/API/Clients.hs @@ -22,16 +22,40 @@ module Galley.API.Clients ) where +import Data.Hex import Data.Id +import Data.Proxy +import Data.Qualified +import Data.Range +import Data.String.Conversions +import qualified Data.Text as T +import Data.Time +import Galley.API.Error +import Galley.API.MLS.Removal +import qualified Galley.API.Query as Query +import Galley.API.Util import Galley.Effects import qualified Galley.Effects.BrigAccess as E import qualified Galley.Effects.ClientStore as E +import Galley.Effects.ConversationStore (getConversation) +import Galley.Effects.FederatorAccess +import Galley.Effects.ProposalStore (ProposalStore) +import Galley.Env import Galley.Types.Clients (clientIds, fromUserClients) import Imports import Network.Wai import Network.Wai.Predicate hiding (setStatus) import Network.Wai.Utilities import Polysemy +import qualified Polysemy.Error as Poly +import Polysemy.Input +import qualified Polysemy.TinyLog as P +import qualified System.Logger as Log +import Wire.API.Conversation hiding (Member) +import Wire.API.Federation.API +import Wire.API.Federation.API.Galley (ClientRemovedRequest (ClientRemovedRequest)) +import Wire.API.Routes.MultiTablePaging +import Wire.Sem.Paging.Cassandra (CassandraPaging) getClientsH :: Members '[BrigAccess, ClientStore] r => @@ -61,9 +85,71 @@ addClientH (usr ::: clt) = do pure empty rmClientH :: - Member ClientStore r => + forall p1 r. + ( p1 ~ CassandraPaging, + Members + '[ ClientStore, + ConversationStore, + ExternalAccess, + FederatorAccess, + GundeckAccess, + Input Env, + Input (Local ()), + Input UTCTime, + ListItems p1 ConvId, + ListItems p1 (Remote ConvId), + MemberStore, + Poly.Error InternalError, + ProposalStore, + P.TinyLog + ] + r + ) => UserId ::: ClientId -> Sem r Response -rmClientH (usr ::: clt) = do - E.deleteClient usr clt +rmClientH (usr ::: cid) = do + lusr <- qualifyLocal usr + let nRange1000 = toRange (Proxy @1000) :: Range 1 1000 Int32 + firstConvIds <- Query.conversationIdsPageFrom lusr (GetPaginatedConversationIds Nothing nRange1000) + goConvs nRange1000 firstConvIds lusr + + E.deleteClient usr cid pure empty + where + rpc = fedClient @'Galley @"on-client-removed" + goConvs :: Range 1 1000 Int32 -> ConvIdsPage -> Local UserId -> Sem r () + goConvs range page lusr = do + loc :: Local () <- input + let (localConvs, remoteConvs) = partitionQualified loc (mtpResults page) + for_ localConvs $ \convId -> do + mConv <- getConversation convId + for_ mConv $ \conv -> do + lconv <- qualifyLocal conv + removeClient lconv (qUntagged lusr) cid + traverse_ removeRemoteMLSClients (rangedChunks remoteConvs) + when (mtpHasMore page) $ do + let nextState = mtpPagingState page + nextQuery = GetPaginatedConversationIds (Just nextState) range + newCids <- Query.conversationIdsPageFrom lusr nextQuery + goConvs range newCids lusr + + removeRemoteMLSClients :: Range 1 1000 [Remote ConvId] -> Sem r () + removeRemoteMLSClients cids = do + for_ (bucketRemote (fromRange cids)) $ \remoteConvs -> do + runFederatedEither remoteConvs (rpc (ClientRemovedRequest usr cid (tUnqualified remoteConvs))) + >>= logAndIgnoreError "Error in onConversationUpdated call" usr + + logAndIgnoreError message usr' res = do + case res of + Left federationError -> + P.err + ( Log.msg + ( "Federation error while notifying remote backends of a client deletion (Galley). " + <> message + <> " " + <> show federationError + ) + . Log.field "user" (show usr') + . Log.field "client" (hex . T.unpack . client $ cid) + ) + Right _ -> pure () diff --git a/services/galley/src/Galley/API/Federation.hs b/services/galley/src/Galley/API/Federation.hs index fc70eafd35..acb3cb4a4c 100644 --- a/services/galley/src/Galley/API/Federation.hs +++ b/services/galley/src/Galley/API/Federation.hs @@ -50,6 +50,7 @@ import Galley.App import qualified Galley.Data.Conversation as Data import Galley.Effects import qualified Galley.Effects.BrigAccess as E +import Galley.Effects.ConversationStore (getConversation) import qualified Galley.Effects.ConversationStore as E import qualified Galley.Effects.FireAndForget as E import qualified Galley.Effects.MemberStore as E @@ -79,7 +80,7 @@ import Wire.API.Error.Galley import Wire.API.Event.Conversation import Wire.API.Federation.API import Wire.API.Federation.API.Common (EmptyResponse (..)) -import Wire.API.Federation.API.Galley (ConversationUpdateResponse) +import Wire.API.Federation.API.Galley (ClientRemovedRequest, ConversationUpdateResponse) import qualified Wire.API.Federation.API.Galley as F import Wire.API.Federation.Error import Wire.API.MLS.Credential @@ -108,6 +109,35 @@ federationSitemap = :<|> Named @"mls-welcome" mlsSendWelcome :<|> Named @"on-mls-message-sent" onMLSMessageSent :<|> Named @"send-mls-message" sendMLSMessage + :<|> Named @"on-client-removed" onClientRemoved + +onClientRemoved :: + ( Members + '[ ConversationStore, + Error InternalError, + ExternalAccess, + FederatorAccess, + GundeckAccess, + Input Env, + Input (Local ()), + Input UTCTime, + MemberStore, + ProposalStore, + TinyLog + ] + r + ) => + Domain -> + ClientRemovedRequest -> + Sem r EmptyResponse +onClientRemoved domain req = do + let qusr = Qualified (F.crrUser req) domain + for_ (F.crrConvs req) $ \convId -> do + mConv <- getConversation convId + for mConv $ \conv -> do + lconv <- qualifyLocal conv + removeClient lconv qusr (F.crrClient req) + pure EmptyResponse onConversationCreated :: Members diff --git a/services/galley/src/Galley/API/MLS/Removal.hs b/services/galley/src/Galley/API/MLS/Removal.hs index 04b3c6f28f..43c6375a1c 100644 --- a/services/galley/src/Galley/API/MLS/Removal.hs +++ b/services/galley/src/Galley/API/MLS/Removal.hs @@ -16,7 +16,9 @@ -- with this program. If not, see . module Galley.API.MLS.Removal - ( removeUserWithClientMap, + ( removeClientsWithClientMap, + removeClient, + removeUserWithClientMap, removeUser, ) where @@ -26,6 +28,7 @@ import Control.Lens (view) import Data.Id import qualified Data.Map as Map import Data.Qualified +import qualified Data.Set as Set import Data.Time import Galley.API.Error import Galley.API.MLS.Propagate @@ -42,12 +45,14 @@ import Polysemy.Input import Polysemy.TinyLog import Wire.API.Conversation.Protocol import Wire.API.MLS.Credential +import Wire.API.MLS.KeyPackage import Wire.API.MLS.Keys import Wire.API.MLS.Message import Wire.API.MLS.Proposal import Wire.API.MLS.Serialisation -removeUserWithClientMap :: +-- | Send remove proposals for a set of clients to clients in the ClientMap. +removeClientsWithClientMap :: ( Members '[ Input UTCTime, TinyLog, @@ -61,16 +66,17 @@ removeUserWithClientMap :: r ) => Local Data.Conversation -> + Set (ClientId, KeyPackageRef) -> ClientMap -> Qualified UserId -> Sem r () -removeUserWithClientMap lc cm qusr = do +removeClientsWithClientMap lc cs cm qusr = do case Data.convProtocol (tUnqualified lc) of ProtocolProteus -> pure () ProtocolMLS meta -> do keyPair <- mlsKeyPair_ed25519 <$> (inputs (view mlsKeys) <*> pure RemovalPurpose) (secKey, pubKey) <- note (InternalErrorWithDescription "backend removal key missing") $ keyPair - for_ (Map.findWithDefault mempty qusr cm) $ \(_client, kpref) -> do + for_ cs $ \(_client, kpref) -> do let proposal = mkRemoveProposal kpref msg = mkSignedMessage secKey pubKey (cnvmlsGroupId meta) (cnvmlsEpoch meta) (ProposalMessage proposal) msgEncoded = encodeMLS' msg @@ -81,6 +87,54 @@ removeUserWithClientMap lc cm qusr = do proposal propagateMessage qusr lc cm Nothing msgEncoded +-- | Send remove proposals for a single client of a user to the local conversation. +removeClient :: + ( Members + '[ Error InternalError, + ExternalAccess, + FederatorAccess, + GundeckAccess, + Input Env, + Input UTCTime, + MemberStore, + ProposalStore, + TinyLog + ] + r + ) => + Local Data.Conversation -> + Qualified UserId -> + ClientId -> + Sem r () +removeClient lc qusr cid = do + cm <- lookupMLSClients (fmap Data.convId lc) + let cidAndKP = Set.filter ((==) cid . fst) $ Map.findWithDefault mempty qusr cm + removeClientsWithClientMap lc cidAndKP cm qusr + +-- | Send remove proposals for all clients of the user to clients in the ClientMap. +-- +-- All clients of the user have to be contained in the ClientMap. +removeUserWithClientMap :: + ( Members + '[ Input UTCTime, + TinyLog, + ExternalAccess, + FederatorAccess, + GundeckAccess, + Error InternalError, + ProposalStore, + Input Env + ] + r + ) => + Local Data.Conversation -> + ClientMap -> + Qualified UserId -> + Sem r () +removeUserWithClientMap lc cm qusr = + removeClientsWithClientMap lc (Map.findWithDefault mempty qusr cm) cm qusr + +-- | Send remove proposals for all clients of the user to the local conversation. removeUser :: ( Members '[ Error InternalError, From 26e675e2bba1e9ceb1c63985b76222d85d93cbd3 Mon Sep 17 00:00:00 2001 From: Stefan Matting Date: Wed, 14 Sep 2022 15:03:47 +0200 Subject: [PATCH 2/6] Add two test cases --- services/galley/test/integration/API/MLS.hs | 82 ++++++++++++++++++++- 1 file changed, 81 insertions(+), 1 deletion(-) diff --git a/services/galley/test/integration/API/MLS.hs b/services/galley/test/integration/API/MLS.hs index 9e89c58315..20598d7c07 100644 --- a/services/galley/test/integration/API/MLS.hs +++ b/services/galley/test/integration/API/MLS.hs @@ -159,7 +159,9 @@ tests s = s "local conversation, local committer leaving" testBackendRemoveProposalLocalConvLocalLeaverCommitter, - test s "local conversation, remote user leaving" testBackendRemoveProposalLocalConvRemoteLeaver + test s "local conversation, remote user leaving" testBackendRemoveProposalLocalConvRemoteLeaver, + test s "local conversation, local client deleted" testBackendRemoveProposalLocalConvLocalClient, + test s "local conversation, remote client deleted" testBackendRemoveProposalLocalConvRemoteClient ], testGroup "Protocol mismatch" @@ -1630,3 +1632,81 @@ testBackendRemoveProposalLocalConvRemoteLeaver = do for_ bobClients $ \(_, ref) -> WS.assertMatch_ (5 # WS.Second) wsA $ wsAssertBackendRemoveProposal bob qcnv ref + +-- for_ kprefs $ \kp -> +-- WS.assertMatch_ (5 # WS.Second) wsA $ \notification -> +-- void $ +-- wsAssertBackendRemoveProposal (pUserId bob) conversation kp notification + +testBackendRemoveProposalLocalConvLocalClient :: TestM () +testBackendRemoveProposalLocalConvLocalClient = do + [alice, bob] <- createAndConnectUsers [Nothing, Nothing] + + runMLSTest $ do + [alice1, bob1, bob2] <- traverse createMLSClient [alice, bob, bob] + traverse_ uploadNewKeyPackage [bob1, bob2] + (_, qcnv) <- setupMLSGroup alice1 + void $ createAddCommit alice1 [bob] >>= sendAndConsumeCommit + [(bobA, kpBobA), (bobB, _kpBobB)] <- getClientsFromGroupState alice1 bob + + mlsBracket [alice1, bobA] $ \[wsA, wsB] -> do + liftTest $ + deleteClient (ciUser bobA) (ciClient bobA) (Just defPassword) + !!! statusCode === const 200 + + State.modify $ \mls -> + mls + { mlsMembers = Set.difference (mlsMembers mls) (Set.fromList [bobA]) + } + + WS.assertMatch_ (5 # WS.Second) wsB $ + wsAssertClientRemoved (ciClient bobA) + + msg <- WS.assertMatch (5 # WS.Second) wsA $ \notification -> do + wsAssertBackendRemoveProposal bob qcnv kpBobA notification + + for_ [alice1, bobB] $ + flip consumeMessage1 msg + + mp <- createPendingProposalCommit alice1 + events <- sendAndConsumeCommit mp + liftIO $ events @?= [] + +testBackendRemoveProposalLocalConvRemoteClient :: TestM () +testBackendRemoveProposalLocalConvRemoteClient = do + [alice, bob] <- createAndConnectUsers [Nothing, Just "faraway.example.com"] + + runMLSTest $ do + [alice1, bob1] <- traverse createMLSClient [alice, bob] + (_, qcnv) <- setupMLSGroup alice1 + commit <- createAddCommit alice1 [bob] + + let mock req = case frRPC req of + "on-conversation-updated" -> pure (Aeson.encode ()) + "on-new-remote-conversation" -> pure (Aeson.encode EmptyResponse) + "get-mls-clients" -> + pure + . Aeson.encode + . Set.fromList + . map (flip ClientInfo True) + . toList + $ [ciClient bob1] + ms -> assertFailure ("unmocked endpoint called: " <> cs ms) + + [(_, bob1KP)] <- getClientsFromGroupState alice1 bob + + void . withTempMockFederator' mock $ do + mlsBracket [alice1] $ \[wsA] -> void $ do + void $ sendAndConsumeCommit commit + + fedGalleyClient <- view tsFedGalleyClient + void $ + runFedClient + @"on-client-removed" + fedGalleyClient + (ciDomain bob1) + (ClientRemovedRequest (ciUser bob1) (ciClient bob1) [qUnqualified qcnv]) + + WS.assertMatch_ (5 # WS.Second) wsA $ + \notification -> + void $ wsAssertBackendRemoveProposal bob qcnv bob1KP notification From 6be235b0c6e4b680d3ffc964fae3615a9ef9c44d Mon Sep 17 00:00:00 2001 From: Stefan Matting Date: Wed, 14 Sep 2022 17:01:56 +0200 Subject: [PATCH 3/6] Clean up --- services/galley/test/integration/API/MLS.hs | 25 +++++++-------------- 1 file changed, 8 insertions(+), 17 deletions(-) diff --git a/services/galley/test/integration/API/MLS.hs b/services/galley/test/integration/API/MLS.hs index 20598d7c07..79f853eb50 100644 --- a/services/galley/test/integration/API/MLS.hs +++ b/services/galley/test/integration/API/MLS.hs @@ -83,10 +83,7 @@ tests s = test s "local welcome (client with no public key)" testWelcomeNoKey, test s "remote welcome" testRemoteWelcome, test s "post a remote MLS welcome message" sendRemoteMLSWelcome, - test - s - "post a remote MLS welcome message (key package ref not found)" - sendRemoteMLSWelcomeKPNotFound + test s "post a remote MLS welcome message (key package ref not found)" sendRemoteMLSWelcomeKPNotFound ], testGroup "Creation" @@ -151,14 +148,8 @@ tests s = "Backend-side External Remove Proposals" [ test s "local conversation, local user deleted" testBackendRemoveProposalLocalConvLocalUser, test s "local conversation, remote user deleted" testBackendRemoveProposalLocalConvRemoteUser, - test - s - "local conversation, creator leaving" - testBackendRemoveProposalLocalConvLocalLeaverCreator, - test - s - "local conversation, local committer leaving" - testBackendRemoveProposalLocalConvLocalLeaverCommitter, + test s "local conversation, creator leaving" testBackendRemoveProposalLocalConvLocalLeaverCreator, + test s "local conversation, local committer leaving" testBackendRemoveProposalLocalConvLocalLeaverCommitter, test s "local conversation, remote user leaving" testBackendRemoveProposalLocalConvRemoteLeaver, test s "local conversation, local client deleted" testBackendRemoveProposalLocalConvLocalClient, test s "local conversation, remote client deleted" testBackendRemoveProposalLocalConvRemoteClient @@ -752,6 +743,7 @@ testRemoteAppMessage = do "on-conversation-updated" -> pure (Aeson.encode ()) "on-new-remote-conversation" -> pure (Aeson.encode EmptyResponse) "on-mls-message-sent" -> pure (Aeson.encode EmptyResponse) + "mls-welcome" -> pure (Aeson.encode EmptyResponse) "get-mls-clients" -> pure . Aeson.encode @@ -1429,6 +1421,7 @@ testBackendRemoveProposalLocalConvRemoteUser = do "on-conversation-updated" -> pure (Aeson.encode ()) "on-new-remote-conversation" -> pure (Aeson.encode EmptyResponse) "on-mls-message-sent" -> pure (Aeson.encode EmptyResponse) + "mls-welcome" -> pure (Aeson.encode EmptyResponse) "get-mls-clients" -> pure . Aeson.encode @@ -1605,6 +1598,7 @@ testBackendRemoveProposalLocalConvRemoteLeaver = do "on-conversation-updated" -> pure (Aeson.encode ()) "on-new-remote-conversation" -> pure (Aeson.encode EmptyResponse) "on-mls-message-sent" -> pure (Aeson.encode EmptyResponse) + "mls-welcome" -> pure (Aeson.encode EmptyResponse) "get-mls-clients" -> pure . Aeson.encode @@ -1633,11 +1627,6 @@ testBackendRemoveProposalLocalConvRemoteLeaver = do WS.assertMatch_ (5 # WS.Second) wsA $ wsAssertBackendRemoveProposal bob qcnv ref --- for_ kprefs $ \kp -> --- WS.assertMatch_ (5 # WS.Second) wsA $ \notification -> --- void $ --- wsAssertBackendRemoveProposal (pUserId bob) conversation kp notification - testBackendRemoveProposalLocalConvLocalClient :: TestM () testBackendRemoveProposalLocalConvLocalClient = do [alice, bob] <- createAndConnectUsers [Nothing, Nothing] @@ -1684,6 +1673,8 @@ testBackendRemoveProposalLocalConvRemoteClient = do let mock req = case frRPC req of "on-conversation-updated" -> pure (Aeson.encode ()) "on-new-remote-conversation" -> pure (Aeson.encode EmptyResponse) + "mls-welcome" -> pure (Aeson.encode EmptyResponse) + "on-mls-message-sent" -> pure (Aeson.encode EmptyResponse) "get-mls-clients" -> pure . Aeson.encode From 8223edcd0beb6be557d8ec57a29f950c30a3ed5d Mon Sep 17 00:00:00 2001 From: Stefan Matting Date: Wed, 14 Sep 2022 17:45:20 +0200 Subject: [PATCH 4/6] Remove test that became irrelevant --- services/galley/test/integration/API/MLS.hs | 26 +-------------------- 1 file changed, 1 insertion(+), 25 deletions(-) diff --git a/services/galley/test/integration/API/MLS.hs b/services/galley/test/integration/API/MLS.hs index 79f853eb50..0927979dce 100644 --- a/services/galley/test/integration/API/MLS.hs +++ b/services/galley/test/integration/API/MLS.hs @@ -104,8 +104,7 @@ tests s = test s "post commit that references a unknown proposal" testUnknownProposalRefCommit, test s "post commit that is not referencing all proposals" testCommitNotReferencingAllProposals, test s "admin removes user from a conversation" testAdminRemovesUserFromConv, - test s "admin removes user from a conversation but doesn't list all clients" testRemoveClientsIncomplete, - test s "anyone removes a non-existing client from a group" testRemoveDeletedClient + test s "admin removes user from a conversation but doesn't list all clients" testRemoveClientsIncomplete ], testGroup "Application Message" @@ -707,29 +706,6 @@ testRemoveClientsIncomplete = do >= sendAndConsumeCommit - - liftTest $ do - cannon <- view tsCannon - WS.bracketR cannon (qUnqualified bob) $ \ws -> do - deleteClient (qUnqualified bob) (ciClient bob2) (Just defPassword) - !!! statusCode === const 200 - -- check that the corresponding event is received - liftIO $ - WS.assertMatch_ (5 # WS.Second) ws $ - wsAssertClientRemoved (ciClient bob2) - - events <- createRemoveCommit charlie1 [bob2] >>= sendAndConsumeCommit - liftIO $ assertEqual "a non-admin received conversation events when removing a client" [] events - testRemoteAppMessage :: TestM () testRemoteAppMessage = do users@[alice, bob] <- createAndConnectUsers [Nothing, Just "bob.example.com"] From 732223741f59c5091c9635e2eaca246c545b4cc0 Mon Sep 17 00:00:00 2001 From: Stefan Matting Date: Wed, 14 Sep 2022 17:49:28 +0200 Subject: [PATCH 5/6] Add changelog --- changelog.d/2-features/mls-remote-proposals-on-client-deletion | 1 + 1 file changed, 1 insertion(+) create mode 100644 changelog.d/2-features/mls-remote-proposals-on-client-deletion diff --git a/changelog.d/2-features/mls-remote-proposals-on-client-deletion b/changelog.d/2-features/mls-remote-proposals-on-client-deletion new file mode 100644 index 0000000000..0b0df17eae --- /dev/null +++ b/changelog.d/2-features/mls-remote-proposals-on-client-deletion @@ -0,0 +1 @@ +Deleting clients creates MLS remove proposals From 85575f030ce666b614aebe6da49846b59077f281 Mon Sep 17 00:00:00 2001 From: Stefan Matting Date: Thu, 15 Sep 2022 13:48:39 +0200 Subject: [PATCH 6/6] Follow suggetions from PR review --- services/galley/src/Galley/API/Clients.hs | 42 ++++++++++----------- services/galley/test/integration/API/MLS.hs | 15 ++++---- 2 files changed, 27 insertions(+), 30 deletions(-) diff --git a/services/galley/src/Galley/API/Clients.hs b/services/galley/src/Galley/API/Clients.hs index b314f452ed..95bf989479 100644 --- a/services/galley/src/Galley/API/Clients.hs +++ b/services/galley/src/Galley/API/Clients.hs @@ -22,6 +22,7 @@ module Galley.API.Clients ) where +import Data.Either.Combinators (whenLeft) import Data.Hex import Data.Id import Data.Proxy @@ -44,10 +45,10 @@ import Galley.Env import Galley.Types.Clients (clientIds, fromUserClients) import Imports import Network.Wai -import Network.Wai.Predicate hiding (setStatus) -import Network.Wai.Utilities +import Network.Wai.Predicate hiding (Error, setStatus) +import Network.Wai.Utilities hiding (Error) import Polysemy -import qualified Polysemy.Error as Poly +import Polysemy.Error import Polysemy.Input import qualified Polysemy.TinyLog as P import qualified System.Logger as Log @@ -99,7 +100,7 @@ rmClientH :: ListItems p1 ConvId, ListItems p1 (Remote ConvId), MemberStore, - Poly.Error InternalError, + Error InternalError, ProposalStore, P.TinyLog ] @@ -119,8 +120,7 @@ rmClientH (usr ::: cid) = do rpc = fedClient @'Galley @"on-client-removed" goConvs :: Range 1 1000 Int32 -> ConvIdsPage -> Local UserId -> Sem r () goConvs range page lusr = do - loc :: Local () <- input - let (localConvs, remoteConvs) = partitionQualified loc (mtpResults page) + let (localConvs, remoteConvs) = partitionQualified lusr (mtpResults page) for_ localConvs $ \convId -> do mConv <- getConversation convId for_ mConv $ \conv -> do @@ -134,22 +134,20 @@ rmClientH (usr ::: cid) = do goConvs range newCids lusr removeRemoteMLSClients :: Range 1 1000 [Remote ConvId] -> Sem r () - removeRemoteMLSClients cids = do - for_ (bucketRemote (fromRange cids)) $ \remoteConvs -> do + removeRemoteMLSClients convIds = do + for_ (bucketRemote (fromRange convIds)) $ \remoteConvs -> do runFederatedEither remoteConvs (rpc (ClientRemovedRequest usr cid (tUnqualified remoteConvs))) >>= logAndIgnoreError "Error in onConversationUpdated call" usr - logAndIgnoreError message usr' res = do - case res of - Left federationError -> - P.err - ( Log.msg - ( "Federation error while notifying remote backends of a client deletion (Galley). " - <> message - <> " " - <> show federationError - ) - . Log.field "user" (show usr') - . Log.field "client" (hex . T.unpack . client $ cid) - ) - Right _ -> pure () + logAndIgnoreError message usr' res = + whenLeft res $ \federationError -> + P.err + ( Log.msg + ( "Federation error while notifying remote backends of a client deletion (Galley). " + <> message + <> " " + <> show federationError + ) + . Log.field "user" (show usr') + . Log.field "client" (hex . T.unpack . client $ cid) + ) diff --git a/services/galley/test/integration/API/MLS.hs b/services/galley/test/integration/API/MLS.hs index 0927979dce..df76b0691f 100644 --- a/services/galley/test/integration/API/MLS.hs +++ b/services/galley/test/integration/API/MLS.hs @@ -1612,25 +1612,25 @@ testBackendRemoveProposalLocalConvLocalClient = do traverse_ uploadNewKeyPackage [bob1, bob2] (_, qcnv) <- setupMLSGroup alice1 void $ createAddCommit alice1 [bob] >>= sendAndConsumeCommit - [(bobA, kpBobA), (bobB, _kpBobB)] <- getClientsFromGroupState alice1 bob + Just (_, kpBob1) <- find (\(ci, _) -> ci == bob1) <$> getClientsFromGroupState alice1 bob - mlsBracket [alice1, bobA] $ \[wsA, wsB] -> do + mlsBracket [alice1, bob1] $ \[wsA, wsB] -> do liftTest $ - deleteClient (ciUser bobA) (ciClient bobA) (Just defPassword) + deleteClient (ciUser bob1) (ciClient bob1) (Just defPassword) !!! statusCode === const 200 State.modify $ \mls -> mls - { mlsMembers = Set.difference (mlsMembers mls) (Set.fromList [bobA]) + { mlsMembers = Set.difference (mlsMembers mls) (Set.fromList [bob1]) } WS.assertMatch_ (5 # WS.Second) wsB $ - wsAssertClientRemoved (ciClient bobA) + wsAssertClientRemoved (ciClient bob1) msg <- WS.assertMatch (5 # WS.Second) wsA $ \notification -> do - wsAssertBackendRemoveProposal bob qcnv kpBobA notification + wsAssertBackendRemoveProposal bob qcnv kpBob1 notification - for_ [alice1, bobB] $ + for_ [alice1, bob2] $ flip consumeMessage1 msg mp <- createPendingProposalCommit alice1 @@ -1656,7 +1656,6 @@ testBackendRemoveProposalLocalConvRemoteClient = do . Aeson.encode . Set.fromList . map (flip ClientInfo True) - . toList $ [ciClient bob1] ms -> assertFailure ("unmocked endpoint called: " <> cs ms)