{-# OPTIONS_GHC -Wno-incomplete-uni-patterns -Wno-ambiguous-fields #-}

-- This file is part of the Wire Server implementation.
--
-- Copyright (C) 2025 Wire Swiss GmbH <opensource@wire.com>
--
-- This program is free software: you can redistribute it and/or modify it under
-- the terms of the GNU Affero General Public License as published by the Free
-- Software Foundation, either version 3 of the License, or (at your option) any
-- later version.
--
-- This program is distributed in the hope that it will be useful, but WITHOUT
-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more
-- details.
--
-- You should have received a copy of the GNU Affero General Public License along
-- with this program. If not, see <https://www.gnu.org/licenses/>.

module Test.MLS where

import API.Brig (claimKeyPackages, deleteClient)
import API.Galley
import qualified API.GalleyInternal as I
import Data.Bits
import qualified Data.ByteString as B
import qualified Data.ByteString.Base64 as Base64
import qualified Data.ByteString.Char8 as B8
import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import qualified Data.Text.Read as T
import MLS.Util
import Notifications
import SetupHelpers
import Test.FeatureFlags.Util
import Test.Version
import Testlib.Prelude
import Testlib.VersionedFed

testSendMessageNoReturnToSender :: (HasCallStack) => App ()
testSendMessageNoReturnToSender :: HasCallStack => App ()
testSendMessageNoReturnToSender = do
  [alice, bob] <- [Domain] -> App [Value]
forall domain.
(HasCallStack, MakesValue domain) =>
[domain] -> App [Value]
createAndConnectUsers [Domain
OwnDomain, Domain
OwnDomain]
  [alice1, alice2, bob1, bob2] <- traverse (createMLSClient def) [alice, alice, bob, bob]
  traverse_ (uploadNewKeyPackage def) [alice2, bob1, bob2]
  convId <- createNewGroup def alice1
  void $ createAddCommit alice1 convId [alice, bob] >>= sendAndConsumeCommitBundle

  -- alice1 sends a message to the conversation, all clients but alice1 receive
  -- the message
  withWebSockets [alice1, alice2, bob1, bob2] $ \(WebSocket
wsSender : [WebSocket]
wss) -> do
    mp <- HasCallStack =>
ConvId -> ClientIdentity -> String -> App MessagePackage
ConvId -> ClientIdentity -> String -> App MessagePackage
createApplicationMessage ConvId
convId ClientIdentity
alice1 String
"hello, bob"
    bindResponse (postMLSMessage mp.sender mp.message) $ \Response
resp -> do
      Response
resp.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
201
    for_ wss $ \WebSocket
ws -> do
      n <- HasCallStack => (Value -> App Bool) -> WebSocket -> App Value
(Value -> App Bool) -> WebSocket -> App Value
awaitMatch (\Value
n -> Value -> App Value
forall a. MakesValue a => a -> App Value
nPayload Value
n App Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"type" App Value -> String -> App Bool
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App Bool
`isEqual` String
"conversation.mls-message-add") WebSocket
ws
      nPayload n %. "data" `shouldMatch` T.decodeUtf8 (Base64.encode mp.message)
    expectFailure (const $ pure ())
      $ awaitMatch
        ( \Value
n ->
            (Bool -> Bool -> Bool) -> App Bool -> App Bool -> App Bool
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2
              Bool -> Bool -> Bool
(&&)
              (Value -> App Value
forall a. MakesValue a => a -> App Value
nPayload Value
n App Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"type" App Value -> String -> App Bool
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App Bool
`isEqual` String
"conversation.mls-message-add")
              (Value -> App Value
forall a. MakesValue a => a -> App Value
nPayload Value
n App Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"data" App Value -> Text -> App Bool
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App Bool
`isEqual` ByteString -> Text
T.decodeUtf8 (ByteString -> ByteString
Base64.encode MessagePackage
mp.message))
        )
        wsSender

testPastStaleApplicationMessage :: (HasCallStack) => Domain -> App ()
testPastStaleApplicationMessage :: HasCallStack => Domain -> App ()
testPastStaleApplicationMessage Domain
otherDomain = do
  [alice, bob, charlie, dave, eve] <-
    [Domain] -> App [Value]
forall domain.
(HasCallStack, MakesValue domain) =>
[domain] -> App [Value]
createAndConnectUsers [Domain
OwnDomain, Domain
otherDomain, Domain
OwnDomain, Domain
OwnDomain, Domain
OwnDomain]
  [alice1, bob1, charlie1] <- traverse (createMLSClient def) [alice, bob, charlie]
  traverse_ (uploadNewKeyPackage def) [bob1, charlie1]
  convId <- createNewGroup def alice1

  -- alice adds bob first
  void $ createAddCommit alice1 convId [bob] >>= sendAndConsumeCommitBundle

  -- bob prepares some application messages
  [msg1, msg2] <- replicateM 2 $ createApplicationMessage convId bob1 "hi alice"

  -- alice adds charlie and dave with different commits
  void $ createAddCommit alice1 convId [charlie] >>= sendAndConsumeCommitBundle
  void $ createAddCommit alice1 convId [dave] >>= sendAndConsumeCommitBundle

  -- bob's application messages still go through
  void $ postMLSMessage bob1 msg1.message >>= getJSON 201

  -- alice adds eve
  void $ createAddCommit alice1 convId [eve] >>= sendAndConsumeCommitBundle

  -- bob's application messages are now rejected
  void $ postMLSMessage bob1 msg2.message >>= getJSON 409

testEpochZeroApplicationMessage :: (HasCallStack) => App ()
testEpochZeroApplicationMessage :: HasCallStack => App ()
testEpochZeroApplicationMessage = do
  [alice] <- [App Value] -> App [Value]
forall domain.
(HasCallStack, MakesValue domain) =>
[domain] -> App [Value]
createAndConnectUsers [Domain -> App Value
forall a. (MakesValue a, HasCallStack) => a -> App Value
make Domain
OwnDomain]
  alice1 <- createMLSClient def alice
  conv <- createNewGroup def alice1
  void $ createAddCommit alice1 conv [] >>= sendAndConsumeCommitBundle
  mlsConv <- getMLSConv conv

  -- send message, make sure that's succeeding
  msg <- createApplicationMessage mlsConv.convId alice1 "group is initialised"
  postMLSMessage alice1 msg.message >>= assertStatus 201

  -- reset conversation, so it exists on server and client with epoch 0
  convId' <- objConvId =<< resetMLSConversation alice1 conv

  -- send message, make sure that's failing
  msg' <- createApplicationMessage convId' alice1 "group not initialised"
  postMLSMessage alice1 msg'.message >>= flip withResponse \Response
resp -> do
    j <- HasCallStack => Int -> Response -> App Value
Int -> Response -> App Value
getJSON Int
400 Response
resp
    j %. "label" `shouldMatch` "mls-protocol-error"
    j %. "message" `shouldMatch` "Application messages at epoch 0 are not supported"

testFutureStaleApplicationMessage :: (HasCallStack) => App ()
testFutureStaleApplicationMessage :: HasCallStack => App ()
testFutureStaleApplicationMessage = do
  [alice, bob, charlie] <- [Domain] -> App [Value]
forall domain.
(HasCallStack, MakesValue domain) =>
[domain] -> App [Value]
createAndConnectUsers [Domain
OwnDomain, Domain
OwnDomain, Domain
OwnDomain]
  [alice1, bob1, charlie1] <- traverse (createMLSClient def) [alice, bob, charlie]
  traverse_ (uploadNewKeyPackage def) [bob1, charlie1]
  convId <- createNewGroup def alice1

  -- alice adds bob
  void . sendAndConsumeCommitBundle =<< createAddCommit alice1 convId [bob]

  -- alice adds charlie and consumes the commit without sending it
  void $ createAddCommit alice1 convId [charlie]
  modifyMLSState $ \MLSState
mls ->
    MLSState
mls
      { convs =
          Map.adjust
            ( \MLSConv
conv ->
                MLSConv
conv
                  { epoch = conv.epoch + 1,
                    members = Set.insert charlie1 conv.members,
                    memberUsers = Set.insert charlie1.qualifiedUserId conv.memberUsers,
                    newMembers = mempty
                  }
            )
            convId
            mls.convs
      }

  -- alice's application message is rejected
  void
    . getJSON 409
    =<< postMLSMessage alice1
    . (.message)
    =<< createApplicationMessage convId alice1 "hi bob"

testMixedProtocolUpgrade :: (HasCallStack) => Domain -> App ()
testMixedProtocolUpgrade :: HasCallStack => Domain -> App ()
testMixedProtocolUpgrade Domain
secondDomain = do
  (alice, tid, _) <- Domain -> Int -> App (Value, String, [Value])
forall domain.
(HasCallStack, MakesValue domain) =>
domain -> Int -> App (Value, String, [Value])
createTeam Domain
OwnDomain Int
1
  [bob, charlie] <- replicateM 2 (randomUser secondDomain def)
  connectUsers [alice, bob, charlie]

  convId <-
    postConversation
      alice
      defProteus
        { qualifiedUsers = [bob, charlie],
          team = Just tid,
          receiptMode = Just 7
        }
      >>= getJSON 201
      >>= objConvId

  bindResponse (putConversationProtocol bob convId "mls") $ \Response
resp -> do
    Response
resp.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
403

  withWebSockets [alice, charlie] $ \[WebSocket]
websockets -> do
    App Response -> (Response -> App ()) -> App ()
forall a.
HasCallStack =>
App Response -> (Response -> App a) -> App a
bindResponse (Value -> ConvId -> String -> App Response
forall user protocol.
(HasCallStack, MakesValue user, MakesValue protocol) =>
user -> ConvId -> protocol -> App Response
putConversationProtocol Value
bob ConvId
convId String
"mixed") ((Response -> App ()) -> App ()) -> (Response -> App ()) -> App ()
forall a b. (a -> b) -> a -> b
$ \Response
resp -> do
      Response
resp.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
200
      Response
resp.json App Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"qualified_conversation" App Value -> Value -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` (ConvId -> Value
convIdToQidObject ConvId
convId)
      Response
resp.json App Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"data.protocol" App Value -> String -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` String
"mixed"

    [WebSocket] -> (WebSocket -> App ()) -> App ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [WebSocket]
websockets ((WebSocket -> App ()) -> App ())
-> (WebSocket -> App ()) -> App ()
forall a b. (a -> b) -> a -> b
$ \WebSocket
ws -> do
      n <- HasCallStack => (Value -> App Bool) -> WebSocket -> App Value
(Value -> App Bool) -> WebSocket -> App Value
awaitMatch (\Value
value -> Value -> App Value
forall a. MakesValue a => a -> App Value
nPayload Value
value App Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"type" App Value -> String -> App Bool
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App Bool
`isEqual` String
"conversation.protocol-update") WebSocket
ws
      nPayload n %. "data.protocol" `shouldMatch` "mixed"

  bindResponse (getConversation alice (convIdToQidObject convId)) $ \Response
resp -> do
    Response
resp.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
200
    Response
resp.json App Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"protocol" App Value -> String -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` String
"mixed"
    Response
resp.json App Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"epoch" App Value -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
0
    Response
resp.json App Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"receipt_mode" App Value -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
7

  bindResponse (putConversationProtocol alice convId "mixed") $ \Response
resp -> do
    Response
resp.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
204

  bindResponse (putConversationProtocol bob convId "proteus") $ \Response
resp -> do
    Response
resp.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
403

  bindResponse (putConversationProtocol bob convId "invalid") $ \Response
resp -> do
    Response
resp.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
400

testMixedProtocolNonTeam :: (HasCallStack) => Domain -> App ()
testMixedProtocolNonTeam :: HasCallStack => Domain -> App ()
testMixedProtocolNonTeam Domain
secondDomain = do
  [alice, bob] <- [Domain] -> App [Value]
forall domain.
(HasCallStack, MakesValue domain) =>
[domain] -> App [Value]
createAndConnectUsers [Domain
OwnDomain, Domain
secondDomain]
  convId <-
    postConversation alice defProteus {qualifiedUsers = [bob]}
      >>= getJSON 201
      >>= objConvId

  bindResponse (putConversationProtocol bob convId "mixed") $ \Response
resp -> do
    Response
resp.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
403

testMixedProtocolAddUsers :: (HasCallStack) => Domain -> Ciphersuite -> App ()
testMixedProtocolAddUsers :: HasCallStack => Domain -> Ciphersuite -> App ()
testMixedProtocolAddUsers Domain
secondDomain Ciphersuite
suite = do
  (alice, tid, _) <- Domain -> Int -> App (Value, String, [Value])
forall domain.
(HasCallStack, MakesValue domain) =>
domain -> Int -> App (Value, String, [Value])
createTeam Domain
OwnDomain Int
1
  [bob, charlie] <- replicateM 2 (randomUser secondDomain def)
  connectUsers [alice, bob, charlie]

  convId <- do
    convId <-
      postConversation alice defProteus {qualifiedUsers = [bob], team = Just tid}
        >>= getJSON 201
        >>= objConvId

    bindResponse (putConversationProtocol bob convId "mixed") $ \Response
resp -> do
      Response
resp.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
200

    bindResponse (getConversation alice (convIdToQidObject convId)) $ \Response
resp -> do
      Response
resp.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
200
      Response
resp.json App Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"epoch" App Value -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
0
      App Value -> App ConvId
forall conv. (HasCallStack, MakesValue conv) => conv -> App ConvId
objConvId Response
resp.json

  [alice1, bob1] <- traverse (createMLSClient def {ciphersuites = [suite]}) [alice, bob]
  createGroup suite alice1 convId

  void $ uploadNewKeyPackage suite bob1

  withWebSocket bob $ \WebSocket
ws -> do
    mp <- HasCallStack =>
ClientIdentity -> ConvId -> [Value] -> App MessagePackage
ClientIdentity -> ConvId -> [Value] -> App MessagePackage
createAddCommit ClientIdentity
alice1 ConvId
convId [Value
bob]
    welcome <- assertJust "should have welcome" mp.welcome
    void $ sendAndConsumeCommitBundleWithProtocol MLSProtocolMixed mp
    n <- awaitMatch (\Value
n -> Value -> App Value
forall a. MakesValue a => a -> App Value
nPayload Value
n App Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"type" App Value -> String -> App Bool
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App Bool
`isEqual` String
"conversation.mls-welcome") ws
    nPayload n %. "data" `shouldMatch` T.decodeUtf8 (Base64.encode welcome)

  bindResponse (getConversation alice (convIdToQidObject convId)) $ \Response
resp -> do
    Response
resp.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
200
    Response
resp.json App Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"epoch" App Value -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
1
    (suiteCode, _) <- Either String (Int, Text) -> App (Int, Text)
forall (t :: * -> *) a. (HasCallStack, Foldable t) => t a -> App a
assertOne (Either String (Int, Text) -> App (Int, Text))
-> Either String (Int, Text) -> App (Int, Text)
forall a b. (a -> b) -> a -> b
$ Reader Int
forall a. Integral a => Reader a
T.hexadecimal (String -> Text
T.pack Ciphersuite
suite.code)
    resp.json %. "cipher_suite" `shouldMatchInt` suiteCode

testMixedProtocolUserLeaves :: (HasCallStack) => Domain -> App ()
testMixedProtocolUserLeaves :: HasCallStack => Domain -> App ()
testMixedProtocolUserLeaves Domain
secondDomain = do
  (alice, tid, _) <- Domain -> Int -> App (Value, String, [Value])
forall domain.
(HasCallStack, MakesValue domain) =>
domain -> Int -> App (Value, String, [Value])
createTeam Domain
OwnDomain Int
1
  bob <- randomUser secondDomain def
  connectUsers [alice, bob]

  convId <- do
    convId <-
      postConversation alice defProteus {qualifiedUsers = [bob], team = Just tid}
        >>= getJSON 201
        >>= objConvId

    bindResponse (putConversationProtocol bob convId "mixed") $ \Response
resp -> do
      Response
resp.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
200

    bindResponse (getConversation alice (convIdToQidObject convId)) $ \Response
resp -> do
      Response
resp.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
200
      App Value -> App ConvId
forall conv. (HasCallStack, MakesValue conv) => conv -> App ConvId
objConvId Response
resp.json

  [alice1, bob1] <- traverse (createMLSClient def) [alice, bob]
  createGroup def alice1 convId
  void $ uploadNewKeyPackage def bob1

  mp <- createAddCommit alice1 convId [bob]
  void $ sendAndConsumeCommitBundleWithProtocol MLSProtocolMixed mp

  withWebSocket alice $ \WebSocket
ws -> do
    App Response -> (Response -> App ()) -> App ()
forall a.
HasCallStack =>
App Response -> (Response -> App a) -> App a
bindResponse (Value -> Value -> App Response
forall user qcnv.
(HasCallStack, MakesValue user, MakesValue qcnv) =>
user -> qcnv -> App Response
removeConversationMember Value
bob (ConvId -> Value
convIdToQidObject ConvId
convId)) ((Response -> App ()) -> App ()) -> (Response -> App ()) -> App ()
forall a b. (a -> b) -> a -> b
$ \Response
resp ->
      Response
resp.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
200

    n <- HasCallStack => (Value -> App Bool) -> WebSocket -> App Value
(Value -> App Bool) -> WebSocket -> App Value
awaitMatch (\Value
n -> Value -> App Value
forall a. MakesValue a => a -> App Value
nPayload Value
n App Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"type" App Value -> String -> App Bool
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App Bool
`isEqual` String
"conversation.mls-message-add") WebSocket
ws

    conv <- getMLSConv convId
    msg <- asByteString (nPayload n %. "data") >>= showMessage conv.ciphersuite alice1
    let leafIndexBob = Int
1
    msg %. "message.content.body.Proposal.Remove.removed" `shouldMatchInt` leafIndexBob
    msg %. "message.content.sender.External" `shouldMatchInt` 0

testMixedProtocolAddPartialClients :: (HasCallStack) => Domain -> App ()
testMixedProtocolAddPartialClients :: HasCallStack => Domain -> App ()
testMixedProtocolAddPartialClients Domain
secondDomain = do
  (alice, tid, _) <- Domain -> Int -> App (Value, String, [Value])
forall domain.
(HasCallStack, MakesValue domain) =>
domain -> Int -> App (Value, String, [Value])
createTeam Domain
OwnDomain Int
1
  bob <- randomUser secondDomain def
  connectUsers [alice, bob]

  convId <- do
    convId <-
      postConversation alice defProteus {qualifiedUsers = [bob], team = Just tid}
        >>= getJSON 201
        >>= objConvId

    bindResponse (putConversationProtocol bob convId "mixed") $ \Response
resp -> do
      Response
resp.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
200

    bindResponse (getConversation alice (convIdToQidObject convId)) $ \Response
resp -> do
      Response
resp.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
200
      App Value -> App ConvId
forall conv. (HasCallStack, MakesValue conv) => conv -> App ConvId
objConvId Response
resp.json

  [alice1, bob1, bob2] <- traverse (createMLSClient def) [alice, bob, bob]
  createGroup def alice1 convId

  traverse_ (uploadNewKeyPackage def) [bob1, bob1, bob2, bob2]

  -- create add commit for only one of bob's two clients
  do
    bundle <- claimKeyPackages def alice1 bob >>= getJSON 200
    kps <- unbundleKeyPackages bundle
    kp1 <- assertOne (filter ((== bob1) . fst) kps)
    mp <- createAddCommitWithKeyPackages alice1 convId [kp1]
    void $ sendAndConsumeCommitBundleWithProtocol MLSProtocolMixed 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 def bob1 bob >>= getJSON 200
    kps <- unbundleKeyPackages bundle
    kp2 <- assertOne (filter ((== bob2) . fst) kps)
    mp <- createAddCommitWithKeyPackages bob1 convId [kp2]
    void $ postMLSCommitBundle mp.sender (mkBundle mp) >>= getJSON 201

testMixedProtocolRemovePartialClients :: (HasCallStack) => Domain -> App ()
testMixedProtocolRemovePartialClients :: HasCallStack => Domain -> App ()
testMixedProtocolRemovePartialClients Domain
secondDomain = do
  (alice, tid, _) <- Domain -> Int -> App (Value, String, [Value])
forall domain.
(HasCallStack, MakesValue domain) =>
domain -> Int -> App (Value, String, [Value])
createTeam Domain
OwnDomain Int
1
  bob <- randomUser secondDomain def
  connectUsers [alice, bob]

  convId <- do
    convId <-
      postConversation alice defProteus {qualifiedUsers = [bob], team = Just tid}
        >>= getJSON 201
        >>= objConvId

    bindResponse (putConversationProtocol bob convId "mixed") $ \Response
resp -> do
      Response
resp.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
200

    bindResponse (getConversation alice (convIdToQidObject convId)) $ \Response
resp -> do
      Response
resp.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
200
      App Value -> App ConvId
forall conv. (HasCallStack, MakesValue conv) => conv -> App ConvId
objConvId Response
resp.json

  [alice1, bob1, bob2] <- traverse (createMLSClient def) [alice, bob, bob]
  createGroup def alice1 convId
  traverse_ (uploadNewKeyPackage def) [bob1, bob2]
  void $ createAddCommit alice1 convId [bob] >>= sendAndConsumeCommitBundleWithProtocol MLSProtocolMixed
  mp <- createRemoveCommit alice1 convId [bob1]

  void $ postMLSCommitBundle mp.sender (mkBundle mp) >>= getJSON 201

testMixedProtocolAppMessagesAreDenied :: (HasCallStack) => Domain -> App ()
testMixedProtocolAppMessagesAreDenied :: HasCallStack => Domain -> App ()
testMixedProtocolAppMessagesAreDenied Domain
secondDomain = do
  (alice, tid, _) <- Domain -> Int -> App (Value, String, [Value])
forall domain.
(HasCallStack, MakesValue domain) =>
domain -> Int -> App (Value, String, [Value])
createTeam Domain
OwnDomain Int
1
  bob <- randomUser secondDomain def
  connectUsers [alice, bob]

  convId <- do
    convId <-
      postConversation alice defProteus {qualifiedUsers = [bob], team = Just tid}
        >>= getJSON 201
        >>= objConvId

    bindResponse (putConversationProtocol bob convId "mixed") $ \Response
resp -> do
      Response
resp.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
200

    bindResponse (getConversation alice (convIdToQidObject convId)) $ \Response
resp -> do
      Response
resp.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
200
      App Value -> App ConvId
forall conv. (HasCallStack, MakesValue conv) => conv -> App ConvId
objConvId Response
resp.json

  [alice1, bob1] <- traverse (createMLSClient def) [alice, bob]

  createGroup def alice1 convId
  void $ uploadNewKeyPackage def bob1

  void $ createAddCommit alice1 convId [bob] >>= sendAndConsumeCommitBundleWithProtocol MLSProtocolMixed

  mp <- createApplicationMessage convId bob1 "hello, world"
  bindResponse (postMLSMessage mp.sender mp.message) $ \Response
resp -> do
    Response
resp.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
422
    Response
resp.json App Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"label" App Value -> String -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` String
"mls-unsupported-message"

testMLSProtocolUpgrade :: (HasCallStack) => Domain -> App ()
testMLSProtocolUpgrade :: HasCallStack => Domain -> App ()
testMLSProtocolUpgrade Domain
secondDomain = do
  (alice, bob, convId) <- Domain -> App (Value, Value, ConvId)
forall domain.
(HasCallStack, MakesValue domain) =>
domain -> App (Value, Value, ConvId)
simpleMixedConversationSetup Domain
secondDomain
  updateReceiptMode alice convId (9 :: Int) >>= assertSuccess
  charlie <- randomUser OwnDomain def

  -- alice creates MLS group and bob joins
  [alice1, bob1, charlie1] <- traverse (createMLSClient def) [alice, bob, charlie]
  createGroup def alice1 convId
  void $ createPendingProposalCommit convId alice1 >>= sendAndConsumeCommitBundleWithProtocol MLSProtocolMixed
  void $ createExternalCommit convId bob1 Nothing >>= sendAndConsumeCommitBundleWithProtocol MLSProtocolMixed

  void $ withWebSocket bob $ \WebSocket
ws -> do
    -- charlie is added to the group
    App String -> App ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (App String -> App ()) -> App String -> App ()
forall a b. (a -> b) -> a -> b
$ HasCallStack => Ciphersuite -> ClientIdentity -> App String
Ciphersuite -> ClientIdentity -> App String
uploadNewKeyPackage Ciphersuite
forall a. Default a => a
def ClientIdentity
charlie1
    App Value -> App ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (App Value -> App ()) -> App Value -> App ()
forall a b. (a -> b) -> a -> b
$ HasCallStack =>
ClientIdentity -> ConvId -> [Value] -> App MessagePackage
ClientIdentity -> ConvId -> [Value] -> App MessagePackage
createAddCommit ClientIdentity
alice1 ConvId
convId [Value
charlie] App MessagePackage -> (MessagePackage -> App Value) -> App Value
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HasCallStack => MLSProtocol -> MessagePackage -> App Value
MLSProtocol -> MessagePackage -> App Value
sendAndConsumeCommitBundleWithProtocol MLSProtocol
MLSProtocolMixed
    HasCallStack => (Value -> App Bool) -> WebSocket -> App Value
(Value -> App Bool) -> WebSocket -> App Value
awaitMatch Value -> App Bool
forall a. (HasCallStack, MakesValue a) => a -> App Bool
isNewMLSMessageNotif WebSocket
ws

  supportMLS alice
  bindResponse (putConversationProtocol bob convId "mls") $ \Response
resp -> do
    Response
resp.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
400
    Response
resp.json App Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"label" App Value -> String -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` String
"mls-migration-criteria-not-satisfied"
  bindResponse (getConversation alice (convIdToQidObject convId)) $ \Response
resp -> do
    Response
resp.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
200
    Response
resp.json App Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"protocol" App Value -> String -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` String
"mixed"
    Response
resp.json App Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"receipt_mode" App Value -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
9

  supportMLS bob

  withWebSockets [alice1, bob1] $ \[WebSocket]
wss -> do
    App Response -> (Response -> App ()) -> App ()
forall a.
HasCallStack =>
App Response -> (Response -> App a) -> App a
bindResponse (Value -> ConvId -> String -> App Response
forall user protocol.
(HasCallStack, MakesValue user, MakesValue protocol) =>
user -> ConvId -> protocol -> App Response
putConversationProtocol Value
bob ConvId
convId String
"mls") ((Response -> App ()) -> App ()) -> (Response -> App ()) -> App ()
forall a b. (a -> b) -> a -> b
$ \Response
resp -> do
      Response
resp.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
200
      Response
resp.json App Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"data.protocol" App Value -> String -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` String
"mls"
    [WebSocket] -> (WebSocket -> App ()) -> App ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [WebSocket]
wss ((WebSocket -> App ()) -> App ())
-> (WebSocket -> App ()) -> App ()
forall a b. (a -> b) -> a -> b
$ \WebSocket
ws -> do
      n <- HasCallStack => (Value -> App Bool) -> WebSocket -> App Value
(Value -> App Bool) -> WebSocket -> App Value
awaitMatch Value -> App Bool
forall a. (HasCallStack, MakesValue a) => a -> App Bool
isNewMLSMessageNotif WebSocket
ws
      msg <- asByteString (nPayload n %. "data") >>= showMessage def alice1
      let leafIndexCharlie = Int
2
      msg %. "message.content.body.Proposal.Remove.removed" `shouldMatchInt` leafIndexCharlie
      msg %. "message.content.sender.External" `shouldMatchInt` 0

  bindResponse (getConversation alice (convIdToQidObject convId)) $ \Response
resp -> do
    Response
resp.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
200
    Response
resp.json App Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"protocol" App Value -> String -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` String
"mls"
    Response
resp.json App Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"receipt_mode" App Value -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
0

testAddUserSimple :: (HasCallStack) => Ciphersuite -> CredentialType -> App ()
testAddUserSimple :: HasCallStack => Ciphersuite -> CredentialType -> App ()
testAddUserSimple Ciphersuite
suite CredentialType
ctype = do
  [alice, bob] <- [Domain] -> App [Value]
forall domain.
(HasCallStack, MakesValue domain) =>
[domain] -> App [Value]
createAndConnectUsers [Domain
OwnDomain, Domain
OwnDomain]

  bob1 <- createMLSClient def {ciphersuites = [suite], credType = ctype} bob
  void $ uploadNewKeyPackage suite bob1
  [alice1, bob2] <- traverse (createMLSClient def {ciphersuites = [suite], credType = ctype}) [alice, bob]

  void $ uploadNewKeyPackage suite bob2
  qcnv <- withWebSocket alice $ \WebSocket
ws -> do
    qcnv <- HasCallStack => Ciphersuite -> ClientIdentity -> App ConvId
Ciphersuite -> ClientIdentity -> App ConvId
createNewGroup Ciphersuite
suite ClientIdentity
alice1
    -- check that the conversation inside the ConvCreated event contains
    -- epoch and ciphersuite, regardless of the API version
    n <- awaitMatch isConvCreateNotif ws
    n %. "payload.0.data.epoch" `shouldMatchInt` 0
    n %. "payload.0.data.cipher_suite" `shouldMatchInt` 1
    pure qcnv

  resp <- createAddCommit alice1 qcnv [bob] >>= sendAndConsumeCommitBundle
  events <- resp %. "events" & asList
  do
    event <- assertOne events
    shouldMatch (event %. "qualified_conversation.id") qcnv.id_
    shouldMatch (event %. "qualified_conversation.domain") qcnv.domain
    shouldMatch (event %. "type") "conversation.member-join"
    shouldMatch (event %. "from") (objId alice)
    members <- event %. "data" %. "users" & asList
    memberQids <- for members $ \Value
mem -> Value
mem Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"qualified_id"
    bobQid <- bob %. "qualified_id"
    shouldMatch memberQids [bobQid]

  -- check that bob can now see the conversation
  convs <- getAllConvs bob
  convIds <- traverse objConvId convs
  void
    $ assertBool
      "Users added to an MLS group should find it when listing conversations"
      (qcnv `elem` convIds)

testRemoteAddUser :: (HasCallStack) => App ()
testRemoteAddUser :: HasCallStack => App ()
testRemoteAddUser = do
  [alice, bob, charlie] <- [Domain] -> App [Value]
forall domain.
(HasCallStack, MakesValue domain) =>
[domain] -> App [Value]
createAndConnectUsers [Domain
OwnDomain, Domain
OtherDomain, Domain
OwnDomain]
  [alice1, bob1, charlie1] <- traverse (createMLSClient def) [alice, bob, charlie]
  traverse_ (uploadNewKeyPackage def) [bob1, charlie1]
  conv <- createNewGroup def alice1
  void $ createAddCommit alice1 conv [bob] >>= sendAndConsumeCommitBundle
  bindResponse (updateConversationMember alice1 (convIdToQidObject conv) bob "wire_admin") $ \Response
resp ->
    Response
resp.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
200

  mp <- createAddCommit bob1 conv [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)) $ \Response
resp -> do
    Response
resp.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
422
    Response
resp.json App Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"label" App Value -> String -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` String
"federation-not-implemented"

testRemoteRemoveClient :: (HasCallStack) => Ciphersuite -> App ()
testRemoteRemoveClient :: HasCallStack => Ciphersuite -> App ()
testRemoteRemoveClient Ciphersuite
suite = do
  [alice, bob] <- [Domain] -> App [Value]
forall domain.
(HasCallStack, MakesValue domain) =>
[domain] -> App [Value]
createAndConnectUsers [Domain
OwnDomain, Domain
OtherDomain]
  [alice1, bob1] <- traverse (createMLSClient def {ciphersuites = [suite]}) [alice, bob]
  void $ uploadNewKeyPackage suite bob1
  conv <- createNewGroup suite alice1
  void $ createAddCommit alice1 conv [bob] >>= sendAndConsumeCommitBundle

  withWebSocket alice $ \WebSocket
wsAlice -> do
    App ByteString -> App ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (App ByteString -> App ()) -> App ByteString -> App ()
forall a b. (a -> b) -> a -> b
$ Value -> String -> App Response
forall user qcnv.
(HasCallStack, MakesValue user, MakesValue qcnv) =>
user -> qcnv -> App Response
deleteClient Value
bob ClientIdentity
bob1.client App Response -> (Response -> App ByteString) -> App ByteString
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HasCallStack => Int -> Response -> App ByteString
Int -> Response -> App ByteString
getBody Int
200
    let predicate :: a -> App Bool
predicate a
n = a -> App Value
forall a. MakesValue a => a -> App Value
nPayload a
n App Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"type" App Value -> String -> App Bool
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App Bool
`isEqual` String
"conversation.mls-message-add"
    n <- HasCallStack => (Value -> App Bool) -> WebSocket -> App Value
(Value -> App Bool) -> WebSocket -> App Value
awaitMatch Value -> App Bool
forall {a}. MakesValue a => a -> App Bool
predicate WebSocket
wsAlice
    shouldMatch (nPayload n %. "qualified_conversation") (convIdToQidObject conv)
    shouldMatch (nPayload n %. "from") (objId bob)

    mlsMsg <- asByteString (nPayload n %. "data")

    -- Checks that the remove proposal is consumable by alice
    void $ mlsCliConsume conv suite alice1 mlsMsg
    -- This doesn't work because `sendAndConsumeCommitBundle` doesn't like
    -- remove proposals from the backend. We should fix that in future.
    -- void $ createPendingProposalCommit alice1 >>= sendAndConsumeCommitBundle

    parsedMsg <- showMessage suite alice1 mlsMsg
    let leafIndexBob = Int
1
    parsedMsg %. "message.content.body.Proposal.Remove.removed" `shouldMatchInt` leafIndexBob
    parsedMsg %. "message.content.sender.External" `shouldMatchInt` 0

testRemoteRemoveCreatorClient :: (HasCallStack) => Ciphersuite -> App ()
testRemoteRemoveCreatorClient :: HasCallStack => Ciphersuite -> App ()
testRemoteRemoveCreatorClient Ciphersuite
suite = do
  [alice, bob] <- [Domain] -> App [Value]
forall domain.
(HasCallStack, MakesValue domain) =>
[domain] -> App [Value]
createAndConnectUsers [Domain
OwnDomain, Domain
OtherDomain]
  [alice1, bob1] <- traverse (createMLSClient def {ciphersuites = [suite]}) [alice, bob]
  void $ uploadNewKeyPackage suite bob1
  conv <- createNewGroup suite alice1
  void $ createAddCommit alice1 conv [bob] >>= sendAndConsumeCommitBundle

  withWebSocket bob $ \WebSocket
wsBob -> do
    App ByteString -> App ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (App ByteString -> App ()) -> App ByteString -> App ()
forall a b. (a -> b) -> a -> b
$ Value -> String -> App Response
forall user qcnv.
(HasCallStack, MakesValue user, MakesValue qcnv) =>
user -> qcnv -> App Response
deleteClient Value
alice ClientIdentity
alice1.client App Response -> (Response -> App ByteString) -> App ByteString
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HasCallStack => Int -> Response -> App ByteString
Int -> Response -> App ByteString
getBody Int
200
    let predicate :: a -> App Bool
predicate a
n = a -> App Value
forall a. MakesValue a => a -> App Value
nPayload a
n App Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"type" App Value -> String -> App Bool
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App Bool
`isEqual` String
"conversation.mls-message-add"
    n <- HasCallStack => (Value -> App Bool) -> WebSocket -> App Value
(Value -> App Bool) -> WebSocket -> App Value
awaitMatch Value -> App Bool
forall {a}. MakesValue a => a -> App Bool
predicate WebSocket
wsBob
    shouldMatch (nPayload n %. "qualified_conversation") (convIdToQidObject conv)
    shouldMatch (nPayload n %. "from") (objId alice)

    mlsMsg <- asByteString (nPayload n %. "data")

    -- Checks that the remove proposal is consumable by alice
    void $ mlsCliConsume conv suite alice1 mlsMsg
    -- This doesn't work because `sendAndConsumeCommitBundle` doesn't like
    -- remove proposals from the backend. We should fix that in future.
    -- void $ createPendingProposalCommit alice1 >>= sendAndConsumeCommitBundle

    parsedMsg <- showMessage suite alice1 mlsMsg
    let leafIndexAlice = Int
0
    parsedMsg %. "message.content.body.Proposal.Remove.removed" `shouldMatchInt` leafIndexAlice
    parsedMsg %. "message.content.sender.External" `shouldMatchInt` 0

testCreateSubConv :: (HasCallStack) => Ciphersuite -> App ()
testCreateSubConv :: HasCallStack => Ciphersuite -> App ()
testCreateSubConv Ciphersuite
suite = do
  [alice, bob] <- [Domain] -> App [Value]
forall domain.
(HasCallStack, MakesValue domain) =>
[domain] -> App [Value]
createAndConnectUsers [Domain
OwnDomain, Domain
OwnDomain]
  aliceClients@(alice1 : _) <- replicateM 5 $ createMLSClient def {ciphersuites = [suite]} alice
  replicateM_ 3 $ traverse_ (uploadNewKeyPackage suite) aliceClients
  [bob1, bob2] <- replicateM 2 $ createMLSClient def {ciphersuites = [suite]} bob
  replicateM_ 3 $ traverse_ (uploadNewKeyPackage suite) [bob1, bob2]
  convId <- createNewGroup suite alice1
  void $ createAddCommit alice1 convId [alice, bob] >>= sendAndConsumeCommitBundle
  createSubConv suite convId alice1 "conference"

testCreateSubConvProteus :: App ()
testCreateSubConvProteus :: App ()
testCreateSubConvProteus = do
  alice <- Domain -> CreateUser -> App Value
forall domain.
(HasCallStack, MakesValue domain) =>
domain -> CreateUser -> App Value
randomUser Domain
OwnDomain CreateUser
forall a. Default a => a
def
  conv <- bindResponse (postConversation alice defProteus) $ \Response
resp -> do
    Response
resp.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
201
    App Value -> App ConvId
forall conv. (HasCallStack, MakesValue conv) => conv -> App ConvId
objConvId Response
resp.json
  bindResponse (getSubConversation alice conv "conference") $ \Response
resp ->
    Response
resp.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
404

testSelfConversation :: Version5 -> App ()
testSelfConversation :: Version5 -> App ()
testSelfConversation Version5
v = Version5 -> App () -> App ()
forall a. Version5 -> App a -> App a
withVersion5 Version5
v (App () -> App ()) -> App () -> App ()
forall a b. (a -> b) -> a -> b
$ do
  alice <- Domain -> CreateUser -> App Value
forall domain.
(HasCallStack, MakesValue domain) =>
domain -> CreateUser -> App Value
randomUser Domain
OwnDomain CreateUser
forall a. Default a => a
def
  creator : others <- traverse (createMLSClient def) (replicate 3 alice)
  traverse_ (uploadNewKeyPackage def) others
  (_, conv) <- createSelfGroup def creator
  convId <- objConvId conv
  conv %. "epoch" `shouldMatchInt` 0
  case v of
    Version5
Version5 -> Value
conv Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"cipher_suite" App Value -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
1
    Version5
NoVersion5 -> Value -> String -> App ()
forall a. (HasCallStack, MakesValue a) => a -> String -> App ()
assertFieldMissing Value
conv String
"cipher_suite"

  void $ createAddCommit creator convId [alice] >>= sendAndConsumeCommitBundle

  newClient <- createMLSClient def alice
  void $ uploadNewKeyPackage def newClient
  void $ createExternalCommit convId newClient Nothing >>= sendAndConsumeCommitBundle

-- | FUTUREWORK: Don't allow partial adds, not even in the first commit
testFirstCommitAllowsPartialAdds :: (HasCallStack) => App ()
testFirstCommitAllowsPartialAdds :: HasCallStack => App ()
testFirstCommitAllowsPartialAdds = do
  alice <- Domain -> CreateUser -> App Value
forall domain.
(HasCallStack, MakesValue domain) =>
domain -> CreateUser -> App Value
randomUser Domain
OwnDomain CreateUser
forall a. Default a => a
def

  [alice1, alice2, alice3] <- traverse (createMLSClient def) [alice, alice, alice]
  traverse_ (uploadNewKeyPackage def) [alice1, alice2, alice2, alice3, alice3]

  convId <- createNewGroup def alice1

  bundle <- claimKeyPackages def alice1 alice >>= getJSON 200
  kps <- unbundleKeyPackages bundle

  -- first commit only adds kp for alice2 (not alice2 and alice3)
  mp <- createAddCommitWithKeyPackages alice1 convId (filter ((== alice2) . fst) kps)
  bindResponse (postMLSCommitBundle mp.sender (mkBundle mp)) $ \Response
resp -> do
    Response
resp.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
409
    Response
resp.json App Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"label" App Value -> String -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` String
"mls-client-mismatch"

-- @SF.Separation @TSFI.RESTfulAPI @S2
--
-- This test verifies that the server rejects a commit containing add proposals
-- that only add a proper subset of the set of clients of a user.
testAddUserPartial :: (HasCallStack) => App ()
testAddUserPartial :: HasCallStack => App ()
testAddUserPartial = do
  [alice, bob, charlie] <- [Domain] -> App [Value]
forall domain.
(HasCallStack, MakesValue domain) =>
[domain] -> App [Value]
createAndConnectUsers (Int -> Domain -> [Domain]
forall a. Int -> a -> [a]
replicate Int
3 Domain
OwnDomain)

  -- Bob has 3 clients, Charlie has 2
  alice1 <- createMLSClient def alice
  bobClients@[_bob1, _bob2, bob3] <- replicateM 3 (createMLSClient def bob)
  charlieClients <- replicateM 2 (createMLSClient def charlie)

  -- Only the first 2 clients of Bob's have uploaded key packages
  traverse_ (uploadNewKeyPackage def) (take 2 bobClients <> charlieClients)

  -- alice adds bob's first 2 clients
  convId <- createNewGroup def alice1

  -- alice sends a commit now, and should get a conflict error
  kps <- fmap concat . for [bob, charlie] $ \Value
user -> do
    bundle <- Ciphersuite -> ClientIdentity -> Value -> App Response
forall u v.
(HasCallStack, MakesValue u, MakesValue v) =>
Ciphersuite -> u -> v -> App Response
claimKeyPackages Ciphersuite
forall a. Default a => a
def ClientIdentity
alice1 Value
user App Response -> (Response -> App Value) -> App Value
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HasCallStack => Int -> Response -> App Value
Int -> Response -> App Value
getJSON Int
200
    unbundleKeyPackages bundle
  mp <- createAddCommitWithKeyPackages alice1 convId kps

  -- before alice can commit, bob3 uploads a key package
  void $ uploadNewKeyPackage def bob3

  err <- postMLSCommitBundle mp.sender (mkBundle mp) >>= getJSON 409
  err %. "label" `shouldMatch` "mls-client-mismatch"

-- @END

-- | admin removes user from a conversation but doesn't list all clients
testRemoveClientsIncomplete :: (HasCallStack) => App ()
testRemoveClientsIncomplete :: HasCallStack => App ()
testRemoveClientsIncomplete = do
  [alice, bob] <- [Domain] -> App [Value]
forall domain.
(HasCallStack, MakesValue domain) =>
[domain] -> App [Value]
createAndConnectUsers [Domain
OwnDomain, Domain
OwnDomain]

  [alice1, bob1, bob2] <- traverse (createMLSClient def) [alice, bob, bob]
  traverse_ (uploadNewKeyPackage def) [bob1, bob2]
  convId <- createNewGroup def alice1
  void $ createAddCommit alice1 convId [bob] >>= sendAndConsumeCommitBundle
  mp <- createRemoveCommit alice1 convId [bob1]

  err <- postMLSCommitBundle mp.sender (mkBundle mp) >>= getJSON 409
  err %. "label" `shouldMatch` "mls-client-mismatch"

testAdminRemovesUserFromConv :: (HasCallStack) => Ciphersuite -> App ()
testAdminRemovesUserFromConv :: HasCallStack => Ciphersuite -> App ()
testAdminRemovesUserFromConv Ciphersuite
suite = do
  [alice, bob] <- [Domain] -> App [Value]
forall domain.
(HasCallStack, MakesValue domain) =>
[domain] -> App [Value]
createAndConnectUsers [Domain
OwnDomain, Domain
OwnDomain]
  [alice1, bob1, bob2] <- traverse (createMLSClient def {ciphersuites = [suite]}) [alice, bob, bob]

  void $ createWireClient bob def
  traverse_ (uploadNewKeyPackage suite) [bob1, bob2]
  convId <- createNewGroup suite alice1
  let Just gid = convId.groupId
  void $ createAddCommit alice1 convId [bob] >>= sendAndConsumeCommitBundle
  events <- createRemoveCommit alice1 convId [bob1, bob2] >>= sendAndConsumeCommitBundle

  do
    event <- assertOne =<< asList (events %. "events")
    event %. "qualified_conversation" `shouldMatch` convIdToQidObject convId
    event %. "type" `shouldMatch` "conversation.member-leave"
    event %. "from" `shouldMatch` objId alice
    members <- event %. "data" %. "qualified_user_ids" & asList
    bobQid <- bob %. "qualified_id"
    shouldMatch members [bobQid]

  do
    convs <- getAllConvs bob
    convIds <- traverse objConvId convs
    clients <- bindResponse (getGroupClients alice gid) $ \Response
resp -> do
      Response
resp.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
200
      Response
resp.json App Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"client_ids" App Value -> (App Value -> App [Value]) -> App [Value]
forall a b. a -> (a -> b) -> b
& App Value -> App [Value]
forall a. (HasCallStack, MakesValue a) => a -> App [Value]
asList
    void $ assertOne clients
    assertBool
      "bob is not longer part of conversation after the commit"
      (convId `notElem` convIds)

testLocalWelcome :: (HasCallStack) => App ()
testLocalWelcome :: HasCallStack => App ()
testLocalWelcome = do
  users@[alice, bob] <- [Domain] -> App [Value]
forall domain.
(HasCallStack, MakesValue domain) =>
[domain] -> App [Value]
createAndConnectUsers [Domain
OwnDomain, Domain
OwnDomain]

  [alice1, bob1] <- traverse (createMLSClient def) users

  void $ uploadNewKeyPackage def bob1

  convId <- createNewGroup def alice1

  commit <- createAddCommit alice1 convId [bob]
  Just welcome <- pure commit.welcome

  es <- withWebSocket bob1 $ \WebSocket
wsBob -> do
    es <- HasCallStack => MessagePackage -> App Value
MessagePackage -> App Value
sendAndConsumeCommitBundle MessagePackage
commit
    let isWelcome a
n = a -> App Value
forall a. MakesValue a => a -> App Value
nPayload a
n App Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"type" App Value -> String -> App Bool
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App Bool
`isEqual` String
"conversation.mls-welcome"

    n <- awaitMatch isWelcome wsBob

    shouldMatch (nPayload n %. "qualified_conversation") (convIdToQidObject convId)
    shouldMatch (nPayload n %. "from") (objId alice)
    shouldMatch (nPayload n %. "data") (B8.unpack (Base64.encode welcome))
    pure es

  event <- assertOne =<< asList (es %. "events")
  event %. "type" `shouldMatch` "conversation.member-join"
  event %. "qualified_conversation" `shouldMatch` convIdToQidObject convId
  addedUser <- (event %. "data.users") >>= asList >>= assertOne
  objQid addedUser `shouldMatch` objQid bob

testStaleCommit :: (HasCallStack) => App ()
testStaleCommit :: HasCallStack => App ()
testStaleCommit = do
  (alice : users) <- [Domain] -> App [Value]
forall domain.
(HasCallStack, MakesValue domain) =>
[domain] -> App [Value]
createAndConnectUsers (Int -> Domain -> [Domain]
forall a. Int -> a -> [a]
replicate Int
5 Domain
OwnDomain)
  let (users1, users2) = splitAt 2 users

  (alice1 : clients) <- traverse (createMLSClient def) (alice : users)
  traverse_ (uploadNewKeyPackage def) clients
  convId <- createNewGroup def alice1

  gsBackup <- getClientGroupState alice1

  -- add the first batch of users to the conversation
  void $ createAddCommit alice1 convId users1 >>= sendAndConsumeCommitBundle

  -- now roll back alice1 and try to add the second batch of users
  setClientGroupState alice1 gsBackup

  mp <- createAddCommit alice1 convId users2
  bindResponse (postMLSCommitBundle mp.sender (mkBundle mp)) $ \Response
resp -> do
    Response
resp.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
409
    Response
resp.json App Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"label" App Value -> String -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` String
"mls-stale-message"

testPropInvalidEpoch :: (HasCallStack) => App ()
testPropInvalidEpoch :: HasCallStack => App ()
testPropInvalidEpoch = do
  users@[_alice, bob, charlie, dee] <- [Domain] -> App [Value]
forall domain.
(HasCallStack, MakesValue domain) =>
[domain] -> App [Value]
createAndConnectUsers (Int -> Domain -> [Domain]
forall a. Int -> a -> [a]
replicate Int
4 Domain
OwnDomain)
  [alice1, bob1, charlie1, dee1] <- traverse (createMLSClient def) users
  convId <- createNewGroup def alice1

  -- Add bob -> epoch 1
  void $ uploadNewKeyPackage def bob1
  gsBackup <- getClientGroupState alice1
  void $ createAddCommit alice1 convId [bob] >>= sendAndConsumeCommitBundle
  gsBackup2 <- getClientGroupState alice1

  -- try to send a proposal from an old epoch (0)
  do
    setClientGroupState alice1 gsBackup
    void $ uploadNewKeyPackage def dee1
    [prop] <- createAddProposals convId alice1 [dee]
    bindResponse (postMLSMessage alice1 prop.message) $ \Response
resp -> do
      Response
resp.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
409
      Response
resp.json App Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"label" App Value -> String -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` String
"mls-stale-message"

  -- try to send a proposal from a newer epoch (2)
  do
    void $ uploadNewKeyPackage def dee1
    void $ uploadNewKeyPackage def charlie1
    setClientGroupState alice1 gsBackup2
    void $ createAddCommit alice1 convId [charlie] -- --> epoch 2
    [prop] <- createAddProposals convId alice1 [dee]
    bindResponse (postMLSMessage alice1 prop.message) $ \Response
resp -> do
      Response
resp.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
409
      Response
resp.json App Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"label" App Value -> String -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` String
"mls-stale-message"
    -- remove charlie from users expected to get a welcome message
    modifyMLSState $ \MLSState
mls -> MLSState
mls {convs = Map.adjust (\MLSConv
conv -> MLSConv
conv {newMembers = mempty}) convId mls.convs}

  -- alice send a well-formed proposal and commits it
  void $ uploadNewKeyPackage def dee1
  setClientGroupState alice1 gsBackup2
  createAddProposals convId alice1 [dee] >>= traverse_ sendAndConsumeMessage
  void $ createPendingProposalCommit convId alice1 >>= sendAndConsumeCommitBundle

--- | This test submits a ReInit proposal, which is currently ignored by the
-- backend, in order to check that unsupported proposal types are accepted.
testPropUnsupported :: (HasCallStack) => App ()
testPropUnsupported :: HasCallStack => App ()
testPropUnsupported = do
  users@[_alice, bob] <- [Domain] -> App [Value]
forall domain.
(HasCallStack, MakesValue domain) =>
[domain] -> App [Value]
createAndConnectUsers (Int -> Domain -> [Domain]
forall a. Int -> a -> [a]
replicate Int
2 Domain
OwnDomain)
  [alice1, bob1] <- traverse (createMLSClient def) users
  void $ uploadNewKeyPackage def bob1
  convId <- createNewGroup def alice1
  void $ createAddCommit alice1 convId [bob] >>= sendAndConsumeCommitBundle

  mp <- createReInitProposal convId alice1

  -- we cannot consume this message, because the membership tag is fake
  void $ postMLSMessage mp.sender mp.message >>= getJSON 201

testAddUserBareProposalCommit :: (HasCallStack) => App ()
testAddUserBareProposalCommit :: HasCallStack => App ()
testAddUserBareProposalCommit = do
  [alice, bob] <- [Domain] -> App [Value]
forall domain.
(HasCallStack, MakesValue domain) =>
[domain] -> App [Value]
createAndConnectUsers (Int -> Domain -> [Domain]
forall a. Int -> a -> [a]
replicate Int
2 Domain
OwnDomain)
  [alice1, bob1] <- traverse (createMLSClient def) [alice, bob]
  convId <- createNewGroup def alice1
  void $ uploadNewKeyPackage def bob1
  void $ createAddCommit alice1 convId [] >>= sendAndConsumeCommitBundle

  createAddProposals convId alice1 [bob]
    >>= traverse_ sendAndConsumeMessage
  commit <- createPendingProposalCommit convId alice1
  void $ assertJust "Expected welcome" commit.welcome
  void $ sendAndConsumeCommitBundle commit

  -- check that bob can now see the conversation
  convs <- getAllConvs bob
  convIds <- traverse objConvId convs
  void
    $ assertBool
      "Users added to an MLS group should find it when listing conversations"
      (convId `elem` convIds)

testShadowConversation :: (HasCallStack) => App ()
testShadowConversation :: HasCallStack => App ()
testShadowConversation = do
  [alice, bob, charlie] <- [Domain] -> App [Value]
forall domain.
(HasCallStack, MakesValue domain) =>
[domain] -> App [Value]
createAndConnectUsers [Domain
OwnDomain, Domain
OwnDomain, Domain
OwnDomain]
  [alice1, bob1, charlie1] <- traverse (createMLSClient def) [alice, bob, charlie]
  traverse_ (uploadNewKeyPackage def) [alice1, bob1, charlie1]
  convId <- createNewGroup def alice1

  void $ createAddCommit alice1 convId [bob, charlie] >>= sendAndConsumeCommitBundle

  shadowConv <- postConversation charlie1 (defProteus {parent = Just convId.id_}) >>= getJSON 201
  shadowConvId <- objConvId shadowConv

  fetchedConversation <- bindResponse (getConversationInternal charlie1 shadowConvId) $ \Response
resp -> do
    Response
resp.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
200
    Response
resp.json
  fetchedMembers <- fetchedConversation %. "members"
  let extractId a
x = a
x a -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"qualified_id"
  fetchedOtherMembers <- fetchedMembers %. "others" & asList
  fetchedOtherMemberIds <- traverse extractId fetchedOtherMembers
  expectedMemberIds <- traverse extractId [alice, bob, charlie]
  sort (nub fetchedOtherMemberIds) `shouldMatch` sort expectedMemberIds

  extractedCharlieMembership <-
    flip filterM fetchedOtherMembers $ \Value
membership -> do
      membershipId <- Value
membership Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"qualified_id"
      charlieId <- charlie %. "qualified_id"
      pure $ membershipId == charlieId
  charlieMembership <- assertOne extractedCharlieMembership
  charlieMembership %. "conversation_role" `shouldMatch` "wire_admin"

testShadowConversationDenied :: (HasCallStack) => App ()
testShadowConversationDenied :: HasCallStack => App ()
testShadowConversationDenied = do
  [alice, bob] <- [Domain] -> App [Value]
forall domain.
(HasCallStack, MakesValue domain) =>
[domain] -> App [Value]
createAndConnectUsers [Domain
OwnDomain, Domain
OwnDomain]
  [alice1, bob1] <- traverse (createMLSClient def) [alice, bob]
  traverse_ (uploadNewKeyPackage def) [alice1, bob1]
  convId <- createNewGroup def alice1

  bindResponse (postConversation bob1 (defMLS {parent = Just convId.id_})) $ \Response
resp -> do
    Response
resp.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
403

testPropExistingConv :: (HasCallStack) => App ()
testPropExistingConv :: HasCallStack => App ()
testPropExistingConv = do
  [alice, bob] <- [Domain] -> App [Value]
forall domain.
(HasCallStack, MakesValue domain) =>
[domain] -> App [Value]
createAndConnectUsers (Int -> Domain -> [Domain]
forall a. Int -> a -> [a]
replicate Int
2 Domain
OwnDomain)
  [alice1, bob1] <- traverse (createMLSClient def) [alice, bob]
  void $ uploadNewKeyPackage def bob1
  convId <- createNewGroup def alice1
  void $ createAddCommit alice1 convId [] >>= sendAndConsumeCommitBundle
  res <- createAddProposals convId alice1 [bob] >>= traverse sendAndConsumeMessage >>= assertOne
  shouldBeEmpty (res %. "events")

-- @SF.Separation @TSFI.RESTfulAPI @S2
--
-- This test verifies that the server rejects any commit that does not
-- reference all pending proposals in an MLS group.
testCommitNotReferencingAllProposals :: (HasCallStack) => App ()
testCommitNotReferencingAllProposals :: HasCallStack => App ()
testCommitNotReferencingAllProposals = do
  users@[_alice, bob, charlie] <- [Domain] -> App [Value]
forall domain.
(HasCallStack, MakesValue domain) =>
[domain] -> App [Value]
createAndConnectUsers (Int -> Domain -> [Domain]
forall a. Int -> a -> [a]
replicate Int
3 Domain
OwnDomain)

  [alice1, bob1, charlie1] <- traverse (createMLSClient def) users
  convId <- createNewGroup def alice1
  traverse_ (uploadNewKeyPackage def) [bob1, charlie1]
  void $ createAddCommit alice1 convId [] >>= sendAndConsumeCommitBundle

  gsBackup <- getClientGroupState alice1

  -- create proposals for bob and charlie
  createAddProposals convId alice1 [bob, charlie]
    >>= traverse_ sendAndConsumeMessage

  -- now create a commit referencing only the first proposal
  setClientGroupState alice1 gsBackup
  commit <- createPendingProposalCommit convId alice1

  -- send commit and expect and error
  bindResponse (postMLSCommitBundle alice1 (mkBundle commit)) $ \Response
resp -> do
    Response
resp.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
400
    Response
resp.json App Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"label" App Value -> String -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` String
"mls-commit-missing-references"

-- @END

testUnsupportedCiphersuite :: (HasCallStack) => App ()
testUnsupportedCiphersuite :: HasCallStack => App ()
testUnsupportedCiphersuite = do
  let suite :: Ciphersuite
suite = (String -> Ciphersuite
Ciphersuite String
"0x0003")
  alice <- Domain -> CreateUser -> App Value
forall domain.
(HasCallStack, MakesValue domain) =>
domain -> CreateUser -> App Value
randomUser Domain
OwnDomain CreateUser
forall a. Default a => a
def
  alice1 <- createMLSClient def {ciphersuites = [suite]} alice
  convId <- createNewGroup suite alice1

  mp <- createPendingProposalCommit convId alice1

  bindResponse (postMLSCommitBundle alice1 (mkBundle mp)) $ \Response
resp -> do
    Response
resp.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
400
    Response
resp.json App Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"label" App Value -> String -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` String
"mls-protocol-error"

testBackendRemoveProposal :: (HasCallStack) => Ciphersuite -> Domain -> App ()
testBackendRemoveProposal :: HasCallStack => Ciphersuite -> Domain -> App ()
testBackendRemoveProposal Ciphersuite
suite Domain
domain = do
  [alice, bob] <- [Domain] -> App [Value]
forall domain.
(HasCallStack, MakesValue domain) =>
[domain] -> App [Value]
createAndConnectUsers [Domain
OwnDomain, Domain
domain]
  (alice1 : bobClients) <- traverse (createMLSClient def {ciphersuites = [suite]}) [alice, bob, bob]
  traverse_ (uploadNewKeyPackage suite) bobClients
  convId <- createNewGroup suite alice1

  void $ createAddCommit alice1 convId [bob] >>= sendAndConsumeCommitBundle

  let isRemoveProposalFor :: Int -> Value -> App Bool
      isRemoveProposalFor Int
index Value
e =
        Value -> App Bool
forall a. (HasCallStack, MakesValue a) => a -> App Bool
isNewMLSMessageNotif Value
e App Bool -> App Bool -> App Bool
&&~ do
          msgData <- Value
e Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"payload.0.data" App Value -> (App Value -> App ByteString) -> App ByteString
forall a b. a -> (a -> b) -> b
& App Value -> App ByteString
forall a. (HasCallStack, MakesValue a) => a -> App ByteString
asByteString
          msg <- showMessage suite alice1 msgData
          fieldEquals msg "message.content.body.Proposal.Remove.removed" index

  withWebSocket alice1 \WebSocket
ws -> do
    Value -> App ()
forall u. (HasCallStack, MakesValue u) => u -> App ()
deleteUser Value
bob
    [(Int, ClientIdentity)]
-> ((Int, ClientIdentity) -> App ()) -> App ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ ([Int] -> [ClientIdentity] -> [(Int, ClientIdentity)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
1 ..] [ClientIdentity]
bobClients) \(Int
index, ClientIdentity
_) -> do
      App Value -> App ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (App Value -> App ()) -> App Value -> App ()
forall a b. (a -> b) -> a -> b
$ HasCallStack =>
(Value -> App Bool)
-> ConvId
-> Ciphersuite
-> ClientIdentity
-> Maybe MessagePackage
-> WebSocket
-> App Value
(Value -> App Bool)
-> ConvId
-> Ciphersuite
-> ClientIdentity
-> Maybe MessagePackage
-> WebSocket
-> App Value
consumeMessageWithPredicate (Int -> Value -> App Bool
isRemoveProposalFor Int
index) ConvId
convId Ciphersuite
suite ClientIdentity
alice1 Maybe MessagePackage
forall a. Maybe a
Nothing WebSocket
ws

  bobUser <- asString $ bob %. "id"
  modifyMLSState $ \MLSState
mls ->
    MLSState
mls
      { convs =
          Map.adjust
            ( \MLSConv
conv ->
                MLSConv
conv
                  { members = Set.filter (\ClientIdentity
m -> ClientIdentity
m.user String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
bobUser) conv.members,
                    memberUsers = Set.filter (\Value
quid -> Value
quid Value -> Value -> Bool
forall a. Eq a => a -> a -> Bool
/= ([ClientIdentity] -> ClientIdentity
forall a. HasCallStack => [a] -> a
head [ClientIdentity]
bobClients).qualifiedUserId) conv.memberUsers
                  }
            )
            convId
            mls.convs
      }

  -- alice commits the external proposals
  r <- createPendingProposalCommit convId alice1 >>= sendAndConsumeCommitBundle
  shouldBeEmpty $ r %. "events"

testExternalCommitDuplicateClient :: (HasCallStack) => App ()
testExternalCommitDuplicateClient :: HasCallStack => App ()
testExternalCommitDuplicateClient = do
  alice <- Domain -> CreateUser -> App Value
forall domain.
(HasCallStack, MakesValue domain) =>
domain -> CreateUser -> App Value
randomUser Domain
OwnDomain CreateUser
forall a. Default a => a
def
  [creator, other] <- traverse (createMLSClient def) (replicate 2 alice)
  (_, conv) <- createSelfGroup def creator
  convId <- objConvId conv
  void $ createAddCommit creator convId [alice] >>= sendAndConsumeCommitBundle

  replicateM_ 2 $ uploadNewKeyPackage def other
  void $ createExternalCommit convId other Nothing >>= sendAndConsumeCommitBundle

  -- reset client state
  setClientGroupState other def

  -- rejoin with the same client without removing the existing leaf node
  mp <- createExternalCommit convId other Nothing
  bindResponse (postMLSCommitBundle other (mkBundle mp)) $ \Response
resp -> do
    Response
resp.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
400
    Response
resp.json App Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"label" App Value -> String -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` String
"mls-protocol-error"

testInternalCommitDuplicateClient :: (HasCallStack) => App ()
testInternalCommitDuplicateClient :: HasCallStack => App ()
testInternalCommitDuplicateClient = do
  alice <- Domain -> CreateUser -> App Value
forall domain.
(HasCallStack, MakesValue domain) =>
domain -> CreateUser -> App Value
randomUser Domain
OwnDomain CreateUser
forall a. Default a => a
def
  [alice1, alice2] <- traverse (createMLSClient def) (replicate 2 alice)
  convId <- createNewGroup def alice1
  void $ createAddCommit alice1 convId [alice] >>= sendAndConsumeCommitBundle
  replicateM_ 2 $ uploadNewKeyPackage def alice2
  void $ createAddCommit alice1 convId [alice] >>= sendAndConsumeCommitBundle

  -- wipe key store
  setClientGroupState alice2 def
  (kp, _) <- generateKeyPackage alice2 def

  -- We cannot upload the new key package at this point, because the
  -- signature key won't match. However, alice1 can still use it to craft an
  -- add proposal.
  mp <- createAddCommitWithKeyPackages alice1 convId [(alice2, kp)]
  bindResponse (postMLSCommitBundle alice1 (mkBundle mp)) $ \Response
resp -> do
    Response
resp.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
400
    Response
resp.json App Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"label" App Value -> String -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` String
"mls-protocol-error"

testExternalCommitWrongSignatureKey :: (HasCallStack) => App ()
testExternalCommitWrongSignatureKey :: HasCallStack => App ()
testExternalCommitWrongSignatureKey = do
  alice <- Domain -> CreateUser -> App Value
forall domain.
(HasCallStack, MakesValue domain) =>
domain -> CreateUser -> App Value
randomUser Domain
OwnDomain CreateUser
forall a. Default a => a
def
  [creator, other] <- traverse (createMLSClient def) (replicate 2 alice)
  (_, conv) <- createSelfGroup def creator
  convId <- objConvId conv
  void $ createAddCommit creator convId [alice] >>= sendAndConsumeCommitBundle

  void $ uploadNewKeyPackage def other

  -- reset client state
  setClientGroupState other def

  -- rejoin with another client and a mismatched signature key
  mp <- createExternalCommit convId other Nothing
  bindResponse (postMLSCommitBundle other (mkBundle mp)) $ \Response
resp -> do
    Response
resp.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
403
    Response
resp.json App Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"label" App Value -> String -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` String
"mls-identity-mismatch"

testInternalCommitWrongSignatureKey :: (HasCallStack) => App ()
testInternalCommitWrongSignatureKey :: HasCallStack => App ()
testInternalCommitWrongSignatureKey = do
  alice <- Domain -> CreateUser -> App Value
forall domain.
(HasCallStack, MakesValue domain) =>
domain -> CreateUser -> App Value
randomUser Domain
OwnDomain CreateUser
forall a. Default a => a
def
  [alice1, alice2] <- traverse (createMLSClient def) (replicate 2 alice)
  convId <- createNewGroup def alice1
  void $ createAddCommit alice1 convId [alice] >>= sendAndConsumeCommitBundle

  -- wipe key store and make a new key package
  setClientGroupState alice2 def
  (kp, _) <- generateKeyPackage alice2 def

  mp <- createAddCommitWithKeyPackages alice1 convId [(alice2, kp)]
  bindResponse (postMLSCommitBundle alice1 (mkBundle mp)) $ \Response
resp -> do
    Response
resp.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
403
    Response
resp.json App Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"label" App Value -> String -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` String
"mls-identity-mismatch"

testRemoteAddLegacy :: (HasCallStack) => AnyFedDomain -> App ()
testRemoteAddLegacy :: HasCallStack => AnyFedDomain -> App ()
testRemoteAddLegacy AnyFedDomain
domain = do
  Bool -> App () -> App ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (AnyFedDomain -> Integer
unFedDomain AnyFedDomain
domain Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Integer
0) (App () -> App ()) -> App () -> App ()
forall a b. (a -> b) -> a -> b
$ do
    let suite :: Ciphersuite
suite = String -> Ciphersuite
Ciphersuite String
"0x0001"
    alice <- Domain -> CreateUser -> App Value
forall domain.
(HasCallStack, MakesValue domain) =>
domain -> CreateUser -> App Value
randomUser Domain
OwnDomain CreateUser
forall a. Default a => a
def
    bob <- randomUser domain def
    connectTwoUsers alice bob

    [alice1, bob1] <- traverse (createMLSClient def {ciphersuites = [suite]}) [alice, bob]
    void $ uploadNewKeyPackage suite bob1
    convId <- createNewGroup suite alice1
    void $ createAddCommit alice1 convId [alice, bob] >>= sendAndConsumeCommitBundle

testInvalidLeafNodeSignature :: (HasCallStack) => App ()
testInvalidLeafNodeSignature :: HasCallStack => App ()
testInvalidLeafNodeSignature = do
  alice <- Domain -> CreateUser -> App Value
forall domain.
(HasCallStack, MakesValue domain) =>
domain -> CreateUser -> App Value
randomUser Domain
OwnDomain CreateUser
forall a. Default a => a
def
  [creator, other] <- traverse (createMLSClient def) (replicate 2 alice)
  (_, conv) <- createSelfGroup def creator
  convId <- objConvId conv
  void $ createAddCommit creator convId [alice] >>= sendAndConsumeCommitBundle

  void $ uploadNewKeyPackage def other

  mp <- createExternalCommit convId other Nothing
  bindResponse (postMLSCommitBundle other (mkBundle mp {message = makeSignatureCorrupt mp.message})) $ \Response
resp -> do
    Response
resp.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
400
    Response
resp.json App Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"label" App Value -> String -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` String
"mls-invalid-leaf-node-signature"
  where
    -- This is a hack to make the signature invalid.
    -- It works as long as the format of the MLS message does not change
    -- in any way that changes the offset of the signature.
    -- If this test ever starts flaking, we should consider
    -- factoring the MLS code out of wire-api into a separate shared package
    -- and use it in this test to invalidate the signature.
    makeSignatureCorrupt :: ByteString -> ByteString
    makeSignatureCorrupt :: ByteString -> ByteString
makeSignatureCorrupt ByteString
bs = case Int -> ByteString -> (ByteString, ByteString)
B.splitAt Int
0xb0 ByteString
bs of
      (ByteString
left, ByteString
right) -> case ByteString -> Maybe (Word8, ByteString)
B.uncons ByteString
right of
        Just (Word8
h, ByteString
t) -> ByteString
left ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Word8 -> ByteString
B.singleton (Word8
h Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
`xor` Word8
0x01) ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
t
        Maybe (Word8, ByteString)
Nothing -> ByteString
bs

testGroupInfoMismatch :: (HasCallStack) => App ()
testGroupInfoMismatch :: HasCallStack => App ()
testGroupInfoMismatch = do
  mls <-
    Value
defAllFeatures
      Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"mls.config"
      App Value -> (Value -> App Value) -> App Value
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> Bool -> Value -> App Value
forall a b.
(HasCallStack, MakesValue a, ToJSON b) =>
String -> b -> a -> App Value
setField String
"groupInfoDiagnostics" Bool
True
  withModifiedBackend
    ( def
        { galleyCfg =
            setField "settings.checkGroupInfo" True
              >=> setField
                "settings.featureFlags.mls.defaults"
                ( object
                    [ "status" .= "enabled",
                      "lockStatus" .= "unlocked",
                      "config" .= mls
                    ]
                )
        }
    )
    $ \String
domain -> do
      (alice, tid, [bob, charlie]) <- String -> Int -> App (Value, String, [Value])
forall domain.
(HasCallStack, MakesValue domain) =>
domain -> Int -> App (Value, String, [Value])
createTeam String
domain Int
3
      [alice1, bob1, bob2, charlie1] <- traverse (createMLSClient def) [alice, bob, bob, charlie]
      traverse_ (uploadNewKeyPackage def) [bob1, charlie1]

      conv <- postConversation alice1 defMLS {team = Just tid} >>= getJSON 201
      convId <- objConvId conv
      createGroup def alice1 convId

      mp1 <- createAddCommit alice1 convId [bob]
      void $ sendAndConsumeCommitBundle mp1

      -- attempt a commit with an old group info
      mp2 <- createAddCommit alice1 convId [charlie]
      bindResponse (postMLSCommitBundle mp2.sender (mkBundle mp2 {groupInfo = mp1.groupInfo}))
        $ \Response
resp -> do
          Response
resp.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
400
          Response
resp.json App Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"conv_id" App Value -> App Value -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` (ConvId
convId ConvId -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"id")
          Response
resp.json App Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"group_id" App Value -> App Value -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` (ConvId
convId ConvId -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"group_id")
          Response
resp.json App Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"domain" App Value -> String -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` String
domain
          clients <- Response
resp.json App Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"clients" App Value -> (App Value -> App [Value]) -> App [Value]
forall a b. a -> (a -> b) -> b
& App Value -> App [Value]
forall a. (HasCallStack, MakesValue a) => a -> App [Value]
asList
          length clients `shouldMatchInt` 3
          resp.json %. "commit" `shouldMatchBase64` mp2.message
          resp.json %. "group_info" `shouldMatchBase64` (fromJust mp1.groupInfo)

      -- check that epoch is still 1
      bindResponse (getConversation alice convId) $ \Response
resp -> do
        Response
resp.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
200
        Response
resp.json App Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"epoch" App Value -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
1

      -- attempt an external commit with an old group info
      void $ uploadNewKeyPackage def bob2
      mp3 <- createExternalCommit convId bob2 Nothing
      let bundle = MessagePackage -> ByteString
mkBundle MessagePackage
mp3 {groupInfo = mp1.groupInfo}
      bindResponse (postMLSCommitBundle bob2 bundle)
        $ \Response
resp -> do
          Response
resp.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
400
          Response
resp.json App Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"conv_id" App Value -> App Value -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` (ConvId
convId ConvId -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"id")
          Response
resp.json App Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"group_id" App Value -> App Value -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` (ConvId
convId ConvId -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"group_id")
          Response
resp.json App Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"domain" App Value -> String -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` String
domain
          clients <- Response
resp.json App Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"clients" App Value -> (App Value -> App [Value]) -> App [Value]
forall a b. a -> (a -> b) -> b
& App Value -> App [Value]
forall a. (HasCallStack, MakesValue a) => a -> App [Value]
asList
          length clients `shouldMatchInt` 3
          resp.json %. "commit" `shouldMatchBase64` mp3.message
          resp.json %. "group_info" `shouldMatchBase64` (fromJust mp1.groupInfo)

      -- check that epoch is still 1
      bindResponse (getConversation alice convId) $ \Response
resp -> do
        Response
resp.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
200
        Response
resp.json App Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"epoch" App Value -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
1

testGroupInfoCheckDisabled :: (HasCallStack) => App ()
testGroupInfoCheckDisabled :: HasCallStack => App ()
testGroupInfoCheckDisabled = do
  [alice, bob, charlie] <- [Domain] -> App [Value]
forall domain.
(HasCallStack, MakesValue domain) =>
[domain] -> App [Value]
createAndConnectUsers [Domain
OwnDomain, Domain
OwnDomain, Domain
OwnDomain]
  [alice1, bob1, charlie1] <- traverse (createMLSClient def) [alice, bob, charlie]
  traverse_ (uploadNewKeyPackage def) [bob1, charlie1]
  conv <- createNewGroup def alice1

  mp1 <- createAddCommit alice1 conv [bob]
  void $ sendAndConsumeCommitBundle mp1

  -- attempt a commit with an old group info
  mp2 <- createAddCommit alice1 conv [charlie]
  bindResponse (postMLSCommitBundle mp2.sender (mkBundle mp2 {groupInfo = mp1.groupInfo}))
    $ \Response
resp -> do
      Response
resp.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
201

testGroupInfoAlreadyBroken :: (HasCallStack) => App ()
testGroupInfoAlreadyBroken :: HasCallStack => App ()
testGroupInfoAlreadyBroken = do
  ServiceOverrides -> (HasCallStack => String -> App ()) -> App ()
forall a.
HasCallStack =>
ServiceOverrides -> (HasCallStack => String -> App a) -> App a
withModifiedBackend
    ( ServiceOverrides
forall a. Default a => a
def
        { galleyCfg =
            setField "settings.checkGroupInfo" True
        }
    )
    ((HasCallStack => String -> App ()) -> App ())
-> (HasCallStack => String -> App ()) -> App ()
forall a b. (a -> b) -> a -> b
$ \String
domain -> do
      (alice, tid, [bob, charlie, dee]) <- String -> Int -> App (Value, String, [Value])
forall domain.
(HasCallStack, MakesValue domain) =>
domain -> Int -> App (Value, String, [Value])
createTeam String
domain Int
4
      [alice1, bob1, charlie1, dee1] <- traverse (createMLSClient def) [alice, bob, charlie, dee]
      traverse_ (uploadNewKeyPackage def) [bob1, charlie1, dee1]

      conv <- postConversation alice1 defMLS {team = Just tid} >>= getJSON 201
      convId <- objConvId conv
      createGroup def alice1 convId

      -- add bob normally
      mp1 <- createAddCommit alice1 convId [bob]
      void $ sendAndConsumeCommitBundle mp1

      -- make a commit with an old group info
      mp2 <- createAddCommit alice1 convId [charlie]
      void $ sendAndConsumeCommitBundle mp2 {groupInfo = mp1.groupInfo}

      -- enable feature
      do
        I.setTeamFeatureLockStatus alice tid "mls" "unlocked"
        mls <-
          defAllFeatures
            %. "mls.config"
            >>= setField "groupInfoDiagnostics" True
        let feat = [Pair] -> Value
object [String
"status" String -> String -> Pair
forall a. ToJSON a => String -> a -> Pair
.= String
"enabled", String
"config" String -> Value -> Pair
forall a. ToJSON a => String -> a -> Pair
.= Value
mls]
        void $ setTeamFeatureConfig alice tid "mls" feat >>= getJSON 200

      -- make another commit with an old group info
      -- the group was already broken previously, so this should be accepted
      mp3 <- createAddCommit alice1 convId [dee]
      void $ sendAndConsumeCommitBundle mp3 {groupInfo = mp1.groupInfo}

testAddUsersDirectlyShouldFail :: (HasCallStack) => App ()
testAddUsersDirectlyShouldFail :: HasCallStack => App ()
testAddUsersDirectlyShouldFail = do
  [alice, bob] <- Int -> App Value -> App [Value]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
2 (App Value -> App [Value]) -> App Value -> App [Value]
forall a b. (a -> b) -> a -> b
$ Domain -> CreateUser -> App Value
forall domain.
(HasCallStack, MakesValue domain) =>
domain -> CreateUser -> App Value
randomUser Domain
OwnDomain CreateUser
forall a. Default a => a
def
  conv <- postConversation alice defMLS >>= getJSON 201
  addMembers alice conv def {users = [bob]} `bindResponse` \Response
resp -> do
    Response
resp.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
403
    Response
resp.json App Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"label" App Value -> String -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` String
"invalid-op"