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

import API.Galley
import qualified API.GalleyInternal as I
import qualified Data.Aeson as A
import qualified Data.ByteString.Base64 as Base64
import qualified Data.Text.Encoding as T
import MLS.Util
import Notifications
import SetupHelpers
import Testlib.Prelude

testExtraAppMessage :: App ()
testExtraAppMessage :: App ()
testExtraAppMessage = 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)
  [alice1, bob1, charlie1] <- traverse (createMLSClient def) [alice, bob, charlie]
  traverse_ (uploadNewKeyPackage def) [bob1, charlie1]
  convId <- createNewGroup def alice1

  -- normal commit
  void $ createAddCommit alice1 convId [bob] >>= sendAndConsumeCommitBundle

  -- make a commit with an extra application message
  mp <- createAddCommit alice1 convId [charlie]
  appPackage <- createApplicationMessage convId alice1 "hello"
  let mp' = MessagePackage
mp {appMessage = Just appPackage.message}

  withWebSockets [bob1, charlie1] $ \[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 => MessagePackage -> App Value
MessagePackage -> App Value
sendAndConsumeCommitBundle MessagePackage
mp'

    let isAppMessage :: Value -> App Bool
        isAppMessage :: Value -> App Bool
isAppMessage Value
n =
          Value -> App Bool
forall a. (HasCallStack, MakesValue a) => a -> App Bool
isNewMLSMessageNotif Value
n
            App Bool -> App Bool -> App Bool
&&~ ConvId -> Value -> App Bool
forall a.
(HasCallStack, MakesValue a, HasCallStack) =>
ConvId -> a -> App Bool
isNotifConvId MessagePackage
mp.convId Value
n
            App Bool -> App Bool -> App Bool
&&~ ( do
                    msg <- 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
                    ty <- msg %. "type" & asString
                    pure $ ty == "private_message"
                )

    [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
isAppMessage WebSocket
ws
      nPayload n %. "data" `shouldMatch` T.decodeUtf8 (Base64.encode appPackage.message)

testConvCreateWithHistory :: App ()
testConvCreateWithHistory :: App ()
testConvCreateWithHistory = 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

  I.setTeamFeatureLockStatus alice tid "channels" "unlocked"
  setTeamFeatureConfig alice tid "channels" channelsConfig >>= assertSuccess

  let history = [Pair] -> Value
object [String
"depth" String -> String -> Pair
forall a. ToJSON a => String -> a -> Pair
.= String
"infinite"]
  bindResponse
    ( postConversation
        alice
        ( defMLS
            { team = Just tid,
              history = Just history
            }
        )
    )
    $ \Response
resp -> do
      Response
resp.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
400
      Response
resp.json 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
"history-not-supported"

  convId <- bindResponse
    ( postConversation
        alice
        ( defMLS
            { team = Just tid,
              history = Just history,
              groupConvType = Just "channel"
            }
        )
    )
    $ \Response
resp -> do
      Response
resp.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
201
      Maybe Value -> App ConvId
forall conv. (HasCallStack, MakesValue conv) => conv -> App ConvId
objConvId Response
resp.json

  conv <- getConversation alice convId >>= getJSON 200
  conv %. "history" `shouldMatch` history

testRegularConvCannotSetHistory :: App ()
testRegularConvCannotSetHistory :: App ()
testRegularConvCannotSetHistory = 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 history = [Pair] -> Value
object [String
"depth" String -> String -> Pair
forall a. ToJSON a => String -> a -> Pair
.= String
"infinite"]
  convId <- postConversation alice defMLS >>= getJSON 201 >>= objConvId

  bindResponse (updateHistory alice convId history) $ \Response
resp -> do
    Response
resp.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
400
    Response
resp.json 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
"history-not-supported"

testSetHistory :: App ()
testSetHistory :: App ()
testSetHistory = do
  (alice, tid, [bob]) <- Domain -> Int -> App (Value, String, [Value])
forall domain.
(HasCallStack, MakesValue domain) =>
domain -> Int -> App (Value, String, [Value])
createTeam Domain
OwnDomain Int
2

  I.setTeamFeatureLockStatus alice tid "channels" "unlocked"
  setTeamFeatureConfig alice tid "channels" channelsConfig >>= assertSuccess

  let history = [Pair] -> Value
object [String
"depth" String -> String -> Pair
forall a. ToJSON a => String -> a -> Pair
.= String
"infinite"]

  [alice1, bob1] <- traverse (createMLSClient def) [alice, bob]
  void $ uploadNewKeyPackage def bob1
  convId <-
    createNewGroupWith
      def
      alice1
      defMLS
        { team = Just tid,
          groupConvType = Just "channel"
        }
  void $ createAddCommit alice1 convId [bob] >>= sendAndConsumeCommitBundle

  bindResponse (updateHistory bob convId history) $ \Response
resp -> do
    Response
resp.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
403
    Response
resp.json 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
"action-denied"

  bindResponse (updateHistory alice convId history) $ \Response
resp -> do
    Response
resp.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
200

  conv <- getConversation alice convId >>= getJSON 200
  conv %. "history" `shouldMatch` history

testHistoryConflicts :: (HasCallStack) => Domain -> App ()
testHistoryConflicts :: HasCallStack => Domain -> App ()
testHistoryConflicts Domain
domain = 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
  mems@[bob, charlie, dorothy, emily] <- replicateM 4 $ randomUser domain def
  for_ mems $ connectTwoUsers alice

  I.setTeamFeatureLockStatus alice tid "channels" "unlocked"
  setTeamFeatureConfig alice tid "channels" channelsConfig >>= assertSuccess

  clients@(alice1 : bob1 : _) <- traverse (createMLSClient def) $ alice : mems
  for_ clients $ uploadNewKeyPackage def
  convId <- createNewGroupWith def alice1 defMLS {team = Just tid, groupConvType = Just "channel"}

  -- adding an empty commit to be able to test application message rejection
  void $ createPendingProposalCommit convId alice1 >>= sendAndConsumeCommitBundle

  -- bob is added to the conversation as a wire-member (not a conversation admin)
  void $ createAddCommit alice1 convId [bob] >>= sendAndConsumeCommitBundle

  getConversation alice convId `bindResponse` \Response
res -> do
    Response
res.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
200
    other <- Response
res.json Maybe Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"members.others" 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 -> App [Value]
forall a. (HasCallStack, MakesValue a) => a -> App [Value]
asList 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] -> App Value
forall (t :: * -> *) a. (HasCallStack, Foldable t) => t a -> App a
assertOne
    other %. "id" `shouldMatch` (bob %. "id")
    other %. "conversation_role" `shouldMatch` "wire_member"

  -- a history client cannot be added if shared history is disabled
  assertAddHistoryClientConflict convId alice1

  -- SHARED HISTORY ENABLED
  enableHistorySharing convId alice

  -- application message and add commit are rejected
  assertApplicationMessageFailure convId alice1
  assertAddCommitIsRejected convId alice1 [charlie]

  -- HISTORY CLIENT ADDED
  hid <- do
    -- this verifies that history clients can be added by non-conversation admins including federated users
    (mp, hid) <- createAddCommitWithHistoryClient bob1 convId []
    void $ sendAndConsumeCommitBundle mp
    pure hid

  -- while shared history is enabled, it is not possible to add more than 1 history client or to remove it
  assertAddHistoryClientDuplication convId alice1
  assertRemoveHistoryClientFailure convId alice1 hid

  -- application message and add commits are accepted
  void $ createApplicationMessage convId alice1 "hello" >>= sendAndConsumeMessage
  void $ createAddCommit alice1 convId [charlie] >>= sendAndConsumeCommitBundle

  -- SHARED HISTORY DISABLED
  disableHistorySharing convId alice

  -- application message and add commit, as well as history client requests are rejected
  assertApplicationMessageFailure convId alice1
  assertAddCommitIsRejected convId alice1 [dorothy]
  assertAddHistoryClientDuplication convId alice1

  -- HISTORY CLIENT REMOVED
  void $ createRemoveCommitGroupMember bob1 convId [HistoryClient hid] >>= sendAndConsumeCommitBundle

  -- application message and add commits are accepted
  void $ createApplicationMessage convId alice1 "hello" >>= sendAndConsumeMessage
  void $ createAddCommit alice1 convId [emily] >>= sendAndConsumeCommitBundle

  -- a history client cannot be added if shared history is disabled
  assertAddHistoryClientConflict convId alice1
  where
    assertAddHistoryClientConflict :: (HasCallStack) => ConvId -> ClientIdentity -> App ()
    assertAddHistoryClientConflict :: HasCallStack => ConvId -> ClientIdentity -> App ()
assertAddHistoryClientConflict = HasCallStack => Int -> String -> ConvId -> ClientIdentity -> App ()
Int -> String -> ConvId -> ClientIdentity -> App ()
assertAddHistoryClientFailure Int
400 String
"mls-history-client-conflict"

    assertAddHistoryClientDuplication :: (HasCallStack) => ConvId -> ClientIdentity -> App ()
    assertAddHistoryClientDuplication :: HasCallStack => ConvId -> ClientIdentity -> App ()
assertAddHistoryClientDuplication = HasCallStack => Int -> String -> ConvId -> ClientIdentity -> App ()
Int -> String -> ConvId -> ClientIdentity -> App ()
assertAddHistoryClientFailure Int
400 String
"mls-history-client-duplication"

    assertAddHistoryClientFailure :: (HasCallStack) => Int -> String -> ConvId -> ClientIdentity -> App ()
    assertAddHistoryClientFailure :: HasCallStack => Int -> String -> ConvId -> ClientIdentity -> App ()
assertAddHistoryClientFailure Int
status String
label ConvId
convId ClientIdentity
user =
      App () -> App ()
forall a. App a -> App a
withMLSStateReset (App () -> App ()) -> App () -> App ()
forall a b. (a -> b) -> a -> b
$ do
        mp <- (MessagePackage, String) -> MessagePackage
forall a b. (a, b) -> a
fst ((MessagePackage, String) -> MessagePackage)
-> App (MessagePackage, String) -> App MessagePackage
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HasCallStack =>
ClientIdentity -> ConvId -> [Value] -> App (MessagePackage, String)
ClientIdentity -> ConvId -> [Value] -> App (MessagePackage, String)
createAddCommitWithHistoryClient ClientIdentity
user ConvId
convId []
        postMLSCommitBundle mp.sender (mkBundle mp) `bindResponse` \Response
resp -> do
          Response
resp.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
status
          Response
resp.json 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
label

    assertRemoveHistoryClientFailure :: (HasCallStack) => ConvId -> ClientIdentity -> String -> App ()
    assertRemoveHistoryClientFailure :: HasCallStack => ConvId -> ClientIdentity -> String -> App ()
assertRemoveHistoryClientFailure ConvId
convId ClientIdentity
user String
hid =
      App () -> App ()
forall a. App a -> App a
withMLSStateReset (App () -> App ()) -> App () -> App ()
forall a b. (a -> b) -> a -> b
$ do
        mp <- HasCallStack =>
ClientIdentity -> ConvId -> [GroupMember] -> App MessagePackage
ClientIdentity -> ConvId -> [GroupMember] -> App MessagePackage
createRemoveCommitGroupMember ClientIdentity
user ConvId
convId [String -> GroupMember
HistoryClient String
hid]
        postMLSCommitBundle mp.sender (mkBundle mp) `bindResponse` \Response
resp -> do
          Response
resp.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
400
          Response
resp.json 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-history-client-conflict"

    assertAddCommitIsRejected :: (HasCallStack) => ConvId -> ClientIdentity -> [Value] -> App ()
    assertAddCommitIsRejected :: HasCallStack => ConvId -> ClientIdentity -> [Value] -> App ()
assertAddCommitIsRejected ConvId
convId ClientIdentity
user [Value]
users =
      App () -> App ()
forall a. App a -> App a
withMLSStateReset (App () -> App ()) -> App () -> App ()
forall a b. (a -> b) -> a -> b
$ do
        mp <- HasCallStack =>
ClientIdentity -> ConvId -> [Value] -> App MessagePackage
ClientIdentity -> ConvId -> [Value] -> App MessagePackage
createAddCommit ClientIdentity
user ConvId
convId [Value]
users
        postMLSCommitBundle mp.sender (mkBundle mp) `bindResponse` \Response
resp -> do
          Response
resp.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
400
          Response
resp.json 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-history-client-conflict"

    assertApplicationMessageFailure :: (HasCallStack) => ConvId -> ClientIdentity -> App ()
    assertApplicationMessageFailure :: HasCallStack => ConvId -> ClientIdentity -> App ()
assertApplicationMessageFailure ConvId
convId ClientIdentity
user = do
      mp <- HasCallStack =>
ConvId -> ClientIdentity -> String -> App MessagePackage
ConvId -> ClientIdentity -> String -> App MessagePackage
createApplicationMessage ConvId
convId ClientIdentity
user String
"hello"
      postMLSMessage mp.sender mp.message `bindResponse` \Response
res -> do
        Response
res.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
400
        Response
res.json 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-history-client-conflict"

    enableHistorySharing :: (HasCallStack) => ConvId -> Value -> App ()
    enableHistorySharing :: HasCallStack => ConvId -> Value -> App ()
enableHistorySharing ConvId
convId Value
user = do
      let history :: Value
history = [Pair] -> Value
object [String
"depth" String -> String -> Pair
forall a. ToJSON a => String -> a -> Pair
.= String
"infinite"]
      App Response -> (Response -> App ()) -> App ()
forall a.
HasCallStack =>
App Response -> (Response -> App a) -> App a
bindResponse (Value -> ConvId -> Value -> App Response
forall user conv.
(HasCallStack, MakesValue user, MakesValue conv) =>
user -> conv -> Value -> App Response
updateHistory Value
user ConvId
convId Value
history) ((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

    disableHistorySharing :: (HasCallStack) => ConvId -> Value -> App ()
    disableHistorySharing :: HasCallStack => ConvId -> Value -> App ()
disableHistorySharing ConvId
convId Value
user = do
      App Response -> (Response -> App ()) -> App ()
forall a.
HasCallStack =>
App Response -> (Response -> App a) -> App a
bindResponse (Value -> ConvId -> Value -> App Response
forall user conv.
(HasCallStack, MakesValue user, MakesValue conv) =>
user -> conv -> Value -> App Response
updateHistory Value
user ConvId
convId Value
A.Null) ((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

channelsConfig :: Value
channelsConfig :: Value
channelsConfig =
  [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
.= [Pair] -> Value
object
          [ String
"allowed_to_create_channels" String -> String -> Pair
forall a. ToJSON a => String -> a -> Pair
.= String
"team-members",
            String
"allowed_to_open_channels" String -> String -> Pair
forall a. ToJSON a => String -> a -> Pair
.= String
"team-members"
          ]
    ]