Only allow protocol updates for team conversations

integration/test/API/GalleyInternal.hs

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

integration/test/SetupHelpers.hs

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

integration/test/Test/B2B.hs

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

integration/test/Test/Brig.hs

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

integration/test/Test/Demo.hs

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

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]

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)
 

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.