From 9f2cc8b1b471bd8cfcbe1a15e96be9fbb2b4887c Mon Sep 17 00:00:00 2001 From: Paolo Capriotti Date: Fri, 19 May 2023 09:22:14 +0200 Subject: [PATCH] Only allow protocol updates for team conversations --- integration/test/API/GalleyInternal.hs | 4 +- integration/test/SetupHelpers.hs | 18 ++-- integration/test/Test/B2B.hs | 2 +- integration/test/Test/Brig.hs | 4 +- integration/test/Test/Demo.hs | 20 ++--- integration/test/Test/MLS.hs | 102 ++++++++++++++++------- integration/test/Test/MLS/KeyPackage.hs | 2 +- integration/test/Testlib/App.hs | 9 +- integration/test/Testlib/Cannon.hs | 4 +- integration/test/Testlib/ModService.hs | 3 +- integration/test/Testlib/PTest.hs | 9 -- services/galley/src/Galley/API/Action.hs | 12 +-- 12 files changed, 112 insertions(+), 77 deletions(-) diff --git a/integration/test/API/GalleyInternal.hs b/integration/test/API/GalleyInternal.hs index 56e811626af..0fb4eb2e184 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/SetupHelpers.hs b/integration/test/SetupHelpers.hs index a46e8e8cc52..fe79d18a7ac 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 48267add7ec..ba9df150f59 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 170017c8f8b..f1c8e9664e2 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 63d663c0458..dbdc984f4a1 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 67c18ea46b1..ccae2aee932 100644 --- a/integration/test/Test/MLS.hs +++ b/integration/test/Test/MLS.hs @@ -13,12 +13,21 @@ import Testlib.Prelude testMixedProtocolUpgrade :: HasCallStack => Domain -> App () testMixedProtocolUpgrade secondDomain = do - [alice, bob, charlie] <- do - d <- ownDomain - d2 <- secondDomain & asString - createAndConnectUsers [d, d2, d2] - - qcnv <- postConversation alice defProteus {qualifiedUsers = [bob, charlie]} >>= getJSON 201 + (alice, tid) <- createTeam OwnDomain + [bob, charlie] <- replicateM 2 (randomUser secondDomain def) + connectUsers [alice, bob, charlie] + + 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 @@ -37,14 +46,31 @@ 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, bob] <- do - d <- ownDomain - d2 <- secondDomain & asString - createAndConnectUsers [d, d2] + (alice, tid) <- createTeam OwnDomain + [bob, charlie] <- replicateM 2 (randomUser secondDomain def) + connectUsers [alice, bob, charlie] - qcnv <- postConversation alice defProteus {qualifiedUsers = [bob]} >>= getJSON 201 + qcnv <- + postConversation alice defProteus {qualifiedUsers = [bob], team = Just tid} + >>= getJSON 201 bindResponse (putConversationProtocol bob qcnv "mixed") $ \resp -> do resp.status `shouldMatchInt` 200 @@ -67,9 +93,13 @@ testMixedProtocolAddUsers secondDomain = do testMixedProtocolUserLeaves :: HasCallStack => Domain -> App () testMixedProtocolUserLeaves secondDomain = do - [alice, bob] <- createAndConnectUsers [ownDomain, secondDomain & asString] + (alice, tid) <- createTeam OwnDomain + bob <- randomUser secondDomain def + connectUsers [alice, bob] - qcnv <- postConversation alice defProteus {qualifiedUsers = [bob]} >>= getJSON 201 + qcnv <- + postConversation alice defProteus {qualifiedUsers = [bob], team = Just tid} + >>= getJSON 201 bindResponse (putConversationProtocol bob qcnv "mixed") $ \resp -> do resp.status `shouldMatchInt` 200 @@ -98,9 +128,13 @@ testMixedProtocolUserLeaves secondDomain = do testMixedProtocolAddPartialClients :: HasCallStack => Domain -> App () testMixedProtocolAddPartialClients secondDomain = do - [alice, bob] <- createAndConnectUsers [ownDomain, secondDomain & asString] + (alice, tid) <- createTeam OwnDomain + bob <- randomUser secondDomain def + connectUsers [alice, bob] - qcnv <- postConversation alice defProteus {qualifiedUsers = [bob]} >>= getJSON 201 + qcnv <- + postConversation alice defProteus {qualifiedUsers = [bob], team = Just tid} + >>= getJSON 201 bindResponse (putConversationProtocol bob qcnv "mixed") $ \resp -> do resp.status `shouldMatchInt` 200 @@ -122,20 +156,24 @@ testMixedProtocolAddPartialClients secondDomain = do 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 + -- 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] - isBobRemote <- secondDomain `isEqual` otherDomain + isBobRemote <- secondDomain `isEqual` OtherDomain void $ postMLSCommitBundle mp.sender (mkBundle mp) >>= getJSON (if isBobRemote then 404 else 201) testMixedProtocolRemovePartialClients :: HasCallStack => Domain -> App () testMixedProtocolRemovePartialClients secondDomain = do - [alice, bob] <- createAndConnectUsers [ownDomain, secondDomain & asString] + (alice, tid) <- createTeam OwnDomain + bob <- randomUser secondDomain def + connectUsers [alice, bob] - qcnv <- postConversation alice defProteus {qualifiedUsers = [bob]} >>= getJSON 201 + qcnv <- + postConversation alice defProteus {qualifiedUsers = [bob], team = Just tid} + >>= getJSON 201 bindResponse (putConversationProtocol bob qcnv "mixed") $ \resp -> do resp.status `shouldMatchInt` 200 @@ -154,9 +192,13 @@ testMixedProtocolRemovePartialClients secondDomain = do testMixedProtocolAppMessagesAreDenied :: HasCallStack => Domain -> App () testMixedProtocolAppMessagesAreDenied secondDomain = do - [alice, bob] <- createAndConnectUsers [ownDomain, secondDomain & asString] + (alice, tid) <- createTeam OwnDomain + bob <- randomUser secondDomain def + connectUsers [alice, bob] - qcnv <- postConversation alice defProteus {qualifiedUsers = [bob]} >>= getJSON 201 + qcnv <- + postConversation alice defProteus {qualifiedUsers = [bob], team = Just tid} + >>= getJSON 201 bindResponse (putConversationProtocol bob qcnv "mixed") $ \resp -> do resp.status `shouldMatchInt` 200 @@ -173,7 +215,7 @@ testMixedProtocolAppMessagesAreDenied secondDomain = do mp <- createApplicationMessage bob1 "hello, world" bindResponse (postMLSMessage mp.sender mp.message) $ \resp -> do - isBobRemote <- secondDomain `isEqual` otherDomain + isBobRemote <- secondDomain `isEqual` OtherDomain if isBobRemote then do resp.status `shouldMatchInt` 404 @@ -184,7 +226,7 @@ testMixedProtocolAppMessagesAreDenied secondDomain = do testAddUser :: HasCallStack => App () testAddUser = do - [alice, bob] <- createAndConnectUsers [ownDomain, ownDomain] + [alice, bob] <- createAndConnectUsers [OwnDomain, OwnDomain] [alice1, bob1, bob2] <- traverse createMLSClient [alice, bob, bob] @@ -214,7 +256,7 @@ testAddUser = do testCreateSubConv :: HasCallStack => App () testCreateSubConv = do - alice <- randomUser ownDomain def + alice <- randomUser OwnDomain def alice1 <- createMLSClient alice (_, conv) <- createNewGroup alice1 bindResponse (getSubConversation alice conv "conference") $ \resp -> do @@ -224,7 +266,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 @@ -236,7 +278,7 @@ 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 $ createSelfGroup creator @@ -254,7 +296,7 @@ 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) <- createNewGroup alice1 @@ -282,7 +324,7 @@ testJoinSubConv = do -- | FUTUREWORK: Don't allow partial adds, not even in the first commit testFirstCommitAllowsPartialAdds :: HasCallStack => App () testFirstCommitAllowsPartialAdds = do - alice <- randomUser ownDomain def + alice <- randomUser OwnDomain def [alice1, alice2, alice3] <- traverse createMLSClient [alice, alice, alice] traverse_ uploadNewKeyPackage [alice1, alice2, alice2, alice3, alice3] @@ -300,7 +342,7 @@ testFirstCommitAllowsPartialAdds = do testAddUserPartial :: HasCallStack => App () testAddUserPartial = do - [alice, bob, charlie] <- createAndConnectUsers (replicate 3 ownDomain) + [alice, bob, charlie] <- createAndConnectUsers (replicate 3 OwnDomain) -- Bob has 3 clients, Charlie has 2 alice1 <- createMLSClient alice @@ -328,7 +370,7 @@ testAddUserPartial = do -- | admin removes user from a conversation but doesn't list all clients testRemoveClientsIncomplete :: HasCallStack => App () testRemoveClientsIncomplete = do - [alice, bob] <- createAndConnectUsers [ownDomain, ownDomain] + [alice, bob] <- createAndConnectUsers [OwnDomain, OwnDomain] [alice1, bob1, bob2] <- traverse createMLSClient [alice, bob, bob] traverse_ uploadNewKeyPackage [bob1, bob2] diff --git a/integration/test/Test/MLS/KeyPackage.hs b/integration/test/Test/MLS/KeyPackage.hs index c6649c8838e..5ec25410f62 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 01c8fb168cc..72afcec4371 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 = String . T.pack <$> asks (.domain1) + make OtherDomain = String . T.pack <$> asks (.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/Cannon.hs b/integration/test/Testlib/Cannon.hs index 85a33b14e1c..414ddd37ba1 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/ModService.hs b/integration/test/Testlib/ModService.hs index 2acf740244c..ed9fab6eae7 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 02b8084b336..d2613fa214e 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/services/galley/src/Galley/API/Action.hs b/services/galley/src/Galley/API/Action.hs index 3352cb63f36..4e72cb8d1ea 100644 --- a/services/galley/src/Galley/API/Action.hs +++ b/services/galley/src/Galley/API/Action.hs @@ -400,17 +400,17 @@ 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 + case (protocolTag (convProtocol (tUnqualified lconv)), action, convTeam (tUnqualified lconv)) of + (ProtocolProteusTag, ProtocolMixedTag, Just _) -> do E.updateToMixedProtocol lcnv MLS_128_DHKEMX25519_AES128GCM_SHA256_Ed25519 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