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

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"
          ]
    ]