{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}

-- This file is part of the Wire Server implementation.
--
-- Copyright (C) 2022 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 API.User.Connection
  ( tests,
  )
where

import API.User.Util
import Bilge hiding (accept, timeout)
import Bilge.Assert
import Brig.Data.Connection (remoteConnectionInsert)
import Cassandra qualified as DB
import Control.Arrow ((&&&))
import Data.ByteString.Conversion
import Data.Domain
import Data.Id
import Data.Json.Util (UTCTimeMillis, toUTCTimeMillis)
import Data.Qualified
import Data.UUID.V4 qualified as UUID
import Imports
import Network.Wai.Utilities.Error qualified as Error
import Test.Tasty hiding (Timeout)
import Test.Tasty.HUnit
import Util
import Util.Timeout
import Wire.API.Connection
import Wire.API.Conversation
import Wire.API.Federation.API.Brig
import Wire.API.Federation.Component
import Wire.API.Routes.Internal.Brig.Connection
import Wire.API.Routes.MultiTablePaging
import Wire.API.User as User

tests ::
  ConnectionLimit ->
  Timeout ->
  Manager ->
  Brig ->
  Cannon ->
  Galley ->
  FedClient 'Brig ->
  DB.ClientState ->
  TestTree
tests cl _at p b _c g fedBrigClient db =
  testGroup
    "connection"
    [ test p "post /connections" $ testCreateManualConnections b,
      test p "post /connections/:domain/:uid" $ testCreateManualConnectionsQualified b,
      test p "post /connections mutual" $ testCreateMutualConnections b g,
      test p "post /connections/:domain/:uid mutual" $ testCreateMutualConnectionsQualified b g,
      test p "post /connections (bad user)" $ testCreateConnectionInvalidUser b,
      test p "post /connections/:domain/:uid (bad user)" $ testCreateConnectionInvalidUserQualified b,
      test p "put /connections/:id accept" $ testAcceptConnection b,
      test p "put /connections/:domain/:id accept" $ testAcceptConnectionQualified b,
      test p "put /connections/:id ignore" $ testIgnoreConnection b,
      test p "put /connections/:domain/:id ignore" $ testIgnoreConnectionQualified b,
      test p "put /connections/:id cancel" $ testCancelConnection b,
      test p "put /connections/:domain/:id cancel" $ testCancelConnectionQualified b,
      test p "put /connections/:id cancel 2" $ testCancelConnection2 b g,
      test p "put /connections/:domain/:id cancel 2" $ testCancelConnectionQualified2 b g,
      test p "put /connections/:id block" $ testBlockConnection b,
      test p "put /connections/:domain/:id block" $ testBlockConnectionQualified b,
      test p "put /connections/:id block-resend" $ testBlockAndResendConnection b g,
      test p "put /connections/:domain/:id block-resend" $ testBlockAndResendConnectionQualified b g,
      test p "put /connections/:id unblock pending" $ testUnblockPendingConnection b,
      test p "put /connections/:domain/:id unblock pending" $ testUnblockPendingConnectionQualified b,
      test p "put /connections/:id accept blocked" $ testAcceptWhileBlocked b,
      test p "put /connections/:domain/:id accept blocked" $ testAcceptWhileBlockedQualified b,
      test p "put /connections/:id bad update" $ testBadUpdateConnection b,
      test p "put /connections/:domain/:id bad update" $ testBadUpdateConnectionQualified b,
      test p "put /connections/:id noop" $ testUpdateConnectionNoop b,
      test p "put /connections/:domain/:id noop" $ testUpdateConnectionNoopQualified b,
      test p "get /connections - 200 (paging)" $ testLocalConnectionsPaging b,
      test p "post /list-connections - 200 (paging)" $ testAllConnectionsPaging b db,
      test p "post /connections - 400 (max conns)" $ testConnectionLimit b cl,
      test p "post /connections/:domain/:id - 400 (max conns)" $ testConnectionLimitQualified b cl,
      test p "Remote connections: connect with no federation" (testConnectFederationNotAvailable b),
      test p "Remote connections: connect OK" (testConnectOK b g fedBrigClient),
      test p "Remote connections: connect with Anon" (testConnectWithAnon b fedBrigClient),
      test p "Remote connections: connection from Anon" (testConnectFromAnon b),
      test p "Remote connections: connect twice" (testConnectFromPending b fedBrigClient)
    ]

testCreateConnectionInvalidUser :: Brig -> Http ()
testCreateConnectionInvalidUser brig = do
  uid1 <- User.userId <$> randomUser brig
  -- user does not exist
  uid2 <- Id <$> liftIO UUID.nextRandom
  postConnection brig uid1 uid2 !!! do
    const 400 === statusCode
    const (Just "invalid-user") === fmap Error.label . responseJsonMaybe
  -- cannot create a connection with yourself
  postConnection brig uid1 uid1 !!! do
    const 400 === statusCode
    const (Just "invalid-user") === fmap Error.label . responseJsonMaybe

testCreateConnectionInvalidUserQualified :: Brig -> Http ()
testCreateConnectionInvalidUserQualified brig = do
  quid1 <- userQualifiedId <$> randomUser brig
  let uid1 = qUnqualified quid1
      domain = qDomain quid1
  -- user does not exist
  uid2 <- Id <$> liftIO UUID.nextRandom
  let quid2 = Qualified uid2 domain
  postConnectionQualified brig uid1 quid2 !!! do
    const 400 === statusCode
    const (Just "invalid-user") === fmap Error.label . responseJsonMaybe
  -- cannot create a connection with yourself
  postConnectionQualified brig uid1 quid1 !!! do
    const 400 === statusCode
    const (Just "invalid-user") === fmap Error.label . responseJsonMaybe

testCreateManualConnections :: Brig -> Http ()
testCreateManualConnections brig = do
  uid1 <- User.userId <$> randomUser brig
  uid2 <- User.userId <$> randomUser brig
  postConnection brig uid1 uid2 !!! const 201 === statusCode
  assertConnections brig uid1 [ConnectionStatus uid1 uid2 Sent]
  assertConnections brig uid2 [ConnectionStatus uid2 uid1 Pending]
  -- Test that no connections to anonymous users can be created,
  -- as well as that anonymous users cannot create connections.
  uid3 <- User.userId <$> createAnonUser "foo3" brig
  postConnection brig uid1 uid3 !!! const 400 === statusCode
  postConnection brig uid3 uid1 !!! const 403 === statusCode

testCreateManualConnectionsQualified :: Brig -> Http ()
testCreateManualConnectionsQualified brig = do
  (quid1, uid1, quid2, uid2) <- twoRandomUsers brig
  postConnectionQualified brig uid1 quid2 !!! const 201 === statusCode
  assertConnectionQualified brig uid1 quid2 Sent
  assertConnectionQualified brig uid2 quid1 Pending
  -- Test that no connections to anonymous users can be created,
  -- as well as that anonymous users cannot create connections.
  quid3 <- userQualifiedId <$> createAnonUser "foo3" brig
  let uid3 = qUnqualified quid3
  postConnectionQualified brig uid1 quid3 !!! const 400 === statusCode
  postConnectionQualified brig uid3 quid1 !!! const 403 === statusCode

testCreateMutualConnections :: Brig -> Galley -> Http ()
testCreateMutualConnections brig galley = do
  uid1 <- User.userId <$> randomUser brig
  uid2 <- User.userId <$> randomUser brig
  postConnection brig uid1 uid2 !!! const 201 === statusCode
  assertConnections brig uid1 [ConnectionStatus uid1 uid2 Sent]
  assertConnections brig uid2 [ConnectionStatus uid2 uid1 Pending]
  rsp <- postConnection brig uid2 uid1 <!! const 200 === statusCode
  assertConnections brig uid1 [ConnectionStatus uid1 uid2 Accepted]
  assertConnections brig uid2 [ConnectionStatus uid2 uid1 Accepted]
  case responseJsonMaybe rsp >>= ucConvId of
    Nothing -> liftIO $ assertFailure "incomplete connection"
    Just qcnv -> do
      getConversationQualified galley uid1 qcnv !!! do
        const 200 === statusCode
        const (Just One2OneConv) === fmap cnvType . responseJsonMaybe @(OwnConversation GroupConvType)
      getConversationQualified galley uid2 qcnv !!! do
        const 200 === statusCode
        const (Just One2OneConv) === fmap cnvType . responseJsonMaybe @(OwnConversation GroupConvType)

testCreateMutualConnectionsQualified :: Brig -> Galley -> Http ()
testCreateMutualConnectionsQualified brig galley = do
  (quid1, uid1, quid2, uid2) <- twoRandomUsers brig

  postConnectionQualified brig uid1 quid2 !!! const 201 === statusCode
  assertConnectionQualified brig uid1 quid2 Sent
  assertConnectionQualified brig uid2 quid1 Pending

  rsp <- postConnectionQualified brig uid2 quid1 <!! const 200 === statusCode
  assertConnectionQualified brig uid2 quid1 Accepted
  assertConnectionQualified brig uid1 quid2 Accepted

  case responseJsonMaybe rsp >>= ucConvId of
    Nothing -> liftIO $ assertFailure "incomplete connection"
    Just cnv -> do
      getConversationQualified galley uid1 cnv !!! do
        const 200 === statusCode
        const (Just One2OneConv) === fmap cnvType . responseJsonMaybe @(OwnConversation GroupConvType)
      getConversationQualified galley uid2 cnv !!! do
        const 200 === statusCode
        const (Just One2OneConv) === fmap cnvType . responseJsonMaybe @(OwnConversation GroupConvType)

testAcceptConnection :: Brig -> Http ()
testAcceptConnection brig = do
  uid1 <- User.userId <$> randomUser brig
  uid2 <- User.userId <$> randomUser brig
  -- Initiate a new connection (A -> B)
  postConnection brig uid1 uid2 !!! const 201 === statusCode
  -- B accepts
  putConnection brig uid2 uid1 Accepted !!! const 200 === statusCode
  assertConnections brig uid1 [ConnectionStatus uid1 uid2 Accepted]
  assertConnections brig uid2 [ConnectionStatus uid2 uid1 Accepted]
  -- Mutual connection request with a user C
  uid3 <- User.userId <$> randomUser brig
  postConnection brig uid1 uid3 !!! const 201 === statusCode
  postConnection brig uid3 uid1 !!! const 200 === statusCode
  assertConnections brig uid1 [ConnectionStatus uid1 uid3 Accepted]
  assertConnections brig uid3 [ConnectionStatus uid3 uid1 Accepted]

testAcceptConnectionQualified :: Brig -> Http ()
testAcceptConnectionQualified brig = do
  (quid1, uid1, quid2, uid2) <- twoRandomUsers brig
  -- Initiate a new connection (A -> B)
  postConnectionQualified brig uid1 quid2 !!! const 201 === statusCode
  -- B accepts
  putConnectionQualified brig uid2 quid1 Accepted !!! const 200 === statusCode

  assertConnectionQualified brig uid1 quid2 Accepted
  assertConnectionQualified brig uid2 quid1 Accepted

testIgnoreConnection :: Brig -> Http ()
testIgnoreConnection brig = do
  uid1 <- User.userId <$> randomUser brig
  uid2 <- User.userId <$> randomUser brig
  -- Initiate a new connection (A -> B)
  postConnection brig uid1 uid2 !!! const 201 === statusCode
  -- B ignores A
  putConnection brig uid2 uid1 Ignored !!! const 200 === statusCode
  assertConnections brig uid1 [ConnectionStatus uid1 uid2 Sent]
  assertConnections brig uid2 [ConnectionStatus uid2 uid1 Ignored]
  -- B accepts after all
  putConnection brig uid2 uid1 Accepted !!! const 200 === statusCode
  assertConnections brig uid1 [ConnectionStatus uid1 uid2 Accepted]
  assertConnections brig uid2 [ConnectionStatus uid2 uid1 Accepted]

testIgnoreConnectionQualified :: Brig -> Http ()
testIgnoreConnectionQualified brig = do
  (quid1, uid1, quid2, uid2) <- twoRandomUsers brig
  -- Initiate a new connection (A -> B)
  postConnectionQualified brig uid1 quid2 !!! const 201 === statusCode
  -- B ignores A
  putConnectionQualified brig uid2 quid1 Ignored !!! const 200 === statusCode
  assertConnectionQualified brig uid1 quid2 Sent
  assertConnectionQualified brig uid2 quid1 Ignored
  -- B accepts after all
  putConnectionQualified brig uid2 quid1 Accepted !!! const 200 === statusCode
  assertConnectionQualified brig uid1 quid2 Accepted
  assertConnectionQualified brig uid2 quid1 Accepted

testCancelConnection :: Brig -> Http ()
testCancelConnection brig = do
  uid1 <- User.userId <$> randomUser brig
  uid2 <- User.userId <$> randomUser brig
  -- Initiate a new connection (A -> B)
  postConnection brig uid1 uid2 !!! const 201 === statusCode
  -- A cancels the request
  putConnection brig uid1 uid2 Cancelled !!! const 200 === statusCode
  assertConnections brig uid1 [ConnectionStatus uid1 uid2 Cancelled]
  assertConnections brig uid2 [ConnectionStatus uid2 uid1 Cancelled]
  -- A changes their mind again
  postConnection brig uid1 uid2 !!! const 200 === statusCode
  assertConnections brig uid1 [ConnectionStatus uid1 uid2 Sent]
  assertConnections brig uid2 [ConnectionStatus uid2 uid1 Pending]

testCancelConnectionQualified :: Brig -> Http ()
testCancelConnectionQualified brig = do
  (quid1, uid1, quid2, uid2) <- twoRandomUsers brig
  -- Initiate a new connection (A -> B)
  postConnectionQualified brig uid1 quid2 !!! const 201 === statusCode
  -- A cancels the request
  putConnectionQualified brig uid1 quid2 Cancelled !!! const 200 === statusCode
  assertConnectionQualified brig uid1 quid2 Cancelled
  assertConnectionQualified brig uid2 quid1 Cancelled
  -- A changes their mind again
  postConnectionQualified brig uid1 quid2 !!! const 200 === statusCode
  assertConnectionQualified brig uid1 quid2 Sent
  assertConnectionQualified brig uid2 quid1 Pending

testCancelConnection2 :: Brig -> Galley -> Http ()
testCancelConnection2 brig galley = do
  uid1 <- User.userId <$> randomUser brig
  uid2 <- User.userId <$> randomUser brig
  -- Initiate a new connection (A -> B)
  postConnection brig uid1 uid2 !!! const 201 === statusCode
  -- A cancels the request
  rsp <- putConnection brig uid1 uid2 Cancelled <!! const 200 === statusCode
  assertConnections brig uid1 [ConnectionStatus uid1 uid2 Cancelled]
  assertConnections brig uid2 [ConnectionStatus uid2 uid1 Cancelled]
  let Just qcnv = ucConvId =<< responseJsonMaybe rsp
  -- A cannot see the conversation (due to cancelling)
  getConversationQualified galley uid1 qcnv !!! do
    const 403 === statusCode
  -- B cannot see the conversation
  getConversationQualified galley uid2 qcnv !!! const 403 === statusCode
  -- B initiates a connection request himself
  postConnection brig uid2 uid1 !!! const 200 === statusCode
  assertConnections brig uid2 [ConnectionStatus uid2 uid1 Sent]
  assertConnections brig uid1 [ConnectionStatus uid1 uid2 Pending]
  -- B is now a current member of the connect conversation
  getConversationQualified galley uid2 qcnv !!! do
    const 200 === statusCode
    const (Just ConnectConv) === \rs -> do
      conv <- responseJsonMaybe @(OwnConversation GroupConvType) rs
      Just (cnvType conv)
  -- A is a past member, cannot see the conversation
  getConversationQualified galley uid1 qcnv !!! do
    const 403 === statusCode
  -- A finally accepts
  putConnection brig uid1 uid2 Accepted !!! const 200 === statusCode
  assertConnections brig uid1 [ConnectionStatus uid1 uid2 Accepted]
  assertConnections brig uid2 [ConnectionStatus uid2 uid1 Accepted]
  getConversationQualified galley uid1 qcnv !!! do
    const 200 === statusCode
  getConversationQualified galley uid2 qcnv !!! do
    const 200 === statusCode

testCancelConnectionQualified2 :: Brig -> Galley -> Http ()
testCancelConnectionQualified2 brig galley = do
  (quid1, uid1, quid2, uid2) <- twoRandomUsers brig
  -- Initiate a new connection (A -> B)
  postConnectionQualified brig uid1 quid2 !!! const 201 === statusCode
  -- A cancels the request
  rsp <- putConnectionQualified brig uid1 quid2 Cancelled <!! const 200 === statusCode
  assertConnectionQualified brig uid1 quid2 Cancelled
  assertConnectionQualified brig uid2 quid1 Cancelled
  let Just cnv = ucConvId =<< responseJsonMaybe rsp
  -- A cannot see the conversation (due to cancelling)
  getConversationQualified galley uid1 cnv !!! do
    const 403 === statusCode
  -- B cannot see the conversation
  getConversationQualified galley uid2 cnv !!! const 403 === statusCode
  -- B inititates a connection request themselves
  postConnectionQualified brig uid2 quid1 !!! const 200 === statusCode
  assertConnectionQualified brig uid2 quid1 Sent
  assertConnectionQualified brig uid1 quid2 Pending
  -- B is now a current member of the connect conversation
  getConversationQualified galley uid2 cnv !!! do
    const 200 === statusCode
    const (Just ConnectConv) === \rs -> do
      conv <- responseJsonMaybe @(OwnConversation GroupConvType) rs
      Just (cnvType conv)
  -- A is a past member, cannot see the conversation
  getConversationQualified galley uid1 cnv !!! do
    const 403 === statusCode
  -- A finally accepts
  putConnectionQualified brig uid1 quid2 Accepted !!! const 200 === statusCode
  assertConnectionQualified brig uid2 quid1 Accepted
  assertConnectionQualified brig uid1 quid2 Accepted
  getConversationQualified galley uid1 cnv !!! do
    const 200 === statusCode
  getConversationQualified galley uid2 cnv !!! do
    const 200 === statusCode

testBlockConnection :: Brig -> Http ()
testBlockConnection brig = do
  u1 <- randomUser brig
  u2 <- randomUser brig
  let uid1 = User.userId u1
  let uid2 = User.userId u2
  -- Initiate a new connection (A -> B)
  postConnection brig uid1 uid2 !!! const 201 === statusCode
  -- Even connected users cannot see each other's email
  assertEmailVisibility brig u2 u1 False
  assertEmailVisibility brig u1 u2 False
  -- B blocks A
  putConnection brig uid2 uid1 Blocked !!! const 200 === statusCode
  -- A does not notice that he got blocked
  postConnection brig uid1 uid2 !!! do
    const 200 === statusCode
    const (Just Sent) === fmap ucStatus . responseJsonMaybe
  assertConnections brig uid2 [ConnectionStatus uid2 uid1 Blocked]
  -- B accepts after all
  putConnection brig uid2 uid1 Accepted !!! const 200 === statusCode
  assertConnections brig uid1 [ConnectionStatus uid1 uid2 Accepted]
  assertConnections brig uid2 [ConnectionStatus uid2 uid1 Accepted]
  assertEmailVisibility brig u1 u2 False
  -- B blocks A again
  putConnection brig uid2 uid1 Blocked !!! const 200 === statusCode
  assertConnections brig uid2 [ConnectionStatus uid2 uid1 Blocked]
  assertConnections brig uid1 [ConnectionStatus uid1 uid2 Accepted]
  assertEmailVisibility brig u1 u2 False
  -- B accepts again
  putConnection brig uid2 uid1 Accepted !!! const 200 === statusCode
  assertConnections brig uid1 [ConnectionStatus uid1 uid2 Accepted]
  assertConnections brig uid2 [ConnectionStatus uid2 uid1 Accepted]
  assertEmailVisibility brig u1 u2 False
  -- A blocks B
  putConnection brig uid1 uid2 Blocked !!! const 200 === statusCode
  assertConnections brig uid1 [ConnectionStatus uid1 uid2 Blocked]
  assertConnections brig uid2 [ConnectionStatus uid2 uid1 Accepted]
  assertEmailVisibility brig u2 u1 False
  -- A accepts B again
  putConnection brig uid1 uid2 Accepted !!! const 200 === statusCode
  assertConnections brig uid2 [ConnectionStatus uid2 uid1 Accepted]
  assertConnections brig uid1 [ConnectionStatus uid1 uid2 Accepted]
  assertEmailVisibility brig u2 u1 False

testBlockConnectionQualified :: Brig -> Http ()
testBlockConnectionQualified brig = do
  u1 <- randomUser brig
  u2 <- randomUser brig
  let uid1 = User.userId u1
      uid2 = User.userId u2
      quid1 = userQualifiedId u1
      quid2 = userQualifiedId u2
  -- Initiate a new connection (A -> B)
  postConnectionQualified brig uid1 quid2 !!! const 201 === statusCode
  -- Even connected users cannot see each other's email
  assertEmailVisibility brig u2 u1 False
  assertEmailVisibility brig u1 u2 False
  -- B blocks A
  putConnectionQualified brig uid2 quid1 Blocked !!! const 200 === statusCode
  -- A does not notice that he got blocked
  postConnectionQualified brig uid1 quid2 !!! do
    const 200 === statusCode
    const (Just Sent) === fmap ucStatus . responseJsonMaybe
  assertConnectionQualified brig uid2 quid1 Blocked
  -- B accepts after all
  putConnectionQualified brig uid2 quid1 Accepted !!! const 200 === statusCode
  assertConnectionQualified brig uid1 quid2 Accepted
  assertConnectionQualified brig uid2 quid1 Accepted
  assertEmailVisibility brig u1 u2 False
  -- B blocks A again
  putConnectionQualified brig uid2 quid1 Blocked !!! const 200 === statusCode
  assertConnectionQualified brig uid2 quid1 Blocked
  assertConnectionQualified brig uid1 quid2 Accepted
  assertEmailVisibility brig u1 u2 False
  -- B accepts again
  putConnectionQualified brig uid2 quid1 Accepted !!! const 200 === statusCode
  assertConnectionQualified brig uid1 quid2 Accepted
  assertConnectionQualified brig uid2 quid1 Accepted
  assertEmailVisibility brig u1 u2 False
  -- A blocks B
  putConnectionQualified brig uid1 quid2 Blocked !!! const 200 === statusCode
  assertConnectionQualified brig uid1 quid2 Blocked
  assertConnectionQualified brig uid2 quid1 Accepted
  assertEmailVisibility brig u2 u1 False
  -- A accepts B again
  putConnectionQualified brig uid1 quid2 Accepted !!! const 200 === statusCode
  assertConnectionQualified brig uid1 quid2 Accepted
  assertConnectionQualified brig uid2 quid1 Accepted
  assertEmailVisibility brig u2 u1 False

testBlockAndResendConnection :: Brig -> Galley -> Http ()
testBlockAndResendConnection brig galley = do
  u1 <- randomUser brig
  u2 <- randomUser brig
  let uid1 = User.userId u1
  let uid2 = User.userId u2
  -- Initiate a new connection (A -> B)
  postConnection brig uid1 uid2 !!! const 201 === statusCode
  -- B blocks A
  putConnection brig uid2 uid1 Blocked !!! const 200 === statusCode
  -- A blocks B
  putConnection brig uid1 uid2 Blocked !!! const 200 === statusCode
  -- Cannot resend while blocked, need to unblock first
  postConnection brig uid1 uid2 !!! const 403 === statusCode
  -- Unblock
  putConnection brig uid1 uid2 Accepted !!! const 200 === statusCode
  -- Try to resend the connection request
  -- B is not actually notified, since he blocked.
  rsp <- postConnection brig uid1 uid2 <!! const 200 === statusCode
  assertConnections brig uid1 [ConnectionStatus uid1 uid2 Accepted]
  assertConnections brig uid2 [ConnectionStatus uid2 uid1 Blocked]
  -- B never accepted and thus does not see the conversation
  let Just qcnv = ucConvId =<< responseJsonMaybe rsp
  getConversationQualified galley uid2 qcnv !!! const 403 === statusCode
  -- A can see the conversation and is a current member
  getConversationQualified galley uid1 qcnv !!! do
    const 200 === statusCode

testBlockAndResendConnectionQualified :: Brig -> Galley -> Http ()
testBlockAndResendConnectionQualified brig galley = do
  (quid1, uid1, quid2, uid2) <- twoRandomUsers brig
  -- Initiate a new connection (A -> B)
  postConnectionQualified brig uid1 quid2 !!! const 201 === statusCode
  -- B blocks A
  putConnectionQualified brig uid2 quid1 Blocked !!! const 200 === statusCode
  -- A blocks B
  putConnectionQualified brig uid1 quid2 Blocked !!! const 200 === statusCode
  -- Cannot resend while blocked, need to unblock first
  postConnectionQualified brig uid1 quid2 !!! const 403 === statusCode
  -- Unblock
  putConnectionQualified brig uid1 quid2 Accepted !!! const 200 === statusCode
  -- Try to resend the connection request
  -- B is not actually notified, since he blocked.
  rsp <- postConnectionQualified brig uid1 quid2 <!! const 200 === statusCode
  assertConnectionQualified brig uid1 quid2 Accepted
  assertConnectionQualified brig uid2 quid1 Blocked
  -- B never accepted and thus does not see the conversation
  let Just cnv = ucConvId =<< responseJsonMaybe rsp
  getConversationQualified galley uid2 cnv !!! const 403 === statusCode
  -- A can see the conversation and is a current member
  getConversationQualified galley uid1 cnv !!! do
    const 200 === statusCode

testUnblockPendingConnection :: Brig -> Http ()
testUnblockPendingConnection brig = do
  u1 <- User.userId <$> randomUser brig
  u2 <- User.userId <$> randomUser brig
  postConnection brig u1 u2 !!! const 201 === statusCode
  putConnection brig u1 u2 Blocked !!! const 200 === statusCode
  assertConnections brig u1 [ConnectionStatus u1 u2 Blocked]
  assertConnections brig u2 [ConnectionStatus u2 u1 Pending]
  putConnection brig u1 u2 Accepted !!! const 200 === statusCode
  assertConnections brig u1 [ConnectionStatus u1 u2 Sent]
  assertConnections brig u2 [ConnectionStatus u2 u1 Pending]

testUnblockPendingConnectionQualified :: Brig -> Http ()
testUnblockPendingConnectionQualified brig = do
  (quid1, uid1, quid2, uid2) <- twoRandomUsers brig
  postConnectionQualified brig uid1 quid2 !!! const 201 === statusCode
  putConnectionQualified brig uid1 quid2 Blocked !!! const 200 === statusCode
  assertConnectionQualified brig uid1 quid2 Blocked
  assertConnectionQualified brig uid2 quid1 Pending
  putConnectionQualified brig uid1 quid2 Accepted !!! const 200 === statusCode
  assertConnectionQualified brig uid1 quid2 Sent
  assertConnectionQualified brig uid2 quid1 Pending

testAcceptWhileBlocked :: Brig -> Http ()
testAcceptWhileBlocked brig = do
  u1 <- User.userId <$> randomUser brig
  u2 <- User.userId <$> randomUser brig
  postConnection brig u1 u2 !!! const 201 === statusCode
  putConnection brig u1 u2 Blocked !!! const 200 === statusCode
  assertConnections brig u1 [ConnectionStatus u1 u2 Blocked]
  assertConnections brig u2 [ConnectionStatus u2 u1 Pending]
  putConnection brig u2 u1 Accepted !!! const 200 === statusCode
  assertConnections brig u1 [ConnectionStatus u1 u2 Blocked]
  assertConnections brig u2 [ConnectionStatus u2 u1 Accepted]

testAcceptWhileBlockedQualified :: Brig -> Http ()
testAcceptWhileBlockedQualified brig = do
  (quid1, uid1, quid2, uid2) <- twoRandomUsers brig
  postConnectionQualified brig uid1 quid2 !!! const 201 === statusCode
  putConnectionQualified brig uid1 quid2 Blocked !!! const 200 === statusCode
  assertConnectionQualified brig uid1 quid2 Blocked
  assertConnectionQualified brig uid2 quid1 Pending
  putConnectionQualified brig uid2 quid1 Accepted !!! const 200 === statusCode
  assertConnectionQualified brig uid1 quid2 Blocked
  assertConnectionQualified brig uid2 quid1 Accepted

testUpdateConnectionNoop :: Brig -> Http ()
testUpdateConnectionNoop brig = do
  (_, uid1, _, uid2) <- twoRandomUsers brig
  postConnection brig uid1 uid2 !!! const 201 === statusCode
  putConnection brig uid2 uid1 Accepted !!! const 200 === statusCode
  putConnection brig uid2 uid1 Accepted !!! const 204 === statusCode

testUpdateConnectionNoopQualified :: Brig -> Http ()
testUpdateConnectionNoopQualified brig = do
  (quid1, uid1, quid2, uid2) <- twoRandomUsers brig
  postConnectionQualified brig uid1 quid2 !!! const 201 === statusCode
  putConnectionQualified brig uid2 quid1 Accepted !!! const 200 === statusCode
  putConnectionQualified brig uid2 quid1 Accepted !!! const 204 === statusCode

testBadUpdateConnection :: Brig -> Http ()
testBadUpdateConnection brig = do
  uid1 <- User.userId <$> randomUser brig
  uid2 <- User.userId <$> randomUser brig
  postConnection brig uid1 uid2 !!! const 201 === statusCode
  assertBadUpdate uid1 uid2 Pending
  assertBadUpdate uid1 uid2 Ignored
  assertBadUpdate uid1 uid2 Accepted
  assertBadUpdate uid2 uid1 Sent
  where
    assertBadUpdate u1 u2 s =
      putConnection brig u1 u2 s !!! do
        const 403 === statusCode
        const (Just "bad-conn-update") === fmap Error.label . responseJsonMaybe

testBadUpdateConnectionQualified :: Brig -> Http ()
testBadUpdateConnectionQualified brig = do
  (quid1, uid1, quid2, uid2) <- twoRandomUsers brig
  postConnectionQualified brig uid1 quid2 !!! const 201 === statusCode
  assertBadUpdate uid1 quid2 Pending
  assertBadUpdate uid1 quid2 Ignored
  assertBadUpdate uid1 quid2 Accepted
  assertBadUpdate uid2 quid1 Sent
  where
    assertBadUpdate :: UserId -> Qualified UserId -> Relation -> Http ()
    assertBadUpdate uid1 quid2 s =
      putConnectionQualified brig uid1 quid2 s !!! do
        const 403 === statusCode
        const (Just "bad-conn-update") === fmap Error.label . responseJsonMaybe

testLocalConnectionsPaging :: Brig -> Http ()
testLocalConnectionsPaging b = do
  u <- User.userId <$> randomUser b
  replicateM_ total $ do
    u2 <- User.userId <$> randomUser b
    postConnection b u u2 !!! const 201 === statusCode
  foldM_ (next u 2) (0, Nothing) [2, 2, 1, 0]
  foldM_ (next u total) (0, Nothing) [total, 0]
  where
    total = 5
    next :: UserId -> Int -> (Int, Maybe UserId) -> Int -> HttpT IO (Int, Maybe UserId)
    next u step (count, start) n = do
      let count' = count + step
      let range = queryRange (toByteString' <$> start) (Just step)
      r <-
        get (apiVersion "v1" . b . path "/connections" . zUser u . range)
          <!! const 200 === statusCode
      let (conns, more) = (fmap clConnections &&& fmap clHasMore) $ responseJsonMaybe r
      liftIO $ assertEqual "page size" (Just n) (length <$> conns)
      liftIO $ assertEqual "has more" (Just (count' < total)) more
      pure (count', conns >>= fmap (qUnqualified . ucTo) . listToMaybe . reverse)

testAllConnectionsPaging :: Brig -> DB.ClientState -> Http ()
testAllConnectionsPaging b db = do
  quid <- userQualifiedId <$> randomUser b
  let uid = qUnqualified quid
  replicateM_ totalLocal $ do
    qOther <- userQualifiedId <$> randomUser b
    postConnectionQualified b uid qOther !!! const 201 === statusCode

  -- FUTUREWORK: For now, because we do not support creating remote connections
  -- yet (as of Oct 1, 2021), we write some made-up remote connections directly
  -- to the database such that querying works.
  now <- toUTCTimeMillis <$> liftIO getCurrentTime
  replicateM_ totalRemote $ createRemoteConnection uid now

  -- get all connections at once
  resAll :: ConnectionsPage <- responseJsonError =<< listAllConnections b uid Nothing Nothing
  liftIO $ assertEqual "all: size" total (length . mtpResults $ resAll)
  liftIO $ assertEqual "all: has_more" False (mtpHasMore resAll)

  -- paginate by passing the pagingState
  resFirst :: ConnectionsPage <- responseJsonError =<< listAllConnections b uid (Just size) Nothing
  liftIO $ assertEqual "first: size" size (length . mtpResults $ resFirst)
  liftIO $ assertEqual "first: has_more" True (mtpHasMore resFirst)

  resNext :: ConnectionsPage <- responseJsonError =<< listAllConnections b uid Nothing (Just $ mtpPagingState resFirst)
  liftIO $ assertEqual "next: size" (total - size) (length . mtpResults $ resNext)
  liftIO $ assertEqual "next: has_more" False (mtpHasMore resNext)
  where
    size = 2
    totalLocal = 5
    totalRemote = 3
    total = totalLocal + totalRemote
    remoteDomain = Domain "faraway.example.com"
    createRemoteConnection :: UserId -> UTCTimeMillis -> Http ()
    createRemoteConnection self now = do
      qOther <- (`Qualified` remoteDomain) <$> randomId
      qConv <- (`Qualified` remoteDomain) <$> randomId
      liftIO . DB.runClient db $
        DB.retry DB.x5 $
          DB.write remoteConnectionInsert $
            DB.params
              DB.LocalQuorum
              (self, remoteDomain, qUnqualified qOther, SentWithHistory, now, qDomain qConv, qUnqualified qConv)

testConnectionLimit :: Brig -> ConnectionLimit -> Http ()
testConnectionLimit brig (ConnectionLimit l) = do
  uid1 <- User.userId <$> randomUser brig
  (uid2 : _) <- replicateM (fromIntegral l) (newConn uid1)
  uidX <- User.userId <$> randomUser brig
  postConnection brig uid1 uidX !!! assertLimited
  -- blocked connections do not count towards the limit
  putConnection brig uid1 uid2 Blocked !!! const 200 === statusCode
  postConnection brig uid1 uidX !!! const 201 === statusCode
  -- the next send/accept hits the limit again
  uidY <- User.userId <$> randomUser brig
  postConnection brig uid1 uidY !!! assertLimited
  -- (re-)sending an already accepted connection does not affect the limit
  postConnection brig uid1 uidX !!! const 200 === statusCode
  where
    newConn from = do
      to <- User.userId <$> randomUser brig
      postConnection brig from to !!! const 201 === statusCode
      pure to
    assertLimited = do
      const 403 === statusCode
      const (Just "connection-limit") === fmap Error.label . responseJsonMaybe

testConnectionLimitQualified :: Brig -> ConnectionLimit -> Http ()
testConnectionLimitQualified brig (ConnectionLimit l) = do
  quid1 <- userQualifiedId <$> randomUser brig
  let uid1 = qUnqualified quid1
  (quid2 : _) <- replicateM (fromIntegral l) (newConn uid1)
  quidX <- userQualifiedId <$> randomUser brig
  postConnectionQualified brig uid1 quidX !!! assertLimited
  -- blocked connections do not count towards the limit
  putConnectionQualified brig uid1 quid2 Blocked !!! const 200 === statusCode
  postConnectionQualified brig uid1 quidX !!! const 201 === statusCode
  -- the next send/accept hits the limit again
  quidY <- userQualifiedId <$> randomUser brig
  postConnectionQualified brig uid1 quidY !!! assertLimited
  -- (re-)sending an already accepted connection does not affect the limit
  postConnectionQualified brig uid1 quidX !!! const 200 === statusCode
  where
    newConn :: UserId -> Http (Qualified UserId)
    newConn from = do
      to <- userQualifiedId <$> randomUser brig
      postConnectionQualified brig from to !!! const 201 === statusCode
      pure to
    assertLimited = do
      const 403 === statusCode
      const (Just "connection-limit") === fmap Error.label . responseJsonMaybe

testConnectFederationNotAvailable :: Brig -> Http ()
testConnectFederationNotAvailable brig = do
  (uid1, quid2) <- localAndRemoteUser brig
  postConnectionQualified brig uid1 quid2
    !!! const 422 === statusCode

testConnectOK :: Brig -> Galley -> FedClient 'Brig -> Http ()
testConnectOK brig galley fedBrigClient = do
  let convIsLocal = True
  (uid1, quid2, convId) <- localAndRemoteUserWithConvId brig convIsLocal
  receiveConnectionAction brig fedBrigClient uid1 quid2 RemoteConnect Nothing Pending

  -- The conversation exists uid1 is not a participant however
  getConversationQualified galley uid1 convId
    !!! statusCode === const 403

testConnectWithAnon :: Brig -> FedClient 'Brig -> Http ()
testConnectWithAnon brig fedBrigClient = do
  fromUser <- randomId
  toUser <- User.userId <$> createAnonUser "anon1234" brig
  res <-
    runFedClient @"send-connection-action" fedBrigClient (Domain "far-away.example.com") $
      NewConnectionRequest fromUser Nothing toUser RemoteConnect
  liftIO $
    assertEqual "The response should specify that the user is not activated" NewConnectionResponseUserNotActivated res

testConnectFromAnon :: Brig -> Http ()
testConnectFromAnon brig = do
  anonUser <- User.userId <$> createAnonUser "anon1234" brig
  remoteUser <- fakeRemoteUser
  postConnectionQualified brig anonUser remoteUser !!! const 403 === statusCode

testConnectFromPending :: Brig -> FedClient 'Brig -> Http ()
testConnectFromPending brig fedBrigClient = do
  (uid1, quid2) <- localAndRemoteUser brig
  receiveConnectionAction brig fedBrigClient uid1 quid2 RemoteConnect Nothing Pending
  receiveConnectionAction brig fedBrigClient uid1 quid2 RemoteConnect Nothing Pending
  receiveConnectionAction brig fedBrigClient uid1 quid2 RemoteRescind Nothing Cancelled
