diff --git a/changelog.d/6-federation/on-new-remote-subconversation b/changelog.d/6-federation/on-new-remote-subconversation new file mode 100644 index 0000000000..edb9c811d3 --- /dev/null +++ b/changelog.d/6-federation/on-new-remote-subconversation @@ -0,0 +1,4 @@ +Split federation endpoint into on-new-remote-conversation and on-new-remote-subconversation +Call on-new-remote-subconversation when a new subconversation is created +Call on-new-remote-subconversation for all existing subconversations when a new backend gets involved +Call on-new-remote-subconversation when a subconversation is reset 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 dd472f0b87..16947e69ce 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 @@ -56,6 +56,7 @@ type GalleyApi = -- This endpoint is called the first time a user from this backend is -- added to a remote conversation. :<|> FedEndpoint "on-new-remote-conversation" NewRemoteConversation EmptyResponse + :<|> FedEndpoint "on-new-remote-subconversation" NewRemoteSubConversation EmptyResponse :<|> FedEndpoint "get-conversations" GetConversationsRequest GetConversationsResponse -- used by the backend that owns a conversation to inform this backend of -- changes to the conversation @@ -63,7 +64,8 @@ type GalleyApi = :<|> FedEndpointWithMods '[ MakesFederatedCall 'Galley "on-conversation-updated", MakesFederatedCall 'Galley "on-mls-message-sent", - MakesFederatedCall 'Galley "on-new-remote-conversation" + MakesFederatedCall 'Galley "on-new-remote-conversation", + MakesFederatedCall 'Galley "on-new-remote-subconversation" ] "leave-conversation" LeaveConversationRequest @@ -83,7 +85,8 @@ type GalleyApi = :<|> FedEndpointWithMods '[ MakesFederatedCall 'Galley "on-mls-message-sent", MakesFederatedCall 'Galley "on-conversation-updated", - MakesFederatedCall 'Galley "on-new-remote-conversation" + MakesFederatedCall 'Galley "on-new-remote-conversation", + MakesFederatedCall 'Galley "on-new-remote-subconversation" ] "on-user-deleted-conversations" UserDeletedConversationsNotification @@ -91,7 +94,8 @@ type GalleyApi = :<|> FedEndpointWithMods '[ MakesFederatedCall 'Galley "on-conversation-updated", MakesFederatedCall 'Galley "on-mls-message-sent", - MakesFederatedCall 'Galley "on-new-remote-conversation" + MakesFederatedCall 'Galley "on-new-remote-conversation", + MakesFederatedCall 'Galley "on-new-remote-subconversation" ] "update-conversation" ConversationUpdateRequest @@ -102,6 +106,7 @@ type GalleyApi = '[ MakesFederatedCall 'Galley "on-conversation-updated", MakesFederatedCall 'Galley "on-mls-message-sent", MakesFederatedCall 'Galley "on-new-remote-conversation", + MakesFederatedCall 'Galley "on-new-remote-subconversation", MakesFederatedCall 'Galley "send-mls-message", MakesFederatedCall 'Brig "get-mls-clients" ] @@ -113,6 +118,7 @@ type GalleyApi = MakesFederatedCall 'Galley "on-conversation-updated", MakesFederatedCall 'Galley "on-mls-message-sent", MakesFederatedCall 'Galley "on-new-remote-conversation", + MakesFederatedCall 'Galley "on-new-remote-subconversation", MakesFederatedCall 'Galley "send-mls-commit-bundle", MakesFederatedCall 'Brig "get-mls-clients" ] @@ -128,7 +134,11 @@ type GalleyApi = EmptyResponse :<|> FedEndpoint "on-typing-indicator-updated" TypingDataUpdateRequest EmptyResponse :<|> FedEndpoint "get-sub-conversation" GetSubConversationsRequest GetSubConversationsResponse - :<|> FedEndpoint "delete-sub-conversation" DeleteSubConversationRequest DeleteSubConversationResponse + :<|> FedEndpointWithMods + '[MakesFederatedCall 'Galley "on-new-remote-subconversation"] + "delete-sub-conversation" + DeleteSubConversationRequest + DeleteSubConversationResponse data TypingDataUpdateRequest = TypingDataUpdateRequest { tdurTypingStatus :: TypingStatus, @@ -226,6 +236,17 @@ data NewRemoteConversation = NewRemoteConversation deriving stock (Eq, Show, Generic) deriving (ToJSON, FromJSON) via (CustomEncoded NewRemoteConversation) +data NewRemoteSubConversation = NewRemoteSubConversation + { -- | The ID of the parent conversation + nrscConvId :: ConvId, + -- | The subconversation ID + nrscSubConvId :: SubConvId, + -- | MLS data + nrscMlsData :: ConversationMLSData + } + deriving stock (Eq, Show, Generic) + deriving (ToJSON, FromJSON) via (CustomEncoded NewRemoteSubConversation) + data ConversationUpdate = ConversationUpdate { cuTime :: UTCTime, cuOrigUserId :: Qualified UserId, @@ -325,6 +346,7 @@ data MLSMessageSendRequest = MLSMessageSendRequest -- | Sender is assumed to be owned by the origin domain, this allows us to -- protect against spoofing attacks mmsrSender :: UserId, + mmsrSenderClient :: ClientId, mmsrRawMessage :: Base64ByteString } deriving stock (Eq, Show, Generic) diff --git a/libs/wire-api/src/Wire/API/Conversation/Protocol.hs b/libs/wire-api/src/Wire/API/Conversation/Protocol.hs index 0fa9fc99c1..f72e45ea67 100644 --- a/libs/wire-api/src/Wire/API/Conversation/Protocol.hs +++ b/libs/wire-api/src/Wire/API/Conversation/Protocol.hs @@ -61,6 +61,34 @@ data ConversationMLSData = ConversationMLSData } deriving stock (Eq, Show, Generic) deriving (Arbitrary) via GenericUniform ConversationMLSData + deriving (ToJSON, FromJSON) via Schema ConversationMLSData + +mlsDataSchema :: ObjectSchema SwaggerDoc ConversationMLSData +mlsDataSchema = + ConversationMLSData + <$> cnvmlsGroupId + .= fieldWithDocModifier + "group_id" + (description ?~ "An MLS group identifier (at most 256 bytes long)") + schema + <*> cnvmlsEpoch + .= fieldWithDocModifier + "epoch" + (description ?~ "The epoch number of the corresponding MLS group") + schema + <*> cnvmlsEpochTimestamp + .= fieldWithDocModifier + "epoch_timestamp" + (description ?~ "The timestamp of the epoch number") + schemaEpochTimestamp + <*> cnvmlsCipherSuite + .= fieldWithDocModifier + "cipher_suite" + (description ?~ "The cipher suite of the corresponding MLS group") + schema + +instance ToSchema ConversationMLSData where + schema = object "ConversationMLSData" mlsDataSchema -- | Conversation protocol and protocol-specific data. data Protocol @@ -116,27 +144,3 @@ deriving via (Schema Protocol) instance ToJSON Protocol protocolDataSchema :: ProtocolTag -> ObjectSchema SwaggerDoc Protocol protocolDataSchema ProtocolProteusTag = tag _ProtocolProteus (pure ()) protocolDataSchema ProtocolMLSTag = tag _ProtocolMLS mlsDataSchema - -mlsDataSchema :: ObjectSchema SwaggerDoc ConversationMLSData -mlsDataSchema = - ConversationMLSData - <$> cnvmlsGroupId - .= fieldWithDocModifier - "group_id" - (description ?~ "An MLS group identifier (at most 256 bytes long)") - schema - <*> cnvmlsEpoch - .= fieldWithDocModifier - "epoch" - (description ?~ "The epoch number of the corresponding MLS group") - schema - <*> cnvmlsEpochTimestamp - .= fieldWithDocModifier - "epoch_timestamp" - (description ?~ "The timestamp of the epoch number") - schemaEpochTimestamp - <*> cnvmlsCipherSuite - .= fieldWithDocModifier - "cipher_suite" - (description ?~ "The cipher suite of the corresponding MLS group") - schema diff --git a/libs/wire-api/src/Wire/API/Routes/Public/Galley/Conversation.hs b/libs/wire-api/src/Wire/API/Routes/Public/Galley/Conversation.hs index a1c9f231f0..66dd85e252 100644 --- a/libs/wire-api/src/Wire/API/Routes/Public/Galley/Conversation.hs +++ b/libs/wire-api/src/Wire/API/Routes/Public/Galley/Conversation.hs @@ -423,6 +423,8 @@ type ConversationAPI = "delete-subconversation" ( Summary "Delete an MLS subconversation" :> MakesFederatedCall 'Galley "delete-sub-conversation" + :> MakesFederatedCall 'Galley "on-new-remote-conversation" + :> MakesFederatedCall 'Galley "on-new-remote-subconversation" :> CanThrow 'ConvAccessDenied :> CanThrow 'ConvNotFound :> CanThrow 'MLSNotEnabled @@ -513,6 +515,7 @@ type ConversationAPI = :> MakesFederatedCall 'Galley "on-conversation-updated" :> MakesFederatedCall 'Galley "on-mls-message-sent" :> MakesFederatedCall 'Galley "on-new-remote-conversation" + :> MakesFederatedCall 'Galley "on-new-remote-subconversation" :> Until 'V2 :> CanThrow ('ActionDenied 'AddConversationMember) :> CanThrow ('ActionDenied 'LeaveConversation) @@ -537,6 +540,7 @@ type ConversationAPI = :> MakesFederatedCall 'Galley "on-conversation-updated" :> MakesFederatedCall 'Galley "on-mls-message-sent" :> MakesFederatedCall 'Galley "on-new-remote-conversation" + :> MakesFederatedCall 'Galley "on-new-remote-subconversation" :> Until 'V2 :> CanThrow ('ActionDenied 'AddConversationMember) :> CanThrow ('ActionDenied 'LeaveConversation) @@ -562,6 +566,7 @@ type ConversationAPI = :> MakesFederatedCall 'Galley "on-conversation-updated" :> MakesFederatedCall 'Galley "on-mls-message-sent" :> MakesFederatedCall 'Galley "on-new-remote-conversation" + :> MakesFederatedCall 'Galley "on-new-remote-subconversation" :> From 'V2 :> CanThrow ('ActionDenied 'AddConversationMember) :> CanThrow ('ActionDenied 'LeaveConversation) @@ -587,6 +592,7 @@ type ConversationAPI = ( Summary "Join a conversation by its ID (if link access enabled)" :> MakesFederatedCall 'Galley "on-conversation-updated" :> MakesFederatedCall 'Galley "on-new-remote-conversation" + :> MakesFederatedCall 'Galley "on-new-remote-subconversation" :> CanThrow 'ConvAccessDenied :> CanThrow 'ConvNotFound :> CanThrow 'InvalidOperation @@ -609,6 +615,7 @@ type ConversationAPI = \Note that this is currently inconsistent (for backwards compatibility reasons) with `POST /conversations/code-check` which responds with 404 CodeNotFound if guest links are disabled." :> MakesFederatedCall 'Galley "on-conversation-updated" :> MakesFederatedCall 'Galley "on-new-remote-conversation" + :> MakesFederatedCall 'Galley "on-new-remote-subconversation" :> CanThrow 'CodeNotFound :> CanThrow 'ConvAccessDenied :> CanThrow 'ConvNotFound @@ -739,6 +746,7 @@ type ConversationAPI = :> MakesFederatedCall 'Galley "on-conversation-updated" :> MakesFederatedCall 'Galley "on-mls-message-sent" :> MakesFederatedCall 'Galley "on-new-remote-conversation" + :> MakesFederatedCall 'Galley "on-new-remote-subconversation" :> Until 'V2 :> ZLocalUser :> ZConn @@ -760,6 +768,7 @@ type ConversationAPI = :> MakesFederatedCall 'Galley "on-conversation-updated" :> MakesFederatedCall 'Galley "on-mls-message-sent" :> MakesFederatedCall 'Galley "on-new-remote-conversation" + :> MakesFederatedCall 'Galley "on-new-remote-subconversation" :> ZLocalUser :> ZConn :> CanThrow ('ActionDenied 'RemoveConversationMember) @@ -779,6 +788,7 @@ type ConversationAPI = :> Description "Use `PUT /conversations/:cnv_domain/:cnv/members/:usr_domain/:usr` instead" :> MakesFederatedCall 'Galley "on-conversation-updated" :> MakesFederatedCall 'Galley "on-new-remote-conversation" + :> MakesFederatedCall 'Galley "on-new-remote-subconversation" :> ZLocalUser :> ZConn :> CanThrow 'ConvNotFound @@ -803,6 +813,7 @@ type ConversationAPI = :> Description "**Note**: at least one field has to be provided." :> MakesFederatedCall 'Galley "on-conversation-updated" :> MakesFederatedCall 'Galley "on-new-remote-conversation" + :> MakesFederatedCall 'Galley "on-new-remote-subconversation" :> ZLocalUser :> ZConn :> CanThrow 'ConvNotFound @@ -829,6 +840,7 @@ type ConversationAPI = :> Description "Use `/conversations/:domain/:conv/name` instead." :> MakesFederatedCall 'Galley "on-conversation-updated" :> MakesFederatedCall 'Galley "on-new-remote-conversation" + :> MakesFederatedCall 'Galley "on-new-remote-subconversation" :> CanThrow ('ActionDenied 'ModifyConversationName) :> CanThrow 'ConvNotFound :> CanThrow 'InvalidOperation @@ -849,6 +861,7 @@ type ConversationAPI = :> Description "Use `/conversations/:domain/:conv/name` instead." :> MakesFederatedCall 'Galley "on-conversation-updated" :> MakesFederatedCall 'Galley "on-new-remote-conversation" + :> MakesFederatedCall 'Galley "on-new-remote-subconversation" :> CanThrow ('ActionDenied 'ModifyConversationName) :> CanThrow 'ConvNotFound :> CanThrow 'InvalidOperation @@ -869,6 +882,7 @@ type ConversationAPI = ( Summary "Update conversation name" :> MakesFederatedCall 'Galley "on-conversation-updated" :> MakesFederatedCall 'Galley "on-new-remote-conversation" + :> MakesFederatedCall 'Galley "on-new-remote-subconversation" :> CanThrow ('ActionDenied 'ModifyConversationName) :> CanThrow 'ConvNotFound :> CanThrow 'InvalidOperation @@ -892,6 +906,7 @@ type ConversationAPI = :> Description "Use `/conversations/:domain/:cnv/message-timer` instead." :> MakesFederatedCall 'Galley "on-conversation-updated" :> MakesFederatedCall 'Galley "on-new-remote-conversation" + :> MakesFederatedCall 'Galley "on-new-remote-subconversation" :> ZLocalUser :> ZConn :> CanThrow ('ActionDenied 'ModifyConversationMessageTimer) @@ -913,6 +928,7 @@ type ConversationAPI = ( Summary "Update the message timer for a conversation" :> MakesFederatedCall 'Galley "on-conversation-updated" :> MakesFederatedCall 'Galley "on-new-remote-conversation" + :> MakesFederatedCall 'Galley "on-new-remote-subconversation" :> ZLocalUser :> ZConn :> CanThrow ('ActionDenied 'ModifyConversationMessageTimer) @@ -937,6 +953,7 @@ type ConversationAPI = :> Description "Use `PUT /conversations/:domain/:cnv/receipt-mode` instead." :> MakesFederatedCall 'Galley "on-conversation-updated" :> MakesFederatedCall 'Galley "on-new-remote-conversation" + :> MakesFederatedCall 'Galley "on-new-remote-subconversation" :> MakesFederatedCall 'Galley "update-conversation" :> ZLocalUser :> ZConn @@ -959,6 +976,7 @@ type ConversationAPI = ( Summary "Update receipt mode for a conversation" :> MakesFederatedCall 'Galley "on-conversation-updated" :> MakesFederatedCall 'Galley "on-new-remote-conversation" + :> MakesFederatedCall 'Galley "on-new-remote-subconversation" :> MakesFederatedCall 'Galley "update-conversation" :> ZLocalUser :> ZConn @@ -985,6 +1003,7 @@ type ConversationAPI = :> MakesFederatedCall 'Galley "on-conversation-updated" :> MakesFederatedCall 'Galley "on-mls-message-sent" :> MakesFederatedCall 'Galley "on-new-remote-conversation" + :> MakesFederatedCall 'Galley "on-new-remote-subconversation" :> Until 'V3 :> Description "Use PUT `/conversations/:domain/:cnv/access` instead." :> ZLocalUser @@ -1011,6 +1030,7 @@ type ConversationAPI = :> MakesFederatedCall 'Galley "on-conversation-updated" :> MakesFederatedCall 'Galley "on-mls-message-sent" :> MakesFederatedCall 'Galley "on-new-remote-conversation" + :> MakesFederatedCall 'Galley "on-new-remote-subconversation" :> Until 'V3 :> ZLocalUser :> ZConn @@ -1036,6 +1056,7 @@ type ConversationAPI = :> MakesFederatedCall 'Galley "on-conversation-updated" :> MakesFederatedCall 'Galley "on-mls-message-sent" :> MakesFederatedCall 'Galley "on-new-remote-conversation" + :> MakesFederatedCall 'Galley "on-new-remote-subconversation" :> From 'V3 :> ZLocalUser :> ZConn diff --git a/libs/wire-api/src/Wire/API/Routes/Public/Galley/Feature.hs b/libs/wire-api/src/Wire/API/Routes/Public/Galley/Feature.hs index a07a09fdfb..ea44382025 100644 --- a/libs/wire-api/src/Wire/API/Routes/Public/Galley/Feature.hs +++ b/libs/wire-api/src/Wire/API/Routes/Public/Galley/Feature.hs @@ -39,7 +39,8 @@ type FeatureAPI = :<|> FeatureStatusPut '[ MakesFederatedCall 'Galley "on-conversation-updated", MakesFederatedCall 'Galley "on-mls-message-sent", - MakesFederatedCall 'Galley "on-new-remote-conversation" + MakesFederatedCall 'Galley "on-new-remote-conversation", + MakesFederatedCall 'Galley "on-new-remote-subconversation" ] '( 'ActionDenied 'RemoveConversationMember, '( AuthenticationError, diff --git a/libs/wire-api/src/Wire/API/Routes/Public/Galley/LegalHold.hs b/libs/wire-api/src/Wire/API/Routes/Public/Galley/LegalHold.hs index 82318d9213..645878f375 100644 --- a/libs/wire-api/src/Wire/API/Routes/Public/Galley/LegalHold.hs +++ b/libs/wire-api/src/Wire/API/Routes/Public/Galley/LegalHold.hs @@ -66,6 +66,7 @@ type LegalHoldAPI = :> MakesFederatedCall 'Galley "on-conversation-updated" :> MakesFederatedCall 'Galley "on-mls-message-sent" :> MakesFederatedCall 'Galley "on-new-remote-conversation" + :> MakesFederatedCall 'Galley "on-new-remote-subconversation" :> CanThrow AuthenticationError :> CanThrow OperationDenied :> CanThrow 'NotATeamMember @@ -105,6 +106,7 @@ type LegalHoldAPI = :> MakesFederatedCall 'Galley "on-conversation-updated" :> MakesFederatedCall 'Galley "on-mls-message-sent" :> MakesFederatedCall 'Galley "on-new-remote-conversation" + :> MakesFederatedCall 'Galley "on-new-remote-subconversation" :> CanThrow ('ActionDenied 'RemoveConversationMember) :> CanThrow 'InvalidOperation :> CanThrow 'TeamMemberNotFound @@ -123,6 +125,7 @@ type LegalHoldAPI = :> MakesFederatedCall 'Galley "on-conversation-updated" :> MakesFederatedCall 'Galley "on-mls-message-sent" :> MakesFederatedCall 'Galley "on-new-remote-conversation" + :> MakesFederatedCall 'Galley "on-new-remote-subconversation" :> CanThrow ('ActionDenied 'RemoveConversationMember) :> CanThrow 'NotATeamMember :> CanThrow OperationDenied @@ -154,6 +157,7 @@ type LegalHoldAPI = :> MakesFederatedCall 'Galley "on-conversation-updated" :> MakesFederatedCall 'Galley "on-mls-message-sent" :> MakesFederatedCall 'Galley "on-new-remote-conversation" + :> MakesFederatedCall 'Galley "on-new-remote-subconversation" :> CanThrow AuthenticationError :> CanThrow ('ActionDenied 'RemoveConversationMember) :> CanThrow 'NotATeamMember @@ -183,6 +187,7 @@ type LegalHoldAPI = :> MakesFederatedCall 'Galley "on-conversation-updated" :> MakesFederatedCall 'Galley "on-mls-message-sent" :> MakesFederatedCall 'Galley "on-new-remote-conversation" + :> MakesFederatedCall 'Galley "on-new-remote-subconversation" :> CanThrow AuthenticationError :> CanThrow 'AccessDenied :> CanThrow ('ActionDenied 'RemoveConversationMember) diff --git a/libs/wire-api/src/Wire/API/Routes/Public/Galley/MLS.hs b/libs/wire-api/src/Wire/API/Routes/Public/Galley/MLS.hs index fd705cf6fe..ebea2b25ba 100644 --- a/libs/wire-api/src/Wire/API/Routes/Public/Galley/MLS.hs +++ b/libs/wire-api/src/Wire/API/Routes/Public/Galley/MLS.hs @@ -54,6 +54,7 @@ type MLSMessagingAPI = :> MakesFederatedCall 'Galley "send-mls-message" :> MakesFederatedCall 'Galley "on-conversation-updated" :> MakesFederatedCall 'Galley "on-new-remote-conversation" + :> MakesFederatedCall 'Galley "on-new-remote-subconversation" :> MakesFederatedCall 'Brig "get-mls-clients" :> Until 'V2 :> CanThrow 'ConvAccessDenied @@ -90,6 +91,7 @@ type MLSMessagingAPI = :> MakesFederatedCall 'Galley "send-mls-message" :> MakesFederatedCall 'Galley "on-conversation-updated" :> MakesFederatedCall 'Galley "on-new-remote-conversation" + :> MakesFederatedCall 'Galley "on-new-remote-subconversation" :> MakesFederatedCall 'Brig "get-mls-clients" :> From 'V2 :> CanThrow 'ConvAccessDenied @@ -127,6 +129,7 @@ type MLSMessagingAPI = :> MakesFederatedCall 'Galley "send-mls-commit-bundle" :> MakesFederatedCall 'Galley "on-conversation-updated" :> MakesFederatedCall 'Galley "on-new-remote-conversation" + :> MakesFederatedCall 'Galley "on-new-remote-subconversation" :> MakesFederatedCall 'Brig "get-mls-clients" :> From 'V3 :> CanThrow 'ConvAccessDenied diff --git a/libs/wire-api/src/Wire/API/Routes/Public/Galley/TeamConversation.hs b/libs/wire-api/src/Wire/API/Routes/Public/Galley/TeamConversation.hs index 759b83c6cc..2499b95fbd 100644 --- a/libs/wire-api/src/Wire/API/Routes/Public/Galley/TeamConversation.hs +++ b/libs/wire-api/src/Wire/API/Routes/Public/Galley/TeamConversation.hs @@ -70,6 +70,7 @@ type TeamConversationAPI = ( Summary "Remove a team conversation" :> MakesFederatedCall 'Galley "on-conversation-updated" :> MakesFederatedCall 'Galley "on-new-remote-conversation" + :> MakesFederatedCall 'Galley "on-new-remote-subconversation" :> CanThrow ('ActionDenied 'DeleteConversation) :> CanThrow 'ConvNotFound :> CanThrow 'InvalidOperation diff --git a/services/brig/test/integration/Federation/End2end.hs b/services/brig/test/integration/Federation/End2end.hs index a13db52313..54f3e8a7b8 100644 --- a/services/brig/test/integration/Federation/End2end.hs +++ b/services/brig/test/integration/Federation/End2end.hs @@ -42,7 +42,7 @@ import Data.Qualified import Data.Range (checked) import qualified Data.Set as Set import qualified Data.Text as T -import Federation.Util (connectUsersEnd2End, generateClientPrekeys, getConvQualified) +import Federation.Util import Imports import System.FilePath import qualified System.Logger as Log @@ -63,6 +63,7 @@ import Wire.API.Internal.Notification (ntfTransient) import Wire.API.MLS.Credential import Wire.API.MLS.KeyPackage import Wire.API.MLS.Serialisation +import Wire.API.MLS.SubConversation import Wire.API.Message import Wire.API.Routes.MultiTablePaging import Wire.API.User hiding (assetKey) @@ -118,7 +119,9 @@ spec _brigOpts mg brig galley cargohold cannon _federator brigTwo galleyTwo carg test mg "download remote asset" $ testRemoteAsset brig brigTwo cargohold cargoholdTwo, test mg "claim remote key packages" $ claimRemoteKeyPackages brig brigTwo, test mg "send an MLS message to a remote user" $ - testSendMLSMessage brig brigTwo galley galleyTwo cannon cannonTwo + testSendMLSMessage brig brigTwo galley galleyTwo cannon cannonTwo, + test mg "send an MLS subconversation message to a federated user" $ + testSendMLSMessageToSubConversation brig brigTwo galley galleyTwo cannon cannonTwo ] -- | Path covered by this test: @@ -736,6 +739,7 @@ testSendMLSMessage brig1 brig2 galley1 galley2 cannon1 cannon2 = do ( brig1 . paths ["clients", toByteString' aliceClient] . zUser (qUnqualified (userQualifiedId alice)) + . zClient aliceClient . json update ) !!! const 200 === statusCode @@ -745,6 +749,7 @@ testSendMLSMessage brig1 brig2 galley1 galley2 cannon1 cannon2 = do ( brig1 . paths ["mls", "key-packages", "self", toByteString' aliceClient] . zUser (qUnqualified (userQualifiedId alice)) + . zClient aliceClient . json (KeyPackageUpload [aliceKP]) ) !!! const 201 === statusCode @@ -779,6 +784,7 @@ testSendMLSMessage brig1 brig2 galley1 galley2 cannon1 cannon2 = do toByteString' (qUnqualified (userQualifiedId alice)) ] . zUser (qUnqualified (userQualifiedId bob)) + . zClient bobClient ) Brig -> Galley -> Galley -> Cannon -> Cannon -> Http () +testSendMLSMessageToSubConversation brig1 brig2 galley1 galley2 cannon1 cannon2 = do + let cli :: String -> FilePath -> [String] -> CreateProcess + cli store tmp args = + proc "mls-test-cli" $ + ["--store", tmp (store <> ".db")] <> args + + -- create alice user and client on domain 1 + alice <- randomUser brig1 + aliceClient <- + clientId . responseJsonUnsafe + <$> addClient + brig1 + (userId alice) + (defNewClient PermanentClientType [] (Imports.head someLastPrekeys)) + let aliceClientId = + show (userId alice) + <> ":" + <> T.unpack (client aliceClient) + <> "@" + <> T.unpack (domainText (qDomain (userQualifiedId alice))) + + -- create bob user and client on domain 2 + bob <- randomUser brig2 + bobClient <- + clientId . responseJsonUnsafe + <$> addClient + brig2 + (userId bob) + (defNewClient PermanentClientType [] (someLastPrekeys !! 1)) + let bobClientId = + show (userId bob) + <> ":" + <> T.unpack (client bobClient) + <> "@" + <> T.unpack (domainText (qDomain (userQualifiedId bob))) + + withSystemTempDirectory "mls" $ \tmp -> do + -- create alice's key package + void . liftIO $ spawn (cli aliceClientId tmp ["init", aliceClientId]) Nothing + kpMLS <- liftIO $ spawn (cli aliceClientId tmp ["key-package", "create"]) Nothing + aliceKP <- liftIO $ case decodeMLS' kpMLS of + Right kp -> pure kp + Left e -> assertFailure $ "Could not decode alice Key Package: " <> T.unpack e + + -- set public key + let update = + defUpdateClient + { updateClientMLSPublicKeys = + Map.singleton + Ed25519 + (bcSignatureKey (kpCredential (rmValue aliceKP))) + } + put + ( brig1 + . paths ["clients", toByteString' aliceClient] + . zUser (qUnqualified (userQualifiedId alice)) + . json update + ) + !!! const 200 === statusCode + + -- upload key package + post + ( brig1 + . paths ["mls", "key-packages", "self", toByteString' aliceClient] + . zUser (qUnqualified (userQualifiedId alice)) + . zClient aliceClient + . json (KeyPackageUpload [aliceKP]) + ) + !!! const 201 === statusCode + + -- create bob's client state + void . liftIO $ spawn (cli bobClientId tmp ["init", bobClientId]) Nothing + + connectUsersEnd2End brig1 brig2 (userQualifiedId alice) (userQualifiedId bob) + + -- bob claims alice's key package + void $ + post + ( brig2 + . paths + [ "mls", + "key-packages", + "claim", + toByteString' (qDomain (userQualifiedId alice)), + toByteString' (qUnqualified (userQualifiedId alice)) + ] + . zUser (qUnqualified (userQualifiedId bob)) + . zClient bobClient + ) + pure (unGroupId (cnvmlsGroupId p)) + ProtocolProteus -> liftIO $ assertFailure "Expected MLS conversation" + let qconvId = cnvQualifiedId conv + groupJSON <- + liftIO $ + spawn + ( cli + bobClientId + tmp + [ "group", + "create", + T.unpack (toBase64Text groupId) + ] + ) + Nothing + liftIO $ BS.writeFile (tmp "group.json") groupJSON + + -- invite alice + liftIO $ BS.writeFile (tmp aliceClientId) (rmRaw aliceKP) + commit <- + liftIO $ + spawn + ( cli + bobClientId + tmp + [ "member", + "add", + "--in-place", + "--group", + tmp "group.json", + "--welcome-out", + tmp "welcome", + tmp aliceClientId + ] + ) + Nothing + welcome <- liftIO $ BS.readFile (tmp "welcome") + + -- send welcome and commit + WS.bracketR cannon1 (userId alice) $ \wsAlice -> do + post + ( galley2 + . paths + ["mls", "messages"] + . zUser (userId bob) + . zClient bobClient + . zConn "conn" + . header "Z-Type" "access" + . content "message/mls" + . bytes commit + ) + !!! const 201 === statusCode + + post + ( galley2 + . paths + ["mls", "welcome"] + . zUser (userId bob) + . zClient bobClient + . zConn "conn" + . header "Z-Type" "access" + . content "message/mls" + . bytes welcome + ) + !!! const 201 === statusCode + + -- verify that alice receives the welcome message + WS.assertMatch_ (5 # Second) wsAlice $ \n -> do + let e = List1.head (WS.unpackPayload n) + ntfTransient n @?= False + evtType e @?= MLSWelcome + evtFrom e @?= userQualifiedId alice + evtData e @?= EdMLSWelcome welcome + + -- verify that alice receives a join event + WS.assertMatch_ (5 # Second) wsAlice $ \n -> do + let e = List1.head (WS.unpackPayload n) + evtConv e @?= qconvId + evtType e @?= MemberJoin + evtFrom e @?= userQualifiedId bob + fmap (sort . mMembers) (evtData e ^? _EdMembersJoin) + @?= Just [SimpleMember (userQualifiedId alice) roleNameWireMember] + + -- alice creates the group + void . liftIO $ + spawn + ( cli + aliceClientId + tmp + [ "group", + "from-welcome", + "--group-out", + tmp "groupA.json", + tmp "welcome" + ] + ) + Nothing + + -- SUBCONVERSATION + -- create subconversation on domain 2 + subConv <- + responseJsonError + =<< createMLSSubConversation galley2 (userId bob) qconvId (SubConvId "sub") + "subgroup.json") subGroupJSON + + -- bob sends commit bundle for subconversation + do + subCommitRaw <- + liftIO $ + spawn + ( cli + bobClientId + tmp + [ "commit", + "--in-place", + "--group", + tmp "subgroup.json", + "--group-state-out", + tmp "subgroupstate.mls" + ] + ) + Nothing + sendCommitBundle + tmp + "subgroupstate.mls" + galley2 + (userId bob) + bobClient + subCommitRaw + + -- alice sends an external commit to add herself to the subconveration + do + subCommitRaw <- + liftIO $ + spawn + ( cli + aliceClientId + tmp + [ "external-commit", + "--group-out", + tmp "subgroupA.json", + "--group-state-in", + tmp "subgroupstate.mls", + "--group-state-out", + tmp "subgroupstateA.mls" + ] + ) + Nothing + sendCommitBundle + tmp + "subgroupstateA.mls" + galley1 + (userId alice) + aliceClient + subCommitRaw + + -- prepare bob's message to the subconversation + dove <- + liftIO $ + spawn + ( cli + bobClientId + tmp + ["message", "--group", tmp "subgroup.json", "dove"] + ) + Nothing + + -- prepare alice's reply to the subconversation + reply <- + liftIO $ + spawn + ( cli + aliceClientId + tmp + ["message", "--group", tmp "subgroupA.json", "raven"] + ) + Nothing + + -- send bob's message + WS.bracketR cannon1 (userId alice) $ \wsAlice -> do + post + ( galley2 + . paths + ["mls", "messages"] + . zUser (userId bob) + . zClient bobClient + . zConn "conn" + . header "Z-Type" "access" + . content "message/mls" + . bytes dove + ) + !!! const 201 === statusCode + + -- verify that alice receives bob's message in the subconversation + WS.assertMatch_ (5 # Second) wsAlice $ \n -> do + let e = List1.head (WS.unpackPayload n) + ntfTransient n @?= False + evtConv e @?= qconvId + evtType e @?= MLSMessageAdd + evtFrom e @?= userQualifiedId bob + evtData e @?= EdMLSMessage dove + + -- send alice's message + WS.bracketR cannon2 (userId bob) $ \wsBob -> do + post + ( galley1 + . paths + ["mls", "messages"] + . zUser (userId alice) + . zClient aliceClient + . zConn "conn" + . header "Z-Type" "access" + . content "message/mls" + . bytes reply + ) + !!! const 201 === statusCode + + -- verify that bob receives alice's message in the subconversation + WS.assertMatch_ (5 # Second) wsBob $ \n -> do + let e = List1.head (WS.unpackPayload n) + ntfTransient n @?= False + evtConv e @?= qconvId + evtType e @?= MLSMessageAdd + evtFrom e @?= userQualifiedId alice + evtData e @?= EdMLSMessage reply diff --git a/services/brig/test/integration/Federation/Util.hs b/services/brig/test/integration/Federation/Util.hs index dbc08acb71..8d56f4f4b0 100644 --- a/services/brig/test/integration/Federation/Util.hs +++ b/services/brig/test/integration/Federation/Util.hs @@ -33,6 +33,7 @@ import Control.Monad.Trans.Except import Control.Retry import Data.Aeson (FromJSON, Value, decode, (.=)) import qualified Data.Aeson as Aeson +import qualified Data.ByteString as BS import Data.ByteString.Conversion (toByteString') import Data.Domain (Domain (Domain)) import Data.Handle (fromHandle) @@ -40,6 +41,7 @@ import Data.Id import qualified Data.Map.Strict as Map import Data.Qualified (Qualified (..)) import Data.String.Conversions (cs) +import qualified Data.Text as T import qualified Data.Text as Text import qualified Database.Bloodhound as ES import qualified Federator.MockServer as Mock @@ -52,6 +54,7 @@ import Network.Socket import Network.Wai.Handler.Warp (Port) import Network.Wai.Test (Session) import qualified Network.Wai.Test as WaiTest +import System.FilePath import Test.QuickCheck (Arbitrary (arbitrary), generate) import Test.Tasty import Test.Tasty.HUnit @@ -63,6 +66,9 @@ import Wire.API.Connection import Wire.API.Conversation (Conversation (cnvMembers)) import Wire.API.Conversation.Member (OtherMember (OtherMember), cmOthers) import Wire.API.Conversation.Role (roleNameWireAdmin) +import Wire.API.MLS.CommitBundle +import Wire.API.MLS.GroupInfoBundle +import Wire.API.MLS.Serialisation import Wire.API.Team.Feature (FeatureStatus (..)) import Wire.API.User import Wire.API.User.Client @@ -111,3 +117,23 @@ connectUsersEnd2End brig1 brig2 quid1 quid2 = do !!! const 201 === statusCode putConnectionQualified brig2 (qUnqualified quid2) quid1 Accepted !!! const 200 === statusCode + +sendCommitBundle :: FilePath -> FilePath -> Galley -> UserId -> ClientId -> ByteString -> Http () +sendCommitBundle tmp subGroupStateFn galley uid cid commit = do + subGroupStateRaw <- liftIO $ BS.readFile $ tmp subGroupStateFn + subGroupState <- either (liftIO . assertFailure . T.unpack) pure . decodeMLS' $ subGroupStateRaw + subCommit <- either (liftIO . assertFailure . T.unpack) pure . decodeMLS' $ commit + let subGroupBundle = CommitBundle subCommit Nothing (GroupInfoBundle UnencryptedGroupInfo TreeFull subGroupState) + let subGroupBundleRaw = serializeCommitBundle subGroupBundle + post + ( galley + . paths + ["mls", "commit-bundles"] + . zUser uid + . zClient cid + . zConn "conn" + . header "Z-Type" "access" + . content "application/x-protobuf" + . bytes subGroupBundleRaw + ) + !!! const 201 === statusCode diff --git a/services/brig/test/integration/Util.hs b/services/brig/test/integration/Util.hs index d6bc80cf92..48de9be3ba 100644 --- a/services/brig/test/integration/Util.hs +++ b/services/brig/test/integration/Util.hs @@ -102,6 +102,7 @@ import Test.Tasty.HUnit import Text.Printf (printf) import qualified UnliftIO.Async as Async import Util.Options +import Web.Internal.HttpApiData import Wire.API.Connection import Wire.API.Conversation import Wire.API.Conversation.Protocol @@ -109,6 +110,7 @@ import Wire.API.Conversation.Role (roleNameWireAdmin) import Wire.API.Federation.API import Wire.API.Federation.Domain import Wire.API.Internal.Notification +import Wire.API.MLS.SubConversation import Wire.API.Routes.MultiTablePaging import Wire.API.Team.Member hiding (userId) import Wire.API.User @@ -740,6 +742,25 @@ createMLSConversation galley zusr c = do . zConn "conn" . json conv +createMLSSubConversation :: + (MonadIO m, MonadHttp m) => + Galley -> + UserId -> + Qualified ConvId -> + SubConvId -> + m ResponseLBS +createMLSSubConversation galley zusr qcnv sconv = + get $ + galley + . paths + [ "conversations", + toByteString' (qDomain qcnv), + toByteString' (qUnqualified qcnv), + "subconversations", + toHeader sconv + ] + . zUser zusr + createConversation :: (MonadIO m, MonadHttp m) => Galley -> UserId -> [Qualified UserId] -> m ResponseLBS createConversation galley zusr usersToAdd = do let conv = @@ -844,6 +865,9 @@ zAuthAccess u c = header "Z-Type" "access" . zUser u . zConn c zUser :: UserId -> Request -> Request zUser = header "Z-User" . B8.pack . show +zClient :: ClientId -> Request -> Request +zClient = header "Z-Client" . toByteString' + zConn :: ByteString -> Request -> Request zConn = header "Z-Connection" diff --git a/services/galley/src/Galley/API/Action.hs b/services/galley/src/Galley/API/Action.hs index d5a33d94d7..e14f46b70c 100644 --- a/services/galley/src/Galley/API/Action.hs +++ b/services/galley/src/Galley/API/Action.hs @@ -68,6 +68,7 @@ import qualified Galley.Effects.FederatorAccess as E import qualified Galley.Effects.FireAndForget as E import qualified Galley.Effects.MemberStore as E import Galley.Effects.ProposalStore +import qualified Galley.Effects.SubConversationStore as E import qualified Galley.Effects.TeamStore as E import Galley.Options import Galley.Types.Conversations.Members @@ -120,6 +121,7 @@ type family HasConversationActionEffects (tag :: ConversationActionTag) r :: Con LegalHoldStore, MemberStore, ProposalStore, + SubConversationStore, TeamStore, TinyLog, ConversationStore, @@ -166,6 +168,7 @@ type family HasConversationActionEffects (tag :: ConversationActionTag) r :: Con Input Env, MemberStore, ProposalStore, + SubConversationStore, TeamStore, TinyLog, Input UTCTime, @@ -278,12 +281,14 @@ type family PerformActionCalls tag where PerformActionCalls 'ConversationAccessDataTag = ( CallsFed 'Galley "on-conversation-updated", CallsFed 'Galley "on-mls-message-sent", - CallsFed 'Galley "on-new-remote-conversation" + CallsFed 'Galley "on-new-remote-conversation", + CallsFed 'Galley "on-new-remote-subconversation" ) PerformActionCalls 'ConversationJoinTag = ( CallsFed 'Galley "on-conversation-updated", CallsFed 'Galley "on-mls-message-sent", - CallsFed 'Galley "on-new-remote-conversation" + CallsFed 'Galley "on-new-remote-conversation", + CallsFed 'Galley "on-new-remote-subconversation" ) PerformActionCalls 'ConversationLeaveTag = ( CallsFed 'Galley "on-mls-message-sent" @@ -367,7 +372,8 @@ performConversationJoin :: ( HasConversationActionEffects 'ConversationJoinTag r, CallsFed 'Galley "on-mls-message-sent", CallsFed 'Galley "on-conversation-updated", - CallsFed 'Galley "on-new-remote-conversation" + CallsFed 'Galley "on-new-remote-conversation", + CallsFed 'Galley "on-new-remote-subconversation" ) => Qualified UserId -> Local Conversation -> @@ -449,6 +455,7 @@ performConversationJoin qusr lconv (ConversationJoin invited role) = do LegalHoldStore, MemberStore, ProposalStore, + SubConversationStore, TeamStore, TinyLog ] @@ -497,7 +504,8 @@ performConversationAccessData :: ( HasConversationActionEffects 'ConversationAccessDataTag r, CallsFed 'Galley "on-mls-message-sent", CallsFed 'Galley "on-conversation-updated", - CallsFed 'Galley "on-new-remote-conversation" + CallsFed 'Galley "on-new-remote-conversation", + CallsFed 'Galley "on-new-remote-subconversation" ) => Qualified UserId -> Local Conversation -> @@ -592,12 +600,14 @@ updateLocalConversation :: FederatorAccess, GundeckAccess, Input Env, - Input UTCTime + Input UTCTime, + SubConversationStore ] r, HasConversationActionEffects tag r, SingI tag, CallsFed 'Galley "on-new-remote-conversation", + CallsFed 'Galley "on-new-remote-subconversation", CallsFed 'Galley "on-conversation-updated", PerformActionCalls tag ) => @@ -636,8 +646,10 @@ updateLocalConversationUnchecked :: Member FederatorAccess r, Member GundeckAccess r, Member (Input UTCTime) r, + Member SubConversationStore r, HasConversationActionEffects tag r, CallsFed 'Galley "on-new-remote-conversation", + CallsFed 'Galley "on-new-remote-subconversation", CallsFed 'Galley "on-conversation-updated", PerformActionCalls tag ) => @@ -715,8 +727,16 @@ addMembersToLocalConversation lcnv users role = do notifyConversationAction :: forall tag r. - ( Members '[FederatorAccess, ExternalAccess, GundeckAccess, Input UTCTime] r, + ( Members + '[ FederatorAccess, + ExternalAccess, + GundeckAccess, + Input UTCTime, + SubConversationStore + ] + r, CallsFed 'Galley "on-new-remote-conversation", + CallsFed 'Galley "on-new-remote-subconversation", CallsFed 'Galley "on-conversation-updated" ) => Sing tag -> @@ -741,19 +761,27 @@ notifyConversationAction tag quid notifyOrigDomain con lconv targets action = do uids (SomeConversationAction tag action) - -- call `on-new-remote-conversation` on backends that are seeing this - -- conversation for the first time + -- Backends that are seeing this conversation for the first time need to be + -- notified about this conversation and all its subconversations let newDomains = Set.difference (Set.map void (bmRemotes targets)) (Set.fromList (map (void . rmId) (convRemoteMembers conv))) - let nrc = + subConvs <- Map.assocs <$> E.listSubConversations (convId conv) + E.runFederatedConcurrently_ (toList newDomains) $ \_ -> do + void $ + fedClient @'Galley @"on-new-remote-conversation" NewRemoteConversation { nrcConvId = convId conv, nrcProtocol = convProtocol conv } - E.runFederatedConcurrently_ (toList newDomains) $ \_ -> do - void $ fedClient @'Galley @"on-new-remote-conversation" nrc + for_ subConvs $ \(mSubId, mlsData) -> + fedClient @'Galley @"on-new-remote-subconversation" + NewRemoteSubConversation + { nrscConvId = convId conv, + nrscSubConvId = mSubId, + nrscMlsData = mlsData + } update <- fmap (fromMaybe (mkUpdate []) . asum . map tUnqualified) . E.runFederatedConcurrently (toList (bmRemotes targets)) @@ -834,8 +862,10 @@ kickMember :: Member (Input UTCTime) r, Member (Input Env) r, Member MemberStore r, + Member SubConversationStore r, Member TinyLog r, CallsFed 'Galley "on-new-remote-conversation", + CallsFed 'Galley "on-new-remote-subconversation", CallsFed 'Galley "on-conversation-updated", PerformActionCalls 'ConversationLeaveTag ) => diff --git a/services/galley/src/Galley/API/Federation.hs b/services/galley/src/Galley/API/Federation.hs index ef197e16ab..fbe6da8336 100644 --- a/services/galley/src/Galley/API/Federation.hs +++ b/services/galley/src/Galley/API/Federation.hs @@ -58,7 +58,7 @@ import qualified Galley.Effects.ConversationStore as E import qualified Galley.Effects.FireAndForget as E import qualified Galley.Effects.MemberStore as E import Galley.Effects.ProposalStore (ProposalStore) -import Galley.Effects.SubConversationStore +import qualified Galley.Effects.SubConversationStore as E import Galley.Effects.SubConversationSupply import Galley.Options import Galley.Types.Conversations.Members @@ -108,6 +108,7 @@ federationSitemap :: federationSitemap = Named @"on-conversation-created" onConversationCreated :<|> Named @"on-new-remote-conversation" onNewRemoteConversation + :<|> Named @"on-new-remote-subconversation" onNewRemoteSubConversation :<|> Named @"get-conversations" getConversations :<|> Named @"on-conversation-updated" onConversationUpdated :<|> Named @"leave-conversation" (callsFed leaveConversation) @@ -123,7 +124,7 @@ federationSitemap = :<|> Named @"on-client-removed" (callsFed onClientRemoved) :<|> Named @"on-typing-indicator-updated" onTypingIndicatorUpdated :<|> Named @"get-sub-conversation" getSubConversationForRemoteUser - :<|> Named @"delete-sub-conversation" deleteSubConversationForRemoteUser + :<|> Named @"delete-sub-conversation" (callsFed deleteSubConversationForRemoteUser) onClientRemoved :: ( Members @@ -203,15 +204,37 @@ onConversationCreated domain rc = do pushConversationEvent Nothing event (qualifyAs loc [qUnqualified . Public.memId $ mem]) [] onNewRemoteConversation :: - Member ConversationStore r => + Members + '[ ConversationStore, + SubConversationStore + ] + r => Domain -> F.NewRemoteConversation -> Sem r EmptyResponse onNewRemoteConversation domain nrc = do -- update group_id -> conv_id mapping for_ (preview (to F.nrcProtocol . _ProtocolMLS) nrc) $ \mls -> - E.setGroupIdForConversation (cnvmlsGroupId mls) (Qualified (F.nrcConvId nrc) domain) + E.setGroupIdForConversation + (cnvmlsGroupId mls) + (Qualified (F.nrcConvId nrc) domain) + + pure EmptyResponse +onNewRemoteSubConversation :: + Members + '[ ConversationStore, + SubConversationStore + ] + r => + Domain -> + F.NewRemoteSubConversation -> + Sem r EmptyResponse +onNewRemoteSubConversation domain nrsc = do + E.setGroupIdForSubConversation + (cnvmlsGroupId (F.nrscMlsData nrsc)) + (Qualified (F.nrscConvId nrsc) domain) + (F.nrscSubConvId nrsc) pure EmptyResponse getConversations :: @@ -349,12 +372,14 @@ leaveConversation :: Input UTCTime, MemberStore, ProposalStore, + SubConversationStore, TinyLog ] r, CallsFed 'Galley "on-conversation-updated", CallsFed 'Galley "on-mls-message-sent", - CallsFed 'Galley "on-new-remote-conversation" + CallsFed 'Galley "on-new-remote-conversation", + CallsFed 'Galley "on-new-remote-subconversation" ) => Domain -> F.LeaveConversationRequest -> @@ -487,12 +512,14 @@ onUserDeleted :: Input Env, MemberStore, ProposalStore, + SubConversationStore, TinyLog ] r, CallsFed 'Galley "on-mls-message-sent", CallsFed 'Galley "on-conversation-updated", - CallsFed 'Galley "on-new-remote-conversation" + CallsFed 'Galley "on-new-remote-conversation", + CallsFed 'Galley "on-new-remote-subconversation" ) => Domain -> F.UserDeletedConversationsNotification -> @@ -535,31 +562,33 @@ onUserDeleted origDomain udcn = do updateConversation :: forall r. ( Members - '[ BrigAccess, + '[ BotAccess, + BrigAccess, CodeStore, - BotAccess, - FireAndForget, + ConversationStore, Error FederationError, + Error InternalError, Error InvalidInput, ExternalAccess, FederatorAccess, - Error InternalError, + FireAndForget, GundeckAccess, Input Env, + Input (Local ()), Input Opts, Input UTCTime, LegalHoldStore, MemberStore, ProposalStore, + SubConversationStore, TeamStore, - TinyLog, - ConversationStore, - Input (Local ()) + TinyLog ] r, CallsFed 'Galley "on-conversation-updated", CallsFed 'Galley "on-mls-message-sent", - CallsFed 'Galley "on-new-remote-conversation" + CallsFed 'Galley "on-new-remote-conversation", + CallsFed 'Galley "on-new-remote-subconversation" ) => Domain -> F.ConversationUpdateRequest -> @@ -647,6 +676,7 @@ sendMLSCommitBundle :: CallsFed 'Galley "on-conversation-updated", CallsFed 'Galley "on-mls-message-sent", CallsFed 'Galley "on-new-remote-conversation", + CallsFed 'Galley "on-new-remote-subconversation", CallsFed 'Galley "send-mls-commit-bundle", CallsFed 'Brig "get-mls-clients" ) => @@ -670,7 +700,13 @@ sendMLSCommitBundle remoteDomain msr = qConvOrSub <- E.lookupConvByGroupId (msgGroupId msg) >>= noteS @'ConvNotFound when (qUnqualified qConvOrSub /= F.mmsrConvOrSubId msr) $ throwS @'MLSGroupConversationMismatch F.MLSMessageResponseUpdates . map lcuUpdate - <$> postMLSCommitBundle loc (tUntagged sender) Nothing qConvOrSub Nothing bundle + <$> postMLSCommitBundle + loc + (tUntagged sender) + (Just (mmsrSenderClient msr)) + qConvOrSub + Nothing + bundle sendMLSMessage :: ( Members @@ -697,6 +733,7 @@ sendMLSMessage :: CallsFed 'Galley "on-conversation-updated", CallsFed 'Galley "on-mls-message-sent", CallsFed 'Galley "on-new-remote-conversation", + CallsFed 'Galley "on-new-remote-subconversation", CallsFed 'Galley "send-mls-message", CallsFed 'Brig "get-mls-clients" ) => @@ -721,7 +758,13 @@ sendMLSMessage remoteDomain msr = qConvOrSub <- E.lookupConvByGroupId (msgGroupId msg) >>= noteS @'ConvNotFound when (qUnqualified qConvOrSub /= F.mmsrConvOrSubId msr) $ throwS @'MLSGroupConversationMismatch F.MLSMessageResponseUpdates . map lcuUpdate - <$> postMLSMessage loc (tUntagged sender) Nothing qConvOrSub Nothing raw + <$> postMLSMessage + loc + (tUntagged sender) + (Just (mmsrSenderClient msr)) + qConvOrSub + Nothing + raw class ToGalleyRuntimeError (effs :: EffectRow) r where mapToGalleyError :: @@ -900,16 +943,19 @@ getSubConversationForRemoteUser domain GetSubConversationsRequest {..} = getLocalSubConversation qusr lconv gsreqSubConv deleteSubConversationForRemoteUser :: - Members - '[ ConversationStore, - Input (Local ()), - Input Env, - MemberStore, - Resource, - SubConversationStore, - SubConversationSupply - ] - r => + ( Members + '[ ConversationStore, + FederatorAccess, + Input (Local ()), + Input Env, + MemberStore, + Resource, + SubConversationStore, + SubConversationSupply + ] + r, + CallsFed 'Galley "on-new-remote-subconversation" + ) => Domain -> DeleteSubConversationRequest -> Sem r DeleteSubConversationResponse diff --git a/services/galley/src/Galley/API/Internal.hs b/services/galley/src/Galley/API/Internal.hs index c334e60031..8a1582dbda 100644 --- a/services/galley/src/Galley/API/Internal.hs +++ b/services/galley/src/Galley/API/Internal.hs @@ -133,7 +133,8 @@ type LegalHoldFeatureStatusChangeErrors = type LegalHoldFeaturesStatusChangeFederatedCalls = '[ MakesFederatedCall 'Galley "on-conversation-updated", MakesFederatedCall 'Galley "on-mls-message-sent", - MakesFederatedCall 'Galley "on-new-remote-conversation" + MakesFederatedCall 'Galley "on-new-remote-conversation", + MakesFederatedCall 'Galley "on-new-remote-subconversation" ] type IFeatureAPI = diff --git a/services/galley/src/Galley/API/LegalHold.hs b/services/galley/src/Galley/API/LegalHold.hs index cfb7e9cbae..c581de86da 100644 --- a/services/galley/src/Galley/API/LegalHold.hs +++ b/services/galley/src/Galley/API/LegalHold.hs @@ -213,6 +213,7 @@ removeSettingsInternalPaging :: MemberStore, ProposalStore, P.TinyLog, + SubConversationStore, TeamFeatureStore db, TeamMemberStore InternalPaging, TeamStore, @@ -221,7 +222,8 @@ removeSettingsInternalPaging :: r, CallsFed 'Galley "on-conversation-updated", CallsFed 'Galley "on-mls-message-sent", - CallsFed 'Galley "on-new-remote-conversation" + CallsFed 'Galley "on-new-remote-conversation", + CallsFed 'Galley "on-new-remote-subconversation" ) => TeamFeatures.FeaturePersistentConstraint db Public.LegalholdConfig => Local UserId -> @@ -262,6 +264,7 @@ removeSettings :: MemberStore, ProposalStore, P.TinyLog, + SubConversationStore, TeamFeatureStore db, TeamMemberStore p, TeamStore @@ -269,7 +272,8 @@ removeSettings :: r, CallsFed 'Galley "on-conversation-updated", CallsFed 'Galley "on-mls-message-sent", - CallsFed 'Galley "on-new-remote-conversation" + CallsFed 'Galley "on-new-remote-conversation", + CallsFed 'Galley "on-new-remote-subconversation" ) => TeamFeatures.FeaturePersistentConstraint db Public.LegalholdConfig => UserId -> @@ -326,12 +330,14 @@ removeSettings' :: TeamMemberStore p, TeamStore, ProposalStore, - P.TinyLog + P.TinyLog, + SubConversationStore ] r, CallsFed 'Galley "on-conversation-updated", CallsFed 'Galley "on-mls-message-sent", - CallsFed 'Galley "on-new-remote-conversation" + CallsFed 'Galley "on-new-remote-conversation", + CallsFed 'Galley "on-new-remote-subconversation" ) => TeamId -> Sem r () @@ -418,12 +424,14 @@ grantConsent :: MemberStore, ProposalStore, P.TinyLog, + SubConversationStore, TeamStore ] r, CallsFed 'Galley "on-conversation-updated", CallsFed 'Galley "on-mls-message-sent", - CallsFed 'Galley "on-new-remote-conversation" + CallsFed 'Galley "on-new-remote-conversation", + CallsFed 'Galley "on-new-remote-subconversation" ) => Local UserId -> TeamId -> @@ -468,13 +476,15 @@ requestDevice :: MemberStore, ProposalStore, P.TinyLog, + SubConversationStore, TeamFeatureStore db, TeamStore ] r, CallsFed 'Galley "on-conversation-updated", CallsFed 'Galley "on-mls-message-sent", - CallsFed 'Galley "on-new-remote-conversation" + CallsFed 'Galley "on-new-remote-conversation", + CallsFed 'Galley "on-new-remote-subconversation" ) => TeamFeatures.FeaturePersistentConstraint db Public.LegalholdConfig => Local UserId -> @@ -552,13 +562,15 @@ approveDevice :: MemberStore, ProposalStore, P.TinyLog, + SubConversationStore, TeamFeatureStore db, TeamStore ] r, CallsFed 'Galley "on-conversation-updated", CallsFed 'Galley "on-mls-message-sent", - CallsFed 'Galley "on-new-remote-conversation" + CallsFed 'Galley "on-new-remote-conversation", + CallsFed 'Galley "on-new-remote-subconversation" ) => TeamFeatures.FeaturePersistentConstraint db Public.LegalholdConfig => Local UserId -> @@ -633,12 +645,14 @@ disableForUser :: MemberStore, ProposalStore, P.TinyLog, + SubConversationStore, TeamStore ] r, CallsFed 'Galley "on-conversation-updated", CallsFed 'Galley "on-mls-message-sent", - CallsFed 'Galley "on-new-remote-conversation" + CallsFed 'Galley "on-new-remote-conversation", + CallsFed 'Galley "on-new-remote-subconversation" ) => Local UserId -> TeamId -> @@ -690,12 +704,14 @@ changeLegalholdStatus :: MemberStore, TeamStore, ProposalStore, - P.TinyLog + P.TinyLog, + SubConversationStore ] r, CallsFed 'Galley "on-conversation-updated", CallsFed 'Galley "on-mls-message-sent", - CallsFed 'Galley "on-new-remote-conversation" + CallsFed 'Galley "on-new-remote-conversation", + CallsFed 'Galley "on-new-remote-subconversation" ) => TeamId -> Local UserId -> @@ -810,12 +826,14 @@ handleGroupConvPolicyConflicts :: MemberStore, ProposalStore, P.TinyLog, + SubConversationStore, TeamStore ] r, CallsFed 'Galley "on-conversation-updated", CallsFed 'Galley "on-mls-message-sent", - CallsFed 'Galley "on-new-remote-conversation" + CallsFed 'Galley "on-new-remote-conversation", + CallsFed 'Galley "on-new-remote-subconversation" ) => Local UserId -> UserLegalHoldStatus -> diff --git a/services/galley/src/Galley/API/MLS/Message.hs b/services/galley/src/Galley/API/MLS/Message.hs index f8c7ab52ad..d860a7cf30 100644 --- a/services/galley/src/Galley/API/MLS/Message.hs +++ b/services/galley/src/Galley/API/MLS/Message.hs @@ -151,6 +151,7 @@ postMLSMessageFromLocalUserV1 :: CallsFed 'Galley "send-mls-message", CallsFed 'Galley "on-conversation-updated", CallsFed 'Galley "on-new-remote-conversation", + CallsFed 'Galley "on-new-remote-subconversation", CallsFed 'Brig "get-mls-clients" ) => Local UserId -> @@ -196,6 +197,7 @@ postMLSMessageFromLocalUser :: CallsFed 'Galley "send-mls-message", CallsFed 'Galley "on-conversation-updated", CallsFed 'Galley "on-new-remote-conversation", + CallsFed 'Galley "on-new-remote-subconversation", CallsFed 'Brig "get-mls-clients" ) => Local UserId -> @@ -234,6 +236,7 @@ postMLSCommitBundle :: CallsFed 'Galley "send-mls-commit-bundle", CallsFed 'Galley "on-conversation-updated", CallsFed 'Galley "on-new-remote-conversation", + CallsFed 'Galley "on-new-remote-subconversation", CallsFed 'Brig "get-mls-clients" ) => Local x -> @@ -247,7 +250,7 @@ postMLSCommitBundle loc qusr mc qConvOrSub conn rawBundle = foldQualified loc (postMLSCommitBundleToLocalConv qusr mc conn rawBundle) - (postMLSCommitBundleToRemoteConv loc qusr conn rawBundle) + (postMLSCommitBundleToRemoteConv loc qusr mc conn rawBundle) qConvOrSub postMLSCommitBundleFromLocalUser :: @@ -273,6 +276,7 @@ postMLSCommitBundleFromLocalUser :: CallsFed 'Galley "send-mls-commit-bundle", CallsFed 'Galley "on-conversation-updated", CallsFed 'Galley "on-new-remote-conversation", + CallsFed 'Galley "on-new-remote-subconversation", CallsFed 'Brig "get-mls-clients" ) => Local UserId -> @@ -311,6 +315,7 @@ postMLSCommitBundleToLocalConv :: CallsFed 'Galley "mls-welcome", CallsFed 'Galley "on-conversation-updated", CallsFed 'Galley "on-new-remote-conversation", + CallsFed 'Galley "on-new-remote-subconversation", CallsFed 'Brig "get-mls-clients" ) => Qualified UserId -> @@ -362,7 +367,8 @@ postMLSCommitBundleToLocalConv qusr mc conn bundle lConvOrSubId = do postMLSCommitBundleToRemoteConv :: ( Members MLSBundleStaticErrors r, Members - '[ Error FederationError, + '[ BrigAccess, + Error FederationError, Error MLSProtocolError, Error MLSProposalFailure, ExternalAccess, @@ -376,23 +382,33 @@ postMLSCommitBundleToRemoteConv :: ) => Local x -> Qualified UserId -> + Maybe ClientId -> Maybe ConnId -> CommitBundle -> Remote ConvOrSubConvId -> Sem r [LocalConversationUpdate] -postMLSCommitBundleToRemoteConv loc qusr con bundle rConvOrSubId = do +postMLSCommitBundleToRemoteConv loc qusr mc con bundle rConvOrSubId = do -- only local users can send messages to remote conversations lusr <- foldQualified loc pure (\_ -> throwS @'ConvAccessDenied) qusr -- only members may send commit bundles to a remote conversation flip unless (throwS @'ConvMemberNotFound) =<< checkLocalMemberRemoteConv (tUnqualified lusr) (convOfConvOrSub <$> rConvOrSubId) + senderIdentity <- + noteS @'MLSMissingSenderClient + =<< getSenderIdentity + qusr + mc + SMLSPlainText + (rmValue (cbCommitMsg bundle)) + resp <- runFederated rConvOrSubId $ fedClient @'Galley @"send-mls-commit-bundle" $ MLSMessageSendRequest { mmsrConvOrSubId = tUnqualified rConvOrSubId, mmsrSender = tUnqualified lusr, + mmsrSenderClient = ciClient senderIdentity, mmsrRawMessage = Base64ByteString (serializeCommitBundle bundle) } updates <- case resp of @@ -435,6 +451,7 @@ postMLSMessage :: CallsFed 'Galley "send-mls-message", CallsFed 'Galley "on-conversation-updated", CallsFed 'Galley "on-new-remote-conversation", + CallsFed 'Galley "on-new-remote-subconversation", CallsFed 'Brig "get-mls-clients" ) => Local x -> @@ -530,6 +547,7 @@ postMLSMessageToLocalConv :: CallsFed 'Galley "on-mls-message-sent", CallsFed 'Galley "on-conversation-updated", CallsFed 'Galley "on-new-remote-conversation", + CallsFed 'Galley "on-new-remote-subconversation", CallsFed 'Brig "get-mls-clients" ) => Qualified UserId -> @@ -577,18 +595,21 @@ postMLSMessageToRemoteConv :: RawMLS SomeMessage -> Remote ConvOrSubConvId -> Sem r [LocalConversationUpdate] -postMLSMessageToRemoteConv loc qusr _senderClient con smsg rConvOrSubId = do +postMLSMessageToRemoteConv loc qusr mc con smsg rConvOrSubId = do -- only local users can send messages to remote conversations lusr <- foldQualified loc pure (\_ -> throwS @'ConvAccessDenied) qusr -- only members may send messages to the remote conversation flip unless (throwS @'ConvMemberNotFound) =<< checkLocalMemberRemoteConv (tUnqualified lusr) (convOfConvOrSub <$> rConvOrSubId) + senderClient <- noteS @'MLSMissingSenderClient mc + resp <- runFederated rConvOrSubId $ fedClient @'Galley @"send-mls-message" $ MLSMessageSendRequest { mmsrConvOrSubId = tUnqualified rConvOrSubId, mmsrSender = tUnqualified lusr, + mmsrSenderClient = senderClient, mmsrRawMessage = Base64ByteString (rmRaw smsg) } updates <- case resp of @@ -699,6 +720,7 @@ processCommit :: Member SubConversationStore r, CallsFed 'Galley "on-mls-message-sent", CallsFed 'Galley "on-conversation-updated", + CallsFed 'Galley "on-new-remote-subconversation", CallsFed 'Galley "on-new-remote-conversation", CallsFed 'Brig "get-mls-clients" ) => @@ -854,6 +876,7 @@ processCommitWithAction :: CallsFed 'Galley "on-mls-message-sent", CallsFed 'Galley "on-conversation-updated", CallsFed 'Galley "on-new-remote-conversation", + CallsFed 'Galley "on-new-remote-subconversation", CallsFed 'Brig "get-mls-clients" ) => Qualified UserId -> @@ -893,6 +916,7 @@ processInternalCommit :: CallsFed 'Galley "on-conversation-updated", CallsFed 'Galley "on-mls-message-sent", CallsFed 'Galley "on-new-remote-conversation", + CallsFed 'Galley "on-new-remote-subconversation", CallsFed 'Brig "get-mls-clients" ) => Qualified UserId -> @@ -1239,11 +1263,13 @@ type HasProposalActionEffects r = Member LegalHoldStore r, Member MemberStore r, Member ProposalStore r, + Member SubConversationStore r, Member TeamStore r, Member TinyLog r, CallsFed 'Galley "on-conversation-updated", CallsFed 'Galley "on-mls-message-sent", - CallsFed 'Galley "on-new-remote-conversation" + CallsFed 'Galley "on-new-remote-conversation", + CallsFed 'Galley "on-new-remote-subconversation" ) executeProposalAction :: @@ -1343,6 +1369,25 @@ executeProposalAction qusr con lconvOrSub action = do for_ (Map.assocs (paRemove action)) $ \(qtarget, clients) -> do removeMLSClients (cnvmlsGroupId mlsMeta) qtarget (Map.keysSet clients) + -- if this is a new subconversation, call `on-new-remote-conversation` on all + -- the remote backends involved in the main conversation + forOf_ _SubConv convOrSub $ \(mlsConv, subConv) -> do + when (cnvmlsEpoch (scMLSData subConv) == Epoch 0) $ do + let remoteDomains = + Set.fromList + ( map + (void . rmId) + (mcRemoteMembers mlsConv) + ) + let nrc = + NewRemoteSubConversation + { nrscConvId = mcId mlsConv, + nrscSubConvId = scSubConvId subConv, + nrscMlsData = scMLSData subConv + } + runFederatedConcurrently_ (toList remoteDomains) $ \_ -> do + void $ fedClient @'Galley @"on-new-remote-subconversation" nrc + pure (addEvents <> removeEvents) where checkRemoval :: diff --git a/services/galley/src/Galley/API/MLS/SubConversation.hs b/services/galley/src/Galley/API/MLS/SubConversation.hs index 9f9617f35f..79ac6534d2 100644 --- a/services/galley/src/Galley/API/MLS/SubConversation.hs +++ b/services/galley/src/Galley/API/MLS/SubConversation.hs @@ -40,11 +40,12 @@ import qualified Galley.Data.Conversation as Data import Galley.Data.Conversation.Types import Galley.Effects import Galley.Effects.FederatorAccess +import qualified Galley.Effects.FederatorAccess as Eff import qualified Galley.Effects.MemberStore as Eff -import Galley.Effects.SubConversationStore (SubConversationStore) import qualified Galley.Effects.SubConversationStore as Eff import Galley.Effects.SubConversationSupply (SubConversationSupply) import qualified Galley.Effects.SubConversationSupply as Eff +import Galley.Types.Conversations.Members import Imports import Polysemy import Polysemy.Error @@ -233,7 +234,8 @@ deleteSubConversation :: SubConversationSupply ] r, - CallsFed 'Galley "delete-sub-conversation" + CallsFed 'Galley "delete-sub-conversation", + CallsFed 'Galley "on-new-remote-subconversation" ) => Local UserId -> Qualified ConvId -> @@ -248,19 +250,22 @@ deleteSubConversation lusr qconv sconv dsc = qconv deleteLocalSubConversation :: - Members - '[ ConversationStore, - ErrorS 'ConvAccessDenied, - ErrorS 'ConvNotFound, - ErrorS 'MLSNotEnabled, - ErrorS 'MLSStaleMessage, - Input Env, - MemberStore, - Resource, - SubConversationStore, - SubConversationSupply - ] - r => + ( Members + '[ ConversationStore, + ErrorS 'ConvAccessDenied, + ErrorS 'ConvNotFound, + ErrorS 'MLSNotEnabled, + ErrorS 'MLSStaleMessage, + FederatorAccess, + Input Env, + MemberStore, + Resource, + SubConversationStore, + SubConversationSupply + ] + r, + CallsFed 'Galley "on-new-remote-subconversation" + ) => Qualified UserId -> Local ConvId -> SubConvId -> @@ -271,7 +276,7 @@ deleteLocalSubConversation qusr lcnvId scnvId dsc = do let cnvId = tUnqualified lcnvId cnv <- getConversationAndCheckMembership qusr lcnvId cs <- cnvmlsCipherSuite <$> noteS @'ConvNotFound (mlsMetadata cnv) - withCommitLock (dscGroupId dsc) (dscEpoch dsc) $ do + mlsData <- withCommitLock (dscGroupId dsc) (dscEpoch dsc) $ do sconv <- Eff.getSubConversation cnvId scnvId >>= noteS @'ConvNotFound @@ -287,6 +292,17 @@ deleteLocalSubConversation qusr lcnvId scnvId dsc = do -- the following overwrites any prior information about the subconversation Eff.createSubConversation cnvId scnvId cs (Epoch 0) newGid Nothing + pure (scMLSData sconv) + + -- notify all backends that the subconversation has a new ID + let remotes = bucketRemote (map rmId (convRemoteMembers cnv)) + Eff.runFederatedConcurrently_ remotes $ \_ -> do + fedClient @'Galley @"on-new-remote-subconversation" + NewRemoteSubConversation + { nrscConvId = cnvId, + nrscSubConvId = scnvId, + nrscMlsData = mlsData + } deleteRemoteSubConversation :: ( Members diff --git a/services/galley/src/Galley/API/Teams.hs b/services/galley/src/Galley/API/Teams.hs index fcad2b51e5..8077788733 100644 --- a/services/galley/src/Galley/API/Teams.hs +++ b/services/galley/src/Galley/API/Teams.hs @@ -1116,11 +1116,13 @@ deleteTeamConversation :: GundeckAccess, Input Env, Input UTCTime, + SubConversationStore, TeamStore ] r, CallsFed 'Galley "on-conversation-updated", - CallsFed 'Galley "on-new-remote-conversation" + CallsFed 'Galley "on-new-remote-conversation", + CallsFed 'Galley "on-new-remote-subconversation" ) => Local UserId -> ConnId -> diff --git a/services/galley/src/Galley/API/Teams/Features.hs b/services/galley/src/Galley/API/Teams/Features.hs index 3da18e4848..479caa616e 100644 --- a/services/galley/src/Galley/API/Teams/Features.hs +++ b/services/galley/src/Galley/API/Teams/Features.hs @@ -715,7 +715,8 @@ instance GetFeatureConfig db LegalholdConfig where instance ( CallsFed 'Galley "on-conversation-updated", CallsFed 'Galley "on-mls-message-sent", - CallsFed 'Galley "on-new-remote-conversation" + CallsFed 'Galley "on-new-remote-conversation", + CallsFed 'Galley "on-new-remote-subconversation" ) => SetFeatureConfig db LegalholdConfig where @@ -749,6 +750,7 @@ instance ListItems LegacyPaging ConvId, MemberStore, ProposalStore, + SubConversationStore, TeamFeatureStore db, TeamStore, TeamMemberStore InternalPaging, diff --git a/services/galley/src/Galley/API/Update.hs b/services/galley/src/Galley/API/Update.hs index 06133de467..ee5182b13a 100644 --- a/services/galley/src/Galley/API/Update.hs +++ b/services/galley/src/Galley/API/Update.hs @@ -285,6 +285,7 @@ type UpdateConversationAccessEffects = Input UTCTime, MemberStore, ProposalStore, + SubConversationStore, TeamStore, TinyLog ] @@ -293,6 +294,7 @@ updateConversationAccess :: ( Members UpdateConversationAccessEffects r, CallsFed 'Galley "on-mls-message-sent", CallsFed 'Galley "on-new-remote-conversation", + CallsFed 'Galley "on-new-remote-subconversation", CallsFed 'Galley "on-conversation-updated" ) => Local UserId -> @@ -309,6 +311,7 @@ updateConversationAccessUnqualified :: ( Members UpdateConversationAccessEffects r, CallsFed 'Galley "on-mls-message-sent", CallsFed 'Galley "on-new-remote-conversation", + CallsFed 'Galley "on-new-remote-subconversation", CallsFed 'Galley "on-conversation-updated" ) => Local UserId -> @@ -339,11 +342,13 @@ updateConversationReceiptMode :: Input Env, Input UTCTime, MemberStore, + SubConversationStore, TinyLog ] r, CallsFed 'Galley "on-conversation-updated", CallsFed 'Galley "on-new-remote-conversation", + CallsFed 'Galley "on-new-remote-subconversation", CallsFed 'Galley "update-conversation" ) => Local UserId -> @@ -419,11 +424,13 @@ updateConversationReceiptModeUnqualified :: Input Env, Input UTCTime, MemberStore, + SubConversationStore, TinyLog ] r, CallsFed 'Galley "on-conversation-updated", CallsFed 'Galley "on-new-remote-conversation", + CallsFed 'Galley "on-new-remote-subconversation", CallsFed 'Galley "update-conversation" ) => Local UserId -> @@ -444,11 +451,13 @@ updateConversationMessageTimer :: FederatorAccess, GundeckAccess, Input Env, - Input UTCTime + Input UTCTime, + SubConversationStore ] r, CallsFed 'Galley "on-conversation-updated", - CallsFed 'Galley "on-new-remote-conversation" + CallsFed 'Galley "on-new-remote-conversation", + CallsFed 'Galley "on-new-remote-subconversation" ) => Local UserId -> ConnId -> @@ -482,11 +491,13 @@ updateConversationMessageTimerUnqualified :: FederatorAccess, GundeckAccess, Input Env, - Input UTCTime + Input UTCTime, + SubConversationStore ] r, CallsFed 'Galley "on-conversation-updated", - CallsFed 'Galley "on-new-remote-conversation" + CallsFed 'Galley "on-new-remote-conversation", + CallsFed 'Galley "on-new-remote-subconversation" ) => Local UserId -> ConnId -> @@ -509,11 +520,13 @@ deleteLocalConversation :: GundeckAccess, Input Env, Input UTCTime, + SubConversationStore, TeamStore ] r, CallsFed 'Galley "on-conversation-updated", - CallsFed 'Galley "on-new-remote-conversation" + CallsFed 'Galley "on-new-remote-conversation", + CallsFed 'Galley "on-new-remote-subconversation" ) => Local UserId -> ConnId -> @@ -718,13 +731,15 @@ joinConversationByReusableCode :: Input Opts, Input UTCTime, MemberStore, + SubConversationStore, TeamStore, TeamFeatureStore db ] r, FeaturePersistentConstraint db GuestLinksConfig, CallsFed 'Galley "on-conversation-updated", - CallsFed 'Galley "on-new-remote-conversation" + CallsFed 'Galley "on-new-remote-conversation", + CallsFed 'Galley "on-new-remote-subconversation" ) => Local UserId -> ConnId -> @@ -752,12 +767,14 @@ joinConversationById :: Input Opts, Input UTCTime, MemberStore, + SubConversationStore, TeamStore, TeamFeatureStore db ] r, CallsFed 'Galley "on-conversation-updated", - CallsFed 'Galley "on-new-remote-conversation" + CallsFed 'Galley "on-new-remote-conversation", + CallsFed 'Galley "on-new-remote-subconversation" ) => Local UserId -> ConnId -> @@ -781,12 +798,14 @@ joinConversation :: Input Opts, Input UTCTime, MemberStore, + SubConversationStore, TeamStore, TeamFeatureStore db ] r, CallsFed 'Galley "on-conversation-updated", - CallsFed 'Galley "on-new-remote-conversation" + CallsFed 'Galley "on-new-remote-conversation", + CallsFed 'Galley "on-new-remote-subconversation" ) => Local UserId -> ConnId -> @@ -840,13 +859,15 @@ addMembers :: LegalHoldStore, MemberStore, ProposalStore, + SubConversationStore, TeamStore, TinyLog ] r, CallsFed 'Galley "on-conversation-updated", CallsFed 'Galley "on-mls-message-sent", - CallsFed 'Galley "on-new-remote-conversation" + CallsFed 'Galley "on-new-remote-conversation", + CallsFed 'Galley "on-new-remote-subconversation" ) => Local UserId -> ConnId -> @@ -883,13 +904,15 @@ addMembersUnqualifiedV2 :: LegalHoldStore, MemberStore, ProposalStore, + SubConversationStore, TeamStore, TinyLog ] r, CallsFed 'Galley "on-conversation-updated", CallsFed 'Galley "on-mls-message-sent", - CallsFed 'Galley "on-new-remote-conversation" + CallsFed 'Galley "on-new-remote-conversation", + CallsFed 'Galley "on-new-remote-subconversation" ) => Local UserId -> ConnId -> @@ -926,13 +949,15 @@ addMembersUnqualified :: LegalHoldStore, MemberStore, ProposalStore, + SubConversationStore, TeamStore, TinyLog ] r, CallsFed 'Galley "on-conversation-updated", CallsFed 'Galley "on-mls-message-sent", - CallsFed 'Galley "on-new-remote-conversation" + CallsFed 'Galley "on-new-remote-conversation", + CallsFed 'Galley "on-new-remote-subconversation" ) => Local UserId -> ConnId -> @@ -1024,11 +1049,13 @@ updateOtherMemberLocalConv :: GundeckAccess, Input Env, Input UTCTime, - MemberStore + MemberStore, + SubConversationStore ] r, CallsFed 'Galley "on-conversation-updated", - CallsFed 'Galley "on-new-remote-conversation" + CallsFed 'Galley "on-new-remote-conversation", + CallsFed 'Galley "on-new-remote-subconversation" ) => Local ConvId -> Local UserId -> @@ -1055,11 +1082,13 @@ updateOtherMemberUnqualified :: GundeckAccess, Input Env, Input UTCTime, - MemberStore + MemberStore, + SubConversationStore ] r, CallsFed 'Galley "on-conversation-updated", - CallsFed 'Galley "on-new-remote-conversation" + CallsFed 'Galley "on-new-remote-conversation", + CallsFed 'Galley "on-new-remote-subconversation" ) => Local UserId -> ConnId -> @@ -1086,11 +1115,13 @@ updateOtherMember :: GundeckAccess, Input Env, Input UTCTime, - MemberStore + MemberStore, + SubConversationStore ] r, CallsFed 'Galley "on-conversation-updated", - CallsFed 'Galley "on-new-remote-conversation" + CallsFed 'Galley "on-new-remote-conversation", + CallsFed 'Galley "on-new-remote-subconversation" ) => Local UserId -> ConnId -> @@ -1126,13 +1157,15 @@ removeMemberUnqualified :: Input UTCTime, MemberStore, ProposalStore, + SubConversationStore, TinyLog ] r, CallsFed 'Galley "leave-conversation", CallsFed 'Galley "on-conversation-updated", CallsFed 'Galley "on-mls-message-sent", - CallsFed 'Galley "on-new-remote-conversation" + CallsFed 'Galley "on-new-remote-conversation", + CallsFed 'Galley "on-new-remote-subconversation" ) => Local UserId -> ConnId -> @@ -1158,13 +1191,15 @@ removeMemberQualified :: Input UTCTime, MemberStore, ProposalStore, + SubConversationStore, TinyLog ] r, CallsFed 'Galley "leave-conversation", CallsFed 'Galley "on-conversation-updated", CallsFed 'Galley "on-mls-message-sent", - CallsFed 'Galley "on-new-remote-conversation" + CallsFed 'Galley "on-new-remote-conversation", + CallsFed 'Galley "on-new-remote-subconversation" ) => Local UserId -> ConnId -> @@ -1234,12 +1269,14 @@ removeMemberFromLocalConv :: Input UTCTime, MemberStore, ProposalStore, + SubConversationStore, TinyLog ] r, CallsFed 'Galley "on-conversation-updated", CallsFed 'Galley "on-mls-message-sent", - CallsFed 'Galley "on-new-remote-conversation" + CallsFed 'Galley "on-new-remote-conversation", + CallsFed 'Galley "on-new-remote-subconversation" ) => Local ConvId -> Local UserId -> @@ -1454,11 +1491,13 @@ updateConversationName :: FederatorAccess, GundeckAccess, Input Env, - Input UTCTime + Input UTCTime, + SubConversationStore ] r, CallsFed 'Galley "on-conversation-updated", - CallsFed 'Galley "on-new-remote-conversation" + CallsFed 'Galley "on-new-remote-conversation", + CallsFed 'Galley "on-new-remote-subconversation" ) => Local UserId -> ConnId -> @@ -1484,11 +1523,13 @@ updateUnqualifiedConversationName :: FederatorAccess, GundeckAccess, Input Env, - Input UTCTime + Input UTCTime, + SubConversationStore ] r, CallsFed 'Galley "on-conversation-updated", - CallsFed 'Galley "on-new-remote-conversation" + CallsFed 'Galley "on-new-remote-conversation", + CallsFed 'Galley "on-new-remote-subconversation" ) => Local UserId -> ConnId -> @@ -1510,11 +1551,13 @@ updateLocalConversationName :: FederatorAccess, GundeckAccess, Input Env, - Input UTCTime + Input UTCTime, + SubConversationStore ] r, CallsFed 'Galley "on-conversation-updated", - CallsFed 'Galley "on-new-remote-conversation" + CallsFed 'Galley "on-new-remote-conversation", + CallsFed 'Galley "on-new-remote-subconversation" ) => Local UserId -> ConnId -> diff --git a/services/galley/src/Galley/Cassandra/Queries.hs b/services/galley/src/Galley/Cassandra/Queries.hs index 78771cefd5..e5e5be455c 100644 --- a/services/galley/src/Galley/Cassandra/Queries.hs +++ b/services/galley/src/Galley/Cassandra/Queries.hs @@ -347,6 +347,9 @@ lookupGroupIdForSubConversation = "SELECT conv_id, domain, subconv_id from group insertEpochForSubConversation :: PrepQuery W (Epoch, ConvId, SubConvId) () insertEpochForSubConversation = "UPDATE subconversation set epoch = ? WHERE conv_id = ? AND subconv_id = ?" +listSubConversations :: PrepQuery R (Identity ConvId) (SubConvId, CipherSuiteTag, Epoch, Writetime Epoch, GroupId) +listSubConversations = "SELECT subconv_id, cipher_suite, epoch, WRITETIME(epoch), group_id FROM subconversation WHERE conv_id = ?" + -- Members ------------------------------------------------------------------ type MemberStatus = Int32 diff --git a/services/galley/src/Galley/Cassandra/SubConversation.hs b/services/galley/src/Galley/Cassandra/SubConversation.hs index 6dd6dca3ed..be9e188ccb 100644 --- a/services/galley/src/Galley/Cassandra/SubConversation.hs +++ b/services/galley/src/Galley/Cassandra/SubConversation.hs @@ -20,6 +20,7 @@ module Galley.Cassandra.SubConversation where import Cassandra import Cassandra.Util import Data.Id +import qualified Data.Map as Map import Data.Qualified import Data.Time.Clock import Galley.API.MLS.Types (SubConversation (..)) @@ -54,10 +55,6 @@ selectSubConversation convId subConvId = do }, scMembers = cm } - where - epochTimestamp :: Epoch -> Writetime Epoch -> Maybe UTCTime - epochTimestamp (Epoch 0) _ = Nothing - epochTimestamp _ (Writetime t) = Just t insertSubConversation :: ConvId -> SubConvId -> CipherSuiteTag -> Epoch -> GroupId -> Maybe OpaquePublicGroupState -> Client () insertSubConversation convId subConvId suite epoch groupId mPgs = @@ -83,6 +80,21 @@ deleteGroupId :: GroupId -> Client () deleteGroupId groupId = retry x5 $ write Cql.deleteGroupIdForSubconv (params LocalQuorum (Identity groupId)) +listSubConversations :: ConvId -> Client (Map SubConvId ConversationMLSData) +listSubConversations cid = do + subs <- retry x1 (query Cql.listSubConversations (params LocalQuorum (Identity cid))) + pure . Map.fromList $ do + (subId, cs, epoch, ts, gid) <- subs + pure + ( subId, + ConversationMLSData + { cnvmlsGroupId = gid, + cnvmlsEpoch = epoch, + cnvmlsEpochTimestamp = epochTimestamp epoch ts, + cnvmlsCipherSuite = cs + } + ) + interpretSubConversationStoreToCassandra :: Members '[Embed IO, Input ClientState] r => Sem (SubConversationStore ': r) a -> @@ -95,3 +107,11 @@ interpretSubConversationStoreToCassandra = interpret $ \case SetGroupIdForSubConversation gId cid sconv -> embedClient $ setGroupIdForSubConversation gId cid sconv SetSubConversationEpoch cid sconv epoch -> embedClient $ setEpochForSubConversation cid sconv epoch DeleteGroupIdForSubConversation groupId -> embedClient $ deleteGroupId groupId + ListSubConversations cid -> embedClient $ listSubConversations cid + +-------------------------------------------------------------------------------- +-- Utilities + +epochTimestamp :: Epoch -> Writetime Epoch -> Maybe UTCTime +epochTimestamp (Epoch 0) _ = Nothing +epochTimestamp _ (Writetime t) = Just t diff --git a/services/galley/src/Galley/Effects.hs b/services/galley/src/Galley/Effects.hs index 62cd8d5f64..37fea753aa 100644 --- a/services/galley/src/Galley/Effects.hs +++ b/services/galley/src/Galley/Effects.hs @@ -36,6 +36,7 @@ module Galley.Effects ClientStore, CodeStore, ConversationStore, + SubConversationStore, CustomBackendStore, LegalHoldStore, MemberStore, diff --git a/services/galley/src/Galley/Effects/FederatorAccess.hs b/services/galley/src/Galley/Effects/FederatorAccess.hs index 1c4a190087..d4d5d64199 100644 --- a/services/galley/src/Galley/Effects/FederatorAccess.hs +++ b/services/galley/src/Galley/Effects/FederatorAccess.hs @@ -65,6 +65,6 @@ makeSem ''FederatorAccess runFederatedConcurrently_ :: (KnownComponent c, Foldable f, Functor f, Member FederatorAccess r) => f (Remote a) -> - (Remote [a] -> FederatorClient c ()) -> + (Remote [a] -> FederatorClient c x) -> Sem r () runFederatedConcurrently_ xs = void . runFederatedConcurrently xs diff --git a/services/galley/src/Galley/Effects/SubConversationStore.hs b/services/galley/src/Galley/Effects/SubConversationStore.hs index cb6f41b05e..29d5d0f3ce 100644 --- a/services/galley/src/Galley/Effects/SubConversationStore.hs +++ b/services/galley/src/Galley/Effects/SubConversationStore.hs @@ -24,8 +24,8 @@ import Data.Qualified import Galley.API.MLS.Types import Imports import Polysemy +import Wire.API.Conversation.Protocol import Wire.API.MLS.CipherSuite -import Wire.API.MLS.Epoch import Wire.API.MLS.Group import Wire.API.MLS.PublicGroupState import Wire.API.MLS.SubConversation @@ -38,5 +38,6 @@ data SubConversationStore m a where SetGroupIdForSubConversation :: GroupId -> Qualified ConvId -> SubConvId -> SubConversationStore m () SetSubConversationEpoch :: ConvId -> SubConvId -> Epoch -> SubConversationStore m () DeleteGroupIdForSubConversation :: GroupId -> SubConversationStore m () + ListSubConversations :: ConvId -> SubConversationStore m (Map SubConvId ConversationMLSData) makeSem ''SubConversationStore diff --git a/services/galley/test/integration/API.hs b/services/galley/test/integration/API.hs index e337a96aa6..f88336c54f 100644 --- a/services/galley/test/integration/API.hs +++ b/services/galley/test/integration/API.hs @@ -2954,8 +2954,10 @@ deleteRemoteMemberConvLocalQualifiedOk = do Left err -> assertFailure err Right e -> assertLeaveEvent qconvId qAlice [qChad] e - let [remote1GalleyFederatedRequest] = fedRequestsForDomain remoteDomain1 Galley federatedRequests - [remote2GalleyFederatedRequest] = fedRequestsForDomain remoteDomain2 Galley federatedRequests + remote1GalleyFederatedRequest <- + assertOne (filter ((== "on-conversation-updated") . frRPC) (fedRequestsForDomain remoteDomain1 Galley federatedRequests)) + remote2GalleyFederatedRequest <- + assertOne (filter ((== "on-conversation-updated") . frRPC) (fedRequestsForDomain remoteDomain2 Galley federatedRequests)) assertRemoveUpdate remote1GalleyFederatedRequest qconvId qAlice [qUnqualified qChad, qUnqualified qDee] qChad assertRemoveUpdate remote2GalleyFederatedRequest qconvId qAlice [qUnqualified qEve] qChad diff --git a/services/galley/test/integration/API/MLS.hs b/services/galley/test/integration/API/MLS.hs index 3cc99e10e0..6b290889b8 100644 --- a/services/galley/test/integration/API/MLS.hs +++ b/services/galley/test/integration/API/MLS.hs @@ -22,16 +22,16 @@ module API.MLS (tests) where import API.MLS.Mocks import API.MLS.Util import API.Util -import Bilge hiding (head) +import Bilge hiding (empty, head) import Bilge.Assert import Cassandra +import Control.Applicative import Control.Lens (view) import qualified Control.Monad.State as State import Crypto.Error import qualified Crypto.PubKey.Ed25519 as Ed25519 import qualified Data.Aeson as Aeson import Data.Binary.Put -import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as LBS import Data.Domain import Data.Id @@ -48,7 +48,6 @@ import Data.Time import Federator.MockServer hiding (withTempMockFederator) import Imports import qualified Network.Wai.Utilities.Error as Wai -import Test.QuickCheck (Arbitrary (arbitrary), generate) import Test.Tasty import Test.Tasty.Cannon (TimeoutUnit (Second), (#)) import qualified Test.Tasty.Cannon as WS @@ -60,6 +59,7 @@ import Wire.API.Conversation.Action import Wire.API.Conversation.Protocol import Wire.API.Conversation.Role import Wire.API.Error.Galley +import Wire.API.Federation.API.Common import Wire.API.Federation.API.Galley import Wire.API.MLS.CipherSuite import Wire.API.MLS.Credential @@ -226,6 +226,7 @@ tests s = [ test s "get subconversation of remote conversation - member" (testGetRemoteSubConv True), test s "get subconversation of remote conversation - not member" (testGetRemoteSubConv False), test s "join remote subconversation" testJoinRemoteSubConv, + test s "backends are notified about subconvs when a user joins" testRemoteSubConvNotificationWhenUserJoins, test s "reset a subconversation - member" (testDeleteRemoteSubConv True), test s "reset a subconversation - not member" (testDeleteRemoteSubConv False) ], @@ -393,12 +394,9 @@ testAddUserWithBundle = do "Users added to an MLS group should find it when listing conversations" (qcnv `elem` map cnvQualifiedId convs) - returnedGS <- - fmap responseBody $ - getGroupInfo (qUnqualified alice) (fmap Conv qcnv) - returnedGS + liftIO $ mpPublicGroupState commit @?= Just returnedGS testAddUserWithBundleIncompleteWelcome :: TestM () testAddUserWithBundleIncompleteWelcome = do @@ -423,7 +421,7 @@ testAddUserWithBundleIncompleteWelcome = do bundle <- createBundle commit err <- responseJsonError - =<< postCommitBundle (mpSender commit) bundle + =<< localPostCommitBundle (mpSender commit) bundle >= sendAndConsumeCommitBundle - pgs <- - LBS.toStrict . fromJust . responseBody - <$> getGroupInfo (ciUser alice1) (fmap Conv qcnv) + pgs <- liftTest $ getGroupInfo (cidQualifiedUser alice1) (fmap Conv qcnv) mp <- createExternalCommit bob1 (Just pgs) (fmap Conv qcnv) bundle <- createBundle mp - postCommitBundle (mpSender mp) bundle + localPostCommitBundle (mpSender mp) bundle !!! const 404 === statusCode testExternalCommitSameClient :: TestM () @@ -1226,6 +1220,7 @@ testRemoteToLocal = do MLSMessageSendRequest { mmsrConvOrSubId = Conv (qUnqualified qcnv), mmsrSender = qUnqualified bob, + mmsrSenderClient = ciClient bob1, mmsrRawMessage = Base64ByteString (mpMessage message) } @@ -1269,6 +1264,7 @@ testRemoteToLocalWrongConversation = do MLSMessageSendRequest { mmsrConvOrSubId = Conv randomConfId, mmsrSender = qUnqualified bob, + mmsrSenderClient = ciClient bob1, mmsrRawMessage = Base64ByteString (mpMessage message) } @@ -1302,6 +1298,7 @@ testRemoteNonMemberToLocal = do MLSMessageSendRequest { mmsrConvOrSubId = Conv (qUnqualified qcnv), mmsrSender = qUnqualified bob, + mmsrSenderClient = ciClient bob1, mmsrRawMessage = Base64ByteString (mpMessage message) } @@ -1317,7 +1314,7 @@ propNonExistingConv = do runMLSTest $ do [alice1, bob1] <- traverse createMLSClient [alice, bob] void $ uploadNewKeyPackage bob1 - createGroup alice1 "test_group" + void $ setupFakeMLSGroup alice1 [prop] <- createAddProposals alice1 [bob] postMessage alice1 (mpMessage prop) !!! do @@ -1876,11 +1873,8 @@ testGetGroupInfoOfLocalConv = do -- check the group info matches gs <- assertJust (mpPublicGroupState commit) - returnedGS <- - fmap responseBody $ - getGroupInfo (qUnqualified alice) (fmap Conv qcnv) - returnedGS + returnedGS <- liftTest $ getGroupInfo alice (fmap Conv qcnv) + liftIO $ gs @=? returnedGS testGetGroupInfoOfRemoteConv :: TestM () testGetGroupInfoOfRemoteConv = do @@ -1895,22 +1889,18 @@ testGetGroupInfoOfRemoteConv = do mp <- createAddCommit alice1 [bob] traverse_ consumeWelcome (mpWelcome mp) - receiveNewRemoteConv qcnv groupId + receiveNewRemoteConv (fmap Conv qcnv) groupId receiveOnConvUpdated qcnv alice bob let fakeGroupState = "\xde\xad\xbe\xef" - let mock = queryGroupStateMock fakeGroupState bob + mock = queryGroupStateMock fakeGroupState bob (_, reqs) <- withTempMockFederator' mock $ do - res <- - fmap responseBody $ - getGroupInfo (qUnqualified bob) (fmap Conv qcnv) - >= sendAndConsumeCommit withMLSDisabled $ - getGroupInfo (qUnqualified alice) (fmap Conv qcnv) + localGetGroupInfo (qUnqualified alice) (fmap Conv qcnv) !!! assertMLSNotEnabled deleteSubConversationDisabled :: TestM () @@ -2247,7 +2244,7 @@ testJoinSubConv = do =<< getSubConv (qUnqualified bob) qcnv subId >= postCommitBundle (mpSender commit)) + (createBundle commit >>= localPostCommitBundle (mpSender commit)) !!! do const 400 === statusCode const (Just "Add proposals in subconversations are not supported") @@ -2328,16 +2325,135 @@ testAddClientSubConvFailure = do (Epoch 1) (pscEpoch finalSub) --- FUTUREWORK: implement the following tests +-- FUTUREWORK: implement the following test testRemoveClientSubConv :: TestM () testRemoveClientSubConv = pure () testJoinRemoteSubConv :: TestM () -testJoinRemoteSubConv = pure () +testJoinRemoteSubConv = do + [alice, bob] <- createAndConnectUsers [Just "alice.example.com", Nothing] + + runMLSTest $ do + alice1 <- createFakeMLSClient alice + bob1 <- createMLSClient bob + void $ uploadNewKeyPackage bob1 + + -- setup fake group for the subconversation + let subId = SubConvId "conference" + (subGroupId, qcnv) <- setupFakeMLSGroup alice1 + let qcs = convsub qcnv (Just subId) + initialCommit <- createPendingProposalCommit alice1 + + -- create a fake group ID for the main (we don't need the actual group) + mainGroupId <- fakeGroupId + + -- inform backend about the main conversation + receiveNewRemoteConv (fmap Conv qcnv) mainGroupId + receiveOnConvUpdated qcnv alice bob + + -- inform backend about the subconversation + receiveNewRemoteConv qcs subGroupId + + -- bob joins subconversation + let pgs = mpPublicGroupState initialCommit + let mock = queryGroupStateMock (fold pgs) bob <|> sendMessageMock + (_, reqs) <- withTempMockFederator' mock $ do + commit <- createExternalCommit bob1 Nothing qcs + sendAndConsumeCommitBundle commit + + -- check that commit bundle is sent to remote backend + fr <- assertOne (filter ((== "send-mls-commit-bundle") . frRPC) reqs) + liftIO $ do + mmsr <- assertJust (Aeson.decode (frBody fr)) + mmsrConvOrSubId mmsr @?= qUnqualified qcs + mmsrSender mmsr @?= ciUser bob1 + mmsrSenderClient mmsr @?= ciClient bob1 + +testRemoteSubConvNotificationWhenUserJoins :: TestM () +testRemoteSubConvNotificationWhenUserJoins = do + [alice, bob] <- createAndConnectUsers [Nothing, Just "bob.example.com"] + + runMLSTest $ do + alice1 <- createMLSClient alice + bob1 <- createFakeMLSClient bob + + (_, qcnv) <- setupMLSGroup alice1 + void $ createPendingProposalCommit alice1 >>= sendAndConsumeCommitBundle + let subId = SubConvId "conference" + s <- State.get + void $ createSubConv qcnv alice1 subId + -- revert first commit and subconv + void . replicateM 2 $ rollBackClient alice1 + State.put s + + (_, reqs) <- + withTempMockFederator' (receiveCommitMock [bob1] <|> welcomeMock) $ + createAddCommit alice1 [bob] >>= sendAndConsumeCommitBundle + + do + req <- assertOne $ filter ((== "on-new-remote-conversation") . frRPC) reqs + nrc <- assertOne (toList (Aeson.decode (frBody req))) + liftIO $ nrcConvId nrc @?= qUnqualified qcnv + do + req <- assertOne $ filter ((== "on-new-remote-subconversation") . frRPC) reqs + nrsc <- assertOne (toList (Aeson.decode (frBody req))) + liftIO $ nrscConvId nrsc @?= qUnqualified qcnv + liftIO $ nrscSubConvId nrsc @?= subId testRemoteUserJoinSubConv :: TestM () -testRemoteUserJoinSubConv = pure () +testRemoteUserJoinSubConv = do + [alice, bob] <- createAndConnectUsers [Nothing, Just "bob.example.com"] + + runMLSTest $ do + alice1 <- createMLSClient alice + (_, qcnv) <- setupMLSGroup alice1 + + bob1 <- createFakeMLSClient bob + void $ do + commit <- createAddCommit alice1 [bob] + withTempMockFederator' (receiveCommitMock [bob1] <|> welcomeMock) $ + sendAndConsumeCommit commit + + let mock = + asum + [ "on-new-remote-subconversation" ~> EmptyResponse, + messageSentMock + ] + let subId = SubConvId "conference" + (psc, reqs) <- withTempMockFederator' mock $ createSubConv qcnv alice1 subId + let qcs = convsub qcnv (Just subId) + + -- check that the remote backend is notified when a subconversation is + -- created locally + req <- assertOne $ filter ((== "on-new-remote-subconversation") . frRPC) reqs + nrsc <- assertOne . toList $ Aeson.decode (frBody req) + liftIO $ do + nrscConvId nrsc @?= qUnqualified qcnv + nrscSubConvId nrsc @?= subId + let mls = nrscMlsData nrsc + cnvmlsGroupId mls @?= pscGroupId psc + cnvmlsEpoch mls @?= Epoch 0 + + -- bob joins the subconversation + void $ createExternalCommit bob1 Nothing qcs >>= sendAndConsumeCommitBundle + + -- check that bob is now part of the subconversation + liftTest $ do + psc' <- + responseJsonError + =<< getSubConv (qUnqualified alice) qcnv subId + >= sendAndConsumeCommitBundle + + liftIO $ + assertBool "Unexpected on-new-remote-subconversation" $ + all ((/= "on-new-remote-subconversation") . frRPC) reqs' testSendMessageSubConv :: TestM () testSendMessageSubConv = do @@ -2471,7 +2587,7 @@ testRemoteMemberDeleteSubConv isAMember = do liftTest $ responseJsonError =<< getSubConv (qUnqualified alice) qcnv scnv - resetGroup alice1 (pscGroupId sub) + resetGroup alice1 (fmap (flip SubConv scnv) qcnv) (pscGroupId sub) pure (qUnqualified qcnv, pscGroupId sub, pscEpoch sub) @@ -2485,11 +2601,18 @@ testRemoteMemberDeleteSubConv isAMember = do dscreqEpoch = epoch } - fedGalleyClient <- view tsFedGalleyClient -- Bob is a member of the parent conversation so he's allowed to delete the -- subconversation. - res <- - runFedClient @"delete-sub-conversation" fedGalleyClient bobDomain delReq + (res, reqs) <- + withTempMockFederator' ("on-new-remote-subconversation" ~> EmptyResponse) $ do + fedGalleyClient <- view tsFedGalleyClient + runFedClient @"delete-sub-conversation" fedGalleyClient bobDomain delReq + when isAMember $ do + req <- assertOne (filter ((== "on-new-remote-subconversation") . frRPC) reqs) + nrsc <- assertOne (toList (Aeson.decode (frBody req))) + liftIO $ do + nrscConvId nrsc @?= cnv + nrscSubConvId nrsc @?= scnv if isAMember then expectSuccess res else expectFailure ConvNotFound res where @@ -2553,7 +2676,7 @@ testDeleteSubConvStale = do =<< getSubConv (qUnqualified alice) qcnv sconv >= sendAndConsumeCommitBundle @@ -2594,7 +2717,8 @@ testDeleteRemoteSubConv isAMember = do withTempMockFederator' mock $ deleteSubConv (qUnqualified alice) qconv sconv dsc (), "on-new-remote-conversation" ~> EmptyResponse, + "on-new-remote-subconversation" ~> EmptyResponse, "get-mls-clients" ~> Set.fromList ( map (flip ClientInfo True . ciClient) clients @@ -56,7 +57,11 @@ welcomeMock :: Mock LByteString welcomeMock = "mls-welcome" ~> MLSWelcomeSent sendMessageMock :: Mock LByteString -sendMessageMock = "send-mls-message" ~> MLSMessageResponseUpdates [] +sendMessageMock = + asum + [ "send-mls-message" ~> MLSMessageResponseUpdates [], + "send-mls-commit-bundle" ~> MLSMessageResponseUpdates [] + ] claimKeyPackagesMock :: KeyPackageBundle -> Mock LByteString claimKeyPackagesMock kpb = "claim-key-packages" ~> kpb diff --git a/services/galley/test/integration/API/MLS/Util.hs b/services/galley/test/integration/API/MLS/Util.hs index f1df1f5f32..96166ac18f 100644 --- a/services/galley/test/integration/API/MLS/Util.hs +++ b/services/galley/test/integration/API/MLS/Util.hs @@ -126,7 +126,7 @@ postMessage sender msg = do . bytes msg ) -postCommitBundle :: +localPostCommitBundle :: ( HasCallStack, MonadIO m, MonadCatch m, @@ -137,7 +137,7 @@ postCommitBundle :: ClientIdentity -> ByteString -> m ResponseLBS -postCommitBundle sender bundle = do +localPostCommitBundle sender bundle = do galley <- viewGalley post ( galley @@ -149,6 +149,58 @@ postCommitBundle sender bundle = do . bytes bundle ) +remotePostCommitBundle :: + ( MonadIO m, + MonadReader TestSetup m + ) => + Remote ClientIdentity -> + Qualified ConvOrSubConvId -> + ByteString -> + m [Event] +remotePostCommitBundle rsender qcs bundle = do + client <- view tsFedGalleyClient + let msr = + MLSMessageSendRequest + { mmsrConvOrSubId = qUnqualified qcs, + mmsrSender = ciUser (tUnqualified rsender), + mmsrSenderClient = ciClient (tUnqualified rsender), + mmsrRawMessage = Base64ByteString bundle + } + runFedClient + @"send-mls-commit-bundle" + client + (tDomain rsender) + msr + >>= liftIO . \case + MLSMessageResponseError e -> + assertFailure $ + "error while receiving commit bundle: " <> show e + MLSMessageResponseProtocolError e -> + assertFailure $ + "protocol error while receiving commit bundle: " <> T.unpack e + MLSMessageResponseProposalFailure e -> + assertFailure $ + "proposal failure while receiving commit bundle: " <> displayException e + MLSMessageResponseUpdates _ -> pure [] + +postCommitBundle :: + HasCallStack => + ClientIdentity -> + Qualified ConvOrSubConvId -> + ByteString -> + TestM [Event] +postCommitBundle sender qcs bundle = do + loc <- qualifyLocal () + foldQualified + loc + ( \_ -> + fmap mmssEvents . responseJsonError + =<< localPostCommitBundle sender bundle + remotePostCommitBundle rsender qcs bundle) + (cidQualifiedUser sender $> sender) + postWelcome :: (MonadIO m, MonadHttp m, HasGalley m, HasCallStack) => UserId -> ByteString -> m ResponseLBS postWelcome uid welcome = do galley <- viewGalley @@ -198,6 +250,7 @@ data MLSState = MLSState -- | users expected to receive a welcome message after the next commit mlsNewMembers :: Set ClientIdentity, mlsGroupId :: Maybe GroupId, + mlsConvId :: Maybe (Qualified ConvOrSubConvId), mlsEpoch :: Word64 } @@ -243,6 +296,7 @@ runMLSTest (MLSTest m) = mlsMembers = mempty, mlsNewMembers = mempty, mlsGroupId = Nothing, + mlsConvId = Nothing, mlsEpoch = 0 } @@ -413,8 +467,9 @@ setupMLSGroupWithConv convAction creator = do fromJust (preview (to cnvProtocol . _ProtocolMLS . to cnvmlsGroupId) conv) - createGroup creator groupId - pure (groupId, cnvQualifiedId conv) + let qcnv = cnvQualifiedId conv + createGroup creator (fmap Conv qcnv) groupId + pure (groupId, qcnv) -- | Create conversation and corresponding group. setupMLSGroup :: HasCallStack => ClientIdentity -> MLSTest (GroupId, Qualified ConvId) @@ -439,27 +494,34 @@ setupMLSSelfGroup creator = setupMLSGroupWithConv action creator (getSelfConv (ciUser creator)) GroupId -> MLSTest () -createGroup cid gid = do +createGroup :: ClientIdentity -> Qualified ConvOrSubConvId -> GroupId -> MLSTest () +createGroup cid qcs gid = do State.gets mlsGroupId >>= \case Just _ -> liftIO $ assertFailure "only one group can be created" Nothing -> pure () - resetGroup cid gid + resetGroup cid qcs gid -resetGroup :: ClientIdentity -> GroupId -> MLSTest () -resetGroup cid gid = do +resetGroup :: ClientIdentity -> Qualified ConvOrSubConvId -> GroupId -> MLSTest () +resetGroup cid qcs gid = do groupJSON <- mlscli cid ["group", "create", T.unpack (toBase64Text (unGroupId gid))] Nothing g <- nextGroupFile cid liftIO $ BS.writeFile g groupJSON State.modify $ \s -> s { mlsGroupId = Just gid, + mlsConvId = Just qcs, mlsMembers = Set.singleton cid, mlsEpoch = 0, mlsNewMembers = mempty } +getConvId :: MLSTest (Qualified ConvOrSubConvId) +getConvId = + State.gets mlsConvId + >>= maybe (liftIO (assertFailure "Uninitialised test conversation")) pure + createSubConv :: + HasCallStack => Qualified ConvId -> ClientIdentity -> SubConvId -> @@ -471,21 +533,27 @@ createSubConv qcnv creator subId = do =<< getSubConv (ciUser creator) qcnv subId >= sendAndConsumeCommitBundle getSC -- | Create a local group only without a conversation. This simulates creating -- an MLS conversation on a remote backend. -setupFakeMLSGroup :: ClientIdentity -> MLSTest (GroupId, Qualified ConvId) +setupFakeMLSGroup :: + HasCallStack => + ClientIdentity -> + MLSTest (GroupId, Qualified ConvId) setupFakeMLSGroup creator = do - groupId <- - liftIO $ - fmap (GroupId . BS.pack) (replicateM 32 (generate arbitrary)) - createGroup creator groupId + groupId <- fakeGroupId qcnv <- randomQualifiedId (ciDomain creator) + createGroup creator (fmap Conv qcnv) groupId pure (groupId, qcnv) +fakeGroupId :: MLSTest GroupId +fakeGroupId = + liftIO $ + fmap (GroupId . BS.pack) (replicateM 32 (generate arbitrary)) + keyPackageFile :: HasCallStack => ClientIdentity -> KeyPackageRef -> MLSTest FilePath keyPackageFile qcid ref = State.gets $ \mls -> @@ -561,6 +629,7 @@ bundleKeyPackages bundle = do createAddCommit :: HasCallStack => ClientIdentity -> [Qualified UserId] -> MLSTest MessagePackage createAddCommit cid users = do kps <- concat <$> traverse (bundleKeyPackages <=< claimKeyPackages cid) users + liftIO $ assertBool "no key packages could be claimed" (not (null kps)) createAddCommitWithKeyPackages cid kps createExternalCommit :: @@ -574,11 +643,7 @@ createExternalCommit qcid mpgs qcs = do gNew <- nextGroupFile qcid pgsFile <- liftIO $ emptyTempFile bd "pgs" pgs <- case mpgs of - Nothing -> - LBS.toStrict . fromJust . responseBody - <$> ( getGroupInfo (ciUser qcid) qcs - liftTest $ getGroupInfo (cidQualifiedUser qcid) qcs Just v -> pure v commit <- mlscli @@ -912,12 +977,9 @@ sendAndConsumeCommitBundle :: MessagePackage -> MLSTest [Event] sendAndConsumeCommitBundle mp = do + qcs <- getConvId bundle <- createBundle mp - events <- - fmap mmssEvents - . responseJsonError - =<< postCommitBundle (mpSender mp) bundle - - Qualified ConvId -> + Qualified ConvOrSubConvId -> GroupId -> m () -receiveNewRemoteConv conv gid = do +receiveNewRemoteConv qcs gid = do client <- view tsFedGalleyClient - let nrc = - NewRemoteConversation (qUnqualified conv) $ - ProtocolMLS - ( ConversationMLSData + case qUnqualified qcs of + Conv c -> do + let nrc = + NewRemoteConversation c $ + ProtocolMLS + ( ConversationMLSData + gid + (Epoch 1) + (Just (UTCTime (fromGregorian 2020 8 29) 0)) + MLS_128_DHKEMX25519_AES128GCM_SHA256_Ed25519 + ) + void $ + runFedClient + @"on-new-remote-conversation" + client + (qDomain qcs) + nrc + SubConv c s -> do + let nrc = + NewRemoteSubConversation c s $ + ConversationMLSData gid (Epoch 1) (Just (UTCTime (fromGregorian 2020 8 29) 0)) MLS_128_DHKEMX25519_AES128GCM_SHA256_Ed25519 - ) - void $ - runFedClient - @"on-new-remote-conversation" - client - (qDomain conv) - nrc + void $ + runFedClient + @"on-new-remote-subconversation" + client + (qDomain qcs) + nrc receiveOnConvUpdated :: (MonadReader TestSetup m, MonadIO m) => @@ -1026,7 +1104,22 @@ receiveOnConvUpdated conv origUser joiner = do (qDomain conv) cu -getGroupInfo :: +getGroupInfo :: HasCallStack => Qualified UserId -> Qualified ConvOrSubConvId -> TestM ByteString +getGroupInfo qusr qcs = do + loc <- qualifyLocal () + foldQualified + loc + ( \lusr -> + fmap (LBS.toStrict . fromJust . responseBody) $ + localGetGroupInfo + (tUnqualified lusr) + qcs + remoteGetGroupInfo rusr qcs) + qusr + +localGetGroupInfo :: ( HasCallStack, MonadIO m, MonadCatch m, @@ -1037,7 +1130,7 @@ getGroupInfo :: UserId -> Qualified ConvOrSubConvId -> m ResponseLBS -getGroupInfo sender qcs = do +localGetGroupInfo sender qcs = do galley <- viewGalley case qUnqualified qcs of Conv cnv -> @@ -1067,6 +1160,23 @@ getGroupInfo sender qcs = do . zConn "conn" ) +remoteGetGroupInfo :: + Remote UserId -> + Qualified ConvOrSubConvId -> + TestM ByteString +remoteGetGroupInfo rusr qcs = do + client <- view tsFedGalleyClient + GetGroupInfoResponseState (Base64ByteString pgs) <- + runFedClient + @"query-group-info" + client + (tDomain rusr) + GetGroupInfoRequest + { ggireqConv = qUnqualified qcs, + ggireqSender = tUnqualified rusr + } + pure pgs + getSelfConv :: UserId -> TestM ResponseLBS