{-# LANGUAGE OverloadedLabels #-}

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

import qualified API.Brig as BrigP
import API.Galley
import Control.Lens
import Control.Monad.Codensity
import Control.Monad.Reader
import qualified Data.ProtoLens as Proto
import Data.ProtoLens.Labels ()
import Notifications
import Numeric.Lens
import qualified Proto.Otr as Proto
import qualified Proto.Otr_Fields as Proto
import SetupHelpers
import Testlib.Prelude
import Testlib.ResourcePool

testNotificationsForOfflineBackends :: (HasCallStack) => App ()
testNotificationsForOfflineBackends :: HasCallStack => App ()
testNotificationsForOfflineBackends = do
  resourcePool <- (Env -> ResourcePool BackendResource)
-> App (ResourcePool BackendResource)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (.resourcePool)
  -- `delUser` will eventually get deleted.
  [delUser, otherUser, otherUser2] <- createUsers [OwnDomain, OtherDomain, OtherDomain]
  delClient <- objId $ bindResponse (BrigP.addClient delUser def) $ getJSON 201
  otherClient <- objId $ bindResponse (BrigP.addClient otherUser def) $ getJSON 201
  otherClient2 <- objId $ bindResponse (BrigP.addClient otherUser2 def) $ getJSON 201

  -- We call it 'downBackend' because it is down for most of this test
  -- except for setup and assertions. Perhaps there is a better name.
  runCodensity (acquireResources 1 resourcePool) $ \[BackendResource
downBackend] -> do
    (downUser1, downClient1, downUser2, upBackendConv, downBackendConv) <- 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
downBackend ServiceOverrides
forall a. Monoid a => a
mempty) ((String -> App (Value, String, Value, Value, Value))
 -> App (Value, String, Value, Value, Value))
-> (String -> App (Value, String, Value, Value, Value))
-> App (Value, String, Value, Value, Value)
forall a b. (a -> b) -> a -> b
$ \String
_ -> do
      downUser1 <- String -> CreateUser -> App Value
forall domain.
(HasCallStack, MakesValue domain) =>
domain -> CreateUser -> App Value
randomUser BackendResource
downBackend.berDomain CreateUser
forall a. Default a => a
def
      downUser2 <- randomUser downBackend.berDomain def
      downClient1 <- objId $ bindResponse (BrigP.addClient downUser1 def) $ getJSON 201

      connectTwoUsers delUser otherUser
      connectTwoUsers delUser otherUser2
      connectTwoUsers delUser downUser1
      connectTwoUsers delUser downUser2
      connectTwoUsers downUser1 otherUser

      upBackendConv <- bindResponse (postConversation delUser (defProteus {qualifiedUsers = [otherUser, otherUser2, downUser1]})) $ getJSON 201
      downBackendConv <- bindResponse (postConversation downUser1 (defProteus {qualifiedUsers = [otherUser, delUser]})) $ getJSON 201
      pure (downUser1, downClient1, downUser2, upBackendConv, downBackendConv)

    withWebSocket otherUser $ \WebSocket
ws -> do
      -- Even when a participating backend is down, messages to conversations
      -- owned by other backends should go.
      successfulMsgForOtherUsers <- Value -> [(Value, [String])] -> String -> App QualifiedUserEntry
forall domain user client.
(HasCallStack, MakesValue domain, MakesValue user,
 MakesValue client) =>
domain -> [(user, [client])] -> String -> App QualifiedUserEntry
mkProteusRecipients Value
otherUser [(Value
otherUser, [String
otherClient]), (Value
otherUser2, [String
otherClient2])] String
"success message for other user"
      successfulMsgForDownUser <- mkProteusRecipient downUser1 downClient1 "success message for down user"
      let successfulMsg =
            forall msg. Message msg => msg
Proto.defMessage @Proto.QualifiedNewOtrMessage
              QualifiedNewOtrMessage
-> (QualifiedNewOtrMessage -> QualifiedNewOtrMessage)
-> QualifiedNewOtrMessage
forall a b. a -> (a -> b) -> b
& (ClientId -> Identity ClientId)
-> QualifiedNewOtrMessage -> Identity QualifiedNewOtrMessage
#sender ((ClientId -> Identity ClientId)
 -> QualifiedNewOtrMessage -> Identity QualifiedNewOtrMessage)
-> ((Word64 -> Identity Word64) -> ClientId -> Identity ClientId)
-> (Word64 -> Identity Word64)
-> QualifiedNewOtrMessage
-> Identity QualifiedNewOtrMessage
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Word64 -> Identity Word64) -> ClientId -> Identity ClientId
forall (f :: * -> *) s a.
(Functor f, HasField s "client" a) =>
LensLike' f s a
Proto.client ((Word64 -> Identity Word64)
 -> QualifiedNewOtrMessage -> Identity QualifiedNewOtrMessage)
-> Word64 -> QualifiedNewOtrMessage -> QualifiedNewOtrMessage
forall s t a b. ASetter s t a b -> b -> s -> t
.~ (String
delClient String -> Getting (Endo Word64) String Word64 -> Word64
forall s a. HasCallStack => s -> Getting (Endo a) s a -> a
^?! Getting (Endo Word64) String Word64
forall a. Integral a => Prism' String a
Prism' String Word64
hex)
              QualifiedNewOtrMessage
-> (QualifiedNewOtrMessage -> QualifiedNewOtrMessage)
-> QualifiedNewOtrMessage
forall a b. a -> (a -> b) -> b
& ASetter
  QualifiedNewOtrMessage
  QualifiedNewOtrMessage
  [QualifiedUserEntry]
  [QualifiedUserEntry]
#recipients ASetter
  QualifiedNewOtrMessage
  QualifiedNewOtrMessage
  [QualifiedUserEntry]
  [QualifiedUserEntry]
-> [QualifiedUserEntry]
-> QualifiedNewOtrMessage
-> QualifiedNewOtrMessage
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [QualifiedUserEntry
successfulMsgForOtherUsers, QualifiedUserEntry
successfulMsgForDownUser]
              QualifiedNewOtrMessage
-> (QualifiedNewOtrMessage -> QualifiedNewOtrMessage)
-> QualifiedNewOtrMessage
forall a b. a -> (a -> b) -> b
& ASetter
  QualifiedNewOtrMessage
  QualifiedNewOtrMessage
  ClientMismatchStrategy'ReportAll
  ClientMismatchStrategy'ReportAll
#reportAll ASetter
  QualifiedNewOtrMessage
  QualifiedNewOtrMessage
  ClientMismatchStrategy'ReportAll
  ClientMismatchStrategy'ReportAll
-> ClientMismatchStrategy'ReportAll
-> QualifiedNewOtrMessage
-> QualifiedNewOtrMessage
forall s t a b. ASetter s t a b -> b -> s -> t
.~ ClientMismatchStrategy'ReportAll
forall msg. Message msg => msg
Proto.defMessage
      bindResponse (postProteusMessage delUser upBackendConv successfulMsg) assertSuccess

      -- When the conversation owning backend is down, messages will fail to be sent.
      failedMsgForOtherUser <- mkProteusRecipient otherUser otherClient "failed message for other user"
      failedMsgForDownUser <- mkProteusRecipient downUser1 downClient1 "failed message for down user"
      let failedMsg =
            forall msg. Message msg => msg
Proto.defMessage @Proto.QualifiedNewOtrMessage
              QualifiedNewOtrMessage
-> (QualifiedNewOtrMessage -> QualifiedNewOtrMessage)
-> QualifiedNewOtrMessage
forall a b. a -> (a -> b) -> b
& (ClientId -> Identity ClientId)
-> QualifiedNewOtrMessage -> Identity QualifiedNewOtrMessage
#sender ((ClientId -> Identity ClientId)
 -> QualifiedNewOtrMessage -> Identity QualifiedNewOtrMessage)
-> ((Word64 -> Identity Word64) -> ClientId -> Identity ClientId)
-> (Word64 -> Identity Word64)
-> QualifiedNewOtrMessage
-> Identity QualifiedNewOtrMessage
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Word64 -> Identity Word64) -> ClientId -> Identity ClientId
forall (f :: * -> *) s a.
(Functor f, HasField s "client" a) =>
LensLike' f s a
Proto.client ((Word64 -> Identity Word64)
 -> QualifiedNewOtrMessage -> Identity QualifiedNewOtrMessage)
-> Word64 -> QualifiedNewOtrMessage -> QualifiedNewOtrMessage
forall s t a b. ASetter s t a b -> b -> s -> t
.~ (String
delClient String -> Getting (Endo Word64) String Word64 -> Word64
forall s a. HasCallStack => s -> Getting (Endo a) s a -> a
^?! Getting (Endo Word64) String Word64
forall a. Integral a => Prism' String a
Prism' String Word64
hex)
              QualifiedNewOtrMessage
-> (QualifiedNewOtrMessage -> QualifiedNewOtrMessage)
-> QualifiedNewOtrMessage
forall a b. a -> (a -> b) -> b
& ASetter
  QualifiedNewOtrMessage
  QualifiedNewOtrMessage
  [QualifiedUserEntry]
  [QualifiedUserEntry]
#recipients ASetter
  QualifiedNewOtrMessage
  QualifiedNewOtrMessage
  [QualifiedUserEntry]
  [QualifiedUserEntry]
-> [QualifiedUserEntry]
-> QualifiedNewOtrMessage
-> QualifiedNewOtrMessage
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [QualifiedUserEntry
failedMsgForOtherUser, QualifiedUserEntry
failedMsgForDownUser]
              QualifiedNewOtrMessage
-> (QualifiedNewOtrMessage -> QualifiedNewOtrMessage)
-> QualifiedNewOtrMessage
forall a b. a -> (a -> b) -> b
& ASetter
  QualifiedNewOtrMessage
  QualifiedNewOtrMessage
  ClientMismatchStrategy'ReportAll
  ClientMismatchStrategy'ReportAll
#reportAll ASetter
  QualifiedNewOtrMessage
  QualifiedNewOtrMessage
  ClientMismatchStrategy'ReportAll
  ClientMismatchStrategy'ReportAll
-> ClientMismatchStrategy'ReportAll
-> QualifiedNewOtrMessage
-> QualifiedNewOtrMessage
forall s t a b. ASetter s t a b -> b -> s -> t
.~ ClientMismatchStrategy'ReportAll
forall msg. Message msg => msg
Proto.defMessage
      bindResponse (postProteusMessage delUser downBackendConv failedMsg) $ \Response
resp ->
        -- Due to the way federation breaks in local env vs K8s, it can return 521
        -- (local) or 533 (K8s).
        Response
resp.status Int -> [Value] -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatchOneOf` [Scientific -> Value
Number Scientific
521, Scientific -> Value
Number Scientific
533]

      -- Conversation creation with people from down backend should fail
      bindResponse (postConversation delUser (defProteus {qualifiedUsers = [otherUser, downUser1]})) $ \Response
resp ->
        Response
resp.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
533

      -- Adding users to an up backend conversation should not work when one of
      -- the participating backends is down. This is due to not being able to
      -- check non-fully connected graph between all participating backends
      -- however, if the backend of the user to be added is already part of the conversation, we do not need to do the check
      -- and the user can be added as long as the backend is reachable
      otherUser3 <- randomUser OtherDomain def
      connectTwoUsers delUser otherUser3
      bindResponse (addMembers delUser upBackendConv def {users = [otherUser3]}) $ \Response
resp ->
        Response
resp.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
200

      -- Adding users from down backend to a conversation should fail
      bindResponse (addMembers delUser upBackendConv def {users = [downUser2]}) $ \Response
resp ->
        Response
resp.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
533

      -- Removing users from an up backend conversation should work even when one
      -- of the participating backends is down.
      bindResponse (removeMember delUser upBackendConv otherUser2) $ \Response
resp ->
        Response
resp.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
200

      -- Even removing a user from the down backend itself should work.
      bindResponse (removeMember delUser upBackendConv delUser) $ \Response
resp ->
        Response
resp.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
200

      -- User deletions should eventually make it to the other backend.
      deleteUser delUser

      let isOtherUser2LeaveUpConvNotif = [Value -> App Bool] -> Value -> App Bool
forall (f :: * -> *) a.
Applicative f =>
[a -> f Bool] -> a -> f Bool
allPreds [Value -> App Bool
forall a. (HasCallStack, MakesValue a) => a -> App Bool
isConvLeaveNotif, Value -> Value -> App Bool
forall conv a.
(HasCallStack, MakesValue conv, MakesValue a, HasCallStack) =>
conv -> a -> App Bool
isNotifConv Value
upBackendConv, Value -> Value -> App Bool
forall conv a.
(HasCallStack, MakesValue conv, MakesValue a, HasCallStack) =>
conv -> a -> App Bool
isNotifForUser Value
otherUser2]
          isDelUserLeaveUpConvNotif = [Value -> App Bool] -> Value -> App Bool
forall (f :: * -> *) a.
Applicative f =>
[a -> f Bool] -> a -> f Bool
allPreds [Value -> App Bool
forall a. (HasCallStack, MakesValue a) => a -> App Bool
isConvLeaveNotif, Value -> Value -> App Bool
forall conv a.
(HasCallStack, MakesValue conv, MakesValue a, HasCallStack) =>
conv -> a -> App Bool
isNotifConv Value
upBackendConv, Value -> Value -> App Bool
forall conv a.
(HasCallStack, MakesValue conv, MakesValue a, HasCallStack) =>
conv -> a -> App Bool
isNotifForUser Value
delUser]

      do
        newMsgNotif <- awaitMatch isNewMessageNotif ws
        newMsgNotif %. "payload.0.qualified_conversation" `shouldMatch` objQidObject upBackendConv
        newMsgNotif %. "payload.0.data.text" `shouldMatchBase64` fromString "success message for other user"

        void $ awaitMatch isOtherUser2LeaveUpConvNotif ws
        void $ awaitMatch isDelUserLeaveUpConvNotif ws

        delUserDeletedNotif <- nPayload $ awaitMatch isDeleteUserNotif ws
        objQid delUserDeletedNotif `shouldMatch` objQid delUser

    runCodensity (startDynamicBackend downBackend mempty) $ \String
_ -> do
      newMsgNotif <- Value -> String -> Maybe Value -> (Value -> App Bool) -> App Value
forall user client lastNotifId.
(HasCallStack, MakesValue user, MakesValue client,
 MakesValue lastNotifId) =>
user
-> client -> Maybe lastNotifId -> (Value -> App Bool) -> App Value
awaitNotificationClient Value
downUser1 String
downClient1 Maybe Value
noValue Value -> App Bool
forall a. (HasCallStack, MakesValue a) => a -> App Bool
isNewMessageNotif
      newMsgNotif %. "payload.0.qualified_conversation" `shouldMatch` objQidObject upBackendConv
      newMsgNotif %. "payload.0.data.text" `shouldMatchBase64` fromString "success message for down user"

      let isDelUserLeaveDownConvNotif =
            [Value -> App Bool] -> Value -> App Bool
forall (f :: * -> *) a.
Applicative f =>
[a -> f Bool] -> a -> f Bool
allPreds
              [ Value -> App Bool
forall a. (HasCallStack, MakesValue a) => a -> App Bool
isConvLeaveNotif,
                Value -> Value -> App Bool
forall conv a.
(HasCallStack, MakesValue conv, MakesValue a, HasCallStack) =>
conv -> a -> App Bool
isNotifConv Value
downBackendConv,
                Value -> Value -> App Bool
forall conv a.
(HasCallStack, MakesValue conv, MakesValue a, HasCallStack) =>
conv -> a -> App Bool
isNotifForUser Value
delUser
              ]
      void $ awaitNotificationClient downUser1 (Just downClient1) (Just newMsgNotif) isDelUserLeaveDownConvNotif

      -- FUTUREWORK: Uncomment after fixing this bug: https://wearezeta.atlassian.net/browse/WPB-3664
      -- void $ awaitNotification downUser1 downClient1 (Just newMsgNotif) 1 isOtherUser2LeaveUpConvNotif
      -- void $ awaitNotification otherUser otherClient (Just newMsgNotif) isDelUserLeaveDownConvNotif

      delUserDeletedNotif <- nPayload $ awaitNotificationClient downUser1 downClient1 (Just newMsgNotif) isDeleteUserNotif
      objQid delUserDeletedNotif `shouldMatch` objQid delUser