From 643aa5235e71a1744f5f8b6c1493285a3fa1512b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marko=20Dimja=C5=A1evi=C4=87?= Date: Tue, 28 Mar 2023 17:10:16 +0200 Subject: [PATCH 01/36] Rename UnrechableUsers to UnreachableUserList --- .../src/Wire/API/Federation/API/Galley.hs | 2 +- .../Federation/Golden/MLSMessageSendingStatus.hs | 14 +++++++------- libs/wire-api/src/Wire/API/MLS/Message.hs | 16 ++++++++-------- services/galley/src/Galley/API/MLS/Message.hs | 12 ++++++------ services/galley/src/Galley/API/MLS/Propagate.hs | 4 ++-- services/galley/test/integration/API/MLS.hs | 6 +++--- .../galley/test/integration/API/MLS/Mocks.hs | 2 +- services/galley/test/integration/API/MLS/Util.hs | 4 ++-- 8 files changed, 30 insertions(+), 30 deletions(-) diff --git a/libs/wire-api-federation/src/Wire/API/Federation/API/Galley.hs b/libs/wire-api-federation/src/Wire/API/Federation/API/Galley.hs index 8a0422c5f2..46f6eb8de1 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 @@ -423,7 +423,7 @@ data MLSMessageResponse = MLSMessageResponseError GalleyError | MLSMessageResponseProtocolError Text | MLSMessageResponseProposalFailure Wai.Error - | MLSMessageResponseUpdates [ConversationUpdate] UnreachableUsers + | MLSMessageResponseUpdates [ConversationUpdate] UnreachableUserList deriving stock (Eq, Show, Generic) deriving (ToJSON, FromJSON) via (CustomEncoded MLSMessageResponse) diff --git a/libs/wire-api-federation/test/Test/Wire/API/Federation/Golden/MLSMessageSendingStatus.hs b/libs/wire-api-federation/test/Test/Wire/API/Federation/Golden/MLSMessageSendingStatus.hs index 0e228bec42..b8a1c63ea5 100644 --- a/libs/wire-api-federation/test/Test/Wire/API/Federation/Golden/MLSMessageSendingStatus.hs +++ b/libs/wire-api-federation/test/Test/Wire/API/Federation/Golden/MLSMessageSendingStatus.hs @@ -30,7 +30,7 @@ testObject_MLSMessageSendingStatus1 = MLSMessageSendingStatus { mmssEvents = [], mmssTime = toUTCTimeMillis (read "1864-04-12 12:22:43.673 UTC"), - mmssUnreachableUsers = UnreachableUsers [] + mmssUnreachableUserList = UnreachableUserList [] } testObject_MLSMessageSendingStatus2 :: MLSMessageSendingStatus @@ -38,7 +38,7 @@ testObject_MLSMessageSendingStatus2 = MLSMessageSendingStatus { mmssEvents = [], mmssTime = toUTCTimeMillis (read "2001-04-12 12:22:43.673 UTC"), - mmssUnreachableUsers = failed1 + mmssUnreachableUserList = failed1 } testObject_MLSMessageSendingStatus3 :: MLSMessageSendingStatus @@ -46,18 +46,18 @@ testObject_MLSMessageSendingStatus3 = MLSMessageSendingStatus { mmssEvents = [], mmssTime = toUTCTimeMillis (read "1999-04-12 12:22:43.673 UTC"), - mmssUnreachableUsers = failed2 + mmssUnreachableUserList = failed2 } -failed1 :: UnreachableUsers +failed1 :: UnreachableUserList failed1 = let domain = Domain "offline.example.com" - in UnreachableUsers [Qualified (Id . fromJust . UUID.fromString $ "00000000-0000-0000-0000-000200000008") domain] + in UnreachableUserList [Qualified (Id . fromJust . UUID.fromString $ "00000000-0000-0000-0000-000200000008") domain] -failed2 :: UnreachableUsers +failed2 :: UnreachableUserList failed2 = let domain = Domain "golden.example.com" - in UnreachableUsers + in UnreachableUserList [ Qualified (Id . fromJust . UUID.fromString $ "00000000-0000-0000-0000-000200000008") domain, Qualified (Id . fromJust . UUID.fromString $ "00000000-0000-0000-0000-000100000007") domain ] diff --git a/libs/wire-api/src/Wire/API/MLS/Message.hs b/libs/wire-api/src/Wire/API/MLS/Message.hs index 1787ceab4b..54d1317fc6 100644 --- a/libs/wire-api/src/Wire/API/MLS/Message.hs +++ b/libs/wire-api/src/Wire/API/MLS/Message.hs @@ -37,7 +37,7 @@ module Wire.API.MLS.Message MLSCipherTextSym0, MLSMessageSendingStatus (..), KnownFormatTag (..), - UnreachableUsers (..), + UnreachableUserList (..), verifyMessageSignature, mkSignedMessage, ) @@ -318,22 +318,22 @@ instance SerialiseMLS (MessagePayload 'MLSPlainText) where -- so the next case is left as a stub serialiseMLS _ = pure () -newtype UnreachableUsers = UnreachableUsers {unreachableUsers :: [Qualified UserId]} +newtype UnreachableUserList = UnreachableUserList {unreachableUsers :: [Qualified UserId]} deriving stock (Eq, Show) - deriving (A.ToJSON, A.FromJSON, S.ToSchema) via Schema UnreachableUsers + deriving (A.ToJSON, A.FromJSON, S.ToSchema) via Schema UnreachableUserList deriving newtype (Semigroup, Monoid) -instance ToSchema UnreachableUsers where +instance ToSchema UnreachableUserList where schema = - named "UnreachableUsers" $ - UnreachableUsers + named "UnreachableUserList" $ + UnreachableUserList <$> unreachableUsers .= array schema data MLSMessageSendingStatus = MLSMessageSendingStatus { mmssEvents :: [Event], mmssTime :: UTCTimeMillis, - mmssUnreachableUsers :: UnreachableUsers + mmssUnreachableUserList :: UnreachableUserList } deriving (Eq, Show) deriving (A.ToJSON, A.FromJSON, S.ToSchema) via Schema MLSMessageSendingStatus @@ -352,7 +352,7 @@ instance ToSchema MLSMessageSendingStatus where "time" (description ?~ "The time of sending the message.") schema - <*> mmssUnreachableUsers + <*> mmssUnreachableUserList .= fieldWithDocModifier "failed_to_send" (description ?~ "List of federated users who could not be reached and did not receive the message") diff --git a/services/galley/src/Galley/API/MLS/Message.hs b/services/galley/src/Galley/API/MLS/Message.hs index 2b92bdb0d2..2f7fd0c929 100644 --- a/services/galley/src/Galley/API/MLS/Message.hs +++ b/services/galley/src/Galley/API/MLS/Message.hs @@ -218,7 +218,7 @@ postMLSCommitBundle :: Qualified ConvId -> Maybe ConnId -> CommitBundle -> - Sem r ([LocalConversationUpdate], UnreachableUsers) + Sem r ([LocalConversationUpdate], UnreachableUserList) postMLSCommitBundle loc qusr mc qcnv conn rawBundle = foldQualified loc @@ -276,7 +276,7 @@ postMLSCommitBundleToLocalConv :: Maybe ConnId -> CommitBundle -> Local ConvId -> - Sem r ([LocalConversationUpdate], UnreachableUsers) + Sem r ([LocalConversationUpdate], UnreachableUserList) postMLSCommitBundleToLocalConv qusr mc conn bundle lcnv = do let msg = rmValue (cbCommitMsg bundle) conv <- getLocalConvForUser qusr lcnv @@ -339,7 +339,7 @@ postMLSCommitBundleToRemoteConv :: Maybe ConnId -> CommitBundle -> Remote ConvId -> - Sem r ([LocalConversationUpdate], UnreachableUsers) + Sem r ([LocalConversationUpdate], UnreachableUserList) postMLSCommitBundleToRemoteConv loc qusr con bundle rcnv = do -- only local users can send messages to remote conversations lusr <- foldQualified loc pure (\_ -> throwS @'ConvAccessDenied) qusr @@ -393,7 +393,7 @@ postMLSMessage :: Qualified ConvId -> Maybe ConnId -> RawMLS SomeMessage -> - Sem r ([LocalConversationUpdate], UnreachableUsers) + Sem r ([LocalConversationUpdate], UnreachableUserList) postMLSMessage loc qusr mc qcnv con smsg = case rmValue smsg of SomeMessage tag msg -> do @@ -471,7 +471,7 @@ postMLSMessageToLocalConv :: Maybe ConnId -> RawMLS SomeMessage -> Local ConvId -> - Sem r ([LocalConversationUpdate], UnreachableUsers) + Sem r ([LocalConversationUpdate], UnreachableUserList) postMLSMessageToLocalConv qusr senderClient con smsg lcnv = case rmValue smsg of SomeMessage tag msg -> do @@ -513,7 +513,7 @@ postMLSMessageToRemoteConv :: Maybe ConnId -> RawMLS SomeMessage -> Remote ConvId -> - Sem r ([LocalConversationUpdate], UnreachableUsers) + Sem r ([LocalConversationUpdate], UnreachableUserList) postMLSMessageToRemoteConv loc qusr _senderClient con smsg rcnv = do -- only local users can send messages to remote conversations lusr <- foldQualified loc pure (\_ -> throwS @'ConvAccessDenied) qusr diff --git a/services/galley/src/Galley/API/MLS/Propagate.hs b/services/galley/src/Galley/API/MLS/Propagate.hs index e3b5918bb4..9e0323361e 100644 --- a/services/galley/src/Galley/API/MLS/Propagate.hs +++ b/services/galley/src/Galley/API/MLS/Propagate.hs @@ -60,7 +60,7 @@ propagateMessage :: ClientMap -> Maybe ConnId -> ByteString -> - Sem r UnreachableUsers + Sem r UnreachableUserList propagateMessage qusr lconv cm con raw = do -- FUTUREWORK: check the epoch let lmems = Data.convLocalMembers . tUnqualified $ lconv @@ -80,7 +80,7 @@ propagateMessage qusr lconv cm con raw = do foldMap (uncurry mkPush) (lmems >>= localMemberMLSClients lcnv) -- send to remotes - UnreachableUsers . concat + UnreachableUserList . concat <$$> traverse handleError <=< runFederatedConcurrentlyEither (map remoteMemberQualify rmems) $ \(tUnqualified -> rs) -> diff --git a/services/galley/test/integration/API/MLS.hs b/services/galley/test/integration/API/MLS.hs index c6c1c2d3db..fcb2a6b8dd 100644 --- a/services/galley/test/integration/API/MLS.hs +++ b/services/galley/test/integration/API/MLS.hs @@ -1138,7 +1138,7 @@ testAppMessageSomeReachable = do (_, us) <- sendAndConsumeMessage message liftIO $ do assertBool "Event should be member join" $ is _EdMembersJoin (evtData event) - us @?= UnreachableUsers [charlie] + us @?= UnreachableUserList [charlie] where mockUnreachableFor :: Set Domain -> Mock LByteString mockUnreachableFor backends = do @@ -1167,7 +1167,7 @@ testAppMessageUnreachable = do (_, us) <- sendAndConsumeMessage message liftIO $ do assertBool "Event should be member join" $ is _EdMembersJoin (evtData event) - us @?= UnreachableUsers [bob] + us @?= UnreachableUserList [bob] testRemoteToRemote :: TestM () testRemoteToRemote = do @@ -2038,7 +2038,7 @@ testAddUserToRemoteConvWithBundle = do commit <- createAddCommit bob1 [charlie] commitBundle <- createBundle commit - let mock = "send-mls-commit-bundle" ~> MLSMessageResponseUpdates [] (UnreachableUsers []) + let mock = "send-mls-commit-bundle" ~> MLSMessageResponseUpdates [] (UnreachableUserList []) (_, reqs) <- withTempMockFederator' mock $ do void $ sendAndConsumeCommitBundle commit diff --git a/services/galley/test/integration/API/MLS/Mocks.hs b/services/galley/test/integration/API/MLS/Mocks.hs index 911b338053..1074ca7273 100644 --- a/services/galley/test/integration/API/MLS/Mocks.hs +++ b/services/galley/test/integration/API/MLS/Mocks.hs @@ -75,7 +75,7 @@ sendMessageMock = "send-mls-message" ~> MLSMessageResponseUpdates [] - (UnreachableUsers []) + (UnreachableUserList []) 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 28f1a47d00..a7472b92de 100644 --- a/services/galley/test/integration/API/MLS/Util.hs +++ b/services/galley/test/integration/API/MLS/Util.hs @@ -839,10 +839,10 @@ consumeMessage1 cid msg = do -- | Send an MLS message and simulate clients receiving it. If the message is a -- commit, the 'sendAndConsumeCommit' function should be used instead. -sendAndConsumeMessage :: HasCallStack => MessagePackage -> MLSTest ([Event], UnreachableUsers) +sendAndConsumeMessage :: HasCallStack => MessagePackage -> MLSTest ([Event], UnreachableUserList) sendAndConsumeMessage mp = do res <- - fmap (mmssEvents Tuple.&&& mmssUnreachableUsers) $ + fmap (mmssEvents Tuple.&&& mmssUnreachableUserList) $ responseJsonError =<< postMessage (mpSender mp) (mpMessage mp) Date: Tue, 28 Mar 2023 17:10:41 +0200 Subject: [PATCH 02/36] Remove duplicated and commented out code --- services/galley/src/Galley/API/MLS/Message.hs | 2 -- 1 file changed, 2 deletions(-) diff --git a/services/galley/src/Galley/API/MLS/Message.hs b/services/galley/src/Galley/API/MLS/Message.hs index 2f7fd0c929..b602c42c45 100644 --- a/services/galley/src/Galley/API/MLS/Message.hs +++ b/services/galley/src/Galley/API/MLS/Message.hs @@ -186,8 +186,6 @@ postMLSMessageFromLocalUser lusr mc conn smsg = do -- FUTUREWORK: Inline the body of 'postMLSMessageFromLocalUserV1' once version -- V1 is dropped assertMLSEnabled - -- (events, unreachables) <- postMLSMessageFromLocalUserV1 lusr mc conn msg - assertMLSEnabled (events, unreachables) <- case rmValue smsg of SomeMessage _ msg -> do qcnv <- getConversationIdByGroupId (msgGroupId msg) >>= noteS @'ConvNotFound From 9bde09bebb3ccbd8360fcc673218b2b82013c139 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marko=20Dimja=C5=A1evi=C4=87?= Date: Mon, 3 Apr 2023 15:19:06 +0200 Subject: [PATCH 03/36] Refactoring of wire-api for UnreachableUserList --- libs/wire-api/src/Wire/API/MLS/Message.hs | 36 +++++++++++++++++++---- 1 file changed, 30 insertions(+), 6 deletions(-) diff --git a/libs/wire-api/src/Wire/API/MLS/Message.hs b/libs/wire-api/src/Wire/API/MLS/Message.hs index 54d1317fc6..090902e0d1 100644 --- a/libs/wire-api/src/Wire/API/MLS/Message.hs +++ b/libs/wire-api/src/Wire/API/MLS/Message.hs @@ -330,10 +330,38 @@ instance ToSchema UnreachableUserList where <$> unreachableUsers .= array schema +-- | Lists of remote users that could not be processed in a federated action, +-- e.g., a message could not be sent to these remote users. +data FailedToProcess = FailedToProcess + { send :: UnreachableUserList + } + deriving (Eq, Show) + +instance Semigroup FailedToProcess where + ftp1 <> ftp2 = + FailedToProcess + { send = send ftp1 <> send ftp2 + } + +instance Monoid FailedToProcess where + mempty = FailedToProcess mempty + +failedToProcessObjectSchema :: ObjectSchema SwaggerDoc FailedToProcess +failedToProcessObjectSchema = + FailedToProcess + <$> send + .= fieldWithDocModifier + "failed_to_send" + (description ?~ "List of federated users who could not be reached and did not receive the message") + (unnamed schema) + +instance ToSchema FailedToProcess where + schema = object "FailedToProcess" failedToProcessObjectSchema + data MLSMessageSendingStatus = MLSMessageSendingStatus { mmssEvents :: [Event], mmssTime :: UTCTimeMillis, - mmssUnreachableUserList :: UnreachableUserList + mmssFailedToProcess :: FailedToProcess } deriving (Eq, Show) deriving (A.ToJSON, A.FromJSON, S.ToSchema) via Schema MLSMessageSendingStatus @@ -352,11 +380,7 @@ instance ToSchema MLSMessageSendingStatus where "time" (description ?~ "The time of sending the message.") schema - <*> mmssUnreachableUserList - .= fieldWithDocModifier - "failed_to_send" - (description ?~ "List of federated users who could not be reached and did not receive the message") - schema + <*> mmssFailedToProcess .= failedToProcessObjectSchema verifyMessageSignature :: CipherSuiteTag -> Message 'MLSPlainText -> ByteString -> Bool verifyMessageSignature cs msg pubkey = From 5fe2710335c5abfeafa561eb02db95aec2dd60cb Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marko=20Dimja=C5=A1evi=C4=87?= Date: Mon, 3 Apr 2023 16:55:22 +0200 Subject: [PATCH 04/36] Refactoring: use FailedToProcess --- .../src/Wire/API/Federation/API/Galley.hs | 2 +- .../Federation/Golden/MLSMessageSendingStatus.hs | 6 +++--- libs/wire-api/src/Wire/API/MLS/Message.hs | 8 ++++++++ services/galley/src/Galley/API/MLS/Message.hs | 14 +++++++------- services/galley/test/integration/API/MLS.hs | 10 +++++----- services/galley/test/integration/API/MLS/Mocks.hs | 3 +-- services/galley/test/integration/API/MLS/Util.hs | 4 ++-- services/galley/test/integration/API/Util.hs | 4 ++-- 8 files changed, 29 insertions(+), 22 deletions(-) diff --git a/libs/wire-api-federation/src/Wire/API/Federation/API/Galley.hs b/libs/wire-api-federation/src/Wire/API/Federation/API/Galley.hs index 46f6eb8de1..eb81209efa 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 @@ -423,7 +423,7 @@ data MLSMessageResponse = MLSMessageResponseError GalleyError | MLSMessageResponseProtocolError Text | MLSMessageResponseProposalFailure Wai.Error - | MLSMessageResponseUpdates [ConversationUpdate] UnreachableUserList + | MLSMessageResponseUpdates [ConversationUpdate] FailedToProcess deriving stock (Eq, Show, Generic) deriving (ToJSON, FromJSON) via (CustomEncoded MLSMessageResponse) diff --git a/libs/wire-api-federation/test/Test/Wire/API/Federation/Golden/MLSMessageSendingStatus.hs b/libs/wire-api-federation/test/Test/Wire/API/Federation/Golden/MLSMessageSendingStatus.hs index b8a1c63ea5..b43d20732c 100644 --- a/libs/wire-api-federation/test/Test/Wire/API/Federation/Golden/MLSMessageSendingStatus.hs +++ b/libs/wire-api-federation/test/Test/Wire/API/Federation/Golden/MLSMessageSendingStatus.hs @@ -30,7 +30,7 @@ testObject_MLSMessageSendingStatus1 = MLSMessageSendingStatus { mmssEvents = [], mmssTime = toUTCTimeMillis (read "1864-04-12 12:22:43.673 UTC"), - mmssUnreachableUserList = UnreachableUserList [] + mmssFailedToProcess = mempty } testObject_MLSMessageSendingStatus2 :: MLSMessageSendingStatus @@ -38,7 +38,7 @@ testObject_MLSMessageSendingStatus2 = MLSMessageSendingStatus { mmssEvents = [], mmssTime = toUTCTimeMillis (read "2001-04-12 12:22:43.673 UTC"), - mmssUnreachableUserList = failed1 + mmssFailedToProcess = failedToSend failed1 } testObject_MLSMessageSendingStatus3 :: MLSMessageSendingStatus @@ -46,7 +46,7 @@ testObject_MLSMessageSendingStatus3 = MLSMessageSendingStatus { mmssEvents = [], mmssTime = toUTCTimeMillis (read "1999-04-12 12:22:43.673 UTC"), - mmssUnreachableUserList = failed2 + mmssFailedToProcess = failedToSend failed2 } failed1 :: UnreachableUserList diff --git a/libs/wire-api/src/Wire/API/MLS/Message.hs b/libs/wire-api/src/Wire/API/MLS/Message.hs index 090902e0d1..b2267725c9 100644 --- a/libs/wire-api/src/Wire/API/MLS/Message.hs +++ b/libs/wire-api/src/Wire/API/MLS/Message.hs @@ -40,6 +40,10 @@ module Wire.API.MLS.Message UnreachableUserList (..), verifyMessageSignature, mkSignedMessage, + + -- * Failed to process + FailedToProcess (..), + failedToSend, ) where @@ -336,6 +340,7 @@ data FailedToProcess = FailedToProcess { send :: UnreachableUserList } deriving (Eq, Show) + deriving (A.ToJSON, A.FromJSON, S.ToSchema) via Schema FailedToProcess instance Semigroup FailedToProcess where ftp1 <> ftp2 = @@ -358,6 +363,9 @@ failedToProcessObjectSchema = instance ToSchema FailedToProcess where schema = object "FailedToProcess" failedToProcessObjectSchema +failedToSend :: UnreachableUserList -> FailedToProcess +failedToSend us = mempty {send = us} + data MLSMessageSendingStatus = MLSMessageSendingStatus { mmssEvents :: [Event], mmssTime :: UTCTimeMillis, diff --git a/services/galley/src/Galley/API/MLS/Message.hs b/services/galley/src/Galley/API/MLS/Message.hs index b602c42c45..e2693144c3 100644 --- a/services/galley/src/Galley/API/MLS/Message.hs +++ b/services/galley/src/Galley/API/MLS/Message.hs @@ -216,7 +216,7 @@ postMLSCommitBundle :: Qualified ConvId -> Maybe ConnId -> CommitBundle -> - Sem r ([LocalConversationUpdate], UnreachableUserList) + Sem r ([LocalConversationUpdate], FailedToProcess) postMLSCommitBundle loc qusr mc qcnv conn rawBundle = foldQualified loc @@ -274,7 +274,7 @@ postMLSCommitBundleToLocalConv :: Maybe ConnId -> CommitBundle -> Local ConvId -> - Sem r ([LocalConversationUpdate], UnreachableUserList) + Sem r ([LocalConversationUpdate], FailedToProcess) postMLSCommitBundleToLocalConv qusr mc conn bundle lcnv = do let msg = rmValue (cbCommitMsg bundle) conv <- getLocalConvForUser qusr lcnv @@ -318,7 +318,7 @@ postMLSCommitBundleToLocalConv qusr mc conn bundle lcnv = do for_ (cbWelcome bundle) $ postMLSWelcome lcnv conn - pure (events, unreachables) + pure (events, failedToSend unreachables) postMLSCommitBundleToRemoteConv :: ( Members MLSBundleStaticErrors r, @@ -337,7 +337,7 @@ postMLSCommitBundleToRemoteConv :: Maybe ConnId -> CommitBundle -> Remote ConvId -> - Sem r ([LocalConversationUpdate], UnreachableUserList) + Sem r ([LocalConversationUpdate], FailedToProcess) postMLSCommitBundleToRemoteConv loc qusr con bundle rcnv = do -- only local users can send messages to remote conversations lusr <- foldQualified loc pure (\_ -> throwS @'ConvAccessDenied) qusr @@ -391,14 +391,14 @@ postMLSMessage :: Qualified ConvId -> Maybe ConnId -> RawMLS SomeMessage -> - Sem r ([LocalConversationUpdate], UnreachableUserList) + Sem r ([LocalConversationUpdate], FailedToProcess) postMLSMessage loc qusr mc qcnv con smsg = case rmValue smsg of SomeMessage tag msg -> do mSender <- fmap ciClient <$> getSenderIdentity qusr mc tag msg foldQualified loc - (postMLSMessageToLocalConv qusr mSender con smsg) + (fmap (second failedToSend) . postMLSMessageToLocalConv qusr mSender con smsg) (postMLSMessageToRemoteConv loc qusr mSender con smsg) qcnv @@ -511,7 +511,7 @@ postMLSMessageToRemoteConv :: Maybe ConnId -> RawMLS SomeMessage -> Remote ConvId -> - Sem r ([LocalConversationUpdate], UnreachableUserList) + Sem r ([LocalConversationUpdate], FailedToProcess) postMLSMessageToRemoteConv loc qusr _senderClient con smsg rcnv = do -- only local users can send messages to remote conversations lusr <- foldQualified loc pure (\_ -> throwS @'ConvAccessDenied) qusr diff --git a/services/galley/test/integration/API/MLS.hs b/services/galley/test/integration/API/MLS.hs index fcb2a6b8dd..e20c9ef793 100644 --- a/services/galley/test/integration/API/MLS.hs +++ b/services/galley/test/integration/API/MLS.hs @@ -1135,10 +1135,10 @@ testAppMessageSomeReachable = do let unreachables = Set.singleton (Domain "charlie.example.com") withTempMockFederator' (mockUnreachableFor unreachables) $ do message <- createApplicationMessage alice1 "hi, bob!" - (_, us) <- sendAndConsumeMessage message + (_, ftp) <- sendAndConsumeMessage message liftIO $ do assertBool "Event should be member join" $ is _EdMembersJoin (evtData event) - us @?= UnreachableUserList [charlie] + ftp @?= failedToSend (UnreachableUserList [charlie]) where mockUnreachableFor :: Set Domain -> Mock LByteString mockUnreachableFor backends = do @@ -1164,10 +1164,10 @@ testAppMessageUnreachable = do sendAndConsumeCommit commit message <- createApplicationMessage alice1 "hi, bob!" - (_, us) <- sendAndConsumeMessage message + (_, ftp) <- sendAndConsumeMessage message liftIO $ do assertBool "Event should be member join" $ is _EdMembersJoin (evtData event) - us @?= UnreachableUserList [bob] + ftp @?= failedToSend (UnreachableUserList [bob]) testRemoteToRemote :: TestM () testRemoteToRemote = do @@ -2038,7 +2038,7 @@ testAddUserToRemoteConvWithBundle = do commit <- createAddCommit bob1 [charlie] commitBundle <- createBundle commit - let mock = "send-mls-commit-bundle" ~> MLSMessageResponseUpdates [] (UnreachableUserList []) + let mock = "send-mls-commit-bundle" ~> MLSMessageResponseUpdates [] mempty (_, reqs) <- withTempMockFederator' mock $ do void $ sendAndConsumeCommitBundle commit diff --git a/services/galley/test/integration/API/MLS/Mocks.hs b/services/galley/test/integration/API/MLS/Mocks.hs index 1074ca7273..06cdef0b7a 100644 --- a/services/galley/test/integration/API/MLS/Mocks.hs +++ b/services/galley/test/integration/API/MLS/Mocks.hs @@ -37,7 +37,6 @@ import Wire.API.Federation.API.Common import Wire.API.Federation.API.Galley import Wire.API.MLS.Credential import Wire.API.MLS.KeyPackage -import Wire.API.MLS.Message import Wire.API.User.Client receiveCommitMock :: [ClientIdentity] -> Mock LByteString @@ -75,7 +74,7 @@ sendMessageMock = "send-mls-message" ~> MLSMessageResponseUpdates [] - (UnreachableUserList []) + mempty 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 a7472b92de..e3f0659315 100644 --- a/services/galley/test/integration/API/MLS/Util.hs +++ b/services/galley/test/integration/API/MLS/Util.hs @@ -839,10 +839,10 @@ consumeMessage1 cid msg = do -- | Send an MLS message and simulate clients receiving it. If the message is a -- commit, the 'sendAndConsumeCommit' function should be used instead. -sendAndConsumeMessage :: HasCallStack => MessagePackage -> MLSTest ([Event], UnreachableUserList) +sendAndConsumeMessage :: HasCallStack => MessagePackage -> MLSTest ([Event], FailedToProcess) sendAndConsumeMessage mp = do res <- - fmap (mmssEvents Tuple.&&& mmssUnreachableUserList) $ + fmap (mmssEvents Tuple.&&& mmssFailedToProcess) $ responseJsonError =<< postMessage (mpSender mp) (mpMessage mp) Client.QualifiedUserClients -> Assertions () -assertMismatchQualified failedToSend missing redundant deleted = do - assertExpected "failed to send" failedToSend (fmap mssFailedToSend . responseJsonMaybe) +assertMismatchQualified failureToSend missing redundant deleted = do + assertExpected "failed to send" failureToSend (fmap mssFailedToSend . responseJsonMaybe) assertExpected "missing" missing (fmap mssMissingClients . responseJsonMaybe) assertExpected "redundant" redundant (fmap mssRedundantClients . responseJsonMaybe) assertExpected "deleted" deleted (fmap mssDeletedClients . responseJsonMaybe) From 7763bfced4972ce728eec2a16f18a854232f666e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marko=20Dimja=C5=A1evi=C4=87?= Date: Tue, 4 Apr 2023 12:56:32 +0200 Subject: [PATCH 05/36] Refactoring: make UnreachableUserList a NonEmpty As agreed with client devs on Apr 4, 2023 in the Squad - Federation chat, the absence of the `failed_to_send` field in response to an MLS message send request has the same meaning as an empty list provided in the same field. --- .../Golden/MLSMessageSendingStatus.hs | 14 +++--- .../testObject_MLSMessageSendingStatus1.json | 7 ++- libs/wire-api/src/Wire/API/MLS/Message.hs | 43 +++++++++++++------ services/galley/src/Galley/API/MLS/Message.hs | 6 +-- .../galley/src/Galley/API/MLS/Propagate.hs | 4 +- services/galley/test/integration/API/MLS.hs | 4 +- 6 files changed, 48 insertions(+), 30 deletions(-) diff --git a/libs/wire-api-federation/test/Test/Wire/API/Federation/Golden/MLSMessageSendingStatus.hs b/libs/wire-api-federation/test/Test/Wire/API/Federation/Golden/MLSMessageSendingStatus.hs index b43d20732c..ee1cf1a2c6 100644 --- a/libs/wire-api-federation/test/Test/Wire/API/Federation/Golden/MLSMessageSendingStatus.hs +++ b/libs/wire-api-federation/test/Test/Wire/API/Federation/Golden/MLSMessageSendingStatus.hs @@ -49,15 +49,15 @@ testObject_MLSMessageSendingStatus3 = mmssFailedToProcess = failedToSend failed2 } -failed1 :: UnreachableUserList +failed1 :: [Qualified UserId] failed1 = let domain = Domain "offline.example.com" - in UnreachableUserList [Qualified (Id . fromJust . UUID.fromString $ "00000000-0000-0000-0000-000200000008") domain] + in [Qualified (Id . fromJust . UUID.fromString $ "00000000-0000-0000-0000-000200000008") domain] -failed2 :: UnreachableUserList +failed2 :: [Qualified UserId] failed2 = let domain = Domain "golden.example.com" - in UnreachableUserList - [ Qualified (Id . fromJust . UUID.fromString $ "00000000-0000-0000-0000-000200000008") domain, - Qualified (Id . fromJust . UUID.fromString $ "00000000-0000-0000-0000-000100000007") domain - ] + in flip Qualified domain . Id . fromJust . UUID.fromString + <$> [ "00000000-0000-0000-0000-000200000008", + "00000000-0000-0000-0000-000100000007" + ] diff --git a/libs/wire-api-federation/test/golden/testObject_MLSMessageSendingStatus1.json b/libs/wire-api-federation/test/golden/testObject_MLSMessageSendingStatus1.json index 9323f7742e..dcd87fe946 100644 --- a/libs/wire-api-federation/test/golden/testObject_MLSMessageSendingStatus1.json +++ b/libs/wire-api-federation/test/golden/testObject_MLSMessageSendingStatus1.json @@ -1,5 +1,4 @@ { - "events": [], - "time": "1864-04-12T12:22:43.673Z", - "failed_to_send": [] -} + "events": [], + "time": "1864-04-12T12:22:43.673Z" +} \ No newline at end of file diff --git a/libs/wire-api/src/Wire/API/MLS/Message.hs b/libs/wire-api/src/Wire/API/MLS/Message.hs index b2267725c9..f0539c3eff 100644 --- a/libs/wire-api/src/Wire/API/MLS/Message.hs +++ b/libs/wire-api/src/Wire/API/MLS/Message.hs @@ -37,13 +37,15 @@ module Wire.API.MLS.Message MLSCipherTextSym0, MLSMessageSendingStatus (..), KnownFormatTag (..), - UnreachableUserList (..), verifyMessageSignature, mkSignedMessage, -- * Failed to process + UnreachableUserList (..), + unreachableFromList, FailedToProcess (..), failedToSend, + failedToSendMaybe, ) where @@ -57,6 +59,7 @@ import qualified Data.ByteArray as BA import Data.Id import Data.Json.Util import Data.Kind +import Data.List.NonEmpty import Data.Qualified import Data.Schema import Data.Singletons.TH @@ -322,22 +325,33 @@ instance SerialiseMLS (MessagePayload 'MLSPlainText) where -- so the next case is left as a stub serialiseMLS _ = pure () -newtype UnreachableUserList = UnreachableUserList {unreachableUsers :: [Qualified UserId]} +newtype UnreachableUserList = UnreachableUserList {unreachableUsers :: NonEmpty (Qualified UserId)} deriving stock (Eq, Show) deriving (A.ToJSON, A.FromJSON, S.ToSchema) via Schema UnreachableUserList - deriving newtype (Semigroup, Monoid) + deriving newtype (Semigroup) instance ToSchema UnreachableUserList where schema = named "UnreachableUserList" $ UnreachableUserList <$> unreachableUsers - .= array schema + .= nonEmptyArray schema + +unreachableFromList :: [Qualified UserId] -> Maybe UnreachableUserList +unreachableFromList = fmap UnreachableUserList . nonEmpty + +-- | A 'mappend'-like operation on two optional values of a type with a +-- Semigroup instance. +(<\>) :: Semigroup a => Maybe a -> Maybe a -> Maybe a +Nothing <\> Nothing = Nothing +Nothing <\> v = v +v <\> Nothing = v +(Just a) <\> (Just b) = Just (a <> b) -- | Lists of remote users that could not be processed in a federated action, -- e.g., a message could not be sent to these remote users. data FailedToProcess = FailedToProcess - { send :: UnreachableUserList + { send :: Maybe UnreachableUserList } deriving (Eq, Show) deriving (A.ToJSON, A.FromJSON, S.ToSchema) via Schema FailedToProcess @@ -345,7 +359,7 @@ data FailedToProcess = FailedToProcess instance Semigroup FailedToProcess where ftp1 <> ftp2 = FailedToProcess - { send = send ftp1 <> send ftp2 + { send = send ftp1 <\> send ftp2 } instance Monoid FailedToProcess where @@ -355,16 +369,21 @@ failedToProcessObjectSchema :: ObjectSchema SwaggerDoc FailedToProcess failedToProcessObjectSchema = FailedToProcess <$> send - .= fieldWithDocModifier - "failed_to_send" - (description ?~ "List of federated users who could not be reached and did not receive the message") - (unnamed schema) + .= maybe_ + ( optFieldWithDocModifier + "failed_to_send" + (description ?~ "List of federated users who could not be reached and did not receive the message") + (unnamed schema) + ) instance ToSchema FailedToProcess where schema = object "FailedToProcess" failedToProcessObjectSchema -failedToSend :: UnreachableUserList -> FailedToProcess -failedToSend us = mempty {send = us} +failedToSend :: [Qualified UserId] -> FailedToProcess +failedToSend = failedToSendMaybe . unreachableFromList + +failedToSendMaybe :: Maybe UnreachableUserList -> FailedToProcess +failedToSendMaybe us = mempty {send = us} data MLSMessageSendingStatus = MLSMessageSendingStatus { mmssEvents :: [Event], diff --git a/services/galley/src/Galley/API/MLS/Message.hs b/services/galley/src/Galley/API/MLS/Message.hs index e2693144c3..7820c9f9ca 100644 --- a/services/galley/src/Galley/API/MLS/Message.hs +++ b/services/galley/src/Galley/API/MLS/Message.hs @@ -318,7 +318,7 @@ postMLSCommitBundleToLocalConv qusr mc conn bundle lcnv = do for_ (cbWelcome bundle) $ postMLSWelcome lcnv conn - pure (events, failedToSend unreachables) + pure (events, failedToSendMaybe unreachables) postMLSCommitBundleToRemoteConv :: ( Members MLSBundleStaticErrors r, @@ -398,7 +398,7 @@ postMLSMessage loc qusr mc qcnv con smsg = mSender <- fmap ciClient <$> getSenderIdentity qusr mc tag msg foldQualified loc - (fmap (second failedToSend) . postMLSMessageToLocalConv qusr mSender con smsg) + (fmap (second failedToSendMaybe) . postMLSMessageToLocalConv qusr mSender con smsg) (postMLSMessageToRemoteConv loc qusr mSender con smsg) qcnv @@ -469,7 +469,7 @@ postMLSMessageToLocalConv :: Maybe ConnId -> RawMLS SomeMessage -> Local ConvId -> - Sem r ([LocalConversationUpdate], UnreachableUserList) + Sem r ([LocalConversationUpdate], Maybe UnreachableUserList) postMLSMessageToLocalConv qusr senderClient con smsg lcnv = case rmValue smsg of SomeMessage tag msg -> do diff --git a/services/galley/src/Galley/API/MLS/Propagate.hs b/services/galley/src/Galley/API/MLS/Propagate.hs index 9e0323361e..83397803d0 100644 --- a/services/galley/src/Galley/API/MLS/Propagate.hs +++ b/services/galley/src/Galley/API/MLS/Propagate.hs @@ -60,7 +60,7 @@ propagateMessage :: ClientMap -> Maybe ConnId -> ByteString -> - Sem r UnreachableUserList + Sem r (Maybe UnreachableUserList) propagateMessage qusr lconv cm con raw = do -- FUTUREWORK: check the epoch let lmems = Data.convLocalMembers . tUnqualified $ lconv @@ -80,7 +80,7 @@ propagateMessage qusr lconv cm con raw = do foldMap (uncurry mkPush) (lmems >>= localMemberMLSClients lcnv) -- send to remotes - UnreachableUserList . concat + unreachableFromList . concat <$$> traverse handleError <=< runFederatedConcurrentlyEither (map remoteMemberQualify rmems) $ \(tUnqualified -> rs) -> diff --git a/services/galley/test/integration/API/MLS.hs b/services/galley/test/integration/API/MLS.hs index e20c9ef793..c91f2e2225 100644 --- a/services/galley/test/integration/API/MLS.hs +++ b/services/galley/test/integration/API/MLS.hs @@ -1138,7 +1138,7 @@ testAppMessageSomeReachable = do (_, ftp) <- sendAndConsumeMessage message liftIO $ do assertBool "Event should be member join" $ is _EdMembersJoin (evtData event) - ftp @?= failedToSend (UnreachableUserList [charlie]) + ftp @?= failedToSend [charlie] where mockUnreachableFor :: Set Domain -> Mock LByteString mockUnreachableFor backends = do @@ -1167,7 +1167,7 @@ testAppMessageUnreachable = do (_, ftp) <- sendAndConsumeMessage message liftIO $ do assertBool "Event should be member join" $ is _EdMembersJoin (evtData event) - ftp @?= failedToSend (UnreachableUserList [bob]) + ftp @?= failedToSend [bob] testRemoteToRemote :: TestM () testRemoteToRemote = do From 607f2772ac079cbc1ca02922ffce0f87a24173f4 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marko=20Dimja=C5=A1evi=C4=87?= Date: Tue, 4 Apr 2023 16:48:02 +0200 Subject: [PATCH 06/36] executeProposalAction: return failed-to-add users --- libs/wire-api/src/Wire/API/MLS/Message.hs | 23 +++++++-- services/galley/src/Galley/API/MLS/Message.hs | 48 ++++++++++++------- 2 files changed, 52 insertions(+), 19 deletions(-) diff --git a/libs/wire-api/src/Wire/API/MLS/Message.hs b/libs/wire-api/src/Wire/API/MLS/Message.hs index f0539c3eff..420a54ee93 100644 --- a/libs/wire-api/src/Wire/API/MLS/Message.hs +++ b/libs/wire-api/src/Wire/API/MLS/Message.hs @@ -46,6 +46,8 @@ module Wire.API.MLS.Message FailedToProcess (..), failedToSend, failedToSendMaybe, + failedToAdd, + failedToAddMaybe, ) where @@ -351,7 +353,8 @@ v <\> Nothing = v -- | Lists of remote users that could not be processed in a federated action, -- e.g., a message could not be sent to these remote users. data FailedToProcess = FailedToProcess - { send :: Maybe UnreachableUserList + { send :: Maybe UnreachableUserList, + add :: Maybe UnreachableUserList } deriving (Eq, Show) deriving (A.ToJSON, A.FromJSON, S.ToSchema) via Schema FailedToProcess @@ -359,11 +362,12 @@ data FailedToProcess = FailedToProcess instance Semigroup FailedToProcess where ftp1 <> ftp2 = FailedToProcess - { send = send ftp1 <\> send ftp2 + { send = send ftp1 <\> send ftp2, + add = add ftp1 <\> add ftp2 } instance Monoid FailedToProcess where - mempty = FailedToProcess mempty + mempty = FailedToProcess mempty mempty failedToProcessObjectSchema :: ObjectSchema SwaggerDoc FailedToProcess failedToProcessObjectSchema = @@ -375,6 +379,13 @@ failedToProcessObjectSchema = (description ?~ "List of federated users who could not be reached and did not receive the message") (unnamed schema) ) + <*> add + .= maybe_ + ( optFieldWithDocModifier + "failed_to_add" + (description ?~ "List of federated users who could not be reached and be added to a conversation") + (unnamed schema) + ) instance ToSchema FailedToProcess where schema = object "FailedToProcess" failedToProcessObjectSchema @@ -385,6 +396,12 @@ failedToSend = failedToSendMaybe . unreachableFromList failedToSendMaybe :: Maybe UnreachableUserList -> FailedToProcess failedToSendMaybe us = mempty {send = us} +failedToAdd :: [Qualified UserId] -> FailedToProcess +failedToAdd = failedToAddMaybe . unreachableFromList + +failedToAddMaybe :: Maybe UnreachableUserList -> FailedToProcess +failedToAddMaybe us = mempty {add = us} + data MLSMessageSendingStatus = MLSMessageSendingStatus { mmssEvents :: [Event], mmssTime :: UTCTimeMillis, diff --git a/services/galley/src/Galley/API/MLS/Message.hs b/services/galley/src/Galley/API/MLS/Message.hs index 7820c9f9ca..a5ce6a2e27 100644 --- a/services/galley/src/Galley/API/MLS/Message.hs +++ b/services/galley/src/Galley/API/MLS/Message.hs @@ -60,6 +60,7 @@ import Galley.Effects.ProposalStore import Galley.Env import Galley.Options import Galley.Types.Conversations.Members +import Galley.Types.UserList import Imports import Polysemy import Polysemy.Error @@ -285,7 +286,7 @@ postMLSCommitBundleToLocalConv qusr mc conn bundle lcnv = do senderClient <- fmap ciClient <$> getSenderIdentity qusr mc SMLSPlainText msg - events <- case msgPayload msg of + (events, failedToProcess) <- case msgPayload msg of CommitMessage commit -> do action <- getCommitData lconv mlsMeta (msgEpoch msg) commit @@ -296,7 +297,7 @@ postMLSCommitBundleToLocalConv qusr mc conn bundle lcnv = do /= Set.fromList (map (snd . snd) (cmAssocs (paAdd action))) ) $ throwS @'MLSWelcomeMismatch - updates <- + (updates, failedToProcess) <- processCommitWithAction qusr senderClient @@ -309,7 +310,7 @@ postMLSCommitBundleToLocalConv qusr mc conn bundle lcnv = do (msgSender msg) commit storeGroupInfoBundle lconv (cbGroupInfoBundle bundle) - pure updates + pure (updates, failedToProcess) ApplicationMessage _ -> throwS @'MLSUnsupportedMessage ProposalMessage _ -> throwS @'MLSUnsupportedMessage @@ -318,7 +319,7 @@ postMLSCommitBundleToLocalConv qusr mc conn bundle lcnv = do for_ (cbWelcome bundle) $ postMLSWelcome lcnv conn - pure (events, failedToSendMaybe unreachables) + pure (events, failedToProcess <> failedToSendMaybe unreachables) postMLSCommitBundleToRemoteConv :: ( Members MLSBundleStaticErrors r, @@ -398,7 +399,7 @@ postMLSMessage loc qusr mc qcnv con smsg = mSender <- fmap ciClient <$> getSenderIdentity qusr mc tag msg foldQualified loc - (fmap (second failedToSendMaybe) . postMLSMessageToLocalConv qusr mSender con smsg) + (postMLSMessageToLocalConv qusr mSender con smsg) (postMLSMessageToRemoteConv loc qusr mSender con smsg) qcnv @@ -469,7 +470,7 @@ postMLSMessageToLocalConv :: Maybe ConnId -> RawMLS SomeMessage -> Local ConvId -> - Sem r ([LocalConversationUpdate], Maybe UnreachableUserList) + Sem r ([LocalConversationUpdate], FailedToProcess) postMLSMessageToLocalConv qusr senderClient con smsg lcnv = case rmValue smsg of SomeMessage tag msg -> do @@ -481,13 +482,13 @@ postMLSMessageToLocalConv qusr senderClient con smsg lcnv = let lconv = qualifyAs lcnv conv -- validate message - events <- case tag of + (events, failedToProcess) <- case tag of SMLSPlainText -> case msgPayload msg of CommitMessage c -> processCommit qusr senderClient con lconv mlsMeta cm (msgEpoch msg) (msgSender msg) c ApplicationMessage _ -> throwS @'MLSUnsupportedMessage ProposalMessage prop -> - processProposal qusr conv mlsMeta msg prop $> mempty + processProposal qusr conv mlsMeta msg prop $> (mempty, mempty) SMLSCipherText -> case toMLSEnum' (msgContentType (msgPayload msg)) of Right CommitMessageTag -> throwS @'MLSUnsupportedMessage Right ProposalMessageTag -> throwS @'MLSUnsupportedMessage @@ -496,7 +497,7 @@ postMLSMessageToLocalConv qusr senderClient con smsg lcnv = -- forward message unreachables <- propagateMessage qusr lconv cm con (rmRaw smsg) - pure (events, unreachables) + pure (events, failedToProcess <> failedToSendMaybe unreachables) postMLSMessageToRemoteConv :: ( Members MLSMessageStaticErrors r, @@ -630,7 +631,7 @@ processCommit :: Epoch -> Sender 'MLSPlainText -> Commit -> - Sem r [LocalConversationUpdate] + Sem r ([LocalConversationUpdate], FailedToProcess) processCommit qusr senderClient con lconv mlsMeta cm epoch sender commit = do action <- getCommitData lconv mlsMeta epoch commit processCommitWithAction qusr senderClient con lconv mlsMeta cm epoch action sender commit @@ -765,11 +766,13 @@ processCommitWithAction :: ProposalAction -> Sender 'MLSPlainText -> Commit -> - Sem r [LocalConversationUpdate] + Sem r ([LocalConversationUpdate], FailedToProcess) processCommitWithAction qusr senderClient con lconv mlsMeta cm epoch action sender commit = case sender of MemberSender ref -> processInternalCommit qusr senderClient con lconv mlsMeta cm epoch action ref commit - NewMemberSender -> processExternalCommit qusr senderClient lconv mlsMeta cm epoch action (cPath commit) $> [] + NewMemberSender -> + processExternalCommit qusr senderClient lconv mlsMeta cm epoch action (cPath commit) + $> (mempty, mempty) _ -> throw (mlsProtocolError "Unexpected sender") processInternalCommit :: @@ -793,7 +796,7 @@ processInternalCommit :: ProposalAction -> KeyPackageRef -> Commit -> - Sem r [LocalConversationUpdate] + Sem r ([LocalConversationUpdate], FailedToProcess) processInternalCommit qusr senderClient con lconv mlsMeta cm epoch action senderRef commit = do self <- noteS @'ConvNotFound $ getConvMember lconv (tUnqualified lconv) qusr @@ -1107,7 +1110,7 @@ executeProposalAction :: ConversationMLSData -> ClientMap -> ProposalAction -> - Sem r [LocalConversationUpdate] + Sem r ([LocalConversationUpdate], FailedToProcess) executeProposalAction qusr con lconv mlsMeta cm action = do let ss = csSignatureScheme (cnvmlsCipherSuite mlsMeta) newUserClients = Map.assocs (paAdd action) @@ -1160,7 +1163,6 @@ executeProposalAction qusr con lconv mlsMeta cm action = do && Set.isSubsetOf clients allClients ) $ do - -- unless (Set.isSubsetOf allClients clients) $ do -- FUTUREWORK: turn this error into a proper response throwS @'MLSClientMismatch @@ -1168,6 +1170,16 @@ executeProposalAction qusr con lconv mlsMeta cm action = do -- add users to the conversation and send events addEvents <- foldMap addMembers . nonEmpty . map fst $ newUserClients + let failedAdding = + Set.toList $ + Set.fromList (fst <$> newUserClients) + `Set.difference` Set.fromList + ( ulAll lconv + . ulNewMembers lconv (tUnqualified lconv) + . toUserList lconv + . foldMap (onlyJoining . lcuEvent) + $ addEvents + ) -- add clients in the conversation state for_ newUserClients $ \(qtarget, newClients) -> do @@ -1181,8 +1193,12 @@ executeProposalAction qusr con lconv mlsMeta cm action = do for_ (Map.assocs (paRemove action)) $ \(qtarget, clients) -> do removeMLSClients (cnvmlsGroupId mlsMeta) qtarget (Set.map fst clients) - pure (addEvents <> removeEvents) + pure (addEvents <> removeEvents, failedToAdd failedAdding) where + onlyJoining :: Event -> [Qualified UserId] + onlyJoining (evtData -> EdMembersJoin ms) = smQualifiedId <$> mMembers ms + onlyJoining _ = [] + checkRemoval :: Qualified UserId -> Set ClientId -> From 6b93a82bf5a8376b842f32978a9ffad9ff64e696 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marko=20Dimja=C5=A1evi=C4=87?= Date: Fri, 7 Apr 2023 11:47:49 +0200 Subject: [PATCH 07/36] Rename back to UnreachableUsers --- libs/wire-api/src/Wire/API/MLS/Message.hs | 24 +++++++++---------- .../galley/src/Galley/API/MLS/Propagate.hs | 2 +- 2 files changed, 13 insertions(+), 13 deletions(-) diff --git a/libs/wire-api/src/Wire/API/MLS/Message.hs b/libs/wire-api/src/Wire/API/MLS/Message.hs index 420a54ee93..b91ba93917 100644 --- a/libs/wire-api/src/Wire/API/MLS/Message.hs +++ b/libs/wire-api/src/Wire/API/MLS/Message.hs @@ -41,7 +41,7 @@ module Wire.API.MLS.Message mkSignedMessage, -- * Failed to process - UnreachableUserList (..), + UnreachableUsers (..), unreachableFromList, FailedToProcess (..), failedToSend, @@ -327,20 +327,20 @@ instance SerialiseMLS (MessagePayload 'MLSPlainText) where -- so the next case is left as a stub serialiseMLS _ = pure () -newtype UnreachableUserList = UnreachableUserList {unreachableUsers :: NonEmpty (Qualified UserId)} +newtype UnreachableUsers = UnreachableUsers {unreachableUsers :: NonEmpty (Qualified UserId)} deriving stock (Eq, Show) - deriving (A.ToJSON, A.FromJSON, S.ToSchema) via Schema UnreachableUserList + deriving (A.ToJSON, A.FromJSON, S.ToSchema) via Schema UnreachableUsers deriving newtype (Semigroup) -instance ToSchema UnreachableUserList where +instance ToSchema UnreachableUsers where schema = - named "UnreachableUserList" $ - UnreachableUserList + named "UnreachableUsers" $ + UnreachableUsers <$> unreachableUsers .= nonEmptyArray schema -unreachableFromList :: [Qualified UserId] -> Maybe UnreachableUserList -unreachableFromList = fmap UnreachableUserList . nonEmpty +unreachableFromList :: [Qualified UserId] -> Maybe UnreachableUsers +unreachableFromList = fmap UnreachableUsers . nonEmpty -- | A 'mappend'-like operation on two optional values of a type with a -- Semigroup instance. @@ -353,8 +353,8 @@ v <\> Nothing = v -- | Lists of remote users that could not be processed in a federated action, -- e.g., a message could not be sent to these remote users. data FailedToProcess = FailedToProcess - { send :: Maybe UnreachableUserList, - add :: Maybe UnreachableUserList + { send :: Maybe UnreachableUsers, + add :: Maybe UnreachableUsers } deriving (Eq, Show) deriving (A.ToJSON, A.FromJSON, S.ToSchema) via Schema FailedToProcess @@ -393,13 +393,13 @@ instance ToSchema FailedToProcess where failedToSend :: [Qualified UserId] -> FailedToProcess failedToSend = failedToSendMaybe . unreachableFromList -failedToSendMaybe :: Maybe UnreachableUserList -> FailedToProcess +failedToSendMaybe :: Maybe UnreachableUsers -> FailedToProcess failedToSendMaybe us = mempty {send = us} failedToAdd :: [Qualified UserId] -> FailedToProcess failedToAdd = failedToAddMaybe . unreachableFromList -failedToAddMaybe :: Maybe UnreachableUserList -> FailedToProcess +failedToAddMaybe :: Maybe UnreachableUsers -> FailedToProcess failedToAddMaybe us = mempty {add = us} data MLSMessageSendingStatus = MLSMessageSendingStatus diff --git a/services/galley/src/Galley/API/MLS/Propagate.hs b/services/galley/src/Galley/API/MLS/Propagate.hs index 83397803d0..99e70ce31e 100644 --- a/services/galley/src/Galley/API/MLS/Propagate.hs +++ b/services/galley/src/Galley/API/MLS/Propagate.hs @@ -60,7 +60,7 @@ propagateMessage :: ClientMap -> Maybe ConnId -> ByteString -> - Sem r (Maybe UnreachableUserList) + Sem r (Maybe UnreachableUsers) propagateMessage qusr lconv cm con raw = do -- FUTUREWORK: check the epoch let lmems = Data.convLocalMembers . tUnqualified $ lconv From 4caf6990ba233f1fe042a0934c3974315fa96878 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marko=20Dimja=C5=A1evi=C4=87?= Date: Fri, 7 Apr 2023 11:50:58 +0200 Subject: [PATCH 08/36] Do not expose the getter for UnreachableUsers --- libs/wire-api/src/Wire/API/MLS/Message.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/libs/wire-api/src/Wire/API/MLS/Message.hs b/libs/wire-api/src/Wire/API/MLS/Message.hs index b91ba93917..95eca7d0ca 100644 --- a/libs/wire-api/src/Wire/API/MLS/Message.hs +++ b/libs/wire-api/src/Wire/API/MLS/Message.hs @@ -41,7 +41,7 @@ module Wire.API.MLS.Message mkSignedMessage, -- * Failed to process - UnreachableUsers (..), + UnreachableUsers (UnreachableUsers), unreachableFromList, FailedToProcess (..), failedToSend, From 1855e44088121373ec82fb2d80b6114ee5d28ebd Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marko=20Dimja=C5=A1evi=C4=87?= Date: Fri, 7 Apr 2023 13:17:04 +0200 Subject: [PATCH 09/36] MLS test utility: reuse code among utilities --- services/galley/test/integration/API/MLS/Mocks.hs | 9 +-------- 1 file changed, 1 insertion(+), 8 deletions(-) diff --git a/services/galley/test/integration/API/MLS/Mocks.hs b/services/galley/test/integration/API/MLS/Mocks.hs index 06cdef0b7a..d4c4aa0c64 100644 --- a/services/galley/test/integration/API/MLS/Mocks.hs +++ b/services/galley/test/integration/API/MLS/Mocks.hs @@ -54,14 +54,7 @@ receiveCommitMockByDomain :: [ClientIdentity] -> Mock LByteString receiveCommitMockByDomain clients = do r <- getRequest let fClients = filter (\c -> frTargetDomain r == ciDomain c) clients - asum - [ "on-conversation-updated" ~> (), - "on-new-remote-conversation" ~> EmptyResponse, - "get-mls-clients" ~> - Set.fromList - ( map (flip ClientInfo True . ciClient) fClients - ) - ] + receiveCommitMock fClients messageSentMock :: Mock LByteString messageSentMock = "on-mls-message-sent" ~> RemoteMLSMessageOk From d098b94a48b3dcc2b5457d71912dc25cca29683c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marko=20Dimja=C5=A1evi=C4=87?= Date: Fri, 7 Apr 2023 14:20:53 +0200 Subject: [PATCH 10/36] Move and generalise mockUnreachableFor --- services/federator/src/Federator/MockServer.hs | 11 +++++++++++ services/galley/test/integration/API/MLS.hs | 11 +---------- services/galley/test/integration/API/MLS/Mocks.hs | 5 +++++ 3 files changed, 17 insertions(+), 10 deletions(-) diff --git a/services/federator/src/Federator/MockServer.hs b/services/federator/src/Federator/MockServer.hs index f8f88e5310..3d1e08de1c 100644 --- a/services/federator/src/Federator/MockServer.hs +++ b/services/federator/src/Federator/MockServer.hs @@ -28,6 +28,7 @@ module Federator.MockServer Mock, runMock, mockReply, + mockUnreachableFor, mockFail, guardRPC, guardComponent, @@ -45,6 +46,7 @@ import Control.Monad.Trans.Except import Control.Monad.Trans.Maybe import qualified Data.Aeson as Aeson import Data.Domain (Domain) +import qualified Data.Set as Set import qualified Data.Text as Text import qualified Data.Text.Lazy as LText import Federator.Error @@ -203,6 +205,15 @@ guardComponent c = do mockReply :: Aeson.ToJSON a => a -> Mock LByteString mockReply = pure . Aeson.encode +-- | Provide a mock reply simulating unreachable backends given by their +-- domains. +mockUnreachableFor :: String -> Set Domain -> Mock LByteString +mockUnreachableFor msg backends = do + r <- getRequest + if Set.member (frTargetDomain r) backends + then throw (MockErrorResponse HTTP.status503 "Down for maintenance.") + else mockReply msg + -- | Abort the mock with an error. mockFail :: Text -> Mock a mockFail = Mock . lift . lift . throwE diff --git a/services/galley/test/integration/API/MLS.hs b/services/galley/test/integration/API/MLS.hs index c91f2e2225..cdeb72031e 100644 --- a/services/galley/test/integration/API/MLS.hs +++ b/services/galley/test/integration/API/MLS.hs @@ -25,7 +25,6 @@ import API.Util import Bilge hiding (head) import Bilge.Assert import Cassandra hiding (Set) -import Control.Exception (throw) import Control.Lens (view) import Control.Lens.Extras import qualified Control.Monad.State as State @@ -49,7 +48,6 @@ import qualified Data.Text as T import Data.Time import Federator.MockServer hiding (withTempMockFederator) import Imports -import qualified Network.HTTP.Types.Status as HTTP import qualified Network.Wai.Utilities.Error as Wai import Test.QuickCheck (Arbitrary (arbitrary), generate) import Test.Tasty @@ -1133,19 +1131,12 @@ testAppMessageSomeReachable = do sendAndConsumeCommit commit let unreachables = Set.singleton (Domain "charlie.example.com") - withTempMockFederator' (mockUnreachableFor unreachables) $ do + withTempMockFederator' (mlsMockUnreachableFor unreachables) $ do message <- createApplicationMessage alice1 "hi, bob!" (_, ftp) <- sendAndConsumeMessage message liftIO $ do assertBool "Event should be member join" $ is _EdMembersJoin (evtData event) ftp @?= failedToSend [charlie] - where - mockUnreachableFor :: Set Domain -> Mock LByteString - mockUnreachableFor backends = do - r <- getRequest - if Set.member (frTargetDomain r) backends - then throw (MockErrorResponse HTTP.status503 "Down for maintenance.") - else mockReply ("RemoteMLSMessageOk" :: String) testAppMessageUnreachable :: TestM () testAppMessageUnreachable = do diff --git a/services/galley/test/integration/API/MLS/Mocks.hs b/services/galley/test/integration/API/MLS/Mocks.hs index d4c4aa0c64..2f58ec462a 100644 --- a/services/galley/test/integration/API/MLS/Mocks.hs +++ b/services/galley/test/integration/API/MLS/Mocks.hs @@ -23,9 +23,11 @@ module API.MLS.Mocks sendMessageMock, claimKeyPackagesMock, queryGroupStateMock, + mlsMockUnreachableFor, ) where +import Data.Domain import Data.Id import Data.Json.Util import Data.Qualified @@ -80,3 +82,6 @@ queryGroupStateMock gs qusr = do if uid == qUnqualified qusr then GetGroupInfoResponseState (Base64ByteString gs) else GetGroupInfoResponseError ConvNotFound + +mlsMockUnreachableFor :: Set Domain -> Mock LByteString +mlsMockUnreachableFor = mockUnreachableFor "RemoteMLSMessageOk" From 76c1e899394b491d4481bf95cbecbc064e2c5083 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marko=20Dimja=C5=A1evi=C4=87?= Date: Thu, 13 Apr 2023 15:46:03 +0200 Subject: [PATCH 11/36] Introduce failed to remove (via failed to fetch client info) --- libs/wire-api/src/Wire/API/MLS/Message.hs | 23 ++++- services/galley/src/Galley/API/MLS/Message.hs | 93 +++++++++++-------- 2 files changed, 72 insertions(+), 44 deletions(-) diff --git a/libs/wire-api/src/Wire/API/MLS/Message.hs b/libs/wire-api/src/Wire/API/MLS/Message.hs index 95eca7d0ca..9674c7d061 100644 --- a/libs/wire-api/src/Wire/API/MLS/Message.hs +++ b/libs/wire-api/src/Wire/API/MLS/Message.hs @@ -48,6 +48,8 @@ module Wire.API.MLS.Message failedToSendMaybe, failedToAdd, failedToAddMaybe, + failedToRemove, + failedToRemoveMaybe, ) where @@ -354,7 +356,8 @@ v <\> Nothing = v -- e.g., a message could not be sent to these remote users. data FailedToProcess = FailedToProcess { send :: Maybe UnreachableUsers, - add :: Maybe UnreachableUsers + add :: Maybe UnreachableUsers, + remove :: Maybe UnreachableUsers } deriving (Eq, Show) deriving (A.ToJSON, A.FromJSON, S.ToSchema) via Schema FailedToProcess @@ -363,11 +366,12 @@ instance Semigroup FailedToProcess where ftp1 <> ftp2 = FailedToProcess { send = send ftp1 <\> send ftp2, - add = add ftp1 <\> add ftp2 + add = add ftp1 <\> add ftp2, + remove = remove ftp1 <\> remove ftp2 } instance Monoid FailedToProcess where - mempty = FailedToProcess mempty mempty + mempty = FailedToProcess mempty mempty mempty failedToProcessObjectSchema :: ObjectSchema SwaggerDoc FailedToProcess failedToProcessObjectSchema = @@ -386,6 +390,13 @@ failedToProcessObjectSchema = (description ?~ "List of federated users who could not be reached and be added to a conversation") (unnamed schema) ) + <*> remove + .= maybe_ + ( optFieldWithDocModifier + "failed_to_remove" + (description ?~ "List of federated users who could not be reached and be removed from a conversation") + (unnamed schema) + ) instance ToSchema FailedToProcess where schema = object "FailedToProcess" failedToProcessObjectSchema @@ -402,6 +413,12 @@ failedToAdd = failedToAddMaybe . unreachableFromList failedToAddMaybe :: Maybe UnreachableUsers -> FailedToProcess failedToAddMaybe us = mempty {add = us} +failedToRemove :: [Qualified UserId] -> FailedToProcess +failedToRemove = failedToRemoveMaybe . unreachableFromList + +failedToRemoveMaybe :: Maybe UnreachableUsers -> FailedToProcess +failedToRemoveMaybe us = mempty {remove = us} + data MLSMessageSendingStatus = MLSMessageSendingStatus { mmssEvents :: [Event], mmssTime :: UTCTimeMillis, diff --git a/services/galley/src/Galley/API/MLS/Message.hs b/services/galley/src/Galley/API/MLS/Message.hs index a5ce6a2e27..64cd97704c 100644 --- a/services/galley/src/Galley/API/MLS/Message.hs +++ b/services/galley/src/Galley/API/MLS/Message.hs @@ -27,7 +27,6 @@ module Galley.API.MLS.Message where import Control.Comonad -import Control.Error.Util (hush) import Control.Lens (preview) import Data.Id import Data.Json.Util @@ -1124,47 +1123,55 @@ executeProposalAction qusr con lconv mlsMeta cm action = do -- Type 2 requires no special processing on the backend, so here we filter -- out all removals of that type, so that further checks and processing can -- be applied only to type 1 removals. - removedUsers <- mapMaybe hush <$$> for (Map.assocs (paRemove action)) $ - \(qtarget, Set.map fst -> clients) -> runError @() $ do + (failedRemoveFetching, removedUsers) <- + fmap partitionEithers $ forM (Map.assocs (paRemove action)) $ \(qtarget, Set.map fst -> clients) -> do -- fetch clients from brig - clientInfo <- Set.map ciId <$> getClientInfo lconv qtarget ss - -- if the clients being removed don't exist, consider this as a removal of - -- type 2, and skip it - when (Set.null (clientInfo `Set.intersection` clients)) $ - throw () - pure (qtarget, clients) + Set.map ciId <$$> getClientInfo lconv qtarget ss >>= \case + Left _ -> pure . Left $ qtarget + Right clientInfo -> do + -- if the clients being removed don't exist, consider this as a removal of + -- type 2, and skip it + pure $ + if Set.null (clientInfo `Set.intersection` clients) + then Left qtarget + else Right (qtarget, clients) -- FUTUREWORK: remove this check after remote admins are implemented in federation https://wearezeta.atlassian.net/browse/FS-216 foldQualified lconv (\_ -> pure ()) (\_ -> throwS @'MLSUnsupportedProposal) qusr -- for each user, we compare their clients with the ones being added to the conversation - for_ newUserClients $ \(qtarget, newclients) -> case Map.lookup qtarget cm of - -- user is already present, skip check in this case - Just _ -> pure () - -- new user - Nothing -> do - -- final set of clients in the conversation - let clients = Set.map fst (newclients <> Map.findWithDefault mempty qtarget cm) - -- get list of mls clients from brig - clientInfo <- getClientInfo lconv qtarget ss - let allClients = Set.map ciId clientInfo - let allMLSClients = Set.map ciId (Set.filter ciMLS clientInfo) - -- We check the following condition: - -- allMLSClients ⊆ clients ⊆ allClients - -- i.e. - -- - if a client has at least 1 key package, it has to be added - -- - if a client is being added, it has to still exist - -- - -- The reason why we can't simply check that clients == allMLSClients is - -- that a client with no remaining key packages might be added by a user - -- who just fetched its last key package. - unless - ( Set.isSubsetOf allMLSClients clients - && Set.isSubsetOf clients allClients - ) - $ do - -- FUTUREWORK: turn this error into a proper response - throwS @'MLSClientMismatch + failedAddFetching <- fmap catMaybes $ + forM newUserClients $ + \(qtarget, newclients) -> case Map.lookup qtarget cm of + -- user is already present, skip check in this case + Just _ -> pure Nothing + -- new user + Nothing -> do + -- final set of clients in the conversation + let clients = Set.map fst (newclients <> Map.findWithDefault mempty qtarget cm) + -- get list of mls clients from Brig (local or remote) + getClientInfo lconv qtarget ss >>= \case + Left _ -> pure (Just qtarget) + Right clientInfo -> do + let allClients = Set.map ciId clientInfo + let allMLSClients = Set.map ciId (Set.filter ciMLS clientInfo) + -- We check the following condition: + -- allMLSClients ⊆ clients ⊆ allClients + -- i.e. + -- - if a client has at least 1 key package, it has to be added + -- - if a client is being added, it has to still exist + -- + -- The reason why we can't simply check that clients == allMLSClients is + -- that a client with no remaining key packages might be added by a user + -- who just fetched its last key package. + unless + ( Set.isSubsetOf allMLSClients clients + && Set.isSubsetOf clients allClients + ) + $ do + -- FUTUREWORK: turn this error into a proper response + throwS @'MLSClientMismatch + pure Nothing membersToRemove <- catMaybes <$> for removedUsers (uncurry checkRemoval) @@ -1193,7 +1200,10 @@ executeProposalAction qusr con lconv mlsMeta cm action = do for_ (Map.assocs (paRemove action)) $ \(qtarget, clients) -> do removeMLSClients (cnvmlsGroupId mlsMeta) qtarget (Set.map fst clients) - pure (addEvents <> removeEvents, failedToAdd failedAdding) + let failedToProcess = + failedToAdd (failedAddFetching <> failedAdding) + <> failedToRemove failedRemoveFetching + pure (addEvents <> removeEvents, failedToProcess) where onlyJoining :: Event -> [Qualified UserId] onlyJoining (evtData -> EdMembersJoin ms) = smQualifiedId <$> mMembers ms @@ -1260,17 +1270,18 @@ getClientInfo :: Local x -> Qualified UserId -> SignatureSchemeTag -> - Sem r (Set ClientInfo) -getClientInfo loc = foldQualified loc getLocalMLSClients getRemoteMLSClients + Sem r (Either FederationError (Set ClientInfo)) +getClientInfo loc = + foldQualified loc (\lusr -> fmap Right . getLocalMLSClients lusr) getRemoteMLSClients getRemoteMLSClients :: ( Member FederatorAccess r ) => Remote UserId -> SignatureSchemeTag -> - Sem r (Set ClientInfo) + Sem r (Either FederationError (Set ClientInfo)) getRemoteMLSClients rusr ss = do - runFederated rusr $ + runFederatedEither rusr $ fedClient @'Brig @"get-mls-clients" $ MLSClientsRequest { mcrUserId = tUnqualified rusr, From 3536b2087ddae077168d3595461396b4f53bef28 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marko=20Dimja=C5=A1evi=C4=87?= Date: Thu, 13 Apr 2023 16:46:51 +0200 Subject: [PATCH 12/36] Test WIP --- .../federator/src/Federator/MockServer.hs | 4 +- services/galley/test/integration/API/MLS.hs | 47 +++++++++++++++++++ 2 files changed, 50 insertions(+), 1 deletion(-) diff --git a/services/federator/src/Federator/MockServer.hs b/services/federator/src/Federator/MockServer.hs index 3d1e08de1c..72872f6470 100644 --- a/services/federator/src/Federator/MockServer.hs +++ b/services/federator/src/Federator/MockServer.hs @@ -212,7 +212,9 @@ mockUnreachableFor msg backends = do r <- getRequest if Set.member (frTargetDomain r) backends then throw (MockErrorResponse HTTP.status503 "Down for maintenance.") - else mockReply msg + else do + liftIO $ putStrLn $ "In mockUnreachableFor, msg = " <> msg + mockReply msg -- | Abort the mock with an error. mockFail :: Text -> Mock a diff --git a/services/galley/test/integration/API/MLS.hs b/services/galley/test/integration/API/MLS.hs index cdeb72031e..3803585e2c 100644 --- a/services/galley/test/integration/API/MLS.hs +++ b/services/galley/test/integration/API/MLS.hs @@ -109,6 +109,7 @@ tests s = test s "add user with some non-MLS clients" testAddUserWithProteusClients, test s "send a stale commit" testStaleCommit, test s "add remote user to a conversation" testAddRemoteUser, + test s "add remote users to a conversation (some unreachable)" testAddRemotesSomeUnreachable, test s "return error when commit is locked" testCommitLock, test s "add user to a conversation with proposal + commit" testAddUserBareProposalCommit, test s "post commit that references an unknown proposal" testUnknownProposalRefCommit, @@ -661,6 +662,52 @@ testAddRemoteUser = do event <- assertOne events assertJoinEvent qcnv alice [bob] roleNameWireMember event +testAddRemotesSomeUnreachable :: TestM () +testAddRemotesSomeUnreachable = do + let bobDomain = Domain "bob.example.com" + charlieDomain = Domain "charlie.example.com" + users@[alice, bob, charlie] <- + createAndConnectUsers + [ Nothing, + Just (domainText bobDomain), + Just (domainText charlieDomain) + ] + (events, reqs, qcnv) <- runMLSTest $ do + [alice1, bob1, _charlie1] <- traverse createMLSClient users + (_, qcnv) <- setupMLSGroup alice1 + + commit <- createAddCommit alice1 [bob, charlie] + let unreachable = Set.singleton charlieDomain + (events, reqs) <- + withTempMockFederator' + ( mlsMockUnreachableFor unreachable + <|> receiveCommitMockByDomain [bob1] + <|> welcomeMock + ) + $ sendAndConsumeCommit commit + pure (events, reqs, qcnv) + + liftIO $ do + req <- assertOne $ filter ((== "on-conversation-updated") . frRPC) reqs + frTargetDomain req @?= qDomain bob + bdy <- case Aeson.eitherDecode (frBody req) of + Right b -> pure b + Left e -> assertFailure $ "Could not parse on-conversation-updated request body: " <> e + cuOrigUserId bdy @?= alice + cuConvId bdy @?= qUnqualified qcnv + cuAlreadyPresentUsers bdy @?= [qUnqualified bob] + cuAction bdy + @?= SomeConversationAction + SConversationJoinTag + ConversationJoin + { cjUsers = pure bob, + cjRole = roleNameWireMember + } + + liftIO $ do + event <- assertOne events + assertJoinEvent qcnv alice [bob] roleNameWireMember event + testCommitLock :: TestM () testCommitLock = do users <- createAndConnectUsers (replicate 4 Nothing) From fd4134c1edc4634d135dcfc5b7c789547e3ad3d1 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marko=20Dimja=C5=A1evi=C4=87?= Date: Fri, 14 Apr 2023 15:53:30 +0200 Subject: [PATCH 13/36] Propagate FailedToProcess across federation API arising from conversation updates --- .../src/Wire/API/Federation/API/Galley.hs | 6 +-- services/galley/src/Galley/API/Action.hs | 52 +++++++++++++------ services/galley/src/Galley/API/Federation.hs | 37 ++++++------- services/galley/src/Galley/API/MLS/Message.hs | 13 +++-- services/galley/src/Galley/API/Update.hs | 28 +++++----- services/galley/test/integration/API.hs | 6 +-- .../galley/test/integration/API/Federation.hs | 4 +- 7 files changed, 86 insertions(+), 60 deletions(-) diff --git a/libs/wire-api-federation/src/Wire/API/Federation/API/Galley.hs b/libs/wire-api-federation/src/Wire/API/Federation/API/Galley.hs index eb81209efa..dbedf89362 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 @@ -365,11 +365,11 @@ newtype MessageSendResponse = MessageSendResponse ) newtype LeaveConversationResponse = LeaveConversationResponse - {leaveResponse :: Either RemoveFromConversationError ()} + {leaveResponse :: Either RemoveFromConversationError FailedToProcess} deriving stock (Eq, Show) deriving (ToJSON, FromJSON) - via (Either (CustomEncoded RemoveFromConversationError) ()) + via (Either (CustomEncoded RemoveFromConversationError) FailedToProcess) type UserDeletedNotificationMaxConvs = 1000 @@ -398,7 +398,7 @@ data ConversationUpdateRequest = ConversationUpdateRequest data ConversationUpdateResponse = ConversationUpdateResponseError GalleyError - | ConversationUpdateResponseUpdate ConversationUpdate + | ConversationUpdateResponseUpdate (ConversationUpdate, FailedToProcess) | ConversationUpdateResponseNoChanges deriving stock (Eq, Show, Generic) deriving diff --git a/services/galley/src/Galley/API/Action.hs b/services/galley/src/Galley/API/Action.hs index dfe49a0595..7ad5821e3b 100644 --- a/services/galley/src/Galley/API/Action.hs +++ b/services/galley/src/Galley/API/Action.hs @@ -95,6 +95,7 @@ import Wire.API.Event.Conversation import Wire.API.Federation.API (Component (Galley), fedClient) import Wire.API.Federation.API.Galley import Wire.API.Federation.Error +import Wire.API.MLS.Message import Wire.API.Team.LegalHold import Wire.API.Team.Member import qualified Wire.API.User as User @@ -578,7 +579,7 @@ updateLocalConversation :: Qualified UserId -> Maybe ConnId -> ConversationAction tag -> - Sem r LocalConversationUpdate + Sem r (LocalConversationUpdate, FailedToProcess) updateLocalConversation lcnv qusr con action = do let tag = sing @tag @@ -616,7 +617,7 @@ updateLocalConversationUnchecked :: Qualified UserId -> Maybe ConnId -> ConversationAction tag -> - Sem r LocalConversationUpdate + Sem r (LocalConversationUpdate, FailedToProcess) updateLocalConversationUnchecked lconv qusr con action = do let tag = sing @tag lcnv = fmap convId lconv @@ -705,7 +706,7 @@ notifyConversationAction :: Local Conversation -> BotsAndMembers -> ConversationAction (tag :: ConversationActionTag) -> - Sem r LocalConversationUpdate + Sem r (LocalConversationUpdate, FailedToProcess) notifyConversationAction failEarly tag quid notifyOrigDomain con lconv targets action = do now <- input let lcnv = fmap convId lconv @@ -726,6 +727,10 @@ notifyConversationAction failEarly tag quid notifyOrigDomain con lconv targets a Set.difference (Set.map void (bmRemotes targets)) (Set.fromList (map (void . rmId) (convRemoteMembers conv))) + newRemotes = + Set.filter (\r -> Set.member (void r) newDomains) + . bmRemotes + $ targets let nrc = NewRemoteConversation { nrcConvId = convId conv, @@ -734,7 +739,7 @@ notifyConversationAction failEarly tag quid notifyOrigDomain con lconv targets a let errorIntolerant = do E.runFederatedConcurrently_ (toList newDomains) $ \_ -> do void $ fedClient @'Galley @"on-new-remote-conversation" nrc - fmap (fromMaybe (mkUpdate []) . asum . map tUnqualified) + update <- fmap (fromMaybe (mkUpdate []) . asum . map tUnqualified) . E.runFederatedConcurrently (toList (bmRemotes targets)) $ \ruids -> do let update = mkUpdate (tUnqualified ruids) @@ -744,13 +749,18 @@ notifyConversationAction failEarly tag quid notifyOrigDomain con lconv targets a if notifyOrigDomain || tDomain ruids /= qDomain quid then fedClient @'Galley @"on-conversation-updated" update $> Nothing else pure (Just update) + pure (update, mempty) errorTolerant = do - fedEithers <- E.runFederatedConcurrentlyEither (toList newDomains) $ \_ -> do - void $ fedClient @'Galley @"on-new-remote-conversation" nrc - for_ fedEithers $ - either - (logError "on-new-remote-conversation" "An error occurred while communicating with federated server: ") - (pure . tUnqualified) + notifyEithers <- + E.runFederatedConcurrentlyEither (toList newRemotes) $ \_ -> do + void $ fedClient @'Galley @"on-new-remote-conversation" nrc + -- For now these users will not be able to join the conversation until + -- queueing and retrying is implemented. + let failedNotifies = lefts notifyEithers + for_ failedNotifies $ + logError + "on-new-remote-conversation" + "An error occurred while communicating with federated server: " updates <- E.runFederatedConcurrentlyEither (toList (bmRemotes targets)) $ \ruids -> do @@ -763,21 +773,33 @@ notifyConversationAction failEarly tag quid notifyOrigDomain con lconv targets a else pure (Just update) let f = fromMaybe (mkUpdate []) . asum . map tUnqualified . rights update = f updates - for_ (lefts updates) $ + failedUpdates = lefts updates + toFailedToProcess :: [Qualified UserId] -> FailedToProcess + toFailedToProcess us = case tag of + SConversationJoinTag -> failedToAdd us + SConversationLeaveTag -> failedToRemove us + SConversationRemoveMembersTag -> failedToRemove us + _ -> mempty + for_ failedUpdates $ logError - "on-conversation-update" + "on-conversation-updated" "An error occurred while communicating with federated server: " - pure update + let totalFailedToProcess = + failedToAdd (qualifiedFails failedNotifies) + <> toFailedToProcess (qualifiedFails failedUpdates) + pure (update, totalFailedToProcess) - update <- if failEarly then errorIntolerant else errorTolerant + (update, failedToProcess) <- if failEarly then errorIntolerant else errorTolerant -- notify local participants and bots pushConversationEvent con e (qualifyAs lcnv (bmLocals targets)) (bmBots targets) -- return both the event and the 'ConversationUpdate' structure corresponding -- to the originating domain (if it is remote) - pure $ LocalConversationUpdate e update + pure $ (LocalConversationUpdate e update, failedToProcess) where + qualifiedFails :: [(QualifiedWithTag t [a], b)] -> [Qualified a] + qualifiedFails = foldMap (sequenceA . tUntagged . fst) logError :: Show a => String -> String -> (a, FederationError) -> Sem r () logError field msg e = P.warn $ diff --git a/services/galley/src/Galley/API/Federation.hs b/services/galley/src/Galley/API/Federation.hs index 11f24556ef..862d4d0bf9 100644 --- a/services/galley/src/Galley/API/Federation.hs +++ b/services/galley/src/Galley/API/Federation.hs @@ -344,7 +344,7 @@ leaveConversation :: F.LeaveConversationRequest -> Sem r F.LeaveConversationResponse leaveConversation requestingDomain lc = do - let leaver :: Remote UserId = qTagUnsafe $ Qualified (F.lcLeaver lc) requestingDomain + let leaver = Qualified (F.lcLeaver lc) requestingDomain lcnv <- qualifyLocal (F.lcConvId lc) res <- @@ -354,34 +354,35 @@ leaveConversation requestingDomain lc = do . mapToRuntimeError @'InvalidOperation F.RemoveFromConversationErrorRemovalNotAllowed . mapError @NoChanges (const F.RemoveFromConversationErrorUnchanged) $ do - (conv, _self) <- getConversationAndMemberWithError @'ConvNotFound (tUntagged leaver) lcnv + (conv, _self) <- getConversationAndMemberWithError @'ConvNotFound leaver lcnv update <- - lcuUpdate + first lcuUpdate <$> updateLocalConversation @'ConversationLeaveTag lcnv - (tUntagged leaver) + leaver Nothing () pure (update, conv) case res of Left e -> pure $ F.LeaveConversationResponse (Left e) - Right (_update, conv) -> do - let remotes = filter ((== tDomain leaver) . tDomain) (rmId <$> Data.convRemoteMembers conv) + Right ((_update, updateFailedToProcess), conv) -> do + let remotes = filter ((== qDomain leaver) . tDomain) (rmId <$> Data.convRemoteMembers conv) let botsAndMembers = BotsAndMembers mempty (Set.fromList remotes) mempty - _ <- + (_, notifyFailedToProcess) <- notifyConversationAction False SConversationLeaveTag - (tUntagged leaver) + leaver False Nothing (qualifyAs lcnv conv) botsAndMembers () - pure $ F.LeaveConversationResponse (Right ()) + pure . F.LeaveConversationResponse . Right $ + updateFailedToProcess <> notifyFailedToProcess -- FUTUREWORK: report errors to the originating backend -- FUTUREWORK: error handling for missing / mismatched clients @@ -545,46 +546,46 @@ updateConversation origDomain updateRequest = do SomeConversationAction tag action -> case tag of SConversationJoinTag -> mapToGalleyError @(HasConversationActionGalleyErrors 'ConversationJoinTag) - . fmap lcuUpdate + . fmap (first lcuUpdate) $ updateLocalConversation @'ConversationJoinTag lcnv (tUntagged rusr) Nothing action SConversationLeaveTag -> mapToGalleyError @(HasConversationActionGalleyErrors 'ConversationLeaveTag) - . fmap lcuUpdate + . fmap (first lcuUpdate) $ updateLocalConversation @'ConversationLeaveTag lcnv (tUntagged rusr) Nothing action SConversationRemoveMembersTag -> mapToGalleyError @(HasConversationActionGalleyErrors 'ConversationRemoveMembersTag) - . fmap lcuUpdate + . fmap (first lcuUpdate) $ updateLocalConversation @'ConversationRemoveMembersTag lcnv (tUntagged rusr) Nothing action SConversationMemberUpdateTag -> mapToGalleyError @(HasConversationActionGalleyErrors 'ConversationMemberUpdateTag) - . fmap lcuUpdate + . fmap (first lcuUpdate) $ updateLocalConversation @'ConversationMemberUpdateTag lcnv (tUntagged rusr) Nothing action SConversationDeleteTag -> mapToGalleyError @(HasConversationActionGalleyErrors 'ConversationDeleteTag) - . fmap lcuUpdate + . fmap (first lcuUpdate) $ updateLocalConversation @'ConversationDeleteTag lcnv (tUntagged rusr) Nothing action SConversationRenameTag -> mapToGalleyError @(HasConversationActionGalleyErrors 'ConversationRenameTag) - . fmap lcuUpdate + . fmap (first lcuUpdate) $ updateLocalConversation @'ConversationRenameTag lcnv (tUntagged rusr) Nothing action SConversationMessageTimerUpdateTag -> mapToGalleyError @(HasConversationActionGalleyErrors 'ConversationMessageTimerUpdateTag) - . fmap lcuUpdate + . fmap (first lcuUpdate) $ updateLocalConversation @'ConversationMessageTimerUpdateTag lcnv (tUntagged rusr) Nothing action SConversationReceiptModeUpdateTag -> mapToGalleyError @(HasConversationActionGalleyErrors 'ConversationReceiptModeUpdateTag) - . fmap lcuUpdate + . fmap (first lcuUpdate) $ updateLocalConversation @'ConversationReceiptModeUpdateTag lcnv (tUntagged rusr) Nothing action SConversationAccessDataTag -> mapToGalleyError @(HasConversationActionGalleyErrors 'ConversationAccessDataTag) - . fmap lcuUpdate + . fmap (first lcuUpdate) $ updateLocalConversation @'ConversationAccessDataTag lcnv (tUntagged rusr) Nothing action where mkResponse = fmap toResponse . runError @GalleyError . runError @NoChanges diff --git a/services/galley/src/Galley/API/MLS/Message.hs b/services/galley/src/Galley/API/MLS/Message.hs index 64cd97704c..9712dca21d 100644 --- a/services/galley/src/Galley/API/MLS/Message.hs +++ b/services/galley/src/Galley/API/MLS/Message.hs @@ -1185,6 +1185,7 @@ executeProposalAction qusr con lconv mlsMeta cm action = do . ulNewMembers lconv (tUnqualified lconv) . toUserList lconv . foldMap (onlyJoining . lcuEvent) + . fst $ addEvents ) @@ -1202,8 +1203,10 @@ executeProposalAction qusr con lconv mlsMeta cm action = do let failedToProcess = failedToAdd (failedAddFetching <> failedAdding) + <> snd addEvents <> failedToRemove failedRemoveFetching - pure (addEvents <> removeEvents, failedToProcess) + <> snd removeEvents + pure (fst addEvents <> fst removeEvents, failedToProcess) where onlyJoining :: Event -> [Qualified UserId] onlyJoining (evtData -> EdMembersJoin ms) = smQualifiedId <$> mMembers ms @@ -1234,13 +1237,13 @@ executeProposalAction qusr con lconv mlsMeta cm action = do existingMembers :: Set (Qualified UserId) existingMembers = existingLocalMembers <> existingRemoteMembers - addMembers :: NonEmpty (Qualified UserId) -> Sem r [LocalConversationUpdate] + addMembers :: NonEmpty (Qualified UserId) -> Sem r ([LocalConversationUpdate], FailedToProcess) addMembers = -- FUTUREWORK: update key package ref mapping to reflect conversation membership foldMap ( handleNoChanges . handleMLSProposalFailures @ProposalErrors - . fmap pure + . fmap (first pure) . updateLocalConversationUnchecked @'ConversationJoinTag lconv qusr con . flip ConversationJoin roleNameWireMember ) @@ -1248,12 +1251,12 @@ executeProposalAction qusr con lconv mlsMeta cm action = do . filter (flip Set.notMember existingMembers) . toList - removeMembers :: NonEmpty (Qualified UserId) -> Sem r [LocalConversationUpdate] + removeMembers :: NonEmpty (Qualified UserId) -> Sem r ([LocalConversationUpdate], FailedToProcess) removeMembers = foldMap ( handleNoChanges . handleMLSProposalFailures @ProposalErrors - . fmap pure + . fmap (first pure) . updateLocalConversationUnchecked @'ConversationRemoveMembersTag lconv qusr con ) . nonEmpty diff --git a/services/galley/src/Galley/API/Update.hs b/services/galley/src/Galley/API/Update.hs index 2460533ccb..1f59493b3e 100644 --- a/services/galley/src/Galley/API/Update.hs +++ b/services/galley/src/Galley/API/Update.hs @@ -288,7 +288,7 @@ updateConversationAccess :: Sem r (UpdateResult Event) updateConversationAccess lusr con qcnv update = do lcnv <- ensureLocal lusr qcnv - getUpdateResult . fmap lcuEvent $ + getUpdateResult . fmap (lcuEvent . fst) $ updateLocalConversation @'ConversationAccessDataTag lcnv (tUntagged lusr) (Just con) update updateConversationAccessUnqualified :: @@ -300,7 +300,7 @@ updateConversationAccessUnqualified :: ConversationAccessData -> Sem r (UpdateResult Event) updateConversationAccessUnqualified lusr con cnv update = - getUpdateResult . fmap lcuEvent $ + getUpdateResult . fmap (lcuEvent . fst) $ updateLocalConversation @'ConversationAccessDataTag (qualifyAs lusr cnv) (tUntagged lusr) @@ -331,7 +331,7 @@ updateConversationReceiptMode lusr zcon qcnv update = foldQualified lusr ( \lcnv -> - getUpdateResult . fmap lcuEvent $ + getUpdateResult . fmap (lcuEvent . fst) $ updateLocalConversation @'ConversationReceiptModeUpdateTag lcnv @@ -370,7 +370,7 @@ updateRemoteConversation rcnv lusr conn action = getUpdateResult $ do convUpdate <- case response of ConversationUpdateResponseNoChanges -> throw NoChanges ConversationUpdateResponseError err' -> rethrowErrors @(HasConversationActionGalleyErrors tag) err' - ConversationUpdateResponseUpdate convUpdate -> pure convUpdate + ConversationUpdateResponseUpdate (convUpdate, _failedToProcess) -> pure convUpdate onConversationUpdated (tDomain rcnv) convUpdate notifyRemoteConversationAction lusr (qualifyAs rcnv convUpdate) (Just conn) @@ -419,7 +419,7 @@ updateConversationMessageTimer lusr zcon qcnv update = foldQualified lusr ( \lcnv -> - lcuEvent + (lcuEvent . fst) <$> updateLocalConversation @'ConversationMessageTimerUpdateTag lcnv @@ -469,7 +469,7 @@ deleteLocalConversation :: Local ConvId -> Sem r (UpdateResult Event) deleteLocalConversation lusr con lcnv = - getUpdateResult . fmap lcuEvent $ + getUpdateResult . fmap (lcuEvent . fst) $ updateLocalConversation @'ConversationDeleteTag lcnv (tUntagged lusr) (Just con) () getUpdateResult :: Sem (Error NoChanges ': r) a -> Sem r (UpdateResult a) @@ -764,7 +764,7 @@ joinConversation lusr zcon conv access = do let users = filter (notIsConvMember lusr conv) [tUnqualified lusr] (extraTargets, action) <- addMembersToLocalConversation lcnv (UserList users []) roleNameWireMember - lcuEvent + (lcuEvent . fst) <$> notifyConversationAction False (sing @'ConversationJoinTag) @@ -808,7 +808,7 @@ addMembers :: Sem r (UpdateResult Event) addMembers lusr zcon qcnv (InviteQualified users role) = do lcnv <- ensureLocal lusr qcnv - getUpdateResult . fmap lcuEvent $ + getUpdateResult . fmap (lcuEvent . fst) $ updateLocalConversation @'ConversationJoinTag lcnv (tUntagged lusr) (Just zcon) $ ConversationJoin users role @@ -845,7 +845,7 @@ addMembersUnqualifiedV2 :: Sem r (UpdateResult Event) addMembersUnqualifiedV2 lusr zcon cnv (InviteQualified users role) = do let lcnv = qualifyAs lusr cnv - getUpdateResult . fmap lcuEvent $ + getUpdateResult . fmap (lcuEvent . fst) $ updateLocalConversation @'ConversationJoinTag lcnv (tUntagged lusr) (Just zcon) $ ConversationJoin users role @@ -968,7 +968,7 @@ updateOtherMemberLocalConv :: Qualified UserId -> OtherMemberUpdate -> Sem r () -updateOtherMemberLocalConv lcnv lusr con qvictim update = void . getUpdateResult . fmap lcuEvent $ do +updateOtherMemberLocalConv lcnv lusr con qvictim update = void . getUpdateResult . fmap (lcuEvent . fst) $ do when (tUntagged lusr == qvictim) $ throwS @'InvalidTarget updateLocalConversation @'ConversationMemberUpdateTag lcnv (tUntagged lusr) (Just con) $ @@ -1102,7 +1102,7 @@ removeMemberFromRemoteConv cnv lusr victim | tUntagged lusr == victim = do let lc = LeaveConversationRequest (tUnqualified cnv) (qUnqualified victim) let rpc = fedClient @'Galley @"leave-conversation" lc - (either handleError handleSuccess . leaveResponse =<<) $ + (either handleError handleSuccess . void . leaveResponse =<<) $ E.runFederated cnv rpc | otherwise = throwS @('ActionDenied 'RemoveConversationMember) where @@ -1148,12 +1148,12 @@ removeMemberFromLocalConv :: Sem r (Maybe Event) removeMemberFromLocalConv lcnv lusr con victim | tUntagged lusr == victim = - fmap (fmap lcuEvent . hush) + fmap (fmap lcuEvent . hush . fmap fst) . runError @NoChanges . updateLocalConversation @'ConversationLeaveTag lcnv (tUntagged lusr) con $ () | otherwise = - fmap (fmap lcuEvent . hush) + fmap (fmap lcuEvent . hush . fmap fst) . runError @NoChanges . updateLocalConversation @'ConversationRemoveMembersTag lcnv (tUntagged lusr) con . pure @@ -1376,7 +1376,7 @@ updateLocalConversationName :: ConversationRename -> Sem r (UpdateResult Event) updateLocalConversationName lusr zcon lcnv rename = - getUpdateResult . fmap lcuEvent $ + getUpdateResult . fmap (lcuEvent . fst) $ updateLocalConversation @'ConversationRenameTag lcnv (tUntagged lusr) (Just zcon) rename memberTyping :: diff --git a/services/galley/test/integration/API.hs b/services/galley/test/integration/API.hs index 5689797051..67a53d9b26 100644 --- a/services/galley/test/integration/API.hs +++ b/services/galley/test/integration/API.hs @@ -3348,7 +3348,7 @@ leaveRemoteConvQualifiedOk = do qBob = Qualified bob remoteDomain let mockedFederatedGalleyResponse = do guardComponent Galley - mockReply (F.LeaveConversationResponse (Right ())) + mockReply (F.LeaveConversationResponse (Right mempty)) mockResponses = mockedFederatedBrigResponse [(qBob, "Bob")] <|> mockedFederatedGalleyResponse @@ -3961,7 +3961,7 @@ putRemoteReceiptModeOk = do cuAction = SomeConversationAction (sing @'ConversationReceiptModeUpdateTag) action } - let mockResponse = mockReply (ConversationUpdateResponseUpdate responseConvUpdate) + let mockResponse = mockReply (ConversationUpdateResponseUpdate (responseConvUpdate, mempty)) WS.bracketR c adam $ \wsAdam -> do (res, federatedRequests) <- withTempMockFederator' mockResponse $ do @@ -4237,7 +4237,7 @@ removeUser = do do guard (d `elem` [bDomain, cDomain]) asum - [ "leave-conversation" ~> F.LeaveConversationResponse (Right ()), + [ "leave-conversation" ~> F.LeaveConversationResponse (Right mempty), "on-conversation-updated" ~> () ] ] diff --git a/services/galley/test/integration/API/Federation.hs b/services/galley/test/integration/API/Federation.hs index f05cfe537e..4d897b0512 100644 --- a/services/galley/test/integration/API/Federation.hs +++ b/services/galley/test/integration/API/Federation.hs @@ -680,7 +680,7 @@ leaveConversationSuccess = do liftIO $ case resp of ConversationUpdateResponseError err -> assertFailure ("Expected ConversationUpdateResponseUpdate but got " <> show err) ConversationUpdateResponseNoChanges -> assertFailure "Expected ConversationUpdateResponseUpdate but got ConversationUpdateResponseNoChanges" ConversationUpdateResponseUpdate up -> pure up From dccf15b336c893c038282c3852626e94c7ae7575 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marko=20Dimja=C5=A1evi=C4=87?= Date: Mon, 17 Apr 2023 15:58:25 +0200 Subject: [PATCH 14/36] Simplify the definition of the (<\>) operator --- libs/wire-api/src/Wire/API/MLS/Message.hs | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/libs/wire-api/src/Wire/API/MLS/Message.hs b/libs/wire-api/src/Wire/API/MLS/Message.hs index 9674c7d061..0dec3d86a9 100644 --- a/libs/wire-api/src/Wire/API/MLS/Message.hs +++ b/libs/wire-api/src/Wire/API/MLS/Message.hs @@ -347,10 +347,8 @@ unreachableFromList = fmap UnreachableUsers . nonEmpty -- | A 'mappend'-like operation on two optional values of a type with a -- Semigroup instance. (<\>) :: Semigroup a => Maybe a -> Maybe a -> Maybe a -Nothing <\> Nothing = Nothing -Nothing <\> v = v -v <\> Nothing = v (Just a) <\> (Just b) = Just (a <> b) +m <\> n = m <|> n -- | Lists of remote users that could not be processed in a federated action, -- e.g., a message could not be sent to these remote users. From 24d72b42fc9d5674ae2a288942d5d4cea0bf92db Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marko=20Dimja=C5=A1evi=C4=87?= Date: Wed, 19 Apr 2023 11:13:37 +0200 Subject: [PATCH 15/36] WIP: Debugging --- services/galley/src/Galley/API/Action.hs | 36 ++++++++++--------- services/galley/src/Galley/API/MLS/Message.hs | 22 +++++++++++- services/galley/test/integration/API/MLS.hs | 35 +++++++++++------- .../galley/test/integration/API/MLS/Util.hs | 15 ++++++-- 4 files changed, 74 insertions(+), 34 deletions(-) diff --git a/services/galley/src/Galley/API/Action.hs b/services/galley/src/Galley/API/Action.hs index 7ad5821e3b..cbd75ba644 100644 --- a/services/galley/src/Galley/API/Action.hs +++ b/services/galley/src/Galley/API/Action.hs @@ -707,7 +707,7 @@ notifyConversationAction :: BotsAndMembers -> ConversationAction (tag :: ConversationActionTag) -> Sem r (LocalConversationUpdate, FailedToProcess) -notifyConversationAction failEarly tag quid notifyOrigDomain con lconv targets action = do +notifyConversationAction _failEarly tag quid notifyOrigDomain con lconv targets action = do now <- input let lcnv = fmap convId lconv conv = tUnqualified lconv @@ -736,21 +736,22 @@ notifyConversationAction failEarly tag quid notifyOrigDomain con lconv targets a { nrcConvId = convId conv, nrcProtocol = convProtocol conv } - let errorIntolerant = do - E.runFederatedConcurrently_ (toList newDomains) $ \_ -> do - void $ fedClient @'Galley @"on-new-remote-conversation" nrc - update <- fmap (fromMaybe (mkUpdate []) . asum . map tUnqualified) - . E.runFederatedConcurrently (toList (bmRemotes targets)) - $ \ruids -> do - let update = mkUpdate (tUnqualified ruids) - -- if notifyOrigDomain is false, filter out user from quid's domain, - -- because quid's backend will update local state and notify its users - -- itself using the ConversationUpdate returned by this function - if notifyOrigDomain || tDomain ruids /= qDomain quid - then fedClient @'Galley @"on-conversation-updated" update $> Nothing - else pure (Just update) - pure (update, mempty) - errorTolerant = do + -- let _errorIntolerant = do + -- -- TODO(md): Get rid of 'errorIntolerant' + -- E.runFederatedConcurrently_ (toList newDomains) $ \_ -> do + -- void $ fedClient @'Galley @"on-new-remote-conversation" nrc + -- update <- fmap (fromMaybe (mkUpdate []) . asum . map tUnqualified) + -- . E.runFederatedConcurrently (toList (bmRemotes targets)) + -- $ \ruids -> do + -- let update = mkUpdate (tUnqualified ruids) + -- -- if notifyOrigDomain is false, filter out user from quid's domain, + -- -- because quid's backend will update local state and notify its users + -- -- itself using the ConversationUpdate returned by this function + -- if notifyOrigDomain || tDomain ruids /= qDomain quid + -- then fedClient @'Galley @"on-conversation-updated" update $> Nothing + -- else pure (Just update) + -- pure (update, mempty :: FailedToProcess) + let errorTolerant = do notifyEithers <- E.runFederatedConcurrentlyEither (toList newRemotes) $ \_ -> do void $ fedClient @'Galley @"on-new-remote-conversation" nrc @@ -789,7 +790,8 @@ notifyConversationAction failEarly tag quid notifyOrigDomain con lconv targets a <> toFailedToProcess (qualifiedFails failedUpdates) pure (update, totalFailedToProcess) - (update, failedToProcess) <- if failEarly then errorIntolerant else errorTolerant + -- traceM $ "In notifyConversationAction: faileEarly = " <> show failEarly + (update, failedToProcess) <- errorTolerant -- notify local participants and bots pushConversationEvent con e (qualifyAs lcnv (bmLocals targets)) (bmBots targets) diff --git a/services/galley/src/Galley/API/MLS/Message.hs b/services/galley/src/Galley/API/MLS/Message.hs index 9712dca21d..418762f509 100644 --- a/services/galley/src/Galley/API/MLS/Message.hs +++ b/services/galley/src/Galley/API/MLS/Message.hs @@ -37,6 +37,7 @@ import qualified Data.Set as Set import qualified Data.Text as T import Data.Time import Data.Tuple.Extra +import Debug.Trace import Galley.API.Action import Galley.API.Error import Galley.API.MLS.Enabled @@ -318,6 +319,9 @@ postMLSCommitBundleToLocalConv qusr mc conn bundle lcnv = do for_ (cbWelcome bundle) $ postMLSWelcome lcnv conn + traceM $ + "In postMLSCommitBundleToLocalConv: FailedToProcess = " + <> show (failedToProcess <> failedToSendMaybe unreachables) pure (events, failedToProcess <> failedToSendMaybe unreachables) postMLSCommitBundleToRemoteConv :: @@ -496,6 +500,12 @@ postMLSMessageToLocalConv qusr senderClient con smsg lcnv = -- forward message unreachables <- propagateMessage qusr lconv cm con (rmRaw smsg) + traceM $ + "In postMLSMessageToLocalConv: failedToProcess = " + <> show failedToProcess + traceM $ + "In postMLSMessageToLocalConv: FailedToProcess = " + <> show (failedToProcess <> failedToSendMaybe unreachables) pure (events, failedToProcess <> failedToSendMaybe unreachables) postMLSMessageToRemoteConv :: @@ -1111,6 +1121,7 @@ executeProposalAction :: ProposalAction -> Sem r ([LocalConversationUpdate], FailedToProcess) executeProposalAction qusr con lconv mlsMeta cm action = do + traceM $ "In executeProposalAction: paAdd action = " <> show (paAdd action) let ss = csSignatureScheme (cnvmlsCipherSuite mlsMeta) newUserClients = Map.assocs (paAdd action) @@ -1147,11 +1158,14 @@ executeProposalAction qusr con lconv mlsMeta cm action = do Just _ -> pure Nothing -- new user Nothing -> do + traceM $ "In executeProposalAction: new qtarget from newUserClients = " <> show qtarget -- final set of clients in the conversation let clients = Set.map fst (newclients <> Map.findWithDefault mempty qtarget cm) -- get list of mls clients from Brig (local or remote) getClientInfo lconv qtarget ss >>= \case - Left _ -> pure (Just qtarget) + Left e -> do + traceM $ "In executeProposalAction: received a fed error: " <> show e + pure (Just qtarget) Right clientInfo -> do let allClients = Set.map ciId clientInfo let allMLSClients = Set.map ciId (Set.filter ciMLS clientInfo) @@ -1173,6 +1187,9 @@ executeProposalAction qusr con lconv mlsMeta cm action = do throwS @'MLSClientMismatch pure Nothing + traceM $ + "In executeProposalAction: failedAddFetching = " + <> show failedAddFetching membersToRemove <- catMaybes <$> for removedUsers (uncurry checkRemoval) -- add users to the conversation and send events @@ -1188,6 +1205,9 @@ executeProposalAction qusr con lconv mlsMeta cm action = do . fst $ addEvents ) + traceM $ + "In executeProposalAction: failedAdding = " + <> show failedAdding -- add clients in the conversation state for_ newUserClients $ \(qtarget, newClients) -> do diff --git a/services/galley/test/integration/API/MLS.hs b/services/galley/test/integration/API/MLS.hs index 3803585e2c..3923cd1194 100644 --- a/services/galley/test/integration/API/MLS.hs +++ b/services/galley/test/integration/API/MLS.hs @@ -37,6 +37,7 @@ import qualified Data.ByteString.Lazy as LBS import Data.Domain import Data.Id import Data.Json.Util hiding ((#)) +import qualified Data.List.NonEmpty as NE import Data.List1 hiding (head) import qualified Data.Map as Map import Data.Qualified @@ -672,23 +673,24 @@ testAddRemotesSomeUnreachable = do Just (domainText bobDomain), Just (domainText charlieDomain) ] - (events, reqs, qcnv) <- runMLSTest $ do + (events, failedToProcess, reqs, qcnv) <- runMLSTest $ do [alice1, bob1, _charlie1] <- traverse createMLSClient users (_, qcnv) <- setupMLSGroup alice1 commit <- createAddCommit alice1 [bob, charlie] let unreachable = Set.singleton charlieDomain - (events, reqs) <- + ((events, failedToProcess), reqs) <- withTempMockFederator' ( mlsMockUnreachableFor unreachable <|> receiveCommitMockByDomain [bob1] <|> welcomeMock ) - $ sendAndConsumeCommit commit - pure (events, reqs, qcnv) + $ sendAndConsumeCommitFederated commit + pure (events, failedToProcess, reqs, qcnv) liftIO $ do - req <- assertOne $ filter ((== "on-conversation-updated") . frRPC) reqs + req <- assertOne $ filter (\r -> ((== "on-conversation-updated") . frRPC) r && frTargetDomain r == bobDomain) reqs + void $ assertOne $ filter (\r -> ((== "on-conversation-updated") . frRPC) r && frTargetDomain r == charlieDomain) reqs frTargetDomain req @?= qDomain bob bdy <- case Aeson.eitherDecode (frBody req) of Right b -> pure b @@ -696,17 +698,24 @@ testAddRemotesSomeUnreachable = do cuOrigUserId bdy @?= alice cuConvId bdy @?= qUnqualified qcnv cuAlreadyPresentUsers bdy @?= [qUnqualified bob] - cuAction bdy - @?= SomeConversationAction - SConversationJoinTag - ConversationJoin - { cjUsers = pure bob, - cjRole = roleNameWireMember - } + let expectedJoiners = sort [bob, charlie] + SomeConversationAction SConversationJoinTag cj = cuAction bdy + ConversationJoin actualJoiners actualRole = cj + (sort . NE.toList) actualJoiners @?= expectedJoiners -- TODO(md): only Bob should be listed as the joiner + actualRole @?= roleNameWireMember liftIO $ do event <- assertOne events - assertJoinEvent qcnv alice [bob] roleNameWireMember event + assertJoinEvent qcnv alice [bob, charlie] roleNameWireMember event -- TODO(md): + liftIO $ putStrLn $ "Failed to process = " <> show failedToProcess + +-- only +-- Bob +-- should +-- be +-- listed +-- as the +-- joiner testCommitLock :: TestM () testCommitLock = do diff --git a/services/galley/test/integration/API/MLS/Util.hs b/services/galley/test/integration/API/MLS/Util.hs index e3f0659315..c90f407988 100644 --- a/services/galley/test/integration/API/MLS/Util.hs +++ b/services/galley/test/integration/API/MLS/Util.hs @@ -861,8 +861,17 @@ sendAndConsumeCommit :: HasCallStack => MessagePackage -> MLSTest [Event] -sendAndConsumeCommit mp = do - (events, _) <- sendAndConsumeMessage mp +sendAndConsumeCommit = fmap fst . sendAndConsumeCommitFederated + +-- | Send an MLS commit message, simulate clients receiving it, and update the +-- test state accordingly. Also return lists of federated users that could not +-- be send a message to. +sendAndConsumeCommitFederated :: + HasCallStack => + MessagePackage -> + MLSTest ([Event], FailedToProcess) +sendAndConsumeCommitFederated mp = do + resp <- sendAndConsumeMessage mp -- increment epoch and add new clients State.modify $ \mls -> @@ -872,7 +881,7 @@ sendAndConsumeCommit mp = do mlsNewMembers = mempty } - pure events + pure resp mkBundle :: MessagePackage -> Either Text CommitBundle mkBundle mp = do From 59d212aa84d63e95aecdfd1c65208b85a38a7237 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marko=20Dimja=C5=A1evi=C4=87?= Date: Fri, 21 Apr 2023 16:36:18 +0200 Subject: [PATCH 16/36] The first version that kind of works --- .../Golden/LeaveConversationResponse.hs | 2 +- libs/wire-api/src/Wire/API/MLS/Message.hs | 7 +++-- .../federator/src/Federator/MockServer.hs | 9 +++---- services/galley/src/Galley/API/MLS/Message.hs | 27 +++---------------- services/galley/test/integration/API/MLS.hs | 21 +++++++-------- .../galley/test/integration/API/MLS/Mocks.hs | 12 +++++++-- 6 files changed, 34 insertions(+), 44 deletions(-) diff --git a/libs/wire-api-federation/test/Test/Wire/API/Federation/Golden/LeaveConversationResponse.hs b/libs/wire-api-federation/test/Test/Wire/API/Federation/Golden/LeaveConversationResponse.hs index 05137a2713..0620028b18 100644 --- a/libs/wire-api-federation/test/Test/Wire/API/Federation/Golden/LeaveConversationResponse.hs +++ b/libs/wire-api-federation/test/Test/Wire/API/Federation/Golden/LeaveConversationResponse.hs @@ -21,7 +21,7 @@ import Imports import Wire.API.Federation.API.Galley testObject_LeaveConversationResponse1 :: LeaveConversationResponse -testObject_LeaveConversationResponse1 = LeaveConversationResponse $ Right () +testObject_LeaveConversationResponse1 = LeaveConversationResponse $ Right mempty testObject_LeaveConversationResponse2 :: LeaveConversationResponse testObject_LeaveConversationResponse2 = LeaveConversationResponse $ Left RemoveFromConversationErrorRemovalNotAllowed diff --git a/libs/wire-api/src/Wire/API/MLS/Message.hs b/libs/wire-api/src/Wire/API/MLS/Message.hs index 0dec3d86a9..ee20a7993b 100644 --- a/libs/wire-api/src/Wire/API/MLS/Message.hs +++ b/libs/wire-api/src/Wire/API/MLS/Message.hs @@ -64,6 +64,7 @@ import Data.Id import Data.Json.Util import Data.Kind import Data.List.NonEmpty +import qualified Data.List.NonEmpty as NE import Data.Qualified import Data.Schema import Data.Singletons.TH @@ -332,7 +333,9 @@ instance SerialiseMLS (MessagePayload 'MLSPlainText) where newtype UnreachableUsers = UnreachableUsers {unreachableUsers :: NonEmpty (Qualified UserId)} deriving stock (Eq, Show) deriving (A.ToJSON, A.FromJSON, S.ToSchema) via Schema UnreachableUsers - deriving newtype (Semigroup) + +instance Semigroup UnreachableUsers where + (UnreachableUsers m) <> (UnreachableUsers n) = UnreachableUsers . NE.nub $ m <> n instance ToSchema UnreachableUsers where schema = @@ -342,7 +345,7 @@ instance ToSchema UnreachableUsers where .= nonEmptyArray schema unreachableFromList :: [Qualified UserId] -> Maybe UnreachableUsers -unreachableFromList = fmap UnreachableUsers . nonEmpty +unreachableFromList = fmap (UnreachableUsers . NE.nub) . nonEmpty -- | A 'mappend'-like operation on two optional values of a type with a -- Semigroup instance. diff --git a/services/federator/src/Federator/MockServer.hs b/services/federator/src/Federator/MockServer.hs index 72872f6470..ed40cc9d95 100644 --- a/services/federator/src/Federator/MockServer.hs +++ b/services/federator/src/Federator/MockServer.hs @@ -209,12 +209,11 @@ mockReply = pure . Aeson.encode -- domains. mockUnreachableFor :: String -> Set Domain -> Mock LByteString mockUnreachableFor msg backends = do - r <- getRequest - if Set.member (frTargetDomain r) backends + target <- frTargetDomain <$> getRequest + guard (target `elem` backends) + if Set.member target backends then throw (MockErrorResponse HTTP.status503 "Down for maintenance.") - else do - liftIO $ putStrLn $ "In mockUnreachableFor, msg = " <> msg - mockReply msg + else mockReply msg -- | Abort the mock with an error. mockFail :: Text -> Mock a diff --git a/services/galley/src/Galley/API/MLS/Message.hs b/services/galley/src/Galley/API/MLS/Message.hs index 418762f509..783331d8ad 100644 --- a/services/galley/src/Galley/API/MLS/Message.hs +++ b/services/galley/src/Galley/API/MLS/Message.hs @@ -37,7 +37,6 @@ import qualified Data.Set as Set import qualified Data.Text as T import Data.Time import Data.Tuple.Extra -import Debug.Trace import Galley.API.Action import Galley.API.Error import Galley.API.MLS.Enabled @@ -319,9 +318,6 @@ postMLSCommitBundleToLocalConv qusr mc conn bundle lcnv = do for_ (cbWelcome bundle) $ postMLSWelcome lcnv conn - traceM $ - "In postMLSCommitBundleToLocalConv: FailedToProcess = " - <> show (failedToProcess <> failedToSendMaybe unreachables) pure (events, failedToProcess <> failedToSendMaybe unreachables) postMLSCommitBundleToRemoteConv :: @@ -500,12 +496,6 @@ postMLSMessageToLocalConv qusr senderClient con smsg lcnv = -- forward message unreachables <- propagateMessage qusr lconv cm con (rmRaw smsg) - traceM $ - "In postMLSMessageToLocalConv: failedToProcess = " - <> show failedToProcess - traceM $ - "In postMLSMessageToLocalConv: FailedToProcess = " - <> show (failedToProcess <> failedToSendMaybe unreachables) pure (events, failedToProcess <> failedToSendMaybe unreachables) postMLSMessageToRemoteConv :: @@ -1121,7 +1111,6 @@ executeProposalAction :: ProposalAction -> Sem r ([LocalConversationUpdate], FailedToProcess) executeProposalAction qusr con lconv mlsMeta cm action = do - traceM $ "In executeProposalAction: paAdd action = " <> show (paAdd action) let ss = csSignatureScheme (cnvmlsCipherSuite mlsMeta) newUserClients = Map.assocs (paAdd action) @@ -1155,17 +1144,15 @@ executeProposalAction qusr con lconv mlsMeta cm action = do forM newUserClients $ \(qtarget, newclients) -> case Map.lookup qtarget cm of -- user is already present, skip check in this case - Just _ -> pure Nothing - -- new user + Just _ -> do + -- new user + pure Nothing Nothing -> do - traceM $ "In executeProposalAction: new qtarget from newUserClients = " <> show qtarget -- final set of clients in the conversation let clients = Set.map fst (newclients <> Map.findWithDefault mempty qtarget cm) -- get list of mls clients from Brig (local or remote) getClientInfo lconv qtarget ss >>= \case - Left e -> do - traceM $ "In executeProposalAction: received a fed error: " <> show e - pure (Just qtarget) + Left _e -> pure (Just qtarget) Right clientInfo -> do let allClients = Set.map ciId clientInfo let allMLSClients = Set.map ciId (Set.filter ciMLS clientInfo) @@ -1187,9 +1174,6 @@ executeProposalAction qusr con lconv mlsMeta cm action = do throwS @'MLSClientMismatch pure Nothing - traceM $ - "In executeProposalAction: failedAddFetching = " - <> show failedAddFetching membersToRemove <- catMaybes <$> for removedUsers (uncurry checkRemoval) -- add users to the conversation and send events @@ -1205,9 +1189,6 @@ executeProposalAction qusr con lconv mlsMeta cm action = do . fst $ addEvents ) - traceM $ - "In executeProposalAction: failedAdding = " - <> show failedAdding -- add clients in the conversation state for_ newUserClients $ \(qtarget, newClients) -> do diff --git a/services/galley/test/integration/API/MLS.hs b/services/galley/test/integration/API/MLS.hs index 3923cd1194..c65101db1a 100644 --- a/services/galley/test/integration/API/MLS.hs +++ b/services/galley/test/integration/API/MLS.hs @@ -681,9 +681,9 @@ testAddRemotesSomeUnreachable = do let unreachable = Set.singleton charlieDomain ((events, failedToProcess), reqs) <- withTempMockFederator' - ( mlsMockUnreachableFor unreachable - <|> receiveCommitMockByDomain [bob1] - <|> welcomeMock + ( receiveCommitMockByDomain [bob1] + <|> mlsMockUnreachableFor unreachable + <|> welcomeMockByDomain [bobDomain] ) $ sendAndConsumeCommitFederated commit pure (events, failedToProcess, reqs, qcnv) @@ -707,16 +707,15 @@ testAddRemotesSomeUnreachable = do liftIO $ do event <- assertOne events assertJoinEvent qcnv alice [bob, charlie] roleNameWireMember event -- TODO(md): + -- only + -- Bob + -- should + -- be + -- listed + -- as the + -- joiner liftIO $ putStrLn $ "Failed to process = " <> show failedToProcess --- only --- Bob --- should --- be --- listed --- as the --- joiner - testCommitLock :: TestM () testCommitLock = do users <- createAndConnectUsers (replicate 4 Nothing) diff --git a/services/galley/test/integration/API/MLS/Mocks.hs b/services/galley/test/integration/API/MLS/Mocks.hs index 2f58ec462a..9ba17fda03 100644 --- a/services/galley/test/integration/API/MLS/Mocks.hs +++ b/services/galley/test/integration/API/MLS/Mocks.hs @@ -20,6 +20,7 @@ module API.MLS.Mocks receiveCommitMockByDomain, messageSentMock, welcomeMock, + welcomeMockByDomain, sendMessageMock, claimKeyPackagesMock, queryGroupStateMock, @@ -54,8 +55,9 @@ receiveCommitMock clients = receiveCommitMockByDomain :: [ClientIdentity] -> Mock LByteString receiveCommitMockByDomain clients = do - r <- getRequest - let fClients = filter (\c -> frTargetDomain r == ciDomain c) clients + domain <- frTargetDomain <$> getRequest + guard (domain `elem` (ciDomain <$> clients)) + let fClients = filter (\c -> domain == ciDomain c) clients receiveCommitMock fClients messageSentMock :: Mock LByteString @@ -64,6 +66,12 @@ messageSentMock = "on-mls-message-sent" ~> RemoteMLSMessageOk welcomeMock :: Mock LByteString welcomeMock = "mls-welcome" ~> MLSWelcomeSent +welcomeMockByDomain :: [Domain] -> Mock LByteString +welcomeMockByDomain reachables = do + domain <- frTargetDomain <$> getRequest + guard (domain `elem` reachables) + welcomeMock + sendMessageMock :: Mock LByteString sendMessageMock = "send-mls-message" ~> From 97fdcda086958fb9e5aa0a43b97a4b0d559de5db Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marko=20Dimja=C5=A1evi=C4=87?= Date: Fri, 21 Apr 2023 16:38:04 +0200 Subject: [PATCH 17/36] fixup! WIP: Debugging --- services/galley/src/Galley/API/Action.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/services/galley/src/Galley/API/Action.hs b/services/galley/src/Galley/API/Action.hs index cbd75ba644..c49404fb03 100644 --- a/services/galley/src/Galley/API/Action.hs +++ b/services/galley/src/Galley/API/Action.hs @@ -790,7 +790,6 @@ notifyConversationAction _failEarly tag quid notifyOrigDomain con lconv targets <> toFailedToProcess (qualifiedFails failedUpdates) pure (update, totalFailedToProcess) - -- traceM $ "In notifyConversationAction: faileEarly = " <> show failEarly (update, failedToProcess) <- errorTolerant -- notify local participants and bots From 694d8aa35b1eab725025926671e5712aecb4f1b5 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marko=20Dimja=C5=A1evi=C4=87?= Date: Mon, 24 Apr 2023 14:27:20 +0200 Subject: [PATCH 18/36] Fix/align an MLS integration test --- services/galley/test/integration/API/MLS.hs | 24 +++++++++++-------- .../galley/test/integration/API/MLS/Mocks.hs | 7 ++++++ 2 files changed, 21 insertions(+), 10 deletions(-) diff --git a/services/galley/test/integration/API/MLS.hs b/services/galley/test/integration/API/MLS.hs index c65101db1a..4c9da4665f 100644 --- a/services/galley/test/integration/API/MLS.hs +++ b/services/galley/test/integration/API/MLS.hs @@ -1164,12 +1164,11 @@ testAppMessage2 = do testAppMessageSomeReachable :: TestM () testAppMessageSomeReachable = do + let bobDomain = Domain "bob.example.com" + charlieDomain = Domain "charlie.example.com" users@[_alice, bob, charlie] <- - createAndConnectUsers - [ Nothing, - Just "bob.example.com", - Just "charlie.example.com" - ] + createAndConnectUsers $ + domainText <$$> [Nothing, Just bobDomain, Just charlieDomain] void $ runMLSTest $ do [alice1, bob1, charlie1] <- @@ -1178,15 +1177,20 @@ testAppMessageSomeReachable = do void $ setupMLSGroup alice1 commit <- createAddCommit alice1 [bob, charlie] - let mocks = + let commitMocks = receiveCommitMockByDomain [bob1, charlie1] <|> welcomeMock - ([event], _) <- - withTempMockFederator' mocks $ do - sendAndConsumeCommit commit + (([event], ftpCommit), _) <- + withTempMockFederator' commitMocks $ do + sendAndConsumeCommitFederated commit + liftIO $ ftpCommit @?= mempty let unreachables = Set.singleton (Domain "charlie.example.com") - withTempMockFederator' (mlsMockUnreachableFor unreachables) $ do + let sendMocks = + messageSentMockByDomain [bobDomain] + <|> mlsMockUnreachableFor unreachables + + withTempMockFederator' sendMocks $ do message <- createApplicationMessage alice1 "hi, bob!" (_, ftp) <- sendAndConsumeMessage message liftIO $ do diff --git a/services/galley/test/integration/API/MLS/Mocks.hs b/services/galley/test/integration/API/MLS/Mocks.hs index 9ba17fda03..903b830f90 100644 --- a/services/galley/test/integration/API/MLS/Mocks.hs +++ b/services/galley/test/integration/API/MLS/Mocks.hs @@ -19,6 +19,7 @@ module API.MLS.Mocks ( receiveCommitMock, receiveCommitMockByDomain, messageSentMock, + messageSentMockByDomain, welcomeMock, welcomeMockByDomain, sendMessageMock, @@ -63,6 +64,12 @@ receiveCommitMockByDomain clients = do messageSentMock :: Mock LByteString messageSentMock = "on-mls-message-sent" ~> RemoteMLSMessageOk +messageSentMockByDomain :: [Domain] -> Mock LByteString +messageSentMockByDomain reachables = do + domain <- frTargetDomain <$> getRequest + guard (domain `elem` reachables) + messageSentMock + welcomeMock :: Mock LByteString welcomeMock = "mls-welcome" ~> MLSWelcomeSent From f20b5360703c796df74162b7a21bb13d13331615 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marko=20Dimja=C5=A1evi=C4=87?= Date: Mon, 24 Apr 2023 17:00:25 +0200 Subject: [PATCH 19/36] Use a V4 add members endpoint in tests --- services/galley/test/integration/API.hs | 47 +++++++++++-------- .../test/integration/API/Teams/LegalHold.hs | 2 +- services/galley/test/integration/API/Util.hs | 13 +++-- 3 files changed, 38 insertions(+), 24 deletions(-) diff --git a/services/galley/test/integration/API.hs b/services/galley/test/integration/API.hs index 67a53d9b26..79448697e3 100644 --- a/services/galley/test/integration/API.hs +++ b/services/galley/test/integration/API.hs @@ -2654,7 +2654,7 @@ testAddRemoteMember = do convId <- decodeConvId <$> postConv alice [] (Just "remote gossip") [] Nothing Nothing let qconvId = Qualified convId localDomain - postQualifiedMembers alice (remoteBob :| []) convId !!! do + postQualifiedMembers alice (remoteBob :| []) qconvId !!! do const 403 === statusCode const (Right (Just "not-connected")) === fmap (view (at "label")) . responseJsonEither @Object @@ -2662,7 +2662,7 @@ testAddRemoteMember = do (resp, reqs) <- withTempMockFederator' (respond remoteBob) $ - postQualifiedMembers alice (remoteBob :| []) convId + postQualifiedMembers alice (remoteBob :| []) qconvId postTeamConv tid alice [] (Just "remote gossip") [] Nothing Nothing - let _qconvId = Qualified convId localDomain + let qconvId = Qualified convId localDomain connectWithRemoteUser alice remoteBob @@ -2708,7 +2708,7 @@ testDeleteTeamConversationWithRemoteMembers = do ("on-new-remote-conversation" ~> EmptyResponse) <|> ("on-conversation-updated" ~> ()) (_, received) <- withTempMockFederator' mock $ do - postQualifiedMembers alice (remoteBob :| []) convId + postQualifiedMembers alice (remoteBob :| []) qconvId !!! const 200 === statusCode deleteTeamConv tid convId alice @@ -2734,6 +2734,7 @@ testDeleteTeamConversationWithUnavailableRemoteMembers = do remoteBob = Qualified bobId remoteDomain convId <- decodeConvId <$> postTeamConv tid alice [] (Just "remote gossip") [] Nothing Nothing + let qconvId = Qualified convId localDomain connectWithRemoteUser alice remoteBob @@ -2742,13 +2743,18 @@ testDeleteTeamConversationWithUnavailableRemoteMembers = do -- Mock an unavailable federation server for the deletion call <|> (guardRPC "on-conversation-updated" *> throw (MockErrorResponse HTTP.status503 "Down for maintenance.")) <|> (guardRPC "delete-team-conversation" *> throw (MockErrorResponse HTTP.status503 "Down for maintenance.")) - (_, received) <- withTempMockFederator' mock $ do - postQualifiedMembers alice (remoteBob :| []) convId - !!! const 503 === statusCode + (addResp, received) <- withTempMockFederator' mock $ do + addResp <- + responseJsonError @_ @Event + =<< postQualifiedMembers alice (remoteBob :| []) qconvId + show received + putStrLn $ "Add members response = " <> show addResp let convUpdates = mapMaybe (eitherToMaybe . parseFedRequest) received convUpdate <- case filter ((== SomeConversationAction (sing @'ConversationDeleteTag) ()) . cuAction) convUpdates of [] -> assertFailure "No ConversationUpdate requests received" @@ -2964,16 +2970,21 @@ testAddRemoteMemberInvalidDomain = do bobId <- randomId let remoteBob = Qualified bobId (Domain "invalid.example.com") convId <- decodeConvId <$> postConv alice [] (Just "remote gossip") [] Nothing Nothing + localDomain <- viewFederationDomain + let qconvId = Qualified convId localDomain connectWithRemoteUser alice remoteBob - postQualifiedMembers alice (remoteBob :| []) convId - !!! do - const 422 === statusCode - const (Just "/federation/api-version") - === preview (ix "data" . ix "path") . responseJsonUnsafe @Value - const (Just "invalid.example.com") - === preview (ix "data" . ix "domain") . responseJsonUnsafe @Value + r <- + responseJsonError @_ @Event + =<< postQualifiedMembers alice (remoteBob :| []) qconvId + show r -- This test is a safeguard to ensure adding remote members will fail -- on environments where federation isn't configured (such as our production as of May 2021) @@ -2982,14 +2993,13 @@ testAddRemoteMemberFederationDisabled = do alice <- randomUser remoteBob <- flip Qualified (Domain "some-remote-backend.example.com") <$> randomId qconvId <- decodeQualifiedConvId <$> postConv alice [] (Just "remote gossip") [] Nothing Nothing - let convId = qUnqualified qconvId connectWithRemoteUser alice remoteBob -- federator endpoint not configured is equivalent to federation being disabled -- This is the case on staging/production in May 2021. let federatorNotConfigured = optFederator .~ Nothing withSettingsOverrides federatorNotConfigured $ - postQualifiedMembers alice (remoteBob :| []) convId !!! do + postQualifiedMembers alice (remoteBob :| []) qconvId !!! do const 400 === statusCode const (Right "federation-not-enabled") === fmap label . responseJsonEither @@ -3002,7 +3012,6 @@ testAddRemoteMemberFederationUnavailable = do alice <- randomUser remoteBob <- flip Qualified (Domain "some-remote-backend.example.com") <$> randomId qconvId <- decodeQualifiedConvId <$> postConv alice [] (Just "remote gossip") [] Nothing Nothing - let convId = qUnqualified qconvId connectWithRemoteUser alice remoteBob -- federator endpoint being configured in brig and/or galley, but not being @@ -3011,7 +3020,7 @@ testAddRemoteMemberFederationUnavailable = do -- Port 1 should always be wrong hopefully. let federatorUnavailable = optFederator ?~ Endpoint "127.0.0.1" 1 withSettingsOverrides federatorUnavailable $ - postQualifiedMembers alice (remoteBob :| []) convId !!! do + postQualifiedMembers alice (remoteBob :| []) qconvId !!! do const 500 === statusCode const (Right "federation-not-available") === fmap label . responseJsonEither diff --git a/services/galley/test/integration/API/Teams/LegalHold.hs b/services/galley/test/integration/API/Teams/LegalHold.hs index 1f568245f3..7936d6b5cf 100644 --- a/services/galley/test/integration/API/Teams/LegalHold.hs +++ b/services/galley/test/integration/API/Teams/LegalHold.hs @@ -1074,7 +1074,7 @@ testNoConsentCannotBeInvited = do >>= errWith 403 (\err -> Error.label err == "missing-legalhold-consent") localdomain <- viewFederationDomain - API.Util.postQualifiedMembers userLHNotActivated (Qualified peer2 localdomain :| []) convId + API.Util.postQualifiedMembers userLHNotActivated (Qualified peer2 localdomain :| []) qconvId >>= errWith 403 (\err -> Error.label err == "missing-legalhold-consent") testCannotCreateGroupWithUsersInConflict :: HasCallStack => TestM () diff --git a/services/galley/test/integration/API/Util.hs b/services/galley/test/integration/API/Util.hs index 02a6ee5eac..feb2c5d958 100644 --- a/services/galley/test/integration/API/Util.hs +++ b/services/galley/test/integration/API/Util.hs @@ -1141,17 +1141,22 @@ listRemoteConvs remoteDomain uid = do pure $ filter (\qcnv -> qDomain qcnv == remoteDomain) allConvs postQualifiedMembers :: - (MonadReader TestSetup m, MonadHttp m) => + (MonadReader TestSetup m, MonadHttp m, HasGalley m) => UserId -> NonEmpty (Qualified UserId) -> - ConvId -> + Qualified ConvId -> m ResponseLBS postQualifiedMembers zusr invitees conv = do - g <- view tsUnversionedGalley + g <- viewGalley let invite = InviteQualified invitees roleNameWireAdmin post $ g - . paths ["v1", "conversations", toByteString' conv, "members", "v2"] + . paths + [ "conversations", + toByteString' . qDomain $ conv, + toByteString' . qUnqualified $ conv, + "members" + ] . zUser zusr . zConn "conn" . zType "access" From a42246dbbedf0d3a4f3eb0a378ebbd7bd1450893 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marko=20Dimja=C5=A1evi=C4=87?= Date: Wed, 26 Apr 2023 11:14:59 +0200 Subject: [PATCH 20/36] Rethrow the invalid-domain exception --- services/galley/src/Galley/API/Action.hs | 23 +++++++-- services/galley/src/Galley/API/Federation.hs | 49 ++++++++++++------- services/galley/src/Galley/API/LegalHold.hs | 10 ++++ .../galley/src/Galley/API/Teams/Features.hs | 2 + services/galley/src/Galley/API/Update.hs | 10 ++++ services/galley/test/integration/API.hs | 17 +++---- 6 files changed, 78 insertions(+), 33 deletions(-) diff --git a/services/galley/src/Galley/API/Action.hs b/services/galley/src/Galley/API/Action.hs index c49404fb03..162be61774 100644 --- a/services/galley/src/Galley/API/Action.hs +++ b/services/galley/src/Galley/API/Action.hs @@ -78,6 +78,8 @@ import Galley.Types.Conversations.Members import Galley.Types.UserList import Galley.Validation import Imports +import qualified Network.HTTP.Types.Status as Wai +import qualified Network.Wai.Utilities.Error as Wai import Polysemy import Polysemy.Error import Polysemy.Input @@ -291,7 +293,8 @@ ensureAllowed tag loc action conv origUser = do -- and also returns the (possible modified) action that was performed performAction :: forall tag r. - ( HasConversationActionEffects tag r + ( HasConversationActionEffects tag r, + Member (Error FederationError) r ) => Sing tag -> Qualified UserId -> @@ -422,7 +425,8 @@ performConversationJoin qusr lconv (ConversationJoin invited role) = do ensureConnectedToRemotes lusr remotes checkLHPolicyConflictsLocal :: - ( Member (Error InternalError) r, + ( Member (Error FederationError) r, + Member (Error InternalError) r, Member (ErrorS 'MissingLegalholdConsent) r, Member ExternalAccess r, Member FederatorAccess r, @@ -477,7 +481,8 @@ performConversationJoin qusr lconv (ConversationJoin invited role) = do checkLHPolicyConflictsRemote _remotes = pure () performConversationAccessData :: - ( HasConversationActionEffects 'ConversationAccessDataTag r + ( HasConversationActionEffects 'ConversationAccessDataTag r, + Member (Error FederationError) r ) => Qualified UserId -> Local Conversation -> @@ -564,6 +569,7 @@ data LocalConversationUpdate = LocalConversationUpdate updateLocalConversation :: forall tag r. ( Member ConversationStore r, + Member (Error FederationError) r, Member (ErrorS ('ActionDenied (ConversationActionPermission tag))) r, Member (ErrorS 'InvalidOperation) r, Member (ErrorS 'ConvNotFound) r, @@ -603,6 +609,7 @@ updateLocalConversation lcnv qusr con action = do updateLocalConversationUnchecked :: forall tag r. ( SingI tag, + Member (Error FederationError) r, Member (ErrorS ('ActionDenied (ConversationActionPermission tag))) r, Member (ErrorS 'ConvNotFound) r, Member (ErrorS 'InvalidOperation) r, @@ -692,7 +699,8 @@ addMembersToLocalConversation lcnv users role = do notifyConversationAction :: forall tag r. - ( Member FederatorAccess r, + ( Member (Error FederationError) r, + Member FederatorAccess r, Member ExternalAccess r, Member GundeckAccess r, Member (Input UTCTime) r, @@ -758,6 +766,10 @@ notifyConversationAction _failEarly tag quid notifyOrigDomain con lconv targets -- For now these users will not be able to join the conversation until -- queueing and retrying is implemented. let failedNotifies = lefts notifyEithers + for_ failedNotifies $ \case + -- rethrow invalid-domain errors + (_, ex@(FederationCallFailure (FederatorClientError (Wai.Error (Wai.Status 422 _) _ _ _)))) -> throw ex + _ -> pure () for_ failedNotifies $ logError "on-new-remote-conversation" @@ -856,7 +868,8 @@ notifyRemoteConversationAction loc rconvUpdate con = do -- leave, but then sends notifications as if the user was removed by someone -- else. kickMember :: - ( Member (Error InternalError) r, + ( Member (Error FederationError) r, + Member (Error InternalError) r, Member ExternalAccess r, Member FederatorAccess r, Member GundeckAccess r, diff --git a/services/galley/src/Galley/API/Federation.hs b/services/galley/src/Galley/API/Federation.hs index 862d4d0bf9..9409950a40 100644 --- a/services/galley/src/Galley/API/Federation.hs +++ b/services/galley/src/Galley/API/Federation.hs @@ -353,6 +353,10 @@ leaveConversation requestingDomain lc = do . mapToRuntimeError @('ActionDenied 'LeaveConversation) F.RemoveFromConversationErrorRemovalNotAllowed . mapToRuntimeError @'InvalidOperation F.RemoveFromConversationErrorRemovalNotAllowed . mapError @NoChanges (const F.RemoveFromConversationErrorUnchanged) + -- As of Apr 25, 2023, a remote member cannot be a conversation admin so + -- the case where the local backend tries to resolve an invalid remote + -- domain is impossible and an internal error is thrown. + . mapError @FederationError (const BadMemberState) $ do (conv, _self) <- getConversationAndMemberWithError @'ConvNotFound leaver lcnv update <- @@ -371,15 +375,19 @@ leaveConversation requestingDomain lc = do let remotes = filter ((== qDomain leaver) . tDomain) (rmId <$> Data.convRemoteMembers conv) let botsAndMembers = BotsAndMembers mempty (Set.fromList remotes) mempty (_, notifyFailedToProcess) <- - notifyConversationAction - False - SConversationLeaveTag - leaver - False - Nothing - (qualifyAs lcnv conv) - botsAndMembers - () + -- As of Apr 25, 2023, a remote member cannot be a conversation admin so + -- the case where the local backend tries to resolve an invalid remote + -- domain is impossible and an internal error is thrown. + mapError @FederationError (const BadMemberState) $ + notifyConversationAction + False + SConversationLeaveTag + leaver + False + Nothing + (qualifyAs lcnv conv) + botsAndMembers + () pure . F.LeaveConversationResponse . Right $ updateFailedToProcess <> notifyFailedToProcess @@ -461,6 +469,7 @@ sendMessage originDomain msr = do onUserDeleted :: ( Member ConversationStore r, + Member (Error InternalError) r, Member FederatorAccess r, Member FireAndForget r, Member ExternalAccess r, @@ -500,15 +509,19 @@ onUserDeleted origDomain udcn = do let botsAndMembers = convBotsAndMembers conv removeUser (qualifyAs lc conv) (tUntagged deletedUser) void $ - notifyConversationAction - False - (sing @'ConversationLeaveTag) - untaggedDeletedUser - False - Nothing - (qualifyAs lc conv) - botsAndMembers - () + -- As of Apr 25, 2023, a remote member cannot be a conversation admin so + -- the case where the local backend tries to resolve an invalid remote + -- domain is impossible and an internal error is thrown. + mapError @FederationError (const BadMemberState) $ + notifyConversationAction + False + (sing @'ConversationLeaveTag) + untaggedDeletedUser + False + Nothing + (qualifyAs lc conv) + botsAndMembers + () pure EmptyResponse updateConversation :: diff --git a/services/galley/src/Galley/API/LegalHold.hs b/services/galley/src/Galley/API/LegalHold.hs index df76873206..78a319801d 100644 --- a/services/galley/src/Galley/API/LegalHold.hs +++ b/services/galley/src/Galley/API/LegalHold.hs @@ -72,6 +72,7 @@ import Wire.API.Conversation (ConvType (..)) import Wire.API.Conversation.Role import Wire.API.Error import Wire.API.Error.Galley +import Wire.API.Federation.Error import Wire.API.Provider.Service import Wire.API.Routes.Internal.Brig.Connection import Wire.API.Routes.Public.Galley.LegalHold @@ -184,6 +185,7 @@ removeSettingsInternalPaging :: Member CodeStore r, Member ConversationStore r, Member (Error AuthenticationError) r, + Member (Error FederationError) r, Member (Error InternalError) r, Member (ErrorS ('ActionDenied 'RemoveConversationMember)) r, Member (ErrorS 'InvalidOperation) r, @@ -226,6 +228,7 @@ removeSettings :: Member CodeStore r, Member ConversationStore r, Member (Error AuthenticationError) r, + Member (Error FederationError) r, Member (Error InternalError) r, Member (ErrorS ('ActionDenied 'RemoveConversationMember)) r, Member (ErrorS 'InvalidOperation) r, @@ -287,6 +290,7 @@ removeSettings' :: Member BrigAccess r, Member CodeStore r, Member ConversationStore r, + Member (Error FederationError) r, Member (Error InternalError) r, Member (Error AuthenticationError) r, Member (ErrorS 'NotATeamMember) r, @@ -376,6 +380,7 @@ getUserStatus _lzusr tid uid = do grantConsent :: ( Member BrigAccess r, Member ConversationStore r, + Member (Error FederationError) r, Member (Error InternalError) r, Member (ErrorS ('ActionDenied 'RemoveConversationMember)) r, Member (ErrorS 'LegalHoldCouldNotBlockConnections) r, @@ -412,6 +417,7 @@ requestDevice :: forall db r. ( Member BrigAccess r, Member ConversationStore r, + Member (Error FederationError) r, Member (Error InternalError) r, Member (ErrorS ('ActionDenied 'RemoveConversationMember)) r, Member (ErrorS 'LegalHoldCouldNotBlockConnections) r, @@ -491,6 +497,7 @@ approveDevice :: ( Member BrigAccess r, Member ConversationStore r, Member (Error AuthenticationError) r, + Member (Error FederationError) r, Member (Error InternalError) r, Member (ErrorS 'AccessDenied) r, Member (ErrorS ('ActionDenied 'RemoveConversationMember)) r, @@ -569,6 +576,7 @@ disableForUser :: ( Member BrigAccess r, Member ConversationStore r, Member (Error AuthenticationError) r, + Member (Error FederationError) r, Member (Error InternalError) r, Member (ErrorS ('ActionDenied 'RemoveConversationMember)) r, Member (ErrorS 'LegalHoldCouldNotBlockConnections) r, @@ -624,6 +632,7 @@ disableForUser lzusr tid uid (Public.DisableLegalHoldForUserRequest mPassword) = changeLegalholdStatus :: ( Member BrigAccess r, Member ConversationStore r, + Member (Error FederationError) r, Member (Error InternalError) r, Member (ErrorS ('ActionDenied 'RemoveConversationMember)) r, Member (ErrorS 'LegalHoldCouldNotBlockConnections) r, @@ -739,6 +748,7 @@ unsetTeamLegalholdWhitelistedH tid = do -- one from the database. handleGroupConvPolicyConflicts :: ( Member ConversationStore r, + Member (Error FederationError) r, Member (Error InternalError) r, Member (ErrorS ('ActionDenied 'RemoveConversationMember)) r, Member ExternalAccess r, diff --git a/services/galley/src/Galley/API/Teams/Features.hs b/services/galley/src/Galley/API/Teams/Features.hs index b5172a853f..85d87da660 100644 --- a/services/galley/src/Galley/API/Teams/Features.hs +++ b/services/galley/src/Galley/API/Teams/Features.hs @@ -76,6 +76,7 @@ import Wire.API.Conversation.Role (Action (RemoveConversationMember)) import Wire.API.Error (ErrorS, throwS) import Wire.API.Error.Galley import qualified Wire.API.Event.FeatureConfig as Event +import Wire.API.Federation.Error import qualified Wire.API.Routes.Internal.Galley.TeamFeatureNoConfigMulti as Multi import Wire.API.Team.Feature import Wire.API.Team.Member @@ -697,6 +698,7 @@ instance SetFeatureConfig db LegalholdConfig where Member CodeStore r, Member ConversationStore r, Member (Error AuthenticationError) r, + Member (Error FederationError) r, Member (Error InternalError) r, Member (ErrorS ('ActionDenied 'RemoveConversationMember)) r, Member (ErrorS 'CannotEnableLegalHoldServiceLargeTeam) r, diff --git a/services/galley/src/Galley/API/Update.hs b/services/galley/src/Galley/API/Update.hs index 1f59493b3e..145909e8f2 100644 --- a/services/galley/src/Galley/API/Update.hs +++ b/services/galley/src/Galley/API/Update.hs @@ -675,6 +675,7 @@ joinConversationByReusableCode :: ( Member BrigAccess r, Member CodeStore r, Member ConversationStore r, + Member (Error FederationError) r, Member (ErrorS 'CodeNotFound) r, Member (ErrorS 'InvalidConversationPassword) r, Member (ErrorS 'ConvAccessDenied) r, @@ -709,6 +710,7 @@ joinConversationById :: ( Member BrigAccess r, Member FederatorAccess r, Member ConversationStore r, + Member (Error FederationError) r, Member (ErrorS 'ConvAccessDenied) r, Member (ErrorS 'ConvNotFound) r, Member (ErrorS 'InvalidOperation) r, @@ -734,6 +736,7 @@ joinConversation :: forall r. ( Member BrigAccess r, Member FederatorAccess r, + Member (Error FederationError) r, Member (ErrorS 'ConvAccessDenied) r, Member (ErrorS 'InvalidOperation) r, Member (ErrorS 'NotATeamMember) r, @@ -950,6 +953,7 @@ updateUnqualifiedSelfMember lusr zcon cnv update = do updateOtherMemberLocalConv :: ( Member ConversationStore r, + Member (Error FederationError) r, Member (ErrorS ('ActionDenied 'ModifyOtherConversationMember)) r, Member (ErrorS 'InvalidTarget) r, Member (ErrorS 'InvalidOperation) r, @@ -976,6 +980,7 @@ updateOtherMemberLocalConv lcnv lusr con qvictim update = void . getUpdateResult updateOtherMemberUnqualified :: ( Member ConversationStore r, + Member (Error FederationError) r, Member (ErrorS ('ActionDenied 'ModifyOtherConversationMember)) r, Member (ErrorS 'InvalidTarget) r, Member (ErrorS 'InvalidOperation) r, @@ -1036,6 +1041,7 @@ updateOtherMemberRemoteConv _ _ _ _ _ = throw FederationNotImplemented removeMemberUnqualified :: ( Member ConversationStore r, + Member (Error FederationError) r, Member (Error InternalError) r, Member (ErrorS ('ActionDenied 'RemoveConversationMember)) r, Member (ErrorS 'ConvNotFound) r, @@ -1061,6 +1067,7 @@ removeMemberUnqualified lusr con cnv victim = do removeMemberQualified :: ( Member ConversationStore r, + Member (Error FederationError) r, Member (Error InternalError) r, Member (ErrorS ('ActionDenied 'RemoveConversationMember)) r, Member (ErrorS 'ConvNotFound) r, @@ -1127,6 +1134,7 @@ removeMemberFromRemoteConv cnv lusr victim -- | Remove a member from a local conversation. removeMemberFromLocalConv :: ( Member ConversationStore r, + Member (Error FederationError) r, Member (Error InternalError) r, Member (ErrorS ('ActionDenied 'LeaveConversation)) r, Member (ErrorS ('ActionDenied 'RemoveConversationMember)) r, @@ -1339,6 +1347,7 @@ updateConversationName lusr zcon qcnv convRename = do updateUnqualifiedConversationName :: ( Member ConversationStore r, + Member (Error FederationError) r, Member (Error InvalidInput) r, Member (ErrorS ('ActionDenied 'ModifyConversationName)) r, Member (ErrorS 'ConvNotFound) r, @@ -1360,6 +1369,7 @@ updateUnqualifiedConversationName lusr zcon cnv rename = do updateLocalConversationName :: ( Member ConversationStore r, + Member (Error FederationError) r, Member (Error InvalidInput) r, Member (ErrorS ('ActionDenied 'ModifyConversationName)) r, Member (ErrorS 'ConvNotFound) r, diff --git a/services/galley/test/integration/API.hs b/services/galley/test/integration/API.hs index 79448697e3..22a82be7b5 100644 --- a/services/galley/test/integration/API.hs +++ b/services/galley/test/integration/API.hs @@ -2975,16 +2975,13 @@ testAddRemoteMemberInvalidDomain = do connectWithRemoteUser alice remoteBob - r <- - responseJsonError @_ @Event - =<< postQualifiedMembers alice (remoteBob :| []) qconvId - show r + postQualifiedMembers alice (remoteBob :| []) qconvId + !!! do + const 422 === statusCode + const (Just "/federation/api-version") + === preview (ix "data" . ix "path") . responseJsonUnsafe @Value + const (Just "invalid.example.com") + === preview (ix "data" . ix "domain") . responseJsonUnsafe @Value -- This test is a safeguard to ensure adding remote members will fail -- on environments where federation isn't configured (such as our production as of May 2021) From 9bcf4330d05525dc0ac03780ba9f9dc73e060b73 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marko=20Dimja=C5=A1evi=C4=87?= Date: Wed, 26 Apr 2023 13:49:06 +0200 Subject: [PATCH 21/36] Rethrow federation-not-available error --- services/galley/src/Galley/API/Action.hs | 3 ++- services/galley/src/Galley/API/Federation.hs | 27 +++++++++++--------- 2 files changed, 17 insertions(+), 13 deletions(-) diff --git a/services/galley/src/Galley/API/Action.hs b/services/galley/src/Galley/API/Action.hs index 162be61774..6a6e9bf9e4 100644 --- a/services/galley/src/Galley/API/Action.hs +++ b/services/galley/src/Galley/API/Action.hs @@ -767,8 +767,9 @@ notifyConversationAction _failEarly tag quid notifyOrigDomain con lconv targets -- queueing and retrying is implemented. let failedNotifies = lefts notifyEithers for_ failedNotifies $ \case - -- rethrow invalid-domain errors + -- rethrow invalid-domain errors and mis-configured federation errors (_, ex@(FederationCallFailure (FederatorClientError (Wai.Error (Wai.Status 422 _) _ _ _)))) -> throw ex + (_, ex@(FederationCallFailure (FederatorClientHTTP2Error (FederatorClientConnectionError _)))) -> throw ex _ -> pure () for_ failedNotifies $ logError diff --git a/services/galley/src/Galley/API/Federation.hs b/services/galley/src/Galley/API/Federation.hs index 9409950a40..d6a9268969 100644 --- a/services/galley/src/Galley/API/Federation.hs +++ b/services/galley/src/Galley/API/Federation.hs @@ -353,10 +353,7 @@ leaveConversation requestingDomain lc = do . mapToRuntimeError @('ActionDenied 'LeaveConversation) F.RemoveFromConversationErrorRemovalNotAllowed . mapToRuntimeError @'InvalidOperation F.RemoveFromConversationErrorRemovalNotAllowed . mapError @NoChanges (const F.RemoveFromConversationErrorUnchanged) - -- As of Apr 25, 2023, a remote member cannot be a conversation admin so - -- the case where the local backend tries to resolve an invalid remote - -- domain is impossible and an internal error is thrown. - . mapError @FederationError (const BadMemberState) + . mapError mapFederationError $ do (conv, _self) <- getConversationAndMemberWithError @'ConvNotFound leaver lcnv update <- @@ -375,10 +372,7 @@ leaveConversation requestingDomain lc = do let remotes = filter ((== qDomain leaver) . tDomain) (rmId <$> Data.convRemoteMembers conv) let botsAndMembers = BotsAndMembers mempty (Set.fromList remotes) mempty (_, notifyFailedToProcess) <- - -- As of Apr 25, 2023, a remote member cannot be a conversation admin so - -- the case where the local backend tries to resolve an invalid remote - -- domain is impossible and an internal error is thrown. - mapError @FederationError (const BadMemberState) $ + mapError mapFederationError $ notifyConversationAction False SConversationLeaveTag @@ -509,10 +503,7 @@ onUserDeleted origDomain udcn = do let botsAndMembers = convBotsAndMembers conv removeUser (qualifyAs lc conv) (tUntagged deletedUser) void $ - -- As of Apr 25, 2023, a remote member cannot be a conversation admin so - -- the case where the local backend tries to resolve an invalid remote - -- domain is impossible and an internal error is thrown. - mapError @FederationError (const BadMemberState) $ + mapError mapFederationError $ notifyConversationAction False (sing @'ConversationLeaveTag) @@ -844,3 +835,15 @@ onTypingIndicatorUpdated origDomain TypingDataUpdated {..} = do let qcnv = Qualified tudConvId origDomain pushTypingIndicatorEvents tudOrigUserId tudTime tudUsersInConv Nothing qcnv tudTypingStatus pure EmptyResponse + +-------------------------------------------------------------------------------- +-- Utilities +-------------------------------------------------------------------------------- + +-- | Map a subset of federation errors to internal errors as these errors are +-- impossible and do not ever occur. Note this is not a general function to be +-- used in places other than in this module. +mapFederationError :: FederationError -> InternalError +mapFederationError (FederationCallFailure e) = + InternalErrorWithDescription . LT.pack . displayException $ e +mapFederationError e = InternalErrorWithDescription . LT.pack . show $ e From d51f660b505d62454c87ded2120fd6334c28e4a1 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marko=20Dimja=C5=A1evi=C4=87?= Date: Wed, 26 Apr 2023 14:02:44 +0200 Subject: [PATCH 22/36] Fix a golden test for LeaveConversationResponse --- .../test/golden/testObject_LeaveConversationResponse1.json | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/libs/wire-api-federation/test/golden/testObject_LeaveConversationResponse1.json b/libs/wire-api-federation/test/golden/testObject_LeaveConversationResponse1.json index 5ce20f1d24..31e2f71f18 100644 --- a/libs/wire-api-federation/test/golden/testObject_LeaveConversationResponse1.json +++ b/libs/wire-api-federation/test/golden/testObject_LeaveConversationResponse1.json @@ -1,3 +1,3 @@ { - "Right": [] + "Right": {} } \ No newline at end of file From f0b3fe50900f3759c808fbead9a8634ecbcafc9b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marko=20Dimja=C5=A1evi=C4=87?= Date: Wed, 26 Apr 2023 14:04:50 +0200 Subject: [PATCH 23/36] Golden tests for MLSMessageSendingStatus --- .../Wire/API/Federation/Golden/GoldenSpec.hs | 5 +++- .../Golden/MLSMessageSendingStatus.hs | 24 +++++++++++++++++++ .../testObject_MLSMessageSendingStatus4.json | 10 ++++++++ .../testObject_MLSMessageSendingStatus5.json | 14 +++++++++++ .../testObject_MLSMessageSendingStatus6.json | 20 ++++++++++++++++ 5 files changed, 72 insertions(+), 1 deletion(-) create mode 100644 libs/wire-api-federation/test/golden/testObject_MLSMessageSendingStatus4.json create mode 100644 libs/wire-api-federation/test/golden/testObject_MLSMessageSendingStatus5.json create mode 100644 libs/wire-api-federation/test/golden/testObject_MLSMessageSendingStatus6.json diff --git a/libs/wire-api-federation/test/Test/Wire/API/Federation/Golden/GoldenSpec.hs b/libs/wire-api-federation/test/Test/Wire/API/Federation/Golden/GoldenSpec.hs index 5bc03b0398..0acf15af8b 100644 --- a/libs/wire-api-federation/test/Test/Wire/API/Federation/Golden/GoldenSpec.hs +++ b/libs/wire-api-federation/test/Test/Wire/API/Federation/Golden/GoldenSpec.hs @@ -42,7 +42,10 @@ spec = testObjects [ (MLSMessageSendingStatus.testObject_MLSMessageSendingStatus1, "testObject_MLSMessageSendingStatus1.json"), (MLSMessageSendingStatus.testObject_MLSMessageSendingStatus2, "testObject_MLSMessageSendingStatus2.json"), - (MLSMessageSendingStatus.testObject_MLSMessageSendingStatus3, "testObject_MLSMessageSendingStatus3.json") + (MLSMessageSendingStatus.testObject_MLSMessageSendingStatus3, "testObject_MLSMessageSendingStatus3.json"), + (MLSMessageSendingStatus.testObject_MLSMessageSendingStatus4, "testObject_MLSMessageSendingStatus4.json"), + (MLSMessageSendingStatus.testObject_MLSMessageSendingStatus5, "testObject_MLSMessageSendingStatus5.json"), + (MLSMessageSendingStatus.testObject_MLSMessageSendingStatus6, "testObject_MLSMessageSendingStatus6.json") ] testObjects [(LeaveConversationRequest.testObject_LeaveConversationRequest1, "testObject_LeaveConversationRequest1.json")] testObjects diff --git a/libs/wire-api-federation/test/Test/Wire/API/Federation/Golden/MLSMessageSendingStatus.hs b/libs/wire-api-federation/test/Test/Wire/API/Federation/Golden/MLSMessageSendingStatus.hs index ee1cf1a2c6..5dbb6a6375 100644 --- a/libs/wire-api-federation/test/Test/Wire/API/Federation/Golden/MLSMessageSendingStatus.hs +++ b/libs/wire-api-federation/test/Test/Wire/API/Federation/Golden/MLSMessageSendingStatus.hs @@ -49,6 +49,30 @@ testObject_MLSMessageSendingStatus3 = mmssFailedToProcess = failedToSend failed2 } +testObject_MLSMessageSendingStatus4 :: MLSMessageSendingStatus +testObject_MLSMessageSendingStatus4 = + MLSMessageSendingStatus + { mmssEvents = [], + mmssTime = toUTCTimeMillis (read "2023-04-12 12:22:43.673 UTC"), + mmssFailedToProcess = failedToAdd failed1 + } + +testObject_MLSMessageSendingStatus5 :: MLSMessageSendingStatus +testObject_MLSMessageSendingStatus5 = + MLSMessageSendingStatus + { mmssEvents = [], + mmssTime = toUTCTimeMillis (read "1901-04-12 12:22:43.673 UTC"), + mmssFailedToProcess = failedToRemove failed2 + } + +testObject_MLSMessageSendingStatus6 :: MLSMessageSendingStatus +testObject_MLSMessageSendingStatus6 = + MLSMessageSendingStatus + { mmssEvents = [], + mmssTime = toUTCTimeMillis (read "1905-04-12 12:22:43.673 UTC"), + mmssFailedToProcess = failedToAdd failed1 <> failedToRemove failed2 + } + failed1 :: [Qualified UserId] failed1 = let domain = Domain "offline.example.com" diff --git a/libs/wire-api-federation/test/golden/testObject_MLSMessageSendingStatus4.json b/libs/wire-api-federation/test/golden/testObject_MLSMessageSendingStatus4.json new file mode 100644 index 0000000000..50831a654f --- /dev/null +++ b/libs/wire-api-federation/test/golden/testObject_MLSMessageSendingStatus4.json @@ -0,0 +1,10 @@ +{ + "events": [], + "failed_to_add": [ + { + "domain": "offline.example.com", + "id": "00000000-0000-0000-0000-000200000008" + } + ], + "time": "2023-04-12T12:22:43.673Z" +} \ No newline at end of file diff --git a/libs/wire-api-federation/test/golden/testObject_MLSMessageSendingStatus5.json b/libs/wire-api-federation/test/golden/testObject_MLSMessageSendingStatus5.json new file mode 100644 index 0000000000..a3a97ffbec --- /dev/null +++ b/libs/wire-api-federation/test/golden/testObject_MLSMessageSendingStatus5.json @@ -0,0 +1,14 @@ +{ + "events": [], + "failed_to_remove": [ + { + "domain": "golden.example.com", + "id": "00000000-0000-0000-0000-000200000008" + }, + { + "domain": "golden.example.com", + "id": "00000000-0000-0000-0000-000100000007" + } + ], + "time": "1901-04-12T12:22:43.673Z" +} \ No newline at end of file diff --git a/libs/wire-api-federation/test/golden/testObject_MLSMessageSendingStatus6.json b/libs/wire-api-federation/test/golden/testObject_MLSMessageSendingStatus6.json new file mode 100644 index 0000000000..53ebbd357b --- /dev/null +++ b/libs/wire-api-federation/test/golden/testObject_MLSMessageSendingStatus6.json @@ -0,0 +1,20 @@ +{ + "events": [], + "failed_to_add": [ + { + "domain": "offline.example.com", + "id": "00000000-0000-0000-0000-000200000008" + } + ], + "failed_to_remove": [ + { + "domain": "golden.example.com", + "id": "00000000-0000-0000-0000-000200000008" + }, + { + "domain": "golden.example.com", + "id": "00000000-0000-0000-0000-000100000007" + } + ], + "time": "1905-04-12T12:22:43.673Z" +} \ No newline at end of file From 9fbff8aa61e31e64e4814325572068c371c871a7 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marko=20Dimja=C5=A1evi=C4=87?= Date: Thu, 27 Apr 2023 11:54:14 +0200 Subject: [PATCH 24/36] Fix a test with an unreachable user --- services/galley/src/Galley/API/MLS/Message.hs | 7 +++- services/galley/test/integration/API/MLS.hs | 32 +++++++++++-------- 2 files changed, 24 insertions(+), 15 deletions(-) diff --git a/services/galley/src/Galley/API/MLS/Message.hs b/services/galley/src/Galley/API/MLS/Message.hs index 783331d8ad..8f6e071966 100644 --- a/services/galley/src/Galley/API/MLS/Message.hs +++ b/services/galley/src/Galley/API/MLS/Message.hs @@ -1177,7 +1177,12 @@ executeProposalAction qusr con lconv mlsMeta cm action = do membersToRemove <- catMaybes <$> for removedUsers (uncurry checkRemoval) -- add users to the conversation and send events - addEvents <- foldMap addMembers . nonEmpty . map fst $ newUserClients + addEvents <- + foldMap addMembers + . nonEmpty + . filter (\u -> u `notElem` failedAddFetching) + . fmap fst + $ newUserClients let failedAdding = Set.toList $ Set.fromList (fst <$> newUserClients) diff --git a/services/galley/test/integration/API/MLS.hs b/services/galley/test/integration/API/MLS.hs index 4c9da4665f..caa7423d1b 100644 --- a/services/galley/test/integration/API/MLS.hs +++ b/services/galley/test/integration/API/MLS.hs @@ -688,9 +688,16 @@ testAddRemotesSomeUnreachable = do $ sendAndConsumeCommitFederated commit pure (events, failedToProcess, reqs, qcnv) + let expectedJoiners = [bob] liftIO $ do - req <- assertOne $ filter (\r -> ((== "on-conversation-updated") . frRPC) r && frTargetDomain r == bobDomain) reqs - void $ assertOne $ filter (\r -> ((== "on-conversation-updated") . frRPC) r && frTargetDomain r == charlieDomain) reqs + req <- + assertOne $ + filter + ( \r -> + ((== "on-conversation-updated") . frRPC) r + && frTargetDomain r == bobDomain + ) + reqs frTargetDomain req @?= qDomain bob bdy <- case Aeson.eitherDecode (frBody req) of Right b -> pure b @@ -698,23 +705,20 @@ testAddRemotesSomeUnreachable = do cuOrigUserId bdy @?= alice cuConvId bdy @?= qUnqualified qcnv cuAlreadyPresentUsers bdy @?= [qUnqualified bob] - let expectedJoiners = sort [bob, charlie] - SomeConversationAction SConversationJoinTag cj = cuAction bdy + failedToProcess + @?= FailedToProcess + { send = Nothing, + add = Just (UnreachableUsers (pure charlie)), + remove = Nothing + } + let SomeConversationAction SConversationJoinTag cj = cuAction bdy ConversationJoin actualJoiners actualRole = cj - (sort . NE.toList) actualJoiners @?= expectedJoiners -- TODO(md): only Bob should be listed as the joiner + (sort . NE.toList) actualJoiners @?= expectedJoiners actualRole @?= roleNameWireMember liftIO $ do event <- assertOne events - assertJoinEvent qcnv alice [bob, charlie] roleNameWireMember event -- TODO(md): - -- only - -- Bob - -- should - -- be - -- listed - -- as the - -- joiner - liftIO $ putStrLn $ "Failed to process = " <> show failedToProcess + assertJoinEvent qcnv alice expectedJoiners roleNameWireMember event testCommitLock :: TestM () testCommitLock = do From 0a99e47d09fd32444b817620137ae2d1ac169f80 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marko=20Dimja=C5=A1evi=C4=87?= Date: Thu, 27 Apr 2023 11:54:34 +0200 Subject: [PATCH 25/36] Test: clean up debugging leftovers --- services/galley/test/integration/API.hs | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/services/galley/test/integration/API.hs b/services/galley/test/integration/API.hs index 22a82be7b5..5c94b4afa2 100644 --- a/services/galley/test/integration/API.hs +++ b/services/galley/test/integration/API.hs @@ -2743,7 +2743,7 @@ testDeleteTeamConversationWithUnavailableRemoteMembers = do -- Mock an unavailable federation server for the deletion call <|> (guardRPC "on-conversation-updated" *> throw (MockErrorResponse HTTP.status503 "Down for maintenance.")) <|> (guardRPC "delete-team-conversation" *> throw (MockErrorResponse HTTP.status503 "Down for maintenance.")) - (addResp, received) <- withTempMockFederator' mock $ do + (_, received) <- withTempMockFederator' mock $ do addResp <- responseJsonError @_ @Event =<< postQualifiedMembers alice (remoteBob :| []) qconvId @@ -2753,8 +2753,6 @@ testDeleteTeamConversationWithUnavailableRemoteMembers = do !!! const 200 === statusCode pure addResp liftIO $ do - -- putStrLn $ "Received = " <> show received - putStrLn $ "Add members response = " <> show addResp let convUpdates = mapMaybe (eitherToMaybe . parseFedRequest) received convUpdate <- case filter ((== SomeConversationAction (sing @'ConversationDeleteTag) ()) . cuAction) convUpdates of [] -> assertFailure "No ConversationUpdate requests received" From fa0be89fa64a9e1587279f564b2551f970d05df8 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marko=20Dimja=C5=A1evi=C4=87?= Date: Thu, 27 Apr 2023 13:37:10 +0200 Subject: [PATCH 26/36] fixup! Test: clean up debugging leftovers --- services/galley/test/integration/API.hs | 7 ++----- services/galley/test/integration/API/MLS.hs | 8 +++----- 2 files changed, 5 insertions(+), 10 deletions(-) diff --git a/services/galley/test/integration/API.hs b/services/galley/test/integration/API.hs index 5c94b4afa2..62275b1d1f 100644 --- a/services/galley/test/integration/API.hs +++ b/services/galley/test/integration/API.hs @@ -2744,14 +2744,11 @@ testDeleteTeamConversationWithUnavailableRemoteMembers = do <|> (guardRPC "on-conversation-updated" *> throw (MockErrorResponse HTTP.status503 "Down for maintenance.")) <|> (guardRPC "delete-team-conversation" *> throw (MockErrorResponse HTTP.status503 "Down for maintenance.")) (_, received) <- withTempMockFederator' mock $ do - addResp <- - responseJsonError @_ @Event - =<< postQualifiedMembers alice (remoteBob :| []) qconvId - [Nothing, Just bobDomain, Just charlieDomain] (events, failedToProcess, reqs, qcnv) <- runMLSTest $ do [alice1, bob1, _charlie1] <- traverse createMLSClient users (_, qcnv) <- setupMLSGroup alice1 From 6ed1368ae717fe3f41b783cc827e01b28210bc5e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marko=20Dimja=C5=A1evi=C4=87?= Date: Thu, 27 Apr 2023 13:47:08 +0200 Subject: [PATCH 27/36] Test utility: fix wording of a haddoc --- services/galley/test/integration/API/MLS/Util.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/services/galley/test/integration/API/MLS/Util.hs b/services/galley/test/integration/API/MLS/Util.hs index c90f407988..6c1f9cefa7 100644 --- a/services/galley/test/integration/API/MLS/Util.hs +++ b/services/galley/test/integration/API/MLS/Util.hs @@ -864,8 +864,8 @@ sendAndConsumeCommit :: sendAndConsumeCommit = fmap fst . sendAndConsumeCommitFederated -- | Send an MLS commit message, simulate clients receiving it, and update the --- test state accordingly. Also return lists of federated users that could not --- be send a message to. +-- test state accordingly. Also return lists of federated users that a message +-- could not be sent to. sendAndConsumeCommitFederated :: HasCallStack => MessagePackage -> From 1a7eeb58e001654437e0087dd68f5ffc9569dc73 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marko=20Dimja=C5=A1evi=C4=87?= Date: Thu, 27 Apr 2023 14:16:14 +0200 Subject: [PATCH 28/36] Clean up conv action federation failure handling --- services/galley/src/Galley/API/Action.hs | 112 ++++++++----------- services/galley/src/Galley/API/Federation.hs | 2 - services/galley/src/Galley/API/Update.hs | 1 - 3 files changed, 44 insertions(+), 71 deletions(-) diff --git a/services/galley/src/Galley/API/Action.hs b/services/galley/src/Galley/API/Action.hs index 6a6e9bf9e4..eede70ff54 100644 --- a/services/galley/src/Galley/API/Action.hs +++ b/services/galley/src/Galley/API/Action.hs @@ -640,11 +640,6 @@ updateLocalConversationUnchecked lconv qusr con action = do (extraTargets, action') <- performAction tag qusr lconv action notifyConversationAction - -- Removing members should be fault tolerant. - ( case tag of - SConversationRemoveMembersTag -> False - _ -> True - ) (sing @tag) qusr False @@ -706,7 +701,6 @@ notifyConversationAction :: Member (Input UTCTime) r, Member (Logger (Log.Msg -> Log.Msg)) r ) => - Bool -> Sing tag -> Qualified UserId -> Bool -> @@ -715,7 +709,7 @@ notifyConversationAction :: BotsAndMembers -> ConversationAction (tag :: ConversationActionTag) -> Sem r (LocalConversationUpdate, FailedToProcess) -notifyConversationAction _failEarly tag quid notifyOrigDomain con lconv targets action = do +notifyConversationAction tag quid notifyOrigDomain con lconv targets action = do now <- input let lcnv = fmap convId lconv conv = tUnqualified lconv @@ -744,66 +738,49 @@ notifyConversationAction _failEarly tag quid notifyOrigDomain con lconv targets { nrcConvId = convId conv, nrcProtocol = convProtocol conv } - -- let _errorIntolerant = do - -- -- TODO(md): Get rid of 'errorIntolerant' - -- E.runFederatedConcurrently_ (toList newDomains) $ \_ -> do - -- void $ fedClient @'Galley @"on-new-remote-conversation" nrc - -- update <- fmap (fromMaybe (mkUpdate []) . asum . map tUnqualified) - -- . E.runFederatedConcurrently (toList (bmRemotes targets)) - -- $ \ruids -> do - -- let update = mkUpdate (tUnqualified ruids) - -- -- if notifyOrigDomain is false, filter out user from quid's domain, - -- -- because quid's backend will update local state and notify its users - -- -- itself using the ConversationUpdate returned by this function - -- if notifyOrigDomain || tDomain ruids /= qDomain quid - -- then fedClient @'Galley @"on-conversation-updated" update $> Nothing - -- else pure (Just update) - -- pure (update, mempty :: FailedToProcess) - let errorTolerant = do - notifyEithers <- - E.runFederatedConcurrentlyEither (toList newRemotes) $ \_ -> do - void $ fedClient @'Galley @"on-new-remote-conversation" nrc - -- For now these users will not be able to join the conversation until - -- queueing and retrying is implemented. - let failedNotifies = lefts notifyEithers - for_ failedNotifies $ \case - -- rethrow invalid-domain errors and mis-configured federation errors - (_, ex@(FederationCallFailure (FederatorClientError (Wai.Error (Wai.Status 422 _) _ _ _)))) -> throw ex - (_, ex@(FederationCallFailure (FederatorClientHTTP2Error (FederatorClientConnectionError _)))) -> throw ex - _ -> pure () - for_ failedNotifies $ - logError - "on-new-remote-conversation" - "An error occurred while communicating with federated server: " - updates <- - E.runFederatedConcurrentlyEither (toList (bmRemotes targets)) $ - \ruids -> do - let update = mkUpdate (tUnqualified ruids) - -- if notifyOrigDomain is false, filter out user from quid's domain, - -- because quid's backend will update local state and notify its users - -- itself using the ConversationUpdate returned by this function - if notifyOrigDomain || tDomain ruids /= qDomain quid - then fedClient @'Galley @"on-conversation-updated" update $> Nothing - else pure (Just update) - let f = fromMaybe (mkUpdate []) . asum . map tUnqualified . rights - update = f updates - failedUpdates = lefts updates - toFailedToProcess :: [Qualified UserId] -> FailedToProcess - toFailedToProcess us = case tag of - SConversationJoinTag -> failedToAdd us - SConversationLeaveTag -> failedToRemove us - SConversationRemoveMembersTag -> failedToRemove us - _ -> mempty - for_ failedUpdates $ - logError - "on-conversation-updated" - "An error occurred while communicating with federated server: " - let totalFailedToProcess = - failedToAdd (qualifiedFails failedNotifies) - <> toFailedToProcess (qualifiedFails failedUpdates) - pure (update, totalFailedToProcess) - - (update, failedToProcess) <- errorTolerant + (update, failedToProcess) <- do + notifyEithers <- + E.runFederatedConcurrentlyEither (toList newRemotes) $ \_ -> do + void $ fedClient @'Galley @"on-new-remote-conversation" nrc + -- For now these users will not be able to join the conversation until + -- queueing and retrying is implemented. + let failedNotifies = lefts notifyEithers + for_ failedNotifies $ \case + -- rethrow invalid-domain errors and mis-configured federation errors + (_, ex@(FederationCallFailure (FederatorClientError (Wai.Error (Wai.Status 422 _) _ _ _)))) -> throw ex + (_, ex@(FederationCallFailure (FederatorClientHTTP2Error (FederatorClientConnectionError _)))) -> throw ex + _ -> pure () + for_ failedNotifies $ + logError + "on-new-remote-conversation" + "An error occurred while communicating with federated server: " + updates <- + E.runFederatedConcurrentlyEither (toList (bmRemotes targets)) $ + \ruids -> do + let update = mkUpdate (tUnqualified ruids) + -- if notifyOrigDomain is false, filter out user from quid's domain, + -- because quid's backend will update local state and notify its users + -- itself using the ConversationUpdate returned by this function + if notifyOrigDomain || tDomain ruids /= qDomain quid + then fedClient @'Galley @"on-conversation-updated" update $> Nothing + else pure (Just update) + let f = fromMaybe (mkUpdate []) . asum . map tUnqualified . rights + update = f updates + failedUpdates = lefts updates + toFailedToProcess :: [Qualified UserId] -> FailedToProcess + toFailedToProcess us = case tag of + SConversationJoinTag -> failedToAdd us + SConversationLeaveTag -> failedToRemove us + SConversationRemoveMembersTag -> failedToRemove us + _ -> mempty + for_ failedUpdates $ + logError + "on-conversation-updated" + "An error occurred while communicating with federated server: " + let totalFailedToProcess = + failedToAdd (qualifiedFails failedNotifies) + <> toFailedToProcess (qualifiedFails failedUpdates) + pure (update, totalFailedToProcess) -- notify local participants and bots pushConversationEvent con e (qualifyAs lcnv (bmLocals targets)) (bmBots targets) @@ -893,7 +870,6 @@ kickMember qusr lconv targets victim = void . runError @NoChanges $ do lconv () notifyConversationAction - False (sing @'ConversationRemoveMembersTag) qusr True diff --git a/services/galley/src/Galley/API/Federation.hs b/services/galley/src/Galley/API/Federation.hs index d6a9268969..7b040f6af0 100644 --- a/services/galley/src/Galley/API/Federation.hs +++ b/services/galley/src/Galley/API/Federation.hs @@ -374,7 +374,6 @@ leaveConversation requestingDomain lc = do (_, notifyFailedToProcess) <- mapError mapFederationError $ notifyConversationAction - False SConversationLeaveTag leaver False @@ -505,7 +504,6 @@ onUserDeleted origDomain udcn = do void $ mapError mapFederationError $ notifyConversationAction - False (sing @'ConversationLeaveTag) untaggedDeletedUser False diff --git a/services/galley/src/Galley/API/Update.hs b/services/galley/src/Galley/API/Update.hs index 145909e8f2..2537f86e4d 100644 --- a/services/galley/src/Galley/API/Update.hs +++ b/services/galley/src/Galley/API/Update.hs @@ -769,7 +769,6 @@ joinConversation lusr zcon conv access = do addMembersToLocalConversation lcnv (UserList users []) roleNameWireMember (lcuEvent . fst) <$> notifyConversationAction - False (sing @'ConversationJoinTag) (tUntagged lusr) False From 23452df5ba074466571a27520dffc917ff8c319b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marko=20Dimja=C5=A1evi=C4=87?= Date: Thu, 27 Apr 2023 14:23:34 +0200 Subject: [PATCH 29/36] Add changelogs --- changelog.d/1-api-changes/mls-conv-add-across-federation | 1 + changelog.d/6-federation/failed-to-process | 1 + 2 files changed, 2 insertions(+) create mode 100644 changelog.d/1-api-changes/mls-conv-add-across-federation create mode 100644 changelog.d/6-federation/failed-to-process diff --git a/changelog.d/1-api-changes/mls-conv-add-across-federation b/changelog.d/1-api-changes/mls-conv-add-across-federation new file mode 100644 index 0000000000..6c86f1106b --- /dev/null +++ b/changelog.d/1-api-changes/mls-conv-add-across-federation @@ -0,0 +1 @@ +Report a failure to add remote users to an MLS conversation diff --git a/changelog.d/6-federation/failed-to-process b/changelog.d/6-federation/failed-to-process new file mode 100644 index 0000000000..22edab941a --- /dev/null +++ b/changelog.d/6-federation/failed-to-process @@ -0,0 +1 @@ +Several federation Galley endpoints have a breaking change in their response types: "leave-conversation", "update-conversation", "send-mls-message" and "send-mls-commit-bundle". From 13bc11c3909f49f74aef727dbb9f5ae861b10bc5 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marko=20Dimja=C5=A1evi=C4=87?= Date: Thu, 27 Apr 2023 14:54:41 +0200 Subject: [PATCH 30/36] Linting --- services/galley/src/Galley/API/Update.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/services/galley/src/Galley/API/Update.hs b/services/galley/src/Galley/API/Update.hs index 2537f86e4d..85d685593b 100644 --- a/services/galley/src/Galley/API/Update.hs +++ b/services/galley/src/Galley/API/Update.hs @@ -419,7 +419,7 @@ updateConversationMessageTimer lusr zcon qcnv update = foldQualified lusr ( \lcnv -> - (lcuEvent . fst) + lcuEvent . fst <$> updateLocalConversation @'ConversationMessageTimerUpdateTag lcnv @@ -767,7 +767,7 @@ joinConversation lusr zcon conv access = do let users = filter (notIsConvMember lusr conv) [tUnqualified lusr] (extraTargets, action) <- addMembersToLocalConversation lcnv (UserList users []) roleNameWireMember - (lcuEvent . fst) + lcuEvent . fst <$> notifyConversationAction (sing @'ConversationJoinTag) (tUntagged lusr) From 2d2beb689d383db5f67ca7bfa0e538a9596c50e9 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marko=20Dimja=C5=A1evi=C4=87?= Date: Thu, 4 May 2023 10:20:24 +0200 Subject: [PATCH 31/36] Remove a hand-rolled Semigroup Maybe instance - The definition of `(<\>)` was exactly the same as `Semigroup a => Semigroup Maybe`, which I confused with the `Alternative Maybe` instance. --- libs/wire-api/src/Wire/API/MLS/Message.hs | 12 +++--------- 1 file changed, 3 insertions(+), 9 deletions(-) diff --git a/libs/wire-api/src/Wire/API/MLS/Message.hs b/libs/wire-api/src/Wire/API/MLS/Message.hs index ee20a7993b..15458d8d78 100644 --- a/libs/wire-api/src/Wire/API/MLS/Message.hs +++ b/libs/wire-api/src/Wire/API/MLS/Message.hs @@ -347,12 +347,6 @@ instance ToSchema UnreachableUsers where unreachableFromList :: [Qualified UserId] -> Maybe UnreachableUsers unreachableFromList = fmap (UnreachableUsers . NE.nub) . nonEmpty --- | A 'mappend'-like operation on two optional values of a type with a --- Semigroup instance. -(<\>) :: Semigroup a => Maybe a -> Maybe a -> Maybe a -(Just a) <\> (Just b) = Just (a <> b) -m <\> n = m <|> n - -- | Lists of remote users that could not be processed in a federated action, -- e.g., a message could not be sent to these remote users. data FailedToProcess = FailedToProcess @@ -366,9 +360,9 @@ data FailedToProcess = FailedToProcess instance Semigroup FailedToProcess where ftp1 <> ftp2 = FailedToProcess - { send = send ftp1 <\> send ftp2, - add = add ftp1 <\> add ftp2, - remove = remove ftp1 <\> remove ftp2 + { send = send ftp1 <> send ftp2, + add = add ftp1 <> add ftp2, + remove = remove ftp1 <> remove ftp2 } instance Monoid FailedToProcess where From 0c260b71b3888faef1913aaf91c7ec2050397f0d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marko=20Dimja=C5=A1evi=C4=87?= Date: Thu, 4 May 2023 10:52:55 +0200 Subject: [PATCH 32/36] Move unreachability stuff into its own module --- .../src/Wire/API/Federation/API/Galley.hs | 2 +- .../Golden/MLSMessageSendingStatus.hs | 1 + libs/wire-api/src/Wire/API/MLS/Message.hs | 100 +------------- libs/wire-api/src/Wire/API/Unreachable.hs | 127 ++++++++++++++++++ libs/wire-api/wire-api.cabal | 1 + services/galley/src/Galley/API/Action.hs | 2 +- services/galley/src/Galley/API/MLS/Message.hs | 1 + .../galley/src/Galley/API/MLS/Propagate.hs | 2 +- services/galley/test/integration/API/MLS.hs | 2 +- .../galley/test/integration/API/MLS/Util.hs | 1 + 10 files changed, 136 insertions(+), 103 deletions(-) create mode 100644 libs/wire-api/src/Wire/API/Unreachable.hs 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 dbedf89362..b282a387dd 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 @@ -35,11 +35,11 @@ import Wire.API.Conversation.Typing import Wire.API.Error.Galley import Wire.API.Federation.API.Common import Wire.API.Federation.Endpoint -import Wire.API.MLS.Message import Wire.API.MLS.SubConversation import Wire.API.MakesFederatedCall import Wire.API.Message import Wire.API.Routes.Public.Galley.Messaging +import Wire.API.Unreachable import Wire.API.Util.Aeson (CustomEncoded (..)) import Wire.Arbitrary (Arbitrary, GenericUniform (..)) diff --git a/libs/wire-api-federation/test/Test/Wire/API/Federation/Golden/MLSMessageSendingStatus.hs b/libs/wire-api-federation/test/Test/Wire/API/Federation/Golden/MLSMessageSendingStatus.hs index 5dbb6a6375..32a420f419 100644 --- a/libs/wire-api-federation/test/Test/Wire/API/Federation/Golden/MLSMessageSendingStatus.hs +++ b/libs/wire-api-federation/test/Test/Wire/API/Federation/Golden/MLSMessageSendingStatus.hs @@ -24,6 +24,7 @@ import Data.Qualified import qualified Data.UUID as UUID import Imports import Wire.API.MLS.Message +import Wire.API.Unreachable testObject_MLSMessageSendingStatus1 :: MLSMessageSendingStatus testObject_MLSMessageSendingStatus1 = diff --git a/libs/wire-api/src/Wire/API/MLS/Message.hs b/libs/wire-api/src/Wire/API/MLS/Message.hs index 15458d8d78..89bda69ab4 100644 --- a/libs/wire-api/src/Wire/API/MLS/Message.hs +++ b/libs/wire-api/src/Wire/API/MLS/Message.hs @@ -39,17 +39,6 @@ module Wire.API.MLS.Message KnownFormatTag (..), verifyMessageSignature, mkSignedMessage, - - -- * Failed to process - UnreachableUsers (UnreachableUsers), - unreachableFromList, - FailedToProcess (..), - failedToSend, - failedToSendMaybe, - failedToAdd, - failedToAddMaybe, - failedToRemove, - failedToRemoveMaybe, ) where @@ -60,12 +49,8 @@ import Data.Binary import Data.Binary.Get import Data.Binary.Put import qualified Data.ByteArray as BA -import Data.Id import Data.Json.Util import Data.Kind -import Data.List.NonEmpty -import qualified Data.List.NonEmpty as NE -import Data.Qualified import Data.Schema import Data.Singletons.TH import qualified Data.Swagger as S @@ -79,6 +64,7 @@ import Wire.API.MLS.Group import Wire.API.MLS.KeyPackage import Wire.API.MLS.Proposal import Wire.API.MLS.Serialisation +import Wire.API.Unreachable import Wire.Arbitrary (GenericUniform (..)) data WireFormatTag = MLSPlainText | MLSCipherText @@ -330,90 +316,6 @@ instance SerialiseMLS (MessagePayload 'MLSPlainText) where -- so the next case is left as a stub serialiseMLS _ = pure () -newtype UnreachableUsers = UnreachableUsers {unreachableUsers :: NonEmpty (Qualified UserId)} - deriving stock (Eq, Show) - deriving (A.ToJSON, A.FromJSON, S.ToSchema) via Schema UnreachableUsers - -instance Semigroup UnreachableUsers where - (UnreachableUsers m) <> (UnreachableUsers n) = UnreachableUsers . NE.nub $ m <> n - -instance ToSchema UnreachableUsers where - schema = - named "UnreachableUsers" $ - UnreachableUsers - <$> unreachableUsers - .= nonEmptyArray schema - -unreachableFromList :: [Qualified UserId] -> Maybe UnreachableUsers -unreachableFromList = fmap (UnreachableUsers . NE.nub) . nonEmpty - --- | Lists of remote users that could not be processed in a federated action, --- e.g., a message could not be sent to these remote users. -data FailedToProcess = FailedToProcess - { send :: Maybe UnreachableUsers, - add :: Maybe UnreachableUsers, - remove :: Maybe UnreachableUsers - } - deriving (Eq, Show) - deriving (A.ToJSON, A.FromJSON, S.ToSchema) via Schema FailedToProcess - -instance Semigroup FailedToProcess where - ftp1 <> ftp2 = - FailedToProcess - { send = send ftp1 <> send ftp2, - add = add ftp1 <> add ftp2, - remove = remove ftp1 <> remove ftp2 - } - -instance Monoid FailedToProcess where - mempty = FailedToProcess mempty mempty mempty - -failedToProcessObjectSchema :: ObjectSchema SwaggerDoc FailedToProcess -failedToProcessObjectSchema = - FailedToProcess - <$> send - .= maybe_ - ( optFieldWithDocModifier - "failed_to_send" - (description ?~ "List of federated users who could not be reached and did not receive the message") - (unnamed schema) - ) - <*> add - .= maybe_ - ( optFieldWithDocModifier - "failed_to_add" - (description ?~ "List of federated users who could not be reached and be added to a conversation") - (unnamed schema) - ) - <*> remove - .= maybe_ - ( optFieldWithDocModifier - "failed_to_remove" - (description ?~ "List of federated users who could not be reached and be removed from a conversation") - (unnamed schema) - ) - -instance ToSchema FailedToProcess where - schema = object "FailedToProcess" failedToProcessObjectSchema - -failedToSend :: [Qualified UserId] -> FailedToProcess -failedToSend = failedToSendMaybe . unreachableFromList - -failedToSendMaybe :: Maybe UnreachableUsers -> FailedToProcess -failedToSendMaybe us = mempty {send = us} - -failedToAdd :: [Qualified UserId] -> FailedToProcess -failedToAdd = failedToAddMaybe . unreachableFromList - -failedToAddMaybe :: Maybe UnreachableUsers -> FailedToProcess -failedToAddMaybe us = mempty {add = us} - -failedToRemove :: [Qualified UserId] -> FailedToProcess -failedToRemove = failedToRemoveMaybe . unreachableFromList - -failedToRemoveMaybe :: Maybe UnreachableUsers -> FailedToProcess -failedToRemoveMaybe us = mempty {remove = us} - data MLSMessageSendingStatus = MLSMessageSendingStatus { mmssEvents :: [Event], mmssTime :: UTCTimeMillis, diff --git a/libs/wire-api/src/Wire/API/Unreachable.hs b/libs/wire-api/src/Wire/API/Unreachable.hs new file mode 100644 index 0000000000..f812d4920b --- /dev/null +++ b/libs/wire-api/src/Wire/API/Unreachable.hs @@ -0,0 +1,127 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2022 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +-- | Types and utilies around unreachable backends and failing to process +-- various kinds of messages. +module Wire.API.Unreachable + ( -- * Failed to process + UnreachableUsers (UnreachableUsers), + unreachableFromList, + FailedToProcess (..), + failedToProcessObjectSchema, + failedToSend, + failedToSendMaybe, + failedToAdd, + failedToAddMaybe, + failedToRemove, + failedToRemoveMaybe, + ) +where + +import Control.Lens ((?~)) +import qualified Data.Aeson as A +import Data.Id +import Data.List.NonEmpty +import qualified Data.List.NonEmpty as NE +import Data.Qualified +import Data.Schema +import qualified Data.Swagger as S +import Imports + +newtype UnreachableUsers = UnreachableUsers {unreachableUsers :: NonEmpty (Qualified UserId)} + deriving stock (Eq, Show) + deriving (A.ToJSON, A.FromJSON, S.ToSchema) via Schema UnreachableUsers + +instance Semigroup UnreachableUsers where + (UnreachableUsers m) <> (UnreachableUsers n) = UnreachableUsers . NE.nub $ m <> n + +instance ToSchema UnreachableUsers where + schema = + named "UnreachableUsers" $ + UnreachableUsers + <$> unreachableUsers + .= nonEmptyArray schema + +unreachableFromList :: [Qualified UserId] -> Maybe UnreachableUsers +unreachableFromList = fmap (UnreachableUsers . NE.nub) . nonEmpty + +-- | Lists of remote users that could not be processed in a federated action, +-- e.g., a message could not be sent to these remote users. +data FailedToProcess = FailedToProcess + { send :: Maybe UnreachableUsers, + add :: Maybe UnreachableUsers, + remove :: Maybe UnreachableUsers + } + deriving (Eq, Show) + deriving (A.ToJSON, A.FromJSON, S.ToSchema) via Schema FailedToProcess + +instance Semigroup FailedToProcess where + ftp1 <> ftp2 = + FailedToProcess + { send = send ftp1 <> send ftp2, + add = add ftp1 <> add ftp2, + remove = remove ftp1 <> remove ftp2 + } + +instance Monoid FailedToProcess where + mempty = FailedToProcess mempty mempty mempty + +failedToProcessObjectSchema :: ObjectSchema SwaggerDoc FailedToProcess +failedToProcessObjectSchema = + FailedToProcess + <$> send + .= maybe_ + ( optFieldWithDocModifier + "failed_to_send" + (description ?~ "List of federated users who could not be reached and did not receive the message") + (unnamed schema) + ) + <*> add + .= maybe_ + ( optFieldWithDocModifier + "failed_to_add" + (description ?~ "List of federated users who could not be reached and be added to a conversation") + (unnamed schema) + ) + <*> remove + .= maybe_ + ( optFieldWithDocModifier + "failed_to_remove" + (description ?~ "List of federated users who could not be reached and be removed from a conversation") + (unnamed schema) + ) + +instance ToSchema FailedToProcess where + schema = object "FailedToProcess" failedToProcessObjectSchema + +failedToSend :: [Qualified UserId] -> FailedToProcess +failedToSend = failedToSendMaybe . unreachableFromList + +failedToSendMaybe :: Maybe UnreachableUsers -> FailedToProcess +failedToSendMaybe us = mempty {send = us} + +failedToAdd :: [Qualified UserId] -> FailedToProcess +failedToAdd = failedToAddMaybe . unreachableFromList + +failedToAddMaybe :: Maybe UnreachableUsers -> FailedToProcess +failedToAddMaybe us = mempty {add = us} + +failedToRemove :: [Qualified UserId] -> FailedToProcess +failedToRemove = failedToRemoveMaybe . unreachableFromList + +failedToRemoveMaybe :: Maybe UnreachableUsers -> FailedToProcess +failedToRemoveMaybe us = mempty {remove = us} diff --git a/libs/wire-api/wire-api.cabal b/libs/wire-api/wire-api.cabal index 4e8d105456..099ac029fa 100644 --- a/libs/wire-api/wire-api.cabal +++ b/libs/wire-api/wire-api.cabal @@ -138,6 +138,7 @@ library Wire.API.Team.Role Wire.API.Team.SearchVisibility Wire.API.Team.Size + Wire.API.Unreachable Wire.API.User Wire.API.User.Activation Wire.API.User.Auth diff --git a/services/galley/src/Galley/API/Action.hs b/services/galley/src/Galley/API/Action.hs index eede70ff54..4412315df3 100644 --- a/services/galley/src/Galley/API/Action.hs +++ b/services/galley/src/Galley/API/Action.hs @@ -97,9 +97,9 @@ import Wire.API.Event.Conversation import Wire.API.Federation.API (Component (Galley), fedClient) import Wire.API.Federation.API.Galley import Wire.API.Federation.Error -import Wire.API.MLS.Message import Wire.API.Team.LegalHold import Wire.API.Team.Member +import Wire.API.Unreachable import qualified Wire.API.User as User data NoChanges = NoChanges diff --git a/services/galley/src/Galley/API/MLS/Message.hs b/services/galley/src/Galley/API/MLS/Message.hs index 8f6e071966..7d60732c9c 100644 --- a/services/galley/src/Galley/API/MLS/Message.hs +++ b/services/galley/src/Galley/API/MLS/Message.hs @@ -92,6 +92,7 @@ import Wire.API.MLS.SubConversation import Wire.API.MLS.Welcome import Wire.API.Message import Wire.API.Routes.Internal.Brig +import Wire.API.Unreachable import Wire.API.User.Client type MLSMessageStaticErrors = diff --git a/services/galley/src/Galley/API/MLS/Propagate.hs b/services/galley/src/Galley/API/MLS/Propagate.hs index 99e70ce31e..3da4edbca1 100644 --- a/services/galley/src/Galley/API/MLS/Propagate.hs +++ b/services/galley/src/Galley/API/MLS/Propagate.hs @@ -44,8 +44,8 @@ import Wire.API.Event.Conversation import Wire.API.Federation.API import Wire.API.Federation.API.Galley import Wire.API.Federation.Error -import Wire.API.MLS.Message import Wire.API.Message +import Wire.API.Unreachable -- | Propagate a message. propagateMessage :: diff --git a/services/galley/test/integration/API/MLS.hs b/services/galley/test/integration/API/MLS.hs index 05328c0e2d..f60d144f41 100644 --- a/services/galley/test/integration/API/MLS.hs +++ b/services/galley/test/integration/API/MLS.hs @@ -66,13 +66,13 @@ import Wire.API.Event.Conversation import Wire.API.Federation.API.Galley import Wire.API.MLS.Credential import Wire.API.MLS.Keys -import Wire.API.MLS.Message import Wire.API.MLS.Serialisation import Wire.API.MLS.SubConversation import Wire.API.MLS.Welcome import Wire.API.Message import Wire.API.Routes.MultiTablePaging import Wire.API.Routes.Version +import Wire.API.Unreachable tests :: IO TestSetup -> TestTree tests s = diff --git a/services/galley/test/integration/API/MLS/Util.hs b/services/galley/test/integration/API/MLS/Util.hs index 6c1f9cefa7..2c14878c55 100644 --- a/services/galley/test/integration/API/MLS/Util.hs +++ b/services/galley/test/integration/API/MLS/Util.hs @@ -78,6 +78,7 @@ import Wire.API.MLS.Keys import Wire.API.MLS.Message import Wire.API.MLS.Proposal import Wire.API.MLS.Serialisation +import Wire.API.Unreachable import Wire.API.User.Client import Wire.API.User.Client.Prekey From 9b146aafb67beb9178f64043f5c59daabce41069 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marko=20Dimja=C5=A1evi=C4=87?= Date: Thu, 4 May 2023 11:02:05 +0200 Subject: [PATCH 33/36] Change the export list of the Unreachable module --- libs/wire-api/src/Wire/API/Unreachable.hs | 2 +- services/galley/test/integration/API/MLS.hs | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/libs/wire-api/src/Wire/API/Unreachable.hs b/libs/wire-api/src/Wire/API/Unreachable.hs index f812d4920b..69725e53d0 100644 --- a/libs/wire-api/src/Wire/API/Unreachable.hs +++ b/libs/wire-api/src/Wire/API/Unreachable.hs @@ -19,7 +19,7 @@ -- various kinds of messages. module Wire.API.Unreachable ( -- * Failed to process - UnreachableUsers (UnreachableUsers), + UnreachableUsers (unreachableUsers), unreachableFromList, FailedToProcess (..), failedToProcessObjectSchema, diff --git a/services/galley/test/integration/API/MLS.hs b/services/galley/test/integration/API/MLS.hs index f60d144f41..d1f8dbe9cf 100644 --- a/services/galley/test/integration/API/MLS.hs +++ b/services/galley/test/integration/API/MLS.hs @@ -706,7 +706,7 @@ testAddRemotesSomeUnreachable = do failedToProcess @?= FailedToProcess { send = Nothing, - add = Just (UnreachableUsers (pure charlie)), + add = unreachableFromList [charlie], remove = Nothing } let SomeConversationAction SConversationJoinTag cj = cuAction bdy From f618a80524d8bdf7d0010bf9ea336b2787f2f734 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marko=20Dimja=C5=A1evi=C4=87?= Date: Thu, 4 May 2023 16:57:32 +0200 Subject: [PATCH 34/36] Run a fed error instead of mapping it --- services/galley/src/Galley/API/Federation.hs | 82 +++++++++++++------- 1 file changed, 52 insertions(+), 30 deletions(-) diff --git a/services/galley/src/Galley/API/Federation.hs b/services/galley/src/Galley/API/Federation.hs index 7b040f6af0..606206c674 100644 --- a/services/galley/src/Galley/API/Federation.hs +++ b/services/galley/src/Galley/API/Federation.hs @@ -25,6 +25,7 @@ import Data.Bifunctor import Data.ByteString.Conversion (toByteString') import Data.Containers.ListUtils (nubOrd) import Data.Domain (Domain) +import Data.Either.Combinators import Data.Id import Data.Json.Util import Data.List.NonEmpty (NonEmpty (..)) @@ -353,37 +354,49 @@ leaveConversation requestingDomain lc = do . mapToRuntimeError @('ActionDenied 'LeaveConversation) F.RemoveFromConversationErrorRemovalNotAllowed . mapToRuntimeError @'InvalidOperation F.RemoveFromConversationErrorRemovalNotAllowed . mapError @NoChanges (const F.RemoveFromConversationErrorUnchanged) - . mapError mapFederationError $ do (conv, _self) <- getConversationAndMemberWithError @'ConvNotFound leaver lcnv - update <- - first lcuUpdate - <$> updateLocalConversation - @'ConversationLeaveTag - lcnv - leaver - Nothing - () - pure (update, conv) + outcome <- + runError @FederationError $ + first lcuUpdate + <$> updateLocalConversation + @'ConversationLeaveTag + lcnv + leaver + Nothing + () + case outcome of + Left e -> do + logFederationError lcnv e + throw . internalErr $ e + Right update -> pure (update, conv) case res of Left e -> pure $ F.LeaveConversationResponse (Left e) Right ((_update, updateFailedToProcess), conv) -> do let remotes = filter ((== qDomain leaver) . tDomain) (rmId <$> Data.convRemoteMembers conv) let botsAndMembers = BotsAndMembers mempty (Set.fromList remotes) mempty - (_, notifyFailedToProcess) <- - mapError mapFederationError $ - notifyConversationAction - SConversationLeaveTag - leaver - False - Nothing - (qualifyAs lcnv conv) - botsAndMembers - () + (_, notifyFailedToProcess) <- do + outcome <- + runError @FederationError $ + notifyConversationAction + SConversationLeaveTag + leaver + False + Nothing + (qualifyAs lcnv conv) + botsAndMembers + () + case outcome of + Left e -> do + logFederationError lcnv e + throw . internalErr $ e + Right v -> pure v pure . F.LeaveConversationResponse . Right $ updateFailedToProcess <> notifyFailedToProcess + where + internalErr = InternalErrorWithDescription . LT.pack . displayException -- FUTUREWORK: report errors to the originating backend -- FUTUREWORK: error handling for missing / mismatched clients @@ -462,7 +475,6 @@ sendMessage originDomain msr = do onUserDeleted :: ( Member ConversationStore r, - Member (Error InternalError) r, Member FederatorAccess r, Member FireAndForget r, Member ExternalAccess r, @@ -501,8 +513,8 @@ onUserDeleted origDomain udcn = do Public.RegularConv -> do let botsAndMembers = convBotsAndMembers conv removeUser (qualifyAs lc conv) (tUntagged deletedUser) - void $ - mapError mapFederationError $ + outcome <- + runError @FederationError $ notifyConversationAction (sing @'ConversationLeaveTag) untaggedDeletedUser @@ -511,6 +523,7 @@ onUserDeleted origDomain udcn = do (qualifyAs lc conv) botsAndMembers () + whenLeft outcome . logFederationError $ lc pure EmptyResponse updateConversation :: @@ -838,10 +851,19 @@ onTypingIndicatorUpdated origDomain TypingDataUpdated {..} = do -- Utilities -------------------------------------------------------------------------------- --- | Map a subset of federation errors to internal errors as these errors are --- impossible and do not ever occur. Note this is not a general function to be --- used in places other than in this module. -mapFederationError :: FederationError -> InternalError -mapFederationError (FederationCallFailure e) = - InternalErrorWithDescription . LT.pack . displayException $ e -mapFederationError e = InternalErrorWithDescription . LT.pack . show $ e +-- | Log a federation error that is impossible in processing a remote request +-- for a local conversation. +logFederationError :: + Member P.TinyLog r => + Local ConvId -> + FederationError -> + Sem r () +logFederationError lc e = + P.warn $ + Log.field "conversation" (toByteString' (tUnqualified lc)) + Log.~~ Log.field "domain" (toByteString' (tDomain lc)) + Log.~~ Log.msg + ( "An impossible federation error occurred when deleting\ + \ a user from a local conversation: " + <> displayException e + ) From fc010ea3e633a4b0e4938a12efc417279e65dcdb Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marko=20Dimja=C5=A1evi=C4=87?= Date: Fri, 5 May 2023 11:42:53 +0200 Subject: [PATCH 35/36] Simplify computation for failed-to-add --- services/galley/src/Galley/API/MLS/Message.hs | 18 ++++++++---------- services/galley/src/Galley/Types/UserList.hs | 8 ++++++++ 2 files changed, 16 insertions(+), 10 deletions(-) diff --git a/services/galley/src/Galley/API/MLS/Message.hs b/services/galley/src/Galley/API/MLS/Message.hs index 7d60732c9c..0f7ca79b66 100644 --- a/services/galley/src/Galley/API/MLS/Message.hs +++ b/services/galley/src/Galley/API/MLS/Message.hs @@ -1185,16 +1185,14 @@ executeProposalAction qusr con lconv mlsMeta cm action = do . fmap fst $ newUserClients let failedAdding = - Set.toList $ - Set.fromList (fst <$> newUserClients) - `Set.difference` Set.fromList - ( ulAll lconv - . ulNewMembers lconv (tUnqualified lconv) - . toUserList lconv - . foldMap (onlyJoining . lcuEvent) - . fst - $ addEvents - ) + ulAll lconv $ + ulDiff + (toUserList lconv $ fst <$> newUserClients) + ( toUserList lconv + . foldMap (onlyJoining . lcuEvent) + . fst + $ addEvents + ) -- add clients in the conversation state for_ newUserClients $ \(qtarget, newClients) -> do diff --git a/services/galley/src/Galley/Types/UserList.hs b/services/galley/src/Galley/Types/UserList.hs index a4565da2c1..3dbc81444d 100644 --- a/services/galley/src/Galley/Types/UserList.hs +++ b/services/galley/src/Galley/Types/UserList.hs @@ -22,6 +22,7 @@ module Galley.Types.UserList ulAll, ulFromLocals, ulFromRemotes, + ulDiff, ) where @@ -56,3 +57,10 @@ ulFromLocals = flip UserList [] ulFromRemotes :: [Remote a] -> UserList a ulFromRemotes = UserList [] + +-- | Remove from the first list all the users that are in the second list. +ulDiff :: Eq a => UserList a -> UserList a -> UserList a +ulDiff (UserList lA rA) (UserList lB rB) = + UserList + (filter (`notElem` lB) lA) + (filter (`notElem` rB) rA) From 626bf05e03ed75a5f58957d4f6db0ba2d4544b9a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marko=20Dimja=C5=A1evi=C4=87?= Date: Fri, 5 May 2023 11:56:08 +0200 Subject: [PATCH 36/36] fixup! Simplify computation for failed-to-add --- services/galley/src/Galley/API/MLS/Message.hs | 12 ++++-------- 1 file changed, 4 insertions(+), 8 deletions(-) diff --git a/services/galley/src/Galley/API/MLS/Message.hs b/services/galley/src/Galley/API/MLS/Message.hs index 0f7ca79b66..e744a7111a 100644 --- a/services/galley/src/Galley/API/MLS/Message.hs +++ b/services/galley/src/Galley/API/MLS/Message.hs @@ -1185,14 +1185,10 @@ executeProposalAction qusr con lconv mlsMeta cm action = do . fmap fst $ newUserClients let failedAdding = - ulAll lconv $ - ulDiff - (toUserList lconv $ fst <$> newUserClients) - ( toUserList lconv - . foldMap (onlyJoining . lcuEvent) - . fst - $ addEvents - ) + ulAll lconv . uncurry ulDiff . both (toUserList lconv) $ + ( fst <$> newUserClients, + foldMap (onlyJoining . lcuEvent) . fst $ addEvents + ) -- add clients in the conversation state for_ newUserClients $ \(qtarget, newClients) -> do