-- This file is part of the Wire Server implementation.
--
-- Copyright (C) 2023 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.One2One where

import API.Brig
import API.Galley
import Control.Concurrent.Async
import Control.Concurrent.MVar
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.Read as T
import MLS.Util
import Notifications
import SetupHelpers
import Test.Version
import Testlib.Prelude
import Testlib.VersionedFed

testGetMLSOne2OneLocalV5 :: (HasCallStack) => App ()
testGetMLSOne2OneLocalV5 :: HasCallStack => App ()
testGetMLSOne2OneLocalV5 = Version5 -> App () -> App ()
forall a. Version5 -> App a -> App a
withVersion5 Version5
Version5 (App () -> App ()) -> App () -> App ()
forall a b. (a -> b) -> a -> b
$ do
  [alice, bob] <- [Domain] -> App [Value]
forall domain.
(HasCallStack, MakesValue domain) =>
[domain] -> App [Value]
createAndConnectUsers [Domain
OwnDomain, Domain
OwnDomain]
  let assertConvData a
conv = do
        a
conv a -> 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
        a
conv a -> 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

  convId <-
    getMLSOne2OneConversationLegacy alice bob `bindResponse` \Response
resp -> do
      conv <- HasCallStack => Int -> Response -> App Value
Int -> Response -> App Value
getJSON Int
200 Response
resp
      conv %. "type" `shouldMatchInt` 2
      shouldBeEmpty (conv %. "members.others")

      conv %. "members.self.conversation_role" `shouldMatch` "wire_member"
      conv %. "members.self.qualified_id" `shouldMatch` (alice %. "qualified_id")
      assertConvData conv

      conv %. "qualified_id"

  -- check that the conversation has the same ID on the other side
  conv2 <- bindResponse (getMLSOne2OneConversationLegacy bob alice) $ \Response
resp -> do
    Response
resp.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
200
    Response
resp.json

  conv2 %. "type" `shouldMatchInt` 2
  conv2 %. "qualified_id" `shouldMatch` convId
  assertConvData conv2

testGetMLSOne2OneRemoteV5 :: (HasCallStack) => App ()
testGetMLSOne2OneRemoteV5 :: HasCallStack => App ()
testGetMLSOne2OneRemoteV5 = Version5 -> App () -> App ()
forall a. Version5 -> App a -> App a
withVersion5 Version5
Version5 (App () -> App ()) -> App () -> App ()
forall a b. (a -> b) -> a -> b
$ do
  [alice, bob] <- [Domain] -> App [Value]
forall domain.
(HasCallStack, MakesValue domain) =>
[domain] -> App [Value]
createAndConnectUsers [Domain
OwnDomain, Domain
OtherDomain]
  getMLSOne2OneConversationLegacy alice bob `bindResponse` \Response
resp -> do
    Response
resp.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
400
    Response
resp.jsonBody Maybe 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-federated-one2one-not-supported"

  getMLSOne2OneConversationLegacy bob alice `bindResponse` \Response
resp -> do
    Response
resp.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
400
    Response
resp.jsonBody Maybe 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-federated-one2one-not-supported"

testGetMLSOne2One :: (HasCallStack) => Domain -> App ()
testGetMLSOne2One :: HasCallStack => Domain -> App ()
testGetMLSOne2One Domain
bobDomain = do
  [alice, bob] <- [Domain] -> App [Value]
forall domain.
(HasCallStack, MakesValue domain) =>
[domain] -> App [Value]
createAndConnectUsers [Domain
OwnDomain, Domain
bobDomain]
  bobDomainStr <- asString bobDomain
  let assertConvData a
conv = do
        a
conv a -> 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
        a -> String -> App ()
forall a. (HasCallStack, MakesValue a) => a -> String -> App ()
assertFieldMissing a
conv String
"cipher_suite"

  mlsOne2OneConv <-
    getMLSOne2OneConversation alice bob `bindResponse` \Response
resp -> do
      one2oneConv <- HasCallStack => Int -> Response -> App Value
Int -> Response -> App Value
getJSON Int
200 Response
resp
      convOwnerDomain <- asString $ one2oneConv %. "conversation.qualified_id.domain"
      let user = if String
convOwnerDomain String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
bobDomainStr then Value
bob else Value
alice
      ownerDomainPublicKeys <- getMLSPublicKeys user >>= getJSON 200

      one2oneConv %. "public_keys" `shouldMatch` ownerDomainPublicKeys

      conv <- one2oneConv %. "conversation"
      conv %. "type" `shouldMatchInt` 2
      shouldBeEmpty (conv %. "members.others")
      conv %. "members.self.conversation_role" `shouldMatch` "wire_member"
      conv %. "members.self.qualified_id" `shouldMatch` (alice %. "qualified_id")
      assertConvData conv

      pure one2oneConv

  -- check that the conversation has the same ID on the other side
  mlsOne2OneConv2 <- bindResponse (getMLSOne2OneConversation bob alice) $ \Response
resp -> do
    Response
resp.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
200
    Response
resp.json

  conv2 <- mlsOne2OneConv2 %. "conversation"
  conv2 %. "type" `shouldMatchInt` 2
  conv2 %. "qualified_id" `shouldMatch` (mlsOne2OneConv %. "conversation.qualified_id")
  mlsOne2OneConv2 %. "public_keys" `shouldMatch` (mlsOne2OneConv %. "public_keys")
  assertConvData conv2

testMLSOne2OneOtherMember :: (HasCallStack) => One2OneScenario -> App ()
testMLSOne2OneOtherMember :: HasCallStack => One2OneScenario -> App ()
testMLSOne2OneOtherMember One2OneScenario
scenario = 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
  let otherDomain = One2OneScenario -> Domain
one2OneScenarioUserDomain One2OneScenario
scenario
      convDomain = One2OneScenario -> Domain
one2OneScenarioConvDomain One2OneScenario
scenario
  bob <- createMLSOne2OnePartner otherDomain alice convDomain
  one2OneConv <- getMLSOne2OneConversation alice bob >>= getJSON 200
  one2OneConvId <- objConvId $ one2OneConv %. "conversation"
  do
    convId <- one2OneConv %. "conversation.qualified_id"
    bobOne2OneConv <- getMLSOne2OneConversation bob alice >>= getJSON 200
    convId `shouldMatch` (bobOne2OneConv %. "conversation.qualified_id")

  [alice1, bob1] <- traverse (createMLSClient def) [alice, bob]
  void $ uploadNewKeyPackage def bob1
  resetOne2OneGroup def alice1 one2OneConv
  withWebSocket bob1 $ \WebSocket
ws -> do
    commit <- HasCallStack =>
ClientIdentity -> ConvId -> [Value] -> App MessagePackage
ClientIdentity -> ConvId -> [Value] -> App MessagePackage
createAddCommit ClientIdentity
alice1 ConvId
one2OneConvId [Value
bob]
    void $ sendAndConsumeCommitBundle commit
    let isMessage 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 isMessage ws
    nPayload n %. "data" `shouldMatch` B8.unpack (Base64.encode (fold commit.welcome))

  -- Make sure the membership info is OK both for the MLS 1-to-1 endpoint and
  -- for the general conversation fetching endpoint.
  let assertOthers :: (HasCallStack, MakesValue other, MakesValue retrievedConv) => other -> retrievedConv -> App ()
      assertOthers other
other retrievedConv
retrievedConv = do
        othersObj <- retrievedConv
retrievedConv retrievedConv -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"members.others" 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
        otherActual <- assertOne othersObj
        otherActual %. "qualified_id" `shouldMatch` (other %. "qualified_id")
  forM_ [(alice, bob), (bob, alice)] $ \(Value
self, Value
other) -> do
    Value -> Value -> App Response
forall self other.
(HasCallStack, MakesValue self, MakesValue other) =>
self -> other -> App Response
getMLSOne2OneConversation Value
self Value
other App Response -> (Response -> App ()) -> App ()
forall a.
HasCallStack =>
App Response -> (Response -> App a) -> App a
`bindResponse` \Response
resp -> do
      retrievedConv <- HasCallStack => Int -> Response -> App Value
Int -> Response -> App Value
getJSON Int
200 Response
resp 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
>>= (Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"conversation")
      assertOthers other retrievedConv
    Value -> App Value -> App Response
forall self other.
(HasCallStack, MakesValue self, MakesValue other) =>
self -> other -> App Response
getConversation Value
self (Value
one2OneConv Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"conversation") App Response -> (Response -> App ()) -> App ()
forall a.
HasCallStack =>
App Response -> (Response -> App a) -> App a
`bindResponse` \Response
resp -> do
      retrievedConv <- HasCallStack => Int -> Response -> App Value
Int -> Response -> App Value
getJSON Int
200 Response
resp
      assertOthers other retrievedConv

testMLSOne2OneRemoveClientLocalV5 :: App ()
testMLSOne2OneRemoveClientLocalV5 :: App ()
testMLSOne2OneRemoveClientLocalV5 = Version5 -> App () -> App ()
forall a. Version5 -> App a -> App a
withVersion5 Version5
Version5 (App () -> App ()) -> App () -> App ()
forall a b. (a -> b) -> a -> b
$ do
  [alice, bob] <- [Domain] -> App [Value]
forall domain.
(HasCallStack, MakesValue domain) =>
[domain] -> App [Value]
createAndConnectUsers [Domain
OwnDomain, Domain
OwnDomain]
  conv <- getMLSOne2OneConversationLegacy alice bob >>= getJSON 200

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

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

  withWebSocket alice $ \WebSocket
wsAlice -> do
    _ <- Value -> String -> App Response
forall self other.
(HasCallStack, MakesValue self, MakesValue other) =>
self -> other -> 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
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 <- awaitMatch predicate wsAlice
    shouldMatch (nPayload n %. "conversation") (objId conv)
    shouldMatch (nPayload n %. "from") (objId bob)

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

    -- Checks that the remove proposal is consumable by alice
    void $ mlsCliConsume convId def alice1 mlsMsg

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

testGetMLSOne2OneUnconnected :: (HasCallStack) => Domain -> App ()
testGetMLSOne2OneUnconnected :: HasCallStack => Domain -> App ()
testGetMLSOne2OneUnconnected Domain
otherDomain = do
  [alice, bob] <- [Domain] -> (Domain -> App Value) -> App [Value]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [Domain
OwnDomain, Domain
otherDomain] ((Domain -> App Value) -> App [Value])
-> (Domain -> App Value) -> App [Value]
forall a b. (a -> b) -> a -> b
$ \Domain
domain -> Domain -> CreateUser -> App Value
forall domain.
(HasCallStack, MakesValue domain) =>
domain -> CreateUser -> App Value
randomUser Domain
domain CreateUser
forall a. Default a => a
def

  bindResponse (getMLSOne2OneConversation alice bob) $ \Response
resp ->
    Response
resp.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
403

testMLSOne2OneBlocked :: (HasCallStack) => Domain -> App ()
testMLSOne2OneBlocked :: HasCallStack => Domain -> App ()
testMLSOne2OneBlocked Domain
otherDomain = do
  [alice, bob] <- [Domain] -> (Domain -> App Value) -> App [Value]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [Domain
OwnDomain, Domain
otherDomain] ((Domain -> App Value) -> App [Value])
-> (Domain -> App Value) -> App [Value]
forall a b. (a -> b) -> a -> b
$ (Domain -> CreateUser -> App Value)
-> CreateUser -> Domain -> App Value
forall a b c. (a -> b -> c) -> b -> a -> c
flip Domain -> CreateUser -> App Value
forall domain.
(HasCallStack, MakesValue domain) =>
domain -> CreateUser -> App Value
randomUser CreateUser
forall a. Default a => a
def
  void $ postConnection bob alice >>= getBody 201
  void $ putConnection alice bob "blocked" >>= getBody 200
  void $ getMLSOne2OneConversation alice bob >>= getJSON 403
  void $ getMLSOne2OneConversation bob alice >>= getJSON 403

-- | Alice and Bob are initially connected, but then Alice blocks Bob.
testMLSOne2OneBlockedAfterConnected :: (HasCallStack) => One2OneScenario -> App ()
testMLSOne2OneBlockedAfterConnected :: HasCallStack => One2OneScenario -> App ()
testMLSOne2OneBlockedAfterConnected One2OneScenario
scenario = 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
  let otherDomain = One2OneScenario -> Domain
one2OneScenarioUserDomain One2OneScenario
scenario
      convDomain = One2OneScenario -> Domain
one2OneScenarioConvDomain One2OneScenario
scenario
  bob <- createMLSOne2OnePartner otherDomain alice convDomain
  one2OneConv <- getMLSOne2OneConversation alice bob >>= getJSON 200
  one2OneConvId <- objConvId $ one2OneConv %. "conversation"
  convId <- one2OneConv %. "conversation.qualified_id"
  do
    bobConv <- getMLSOne2OneConversation bob alice >>= getJSON 200
    convId `shouldMatch` (bobConv %. "conversation.qualified_id")

  [alice1, bob1] <- traverse (createMLSClient def) [alice, bob]
  void $ uploadNewKeyPackage def bob1
  resetOne2OneGroup def alice1 one2OneConv
  commit <- createAddCommit alice1 one2OneConvId [bob]
  withWebSocket bob1 $ \WebSocket
ws -> 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 => MessagePackage -> App Value
MessagePackage -> App Value
sendAndConsumeCommitBundle MessagePackage
commit
    let isMessage :: a -> App Bool
isMessage 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 <- HasCallStack => (Value -> App Bool) -> WebSocket -> App Value
(Value -> App Bool) -> WebSocket -> App Value
awaitMatch Value -> App Bool
forall {a}. MakesValue a => a -> App Bool
isMessage WebSocket
ws
    nPayload n %. "data" `shouldMatch` B8.unpack (Base64.encode (fold commit.welcome))

  withWebSocket bob1 $ \WebSocket
ws -> do
    -- Alice blocks Bob
    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 -> Value -> String -> App Response
forall userFrom userTo status.
(HasCallStack, MakesValue userFrom, MakesValue userTo,
 MakesValue status) =>
userFrom -> userTo -> status -> App Response
putConnection Value
alice Value
bob String
"blocked" 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
    -- There is also a proteus 1-to-1 conversation. Neither it nor the MLS
    -- 1-to-1 conversation should get any events.
    Int -> WebSocket -> App (Maybe Value)
awaitAnyEvent Int
2 WebSocket
ws App (Maybe Value) -> Maybe Value -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` (Maybe Value
forall a. Maybe a
Nothing :: Maybe Value)
    -- Alice is not in the MLS 1-to-1 conversation given that she has blocked
    -- Bob.
    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
$ Value -> Value -> App Response
forall self other.
(HasCallStack, MakesValue self, MakesValue other) =>
self -> other -> App Response
getMLSOne2OneConversation Value
alice Value
bob 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
403

  mp <- createApplicationMessage one2OneConvId bob1 "hello, world, again"
  withWebSocket alice1 $ \WebSocket
ws -> 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 -> ByteString -> App Response
ClientIdentity -> ByteString -> App Response
postMLSMessage MessagePackage
mp.sender MessagePackage
mp.message 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
    Int -> WebSocket -> App (Maybe Value)
awaitAnyEvent Int
2 WebSocket
ws App (Maybe Value) -> Maybe Value -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` (Maybe Value
forall a. Maybe a
Nothing :: Maybe Value)

-- | Alice and Bob are initially connected, then Alice blocks Bob, and finally
-- Alice unblocks Bob.
testMLSOne2OneUnblocked :: (HasCallStack) => One2OneScenario -> App ()
testMLSOne2OneUnblocked :: HasCallStack => One2OneScenario -> App ()
testMLSOne2OneUnblocked One2OneScenario
scenario = 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
  let otherDomain = One2OneScenario -> Domain
one2OneScenarioUserDomain One2OneScenario
scenario
      convDomain = One2OneScenario -> Domain
one2OneScenarioConvDomain One2OneScenario
scenario
  bob <- createMLSOne2OnePartner otherDomain alice convDomain
  one2OneConv <- getMLSOne2OneConversation alice bob >>= getJSON 200
  one2OneConvId <- objConvId $ one2OneConv %. "conversation"
  do
    convId <- one2OneConv %. "conversation.qualified_id"
    bobConv <- getMLSOne2OneConversation bob alice >>= getJSON 200
    convId `shouldMatch` (bobConv %. "conversation.qualified_id")

  [alice1, bob1] <- traverse (createMLSClient def) [alice, bob]
  void $ uploadNewKeyPackage def bob1
  resetOne2OneGroup def alice1 one2OneConv
  withWebSocket bob1 $ \WebSocket
ws -> do
    commit <- HasCallStack =>
ClientIdentity -> ConvId -> [Value] -> App MessagePackage
ClientIdentity -> ConvId -> [Value] -> App MessagePackage
createAddCommit ClientIdentity
alice1 ConvId
one2OneConvId [Value
bob]
    void $ sendAndConsumeCommitBundle commit
    let isMessage 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 isMessage ws
    nPayload n %. "data" `shouldMatch` B8.unpack (Base64.encode (fold commit.welcome))

  -- Alice blocks Bob
  void $ putConnection alice bob "blocked" >>= getBody 200
  void $ getMLSOne2OneConversation alice bob >>= getJSON 403

  -- Reset the group membership in the test setup as only 'bob1' is left in
  -- reality, even though the test state believes 'alice1' is still part of the
  -- conversation.
  modifyMLSState $ \MLSState
s ->
    MLSState
s
      { convs =
          Map.adjust
            ( \MLSConv
conv ->
                MLSConv
conv
                  { members = Set.singleton bob1,
                    memberUsers = Set.singleton bob1.qualifiedUserId
                  }
            )
            one2OneConvId
            s.convs
      }

  -- Bob creates a new client and adds it to the one-to-one conversation just so
  -- that the epoch advances.
  bob2 <- createMLSClient def bob
  void $ uploadNewKeyPackage def bob2
  void $ createAddCommit bob1 one2OneConvId [bob] >>= sendAndConsumeCommitBundle

  -- Alice finally unblocks Bob
  void $ putConnection alice bob "accepted" >>= getBody 200
  void $ getMLSOne2OneConversation alice bob >>= getJSON 200

  -- Alice rejoins via an external commit
  void $ createExternalCommit one2OneConvId alice1 Nothing >>= sendAndConsumeCommitBundle

  -- Check that an application message can get to Bob
  withWebSockets [bob1, bob2] $ \[WebSocket]
wss -> do
    mp <- HasCallStack =>
ConvId -> ClientIdentity -> String -> App MessagePackage
ConvId -> ClientIdentity -> String -> App MessagePackage
createApplicationMessage ConvId
one2OneConvId ClientIdentity
alice1 String
"hello, I've always been here"
    void $ sendAndConsumeMessage mp
    let isMessage 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"
    forM_ wss $ \WebSocket
ws -> do
      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
isMessage WebSocket
ws
      nPayload n %. "data" `shouldMatch` B8.unpack (Base64.encode mp.message)

testGetMLSOne2OneSameTeam :: App ()
testGetMLSOne2OneSameTeam :: App ()
testGetMLSOne2OneSameTeam = do
  (alice, _, _) <- Domain -> Int -> App (Value, String, [Value])
forall domain.
(HasCallStack, MakesValue domain) =>
domain -> Int -> App (Value, String, [Value])
createTeam Domain
OwnDomain Int
1
  bob <- addUserToTeam alice
  void $ getMLSOne2OneConversation alice bob >>= getJSON 200

data One2OneScenario
  = -- | Both users are local
    One2OneScenarioLocal
  | -- | One user is remote, conversation is local
    One2OneScenarioLocalConv
  | -- | One user is remote, conversation is remote
    One2OneScenarioRemoteConv

instance TestCases One2OneScenario where
  mkTestCases :: IO [TestCase One2OneScenario]
mkTestCases =
    [TestCase One2OneScenario] -> IO [TestCase One2OneScenario]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
      [ String -> One2OneScenario -> TestCase One2OneScenario
forall a. String -> a -> TestCase a
MkTestCase String
"[domain=own]" One2OneScenario
One2OneScenarioLocal,
        String -> One2OneScenario -> TestCase One2OneScenario
forall a. String -> a -> TestCase a
MkTestCase String
"[domain=other;conv=own]" One2OneScenario
One2OneScenarioLocalConv,
        String -> One2OneScenario -> TestCase One2OneScenario
forall a. String -> a -> TestCase a
MkTestCase String
"[domain=other;conv=other]" One2OneScenario
One2OneScenarioRemoteConv
      ]

one2OneScenarioUserDomain :: One2OneScenario -> Domain
one2OneScenarioUserDomain :: One2OneScenario -> Domain
one2OneScenarioUserDomain One2OneScenario
One2OneScenarioLocal = Domain
OwnDomain
one2OneScenarioUserDomain One2OneScenario
_ = Domain
OtherDomain

one2OneScenarioConvDomain :: One2OneScenario -> Domain
one2OneScenarioConvDomain :: One2OneScenario -> Domain
one2OneScenarioConvDomain One2OneScenario
One2OneScenarioLocal = Domain
OwnDomain
one2OneScenarioConvDomain One2OneScenario
One2OneScenarioLocalConv = Domain
OwnDomain
one2OneScenarioConvDomain One2OneScenario
One2OneScenarioRemoteConv = Domain
OtherDomain

testMLSOne2One :: (HasCallStack) => Ciphersuite -> One2OneScenario -> App ()
testMLSOne2One :: HasCallStack => Ciphersuite -> One2OneScenario -> App ()
testMLSOne2One Ciphersuite
suite One2OneScenario
scenario = 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
  let otherDomain = One2OneScenario -> Domain
one2OneScenarioUserDomain One2OneScenario
scenario
      convDomain = One2OneScenario -> Domain
one2OneScenarioConvDomain One2OneScenario
scenario
  bob <- createMLSOne2OnePartner otherDomain alice convDomain
  [alice1, bob1] <- traverse (createMLSClient def {ciphersuites = [suite]}) [alice, bob]
  void $ uploadNewKeyPackage suite bob1

  one2OneConv <- getMLSOne2OneConversation alice bob >>= getJSON 200
  one2OneConvId <- objConvId $ one2OneConv %. "conversation"
  resetOne2OneGroup suite alice1 one2OneConv

  commit <- createAddCommit alice1 one2OneConvId [bob]
  withWebSocket bob1 $ \WebSocket
ws -> 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 => MessagePackage -> App Value
MessagePackage -> App Value
sendAndConsumeCommitBundle MessagePackage
commit

    let isWelcome :: a -> App Bool
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 <- HasCallStack => (Value -> App Bool) -> WebSocket -> App Value
(Value -> App Bool) -> WebSocket -> App Value
awaitMatch Value -> App Bool
forall {a}. MakesValue a => a -> App Bool
isWelcome WebSocket
ws
    nPayload n %. "data" `shouldMatch` B8.unpack (Base64.encode (fold commit.welcome))

    void $ awaitMatch isMemberJoinNotif ws

  withWebSocket bob1 $ \WebSocket
ws -> do
    mp <- HasCallStack =>
ConvId -> ClientIdentity -> String -> App MessagePackage
ConvId -> ClientIdentity -> String -> App MessagePackage
createApplicationMessage ConvId
one2OneConvId ClientIdentity
alice1 String
"hello, world"
    void $ sendAndConsumeMessage mp
    let isMessage 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 <- awaitMatch isMessage ws
    nPayload n %. "data" `shouldMatch` B8.unpack (Base64.encode mp.message)

  -- Send another commit. This verifies that the backend has correctly updated
  -- the cipersuite of this conversation.
  void $ createPendingProposalCommit one2OneConvId alice1 >>= sendAndConsumeCommitBundle

  one2OneConv' <- getMLSOne2OneConversation alice bob >>= getJSON 200
  (suiteCode, _) <- assertOne $ T.hexadecimal (T.pack suite.code)
  one2OneConv' %. "conversation.cipher_suite" `shouldMatchInt` suiteCode

-- | This test verifies that one-to-one conversations are created inside the
-- commit lock. There used to be an issue where a conversation could be
-- partially created at the time of setting its ciphersuite, resulting in an
-- incomplete database entry that would prevent further uses of the
-- conversation.
testMLSGhostOne2OneConv :: App ()
testMLSGhostOne2OneConv :: App ()
testMLSGhostOne2OneConv = 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

  doneVar <- liftIO $ newEmptyMVar
  let checkConversation =
        IO (Maybe ()) -> App (Maybe ())
forall a. IO a -> App a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (MVar () -> IO (Maybe ())
forall a. MVar a -> IO (Maybe a)
tryReadMVar MVar ()
doneVar) App (Maybe ()) -> (Maybe () -> App ()) -> App ()
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          Maybe ()
Nothing -> do
            App Response -> (Response -> App ()) -> App ()
forall a.
HasCallStack =>
App Response -> (Response -> App a) -> App a
bindResponse (Value -> App Value -> App Response
forall self other.
(HasCallStack, MakesValue self, MakesValue other) =>
self -> other -> App Response
getConversation Value
alice (Value
one2OneConv Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"conversation")) ((Response -> App ()) -> App ()) -> (Response -> App ()) -> App ()
forall a b. (a -> b) -> a -> b
$ \Response
resp ->
              Response
resp.status Int -> [Int] -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatchOneOf` [Int
404 :: Int, Int
403, Int
200]

            App ()
checkConversation
          Just ()
_ -> () -> App ()
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  checkConversationIO <- appToIO checkConversation

  createCommit <-
    appToIO
      $ void
      $ createAddCommit alice1 one2OneConvId [bob]
      >>= sendAndConsumeCommitBundle

  liftIO $ withAsync checkConversationIO $ \Async ()
a -> do
    IO ()
createCommit
    IO () -> IO ()
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ MVar () -> () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ()
doneVar ()
    Async () -> IO ()
forall a. Async a -> IO a
wait Async ()
a

-- Note [Federated 1:1 MLS Conversations]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-- 1:1 Conversations shouldn't work when there is no way for the creator to know
-- the MLS public keys of the backend which will host this conversation. In
-- federation API V2, this will always work and has been tested above. When one
-- of the backends doesn't support federation API v2, the 1:1 conversation can
-- still be created but only by the user whose backend hosts this conversation.

-- | See Note: [Federated 1:1 MLS Conversations]
-- To run locally this test requires federation-v1 docker containers to be up and running.
-- See `deploy/dockerephemeral/run.sh` and comment on `StaticFedDomain` in `Testlib/VersionedFed.hs` for more details.
testMLSFederationV1ConvOnOldBackend :: (HasCallStack) => FedDomain 1 -> App ()
testMLSFederationV1ConvOnOldBackend :: HasCallStack => FedDomain 1 -> App ()
testMLSFederationV1ConvOnOldBackend FedDomain 1
domain = do
  let cs :: Ciphersuite
cs = 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
  let createBob = do
        bobCandidate <- FedDomain 1 -> CreateUser -> App Value
forall domain.
(HasCallStack, MakesValue domain) =>
domain -> CreateUser -> App Value
randomUser FedDomain 1
domain CreateUser
forall a. Default a => a
def
        connectUsers [alice, bobCandidate]
        getMLSOne2OneConversation alice bobCandidate `bindResponse` \Response
resp -> do
          if Response
resp.status Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
533
            then Value -> App Value
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Value
bobCandidate
            else App Value
createBob

  bob <- createBob
  [alice1, bob1] <- traverse (createMLSClient def {ciphersuites = [cs]}) [alice, bob]
  void $ uploadNewKeyPackage cs alice1

  -- Alice cannot start this conversation because it would exist on Bob's
  -- backend and Alice cannot get the MLS public keys of that backend.
  getMLSOne2OneConversation alice bob `bindResponse` \Response
resp -> do
    fedError <- HasCallStack => Int -> Response -> App Value
Int -> Response -> App Value
getJSON Int
533 Response
resp
    fedError %. "label" `shouldMatch` "federation-version-error"

  conv <- getMLSOne2OneConversationLegacy bob alice >>= getJSON 200
  convId <- objConvId conv
  keys <- getMLSPublicKeys bob >>= getJSON 200
  resetOne2OneGroupGeneric cs bob1 conv keys

  withWebSocket alice1 $ \WebSocket
wsAlice -> do
    commit <- HasCallStack =>
ClientIdentity -> ConvId -> [Value] -> App MessagePackage
ClientIdentity -> ConvId -> [Value] -> App MessagePackage
createAddCommit ClientIdentity
bob1 ConvId
convId [Value
alice]
    void $ sendAndConsumeCommitBundle commit

    let isMessage 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 isMessage wsAlice
    nPayload n %. "data" `shouldMatch` B8.unpack (Base64.encode (fold commit.welcome))

  withWebSocket bob1 $ \WebSocket
wsBob -> do
    _ <- Value -> String -> App Response
forall self other.
(HasCallStack, MakesValue self, MakesValue other) =>
self -> other -> 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
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 <- awaitMatch predicate wsBob
    shouldMatch (nPayload n %. "conversation") (objId conv)
    shouldMatch (nPayload n %. "from") (objId alice)

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

    -- Checks that the remove proposal is consumable by bob
    void $ mlsCliConsume convId cs bob1 mlsMsg

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

-- | See Note: Federated 1:1 MLS Conversations
-- To run locally this test requires federation-v1 docker containers to be up and running.
-- See `deploy/dockerephemeral/run.sh` and comment on `StaticFedDomain` in `Testlib/VersionedFed.hs` for more details.
testMLSFederationV1ConvOnNewBackend :: (HasCallStack) => FedDomain 1 -> App ()
testMLSFederationV1ConvOnNewBackend :: HasCallStack => FedDomain 1 -> App ()
testMLSFederationV1ConvOnNewBackend FedDomain 1
domain = do
  let cs :: Ciphersuite
cs = 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
  let createBob = do
        bobCandidate <- FedDomain 1 -> CreateUser -> App Value
forall domain.
(HasCallStack, MakesValue domain) =>
domain -> CreateUser -> App Value
randomUser FedDomain 1
domain CreateUser
forall a. Default a => a
def
        connectUsers [alice, bobCandidate]
        getMLSOne2OneConversation alice bobCandidate `bindResponse` \Response
resp -> do
          if Response
resp.status Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
200
            then Value -> App Value
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Value
bobCandidate
            else App Value
createBob

  bob <- createBob
  [alice1, bob1] <- traverse (createMLSClient def {ciphersuites = [cs]}) [alice, bob]
  void $ uploadNewKeyPackage cs bob1

  -- Bob cannot start this conversation because it would exist on Alice's
  -- backend and Bob cannot get the MLS public keys of that backend.
  getMLSOne2OneConversationLegacy bob alice `bindResponse` \Response
resp -> do
    fedError <- HasCallStack => Int -> Response -> App Value
Int -> Response -> App Value
getJSON Int
533 Response
resp
    fedError %. "label" `shouldMatch` "federation-remote-error"

  one2OneConv <- getMLSOne2OneConversation alice bob >>= getJSON 200
  one2OneConvId <- objConvId $ one2OneConv %. "conversation"
  conv <- one2OneConv %. "conversation"
  resetOne2OneGroup cs alice1 one2OneConv

  withWebSocket bob1 $ \WebSocket
wsBob -> do
    commit <- HasCallStack =>
ClientIdentity -> ConvId -> [Value] -> App MessagePackage
ClientIdentity -> ConvId -> [Value] -> App MessagePackage
createAddCommit ClientIdentity
alice1 ConvId
one2OneConvId [Value
bob]
    void $ sendAndConsumeCommitBundle commit

    let isMessage 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 isMessage wsBob
    nPayload n %. "data" `shouldMatch` B8.unpack (Base64.encode (fold commit.welcome))

  withWebSocket alice1 $ \WebSocket
wsAlice -> do
    _ <- Value -> String -> App Response
forall self other.
(HasCallStack, MakesValue self, MakesValue other) =>
self -> other -> 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
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 <- awaitMatch predicate wsAlice
    shouldMatch (nPayload n %. "conversation") (objId conv)
    shouldMatch (nPayload n %. "from") (objId bob)

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

    -- Checks that the remove proposal is consumable by bob
    void $ mlsCliConsume one2OneConvId cs alice1 mlsMsg

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