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

import API.Brig
import API.Galley
import Control.Monad.Codensity
import Control.Monad.Reader
import GHC.Stack
import MLS.Util
import Notifications
import SetupHelpers
import Testlib.Prelude
import Testlib.ResourcePool

-- These two commented out tests exist to test the Setup.hs code.
-- Both of these tests should not appear in the output.

-- testBar :: HasCallStack => App ()
-- testBar = pure ()

{-
testBaz :: HasCallStack => App ()
testBaz = pure ()
-}

-- | @SF.Federation @SF.Separation @TSFI.RESTfulAPI @S2
--
-- The test asserts that, among others, remote users are removed from a
-- conversation when an access update occurs that disallows guests from
-- accessing.
testAccessUpdateGuestRemoved :: (HasCallStack) => ConversationProtocol -> App ()
testAccessUpdateGuestRemoved :: HasCallStack => ConversationProtocol -> App ()
testAccessUpdateGuestRemoved ConversationProtocol
proto = 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
  charlie <- randomUser OwnDomain def
  dee <- randomUser OtherDomain def
  mapM_ (connectTwoUsers alice) [charlie, dee]

  (conv, [aliceClient, bobClient, charlieClient, deeClient]) <- case proto of
    ConversationProtocol
ConversationProtocolProteus -> do
      clients <-
        (Value -> App String) -> [Value] -> App [String]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM
          (\Value
user -> App Value -> App String
forall a. (HasCallStack, MakesValue a) => a -> App String
objId (App Value -> App String) -> App Value -> App String
forall a b. (a -> b) -> a -> b
$ App Response -> (Response -> App Value) -> App Value
forall a.
HasCallStack =>
App Response -> (Response -> App a) -> App a
bindResponse (Value -> AddClient -> App Response
forall user.
(HasCallStack, MakesValue user) =>
user -> AddClient -> App Response
addClient Value
user AddClient
forall a. Default a => a
def) ((Response -> App Value) -> App Value)
-> (Response -> App Value) -> App Value
forall a b. (a -> b) -> a -> b
$ HasCallStack => Int -> Response -> App Value
Int -> Response -> App Value
getJSON Int
201)
          [Value
alice, Value
bob, Value
charlie, Value
dee]
      conv <-
        postConversation
          alice
          defProteus
            { qualifiedUsers = [bob, charlie, dee],
              team = Just tid
            }
          >>= getJSON 201
      pure (conv, clients)
    ConversationProtocol
ConversationProtocolMLS -> do
      alice1 <- InitMLSClient -> Value -> App ClientIdentity
forall u.
(MakesValue u, HasCallStack) =>
InitMLSClient -> u -> App ClientIdentity
createMLSClient InitMLSClient
forall a. Default a => a
def Value
alice
      clients <- traverse (createMLSClient def) [bob, charlie, dee]
      traverse_ (uploadNewKeyPackage def) clients

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

      void $ createAddCommit alice1 convId [bob, charlie, dee] >>= sendAndConsumeCommitBundle
      convQid <- conv %. "qualified_id"
      pure (convQid, map (.client) (alice1 : clients))

  let update = [String
"access" String -> [String] -> Pair
forall a. ToJSON a => String -> a -> Pair
.= ([] :: [String]), String
"access_role" String -> [String] -> Pair
forall a. ToJSON a => String -> a -> Pair
.= [String
"team_member"]]
  void $ updateAccess alice conv update >>= getJSON 200

  mapM_ (assertLeaveNotification alice conv alice aliceClient) [charlie, dee]
  mapM_ (assertLeaveNotification alice conv bob bobClient) [charlie, dee]
  mapM_ (assertLeaveNotification alice conv charlie charlieClient) [charlie, dee]
  mapM_ (assertLeaveNotification alice conv dee deeClient) [charlie, dee]

  bindResponse (getConversation alice conv) $ \Response
res -> do
    Response
res.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
200
    Response
res.json App Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"members.others.0.qualified_id" App Value -> App Value -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` Value -> App Value
forall a. (HasCallStack, MakesValue a) => a -> App Value
objQidObject Value
bob

-- @END

testAccessUpdateGuestRemovedUnreachableRemotes :: (HasCallStack) => App ()
testAccessUpdateGuestRemovedUnreachableRemotes :: HasCallStack => App ()
testAccessUpdateGuestRemovedUnreachableRemotes = do
  resourcePool <- (Env -> ResourcePool BackendResource)
-> App (ResourcePool BackendResource)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env -> ResourcePool BackendResource
resourcePool
  (alice, tid, [bob]) <- createTeam OwnDomain 2
  charlie <- randomUser OwnDomain def
  connectTwoUsers alice charlie
  [aliceClient, bobClient, charlieClient] <-
    mapM
      (\Value
user -> App Value -> App String
forall a. (HasCallStack, MakesValue a) => a -> App String
objId (App Value -> App String) -> App Value -> App String
forall a b. (a -> b) -> a -> b
$ App Response -> (Response -> App Value) -> App Value
forall a.
HasCallStack =>
App Response -> (Response -> App a) -> App a
bindResponse (Value -> AddClient -> App Response
forall user.
(HasCallStack, MakesValue user) =>
user -> AddClient -> App Response
addClient Value
user AddClient
forall a. Default a => a
def) ((Response -> App Value) -> App Value)
-> (Response -> App Value) -> App Value
forall a b. (a -> b) -> a -> b
$ HasCallStack => Int -> Response -> App Value
Int -> Response -> App Value
getJSON Int
201)
      [alice, bob, charlie]
  (conv, dee) <- runCodensity (acquireResources 1 resourcePool) $ \[BackendResource
dynBackend] ->
    Codensity App String -> forall b. (String -> App b) -> App b
forall k (m :: k -> *) a.
Codensity m a -> forall (b :: k). (a -> m b) -> m b
runCodensity (HasCallStack =>
BackendResource -> ServiceOverrides -> Codensity App String
BackendResource -> ServiceOverrides -> Codensity App String
startDynamicBackend BackendResource
dynBackend ServiceOverrides
forall a. Monoid a => a
mempty) ((String -> App (Value, Value)) -> App (Value, Value))
-> (String -> App (Value, Value)) -> App (Value, Value)
forall a b. (a -> b) -> a -> b
$ \String
_ -> do
      dee <- String -> CreateUser -> App Value
forall domain.
(HasCallStack, MakesValue domain) =>
domain -> CreateUser -> App Value
randomUser BackendResource
dynBackend.berDomain CreateUser
forall a. Default a => a
def
      connectTwoUsers alice dee
      conv <-
        postConversation
          alice
          ( defProteus
              { qualifiedUsers = [bob, charlie, dee],
                team = Just tid
              }
          )
          >>= getJSON 201
      pure (conv, dee)

  let update = [String
"access" String -> [String] -> Pair
forall a. ToJSON a => String -> a -> Pair
.= ([] :: [String]), String
"access_role" String -> [String] -> Pair
forall a. ToJSON a => String -> a -> Pair
.= [String
"team_member"]]
  void $ updateAccess alice conv update >>= getJSON 200

  mapM_ (assertLeaveNotification alice conv alice aliceClient) [charlie, dee]
  mapM_ (assertLeaveNotification alice conv bob bobClient) [charlie, dee]
  mapM_ (assertLeaveNotification alice conv charlie charlieClient) [charlie, dee]

  bindResponse (getConversation alice conv) $ \Response
res -> do
    Response
res.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
200
    Response
res.json App Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"members.others.0.qualified_id" App Value -> App Value -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` Value -> App Value
forall a. (HasCallStack, MakesValue a) => a -> App Value
objQidObject Value
bob

testAccessUpdateWithRemotes :: (HasCallStack) => App ()
testAccessUpdateWithRemotes :: HasCallStack => App ()
testAccessUpdateWithRemotes = do
  [alice, bob, charlie] <- [Domain] -> App [Value]
forall domain.
(HasCallStack, MakesValue domain) =>
[domain] -> App [Value]
createUsers [Domain
OwnDomain, Domain
OtherDomain, Domain
OwnDomain]
  connectTwoUsers alice bob
  connectTwoUsers alice charlie
  conv <-
    postConversation alice (defProteus {qualifiedUsers = [bob, charlie]})
      >>= getJSON 201
  let update_access_value = [String
"code"]
      update_access_role_value = [String
"team_member", String
"non_team_member", String
"guest", String
"service"]
      update = [String
"access" String -> [String] -> Pair
forall a. ToJSON a => String -> a -> Pair
.= [String]
update_access_value, String
"access_role" String -> [String] -> Pair
forall a. ToJSON a => String -> a -> Pair
.= [String]
update_access_role_value]
  withWebSockets [alice, 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
$ Value -> Value -> [Pair] -> App Response
forall user conv.
(HasCallStack, MakesValue user, MakesValue conv) =>
user -> conv -> [Pair] -> App Response
updateAccess Value
alice Value
conv [Pair]
update App Response -> (Response -> App Value) -> App Value
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HasCallStack => Int -> Response -> App Value
Int -> Response -> App Value
getJSON Int
200
    [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
      notif <- HasCallStack => (Value -> App Bool) -> WebSocket -> App Value
(Value -> App Bool) -> WebSocket -> App Value
awaitMatch Value -> App Bool
forall n. (HasCallStack, MakesValue n) => n -> App Bool
isConvAccessUpdateNotif WebSocket
ws
      notif %. "payload.0.qualified_conversation" `shouldMatch` objQidObject conv
      notif %. "payload.0.qualified_from" `shouldMatch` objQidObject alice
      notif %. "payload.0.data.access" `shouldMatch` update_access_value
      notif %. "payload.0.data.access_role_v2" `shouldMatch` update_access_role_value