diff --git a/changelog.d/5-internal/mls-mixed b/changelog.d/5-internal/mls-mixed new file mode 100644 index 0000000000..7e35c12b3b --- /dev/null +++ b/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 diff --git a/integration/test/API/Galley.hs b/integration/test/API/Galley.hs index 8dc54f6d95..b10126ab02 100644 --- a/integration/test/API/Galley.hs +++ b/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]) diff --git a/integration/test/API/GalleyInternal.hs b/integration/test/API/GalleyInternal.hs index 56e811626a..0fb4eb2e18 100644 --- a/integration/test/API/GalleyInternal.hs +++ b/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 diff --git a/integration/test/MLS/Util.hs b/integration/test/MLS/Util.hs index 1a54fb4366..f142b67475 100644 --- a/integration/test/MLS/Util.hs +++ b/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 "" fn) else pure id + let args' = map (substIn . substOut) args + for_ args' $ \arg -> + when (arg `elem` ["", ""]) $ + assertFailure ("Unbound arg: " <> arg) + out <- spawn ( proc "mls-test-cli" ( ["--store", cdir "store"] - <> map (substIn . substOut) args + <> args' ) ) mbstdin @@ -160,8 +167,8 @@ 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" @@ -169,8 +176,8 @@ setupMLSGroup cid = do 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-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", "", messageContent] + Nothing + + pure + MessagePackage + { sender = cid, + message = message, + welcome = Nothing, + groupInfo = Nothing + } diff --git a/integration/test/SetupHelpers.hs b/integration/test/SetupHelpers.hs index a46e8e8cc5..fe79d18a7a 100644 --- a/integration/test/SetupHelpers.hs +++ b/integration/test/SetupHelpers.hs @@ -25,7 +25,7 @@ createTeam domain = do -- refreshIndex pure (user, tid) -connectUsers :: +connectUsers2 :: ( HasCallStack, MakesValue alice, MakesValue bob @@ -33,19 +33,21 @@ connectUsers :: 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] diff --git a/integration/test/Test/B2B.hs b/integration/test/Test/B2B.hs index 48267add7e..ba9df150f5 100644 --- a/integration/test/Test/B2B.hs +++ b/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 () diff --git a/integration/test/Test/Brig.hs b/integration/test/Test/Brig.hs index 170017c8f8..f1c8e9664e 100644 --- a/integration/test/Test/Brig.hs +++ b/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 diff --git a/integration/test/Test/Demo.hs b/integration/test/Test/Demo.hs index 63d663c045..dbdc984f4a 100644 --- a/integration/test/Test/Demo.hs +++ b/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,7 +57,7 @@ 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 @@ -65,11 +65,11 @@ testWebSockets = do 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 diff --git a/integration/test/Test/MLS.hs b/integration/test/Test/MLS.hs index 8fb9d4c312..5027c628f2 100644 --- a/integration/test/Test/MLS.hs +++ b/integration/test/Test/MLS.hs @@ -2,21 +2,32 @@ module Test.MLS where +import API.Brig (claimKeyPackages) import API.Galley import qualified Data.ByteString.Base64 as Base64 import qualified Data.ByteString.Char8 as B8 +import qualified Data.Text.Encoding as T import MLS.Util import SetupHelpers import Testlib.Prelude testMixedProtocolUpgrade :: HasCallStack => Domain -> App () testMixedProtocolUpgrade secondDomain = do - [alice, bob, charlie] <- do - d <- ownDomain - d2 <- secondDomain & asString - createAndConnectUsers [d, d2, d2] + (alice, tid) <- createTeam OwnDomain + [bob, charlie] <- replicateM 2 (randomUser secondDomain def) + connectUsers [alice, bob, charlie] - qcnv <- postConversation alice defProteus {qualifiedUsers = [bob, charlie]} >>= getJSON 201 + qcnv <- + postConversation + alice + defProteus + { qualifiedUsers = [bob, charlie], + team = Just tid + } + >>= getJSON 201 + + bindResponse (putConversationProtocol bob qcnv "mls") $ \resp -> do + resp.status `shouldMatchInt` 403 withWebSockets [alice, charlie] $ \websockets -> do bindResponse (putConversationProtocol bob qcnv "mixed") $ \resp -> do @@ -35,15 +46,186 @@ testMixedProtocolUpgrade secondDomain = do bindResponse (putConversationProtocol alice qcnv "mixed") $ \resp -> do resp.status `shouldMatchInt` 204 + bindResponse (putConversationProtocol bob qcnv "proteus") $ \resp -> do + resp.status `shouldMatchInt` 403 + + bindResponse (putConversationProtocol bob qcnv "invalid") $ \resp -> do + resp.status `shouldMatchInt` 400 + +testMixedProtocolNonTeam :: HasCallStack => Domain -> App () +testMixedProtocolNonTeam secondDomain = do + [alice, bob] <- createAndConnectUsers [OwnDomain, secondDomain] + qcnv <- + postConversation alice defProteus {qualifiedUsers = [bob]} + >>= getJSON 201 + + bindResponse (putConversationProtocol bob qcnv "mixed") $ \resp -> do + resp.status `shouldMatchInt` 403 + +testMixedProtocolAddUsers :: HasCallStack => Domain -> App () +testMixedProtocolAddUsers secondDomain = do + (alice, tid) <- createTeam OwnDomain + [bob, charlie] <- replicateM 2 (randomUser secondDomain def) + connectUsers [alice, bob, charlie] + + qcnv <- + postConversation alice defProteus {qualifiedUsers = [bob], team = Just tid} + >>= getJSON 201 + + bindResponse (putConversationProtocol bob qcnv "mixed") $ \resp -> do + resp.status `shouldMatchInt` 200 + + [alice1, bob1] <- traverse createMLSClient [alice, bob] + + bindResponse (getConversation alice qcnv) $ \resp -> do + resp.status `shouldMatchInt` 200 + createGroup alice1 resp.json + + traverse_ uploadNewKeyPackage [bob1] + + withWebSockets [alice, bob] $ \wss -> do + mp <- createAddCommit alice1 [bob] + welcome <- assertJust "should have welcome" mp.welcome + void $ sendAndConsumeCommitBundle mp + for_ wss $ \ws -> do + n <- awaitMatch 3 (\n -> nPayload n %. "type" `isEqual` "conversation.mls-welcome") ws + nPayload n %. "data" `shouldMatch` T.decodeUtf8 (Base64.encode welcome) + +testMixedProtocolUserLeaves :: HasCallStack => Domain -> App () +testMixedProtocolUserLeaves secondDomain = do + (alice, tid) <- createTeam OwnDomain + bob <- randomUser secondDomain def + connectUsers [alice, bob] + + qcnv <- + postConversation alice defProteus {qualifiedUsers = [bob], team = Just tid} + >>= getJSON 201 + + bindResponse (putConversationProtocol bob qcnv "mixed") $ \resp -> do + resp.status `shouldMatchInt` 200 + + [alice1, bob1] <- traverse createMLSClient [alice, bob] + + bindResponse (getConversation alice qcnv) $ \resp -> do + resp.status `shouldMatchInt` 200 + createGroup alice1 resp.json + + traverse_ uploadNewKeyPackage [bob1] + + mp <- createAddCommit alice1 [bob] + void $ sendAndConsumeCommitBundle mp + + withWebSocket alice $ \ws -> do + bindResponse (removeConversationMember bob qcnv) $ \resp -> + resp.status `shouldMatchInt` 200 + + n <- awaitMatch 3 (\n -> nPayload n %. "type" `isEqual` "conversation.mls-message-add") ws + + msg <- asByteString (nPayload n %. "data") >>= showMessage alice1 + let leafIndexBob = 1 + msg %. "message.content.body.Proposal.Remove.removed" `shouldMatchInt` leafIndexBob + msg %. "message.content.sender.External" `shouldMatchInt` 0 + +testMixedProtocolAddPartialClients :: HasCallStack => Domain -> App () +testMixedProtocolAddPartialClients secondDomain = do + (alice, tid) <- createTeam OwnDomain + bob <- randomUser secondDomain def + connectUsers [alice, bob] + + qcnv <- + postConversation alice defProteus {qualifiedUsers = [bob], team = Just tid} + >>= getJSON 201 + + bindResponse (putConversationProtocol bob qcnv "mixed") $ \resp -> do + resp.status `shouldMatchInt` 200 + + [alice1, bob1, bob2] <- traverse createMLSClient [alice, bob, bob] + + bindResponse (getConversation alice qcnv) $ \resp -> do + resp.status `shouldMatchInt` 200 + createGroup alice1 resp.json + + traverse_ uploadNewKeyPackage [bob1, bob1, bob2, bob2] + + -- create add commit for only one of bob's two clients + do + bundle <- claimKeyPackages alice1 bob >>= getJSON 200 + kps <- unbundleKeyPackages bundle + kp1 <- assertOne (filter ((== bob1) . fst) kps) + mp <- createAddCommitWithKeyPackages alice1 [kp1] + void $ sendAndConsumeCommitBundle mp + + -- this tests that bob's backend has a mapping of group id to the remote conv + -- this test is only interesting when bob is on OtherDomain + do + bundle <- claimKeyPackages bob1 bob >>= getJSON 200 + kps <- unbundleKeyPackages bundle + kp2 <- assertOne (filter ((== bob2) . fst) kps) + mp <- createAddCommitWithKeyPackages bob1 [kp2] + void $ postMLSCommitBundle mp.sender (mkBundle mp) >>= getJSON 201 + +testMixedProtocolRemovePartialClients :: HasCallStack => Domain -> App () +testMixedProtocolRemovePartialClients secondDomain = do + (alice, tid) <- createTeam OwnDomain + bob <- randomUser secondDomain def + connectUsers [alice, bob] + + qcnv <- + postConversation alice defProteus {qualifiedUsers = [bob], team = Just tid} + >>= getJSON 201 + + bindResponse (putConversationProtocol bob qcnv "mixed") $ \resp -> do + resp.status `shouldMatchInt` 200 + + [alice1, bob1, bob2] <- traverse createMLSClient [alice, bob, bob] + + bindResponse (getConversation alice qcnv) $ \resp -> do + resp.status `shouldMatchInt` 200 + createGroup alice1 resp.json + + traverse_ uploadNewKeyPackage [bob1, bob2] + void $ createAddCommit alice1 [bob] >>= sendAndConsumeCommitBundle + mp <- createRemoveCommit alice1 [bob1] + + void $ postMLSCommitBundle mp.sender (mkBundle mp) >>= getJSON 201 + +testMixedProtocolAppMessagesAreDenied :: HasCallStack => Domain -> App () +testMixedProtocolAppMessagesAreDenied secondDomain = do + (alice, tid) <- createTeam OwnDomain + bob <- randomUser secondDomain def + connectUsers [alice, bob] + + qcnv <- + postConversation alice defProteus {qualifiedUsers = [bob], team = Just tid} + >>= getJSON 201 + + bindResponse (putConversationProtocol bob qcnv "mixed") $ \resp -> do + resp.status `shouldMatchInt` 200 + + [alice1, bob1] <- traverse createMLSClient [alice, bob] + + traverse_ uploadNewKeyPackage [bob1] + + bindResponse (getConversation alice qcnv) $ \resp -> do + resp.status `shouldMatchInt` 200 + createGroup alice1 resp.json + + void $ createAddCommit alice1 [bob] >>= sendAndConsumeCommitBundle + + mp <- createApplicationMessage bob1 "hello, world" + bindResponse (postMLSMessage mp.sender mp.message) $ \resp -> do + resp.status `shouldMatchInt` 422 + resp.json %. "label" `shouldMatch` "mls-unsupported-message" + testAddUser :: HasCallStack => App () testAddUser = do - [alice, bob] <- createAndConnectUsers [ownDomain, ownDomain] + [alice, bob] <- createAndConnectUsers [OwnDomain, OwnDomain] [alice1, bob1, bob2] <- traverse createMLSClient [alice, bob, bob] traverse_ uploadNewKeyPackage [bob1, bob2] - (_, qcnv) <- setupMLSGroup alice1 + (_, qcnv) <- createNewGroup alice1 resp <- createAddCommit alice1 [bob] >>= sendAndConsumeCommitBundle events <- resp %. "events" & asList @@ -65,11 +247,28 @@ testAddUser = do "Users added to an MLS group should find it when listing conversations" (qcnv `elem` convIds) +testRemoteAddUser :: HasCallStack => App () +testRemoteAddUser = do + [alice, bob, charlie] <- createAndConnectUsers [OwnDomain, OtherDomain, OwnDomain] + [alice1, bob1, charlie1] <- traverse createMLSClient [alice, bob, charlie] + traverse_ uploadNewKeyPackage [bob1, charlie1] + (_, conv) <- createNewGroup alice1 + void $ createAddCommit alice1 [bob] >>= sendAndConsumeCommitBundle + bindResponse (updateConversationMember alice1 conv bob "wire_admin") $ \resp -> + resp.status `shouldMatchInt` 200 + + mp <- createAddCommit bob1 [charlie] + -- Support for remote admins is not implemeted yet, but this shows that add + -- proposal is being applied action + bindResponse (postMLSCommitBundle mp.sender (mkBundle mp)) $ \resp -> do + resp.status `shouldMatchInt` 500 + resp.json %. "label" `shouldMatch` "federation-not-implemented" + testCreateSubConv :: HasCallStack => App () testCreateSubConv = do - alice <- randomUser ownDomain def + alice <- randomUser OwnDomain def alice1 <- createMLSClient alice - (_, conv) <- setupMLSGroup alice1 + (_, conv) <- createNewGroup alice1 bindResponse (getSubConversation alice conv "conference") $ \resp -> do resp.status `shouldMatchInt` 200 let tm = resp.json %. "epoch_timestamp" @@ -77,7 +276,7 @@ testCreateSubConv = do testCreateSubConvProteus :: App () testCreateSubConvProteus = do - alice <- randomUser ownDomain def + alice <- randomUser OwnDomain def conv <- bindResponse (postConversation alice defProteus) $ \resp -> do resp.status `shouldMatchInt` 201 resp.json @@ -89,10 +288,10 @@ testCreateSubConvProteus = do -- commits are used. testSelfConversation :: App () testSelfConversation = do - alice <- randomUser ownDomain def + alice <- randomUser OwnDomain def creator : others <- traverse createMLSClient (replicate 3 alice) traverse_ uploadNewKeyPackage others - void $ setupMLSSelfGroup creator + void $ createSelfGroup creator commit <- createAddCommit creator [alice] welcome <- assertOne (toList commit.welcome) @@ -107,10 +306,10 @@ testSelfConversation = do testJoinSubConv :: App () testJoinSubConv = do - [alice, bob] <- createAndConnectUsers [ownDomain, ownDomain] + [alice, bob] <- createAndConnectUsers [OwnDomain, OwnDomain] [alice1, bob1, bob2] <- traverse createMLSClient [alice, bob, bob] traverse_ uploadNewKeyPackage [bob1, bob2] - (_, qcnv) <- setupMLSGroup alice1 + (_, qcnv) <- createNewGroup alice1 void $ createAddCommit alice1 [bob] >>= sendAndConsumeCommitBundle sub <- bindResponse (getSubConversation bob qcnv "conference") $ \resp -> do @@ -131,3 +330,63 @@ testJoinSubConv = do void $ createExternalCommit alice1 Nothing >>= sendAndConsumeCommitBundle + +-- | FUTUREWORK: Don't allow partial adds, not even in the first commit +testFirstCommitAllowsPartialAdds :: HasCallStack => App () +testFirstCommitAllowsPartialAdds = do + alice <- randomUser OwnDomain def + + [alice1, alice2, alice3] <- traverse createMLSClient [alice, alice, alice] + traverse_ uploadNewKeyPackage [alice1, alice2, alice2, alice3, alice3] + + (_, _qcnv) <- createNewGroup alice1 + + bundle <- claimKeyPackages alice1 alice >>= getJSON 200 + kps <- unbundleKeyPackages bundle + + -- first commit only adds kp for alice2 (not alice2 and alice3) + mp <- createAddCommitWithKeyPackages alice1 (filter ((== alice2) . fst) kps) + bindResponse (postMLSCommitBundle mp.sender (mkBundle mp)) $ \resp -> do + resp.status `shouldMatchInt` 409 + resp.json %. "label" `shouldMatch` "mls-client-mismatch" + +testAddUserPartial :: HasCallStack => App () +testAddUserPartial = do + [alice, bob, charlie] <- createAndConnectUsers (replicate 3 OwnDomain) + + -- Bob has 3 clients, Charlie has 2 + alice1 <- createMLSClient alice + bobClients@[_bob1, _bob2, bob3] <- replicateM 3 (createMLSClient bob) + charlieClients <- replicateM 2 (createMLSClient charlie) + + -- Only the first 2 clients of Bob's have uploaded key packages + traverse_ uploadNewKeyPackage (take 2 bobClients <> charlieClients) + + -- alice adds bob's first 2 clients + void $ createNewGroup alice1 + + -- alice sends a commit now, and should get a conflict error + kps <- fmap concat . for [bob, charlie] $ \user -> do + bundle <- claimKeyPackages alice1 user >>= getJSON 200 + unbundleKeyPackages bundle + mp <- createAddCommitWithKeyPackages alice1 kps + + -- before alice can commit, bob3 uploads a key package + void $ uploadNewKeyPackage bob3 + + err <- postMLSCommitBundle mp.sender (mkBundle mp) >>= getJSON 409 + err %. "label" `shouldMatch` "mls-client-mismatch" + +-- | admin removes user from a conversation but doesn't list all clients +testRemoveClientsIncomplete :: HasCallStack => App () +testRemoveClientsIncomplete = do + [alice, bob] <- createAndConnectUsers [OwnDomain, OwnDomain] + + [alice1, bob1, bob2] <- traverse createMLSClient [alice, bob, bob] + traverse_ uploadNewKeyPackage [bob1, bob2] + void $ createNewGroup alice1 + void $ createAddCommit alice1 [bob] >>= sendAndConsumeCommitBundle + mp <- createRemoveCommit alice1 [bob1] + + err <- postMLSCommitBundle mp.sender (mkBundle mp) >>= getJSON 409 + err %. "label" `shouldMatch` "mls-client-mismatch" diff --git a/integration/test/Test/MLS/KeyPackage.hs b/integration/test/Test/MLS/KeyPackage.hs index c6649c8838..5ec25410f6 100644 --- a/integration/test/Test/MLS/KeyPackage.hs +++ b/integration/test/Test/MLS/KeyPackage.hs @@ -7,7 +7,7 @@ import Testlib.Prelude testDeleteKeyPackages :: App () testDeleteKeyPackages = do - alice <- randomUser ownDomain def + alice <- randomUser OwnDomain def alice1 <- createMLSClient alice kps <- replicateM 3 (uploadNewKeyPackage alice1) diff --git a/integration/test/Testlib/App.hs b/integration/test/Testlib/App.hs index 01c8fb168c..e3dcbed544 100644 --- a/integration/test/Testlib/App.hs +++ b/integration/test/Testlib/App.hs @@ -4,6 +4,7 @@ import Control.Monad.Reader import qualified Control.Retry as Retry import Data.Aeson hiding ((.=)) import Data.IORef +import qualified Data.Text as T import qualified Data.Yaml as Yaml import GHC.Exception import System.FilePath @@ -46,11 +47,11 @@ readServiceConfig srv = do Left err -> failApp ("Error while parsing " <> cfgFile <> ": " <> Yaml.prettyPrintParseException err) Right value -> pure value -ownDomain :: App String -ownDomain = asks (.domain1) +data Domain = OwnDomain | OtherDomain -otherDomain :: App String -otherDomain = asks (.domain2) +instance MakesValue Domain where + make OwnDomain = asks (String . T.pack . (.domain1)) + make OtherDomain = asks (String . T.pack . (.domain2)) -- | Run an action, `recoverAll`ing with exponential backoff (min step 8ms, total timeout -- ~15s). Search this package for examples how to use it. diff --git a/integration/test/Testlib/Assertions.hs b/integration/test/Testlib/Assertions.hs index c056fe1c8d..c47f8d69d2 100644 --- a/integration/test/Testlib/Assertions.hs +++ b/integration/test/Testlib/Assertions.hs @@ -20,9 +20,10 @@ assertBool :: HasCallStack => String -> Bool -> App () assertBool _ True = pure () assertBool msg False = assertFailure msg -assertOne :: HasCallStack => [a] -> App a -assertOne [x] = pure x -assertOne xs = assertFailure ("Expected one, but got " <> show (length xs)) +assertOne :: (HasCallStack, Foldable t) => t a -> App a +assertOne xs = case toList xs of + [x] -> pure x + other -> assertFailure ("Expected one, but got " <> show (length other)) expectFailure :: HasCallStack => (AssertionFailure -> App ()) -> App a -> App () expectFailure checkFailure action = do diff --git a/integration/test/Testlib/Cannon.hs b/integration/test/Testlib/Cannon.hs index 85a33b14e1..414ddd37ba 100644 --- a/integration/test/Testlib/Cannon.hs +++ b/integration/test/Testlib/Cannon.hs @@ -129,7 +129,7 @@ clientApp wsChan latch conn = do -- for the connection to register with Gundeck, and return the 'Async' thread. run :: HasCallStack => WSConnect -> WS.ClientApp () -> App (Async ()) run wsConnect app = do - domain <- ownDomain + domain <- OwnDomain & asString serviceMap <- getServiceMap domain let HostPort caHost caPort = serviceHostPort serviceMap Cannon @@ -166,7 +166,7 @@ run wsConnect app = do let waitForRegistry :: HasCallStack => App () waitForRegistry = unrace $ do - request <- baseRequest ownDomain Cannon Unversioned ("/i/presences/" <> wsConnect.user <> "/" <> connId) + request <- baseRequest OwnDomain Cannon Unversioned ("/i/presences/" <> wsConnect.user <> "/" <> connId) response <- submit "HEAD" request status response `shouldMatchInt` 200 diff --git a/integration/test/Testlib/HTTP.hs b/integration/test/Testlib/HTTP.hs index f1d57f1e22..3a385816ef 100644 --- a/integration/test/Testlib/HTTP.hs +++ b/integration/test/Testlib/HTTP.hs @@ -78,7 +78,7 @@ getBody status resp = withResponse resp $ \r -> do pure r.body -- | Check response status code, then return JSON body. -getJSON :: Int -> Response -> App Aeson.Value +getJSON :: HasCallStack => Int -> Response -> App Aeson.Value getJSON status resp = withResponse resp $ \r -> do r.status `shouldMatch` status r.json diff --git a/integration/test/Testlib/JSON.hs b/integration/test/Testlib/JSON.hs index fc4360a6e0..d8dec5d65e 100644 --- a/integration/test/Testlib/JSON.hs +++ b/integration/test/Testlib/JSON.hs @@ -9,6 +9,8 @@ import qualified Data.Aeson.Encode.Pretty as Aeson import qualified Data.Aeson.Key as KM import qualified Data.Aeson.KeyMap as KM import qualified Data.Aeson.Types as Aeson +import Data.ByteString +import qualified Data.ByteString.Base64 as Base64 import qualified Data.ByteString.Lazy.Char8 as LC8 import Data.Foldable import Data.Function @@ -17,6 +19,7 @@ import Data.List.Split (splitOn) import qualified Data.Scientific as Sci import Data.String import qualified Data.Text as T +import qualified Data.Text.Encoding as T import GHC.Stack import Testlib.Env import Testlib.Types @@ -77,14 +80,22 @@ asStringM x = (String s) -> pure (Just (T.unpack s)) _ -> pure Nothing +asByteString :: (HasCallStack, MakesValue a) => a -> App ByteString +asByteString x = do + s <- asString x + let bs = T.encodeUtf8 (T.pack s) + case Base64.decode bs of + Left _ -> assertFailure "Could not base64 decode" + Right a -> pure a + asObject :: HasCallStack => MakesValue a => a -> App Object asObject x = make x >>= \case (Object o) -> pure o v -> assertFailureWithJSON x ("Object" `typeWasExpectedButGot` v) -asInt :: HasCallStack => MakesValue a => a -> App Int -asInt x = +asIntegral :: (Integral i, HasCallStack) => MakesValue a => a -> App i +asIntegral x = make x >>= \case (Number n) -> case Sci.floatingOrInteger n of diff --git a/integration/test/Testlib/ModService.hs b/integration/test/Testlib/ModService.hs index 2acf740244..ed9fab6eae 100644 --- a/integration/test/Testlib/ModService.hs +++ b/integration/test/Testlib/ModService.hs @@ -130,13 +130,12 @@ withModifiedServices services k = do waitUntilServiceUp :: HasCallStack => Service -> App () waitUntilServiceUp srv = do - d <- ownDomain isUp <- retrying (limitRetriesByCumulativeDelay (4 * 1000 * 1000) (fibonacciBackoff (200 * 1000))) (\_ isUp -> pure (not isUp)) ( \_ -> do - req <- baseRequest d srv Unversioned "/i/status" + req <- baseRequest OwnDomain srv Unversioned "/i/status" env <- ask eith <- liftIO $ diff --git a/integration/test/Testlib/PTest.hs b/integration/test/Testlib/PTest.hs index 02b8084b33..d2613fa214 100644 --- a/integration/test/Testlib/PTest.hs +++ b/integration/test/Testlib/PTest.hs @@ -1,9 +1,6 @@ module Testlib.PTest where -import Data.Aeson (Value (..)) -import qualified Data.Text as T import Testlib.App -import Testlib.JSON import Testlib.Types import Prelude @@ -15,12 +12,6 @@ class HasTests x where instance HasTests (App ()) where mkTests m n s f x = [(m, n, s, f, x)] -data Domain = OwnDomain | OtherDomain - -instance MakesValue Domain where - make OwnDomain = String . T.pack <$> ownDomain - make OtherDomain = String . T.pack <$> otherDomain - instance HasTests x => HasTests (Domain -> x) where mkTests m n s f x = mkTests m (n <> "[domain=own]") s f (x OwnDomain) diff --git a/libs/wire-api/src/Wire/API/Conversation/Protocol.hs b/libs/wire-api/src/Wire/API/Conversation/Protocol.hs index 15f635b08c..efd1205095 100644 --- a/libs/wire-api/src/Wire/API/Conversation/Protocol.hs +++ b/libs/wire-api/src/Wire/API/Conversation/Protocol.hs @@ -28,6 +28,7 @@ module Wire.API.Conversation.Protocol _ProtocolMLS, _ProtocolMixed, _ProtocolProteus, + conversationMLSData, protocolSchema, ConversationMLSData (..), ProtocolUpdate (..), @@ -35,7 +36,7 @@ module Wire.API.Conversation.Protocol where import Control.Arrow -import Control.Lens (makePrisms, (?~)) +import Control.Lens (Traversal', makePrisms, (?~)) import Data.Aeson (FromJSON (..), ToJSON (..)) import Data.Schema import qualified Data.Swagger as S @@ -103,6 +104,11 @@ data Protocol $(makePrisms ''Protocol) +conversationMLSData :: Traversal' Protocol ConversationMLSData +conversationMLSData _ ProtocolProteus = pure ProtocolProteus +conversationMLSData f (ProtocolMLS mls) = ProtocolMLS <$> f mls +conversationMLSData f (ProtocolMixed mls) = ProtocolMixed <$> f mls + protocolTag :: Protocol -> ProtocolTag protocolTag ProtocolProteus = ProtocolProteusTag protocolTag (ProtocolMLS _) = ProtocolMLSTag diff --git a/libs/wire-api/src/Wire/API/MLS/SubConversation.hs b/libs/wire-api/src/Wire/API/MLS/SubConversation.hs index 16d1462127..4082dc5fde 100644 --- a/libs/wire-api/src/Wire/API/MLS/SubConversation.hs +++ b/libs/wire-api/src/Wire/API/MLS/SubConversation.hs @@ -36,6 +36,7 @@ import Data.Schema import qualified Data.Swagger as S import qualified Data.Text as T import Data.Time.Clock +import GHC.Records import Imports import Servant (FromHttpApiData (..), ToHttpApiData (toQueryParam)) import Test.QuickCheck @@ -125,6 +126,10 @@ deriving via instance (Generic c, Generic s, Arbitrary c, Arbitrary s) => Arbitrary (ConvOrSubChoice c s) +instance HasField "conv" (ConvOrSubChoice c s) c where + getField (Conv c) = c + getField (SubConv c _) = c + type ConvOrSubConvId = ConvOrSubChoice ConvId SubConvId makePrisms ''ConvOrSubChoice diff --git a/nix/pkgs/mls-test-cli/default.nix b/nix/pkgs/mls-test-cli/default.nix index ddbf9b342a..e7104041ed 100644 --- a/nix/pkgs/mls-test-cli/default.nix +++ b/nix/pkgs/mls-test-cli/default.nix @@ -13,8 +13,8 @@ let src = fetchFromGitHub { owner = "wireapp"; repo = "mls-test-cli"; - rev = "29109bd32cedae64bdd9a47ef373710fad477590"; - sha256 = "sha256-1GMiEMkzcKPOd5AsQkQTSMLDkNqy3yjCC03K20vyFVY="; + rev = "87845faa7d5ee69652747ceaf1664baa8198c0d8"; + sha256 = "sha256-DoQ6brp1KvglVVCDp4vC5zaRx76IUywu3Rcu/TzJlvo="; }; cargoLockFile = builtins.toFile "cargo.lock" (builtins.readFile "${src}/Cargo.lock"); in rustPlatform.buildRustPackage rec { diff --git a/services/galley/src/Galley/API/Action.hs b/services/galley/src/Galley/API/Action.hs index 45d78a6406..a8f0b775d8 100644 --- a/services/galley/src/Galley/API/Action.hs +++ b/services/galley/src/Galley/API/Action.hs @@ -215,7 +215,8 @@ type family HasConversationActionEffects (tag :: ConversationActionTag) r :: Con HasConversationActionEffects 'ConversationUpdateProtocolTag r = ( Member ConversationStore r, Member (ErrorS 'ConvInvalidProtocolTransition) r, - Member (Error NoChanges) r + Member (Error NoChanges) r, + Member FederatorAccess r ) type family HasConversationActionGalleyErrors (tag :: ConversationActionTag) :: EffectRow where @@ -361,7 +362,7 @@ performAction tag origUser lconv action = do E.deleteAllProposals groupId let cid = convId conv - for_ (conv & mlsMetadata <&> cnvmlsGroupId) $ \gidParent -> do + for_ (conv & mlsMetadata <&> cnvmlsGroupId . fst) $ \gidParent -> do sconvs <- E.listSubConversations cid gidSubs <- for (Map.assocs sconvs) $ \(subid, mlsData) -> do let gidSub = cnvmlsGroupId mlsData @@ -400,17 +401,24 @@ performAction tag origUser lconv action = do (bm, act) <- performConversationAccessData origUser lconv action pure (bm, act) SConversationUpdateProtocolTag -> do - case (protocolTag (convProtocol (tUnqualified lconv)), action) of - (ProtocolProteusTag, ProtocolMixedTag) -> do - E.updateToMixedProtocol lcnv MLS_128_DHKEMX25519_AES128GCM_SHA256_Ed25519 + case (protocolTag (convProtocol (tUnqualified lconv)), action, convTeam (tUnqualified lconv)) of + (ProtocolProteusTag, ProtocolMixedTag, Just _) -> do + mls <- E.updateToMixedProtocol lcnv MLS_128_DHKEMX25519_AES128GCM_SHA256_Ed25519 + E.runFederatedConcurrently_ (map rmId (convRemoteMembers conv)) $ \_ -> do + void $ + fedClient @'Galley @"on-new-remote-conversation" $ + NewRemoteConversation + { nrcConvId = convId conv, + nrcProtocol = ProtocolMixed mls + } pure (mempty, action) - (ProtocolProteusTag, ProtocolProteusTag) -> + (ProtocolProteusTag, ProtocolProteusTag, _) -> noChanges - (ProtocolMixedTag, ProtocolMixedTag) -> + (ProtocolMixedTag, ProtocolMixedTag, _) -> noChanges - (ProtocolMLSTag, ProtocolMLSTag) -> + (ProtocolMLSTag, ProtocolMLSTag, _) -> noChanges - (_, _) -> throwS @'ConvInvalidProtocolTransition + (_, _, _) -> throwS @'ConvInvalidProtocolTransition performConversationJoin :: ( HasConversationActionEffects 'ConversationJoinTag r diff --git a/services/galley/src/Galley/API/Federation.hs b/services/galley/src/Galley/API/Federation.hs index f5306229c7..4acb76390d 100644 --- a/services/galley/src/Galley/API/Federation.hs +++ b/services/galley/src/Galley/API/Federation.hs @@ -208,7 +208,7 @@ onNewRemoteConversation :: Sem r EmptyResponse onNewRemoteConversation domain nrc = do -- update group_id -> conv_id mapping - for_ (preview (to F.nrcProtocol . _ProtocolMLS) nrc) $ \mls -> + for_ (preview (to F.nrcProtocol . conversationMLSData) nrc) $ \mls -> E.setGroupIdForConversation (cnvmlsGroupId mls) (Qualified (F.nrcConvId nrc) domain) diff --git a/services/galley/src/Galley/API/MLS/Commit/Core.hs b/services/galley/src/Galley/API/MLS/Commit/Core.hs index 50eca037f1..9375dea2a7 100644 --- a/services/galley/src/Galley/API/MLS/Commit/Core.hs +++ b/services/galley/src/Galley/API/MLS/Commit/Core.hs @@ -96,16 +96,15 @@ getCommitData :: Sem r ProposalAction getCommitData senderIdentity lConvOrSub epoch commit = do let convOrSub = tUnqualified lConvOrSub - mlsMeta = mlsMetaConvOrSub convOrSub - groupId = cnvmlsGroupId mlsMeta + groupId = cnvmlsGroupId convOrSub.meta - evalState (indexMapConvOrSub convOrSub) $ do + evalState convOrSub.indexMap $ do creatorAction <- if epoch == Epoch 0 then addProposedClient senderIdentity else mempty - proposals <- traverse (derefOrCheckProposal mlsMeta groupId epoch) commit.proposals - action <- applyProposals mlsMeta groupId proposals + proposals <- traverse (derefOrCheckProposal convOrSub.meta groupId epoch) commit.proposals + action <- applyProposals convOrSub.meta groupId proposals pure (creatorAction <> action) incrementEpoch :: diff --git a/services/galley/src/Galley/API/MLS/Commit/ExternalCommit.hs b/services/galley/src/Galley/API/MLS/Commit/ExternalCommit.hs index edb792d932..03321be6f4 100644 --- a/services/galley/src/Galley/API/MLS/Commit/ExternalCommit.hs +++ b/services/galley/src/Galley/API/MLS/Commit/ExternalCommit.hs @@ -69,9 +69,8 @@ getExternalCommitData :: Sem r ExternalCommitAction getExternalCommitData senderIdentity lConvOrSub epoch commit = do let convOrSub = tUnqualified lConvOrSub - mlsMeta = mlsMetaConvOrSub convOrSub - curEpoch = cnvmlsEpoch mlsMeta - groupId = cnvmlsGroupId mlsMeta + curEpoch = cnvmlsEpoch convOrSub.meta + groupId = cnvmlsGroupId convOrSub.meta when (epoch /= curEpoch) $ throwS @'MLSStaleMessage proposals <- traverse getInlineProposal commit.proposals @@ -90,9 +89,9 @@ getExternalCommitData senderIdentity lConvOrSub epoch commit = do unless (null (Map.keys counts \\ allowedProposals)) $ throw (mlsProtocolError "Invalid proposal type in an external commit") - evalState (indexMapConvOrSub convOrSub) $ do + evalState convOrSub.indexMap $ do -- process optional removal - propAction <- applyProposals mlsMeta groupId proposals + propAction <- applyProposals convOrSub.meta groupId proposals removedIndex <- case cmAssocs (paRemove propAction) of [(cid, idx)] | cid /= senderIdentity -> @@ -144,8 +143,8 @@ processExternalCommit senderIdentity lConvOrSub epoch action updatePath = do <$> note (mlsProtocolError "External commits need an update path") updatePath - let cs = cnvmlsCipherSuite (mlsMetaConvOrSub (tUnqualified lConvOrSub)) - let groupId = cnvmlsGroupId (mlsMetaConvOrSub convOrSub) + let cs = cnvmlsCipherSuite (tUnqualified lConvOrSub).meta + let groupId = cnvmlsGroupId convOrSub.meta let extra = LeafNodeTBSExtraCommit groupId action.add case validateLeafNode cs (Just senderIdentity) extra leafNode.value of Left errMsg -> @@ -153,7 +152,7 @@ processExternalCommit senderIdentity lConvOrSub epoch action updatePath = do mlsProtocolError ("Tried to add invalid LeafNode: " <> errMsg) Right _ -> pure () - withCommitLock (fmap idForConvOrSub lConvOrSub) groupId epoch $ do + withCommitLock (fmap (.id) lConvOrSub) groupId epoch $ do executeExternalCommitAction lConvOrSub senderIdentity action -- increment epoch number @@ -166,12 +165,11 @@ processExternalCommit senderIdentity lConvOrSub epoch action updatePath = do <$> getPendingBackendRemoveProposals groupId epoch -- requeue backend remove proposals for the current epoch - let cm = membersConvOrSub (tUnqualified lConvOrSub') createAndSendRemoveProposals lConvOrSub' indicesInRemoveProposals (cidQualifiedUser senderIdentity) - cm + (tUnqualified lConvOrSub').members executeExternalCommitAction :: forall r. @@ -181,7 +179,7 @@ executeExternalCommitAction :: ExternalCommitAction -> Sem r () executeExternalCommitAction lconvOrSub senderIdentity action = do - let mlsMeta = mlsMetaConvOrSub $ tUnqualified lconvOrSub + let mlsMeta = (tUnqualified lconvOrSub).meta -- Remove deprecated sender client from conversation state. for_ action.remove $ \_ -> diff --git a/services/galley/src/Galley/API/MLS/Commit/InternalCommit.hs b/services/galley/src/Galley/API/MLS/Commit/InternalCommit.hs index 11f6092aa1..cc097c92b5 100644 --- a/services/galley/src/Galley/API/MLS/Commit/InternalCommit.hs +++ b/services/galley/src/Galley/API/MLS/Commit/InternalCommit.hs @@ -77,135 +77,137 @@ processInternalCommit :: Sem r [LocalConversationUpdate] processInternalCommit senderIdentity con lConvOrSub epoch action commit = do let convOrSub = tUnqualified lConvOrSub - mlsMeta = mlsMetaConvOrSub convOrSub qusr = cidQualifiedUser senderIdentity - cm = membersConvOrSub convOrSub - ss = csSignatureScheme (cnvmlsCipherSuite mlsMeta) + cm = convOrSub.members + ss = csSignatureScheme (cnvmlsCipherSuite convOrSub.meta) newUserClients = Map.assocs (paAdd action) -- check all pending proposals are referenced in the commit - allPendingProposals <- getAllPendingProposalRefs (cnvmlsGroupId mlsMeta) epoch + allPendingProposals <- getAllPendingProposalRefs (cnvmlsGroupId convOrSub.meta) epoch let referencedProposals = Set.fromList $ mapMaybe (\x -> preview Proposal._Ref x) commit.proposals unless (all (`Set.member` referencedProposals) allPendingProposals) $ throwS @'MLSCommitMissingReferences - withCommitLock (fmap idForConvOrSub lConvOrSub) (cnvmlsGroupId (mlsMetaConvOrSub convOrSub)) epoch $ do - -- FUTUREWORK: remove this check after remote admins are implemented in federation https://wearezeta.atlassian.net/browse/FS-216 - foldQualified lConvOrSub (\_ -> pure ()) (\_ -> throwS @'MLSUnsupportedProposal) qusr - + withCommitLock (fmap (.id) lConvOrSub) (cnvmlsGroupId convOrSub.meta) epoch $ do -- no client can be directly added to a subconversation when (is _SubConv convOrSub && any ((senderIdentity /=) . fst) (cmAssocs (paAdd action))) $ throw (mlsProtocolError "Add proposals in subconversations are not supported") - -- Note [client removal] - -- We support two types of removals: - -- 1. when a user is removed from a group, all their clients have to be removed - -- 2. when a client is deleted, that particular client (but not necessarily - -- other clients of the same user) has to be removed. - -- - -- 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. - -- - -- Furthermore, subconversation clients can be removed arbitrarily, so this - -- processing is only necessary for main conversations. In the - -- subconversation case, an empty list is returned. - membersToRemove <- case convOrSub of - SubConv _ _ -> pure [] - Conv _ -> mapMaybe hush <$$> for (Map.assocs (paRemove action)) $ - \(qtarget, Map.keysSet -> clients) -> runError @() $ do - let clientsInConv = Map.keysSet (Map.findWithDefault mempty qtarget cm) - let removedClients = Set.intersection clients clientsInConv + events <- + if convOrSub.migrationState == MLSMigrationMLS + then do + -- Note [client removal] + -- We support two types of removals: + -- 1. when a user is removed from a group, all their clients have to be removed + -- 2. when a client is deleted, that particular client (but not necessarily + -- other clients of the same user) has to be removed. + -- + -- 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. + -- + -- Furthermore, subconversation clients can be removed arbitrarily, so this + -- processing is only necessary for main conversations. In the + -- subconversation case, an empty list is returned. + membersToRemove <- case convOrSub of + SubConv _ _ -> pure [] + Conv _ -> mapMaybe hush <$$> for (Map.assocs (paRemove action)) $ + \(qtarget, Map.keysSet -> clients) -> runError @() $ do + let clientsInConv = Map.keysSet (Map.findWithDefault mempty qtarget cm) + let removedClients = Set.intersection clients clientsInConv + + -- ignore user if none of their clients are being removed + when (Set.null removedClients) $ throw () + + -- return error if the user is trying to remove themself + when (cidQualifiedUser senderIdentity == qtarget) $ + throwS @'MLSSelfRemovalNotAllowed + + -- FUTUREWORK: add tests against this situation for conv v subconv + when (removedClients /= clientsInConv) $ do + -- FUTUREWORK: turn this error into a proper response + throwS @'MLSClientMismatch - -- ignore user if none of their clients are being removed - when (Set.null removedClients) $ throw () + pure qtarget - -- return error if the user is trying to remove themself - when (cidQualifiedUser senderIdentity == qtarget) $ - throwS @'MLSSelfRemovalNotAllowed + -- 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 = Map.keysSet (newclients <> Map.findWithDefault mempty qtarget cm) + -- get list of mls clients from brig + clientInfo <- getClientInfo lConvOrSub 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 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 + -- unless (Set.isSubsetOf allClients clients) $ do + -- FUTUREWORK: turn this error into a proper response + throwS @'MLSClientMismatch - -- FUTUREWORK: add tests against this situation for conv v subconv - when (removedClients /= clientsInConv) $ do - -- FUTUREWORK: turn this error into a proper response - throwS @'MLSClientMismatch + -- remove users from the conversation and send events + removeEvents <- + foldMap + (removeMembers qusr con lConvOrSub) + (nonEmpty membersToRemove) - pure qtarget + -- if this is a new subconversation, call `on-new-remote-conversation` on all + -- the remote backends involved in the main conversation + forOf_ _SubConv convOrSub $ \(mlsConv, subConv) -> do + when (cnvmlsEpoch (scMLSData subConv) == Epoch 0) $ do + let remoteDomains = + Set.fromList + ( map + (void . rmId) + (mcRemoteMembers mlsConv) + ) + let nrc = + NewRemoteSubConversation + { nrscConvId = mcId mlsConv, + nrscSubConvId = scSubConvId subConv, + nrscMlsData = scMLSData subConv + } + runFederatedConcurrently_ (toList remoteDomains) $ \_ -> do + void $ fedClient @'Galley @"on-new-remote-subconversation" nrc - -- 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 = Map.keysSet (newclients <> Map.findWithDefault mempty qtarget cm) - -- get list of mls clients from brig - clientInfo <- getClientInfo lConvOrSub 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 - -- unless (Set.isSubsetOf allClients clients) $ do - -- FUTUREWORK: turn this error into a proper response - throwS @'MLSClientMismatch + -- add users to the conversation and send events + addEvents <- + foldMap (addMembers qusr con lConvOrSub) + . nonEmpty + . map fst + $ newUserClients - -- remove users from the conversation and send events - removeEvents <- - foldMap - (removeMembers qusr con lConvOrSub) - (nonEmpty membersToRemove) + pure (addEvents <> removeEvents) + else pure [] -- Remove clients from the conversation state. This includes client removals -- of all types (see Note [client removal]). for_ (Map.assocs (paRemove action)) $ \(qtarget, clients) -> do - removeMLSClients (cnvmlsGroupId mlsMeta) qtarget (Map.keysSet clients) - - -- if this is a new subconversation, call `on-new-remote-conversation` on all - -- the remote backends involved in the main conversation - forOf_ _SubConv convOrSub $ \(mlsConv, subConv) -> do - when (cnvmlsEpoch (scMLSData subConv) == Epoch 0) $ do - let remoteDomains = - Set.fromList - ( map - (void . rmId) - (mcRemoteMembers mlsConv) - ) - let nrc = - NewRemoteSubConversation - { nrscConvId = mcId mlsConv, - nrscSubConvId = scSubConvId subConv, - nrscMlsData = scMLSData subConv - } - runFederatedConcurrently_ (toList remoteDomains) $ \_ -> do - void $ fedClient @'Galley @"on-new-remote-subconversation" nrc - - -- add users to the conversation and send events - addEvents <- - foldMap (addMembers qusr con lConvOrSub) - . nonEmpty - . map fst - $ newUserClients + removeMLSClients (cnvmlsGroupId convOrSub.meta) qtarget (Map.keysSet clients) -- add clients in the conversation state for_ newUserClients $ \(qtarget, newClients) -> do - addMLSClients (cnvmlsGroupId mlsMeta) qtarget (Set.fromList (Map.assocs newClients)) + addMLSClients (cnvmlsGroupId convOrSub.meta) qtarget (Set.fromList (Map.assocs newClients)) -- increment epoch number for_ lConvOrSub incrementEpoch - pure (addEvents <> removeEvents) + pure events addMembers :: HasProposalActionEffects r => diff --git a/services/galley/src/Galley/API/MLS/Conversation.hs b/services/galley/src/Galley/API/MLS/Conversation.hs index 5d91d1e4ba..7d38a77657 100644 --- a/services/galley/src/Galley/API/MLS/Conversation.hs +++ b/services/galley/src/Galley/API/MLS/Conversation.hs @@ -33,7 +33,7 @@ mkMLSConversation :: Data.Conversation -> Sem r (Maybe MLSConversation) mkMLSConversation conv = - for (Data.mlsMetadata conv) $ \mlsData -> do + for (Data.mlsMetadata conv) $ \(mlsData, migrationState) -> do (cm, im) <- lookupMLSClientLeafIndices (cnvmlsGroupId mlsData) pure MLSConversation @@ -43,7 +43,8 @@ mkMLSConversation conv = mcRemoteMembers = Data.convRemoteMembers conv, mcMLSData = mlsData, mcMembers = cm, - mcIndexMap = im + mcIndexMap = im, + mcMigrationState = migrationState } mcConv :: MLSConversation -> Data.Conversation diff --git a/services/galley/src/Galley/API/MLS/Message.hs b/services/galley/src/Galley/API/MLS/Message.hs index c8facdd7c2..65066ed6ef 100644 --- a/services/galley/src/Galley/API/MLS/Message.hs +++ b/services/galley/src/Galley/API/MLS/Message.hs @@ -45,6 +45,7 @@ import Galley.API.MLS.Types import Galley.API.MLS.Util import Galley.API.MLS.Welcome (sendWelcomes) import Galley.API.Util +import Galley.Data.Conversation.Types import Galley.Effects import Galley.Effects.ConversationStore import Galley.Effects.FederatorAccess @@ -218,10 +219,9 @@ postMLSCommitBundleToLocalConv qusr c conn bundle lConvOrSubId = do bundle.commit.value.path pure ([], []) - storeGroupInfo (idForConvOrSub . tUnqualified $ lConvOrSub) bundle.groupInfo + storeGroupInfo (tUnqualified lConvOrSub).id bundle.groupInfo - let cm = membersConvOrSub (tUnqualified lConvOrSub) - unreachables <- propagateMessage qusr lConvOrSub conn bundle.rawMessage cm + unreachables <- propagateMessage qusr lConvOrSub conn bundle.rawMessage (tUnqualified lConvOrSub).members traverse_ (sendWelcomes lConvOrSub conn newClients) bundle.welcome pure (events, unreachables) @@ -250,7 +250,7 @@ postMLSCommitBundleToRemoteConv loc qusr c con bundle rConvOrSubId = do lusr <- foldQualified loc pure (\_ -> throwS @'ConvAccessDenied) qusr -- only members may send commit bundles to a remote conversation - flip unless (throwS @'ConvMemberNotFound) =<< checkLocalMemberRemoteConv (tUnqualified lusr) (convOfConvOrSub <$> rConvOrSubId) + flip unless (throwS @'ConvMemberNotFound) =<< checkLocalMemberRemoteConv (tUnqualified lusr) ((.conv) <$> rConvOrSubId) resp <- runFederated rConvOrSubId $ @@ -314,11 +314,10 @@ getSenderIdentity :: Sem r ClientIdentity getSenderIdentity qusr c mSender lConvOrSubConv = do let cid = mkClientIdentity qusr c - let idxMap = indexMapConvOrSub $ tUnqualified lConvOrSubConv - let epoch = epochNumber . cnvmlsEpoch . mlsMetaConvOrSub . tUnqualified $ lConvOrSubConv + let epoch = epochNumber . cnvmlsEpoch . (.meta) . tUnqualified $ lConvOrSubConv case mSender of SenderMember idx | epoch > 0 -> do - cid' <- note (mlsProtocolError "unknown sender leaf index") $ imLookup idxMap idx + cid' <- note (mlsProtocolError "unknown sender leaf index") $ imLookup (tUnqualified lConvOrSubConv).indexMap idx unless (cid' == cid) $ throwS @'MLSClientSenderUserMismatch _ -> pure () pure cid @@ -350,10 +349,11 @@ postMLSMessageToLocalConv qusr c con msg convOrSubId = do FramedContentApplicationData _ -> throwS @'MLSUnsupportedMessage FramedContentProposal prop -> processProposal qusr lConvOrSub msg.groupId msg.epoch pub prop - IncomingMessageContentPrivate -> pure () + IncomingMessageContentPrivate -> do + when ((tUnqualified lConvOrSub).migrationState == MLSMigrationMixed) $ + throwS @'MLSUnsupportedMessage - let cm = membersConvOrSub (tUnqualified lConvOrSub) - unreachables <- propagateMessage qusr lConvOrSub con msg.rawMessage cm + unreachables <- propagateMessage qusr lConvOrSub con msg.rawMessage (tUnqualified lConvOrSub).members pure ([], unreachables) postMLSMessageToRemoteConv :: @@ -374,7 +374,7 @@ postMLSMessageToRemoteConv loc qusr senderClient con msg rConvOrSubId = do -- only local users can send messages to remote conversations lusr <- foldQualified loc pure (\_ -> throwS @'ConvAccessDenied) qusr -- only members may send messages to the remote conversation - flip unless (throwS @'ConvMemberNotFound) =<< checkLocalMemberRemoteConv (tUnqualified lusr) (convOfConvOrSub <$> rConvOrSubId) + flip unless (throwS @'ConvMemberNotFound) =<< checkLocalMemberRemoteConv (tUnqualified lusr) ((.conv) <$> rConvOrSubId) resp <- runFederated rConvOrSubId $ diff --git a/services/galley/src/Galley/API/MLS/Propagate.hs b/services/galley/src/Galley/API/MLS/Propagate.hs index 177fb57c4f..a74a8b6cfa 100644 --- a/services/galley/src/Galley/API/MLS/Propagate.hs +++ b/services/galley/src/Galley/API/MLS/Propagate.hs @@ -65,7 +65,7 @@ propagateMessage :: Sem r (Maybe UnreachableUsers) propagateMessage qusr lConvOrSub con msg cm = do now <- input @UTCTime - let mlsConv = convOfConvOrSub <$> lConvOrSub + let mlsConv = (.conv) <$> lConvOrSub lmems = mcLocalMembers . tUnqualified $ mlsConv rmems = mcRemoteMembers . tUnqualified $ mlsConv botMap = Map.fromList $ do diff --git a/services/galley/src/Galley/API/MLS/Proposal.hs b/services/galley/src/Galley/API/MLS/Proposal.hs index 437e1cba42..652df873e3 100644 --- a/services/galley/src/Galley/API/MLS/Proposal.hs +++ b/services/galley/src/Galley/API/MLS/Proposal.hs @@ -239,7 +239,7 @@ processProposal :: RawMLS Proposal -> Sem r () processProposal qusr lConvOrSub groupId epoch pub prop = do - let mlsMeta = mlsMetaConvOrSub (tUnqualified lConvOrSub) + let mlsMeta = (tUnqualified lConvOrSub).meta -- Check if the epoch number matches that of a conversation unless (epoch == cnvmlsEpoch mlsMeta) $ throwS @'MLSStaleMessage -- Check if the group ID matches that of a conversation @@ -247,8 +247,7 @@ processProposal qusr lConvOrSub groupId epoch pub prop = do let suiteTag = cnvmlsCipherSuite mlsMeta -- FUTUREWORK: validate the member's conversation role - let im = indexMapConvOrSub $ tUnqualified lConvOrSub - checkProposal mlsMeta im prop.value + checkProposal mlsMeta (tUnqualified lConvOrSub).indexMap prop.value when (isExternal pub.sender) $ checkExternalProposalUser qusr prop.value let propRef = authContentRef suiteTag (incomingMessageAuthenticatedContent pub) storeProposal groupId epoch propRef ProposalOriginClient prop diff --git a/services/galley/src/Galley/API/MLS/Removal.hs b/services/galley/src/Galley/API/MLS/Removal.hs index f801bf06b5..a7fdfc414f 100644 --- a/services/galley/src/Galley/API/MLS/Removal.hs +++ b/services/galley/src/Galley/API/MLS/Removal.hs @@ -74,7 +74,7 @@ createAndSendRemoveProposals :: ClientMap -> Sem r () createAndSendRemoveProposals lConvOrSubConv indices qusr cm = do - let meta = mlsMetaConvOrSub (tUnqualified lConvOrSubConv) + let meta = (tUnqualified lConvOrSubConv).meta mKeyPair <- getMLSRemovalKey case mKeyPair of Nothing -> do @@ -164,7 +164,7 @@ removeClient lc qusr c = do mMlsConv <- mkMLSConversation (tUnqualified lc) for_ mMlsConv $ \mlsConv -> do let cid = mkClientIdentity qusr c - let getClients = fmap (cid,) . cmLookupIndex cid . membersConvOrSub + let getClients = fmap (cid,) . cmLookupIndex cid . (.members) removeClientsWithClientMapRecursively (qualifyAs lc mlsConv) getClients qusr -- | Send remove proposals for all clients of the user to the local conversation. @@ -190,7 +190,7 @@ removeUser lc qusr = do map (first (mkClientIdentity qusr)) . Map.assocs . Map.findWithDefault mempty qusr - . membersConvOrSub + . (.members) removeClientsWithClientMapRecursively (qualifyAs lc mlsConv) getClients qusr -- | Convert cassandra subconv maps into SubConversations diff --git a/services/galley/src/Galley/API/MLS/SubConversation.hs b/services/galley/src/Galley/API/MLS/SubConversation.hs index 461836174d..ea9060b9d6 100644 --- a/services/galley/src/Galley/API/MLS/SubConversation.hs +++ b/services/galley/src/Galley/API/MLS/SubConversation.hs @@ -122,7 +122,12 @@ getLocalSubConversation qusr lconv sconv = do msub <- Eff.getSubConversation (tUnqualified lconv) sconv sub <- case msub of Nothing -> do - mlsMeta <- noteS @'ConvNotFound (mlsMetadata c) + (mlsMeta, mlsProtocol) <- noteS @'ConvNotFound (mlsMetadata c) + + case mlsProtocol of + MLSMigrationMixed -> throwS @'MLSSubConvUnsupportedConvType + MLSMigrationMLS -> pure () + -- deriving this detemernistically to prevent race condition between -- multiple threads creating the subconversation let groupId = initialGroupId lconv sconv @@ -281,7 +286,11 @@ deleteLocalSubConversation qusr lcnvId scnvId dsc = do let cnvId = tUnqualified lcnvId lConvOrSubId = qualifyAs lcnvId (SubConv cnvId scnvId) cnv <- getConversationAndCheckMembership qusr lcnvId - cs <- cnvmlsCipherSuite <$> noteS @'ConvNotFound (mlsMetadata cnv) + + (mlsMeta, _mlsProtocol) <- noteS @'ConvNotFound (mlsMetadata cnv) + + let cs = cnvmlsCipherSuite mlsMeta + (mlsData, oldGid) <- withCommitLock lConvOrSubId (dscGroupId dsc) (dscEpoch dsc) $ do sconv <- Eff.getSubConversation cnvId scnvId diff --git a/services/galley/src/Galley/API/MLS/Types.hs b/services/galley/src/Galley/API/MLS/Types.hs index 59cdbe327b..eda21c18cf 100644 --- a/services/galley/src/Galley/API/MLS/Types.hs +++ b/services/galley/src/Galley/API/MLS/Types.hs @@ -24,6 +24,8 @@ import Data.IntMap (IntMap) import qualified Data.IntMap as IntMap import qualified Data.Map as Map import Data.Qualified +import GHC.Records (HasField (..)) +import Galley.Data.Conversation.Types import Galley.Types.Conversations.Members import Imports import Wire.API.Conversation @@ -130,7 +132,8 @@ data MLSConversation = MLSConversation mcLocalMembers :: [LocalMember], mcRemoteMembers :: [RemoteMember], mcMembers :: ClientMap, - mcIndexMap :: IndexMap + mcIndexMap :: IndexMap, + mcMigrationState :: MLSMigrationState } deriving (Show) @@ -158,22 +161,22 @@ toPublicSubConv (Qualified (SubConversation {..}) domain) = type ConvOrSubConv = ConvOrSubChoice MLSConversation SubConversation -mlsMetaConvOrSub :: ConvOrSubConv -> ConversationMLSData -mlsMetaConvOrSub (Conv c) = mcMLSData c -mlsMetaConvOrSub (SubConv _ s) = scMLSData s +instance HasField "meta" ConvOrSubConv ConversationMLSData where + getField (Conv c) = mcMLSData c + getField (SubConv _ s) = scMLSData s -membersConvOrSub :: ConvOrSubConv -> ClientMap -membersConvOrSub (Conv c) = mcMembers c -membersConvOrSub (SubConv _ s) = scMembers s +instance HasField "members" ConvOrSubConv ClientMap where + getField (Conv c) = mcMembers c + getField (SubConv _ s) = scMembers s -indexMapConvOrSub :: ConvOrSubConv -> IndexMap -indexMapConvOrSub (Conv c) = mcIndexMap c -indexMapConvOrSub (SubConv _ s) = scIndexMap s +instance HasField "indexMap" ConvOrSubConv IndexMap where + getField (Conv c) = mcIndexMap c + getField (SubConv _ s) = scIndexMap s -convOfConvOrSub :: ConvOrSubChoice c s -> c -convOfConvOrSub (Conv c) = c -convOfConvOrSub (SubConv c _) = c +instance HasField "id" ConvOrSubConv ConvOrSubConvId where + getField (Conv c) = Conv (mcId c) + getField (SubConv c s) = SubConv (mcId c) (scSubConvId s) -idForConvOrSub :: ConvOrSubConv -> ConvOrSubConvId -idForConvOrSub (Conv c) = Conv (mcId c) -idForConvOrSub (SubConv c s) = SubConv (mcId c) (scSubConvId s) +instance HasField "migrationState" ConvOrSubConv MLSMigrationState where + getField (Conv c) = c.mcMigrationState + getField (SubConv _ _) = MLSMigrationMLS diff --git a/services/galley/src/Galley/Cassandra/Conversation.hs b/services/galley/src/Galley/Cassandra/Conversation.hs index 98000e9523..701a3f11ee 100644 --- a/services/galley/src/Galley/Cassandra/Conversation.hs +++ b/services/galley/src/Galley/Cassandra/Conversation.hs @@ -445,14 +445,22 @@ updateToMixedProtocol :: r => Local ConvId -> CipherSuiteTag -> - Sem r () -updateToMixedProtocol lcnv cs = + Sem r ConversationMLSData +updateToMixedProtocol lcnv cs = do + let gid = convToGroupId lcnv + epoch = Epoch 0 embedClient . retry x5 . batch $ do setType BatchLogged setConsistency LocalQuorum - let gid = convToGroupId lcnv addPrepQuery Cql.insertGroupIdForConversation (gid, tUnqualified lcnv, tDomain lcnv) - addPrepQuery Cql.updateToMixedConv (tUnqualified lcnv, ProtocolMixedTag, gid, Epoch 0, cs) + addPrepQuery Cql.updateToMixedConv (tUnqualified lcnv, ProtocolMixedTag, gid, epoch, cs) + pure + ConversationMLSData + { cnvmlsGroupId = gid, + cnvmlsEpoch = epoch, + cnvmlsEpochTimestamp = Nothing, + cnvmlsCipherSuite = cs + } interpretConversationStoreToCassandra :: ( Member (Embed IO) r, diff --git a/services/galley/src/Galley/Data/Conversation/Types.hs b/services/galley/src/Galley/Data/Conversation/Types.hs index edff99fa5c..beacb1b30b 100644 --- a/services/galley/src/Galley/Data/Conversation/Types.hs +++ b/services/galley/src/Galley/Data/Conversation/Types.hs @@ -44,9 +44,14 @@ data NewConversation = NewConversation ncProtocol :: ProtocolCreateTag } -mlsMetadata :: Conversation -> Maybe ConversationMLSData +data MLSMigrationState + = MLSMigrationMixed + | MLSMigrationMLS + deriving (Show, Eq, Ord) + +mlsMetadata :: Conversation -> Maybe (ConversationMLSData, MLSMigrationState) mlsMetadata conv = case convProtocol conv of ProtocolProteus -> Nothing - ProtocolMLS meta -> pure meta - ProtocolMixed meta -> pure meta + ProtocolMLS meta -> pure (meta, MLSMigrationMLS) + ProtocolMixed meta -> pure (meta, MLSMigrationMixed) diff --git a/services/galley/src/Galley/Effects/ConversationStore.hs b/services/galley/src/Galley/Effects/ConversationStore.hs index fe47bb376c..d5bb268f99 100644 --- a/services/galley/src/Galley/Effects/ConversationStore.hs +++ b/services/galley/src/Galley/Effects/ConversationStore.hs @@ -71,8 +71,8 @@ import Galley.Types.Conversations.Members import Imports import Polysemy import Wire.API.Conversation hiding (Conversation, Member) +import Wire.API.Conversation.Protocol import Wire.API.MLS.CipherSuite (CipherSuiteTag) -import Wire.API.MLS.Epoch import Wire.API.MLS.GroupInfo import Wire.API.MLS.SubConversation @@ -107,7 +107,7 @@ data ConversationStore m a where AcquireCommitLock :: GroupId -> Epoch -> NominalDiffTime -> ConversationStore m LockAcquired ReleaseCommitLock :: GroupId -> Epoch -> ConversationStore m () DeleteGroupIds :: [GroupId] -> ConversationStore m () - UpdateToMixedProtocol :: Local ConvId -> CipherSuiteTag -> ConversationStore m () + UpdateToMixedProtocol :: Local ConvId -> CipherSuiteTag -> ConversationStore m ConversationMLSData makeSem ''ConversationStore diff --git a/services/galley/test/integration/API/MLS.hs b/services/galley/test/integration/API/MLS.hs index 791fb54a6f..a3d746d79a 100644 --- a/services/galley/test/integration/API/MLS.hs +++ b/services/galley/test/integration/API/MLS.hs @@ -100,7 +100,6 @@ tests s = testGroup "Commit" [ test s "add user (not connected)" testAddUserNotConnected, - test s "add user (partial client list)" testAddUserPartial, test s "add client of existing user" testAddClientPartial, test s "add user with some non-MLS clients" testAddUserWithProteusClients, test s "send a stale commit" testStaleCommit, @@ -109,8 +108,7 @@ tests s = test s "add user to a conversation with proposal + commit" testAddUserBareProposalCommit, test s "post commit that references an unknown proposal" testUnknownProposalRefCommit, test s "post commit that is not referencing all proposals" testCommitNotReferencingAllProposals, - test s "admin removes user from a conversation" testAdminRemovesUserFromConv, - test s "admin removes user from a conversation but doesn't list all clients" testRemoveClientsIncomplete + test s "admin removes user from a conversation" testAdminRemovesUserFromConv ], testGroup "External commit" @@ -187,8 +185,7 @@ tests s = testGroup "CommitBundle" [ test s "add user with a commit bundle" testAddUserWithBundle, - test s "add user with a commit bundle to a remote conversation" testAddUserToRemoteConvWithBundle, - test s "remote user posts commit bundle" testRemoteUserPostsCommitBundle + test s "add user with a commit bundle to a remote conversation" testAddUserToRemoteConvWithBundle ], testGroup "Self conversation" @@ -252,10 +249,6 @@ tests s = "Remote Sender/Remote SubConversation" [ test s "on-mls-message-sent in subconversation" testRemoteToRemoteInSub ] - ], - testGroup - "MixedProtocol" - [ test s "Add clients to a mixed conversation and send proteus message" testMixedAddClients ] ] @@ -415,34 +408,6 @@ testAddUserWithProteusClients = do void $ setupMLSGroup alice1 void $ createAddCommit alice1 [bob] >>= sendAndConsumeCommitBundle -testAddUserPartial :: TestM () -testAddUserPartial = do - [alice, bob, charlie] <- createAndConnectUsers (replicate 3 Nothing) - - runMLSTest $ do - -- Bob has 3 clients, Charlie has 2 - alice1 <- createMLSClient alice - bobClients@[_bob1, _bob2, bob3] <- replicateM 3 (createMLSClient bob) - charlieClients <- replicateM 2 (createMLSClient charlie) - - -- Only the first 2 clients of Bob's have uploaded key packages - traverse_ uploadNewKeyPackage (take 2 bobClients <> charlieClients) - - -- alice adds bob's first 2 clients - void $ setupMLSGroup alice1 - commit <- createAddCommit alice1 [bob, charlie] - - -- before alice can commit, bob3 uploads a key package - void $ uploadNewKeyPackage bob3 - - -- alice sends a commit now, and should get a conflict error - bundle <- createBundle commit - err <- - responseJsonError - =<< localPostCommitBundle (mpSender commit) bundle - >= sendAndConsumeCommitBundle - commit <- createRemoveCommit alice1 [bob1] - - bundle <- createBundle commit - err <- - responseJsonError - =<< localPostCommitBundle alice1 bundle - welcomeMock - withTempMockFederator' mock $ do - void $ sendAndConsumeCommitBundle commit - putOtherMemberQualified (qUnqualified alice) bob (OtherMemberUpdate (Just roleNameWireAdmin)) qcnv - !!! const 200 === statusCode - - [_charlie1] <- traverse createMLSClient [charlie] - commitAddCharlie <- createAddCommit bob1 [charlie] - commitBundle <- createBundle commitAddCharlie - - let msr = - MLSMessageSendRequest - { mmsrConvOrSubId = Conv (qUnqualified qcnv), - mmsrSender = qUnqualified bob, - mmsrSenderClient = ciClient bob1, - mmsrRawMessage = Base64ByteString commitBundle - } - - -- we can't fully test it, because remote admins are not implemeted, but - -- at least this proves that proposal processing has started on the - -- backend - MLSMessageResponseError MLSUnsupportedProposal <- runFedClient @"send-mls-commit-bundle" fedGalleyClient (Domain bobDomain) msr - - pure () - -- | The MLS self-conversation should be available even without explicitly -- creating it by calling `GET /conversations/mls-self` starting from version 3 -- of the client API and should not be listed in versions less than 3. @@ -3345,49 +3256,3 @@ testCreatorRemovesUserFromParent = do ) (sort [alice1, charlie1, charlie2]) (sort $ pscMembers sub2) - -testMixedAddClients :: TestM () -testMixedAddClients = do - [alice, bob, charlie] <- createAndConnectUsers (replicate 3 Nothing) - - runMLSTest $ do - clients@[alice1, bob1, charlie1] <- traverse createMLSClient [alice, bob, charlie] - traverse_ uploadNewKeyPackage clients - - -- alice creates conv - qcnv <- - cnvQualifiedId - <$> liftTest - ( postConvQualified (qUnqualified alice) Nothing defNewProteusConv {newConvQualifiedUsers = [bob, charlie]} - >>= responseJsonError - ) - - -- bob upgrades to mixed - putConversationProtocol (qUnqualified bob) (ciClient bob1) qcnv ProtocolMixedTag - !!! const 200 === statusCode - - conv <- - responseJsonError - =<< getConvQualified (qUnqualified alice) qcnv - do - void $ sendAndConsumeCommitBundle commit - for_ (zip [alice1, charlie1] wss) $ \(c, ws) -> - WS.assertMatch (5 # Second) ws $ - wsAssertMLSWelcome (cidQualifiedUser c) welcome - - -- charlie sends a Proteus message - let msgs = - [ (qUnqualified alice, ciClient alice1, toBase64Text "ciphertext-to-alice"), - (qUnqualified bob, ciClient bob1, toBase64Text "ciphertext-to-bob") - ] - liftTest $ - postOtrMessage id (qUnqualified charlie) (ciClient charlie1) (qUnqualified qcnv) msgs !!! do - const 201 === statusCode - assertMismatch [] [] [] diff --git a/services/galley/test/integration/API/Util.hs b/services/galley/test/integration/API/Util.hs index a79b76b1de..2e072039fc 100644 --- a/services/galley/test/integration/API/Util.hs +++ b/services/galley/test/integration/API/Util.hs @@ -77,7 +77,6 @@ import Federator.MockServer import qualified Federator.MockServer as Mock import GHC.TypeLits (KnownSymbol) import GHC.TypeNats -import Galley.API.MLS.Types import Galley.Intra.User (chunkify) import qualified Galley.Options as Opts import qualified Galley.Run as Run @@ -1729,7 +1728,7 @@ assertMLSMessageEvent :: Conv.Event -> IO () assertMLSMessageEvent qcs u message e = do - evtConv e @?= convOfConvOrSub <$> qcs + evtConv e @?= (.conv) <$> qcs case qUnqualified qcs of Conv _ -> pure () SubConv _ subconvId -> @@ -2917,7 +2916,7 @@ wsAssertBackendRemoveProposal :: HasCallStack => Qualified UserId -> Qualified C wsAssertBackendRemoveProposal fromUser cnvOrSubCnv idx n = do let e = List1.head (WS.unpackPayload n) ntfTransient n @?= False - evtConv e @?= convOfConvOrSub <$> cnvOrSubCnv + evtConv e @?= (.conv) <$> cnvOrSubCnv evtType e @?= MLSMessageAdd evtFrom e @?= fromUser let bs = getMLSMessageData (evtData e)