Group info diagnostics

changelog.d/2-features/group-info-diagnostics

@@ -0,0 +1 @@
+Return informative diagnostics on group info mismatch

changelog.d/2-features/group-info-diagnostics-flag

@@ -0,0 +1 @@
+Add field to mls feature for enabling group info diagnostics per team

charts/galley/values.yaml

@@ -153,6 +153,7 @@ config:
             allowedCipherSuites: [2]
             defaultCipherSuite: 2
             supportedProtocols: [proteus, mls] # must contain defaultProtocol
+            groupInfoDiagnostics: false
           lockStatus: unlocked
       searchVisibilityInbound:
         defaults:

integration/test/Test/Events.hs

@@ -206,7 +206,7 @@ testSendMessageNoReturnToSenderWithConsumableNotificationsProteus = do
   runCodensity (createEventsWebSocket bob (Just bobClientId)) $ \ws -> do
     assertFindsEvent ws $ \e -> do
       e %. "data.event.payload.0.type" `shouldMatch` "conversation.otr-message-add"
-      e %. "data.event.payload.0.data.text" `shouldMatchBase64` "hello, bob"
+      e %. "data.event.payload.0.data.text" `shouldMatchBase64` fromString "hello, bob"
       ackEvent ws e
 
   runCodensity (createEventsWebSocket alice (Just aliceClientId)) $ \ws -> do

integration/test/Test/FeatureFlags/AllowedGlobalOperations.hs

@@ -11,12 +11,15 @@ testAllowedGlobalOperations (TaggedBool isSet) = do
   let setting =
         object
           [ "status" .= "disabled",
-            "config" .= object ["mlsConversationReset" .= True]
+            "config"
+              .= object
+                ["mlsConversationReset" .= True]
           ]
       defSetting =
         object
           [ "status" .= "enabled",
-            "config" .= object ["mlsConversationReset" .= False]
+            "config"
+              .= object ["mlsConversationReset" .= False]
           ]
   let galleyConf =
         if isSet

integration/test/Test/FeatureFlags/Mls.hs

@@ -44,7 +44,8 @@ testMlsPatch = do
                   "defaultProtocol" .= "mls",
                   "supportedProtocols" .= ["proteus", "mls"],
                   "allowedCipherSuites" .= ([1] :: [Int]),
-                  "defaultCipherSuite" .= toJSON (1 :: Int)
+                  "defaultCipherSuite" .= toJSON (1 :: Int),
+                  "groupInfoDiagnostics" .= True
                 ]
           ]
       checkPatch domain "mls"
@@ -55,7 +56,8 @@ testMlsPatch = do
                   "defaultProtocol" .= "mls",
                   "supportedProtocols" .= ["proteus", "mls"],
                   "allowedCipherSuites" .= ([1] :: [Int]),
-                  "defaultCipherSuite" .= toJSON (1 :: Int)
+                  "defaultCipherSuite" .= toJSON (1 :: Int),
+                  "groupInfoDiagnostics" .= True
                 ]
           ]
 
@@ -69,7 +71,8 @@ mls1 uid =
             "defaultProtocol" .= "mls",
             "supportedProtocols" .= ["proteus", "mls"],
             "allowedCipherSuites" .= ([1] :: [Int]),
-            "defaultCipherSuite" .= toJSON (1 :: Int)
+            "defaultCipherSuite" .= toJSON (1 :: Int),
+            "groupInfoDiagnostics" .= True
           ]
     ]
 
@@ -83,7 +86,8 @@ mls2 =
             "defaultProtocol" .= "mls",
             "supportedProtocols" .= ["mls"],
             "allowedCipherSuites" .= ([1] :: [Int]),
-            "defaultCipherSuite" .= toJSON (1 :: Int)
+            "defaultCipherSuite" .= toJSON (1 :: Int),
+            "groupInfoDiagnostics" .= True
           ]
     ]
 
@@ -97,6 +101,7 @@ mlsInvalidConfig =
             "defaultProtocol" .= "mls",
             "supportedProtocols" .= ["proteus"],
             "allowedCipherSuites" .= ([1] :: [Int]),
-            "defaultCipherSuite" .= toJSON (1 :: Int)
+            "defaultCipherSuite" .= toJSON (1 :: Int),
+            "groupInfoDiagnostics" .= True
           ]
     ]

integration/test/Test/FeatureFlags/Util.hs

@@ -96,7 +96,8 @@ defAllFeatures =
                   "defaultProtocol" .= "proteus",
                   "supportedProtocols" .= ["proteus", "mls"],
                   "allowedCipherSuites" .= ([2] :: [Int]),
-                  "defaultCipherSuite" .= A.Number 2
+                  "defaultCipherSuite" .= A.Number 2,
+                  "groupInfoDiagnostics" .= False
                 ]
           ],
       "searchVisibilityInbound" .= disabled,

integration/test/Test/Federation.hs

@@ -105,7 +105,7 @@ testNotificationsForOfflineBackends = do
       do
         newMsgNotif <- awaitMatch isNewMessageNotif ws
         newMsgNotif %. "payload.0.qualified_conversation" `shouldMatch` objQidObject upBackendConv
-        newMsgNotif %. "payload.0.data.text" `shouldMatchBase64` "success message for other user"
+        newMsgNotif %. "payload.0.data.text" `shouldMatchBase64` fromString "success message for other user"
 
         void $ awaitMatch isOtherUser2LeaveUpConvNotif ws
         void $ awaitMatch isDelUserLeaveUpConvNotif ws
@@ -116,7 +116,7 @@ testNotificationsForOfflineBackends = do
     runCodensity (startDynamicBackend downBackend mempty) $ \_ -> do
       newMsgNotif <- awaitNotificationClient downUser1 downClient1 noValue isNewMessageNotif
       newMsgNotif %. "payload.0.qualified_conversation" `shouldMatch` objQidObject upBackendConv
-      newMsgNotif %. "payload.0.data.text" `shouldMatchBase64` "success message for down user"
+      newMsgNotif %. "payload.0.data.text" `shouldMatchBase64` fromString "success message for down user"
 
       let isDelUserLeaveDownConvNotif =
             allPreds

integration/test/Test/MLS.hs

@@ -16,6 +16,7 @@ import qualified Data.Text.Read as T
 import MLS.Util
 import Notifications
 import SetupHelpers
+import Test.FeatureFlags.Util
 import Test.Version
 import Testlib.Prelude
 import Testlib.VersionedFed
@@ -1012,41 +1013,74 @@ testInvalidLeafNodeSignature = do
         Nothing -> bs
 
 testGroupInfoMismatch :: (HasCallStack) => App ()
-testGroupInfoMismatch = withModifiedBackend
-  (def {galleyCfg = setField "settings.checkGroupInfo" True})
-  $ \domain -> do
-    [alice, bob, charlie] <- createAndConnectUsers [domain, domain, domain]
-    [alice1, bob1, bob2, charlie1] <- traverse (createMLSClient def) [alice, bob, bob, charlie]
-    traverse_ (uploadNewKeyPackage def) [bob1, charlie1]
-    conv <- createNewGroup def alice1
-
-    mp1 <- createAddCommit alice1 conv [bob]
-    void $ sendAndConsumeCommitBundle mp1
-
-    -- attempt a commit with an old group info
-    mp2 <- createAddCommit alice1 conv [charlie]
-    bindResponse (postMLSCommitBundle mp2.sender (mkBundle mp2 {groupInfo = mp1.groupInfo}))
-      $ \resp -> do
-        resp.status `shouldMatchInt` 400
-        resp.json %. "label" `shouldMatch` "mls-group-info-mismatch"
-
-    -- check that epoch is still 1
-    bindResponse (getConversation alice conv) $ \resp -> do
-      resp.status `shouldMatchInt` 200
-      resp.json %. "epoch" `shouldMatchInt` 1
-
-    -- attempt an external commit with an old group info
-    void $ uploadNewKeyPackage def bob2
-    mp3 <- createExternalCommit conv bob2 Nothing
-    bindResponse (postMLSCommitBundle bob2 (mkBundle mp3 {groupInfo = mp1.groupInfo}))
-      $ \resp -> do
-        resp.status `shouldMatchInt` 400
-        resp.json %. "label" `shouldMatch` "mls-group-info-mismatch"
-
-    -- check that epoch is still 1
-    bindResponse (getConversation alice conv) $ \resp -> do
-      resp.status `shouldMatchInt` 200
-      resp.json %. "epoch" `shouldMatchInt` 1
+testGroupInfoMismatch = do
+  mls <-
+    defAllFeatures
+      %. "mls.config"
+      >>= setField "groupInfoDiagnostics" True
+  withModifiedBackend
+    ( def
+        { galleyCfg =
+            setField "settings.checkGroupInfo" True
+              >=> setField
+                "settings.featureFlags.mls.defaults"
+                ( object
+                    [ "status" .= "enabled",
+                      "lockStatus" .= "unlocked",
+                      "config" .= mls
+                    ]
+                )
+        }
+    )
+    $ \domain -> do
+      (alice, tid, [bob, charlie]) <- createTeam domain 3
+      [alice1, bob1, bob2, charlie1] <- traverse (createMLSClient def) [alice, bob, bob, charlie]
+      traverse_ (uploadNewKeyPackage def) [bob1, charlie1]
+
+      conv <- postConversation alice1 defMLS {team = Just tid} >>= getJSON 201
+      convId <- objConvId conv
+      createGroup def alice1 convId
+
+      mp1 <- createAddCommit alice1 convId [bob]
+      void $ sendAndConsumeCommitBundle mp1
+
+      -- attempt a commit with an old group info
+      mp2 <- createAddCommit alice1 convId [charlie]
+      bindResponse (postMLSCommitBundle mp2.sender (mkBundle mp2 {groupInfo = mp1.groupInfo}))
+        $ \resp -> do
+          resp.status `shouldMatchInt` 400
+          resp.json %. "conv_id" `shouldMatch` (convId %. "id")
+          resp.json %. "group_id" `shouldMatch` (convId %. "group_id")
+          resp.json %. "domain" `shouldMatch` domain
+          clients <- resp.json %. "clients" & asList
+          length clients `shouldMatchInt` 3
+          resp.json %. "commit" `shouldMatchBase64` mp2.message
+          resp.json %. "group_info" `shouldMatchBase64` (fromJust mp1.groupInfo)
+
+      -- check that epoch is still 1
+      bindResponse (getConversation alice convId) $ \resp -> do
+        resp.status `shouldMatchInt` 200
+        resp.json %. "epoch" `shouldMatchInt` 1
+
+      -- attempt an external commit with an old group info
+      void $ uploadNewKeyPackage def bob2
+      mp3 <- createExternalCommit convId bob2 Nothing
+      let bundle = mkBundle mp3 {groupInfo = mp1.groupInfo}
+      bindResponse (postMLSCommitBundle bob2 bundle)
+        $ \resp -> do
+          resp.status `shouldMatchInt` 400
+          resp.json %. "conv_id" `shouldMatch` (convId %. "id")
+          resp.json %. "group_id" `shouldMatch` (convId %. "group_id")
+          resp.json %. "domain" `shouldMatch` domain
+          clients <- resp.json %. "clients" & asList
+          length clients `shouldMatchInt` 3
+          resp.json %. "commit" `shouldMatchBase64` mp3.message
+          resp.json %. "group_info" `shouldMatchBase64` (fromJust mp1.groupInfo)
+
+      -- check that epoch is still 1
+      bindResponse (getConversation alice convId) $ \resp -> do
+        resp.status `shouldMatchInt` 200
+        resp.json %. "epoch" `shouldMatchInt` 1
 
 testGroupInfoCheckDisabled :: (HasCallStack) => App ()
 testGroupInfoCheckDisabled = do

integration/test/Testlib/Assertions.hs

@@ -16,6 +16,7 @@ import qualified Data.Aeson.Diff as AD
 import qualified Data.Aeson.Encode.Pretty as Aeson
 import qualified Data.Aeson.KeyMap as Aeson
 import Data.Aeson.Lens (_Array, _Object)
+import Data.ByteString (ByteString)
 import qualified Data.ByteString.Base64 as B64
 import qualified Data.ByteString.Lazy as BS
 import Data.Char
@@ -152,15 +153,15 @@ shouldMatchWithRules rules customRules a b = do
       _ -> Nothing
 
 shouldMatchBase64 ::
-  (MakesValue a, MakesValue b, HasCallStack) =>
+  (MakesValue a, HasCallStack) =>
   -- | The actual value, in base64
   a ->
-  -- | The expected value, in plain text
-  b ->
+  -- | The expected value
+  ByteString ->
   App ()
 a `shouldMatchBase64` b = do
-  xa <- Text.decodeUtf8With Text.lenientDecode . B64.decodeLenient . Text.encodeUtf8 . Text.pack <$> asString a
-  xa `shouldMatch` b
+  let xb = Text.decodeUtf8 (B64.encode b)
+  a `shouldMatch` xb
 
 shouldNotMatch ::
   (MakesValue a, MakesValue b, HasCallStack) =>

libs/wire-api-federation/src/Wire/API/Federation/API/Galley.hs

@@ -526,6 +526,7 @@ data MLSMessageResponse
     -- that an application message could not be sent to.
     MLSMessageResponseUpdates [ConversationUpdate]
   | MLSMessageResponseNonFederatingBackends NonFederatingBackends
+  | MLSMessageResponseGroupInfoDiagnostics GroupInfoDiagnostics
   deriving stock (Eq, Show, Generic)
   deriving (ToJSON, FromJSON) via (CustomEncoded MLSMessageResponse)
 

libs/wire-api/src/Wire/API/Error/Galley.hs

@@ -30,6 +30,7 @@ module Wire.API.Error.Galley
     UnreachableBackends (..),
     unreachableUsersToUnreachableBackends,
     UnreachableBackendsLegacy (..),
+    GroupInfoDiagnostics (..),
   )
 where
 
@@ -38,6 +39,7 @@ import Data.Aeson (FromJSON (..), ToJSON (..))
 import Data.Containers.ListUtils
 import Data.Domain
 import Data.HashMap.Strict.InsOrd (singleton)
+import Data.Json.Util
 import Data.OpenApi qualified as S
 import Data.Proxy
 import Data.Qualified
@@ -56,6 +58,9 @@ import Servant.API.ContentTypes (JSON, contentType)
 import Wire.API.Conversation.Role
 import Wire.API.Error
 import Wire.API.Error.Brig qualified as BrigError
+import Wire.API.MLS.Credential
+import Wire.API.MLS.Group
+import Wire.API.MLS.SubConversation
 import Wire.API.Routes.API
 import Wire.API.Team.HardTruncationLimit
 import Wire.API.Team.Permission
@@ -106,7 +111,6 @@ data GalleyError
   | MLSMigrationCriteriaNotSatisfied
   | MLSFederatedOne2OneNotSupported
   | MLSFederatedResetNotSupported
-  | MLSGroupInfoMismatch
   | GroupIdVersionNotSupported
   | -- | MLS and federation are incompatible with legalhold - this error is thrown if a user
     -- tries to create an MLS group while being under legalhold
@@ -269,8 +273,6 @@ type instance MapError 'MLSFederatedOne2OneNotSupported = 'StaticError 400 "mls-
 
 type instance MapError 'MLSFederatedResetNotSupported = 'StaticError 400 "mls-federated-reset-not-supported" "Reset is not supported by the owning backend of the conversation"
 
-type instance MapError 'MLSGroupInfoMismatch = 'StaticError 400 "mls-group-info-mismatch" "Ratchet tree mismatch in GroupInfo"
-
 type instance MapError 'GroupIdVersionNotSupported = 'StaticError 400 "mls-group-id-not-supported" "The group ID version of the conversation is not supported by one of the federated backends"
 
 type instance MapError MLSLegalholdIncompatible = 'StaticError 409 "mls-legal-hold-not-allowed" "A user who is under legal-hold may not participate in MLS conversations"
@@ -590,3 +592,61 @@ type instance ErrorEffect UnreachableBackendsLegacy = Error UnreachableBackendsL
 
 instance (Member (Error JSONResponse) r) => ServerEffect (Error UnreachableBackendsLegacy) r where
   interpretServerEffect = mapError toResponse
+
+--------------------------------------------------------------------------------
+-- Group info diagnostics
+
+data GroupInfoDiagnostics = GroupInfoDiagnostics
+  { commit :: ByteString,
+    groupInfo :: ByteString,
+    groupId :: GroupId,
+    clients :: [(Int, ClientIdentity)],
+    convId :: ConvOrSubConvId,
+    domain :: Domain
+  }
+  deriving (Eq, Show, Generic)
+  deriving (S.ToSchema, FromJSON, ToJSON) via Schema GroupInfoDiagnostics
+
+groupInfoDiagnosticsStatus :: HTTP.Status
+groupInfoDiagnosticsStatus = HTTP.status400
+
+instance APIError GroupInfoDiagnostics where
+  toResponse e =
+    JSONResponse
+      { status = groupInfoDiagnosticsStatus,
+        value = toJSON e,
+        headers = []
+      }
+
+indexedClientSchema :: ValueSchema NamedSwaggerDoc (Int, ClientIdentity)
+indexedClientSchema =
+  object "IndexedClient" $
+    (,)
+      <$> fst .= field "index" schema
+      <*> snd .= field "client" schema
+
+instance ToSchema GroupInfoDiagnostics where
+  schema =
+    object "GroupInfoDiagnostics" $
+      GroupInfoDiagnostics
+        <$> (.commit) .= field "commit" base64Schema
+        <*> (.groupInfo) .= field "group_info" base64Schema
+        <*> (.groupId) .= field "group_id" schema
+        <*> (.clients) .= field "clients" (array indexedClientSchema)
+        <*> (.convId) .= convOrSubConvIdObjectSchema
+        <*> (.domain) .= field "domain" schema
+
+instance IsSwaggerError GroupInfoDiagnostics where
+  addToOpenApi =
+    addErrorResponseToSwagger (HTTP.statusCode groupInfoDiagnosticsStatus) $
+      mempty
+        & S.description .~ "Submitted group info is inconsistent with the backend group state"
+        & S.content .~ singleton mediaType mediaTypeObject
+    where
+      mediaType = contentType $ Proxy @JSON
+      mediaTypeObject = mempty & S.schema ?~ S.Inline (S.toSchema (Proxy @GroupInfoDiagnostics))
+
+type instance ErrorEffect GroupInfoDiagnostics = Error GroupInfoDiagnostics
+
+instance (Member (Error JSONResponse) r) => ServerEffect (Error GroupInfoDiagnostics) r where
+  interpretServerEffect = mapError toResponse

libs/wire-api/src/Wire/API/MLS/SubConversation.hs

@@ -129,6 +129,23 @@ type ConvOrSubConvId = ConvOrSubChoice ConvId SubConvId
 
 makePrisms ''ConvOrSubChoice
 
+convOrSubToPair :: ConvOrSubChoice c s -> (c, Maybe s)
+convOrSubToPair (Conv c) = (c, Nothing)
+convOrSubToPair (SubConv c s) = (c, Just s)
+
+convOrSubFromPair :: (c, Maybe s) -> ConvOrSubChoice c s
+convOrSubFromPair (c, Nothing) = Conv c
+convOrSubFromPair (c, Just s) = SubConv c s
+
+convOrSubConvIdObjectSchema :: ObjectSchema SwaggerDoc ConvOrSubConvId
+convOrSubConvIdObjectSchema =
+  convOrSubFromPair
+    <$> convOrSubToPair
+      .= ( (,)
+             <$> fst .= field "conv_id" schema
+             <*> snd .= maybe_ (optField "subconv_id" schema)
+         )
+
 instance ToSchema ConvOrSubConvId where
   schema =
     object "ConvOrSubConvId" $