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 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..95bf989479 100644 --- a/services/galley/src/Galley/API/Clients.hs +++ b/services/galley/src/Galley/API/Clients.hs @@ -22,16 +22,41 @@ module Galley.API.Clients ) where +import Data.Either.Combinators (whenLeft) +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 Network.Wai.Predicate hiding (Error, setStatus) +import Network.Wai.Utilities hiding (Error) import Polysemy +import Polysemy.Error +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 +86,68 @@ 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, + 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 + let (localConvs, remoteConvs) = partitionQualified lusr (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 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 = + 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/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, diff --git a/services/galley/test/integration/API/MLS.hs b/services/galley/test/integration/API/MLS.hs index 9e89c58315..df76b0691f 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" @@ -107,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" @@ -151,15 +147,11 @@ 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, remote user leaving" testBackendRemoveProposalLocalConvRemoteLeaver + 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 ], testGroup "Protocol mismatch" @@ -714,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"] @@ -750,6 +719,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 @@ -1427,6 +1397,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 @@ -1603,6 +1574,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 @@ -1630,3 +1602,77 @@ testBackendRemoveProposalLocalConvRemoteLeaver = do for_ bobClients $ \(_, ref) -> WS.assertMatch_ (5 # WS.Second) wsA $ wsAssertBackendRemoveProposal bob qcnv ref + +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 + Just (_, kpBob1) <- find (\(ci, _) -> ci == bob1) <$> getClientsFromGroupState alice1 bob + + mlsBracket [alice1, bob1] $ \[wsA, wsB] -> do + liftTest $ + deleteClient (ciUser bob1) (ciClient bob1) (Just defPassword) + !!! statusCode === const 200 + + State.modify $ \mls -> + mls + { mlsMembers = Set.difference (mlsMembers mls) (Set.fromList [bob1]) + } + + WS.assertMatch_ (5 # WS.Second) wsB $ + wsAssertClientRemoved (ciClient bob1) + + msg <- WS.assertMatch (5 # WS.Second) wsA $ \notification -> do + wsAssertBackendRemoveProposal bob qcnv kpBob1 notification + + for_ [alice1, bob2] $ + 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) + "mls-welcome" -> pure (Aeson.encode EmptyResponse) + "on-mls-message-sent" -> pure (Aeson.encode EmptyResponse) + "get-mls-clients" -> + pure + . Aeson.encode + . Set.fromList + . map (flip ClientInfo True) + $ [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