-- 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.SubConversation where

import API.Galley
import Control.Monad.Trans (lift)
import Control.Monad.Trans.Maybe (MaybeT (runMaybeT))
import qualified Data.Map as Map
import qualified Data.Set as Set
import MLS.Util
import Notifications
import SetupHelpers
import Test.MLS.One2One
import Testlib.Prelude

testJoinSubConv :: App ()
testJoinSubConv :: App ()
testJoinSubConv = 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
  void $ createSubConv def convId bob1 "conference"

  -- bob adds his first client to the subconversation
  sub' <- getSubConversation bob convId "conference" >>= getJSON 200
  subConvId <- objConvId sub'
  do
    tm <- sub' %. "epoch_timestamp"
    assertBool "Epoch timestamp should not be null" (tm /= Null)

  -- now alice joins with her own client
  void
    $ createExternalCommit subConvId alice1 Nothing
    >>= sendAndConsumeCommitBundle

testJoinOne2OneSubConv :: App ()
testJoinOne2OneSubConv :: App ()
testJoinOne2OneSubConv = 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]
  one2OneConv <- getMLSOne2OneConversation alice bob >>= getJSON 200
  one2OneConvId <- objConvId (one2OneConv %. "conversation")
  resetOne2OneGroup def alice1 one2OneConv

  void $ createAddCommit alice1 one2OneConvId [bob] >>= sendAndConsumeCommitBundle
  createOne2OneSubConv def one2OneConvId bob1 "conference" (one2OneConv %. "public_keys")

  -- bob adds his first client to the subconversation
  sub' <- getSubConversation bob one2OneConvId "conference" >>= getJSON 200
  subConvId <- objConvId sub'
  do
    tm <- sub' %. "epoch_timestamp"
    assertBool "Epoch timestamp should not be null" (tm /= Null)

  -- now alice joins with her own client
  void
    $ createExternalCommit subConvId alice1 Nothing
    >>= sendAndConsumeCommitBundle

testLeaveOne2OneSubConv :: One2OneScenario -> Leaver -> App ()
testLeaveOne2OneSubConv :: One2OneScenario -> Leaver -> App ()
testLeaveOne2OneSubConv One2OneScenario
scenario Leaver
leaver = do
  -- set up 1-1 conversation
  alice <- Domain -> CreateUser -> App Value
forall domain.
(HasCallStack, MakesValue domain) =>
domain -> CreateUser -> App Value
randomUser Domain
OwnDomain CreateUser
forall a. Default a => a
def
  let otherDomain = One2OneScenario -> Domain
one2OneScenarioUserDomain One2OneScenario
scenario
      convDomain = One2OneScenario -> Domain
one2OneScenarioConvDomain One2OneScenario
scenario
  bob <- createMLSOne2OnePartner otherDomain alice convDomain
  [alice1, bob1] <- traverse (createMLSClient def) [alice, bob]
  void $ uploadNewKeyPackage def bob1
  one2OneConv <- getMLSOne2OneConversation alice bob >>= getJSON 200
  one2OneConvId <- objConvId $ one2OneConv %. "conversation"
  resetOne2OneGroup def alice1 one2OneConv
  void $ createAddCommit alice1 one2OneConvId [bob] >>= sendAndConsumeCommitBundle

  -- create and join subconversation
  createOne2OneSubConv def one2OneConvId alice1 "conference" (one2OneConv %. "public_keys")
  subConvId <- getSubConvId bob one2OneConvId "conference"

  void $ createExternalCommit subConvId bob1 Nothing >>= sendAndConsumeCommitBundle

  -- one of the two clients leaves
  let (leaverClient, leaverIndex, remainingClient) = case leaver of
        Leaver
Alice -> (ClientIdentity
alice1, Int
0, ClientIdentity
bob1)
        Leaver
Bob -> (ClientIdentity
bob1, Int
1, ClientIdentity
alice1)

  withWebSocket remainingClient $ \WebSocket
ws -> do
    HasCallStack => ConvId -> ClientIdentity -> App ()
ConvId -> ClientIdentity -> App ()
leaveConv ConvId
subConvId ClientIdentity
leaverClient
    msg <- HasCallStack =>
ConvId
-> Ciphersuite
-> ClientIdentity
-> Maybe MessagePackage
-> WebSocket
-> App Value
ConvId
-> Ciphersuite
-> ClientIdentity
-> Maybe MessagePackage
-> WebSocket
-> App Value
consumeMessage ConvId
subConvId Ciphersuite
forall a. Default a => a
def ClientIdentity
remainingClient Maybe MessagePackage
forall a. Maybe a
Nothing WebSocket
ws
    msg %. "message.content.body.Proposal.Remove.removed" `shouldMatchInt` leaverIndex
    msg %. "message.content.sender.External" `shouldMatchInt` 0

  -- the other client commits the pending proposal
  void $ createPendingProposalCommit subConvId remainingClient >>= sendAndConsumeCommitBundle

testDeleteParentOfSubConv :: (HasCallStack) => Domain -> App ()
testDeleteParentOfSubConv :: HasCallStack => Domain -> App ()
testDeleteParentOfSubConv 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]

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

  -- bob creates a subconversation and adds his own client
  createSubConv def convId bob1 "conference"
  subConvId <- getSubConvId bob convId "conference"

  -- alice joins with her own client
  void $ createExternalCommit subConvId alice1 Nothing >>= sendAndConsumeCommitBundle

  -- bob sends a message to the subconversation
  do
    mp <- createApplicationMessage subConvId bob1 "hello, alice"
    void . 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

  -- alice sends a message to the subconversation
  do
    mp <- createApplicationMessage subConvId bob1 "hello, bob"
    void . 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

  -- alice deletes main conversation
  withWebSocket bob $ \WebSocket
ws -> do
    App () -> App ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (App () -> App ())
-> ((Response -> App ()) -> App ())
-> (Response -> App ())
-> App ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. App Response -> (Response -> App ()) -> App ()
forall a.
HasCallStack =>
App Response -> (Response -> App a) -> App a
bindResponse (String -> Value -> Value -> App Response
forall team conv user.
(HasCallStack, MakesValue team, MakesValue conv,
 MakesValue user) =>
team -> conv -> user -> App Response
deleteTeamConv String
tid (ConvId -> Value
convIdToQidObject ConvId
convId) Value
alice) ((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
    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) -> WebSocket -> App Value
(Value -> App Bool) -> WebSocket -> App Value
awaitMatch Value -> App Bool
forall a. (HasCallStack, MakesValue a) => a -> App Bool
isConvDeleteNotif WebSocket
ws

  -- bob fails to send a message to the subconversation
  do
    mp <- createApplicationMessage subConvId bob1 "hello, alice"
    void . 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
404
      case Domain
secondDomain of
        Domain
OwnDomain -> 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
"no-conversation"
        Domain
OtherDomain -> 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
"no-conversation-member"

  -- alice fails to send a message to the subconversation
  do
    mp <- createApplicationMessage subConvId alice1 "hello, bob"
    void . 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
404
      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
"no-conversation"

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

  createSubConv def convId alice1 "conference1"
  sub1 <- getSubConversation alice convId "conference1" >>= getJSON 200
  void $ deleteSubConversation charlie sub1 >>= getBody 403
  void $ deleteSubConversation alice sub1 >>= getBody 200

  createSubConv def convId alice1 "conference2"
  sub2 <- getSubConversation alice convId "conference2" >>= getJSON 200
  void $ deleteSubConversation bob sub2 >>= getBody 200

  sub2' <- getSubConversation alice1 convId "conference2" >>= getJSON 200
  sub2 `shouldNotMatch` sub2'

data Leaver = Alice | Bob
  deriving stock ((forall x. Leaver -> Rep Leaver x)
-> (forall x. Rep Leaver x -> Leaver) -> Generic Leaver
forall x. Rep Leaver x -> Leaver
forall x. Leaver -> Rep Leaver x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Leaver -> Rep Leaver x
from :: forall x. Leaver -> Rep Leaver x
$cto :: forall x. Rep Leaver x -> Leaver
to :: forall x. Rep Leaver x -> Leaver
Generic)

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

  withWebSockets [bob, charlie] $ \[WebSocket]
wss -> 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 =>
ClientIdentity -> ConvId -> [Value] -> App MessagePackage
ClientIdentity -> ConvId -> [Value] -> App MessagePackage
createAddCommit ClientIdentity
alice1 ConvId
convId [Value
bob, 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 => MessagePackage -> App Value
MessagePackage -> App Value
sendAndConsumeCommitBundle
    (WebSocket -> App Value) -> [WebSocket] -> App ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (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
isMemberJoinNotif) [WebSocket]
wss

  createSubConv def convId bob1 "conference"
  subConvId <- getSubConvId bob convId "conference"
  void $ createExternalCommit subConvId alice1 Nothing >>= sendAndConsumeCommitBundle
  void $ createExternalCommit subConvId bob2 Nothing >>= sendAndConsumeCommitBundle
  void $ createExternalCommit subConvId charlie1 Nothing >>= sendAndConsumeCommitBundle

  -- a member leaves the subconversation
  let (firstLeaver, idxFirstLeaver) = case leaver of
        Leaver
Bob -> (ClientIdentity
bob1, Int
0)
        Leaver
Alice -> (ClientIdentity
alice1, Int
1)
  let idxCharlie1 = Int
3

  let others = (ClientIdentity -> Bool) -> [ClientIdentity] -> [ClientIdentity]
forall a. (a -> Bool) -> [a] -> [a]
filter (ClientIdentity -> ClientIdentity -> Bool
forall a. Eq a => a -> a -> Bool
/= ClientIdentity
firstLeaver) [ClientIdentity]
clients
  withWebSockets others $ \[WebSocket]
wss -> do
    HasCallStack => ConvId -> ClientIdentity -> App ()
ConvId -> ClientIdentity -> App ()
leaveConv ConvId
subConvId ClientIdentity
firstLeaver

    [(ClientIdentity, WebSocket)]
-> ((ClientIdentity, WebSocket) -> App ()) -> App ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ ([ClientIdentity] -> [WebSocket] -> [(ClientIdentity, WebSocket)]
forall a b. [a] -> [b] -> [(a, b)]
zip [ClientIdentity]
others [WebSocket]
wss) (((ClientIdentity, WebSocket) -> App ()) -> App ())
-> ((ClientIdentity, WebSocket) -> App ()) -> App ()
forall a b. (a -> b) -> a -> b
$ \(ClientIdentity
cid, WebSocket
ws) -> do
      msg <- HasCallStack =>
ConvId
-> Ciphersuite
-> ClientIdentity
-> Maybe MessagePackage
-> WebSocket
-> App Value
ConvId
-> Ciphersuite
-> ClientIdentity
-> Maybe MessagePackage
-> WebSocket
-> App Value
consumeMessage ConvId
subConvId Ciphersuite
forall a. Default a => a
def ClientIdentity
cid Maybe MessagePackage
forall a. Maybe a
Nothing WebSocket
ws
      msg %. "message.content.body.Proposal.Remove.removed" `shouldMatchInt` idxFirstLeaver
      msg %. "message.content.sender.External" `shouldMatchInt` 0

  withWebSockets (tail others) $ \[WebSocket]
wss -> do
    -- a member commits the pending proposal
    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 => ConvId -> ClientIdentity -> App MessagePackage
ConvId -> ClientIdentity -> App MessagePackage
createPendingProposalCommit ConvId
subConvId ([ClientIdentity] -> ClientIdentity
forall a. HasCallStack => [a] -> a
head [ClientIdentity]
others) 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 => MessagePackage -> App Value
MessagePackage -> App Value
sendAndConsumeCommitBundle
    (WebSocket -> App Value) -> [WebSocket] -> App ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (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]
wss

    -- send an application message
    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 =>
ConvId -> ClientIdentity -> String -> App MessagePackage
ConvId -> ClientIdentity -> String -> App MessagePackage
createApplicationMessage ConvId
subConvId ([ClientIdentity] -> ClientIdentity
forall a. HasCallStack => [a] -> a
head [ClientIdentity]
others) String
"good riddance" 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 => MessagePackage -> App Value
MessagePackage -> App Value
sendAndConsumeMessage
    (WebSocket -> App Value) -> [WebSocket] -> App ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (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]
wss

  -- check that only 3 clients are left in the subconv
  do
    conv <- getConv subConvId (head others)
    mems <- conv %. "members" & asList
    length mems `shouldMatchInt` 3

  -- charlie1 leaves
  let others' = (ClientIdentity -> Bool) -> [ClientIdentity] -> [ClientIdentity]
forall a. (a -> Bool) -> [a] -> [a]
filter (ClientIdentity -> ClientIdentity -> Bool
forall a. Eq a => a -> a -> Bool
/= ClientIdentity
charlie1) [ClientIdentity]
others
  withWebSockets others' $ \[WebSocket]
wss -> do
    HasCallStack => ConvId -> ClientIdentity -> App ()
ConvId -> ClientIdentity -> App ()
leaveConv ConvId
subConvId ClientIdentity
charlie1

    [(ClientIdentity, WebSocket)]
-> ((ClientIdentity, WebSocket) -> App ()) -> App ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ ([ClientIdentity] -> [WebSocket] -> [(ClientIdentity, WebSocket)]
forall a b. [a] -> [b] -> [(a, b)]
zip [ClientIdentity]
others' [WebSocket]
wss) (((ClientIdentity, WebSocket) -> App ()) -> App ())
-> ((ClientIdentity, WebSocket) -> App ()) -> App ()
forall a b. (a -> b) -> a -> b
$ \(ClientIdentity
cid, WebSocket
ws) -> do
      msg <- HasCallStack =>
ConvId
-> Ciphersuite
-> ClientIdentity
-> Maybe MessagePackage
-> WebSocket
-> App Value
ConvId
-> Ciphersuite
-> ClientIdentity
-> Maybe MessagePackage
-> WebSocket
-> App Value
consumeMessage ConvId
subConvId Ciphersuite
forall a. Default a => a
def ClientIdentity
cid Maybe MessagePackage
forall a. Maybe a
Nothing WebSocket
ws
      msg %. "message.content.body.Proposal.Remove.removed" `shouldMatchInt` idxCharlie1
      msg %. "message.content.sender.External" `shouldMatchInt` 0

  -- a member commits the pending proposal
  void $ createPendingProposalCommit subConvId (head others') >>= sendAndConsumeCommitBundle

  -- check that only 2 clients are left in the subconv
  do
    conv <- getConv subConvId (head others)
    mems <- conv %. "members" & asList
    length mems `shouldMatchInt` 2

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

    _ <- createAddCommit alice1 convId [bob, charlie] >>= sendAndConsumeCommitBundle

    -- save the state of the parent group
    let subConvName = String
"conference"
    createSubConv def convId alice1 subConvName
    subConvId <- getSubConvId alice convId "conference"

    for_ [bob1, bob2, charlie1, charlie2] \ClientIdentity
c ->
      HasCallStack =>
ConvId -> ClientIdentity -> Maybe ByteString -> App MessagePackage
ConvId -> ClientIdentity -> Maybe ByteString -> App MessagePackage
createExternalCommit ConvId
subConvId ClientIdentity
c Maybe ByteString
forall a. Maybe a
Nothing 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 => MessagePackage -> App Value
MessagePackage -> App Value
sendAndConsumeCommitBundle

    withWebSockets [alice1, charlie1, charlie2] \[WebSocket]
wss -> do
      removeCommitEvents <- HasCallStack =>
ClientIdentity -> ConvId -> [ClientIdentity] -> App MessagePackage
ClientIdentity -> ConvId -> [ClientIdentity] -> App MessagePackage
createRemoveCommit ClientIdentity
alice1 ConvId
convId [ClientIdentity
bob1, ClientIdentity
bob2] 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 => MessagePackage -> App Value
MessagePackage -> App Value
sendAndConsumeCommitBundle
      modifyMLSState $ \MLSState
s ->
        MLSState
s
          { convs =
              Map.adjust
                ( \MLSConv
conv ->
                    MLSConv
conv
                      { members = conv.members Set.\\ Set.fromList [bob1, bob2],
                        memberUsers = conv.memberUsers Set.\\ Set.fromList [bob1.qualifiedUserId]
                      }
                )
                convId
                s.convs
          }

      removeCommitEvents %. "events.0.type" `shouldMatch` "conversation.member-leave"
      removeCommitEvents %. "events.0.data.reason" `shouldMatch` "removed"
      removeCommitEvents %. "events.0.from" `shouldMatch` alice1.user

      for_ wss \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
isConvLeaveNotif WebSocket
ws
        n %. "payload.0.data.reason" `shouldMatch` "removed"
        n %. "payload.0.from" `shouldMatch` alice1.user

      let idxBob1 :: Int = 1
          idxBob2 :: Int = 2
      for_ ((,) <$> [idxBob1, idxBob2] <*> wss) \(Int
idx, WebSocket
ws) -> do
        msg <-
          HasCallStack => (Value -> App Bool) -> WebSocket -> App Value
(Value -> App Bool) -> WebSocket -> App Value
awaitMatch
            do
              \Value
n ->
                Maybe Bool -> Bool
forall a. Maybe a -> Bool
isJust (Maybe Bool -> Bool) -> App (Maybe Bool) -> App Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MaybeT App Bool -> App (Maybe Bool)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT do
                  msg <- App Value -> MaybeT App Value
forall (m :: * -> *) a. Monad m => m a -> MaybeT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (App Value -> MaybeT App Value) -> App Value -> MaybeT App Value
forall a b. (a -> b) -> a -> b
$ Value
n 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 App ByteString -> (ByteString -> 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 =>
Ciphersuite -> ClientIdentity -> ByteString -> App Value
Ciphersuite -> ClientIdentity -> ByteString -> App Value
showMessage Ciphersuite
forall a. Default a => a
def ClientIdentity
alice1
                  guard =<< lift do
                    isNewMLSMessageNotif n

                  prop <-
                    maybe mzero pure =<< lift do
                      lookupField msg "message.content.body.Proposal"

                  lift do
                    (== idx) <$> (prop %. "Remove.removed" & asInt)
            WebSocket
ws
        for_ ws.client $ \ClientIdentity
consumer ->
          Value
msg 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 App ByteString -> (ByteString -> 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 =>
ConvId
-> Ciphersuite -> ClientIdentity -> ByteString -> App ByteString
ConvId
-> Ciphersuite -> ClientIdentity -> ByteString -> App ByteString
mlsCliConsume ConvId
subConvId Ciphersuite
forall a. Default a => a
def ClientIdentity
consumer

      -- remove bob from the child state
      modifyMLSState $ \MLSState
s ->
        MLSState
s
          { convs =
              Map.adjust
                ( \MLSConv
conv ->
                    MLSConv
conv
                      { members = conv.members Set.\\ Set.fromList [bob1, bob2],
                        memberUsers = conv.memberUsers Set.\\ Set.fromList [bob1.qualifiedUserId]
                      }
                )
                subConvId
                s.convs
          }

      _ <- createPendingProposalCommit subConvId alice1 >>= sendAndConsumeCommitBundle

      getSubConversation bob convId subConvName >>= flip withResponse \Response
resp ->
        HasCallStack => String -> Bool -> App ()
String -> Bool -> App ()
assertBool String
"access to the conversation for bob should be denied" (Response
resp.status Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
403)

      for_ [charlie, alice] \Value
m -> do
        resp <- Value -> ConvId -> String -> App Response
forall user.
(HasCallStack, MakesValue user) =>
user -> ConvId -> String -> App Response
getSubConversation Value
m ConvId
convId String
subConvName
        assertBool "alice and charlie should have access to the conversation" (resp.status == 200)
        mems <- resp.jsonBody %. "members" & asList
        mems `shouldMatchSet` ((renameField "id" "user_id" <=< make) `traverse` [alice1, charlie1, charlie2])

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

  conv <- createNewGroup def alice1
  void $ createAddCommit alice1 conv [alice, bob, charlie] >>= sendAndConsumeCommitBundle

  createSubConv def conv alice1 "conference"
  subConvId <- getSubConvId alice conv "conference"

  void $ createExternalCommit subConvId alice2 Nothing >>= sendAndConsumeCommitBundle
  void $ createExternalCommit subConvId bob1 Nothing >>= sendAndConsumeCommitBundle
  void $ createExternalCommit subConvId bob2 Nothing >>= sendAndConsumeCommitBundle
  void $ createExternalCommit subConvId bob3 Nothing >>= sendAndConsumeCommitBundle

  withWebSockets [alice1, alice2, charlie1] \[WebSocket]
wss -> do
    HasCallStack => ConvId -> ClientIdentity -> App ()
ConvId -> ClientIdentity -> App ()
leaveConv ConvId
subConvId ClientIdentity
bob1
    HasCallStack => ConvId -> ClientIdentity -> App ()
ConvId -> ClientIdentity -> App ()
leaveConv ConvId
subConvId ClientIdentity
bob2
    HasCallStack => ConvId -> ClientIdentity -> App ()
ConvId -> ClientIdentity -> App ()
leaveConv ConvId
subConvId ClientIdentity
bob3
    [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 ->
      Bool -> App () -> App ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (WebSocket
ws.client Maybe ClientIdentity -> Maybe ClientIdentity -> Bool
forall a. Eq a => a -> a -> Bool
/= ClientIdentity -> Maybe ClientIdentity
forall a. a -> Maybe a
Just ClientIdentity
charlie1) (App () -> App ()) -> App () -> App ()
forall a b. (a -> b) -> a -> b
$ do
        Int -> App () -> App ()
forall (m :: * -> *) a. Applicative m => Int -> m a -> m ()
replicateM_ Int
3 do
          msg <- HasCallStack =>
ConvId
-> Ciphersuite
-> ClientIdentity
-> Maybe MessagePackage
-> WebSocket
-> App Value
ConvId
-> Ciphersuite
-> ClientIdentity
-> Maybe MessagePackage
-> WebSocket
-> App Value
consumeMessage ConvId
subConvId Ciphersuite
forall a. Default a => a
def (Maybe ClientIdentity -> ClientIdentity
forall a. HasCallStack => Maybe a -> a
fromJust WebSocket
ws.client) Maybe MessagePackage
forall a. Maybe a
Nothing WebSocket
ws
          msg %. "message.content.sender.External" `shouldMatchInt` 0

    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 =>
ConvId -> ClientIdentity -> Maybe ByteString -> App MessagePackage
ConvId -> ClientIdentity -> Maybe ByteString -> App MessagePackage
createExternalCommit ConvId
subConvId ClientIdentity
charlie1 Maybe ByteString
forall a. Maybe a
Nothing
      App MessagePackage
-> (MessagePackage -> App Response) -> App Response
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (HasCallStack => ClientIdentity -> ByteString -> App Response
ClientIdentity -> ByteString -> App Response
postMLSCommitBundle ClientIdentity
charlie1 (ByteString -> App Response)
-> (MessagePackage -> ByteString) -> MessagePackage -> App Response
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MessagePackage -> ByteString
mkBundle)
      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
201

    -- increment epoch and add charlie1
    (MLSState -> MLSState) -> App ()
modifyMLSState ((MLSState -> MLSState) -> App ())
-> (MLSState -> MLSState) -> App ()
forall a b. (a -> b) -> a -> b
$ \MLSState
mls ->
      MLSState
mls
        { convs =
            Map.adjust
              ( \MLSConv
conv' ->
                  MLSConv
conv'
                    { epoch = conv'.epoch + 1,
                      members = conv'.members <> conv'.newMembers,
                      newMembers = mempty
                    }
              )
              subConvId
              mls.convs
        }

    -- consume proposals after backend resends them
    [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
      Bool -> App () -> App ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (WebSocket
ws.client Maybe ClientIdentity -> Maybe ClientIdentity -> Bool
forall a. Eq a => a -> a -> Bool
/= ClientIdentity -> Maybe ClientIdentity
forall a. a -> Maybe a
Just ClientIdentity
charlie1) (App () -> App ()) -> App () -> App ()
forall a b. (a -> b) -> a -> b
$ do
        commitMsg <- HasCallStack =>
ConvId
-> Ciphersuite
-> ClientIdentity
-> Maybe MessagePackage
-> WebSocket
-> App Value
ConvId
-> Ciphersuite
-> ClientIdentity
-> Maybe MessagePackage
-> WebSocket
-> App Value
consumeMessage ConvId
subConvId Ciphersuite
forall a. Default a => a
def (Maybe ClientIdentity -> ClientIdentity
forall a. HasCallStack => Maybe a -> a
fromJust WebSocket
ws.client) Maybe MessagePackage
forall a. Maybe a
Nothing WebSocket
ws
        commitMsg %. "message.content.sender" `shouldMatch` "NewMemberCommit"
      Int -> App () -> App ()
forall (m :: * -> *) a. Applicative m => Int -> m a -> m ()
replicateM_ Int
3 do
        msg <- HasCallStack =>
ConvId
-> Ciphersuite
-> ClientIdentity
-> Maybe MessagePackage
-> WebSocket
-> App Value
ConvId
-> Ciphersuite
-> ClientIdentity
-> Maybe MessagePackage
-> WebSocket
-> App Value
consumeMessage ConvId
subConvId Ciphersuite
forall a. Default a => a
def (Maybe ClientIdentity -> ClientIdentity
forall a. HasCallStack => Maybe a -> a
fromJust WebSocket
ws.client) Maybe MessagePackage
forall a. Maybe a
Nothing WebSocket
ws
        msg %. "message.content.sender.External" `shouldMatchInt` 0

  void $ createPendingProposalCommit subConvId alice1 >>= sendAndConsumeCommitBundle

  sub <- getSubConversation alice1 conv "conference" >>= getJSON 200
  let members =
        (ClientIdentity -> Value) -> [ClientIdentity] -> [Value]
forall a b. (a -> b) -> [a] -> [b]
map
          ( \ClientIdentity
cid ->
              [Pair] -> Value
object
                [ String
"client_id" String -> String -> Pair
forall a. ToJSON a => String -> a -> Pair
.= ClientIdentity
cid.client,
                  String
"user_id" String -> String -> Pair
forall a. ToJSON a => String -> a -> Pair
.= ClientIdentity
cid.user,
                  String
"domain" String -> String -> Pair
forall a. ToJSON a => String -> a -> Pair
.= ClientIdentity
cid.domain
                ]
          )
          [ClientIdentity
alice1, ClientIdentity
alice2, ClientIdentity
charlie1]
  sub %. "members" `shouldMatchSet` members