FS-1901: Missing bits for mixed protocol state

changelog.d/5-internal/mls-mixed

@@ -0,0 +1,4 @@
+- Do not perform client checks for add and remove proposals in mixed conversations
+- Restrict protocol updates to team conversations
+- Disallow MLS application messages in mixed conversations
+- Send remove proposals when users leave mixed conversations

integration/test/API/Galley.hs

@@ -164,3 +164,27 @@ getGroupInfo user conv = do
         Just sub -> ["conversations", convDomain, convId, "subconversations", sub, "groupinfo"]
   req <- baseRequest user Galley Versioned path
   submit "GET" req
+
+removeConversationMember ::
+  (HasCallStack, MakesValue user, MakesValue conv) =>
+  user ->
+  conv ->
+  App Response
+removeConversationMember user conv = do
+  (convDomain, convId) <- objQid conv
+  (userDomain, userId) <- objQid user
+  req <- baseRequest user Galley Versioned (joinHttpPath ["conversations", convDomain, convId, "members", userDomain, userId])
+  submit "DELETE" req
+
+updateConversationMember ::
+  (HasCallStack, MakesValue user, MakesValue conv, MakesValue target) =>
+  user ->
+  conv ->
+  target ->
+  String ->
+  App Response
+updateConversationMember user conv target role = do
+  (convDomain, convId) <- objQid conv
+  (targetDomain, targetId) <- objQid target
+  req <- baseRequest user Galley Versioned (joinHttpPath ["conversations", convDomain, convId, "members", targetDomain, targetId])
+  submit "PUT" (req & addJSONObject ["conversation_role" .= role])

integration/test/API/GalleyInternal.hs

@@ -9,7 +9,7 @@ putTeamMember user team perms = do
   tid <- asString team
   req <-
     baseRequest
-      ownDomain
+      user
       Galley
       Unversioned
       ("/i/teams/" <> tid <> "/members")
@@ -31,5 +31,5 @@ putTeamMember user team perms = do
 
 getTeamFeature :: HasCallStack => String -> String -> App Response
 getTeamFeature featureName tid = do
-  req <- baseRequest ownDomain Galley Unversioned $ joinHttpPath ["i", "teams", tid, "features", featureName]
+  req <- baseRequest OwnDomain Galley Unversioned $ joinHttpPath ["i", "teams", tid, "features", featureName]
   submit "GET" $ req

integration/test/MLS/Util.hs

@@ -10,9 +10,11 @@ import Control.Monad.Catch
 import Control.Monad.Cont
 import Control.Monad.Reader
 import Control.Monad.Trans.Maybe
+import qualified Data.Aeson as Aeson
 import qualified Data.ByteString as BS
 import qualified Data.ByteString.Base64 as Base64
 import qualified Data.ByteString.Char8 as B8
+import qualified Data.ByteString.Char8 as C8
 import Data.Default
 import Data.Foldable
 import Data.Function
@@ -27,7 +29,7 @@ import GHC.Stack
 import System.Directory
 import System.Exit
 import System.FilePath
-import System.IO
+import System.IO hiding (print, putStrLn)
 import System.IO.Temp
 import System.Posix.Files
 import System.Process
@@ -89,12 +91,17 @@ mlscli cid args mbstdin = do
         pure (argSubst "<group-in>" fn)
       else pure id
 
+  let args' = map (substIn . substOut) args
+  for_ args' $ \arg ->
+    when (arg `elem` ["<group-in>", "<group-out>"]) $
+      assertFailure ("Unbound arg: " <> arg)
+
   out <-
     spawn
       ( proc
           "mls-test-cli"
           ( ["--store", cdir </> "store"]
-              <> map (substIn . substOut) args
+              <> args'
           )
       )
       mbstdin
@@ -160,17 +167,17 @@ generateKeyPackage cid = do
   pure (kp, ref)
 
 -- | Create conversation and corresponding group.
-setupMLSGroup :: HasCallStack => ClientIdentity -> App (String, Value)
-setupMLSGroup cid = do
+createNewGroup :: HasCallStack => ClientIdentity -> App (String, Value)
+createNewGroup cid = do
   conv <- postConversation cid defMLS >>= getJSON 201
   groupId <- conv %. "group_id" & asString
   convId <- conv %. "qualified_id"
   createGroup cid conv
   pure (groupId, convId)
 
 -- | Retrieve self conversation and create the corresponding group.
-setupMLSSelfGroup :: HasCallStack => ClientIdentity -> App (String, Value)
-setupMLSSelfGroup cid = do
+createSelfGroup :: HasCallStack => ClientIdentity -> App (String, Value)
+createSelfGroup cid = do
   conv <- getSelfConversation cid >>= getJSON 200
   conv %. "epoch" `shouldMatchInt` 0
   groupId <- conv %. "group_id" & asString
@@ -225,7 +232,7 @@ keyPackageFile cid ref = do
     urlSafe '/' = '_'
     urlSafe c = c
 
-unbundleKeyPackages :: Value -> App [(ClientIdentity, ByteString)]
+unbundleKeyPackages :: HasCallStack => Value -> App [(ClientIdentity, ByteString)]
 unbundleKeyPackages bundle = do
   let entryIdentity be = do
         d <- be %. "domain" & asString
@@ -263,6 +270,7 @@ withTempKeyPackageFile bs = do
         k fp
 
 createAddCommitWithKeyPackages ::
+  HasCallStack =>
   ClientIdentity ->
   [(ClientIdentity, ByteString)] ->
   App MessagePackage
@@ -304,6 +312,44 @@ createAddCommitWithKeyPackages cid clientsAndKeyPackages = do
         groupInfo = Just gi
       }
 
+createRemoveCommit :: HasCallStack => ClientIdentity -> [ClientIdentity] -> App MessagePackage
+createRemoveCommit cid targets = do
+  bd <- getBaseDir
+  welcomeFile <- liftIO $ emptyTempFile bd "welcome"
+  giFile <- liftIO $ emptyTempFile bd "gi"
+
+  groupStateMap <- Map.fromList <$> (getClientGroupState cid >>= readGroupState)
+  let indices = map (fromMaybe (error "could not find target") . flip Map.lookup groupStateMap) targets
+
+  commit <-
+    mlscli
+      cid
+      ( [ "member",
+          "remove",
+          "--group",
+          "<group-in>",
+          "--group-out",
+          "<group-out>",
+          "--welcome-out",
+          welcomeFile,
+          "--group-info-out",
+          giFile
+        ]
+          <> map show indices
+      )
+      Nothing
+
+  welcome <- liftIO $ BS.readFile welcomeFile
+  gi <- liftIO $ BS.readFile giFile
+
+  pure
+    MessagePackage
+      { sender = cid,
+        message = commit,
+        welcome = Just welcome,
+        groupInfo = Just gi
+      }
+
 createAddProposals :: HasCallStack => ClientIdentity -> [Value] -> App [MessagePackage]
 createAddProposals cid users = do
   bundles <- for users $ (claimKeyPackages cid >=> getJSON 200)
@@ -509,3 +555,48 @@ setClientGroupState :: HasCallStack => ClientIdentity -> ByteString -> App ()
 setClientGroupState cid g =
   modifyMLSState $ \s ->
     s {clientGroupState = Map.insert cid g (clientGroupState s)}
+
+showMessage :: HasCallStack => ClientIdentity -> ByteString -> App Value
+showMessage cid msg = do
+  bs <- mlscli cid ["show", "message", "-"] (Just msg)
+  assertOne (Aeson.decode (BS.fromStrict bs))
+
+readGroupState :: HasCallStack => ByteString -> App [(ClientIdentity, Word32)]
+readGroupState gs = do
+  v :: Value <- assertJust "Could not decode group state" (Aeson.decode (BS.fromStrict gs))
+  lnodes <- v %. "group" %. "public_group" %. "treesync" %. "tree" %. "leaf_nodes" & asList
+  catMaybes <$$> for (zip lnodes [0 ..]) $ \(el, leafNodeIndex) -> do
+    lookupField el "node" >>= \case
+      Just lnode -> do
+        case lnode of
+          Null -> pure Nothing
+          _ -> do
+            vecb <- lnode %. "payload" %. "credential" %. "credential" %. "Basic" %. "identity" %. "vec"
+            vec <- asList vecb
+            ws <- BS.pack <$> for vec (\x -> asIntegral @Word8 x)
+            [uc, domain] <- pure (C8.split '@' ws)
+            [uid, client] <- pure (C8.split ':' uc)
+            let cid = ClientIdentity (C8.unpack domain) (C8.unpack uid) (C8.unpack client)
+            pure (Just (cid, leafNodeIndex))
+      Nothing ->
+        pure Nothing
+
+createApplicationMessage ::
+  HasCallStack =>
+  ClientIdentity ->
+  String ->
+  App MessagePackage
+createApplicationMessage cid messageContent = do
+  message <-
+    mlscli
+      cid
+      ["message", "--group", "<group-in>", messageContent]
+      Nothing
+
+  pure
+    MessagePackage
+      { sender = cid,
+        message = message,
+        welcome = Nothing,
+        groupInfo = Nothing
+      }

integration/test/SetupHelpers.hs

@@ -25,27 +25,29 @@ createTeam domain = do
   -- refreshIndex
   pure (user, tid)
 
-connectUsers ::
+connectUsers2 ::
   ( HasCallStack,
     MakesValue alice,
     MakesValue bob
   ) =>
   alice ->
   bob ->
   App ()
-connectUsers alice bob = do
+connectUsers2 alice bob = do
   bindResponse (Public.postConnection alice bob) (\resp -> resp.status `shouldMatchInt` 201)
   bindResponse (Public.putConnection bob alice "accepted") (\resp -> resp.status `shouldMatchInt` 200)
 
+connectUsers :: HasCallStack => [Value] -> App ()
+connectUsers users = traverse_ (uncurry connectUsers2) $ do
+  t <- tails users
+  (a, others) <- maybeToList (uncons t)
+  b <- others
+  pure (a, b)
+
 createAndConnectUsers :: (HasCallStack, MakesValue domain) => [domain] -> App [Value]
 createAndConnectUsers domains = do
   users <- for domains (flip randomUser def)
-  let userPairs = do
-        t <- tails users
-        (a, others) <- maybeToList (uncons t)
-        b <- others
-        pure (a, b)
-  for_ userPairs (uncurry connectUsers)
+  connectUsers users
   pure users
 
 getAllConvs :: (HasCallStack, MakesValue u) => u -> App [Value]

integration/test/Test/B2B.hs

@@ -6,5 +6,5 @@ import Testlib.Prelude
 
 testConnectUsers :: App ()
 testConnectUsers = do
-  _alice <- randomUser ownDomain def
+  _alice <- randomUser OwnDomain def
   pure ()

integration/test/Test/Brig.hs

@@ -10,8 +10,8 @@ import Testlib.Prelude
 
 testSearchContactForExternalUsers :: HasCallStack => App ()
 testSearchContactForExternalUsers = do
-  owner <- randomUser ownDomain def {Internal.team = True}
-  partner <- randomUser ownDomain def {Internal.team = True}
+  owner <- randomUser OwnDomain def {Internal.team = True}
+  partner <- randomUser OwnDomain def {Internal.team = True}
 
   bindResponse (Internal.putTeamMember partner (partner %. "team") (API.teamRole "partner")) $ \resp ->
     resp.status `shouldMatchInt` 200

integration/test/Test/Demo.hs

@@ -10,7 +10,7 @@ import Testlib.Prelude
 -- | Legalhold clients cannot be deleted.
 testCantDeleteLHClient :: HasCallStack => App ()
 testCantDeleteLHClient = do
-  user <- randomUser ownDomain def
+  user <- randomUser OwnDomain def
   client <-
     Public.addClient user def {Public.ctype = "legalhold", Public.internal = True}
       >>= getJSON 201
@@ -21,7 +21,7 @@ testCantDeleteLHClient = do
 -- | Deleting unknown clients should fail with 404.
 testDeleteUnknownClient :: HasCallStack => App ()
 testDeleteUnknownClient = do
-  user <- randomUser ownDomain def
+  user <- randomUser OwnDomain def
   let fakeClientId = "deadbeefdeadbeef"
   bindResponse (Public.deleteClient user fakeClientId) $ \resp -> do
     resp.status `shouldMatchInt` 404
@@ -32,14 +32,14 @@ testModifiedBrig = do
   withModifiedService
     Brig
     (setField "optSettings.setFederationDomain" "overridden.example.com")
-    $ bindResponse (Public.getAPIVersion ownDomain)
+    $ bindResponse (Public.getAPIVersion OwnDomain)
     $ \resp -> do
       resp.status `shouldMatchInt` 200
       (resp.json %. "domain") `shouldMatch` "overridden.example.com"
 
 testModifiedGalley :: HasCallStack => App ()
 testModifiedGalley = do
-  (_user, tid) <- createTeam ownDomain
+  (_user, tid) <- createTeam OwnDomain
 
   let getFeatureStatus = do
         bindResponse (Internal.getTeamFeature "searchVisibility" tid) $ \res -> do
@@ -57,19 +57,19 @@ testModifiedGalley = do
 
 testWebSockets :: HasCallStack => App ()
 testWebSockets = do
-  user <- randomUser ownDomain def
+  user <- randomUser OwnDomain def
   withWebSocket user $ \ws -> do
     client <- Public.addClient user def >>= getJSON 201
     n <- awaitMatch 3 (\n -> nPayload n %. "type" `isEqual` "user.client-add") ws
     nPayload n %. "client.id" `shouldMatch` (client %. "id")
 
 testMultipleBackends :: App ()
 testMultipleBackends = do
-  ownDomainRes <- (Public.getAPIVersion ownDomain >>= getJSON 200) %. "domain"
-  otherDomainRes <- (Public.getAPIVersion otherDomain >>= getJSON 200) %. "domain"
-  ownDomainRes `shouldMatch` ownDomain
-  otherDomainRes `shouldMatch` otherDomain
-  ownDomain `shouldNotMatch` otherDomain
+  ownDomainRes <- (Public.getAPIVersion OwnDomain >>= getJSON 200) %. "domain"
+  otherDomainRes <- (Public.getAPIVersion OtherDomain >>= getJSON 200) %. "domain"
+  ownDomainRes `shouldMatch` OwnDomain
+  otherDomainRes `shouldMatch` OtherDomain
+  OwnDomain `shouldNotMatch` OtherDomain
 
 testUnrace :: App ()
 testUnrace = do