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

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

testAddUsersSomeReachable :: (HasCallStack) => App ()
testAddUsersSomeReachable :: HasCallStack => App ()
testAddUsersSomeReachable = do
  (addCommit, d) <- [ServiceOverrides]
-> ([String] -> App (MessagePackage, String))
-> App (MessagePackage, String)
forall a.
HasCallStack =>
[ServiceOverrides] -> ([String] -> App a) -> App a
startDynamicBackends [ServiceOverrides
forall a. Monoid a => a
mempty] (([String] -> App (MessagePackage, String))
 -> App (MessagePackage, String))
-> ([String] -> App (MessagePackage, String))
-> App (MessagePackage, String)
forall a b. (a -> b) -> a -> b
$ \[String
thirdDomain] -> do
    ownDomain <- Domain -> App Value
forall a. (MakesValue a, HasCallStack) => a -> App Value
make Domain
OwnDomain App Value -> (App Value -> App String) -> App String
forall a b. a -> (a -> b) -> b
& App Value -> App String
forall a. (HasCallStack, MakesValue a) => a -> App String
asString
    otherDomain <- make OtherDomain & asString
    [alice, bob, charlie] <- createAndConnectUsers [ownDomain, otherDomain, thirdDomain]

    [alice1, bob1, charlie1] <- traverse (createMLSClient def) [alice, bob, charlie]
    traverse_ (uploadNewKeyPackage def) [bob1, charlie1]
    convId <- createNewGroup def alice1
    void $ withWebSocket bob $ \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 -> ConvId -> [Value] -> App MessagePackage
ClientIdentity -> ConvId -> [Value] -> App MessagePackage
createAddCommit ClientIdentity
alice1 ConvId
convId [Value
bob] 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
      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
ws
    mp <- createAddCommit alice1 convId [charlie]
    pure (mp, thirdDomain)

  -- try adding Charlie now that his backend is unreachable
  bindResponse (postMLSCommitBundle addCommit.sender (mkBundle addCommit)) $ \Response
resp -> do
    Response
resp.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
533
    (Response
resp.json App Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"unreachable_backends" 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) App [Value] -> [String] -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` [String
d]

-- | There is analogous counterpart for Proteus in the 'Test.Conversation' module.
testAddUserWithUnreachableRemoteUsers :: (HasCallStack) => App ()
testAddUserWithUnreachableRemoteUsers :: HasCallStack => App ()
testAddUserWithUnreachableRemoteUsers = do
  resourcePool <- (Env -> ResourcePool BackendResource)
-> App (ResourcePool BackendResource)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env -> ResourcePool BackendResource
resourcePool
  runCodensity (acquireResources 1 resourcePool) $ \[BackendResource
cDom] -> do
    (alice1, bob, brad, chris, convId) <- 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
cDom ServiceOverrides
forall a. Monoid a => a
mempty) ((String -> App (ClientIdentity, Value, Value, Value, ConvId))
 -> App (ClientIdentity, Value, Value, Value, ConvId))
-> (String -> App (ClientIdentity, Value, Value, Value, ConvId))
-> App (ClientIdentity, Value, Value, Value, ConvId)
forall a b. (a -> b) -> a -> b
$ \String
_ -> do
      [own, other] <- [Domain] -> (Domain -> App String) -> App [String]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Domain
OwnDomain, Domain
OtherDomain] ((Domain -> App String) -> App [String])
-> (Domain -> App String) -> App [String]
forall a b. (a -> b) -> a -> b
$ App Value -> App String
forall a. (HasCallStack, MakesValue a) => a -> App String
asString (App Value -> App String)
-> (Domain -> App Value) -> Domain -> App String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Domain -> App Value
forall a. (MakesValue a, HasCallStack) => a -> App Value
make
      [alice, bob, brad, charlie, chris] <-
        createAndConnectUsers [own, other, other, cDom.berDomain, cDom.berDomain]
      [alice1, charlie1, chris1] <-
        traverse (createMLSClient def) [alice, charlie, chris]
      traverse_ (uploadNewKeyPackage def) [charlie1, chris1]
      convId <- createNewGroup def alice1
      void $ withWebSocket charlie $ \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 -> ConvId -> [Value] -> App MessagePackage
ClientIdentity -> ConvId -> [Value] -> App MessagePackage
createAddCommit ClientIdentity
alice1 ConvId
convId [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
        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
ws
      pure (alice1, bob, brad, chris, convId)

    [bob1, brad1] <- traverse (createMLSClient def) [bob, brad]
    traverse_ (uploadNewKeyPackage def) [bob1, brad1]

    do
      mp <- createAddCommit alice1 convId [bob]
      bindResponse (postMLSCommitBundle mp.sender (mkBundle mp)) $ \Response
resp -> do
        Response
resp.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
533
        Response
resp.jsonBody Maybe Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"unreachable_backends" App Value -> [String] -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatchSet` [BackendResource
cDom.berDomain]

      runCodensity (startDynamicBackend cDom mempty) $ \String
_ ->
        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
$ HasCallStack => ClientIdentity -> ByteString -> App Response
ClientIdentity -> ByteString -> App Response
postMLSCommitBundle MessagePackage
mp.sender (MessagePackage -> ByteString
mkBundle MessagePackage
mp) 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
201

    do
      mp <- createAddCommit alice1 convId [brad]
      void $ postMLSCommitBundle mp.sender (mkBundle mp) >>= getBody 201

    do
      mp <- runCodensity (startDynamicBackend cDom mempty) $ \String
_ ->
        HasCallStack =>
ClientIdentity -> ConvId -> [Value] -> App MessagePackage
ClientIdentity -> ConvId -> [Value] -> App MessagePackage
createAddCommit ClientIdentity
alice1 ConvId
convId [Value
chris]
      bindResponse (postMLSCommitBundle mp.sender (mkBundle mp)) $ \Response
resp -> do
        Response
resp.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
533
        Response
resp.jsonBody Maybe Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"unreachable_backends" App Value -> [String] -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatchSet` [BackendResource
cDom.berDomain]

testAddUnreachableUserFromFederatingBackend :: (HasCallStack) => App ()
testAddUnreachableUserFromFederatingBackend :: HasCallStack => App ()
testAddUnreachableUserFromFederatingBackend = do
  resourcePool <- (Env -> ResourcePool BackendResource)
-> App (ResourcePool BackendResource)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env -> ResourcePool BackendResource
resourcePool
  runCodensity (acquireResources 1 resourcePool) $ \[BackendResource
cDom] -> do
    mp <- 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
cDom ServiceOverrides
forall a. Monoid a => a
mempty) ((String -> App MessagePackage) -> App MessagePackage)
-> (String -> App MessagePackage) -> App MessagePackage
forall a b. (a -> b) -> a -> b
$ \String
_ -> do
      ownDomain <- Domain -> App Value
forall a. (MakesValue a, HasCallStack) => a -> App Value
make Domain
OwnDomain App Value -> (App Value -> App String) -> App String
forall a b. a -> (a -> b) -> b
& App Value -> App String
forall a. (HasCallStack, MakesValue a) => a -> App String
asString
      otherDomain <- make OtherDomain & asString
      [alice, bob, charlie, chad] <-
        createAndConnectUsers [ownDomain, otherDomain, cDom.berDomain, cDom.berDomain]

      [alice1, bob1, charlie1, chad1] <- traverse (createMLSClient def) [alice, bob, charlie, chad]
      traverse_ (uploadNewKeyPackage def) [bob1, charlie1, chad1]
      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] -> (WebSocket -> App Value) -> App ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [WebSocket]
wss ((WebSocket -> App Value) -> App ())
-> (WebSocket -> 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
isMemberJoinNotif
      createAddCommit alice1 convId [chad]

    bindResponse (postMLSCommitBundle mp.sender (mkBundle mp)) $ \Response
resp -> do
      Response
resp.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
533
      Response
resp.jsonBody Maybe Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"unreachable_backends" App Value -> [String] -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatchSet` [BackendResource
cDom.berDomain]