-- 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/>.
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
-- Disabling to stop warnings on HasCallStack
{-# OPTIONS_GHC -Wno-redundant-constraints #-}

-- 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 API.Util where

import API.SQS qualified as SQS
import Bilge hiding (timeout)
import Bilge.Assert
import Bilge.TestSession
import Control.Applicative
import Control.Concurrent.Async
import Control.Lens hiding (from, to, uncons, (#), (.=))
import Control.Monad.Catch (MonadCatch, MonadMask)
import Control.Monad.Codensity (lowerCodensity)
import Control.Retry (constantDelay, exponentialBackoff, limitRetries, recoverAll, retrying)
import Data.Aeson
import Data.Aeson qualified as A
import Data.Aeson.Lens (key, _String)
import Data.ByteString qualified as BS
import Data.ByteString.Char8 qualified as B8
import Data.ByteString.Char8 qualified as C
import Data.ByteString.Conversion
import Data.ByteString.Lazy qualified as Lazy
import Data.Code qualified as Code
import Data.Currency qualified as Currency
import Data.Default
import Data.Domain
import Data.HashMap.Strict qualified as HashMap
import Data.Id
import Data.Json.Util hiding ((#))
import Data.LegalHold (defUserLegalHoldStatus)
import Data.List.NonEmpty (NonEmpty ((:|)))
import Data.List.NonEmpty qualified as NonEmpty
import Data.Map qualified as LMap
import Data.Map.Strict qualified as Map
import Data.Misc
import Data.ProtoLens qualified as Protolens
import Data.ProtocolBuffers (encodeMessage)
import Data.Qualified
import Data.Range
import Data.Serialize (runPut)
import Data.Set qualified as Set
import Data.String.Conversions
import Data.Text qualified as Text
import Data.Text.Encoding qualified as T
import Data.Text.Encoding qualified as Text
import Data.Time (getCurrentTime)
import Data.Tuple.Extra
import Data.UUID qualified as UUID
import Data.UUID.V4
import Federator.MockServer hiding (body)
import Federator.MockServer qualified as Mock
import GHC.TypeNats
import Galley.Run qualified as Run
import Galley.Types.Conversations.One2One
import Imports
import Network.HTTP.Client qualified as HTTP
import Network.URI (pathSegments)
import Network.Wai.Utilities.MockServer (withMockServer)
import Servant
import System.Exit
import System.Process
import System.Random
import Test.Tasty.Cannon (TimeoutUnit (..), (#))
import Test.Tasty.Cannon qualified as WS
import Test.Tasty.HUnit
import TestHelpers (viewFederationDomain)
import TestSetup
import UnliftIO.Timeout
import Util.Options
import Web.Cookie
import Wire.API.Connection
import Wire.API.Conversation
import Wire.API.Conversation qualified as Conv
import Wire.API.Conversation.Code hiding (Value)
import Wire.API.Conversation.Protocol
import Wire.API.Conversation.Role
import Wire.API.Conversation.Typing
import Wire.API.Event.Conversation
import Wire.API.Event.Conversation qualified as Conv
import Wire.API.Event.LeaveReason
import Wire.API.Event.Team
import Wire.API.Event.Team qualified as TE
import Wire.API.Federation.API
import Wire.API.Federation.API.Brig
import Wire.API.Federation.API.Common
import Wire.API.Federation.API.Galley
import Wire.API.History
import Wire.API.Internal.Notification hiding (target)
import Wire.API.MLS.LeafNode
import Wire.API.MLS.Message
import Wire.API.MLS.Proposal
import Wire.API.MLS.Serialisation
import Wire.API.MLS.SubConversation
import Wire.API.Message
import Wire.API.Message.Proto qualified as Proto
import Wire.API.Routes.Internal.Brig.Connection
import Wire.API.Routes.Internal.Galley.ConversationsIntra
import Wire.API.Routes.Internal.Galley.TeamsIntra
import Wire.API.Routes.MultiTablePaging
import Wire.API.Routes.Version
import Wire.API.Team
import Wire.API.Team.Invitation
import Wire.API.Team.Member hiding (userId)
import Wire.API.Team.Member qualified as Team
import Wire.API.Team.Permission hiding (self)
import Wire.API.Team.Role
import Wire.API.User as User hiding (AccountStatus (..))
import Wire.API.User.Auth hiding (Access)
import Wire.API.User.Client
import Wire.API.User.Client qualified as Client
import Wire.API.User.Client.Prekey
import Wire.Options.Galley qualified as Opts
import Wire.UserList

-------------------------------------------------------------------------------
-- API Operations

addPrefix :: Request -> Request
addPrefix = maybeAddPrefixAtVersion maxBound

maybeAddPrefixAtVersion :: Version -> Request -> Request
maybeAddPrefixAtVersion vers r = case pathSegments $ getUri r of
  ("i" : _) -> r
  ("api-internal" : _) -> r
  _ -> addPrefixAtVersion vers r

addPrefixAtVersion :: Version -> Request -> Request
addPrefixAtVersion v r = r {HTTP.path = toHeader v <> "/" <> removeSlash (HTTP.path r)}
  where
    removeSlash s = case B8.uncons s of
      Just ('/', s') -> s'
      _ -> s

-- | A class for monads with access to a Sem r instance
class HasGalley m where
  viewGalley :: m GalleyR
  viewGalleyOpts :: m Opts.Opts

instance HasGalley TestM where
  viewGalley = fmap (addPrefix .) (view tsUnversionedGalley)
  viewGalleyOpts = view tsGConf

instance (HasGalley m, Monad m) => HasGalley (SessionT m) where
  viewGalley = lift viewGalley
  viewGalleyOpts = lift viewGalleyOpts

class HasBrig m where
  viewBrig :: m BrigR

instance HasBrig TestM where
  viewBrig = fmap (addPrefix .) (view tsUnversionedBrig)

symmPermissions :: [Perm] -> Permissions
symmPermissions p = let s = Set.fromList p in fromJust (newPermissions s s)

createBindingTeam :: (HasCallStack) => TestM (UserId, TeamId)
createBindingTeam = do
  first User.userId <$> createBindingTeam'

createBindingTeam' :: (HasCallStack) => TestM (User, TeamId)
createBindingTeam' = do
  owner <- randomTeamCreator
  teams <- getTeams (User.userId owner) []
  team <- assertOne $ view teamListTeams teams
  let tid = view teamId team
  SQS.assertTeamActivate "create team" tid
  refreshIndex
  pure (owner, tid)

createBindingTeamWithMembers :: (HasCallStack) => Int -> TestM (TeamId, UserId, [UserId])
createBindingTeamWithMembers numUsers = do
  (owner, tid) <- createBindingTeam
  members <- forM [2 .. numUsers] $ \n -> do
    mem <- addUserToTeam owner tid
    SQS.assertTeamUpdate "add member" tid (fromIntegral n) [owner]
    -- 'refreshIndex' needs to happen here to make tests more realistic.  one effect of
    -- refreshing the index once at the end would be that the hard member limit wouldn't hold
    -- any more.
    refreshIndex
    pure $ view Team.userId mem

  pure (tid, owner, members)

createBindingTeamWithQualifiedMembers :: (HasCallStack) => Int -> TestM (TeamId, Qualified UserId, [Qualified UserId])
createBindingTeamWithQualifiedMembers num = do
  localDomain <- viewFederationDomain
  (tid, owner, users) <- createBindingTeamWithMembers num
  pure (tid, Qualified owner localDomain, map (`Qualified` localDomain) users)

getTeams :: UserId -> [(ByteString, Maybe ByteString)] -> TestM TeamList
getTeams u queryItems = do
  -- This endpoint is removed from version v4 onwards
  g <- fmap (addPrefixAtVersion V3 .) (view tsUnversionedGalley)
  r <-
    get
      ( g
          . paths ["teams"]
          . query queryItems
          . zUser u
          . zConn "conn"
          . zType "access"
          . expect2xx
      )
  pure $ responseJsonUnsafe r

createBindingTeamWithNMembers :: Int -> TestM (UserId, TeamId, [UserId])
createBindingTeamWithNMembers = createBindingTeamWithNMembersWithHandles False

createBindingTeamWithNMembersWithHandles :: Bool -> Int -> TestM (UserId, TeamId, [UserId])
createBindingTeamWithNMembersWithHandles withHandles n = do
  (owner, tid) <- createBindingTeam
  setHandle owner
  mems <- replicateM n $ do
    member1 <- (^. Team.userId) <$> addUserToTeamWithRole (Just RoleMember) owner tid
    setHandle member1
    pure member1
  pure (owner, tid, mems)
  where
    mkRandomHandle :: (MonadIO m) => m Text
    mkRandomHandle = liftIO $ do
      nrs <- replicateM 21 (randomRIO (97, 122)) -- a-z
      pure (cs (map chr nrs))

    setHandle :: UserId -> TestM ()
    setHandle uid = when withHandles $ do
      b <- viewBrig
      randomHandle <- mkRandomHandle
      put
        ( b
            . paths ["/i/users", toByteString' uid, "handle"]
            . json (HandleUpdate randomHandle)
        )
        !!! do
          const 200 === statusCode

changeTeamStatus :: (HasCallStack) => TeamId -> TeamStatus -> TestM ()
changeTeamStatus tid s = do
  g <- viewGalley
  put
    ( g
        . paths ["i", "teams", toByteString' tid, "status"]
        . json (TeamStatusUpdate s Nothing)
    )
    !!! const 200
      === statusCode

createBindingTeamInternal :: (HasCallStack) => Text -> UserId -> TestM TeamId
createBindingTeamInternal name owner = do
  tid <- createBindingTeamInternalNoActivate name owner
  changeTeamStatus tid Active
  pure tid

createBindingTeamInternalNoActivate :: (HasCallStack) => Text -> UserId -> TestM TeamId
createBindingTeamInternalNoActivate name owner = do
  g <- viewGalley
  tid <- randomId
  let nt = newNewTeam (unsafeRange name) DefaultIcon
  _ <-
    put (g . paths ["/i/teams", toByteString' tid] . zUser owner . zConn "conn" . zType "access" . json nt) <!! do
      const 201 === statusCode
      const True === isJust . getHeader "Location"
  pure tid

createBindingTeamInternalWithCurrency :: (HasCallStack) => Text -> UserId -> Currency.Alpha -> TestM TeamId
createBindingTeamInternalWithCurrency name owner cur = do
  g <- viewGalley
  tid <- createBindingTeamInternalNoActivate name owner
  _ <-
    put (g . paths ["i", "teams", toByteString' tid, "status"] . json (TeamStatusUpdate Active $ Just cur))
      !!! const 200
        === statusCode
  pure tid

getTeam :: (HasCallStack) => UserId -> TeamId -> TestM Team
getTeam usr tid = do
  g <- viewGalley
  r <- get (g . paths ["teams", toByteString' tid] . zUser usr) <!! const 200 === statusCode
  responseJsonError r

getTeamMembers :: (HasCallStack) => UserId -> TeamId -> TestM TeamMemberList
getTeamMembers usr tid = do
  g <- viewGalley
  r <- get (g . paths ["teams", toByteString' tid, "members"] . zUser usr) <!! const 200 === statusCode
  responseJsonError r

getTeamMembersTruncated :: (HasCallStack) => UserId -> TeamId -> Int -> TestM TeamMemberList
getTeamMembersTruncated usr tid n = do
  g <- viewGalley
  r <- get (g . paths ["teams", toByteString' tid, "members"] . zUser usr . queryItem "maxResults" (C.pack $ show n)) <!! const 200 === statusCode
  responseJsonError r

data ResultPage = ResultPage
  { rpResults :: [A.Value],
    rpHasMore :: Bool,
    rpPagingState :: Text
  }

instance FromJSON ResultPage where
  parseJSON = withObject "ResultPage" $ \o ->
    ResultPage
      <$> o
        .: "members"
      <*> o
        .: "hasMore"
      <*> o
        .: "pagingState"

getTeamMembersPaginated :: (HasCallStack) => UserId -> TeamId -> Int -> Maybe Text -> TestM ResultPage
getTeamMembersPaginated usr tid n mPs = do
  g <- viewGalley
  r <-
    get
      ( g
          . paths ["teams", toByteString' tid, "members"]
          . zUser usr
          . queryItem "maxResults" (C.pack $ show n)
          . maybe Imports.id (queryItem "pagingState" . cs) mPs
      )
      <!! const 200
        === statusCode
  responseJsonError r

getTeamMembersInternalTruncated :: (HasCallStack) => TeamId -> Int -> TestM TeamMemberList
getTeamMembersInternalTruncated tid n = do
  g <- viewGalley
  r <-
    get
      ( g
          . paths ["i", "teams", toByteString' tid, "members"]
          . queryItem "maxResults" (C.pack $ show n)
      )
      <!! const 200
        === statusCode
  responseJsonError r

bulkGetTeamMembers :: (HasCallStack) => UserId -> TeamId -> [UserId] -> TestM TeamMemberList
bulkGetTeamMembers usr tid uids = do
  g <- viewGalley
  r <-
    post
      ( g
          . paths ["teams", toByteString' tid, "get-members-by-ids-using-post"]
          . zUser usr
          . json (UserIdList uids)
      )
      <!! const 200
        === statusCode
  responseJsonError r

bulkGetTeamMembersTruncated :: (HasCallStack) => UserId -> TeamId -> [UserId] -> Int -> TestM ResponseLBS
bulkGetTeamMembersTruncated usr tid uids trnc = do
  g <- viewGalley
  post
    ( g
        . paths ["teams", toByteString' tid, "get-members-by-ids-using-post"]
        . zUser usr
        . queryItem "maxResults" (C.pack $ show trnc)
        . json (UserIdList uids)
    )

getTeamMember :: (HasCallStack) => UserId -> TeamId -> UserId -> TestM TeamMember
getTeamMember getter tid gettee = do
  g <- viewGalley
  getTeamMember' g getter tid gettee

getTeamMember' :: (HasCallStack, MonadHttp m, MonadIO m, MonadCatch m) => GalleyR -> UserId -> TeamId -> UserId -> m TeamMember
getTeamMember' g getter tid gettee = do
  r <- get (g . paths ["teams", toByteString' tid, "members", toByteString' gettee] . zUser getter) <!! const 200 === statusCode
  responseJsonError r

getTeamMemberInternal :: (HasCallStack) => TeamId -> UserId -> TestM TeamMember
getTeamMemberInternal tid mid = do
  g <- viewGalley
  r <- get (g . paths ["i", "teams", toByteString' tid, "members", toByteString' mid]) <!! const 200 === statusCode
  responseJsonError r

addUserToTeam :: (HasCallStack) => UserId -> TeamId -> TestM TeamMember
addUserToTeam = addUserToTeamWithRole Nothing

addUserToTeam' :: (HasCallStack) => UserId -> TeamId -> TestM ResponseLBS
addUserToTeam' u t = snd <$> addUserToTeamWithRole' Nothing u t

addUserToTeamWithRole :: (HasCallStack) => Maybe Role -> UserId -> TeamId -> TestM TeamMember
addUserToTeamWithRole role inviter tid = do
  (inv, rsp2) <- addUserToTeamWithRole' role inviter tid
  let invitee :: User = responseJsonUnsafe rsp2
      inviteeId = User.userId invitee
  let invmeta = Just (inviter, inv.createdAt)
  mem <- getTeamMember inviter tid inviteeId
  liftIO $ assertEqual "Member has no/wrong invitation metadata" invmeta (mem ^. Team.invitation)
  let zuid = parseSetCookie <$> getHeader "Set-Cookie" rsp2
  liftIO $ assertEqual "Wrong cookie" (Just "zuid") (setCookieName <$> zuid)
  pure mem

addUserToTeamWithRole' :: (HasCallStack) => Maybe Role -> UserId -> TeamId -> TestM (Invitation, ResponseLBS)
addUserToTeamWithRole' role inviter tid = do
  brig <- viewBrig
  inviteeEmail <- randomEmail
  let invite = InvitationRequest Nothing role Nothing inviteeEmail True
  invResponse <- postInvitation tid inviter invite
  inv <- responseJsonError invResponse
  inviteeCode <- recoverAll (exponentialBackoff 1000 <> limitRetries 11) $
    \_ -> getInvitationCode tid inv.invitationId
  r <-
    post
      ( brig
          . path "/register"
          . contentJson
          . header "X-Forwarded-For" "127.0.0.42"
          . body (acceptInviteBody inviteeEmail inviteeCode)
      )
  pure (inv, r)

addUserToTeamWithSSO :: (HasCallStack) => Bool -> TeamId -> TestM TeamMember
addUserToTeamWithSSO hasEmail tid = do
  let ssoid = UserSSOId mkSimpleSampleUref
  uid <- fmap (\(u :: User) -> User.userId u) $ responseJsonError =<< postSSOUser "SSO User" hasEmail ssoid tid
  getTeamMember uid tid uid

makeOwner :: (HasCallStack) => UserId -> TeamMember -> TeamId -> TestM ()
makeOwner owner mem tid = updateTeamMemberPermissions owner mem tid fullPermissions

-- | Update an existing team member's permissions via the public
-- @PUT /teams/:tid/members@ endpoint. Use this together with
-- 'addUserToTeamWithRole' when a test needs a member with custom
-- 'Permissions' that do not correspond to a 'Role' (the invitation flow
-- only accepts a 'Role').
updateTeamMemberPermissions ::
  (HasCallStack) =>
  UserId ->
  TeamMember ->
  TeamId ->
  Permissions ->
  TestM ()
updateTeamMemberPermissions owner mem tid perms = do
  galley <- viewGalley
  let changeMember = mkNewTeamMember (mem ^. Team.userId) perms (mem ^. Team.invitation)
  put
    ( galley
        . paths ["teams", toByteString' tid, "members"]
        . zUser owner
        . zConn "conn"
        . json changeMember
    )
    !!! const 200
      === statusCode

acceptInviteBody :: EmailAddress -> InvitationCode -> RequestBody
acceptInviteBody email code =
  RequestBodyLBS . encode $
    object
      [ "name" .= Name "bob",
        "email" .= fromEmail email,
        "password" .= defPassword,
        "team_code" .= code
      ]

postInvitation :: TeamId -> UserId -> InvitationRequest -> TestM ResponseLBS
postInvitation t u i = do
  brig <- viewBrig
  post $
    brig
      . paths ["teams", toByteString' t, "invitations"]
      . contentJson
      . body (RequestBodyLBS $ encode i)
      . zAuthAccess u "conn"

zAuthAccess :: UserId -> ByteString -> (Request -> Request)
zAuthAccess u conn =
  zUser u
    . zConn conn
    . zType "access"

getInvitationCode :: (HasCallStack) => TeamId -> InvitationId -> TestM InvitationCode
getInvitationCode t ref = do
  brig <- viewBrig

  let getm :: TestM (Maybe InvitationCode)
      getm = do
        r <-
          get
            ( brig
                . path "/i/teams/invitation-code"
                . queryItem "team" (toByteString' t)
                . queryItem "invitation_id" (toByteString' ref)
            )
        let lbs = fromMaybe "" $ responseBody r
        pure $ fromByteString . Text.encodeUtf8 =<< lbs ^? key "code" . _String

  fromMaybe (error "No code?")
    <$> retrying
      (constantDelay 800000 <> limitRetries 3)
      (\_ -> pure . isNothing)
      (const getm)

-- Note that here we don't make use of the datatype because NewConv has a default
-- and therefore cannot be unset. However, given that this is to test the legacy
-- API (i.e., no roles) it's fine to hardcode the JSON object in the test since
-- it clearly shows the API that old(er) clients use.
createTeamConvLegacy :: (HasCallStack) => UserId -> TeamId -> [UserId] -> Maybe Text -> TestM ConvId
createTeamConvLegacy u tid us name = do
  g <- viewGalley
  let tinfo = ConvTeamInfo tid
  let convPayload =
        object
          [ "users" .= us,
            "name" .= name,
            "team" .= Just tinfo
          ]
  post
    ( g
        . path "/conversations"
        . zUser u
        . zConn "conn"
        . zType "access"
        . json convPayload
    )
    >>= \r -> fromBS (getHeader' "Location" r)

createTeamConv ::
  (HasCallStack) =>
  UserId ->
  TeamId ->
  [UserId] ->
  Maybe Text ->
  Maybe (Set Access) ->
  Maybe Milliseconds ->
  TestM ConvId
createTeamConv u tid us name acc mtimer = createTeamConvAccess u tid us name acc Nothing mtimer (Just roleNameWireAdmin)

createTeamConvWithRole ::
  (HasCallStack) =>
  UserId ->
  TeamId ->
  [UserId] ->
  Maybe Text ->
  Maybe (Set Access) ->
  Maybe Milliseconds ->
  RoleName ->
  TestM ConvId
createTeamConvWithRole u tid us name acc mtimer convRole = createTeamConvAccess u tid us name acc Nothing mtimer (Just convRole)

createTeamConvAccess ::
  (HasCallStack) =>
  UserId ->
  TeamId ->
  [UserId] ->
  Maybe Text ->
  Maybe (Set Access) ->
  Maybe (Set AccessRole) ->
  Maybe Milliseconds ->
  Maybe RoleName ->
  TestM ConvId
createTeamConvAccess u tid us name acc role mtimer convRole = do
  r <- createTeamConvAccessRaw u tid us name acc role mtimer convRole <!! const 201 === statusCode
  fromBS (getHeader' "Location" r)

createTeamConvAccessRaw ::
  UserId ->
  TeamId ->
  [UserId] ->
  Maybe Text ->
  Maybe (Set Access) ->
  Maybe (Set AccessRole) ->
  Maybe Milliseconds ->
  Maybe RoleName ->
  TestM ResponseLBS
createTeamConvAccessRaw u tid us name acc role mtimer convRole = do
  g <- viewGalley
  let tinfo = ConvTeamInfo tid
  let conv =
        NewConv
          us
          []
          (name >>= checked)
          (fromMaybe (Set.fromList []) acc)
          role
          (Just tinfo)
          mtimer
          Nothing
          (fromMaybe roleNameWireAdmin convRole)
          BaseProtocolProteusTag
          GroupConversation
          False
          Nothing
          False
          Nothing
          def
  post
    ( g
        . path "/conversations"
        . zUser u
        . zConn "conn"
        . zType "access"
        . json conv
    )

-- | Create a team MLS conversation
createMLSTeamConv ::
  (HasGalley m, MonadIO m, MonadHttp m, HasCallStack) =>
  Local UserId ->
  ClientId ->
  TeamId ->
  UserList UserId ->
  Maybe Text ->
  Maybe (Set Access) ->
  Maybe (Set AccessRole) ->
  Maybe Milliseconds ->
  Maybe RoleName ->
  m (Local ConvId)
createMLSTeamConv lusr c tid users name access role timer convRole = do
  g <- viewGalley
  let conv =
        NewConv
          { newConvUsers = [],
            newConvQualifiedUsers = ulAll lusr users,
            newConvName = name >>= checked,
            newConvAccess = fromMaybe Set.empty access,
            newConvAccessRoles = role,
            newConvTeam = Just . ConvTeamInfo $ tid,
            newConvMessageTimer = timer,
            newConvUsersRole = fromMaybe roleNameWireAdmin convRole,
            newConvReceiptMode = Nothing,
            newConvProtocol = BaseProtocolMLSTag,
            newConvGroupConvType = GroupConversation,
            newConvCells = False,
            newConvChannelAddPermission = Nothing,
            newConvSkipCreator = False,
            newConvParent = Nothing,
            newConvHistory = HistoryPrivate
          }
  r <-
    post
      ( g
          . path "/conversations"
          . zUser (tUnqualified lusr)
          . zClient c
          . zConn "conn"
          . zType "access"
          . json conv
      )
  convId <- fromBS (getHeader' "Location" r)
  pure $ qualifyAs lusr convId

updateTeamConv :: UserId -> ConvId -> ConversationRename -> TestM ResponseLBS
updateTeamConv zusr convid upd = do
  g <- view tsUnversionedGalley
  put
    ( g
        . paths ["v7", "conversations", toByteString' convid]
        . zUser zusr
        . zConn "conn"
        . zType "access"
        . json upd
    )

postConv ::
  UserId ->
  [UserId] ->
  Maybe Text ->
  [Access] ->
  Maybe (Set AccessRole) ->
  Maybe Milliseconds ->
  TestM ResponseLBS
postConv u us name a r mtimer = postConvWithRole u us name a r mtimer roleNameWireAdmin

defNewProteusConv :: NewConv
defNewProteusConv =
  NewConv
    []
    []
    Nothing
    mempty
    Nothing
    Nothing
    Nothing
    Nothing
    roleNameWireAdmin
    BaseProtocolProteusTag
    GroupConversation
    False
    Nothing
    False
    Nothing
    def

defNewMLSConv :: NewConv
defNewMLSConv =
  defNewProteusConv
    { newConvProtocol = BaseProtocolMLSTag
    }

postConvQualified ::
  UserId ->
  Maybe ClientId ->
  NewConv ->
  TestM ResponseLBS
postConvQualified u c n = do
  g <- viewGalley
  post $
    g
      . path "/conversations"
      . zUser u
      . maybe Imports.id zClient c
      . zConn "conn"
      . zType "access"
      . json n

postConvWithRemoteUsers ::
  (HasCallStack) =>
  UserId ->
  Maybe ClientId ->
  NewConv ->
  TestM (Response (Maybe LByteString))
postConvWithRemoteUsers u c n =
  fmap fst $
    withTempMockFederator' (("get-not-fully-connected-backends" ~> NonConnectedBackends mempty) <|> mockReply EmptyResponse) $
      postConvQualified u c n {newConvName = setName (newConvName n)}
        <!! const 201
          === statusCode
  where
    setName :: (KnownNat n, KnownNat m, Within Text n m) => Maybe (Range n m Text) -> Maybe (Range n m Text)
    setName Nothing = checked "federated gossip"
    setName x = x

postTeamConv :: TeamId -> UserId -> [UserId] -> Maybe Text -> [Access] -> Maybe (Set AccessRole) -> Maybe Milliseconds -> TestM ResponseLBS
postTeamConv tid u us name a r mtimer = do
  g <- viewGalley
  let conv =
        NewConv
          us
          []
          (name >>= checked)
          (Set.fromList a)
          r
          (Just (ConvTeamInfo tid))
          mtimer
          Nothing
          roleNameWireAdmin
          BaseProtocolProteusTag
          GroupConversation
          False
          Nothing
          False
          Nothing
          def
  post $ g . path "/conversations" . zUser u . zConn "conn" . zType "access" . json conv

deleteTeamConv :: (HasGalley m, MonadIO m, MonadHttp m) => TeamId -> ConvId -> UserId -> m ResponseLBS
deleteTeamConv tid convId zusr = do
  g <- viewGalley
  delete
    ( g
        . paths ["teams", toByteString' tid, "conversations", toByteString' convId]
        . zUser zusr
        . zConn "conn"
    )

postConvWithRole ::
  UserId ->
  [UserId] ->
  Maybe Text ->
  [Access] ->
  Maybe (Set AccessRole) ->
  Maybe Milliseconds ->
  RoleName ->
  TestM ResponseLBS
postConvWithRole u members name access arole timer role =
  postConvQualified
    u
    Nothing
    defNewProteusConv
      { newConvUsers = members,
        newConvName = name >>= checked,
        newConvAccess = Set.fromList access,
        newConvAccessRoles = arole,
        newConvMessageTimer = timer,
        newConvUsersRole = role
      }

postConvWithReceipt :: UserId -> [UserId] -> Maybe Text -> [Access] -> Maybe (Set AccessRole) -> Maybe Milliseconds -> ReceiptMode -> TestM ResponseLBS
postConvWithReceipt u us name a r mtimer rcpt = do
  g <- viewGalley
  let conv =
        NewConv
          us
          []
          (name >>= checked)
          (Set.fromList a)
          r
          Nothing
          mtimer
          (Just rcpt)
          roleNameWireAdmin
          BaseProtocolProteusTag
          GroupConversation
          False
          Nothing
          False
          Nothing
          def
  post $ g . path "/conversations" . zUser u . zConn "conn" . zType "access" . json conv

postSelfConv :: UserId -> TestM ResponseLBS
postSelfConv u = do
  g <- viewGalley
  post $ g . path "/conversations/self" . zUser u . zConn "conn" . zType "access"

postO2OConv :: UserId -> UserId -> Maybe Text -> TestM ResponseLBS
postO2OConv u1 u2 n = do
  g <- viewGalley
  let conv = NewOne2OneConv [u2] [] (n >>= checked) Nothing
  post $ g . path "/one2one-conversations" . zUser u1 . zConn "conn" . zType "access" . json conv

postConnectConv :: UserId -> UserId -> Text -> Text -> Maybe Text -> TestM ResponseLBS
postConnectConv a b name msg email = do
  qb <- Qualified b <$> viewFederationDomain
  g <- viewGalley
  post $
    g
      . path "/i/conversations/connect"
      . zUser a
      . zConn "conn"
      . zType "access"
      . json (Connect qb (Just msg) (Just name) email)

putConvAccept :: UserId -> ConvId -> TestM ResponseLBS
putConvAccept invited cid = do
  g <- viewGalley
  put $
    g
      . paths ["/i/conversations", C.pack $ show cid, "accept", "v2"]
      . zUser invited
      . zType "access"
      . zConn "conn"

postOtrMessage ::
  (Request -> Request) ->
  UserId ->
  ClientId ->
  ConvId ->
  [(UserId, ClientId, Text)] ->
  TestM ResponseLBS
postOtrMessage = postOtrMessage' Nothing

postOtrMessage' ::
  Maybe [UserId] ->
  (Request -> Request) ->
  UserId ->
  ClientId ->
  ConvId ->
  [(UserId, ClientId, Text)] ->
  TestM ResponseLBS
postOtrMessage' reportMissing f u d c rec = do
  g <- viewGalley
  post $
    g
      . f
      . paths ["conversations", toByteString' c, "otr", "messages"]
      . zUser u
      . zConn "conn"
      . zType "access"
      . json (mkOtrPayload d rec reportMissing "ZXhhbXBsZQ==")

postProteusMessageQualifiedWithMockFederator ::
  UserId ->
  ClientId ->
  Qualified ConvId ->
  [(Qualified UserId, ClientId, ByteString)] ->
  ByteString ->
  ClientMismatchStrategy ->
  Mock LByteString ->
  TestM (ResponseLBS, [FederatedRequest])
postProteusMessageQualifiedWithMockFederator senderUser senderClient convId recipients dat strat mock =
  withTempMockFederator' mock $
    postProteusMessageQualified senderUser senderClient convId recipients dat strat

postProteusMessageQualified ::
  (MonadIO m, HasGalley m, MonadHttp m) =>
  UserId ->
  ClientId ->
  Qualified ConvId ->
  [(Qualified UserId, ClientId, ByteString)] ->
  ByteString ->
  ClientMismatchStrategy ->
  m ResponseLBS
postProteusMessageQualified senderUser senderClient (Qualified conv domain) recipients dat strat = do
  g <- viewGalley
  let protoMsg = mkQualifiedOtrPayload senderClient recipients dat strat
  post $
    g
      . paths ["conversations", toByteString' domain, toByteString' conv, "proteus", "messages"]
      . zUser senderUser
      . zConn "conn"
      . zType "access"
      . contentProtobuf
      . bytes (Protolens.encodeMessage protoMsg)

data BroadcastAPI
  = BroadcastLegacyQueryParams
  | BroadcastLegacyBody
  | BroadcastQualified

broadcastAPIName :: BroadcastAPI -> String
broadcastAPIName BroadcastLegacyQueryParams = "legacy API with query parameters only"
broadcastAPIName BroadcastLegacyBody = "legacy API with report_missing in the body"
broadcastAPIName BroadcastQualified = "qualified API"

data BroadcastType = BroadcastJSON | BroadcastProto

broadcastTypeName :: BroadcastType -> String
broadcastTypeName BroadcastJSON = "json"
broadcastTypeName BroadcastProto = "protobuf"

data Broadcast = Broadcast
  { bAPI :: BroadcastAPI,
    bType :: BroadcastType,
    bMessage :: [(UserId, ClientId, Text)],
    bData :: Text,
    bReport :: Maybe [UserId],
    bReq :: Request -> Request
  }

instance Default Broadcast where
  def = Broadcast BroadcastLegacyQueryParams BroadcastJSON mempty "ZXhhbXBsZQ==" mempty Imports.id

postBroadcast ::
  (MonadIO m, MonadHttp m, HasGalley m) =>
  Qualified UserId ->
  ClientId ->
  Broadcast ->
  m ResponseLBS
postBroadcast lu c b = do
  let u = qUnqualified lu
  g <- viewGalley
  let (bodyReport, queryReport) = case bAPI b of
        BroadcastLegacyQueryParams -> (Nothing, maybe Imports.id mkOtrReportMissing (bReport b))
        _ -> (bReport b, Imports.id)
  let bdy = case (bAPI b, bType b) of
        (BroadcastQualified, BroadcastJSON) -> error "JSON not supported for the qualified broadcast API"
        (BroadcastQualified, BroadcastProto) ->
          let m =
                Protolens.encodeMessage $
                  mkQualifiedOtrPayload
                    c
                    (map ((_1 %~ (lu $>)) . (_3 %~ fromBase64TextLenient)) (bMessage b))
                    (fromBase64TextLenient (bData b))
                    ( maybe
                        MismatchReportAll
                        (MismatchReportOnly . Set.fromList . map (lu $>))
                        (bReport b)
                    )
           in contentProtobuf . bytes m
        (_, BroadcastJSON) -> json (mkOtrPayload c (bMessage b) bodyReport (bData b))
        (_, BroadcastProto) ->
          let m =
                runPut . encodeMessage $
                  mkOtrProtoMessage c (otrRecipients (bMessage b)) bodyReport (bData b)
           in contentProtobuf . bytes m
  let name = case bAPI b of BroadcastQualified -> "proteus"; _ -> "otr"
  post $
    g
      . bReq b
      . paths ["broadcast", name, "messages"]
      . zUser u
      . zConn "conn"
      . zType "access"
      . queryReport
      . bdy

mkOtrReportMissing :: [UserId] -> Request -> Request
mkOtrReportMissing = queryItem "report_missing" . BS.intercalate "," . map toByteString'

mkOtrPayload :: ClientId -> [(UserId, ClientId, Text)] -> Maybe [UserId] -> Text -> Value
mkOtrPayload sender rec reportMissingBody ad =
  object
    [ "sender" .= sender,
      "recipients" .= (HashMap.map toJSON . HashMap.fromListWith HashMap.union $ map mkOtrMessage rec),
      "data" .= Just ad,
      "report_missing" .= reportMissingBody
    ]

mkOtrMessage :: (UserId, ClientId, Text) -> (Text, HashMap.HashMap Text Text)
mkOtrMessage (usr, clt, m) = (fn usr, HashMap.singleton (fn clt) m)
  where
    fn :: (ToByteString a) => a -> Text
    fn = fromJust . fromByteString . toByteString'

postProtoOtrMessage :: UserId -> ClientId -> ConvId -> OtrRecipients -> TestM ResponseLBS
postProtoOtrMessage = postProtoOtrMessage' Nothing Imports.id

postProtoOtrMessage' :: Maybe [UserId] -> (Request -> Request) -> UserId -> ClientId -> ConvId -> OtrRecipients -> TestM ResponseLBS
postProtoOtrMessage' reportMissing modif u d c rec = do
  g <- viewGalley
  let m = runPut (encodeMessage $ mkOtrProtoMessage d rec reportMissing "ZXhhbXBsZQ==")
   in post $
        g
          . modif
          . paths ["conversations", toByteString' c, "otr", "messages"]
          . zUser u
          . zConn "conn"
          . zType "access"
          . contentProtobuf
          . bytes m

mkOtrProtoMessage :: ClientId -> OtrRecipients -> Maybe [UserId] -> Text -> Proto.NewOtrMessage
mkOtrProtoMessage sender rec reportMissing ad =
  let rcps = protoFromOtrRecipients rec
      sndr = Proto.fromClientId sender
      rmis = Proto.fromUserId <$> fromMaybe [] reportMissing
   in Proto.newOtrMessage sndr rcps
        & Proto.newOtrMessageData ?~ fromBase64TextLenient ad
        & Proto.newOtrMessageReportMissing .~ rmis

getConvs :: (HasCallStack) => UserId -> [Qualified ConvId] -> TestM ResponseLBS
getConvs u cids = do
  g <- viewGalley
  post $
    g
      . path "/conversations/list"
      . zUser u
      . zConn "conn"
      . json (ListConversations (unsafeRange cids))

getAllConvs :: (HasCallStack) => UserId -> TestM [OwnConversation GroupConvType]
getAllConvs u = do
  g <- viewGalley
  cids <- do
    r :: ConvIdsPage <-
      responseJsonError
        =<< post
          ( g
              . path "/conversations/list-ids"
              . zUser u
              . zConn "conn"
              . json
                ( GetPaginatedConversationIds Nothing maxBound ::
                    GetPaginatedConversationIds
                )
          )
          <!! const 200 === statusCode
    pure (mtpResults r)
  r <-
    responseJsonError
      =<< getConvs u cids
        <!! const 200 === statusCode
  pure (crFound r)

listConvs ::
  (MonadIO m, MonadHttp m, MonadReader TestSetup m) =>
  UserId ->
  ListConversations ->
  m ResponseLBS
listConvs u req = do
  g <- view tsUnversionedGalley
  post $
    g
      . path "/v1/conversations/list/v2"
      . zUser u
      . zConn "conn"
      . zType "access"
      . json req

getConv ::
  ( MonadIO m,
    MonadHttp m,
    MonadReader TestSetup m,
    HasCallStack
  ) =>
  UserId ->
  ConvId ->
  m ResponseLBS
getConv u c = do
  g <- view tsUnversionedGalley
  get $
    g
      . paths ["v2", "conversations", toByteString' c]
      . zUser u
      . zConn "conn"
      . zType "access"

getConvQualifiedV2 ::
  ( MonadReader TestSetup m,
    MonadHttp m
  ) =>
  UserId ->
  Qualified ConvId ->
  m ResponseLBS
getConvQualifiedV2 u qcnv = do
  g <- view tsUnversionedGalley
  get $
    g
      . paths
        [ "v2",
          "conversations",
          toByteString' (qDomain qcnv),
          toByteString' (qUnqualified qcnv)
        ]
      . zUser u
      . zConn "conn"
      . zType "access"

getConvQualified :: (MonadIO m, MonadHttp m, HasGalley m, HasCallStack) => UserId -> Qualified ConvId -> m ResponseLBS
getConvQualified u (Qualified conv domain) = do
  g <- viewGalley
  get $
    g
      . paths ["conversations", toByteString' domain, toByteString' conv]
      . zUser u
      . zConn "conn"
      . zType "access"

getConvIdsV2 :: UserId -> Maybe (Either [ConvId] ConvId) -> Maybe Int32 -> TestM ResponseLBS
getConvIdsV2 u r s = do
  -- The endpoint is removed starting V3
  g <- fmap (addPrefixAtVersion V2 .) (view tsUnversionedGalley)
  get $
    g
      . path "/conversations/ids"
      . zUser u
      . zConn "conn"
      . zType "access"
      . convRange r s

getConvPage :: UserId -> Maybe ConversationPagingState -> Maybe Int32 -> TestM ResponseLBS
getConvPage u state count = do
  g <- viewGalley
  getConvPageWithGalley g u state count

getConvPageWithGalley ::
  (Request -> Request) ->
  UserId ->
  Maybe ConversationPagingState ->
  Maybe Int32 ->
  TestM ResponseLBS
getConvPageWithGalley g u state count =
  post $
    g
      . path "/conversations/list-ids"
      . zUser u
      . zConn "conn"
      -- generate JSON by hand here, so we can bypass the static range check
      . json
        ( object
            ( map (\n -> "size" .= toJSON n) (toList count)
                <> map (\s -> "paging_state" .= toJSON s) (toList state)
            )
        )

-- | Does not page through conversation list
listRemoteConvs :: Domain -> UserId -> TestM [Qualified ConvId]
listRemoteConvs remoteDomain uid = do
  allConvs <-
    fmap mtpResults . responseJsonError @_ @ConvIdsPage
      =<< getConvPage uid Nothing (Just 100) <!! const 200 === statusCode
  pure $ filter (\qcnv -> qDomain qcnv == remoteDomain) allConvs

postQualifiedMembers ::
  (MonadReader TestSetup m, MonadHttp m, HasGalley m) =>
  UserId ->
  NonEmpty (Qualified UserId) ->
  Qualified ConvId ->
  m ResponseLBS
postQualifiedMembers zusr invitees conv = do
  g <- viewGalley
  let invite = InviteQualified invitees roleNameWireAdmin
  post $
    g
      . paths
        [ "conversations",
          toByteString' . qDomain $ conv,
          toByteString' . qUnqualified $ conv,
          "members"
        ]
      . zUser zusr
      . zConn "conn"
      . zType "access"
      . json invite

postMembers ::
  (MonadIO m, MonadHttp m, HasGalley m) =>
  UserId ->
  NonEmpty (Qualified UserId) ->
  Qualified ConvId ->
  m ResponseLBS
postMembers u us c = postMembersWithRole u us c roleNameWireAdmin

postMembersWithRole ::
  (MonadIO m, MonadHttp m, HasGalley m) =>
  UserId ->
  NonEmpty (Qualified UserId) ->
  Qualified ConvId ->
  RoleName ->
  m ResponseLBS
postMembersWithRole u us c r = do
  g <- viewGalley
  let i = InviteQualified us r
  post $
    g
      . paths
        [ "conversations",
          toByteString' (qDomain c),
          toByteString' (qUnqualified c),
          "members"
        ]
      . zUser u
      . zConn "conn"
      . zType "access"
      . json i

deleteMemberQualified ::
  (HasCallStack, MonadIO m, MonadHttp m, HasGalley m) =>
  UserId ->
  Qualified UserId ->
  Qualified ConvId ->
  m ResponseLBS
deleteMemberQualified u1 (Qualified u2 u2Domain) (Qualified conv convDomain) = do
  g <- viewGalley
  delete $
    g
      . zUser u1
      . paths
        [ "conversations",
          toByteString' convDomain,
          toByteString' conv,
          "members",
          toByteString' u2Domain,
          toByteString' u2
        ]
      . zConn "conn"
      . zType "access"

getSelfMember :: UserId -> ConvId -> TestM ResponseLBS
getSelfMember u c = do
  g <- view tsUnversionedGalley
  get $
    g
      . paths ["v7", "conversations", toByteString' c, "self"]
      . zUser u
      . zConn "conn"
      . zType "access"

putMember :: UserId -> MemberUpdate -> Qualified ConvId -> TestM ResponseLBS
putMember u m (Qualified c dom) = do
  g <- viewGalley
  put $
    g
      . paths ["conversations", toByteString' dom, toByteString' c, "self"]
      . zUser u
      . zConn "conn"
      . zType "access"
      . json m

putOtherMemberQualified ::
  (HasGalley m, MonadIO m, MonadHttp m) =>
  UserId ->
  Qualified UserId ->
  OtherMemberUpdate ->
  Qualified ConvId ->
  m ResponseLBS
putOtherMemberQualified from to m c = do
  g <- viewGalley
  put $
    g
      . paths
        [ "conversations",
          toByteString' (qDomain c),
          toByteString' (qUnqualified c),
          "members",
          toByteString' (qDomain to),
          toByteString' (qUnqualified to)
        ]
      . zUser from
      . zConn "conn"
      . zType "access"
      . json m

putOtherMember :: UserId -> UserId -> OtherMemberUpdate -> ConvId -> TestM ResponseLBS
putOtherMember from to m c = do
  -- this endpoint was removed in v7
  g <- fmap (addPrefixAtVersion V6 .) (view tsUnversionedGalley)
  put $
    g
      . paths ["conversations", toByteString' c, "members", toByteString' to]
      . zUser from
      . zConn "conn"
      . zType "access"
      . json m

putQualifiedConversationName ::
  (HasCallStack, HasGalley m, MonadIO m, MonadHttp m) =>
  UserId ->
  Qualified ConvId ->
  Text ->
  m ResponseLBS
putQualifiedConversationName u c n = do
  g <- viewGalley
  let update = ConversationRename n
  put
    ( g
        . paths
          [ "conversations",
            toByteString' (qDomain c),
            toByteString' (qUnqualified c),
            "name"
          ]
        . zUser u
        . zConn "conn"
        . zType "access"
        . json update
    )

putConversationName :: UserId -> ConvId -> Text -> TestM ResponseLBS
putConversationName u c n = do
  g <- view tsUnversionedGalley
  let update = ConversationRename n
  put
    ( g
        . paths ["v7", "conversations", toByteString' c, "name"]
        . zUser u
        . zConn "conn"
        . zType "access"
        . json update
    )

putQualifiedReceiptMode ::
  (MonadIO m, MonadHttp m, HasGalley m, HasCallStack) =>
  UserId ->
  Qualified ConvId ->
  ReceiptMode ->
  m ResponseLBS
putQualifiedReceiptMode u (Qualified c dom) r = do
  g <- viewGalley
  let update = ConversationReceiptModeUpdate r
  put
    ( g
        . paths ["conversations", toByteString' dom, toByteString' c, "receipt-mode"]
        . zUser u
        . zConn "conn"
        . zType "access"
        . json update
    )

putReceiptMode :: UserId -> ConvId -> ReceiptMode -> TestM ResponseLBS
putReceiptMode u c r = do
  g <- view tsUnversionedGalley
  let update = ConversationReceiptModeUpdate r
  put
    ( g
        . paths ["v7", "conversations", toByteString' c, "receipt-mode"]
        . zUser u
        . zConn "conn"
        . zType "access"
        . json update
    )

getJoinCodeConv :: UserId -> Code.Key -> Code.Value -> TestM ResponseLBS
getJoinCodeConv u k v = do
  g <- viewGalley
  get $
    g
      . paths ["/conversations", "join"]
      . zUser u
      . queryItem "key" (toByteString' k)
      . queryItem "code" (toByteString' v)

postJoinConv :: UserId -> ConvId -> TestM ResponseLBS
postJoinConv u c = do
  -- This endpoint is removed from version v5 onwards
  g <- fmap (addPrefixAtVersion V4 .) (view tsUnversionedGalley)
  post $
    g
      . paths ["/conversations", toByteString' c, "join"]
      . zUser u
      . zConn "conn"
      . zType "access"

postJoinCodeConv :: UserId -> ConversationCode -> TestM ResponseLBS
postJoinCodeConv = postJoinCodeConv' Nothing

postJoinCodeConv' :: Maybe PlainTextPassword8 -> UserId -> ConversationCode -> TestM ResponseLBS
postJoinCodeConv' mPw u j = do
  g <- viewGalley
  post $
    g
      . paths ["conversations", "join"]
      . zUser u
      . zConn "conn"
      . zType "access"
      -- `json (JoinConversationByCode j Nothing)` and `json j` are equivalent, using the latter to test backwards compatibility
      . (if isJust mPw then json (JoinConversationByCode j mPw) else json j)

putQualifiedAccessUpdate ::
  (MonadHttp m, HasGalley m, MonadIO m) =>
  UserId ->
  Qualified ConvId ->
  ConversationAccessData ->
  m ResponseLBS
putQualifiedAccessUpdate u (Qualified c domain) acc = do
  g <- viewGalley
  put $
    g
      . paths ["/conversations", toByteString' domain, toByteString' c, "access"]
      . zUser u
      . zConn "conn"
      . zType "access"
      . json acc

putMessageTimerUpdateQualified ::
  (HasGalley m, MonadIO m, MonadHttp m) =>
  UserId ->
  Qualified ConvId ->
  ConversationMessageTimerUpdate ->
  m ResponseLBS
putMessageTimerUpdateQualified u c acc = do
  g <- viewGalley
  put $
    g
      . paths
        [ "/conversations",
          toByteString' (qDomain c),
          toByteString' (qUnqualified c),
          "message-timer"
        ]
      . zUser u
      . zConn "conn"
      . zType "access"
      . json acc

putMessageTimerUpdate ::
  UserId -> ConvId -> ConversationMessageTimerUpdate -> TestM ResponseLBS
putMessageTimerUpdate u c acc = do
  g <- view tsUnversionedGalley
  put $
    g
      . paths ["v7", "conversations", toByteString' c, "message-timer"]
      . zUser u
      . zConn "conn"
      . zType "access"
      . json acc

postConvCode :: UserId -> ConvId -> TestM ResponseLBS
postConvCode = postConvCode' Nothing

postConvCode' :: Maybe PlainTextPassword8 -> UserId -> ConvId -> TestM ResponseLBS
postConvCode' mPw u c = do
  g <- viewGalley
  post $
    g
      . paths ["/conversations", toByteString' c, "code"]
      . zUser u
      . zConn "conn"
      . zType "access"
      . json (CreateConversationCodeRequest mPw)

postConvCodeCheck :: ConversationCode -> TestM ResponseLBS
postConvCodeCheck code = do
  g <- viewGalley
  post $
    g
      . path "/conversations/code-check"
      . header "X-Forwarded-For" "127.0.0.42"
      . json code

getConvCode :: UserId -> ConvId -> TestM ResponseLBS
getConvCode u c = do
  g <- viewGalley
  get $
    g
      . paths ["/conversations", toByteString' c, "code"]
      . zUser u
      . zConn "conn"
      . zType "access"

deleteConvCode :: UserId -> ConvId -> TestM ResponseLBS
deleteConvCode u c = do
  g <- viewGalley
  delete $
    g
      . paths ["/conversations", toByteString' c, "code"]
      . zUser u
      . zConn "conn"
      . zType "access"

deleteUser :: (MonadIO m, MonadHttp m, HasGalley m, HasCallStack) => UserId -> m ResponseLBS
deleteUser u = do
  g <- viewGalley
  delete (g . path "/i/user" . zUser u)

getTeamQueue :: (HasCallStack) => UserId -> Maybe NotificationId -> Maybe (Int, Bool) -> Bool -> TestM [(NotificationId, UserId)]
getTeamQueue zusr msince msize onlyLast =
  parseEventList . responseJsonUnsafe
    <$> ( getTeamQueue' zusr msince (fst <$> msize) onlyLast
            <!! const 200
              === statusCode
        )
  where
    parseEventList :: QueuedNotificationList -> [(NotificationId, UserId)]
    parseEventList qnl
      | isJust msize && qnl ^. queuedHasMore /= snd (fromJust msize) =
          error $ "expected has_more: " <> show (snd $ fromJust msize) <> "; but found: " <> show (qnl ^. queuedHasMore)
      | isJust (qnl ^. queuedTime) =
          error $ "expected time: Nothing; but found: " <> show (qnl ^. queuedTime)
      | otherwise =
          fmap (_2 %~ parseEvt) . mconcat . fmap parseEvts . view queuedNotifications $ qnl

    parseEvts :: QueuedNotification -> [(NotificationId, Object)]
    parseEvts qn = (qn ^. queuedNotificationId,) <$> toList (qn ^. queuedNotificationPayload)

    parseEvt :: Object -> UserId
    parseEvt o = case fromJSON (Object o) of
      (Error msg) -> error msg
      (Success (e :: TE.Event)) ->
        case e ^. TE.eventData of
          EdMemberJoin uid -> uid
          _ -> error ("bad event type: " <> show (TE.eventType e))

getTeamQueue' :: (HasCallStack) => UserId -> Maybe NotificationId -> Maybe Int -> Bool -> TestM ResponseLBS
getTeamQueue' zusr msince msize onlyLast = do
  g <- viewGalley
  get
    ( g
        . path "/teams/notifications"
        . zUser zusr
        . zConn "conn"
        . zType "access"
        . query
          [ ("since", toByteString' <$> msince),
            ("size", toByteString' <$> msize),
            ("last", if onlyLast then Just "true" else Nothing)
          ]
    )

asOtherMember :: Qualified UserId -> OtherMember
asOtherMember quid = OtherMember quid Nothing roleNameWireMember

registerRemoteConv :: Qualified ConvId -> UserId -> Maybe Text -> Set OtherMember -> TestM ()
registerRemoteConv convId originUser name othMembers = do
  fedGalleyClient <- view tsFedGalleyClient
  now <- liftIO getCurrentTime
  void $
    runFedClient @"on-conversation-created" fedGalleyClient (qDomain convId) $
      ConversationCreated
        { time = now,
          origUserId = originUser,
          cnvId = qUnqualified convId,
          cnvType = RegularConv,
          cnvAccess = [],
          cnvAccessRoles = Set.fromList [TeamMemberAccessRole, NonTeamMemberAccessRole],
          cnvName = name,
          nonCreatorMembers = othMembers,
          messageTimer = Nothing,
          receiptMode = Nothing,
          protocol = ProtocolProteus,
          groupConvType = Nothing,
          channelAddPermission = Nothing,
          history = Nothing
        }

-------------------------------------------------------------------------------
-- Common Assertions

assertConvMemberWithRole :: (HasCallStack) => RoleName -> ConvId -> Qualified UserId -> TestM ()
assertConvMemberWithRole r c u =
  getSelfMember (qUnqualified u) c !!! do
    const 200 === statusCode
    const (Right u) === (fmap memId <$> responseJsonEither)
    const (Right r) === (fmap memConvRoleName <$> responseJsonEither)

assertConvMember :: (HasCallStack) => Qualified UserId -> ConvId -> TestM ()
assertConvMember u c =
  getSelfMember (qUnqualified u) c !!! do
    const 200 === statusCode
    const (Right u) === (fmap memId <$> responseJsonEither)

assertNotConvMember :: (HasCallStack) => UserId -> ConvId -> TestM ()
assertNotConvMember u c =
  getSelfMember u c !!! do
    const 200 === statusCode
    const (Right Null) === responseJsonEither

assertConvEquals :: forall gct m. (HasCallStack, MonadIO m) => OwnConversation gct -> OwnConversation gct -> m ()
assertConvEquals c1 c2 = liftIO $ do
  assertEqual "id" c1.cnvQualifiedId c2.cnvQualifiedId
  assertEqual "type" (Conv.cnvType c1) (Conv.cnvType c2)
  assertEqual "creator" (Conv.cnvCreator c1) (Conv.cnvCreator c2)
  assertEqual "access" (accessSet c1) (accessSet c2)
  assertEqual "name" (Conv.cnvName c1) (Conv.cnvName c2)
  assertEqual "self member" (selfMember c1) (selfMember c2)
  assertEqual "other members" (otherMembers c1) (otherMembers c2)
  where
    accessSet = Set.fromList . toList . Conv.cnvAccess
    selfMember = cmSelf . cnvMembers
    otherMembers = Set.fromList . cmOthers . cnvMembers

assertConv ::
  (HasCallStack) =>
  Response (Maybe Lazy.ByteString) ->
  ConvType ->
  Maybe UserId ->
  Qualified UserId ->
  [Qualified UserId] ->
  Maybe Text ->
  Maybe Milliseconds ->
  TestM (Qualified ConvId)
assertConv r t c s us n mt = assertConvWithRole r t c s us n mt roleNameWireAdmin

assertConvWithRole ::
  (HasCallStack) =>
  Response (Maybe Lazy.ByteString) ->
  ConvType ->
  Maybe UserId ->
  Qualified UserId ->
  [Qualified UserId] ->
  Maybe Text ->
  Maybe Milliseconds ->
  RoleName ->
  TestM (Qualified ConvId)
assertConvWithRole r t c s us n mt role = do
  cId <- fromBS $ getHeader' "Location" r
  cnv :: Conversation GroupConvType <- responseJsonError r
  liftIO $ do
    assertEqual "id" cId cnv.qualifiedId.qUnqualified
    assertEqual "name" n cnv.metadata.cnvmName
    assertEqual "type" t cnv.metadata.cnvmType
    assertEqual "creator" c cnv.metadata.cnvmCreator
    assertEqual "message_timer" mt cnv.metadata.cnvmMessageTimer
    assertEqual "members" (Set.fromList $ s : us) (Set.fromList (maybe [] (\self -> [self.memId]) cnv.members.self <> fmap omQualifiedId cnv.members.others))
    assertEqual "creator is always an admin" (Just roleNameWireAdmin) (memConvRoleName <$> cnv.members.self)
    assertBool "others role" (all ((== role) . omConvRoleName) cnv.members.others)
    case t of
      SelfConv -> assertEqual "access" privateAccess (cnv.metadata.cnvmAccess)
      ConnectConv -> assertEqual "access" privateAccess (cnv.metadata.cnvmAccess)
      One2OneConv -> assertEqual "access" privateAccess (cnv.metadata.cnvmAccess)
      _ -> pure ()
  pure cnv.qualifiedId

assertConvV9 ::
  (HasCallStack) =>
  Response (Maybe Lazy.ByteString) ->
  ConvType ->
  Maybe UserId ->
  Qualified UserId ->
  [Qualified UserId] ->
  Maybe Text ->
  Maybe Milliseconds ->
  TestM (Qualified ConvId)
assertConvV9 r t c s us n mt = assertConvWithRoleV9 r t c s us n mt roleNameWireAdmin

assertConvWithRoleV9 ::
  (HasCallStack) =>
  Response (Maybe Lazy.ByteString) ->
  ConvType ->
  Maybe UserId ->
  Qualified UserId ->
  [Qualified UserId] ->
  Maybe Text ->
  Maybe Milliseconds ->
  RoleName ->
  TestM (Qualified ConvId)
assertConvWithRoleV9 r t c s us n mt role = do
  cId <- fromBS $ getHeader' "Location" r
  cnv :: OwnConversation GroupConvType <- responseJsonError r
  let _self = cmSelf (cnvMembers cnv)
  let others = cmOthers (cnvMembers cnv)
  liftIO $ do
    assertEqual "id" cId (qUnqualified cnv.cnvQualifiedId)
    assertEqual "name" n (Conv.cnvName cnv)
    assertEqual "type" t (Conv.cnvType cnv)
    assertEqual "creator" c (cnvCreator cnv)
    assertEqual "message_timer" mt (cnvMessageTimer cnv)
    assertEqual "self" s (memId _self)
    assertEqual "others" (Set.fromList $ us) (Set.fromList . map omQualifiedId . toList $ others)
    assertEqual "creator is always and admin" roleNameWireAdmin (memConvRoleName _self)
    assertBool "others role" (all ((== role) . omConvRoleName) (toList others))
    assertBool "otr muted ref not empty" (isNothing (memOtrMutedRef _self))
    assertBool "otr archived not false" (not (memOtrArchived _self))
    assertBool "otr archived ref not empty" (isNothing (memOtrArchivedRef _self))
    case t of
      SelfConv -> assertEqual "access" privateAccess (Conv.cnvAccess cnv)
      ConnectConv -> assertEqual "access" privateAccess (Conv.cnvAccess cnv)
      One2OneConv -> assertEqual "access" privateAccess (Conv.cnvAccess cnv)
      _ -> pure ()
  pure (cnvQualifiedId cnv)

wsAssertOtr ::
  (HasCallStack) =>
  Qualified ConvId ->
  Qualified UserId ->
  ClientId ->
  ClientId ->
  Text ->
  Notification ->
  IO ()
wsAssertOtr = wsAssertOtr' "ZXhhbXBsZQ=="

wsAssertOtr' ::
  (HasCallStack) =>
  Text ->
  Qualified ConvId ->
  Qualified UserId ->
  ClientId ->
  ClientId ->
  Text ->
  Notification ->
  IO ()
wsAssertOtr' evData conv usr from to txt n = do
  let e = NonEmpty.head (WS.unpackPayload n)
  ntfTransient n @?= False
  evtConv e @?= conv
  evtType e @?= OtrMessageAdd
  evtFrom e @?= EventFromUser usr
  evtData e @?= EdOtrMessage (OtrMessage from to txt (Just evData))

wsAssertMLSWelcome ::
  (HasCallStack) =>
  Qualified UserId ->
  Qualified ConvId ->
  ByteString ->
  Notification ->
  IO ()
wsAssertMLSWelcome u cid welcome n = do
  let e = NonEmpty.head (WS.unpackPayload n)
  ntfTransient n @?= False
  evtConv e @?= cid
  evtType e @?= MLSWelcome
  evtFrom e @?= EventFromUser u
  evtData e @?= EdMLSWelcome welcome

wsAssertMLSMessage ::
  (HasCallStack) =>
  Qualified ConvOrSubConvId ->
  Qualified UserId ->
  ByteString ->
  Notification ->
  IO ()
wsAssertMLSMessage qcs u message n = do
  let e = NonEmpty.head (WS.unpackPayload n)
  ntfTransient n @?= False
  assertMLSMessageEvent qcs u message e

wsAssertClientRemoved ::
  (HasCallStack) =>
  ClientId ->
  Notification ->
  IO ()
wsAssertClientRemoved cid n = do
  let j = Object $ NonEmpty.head (ntfPayload n)
  let etype = j ^? key "type" . _String
  let eclient = j ^? key "client" . key "id" . _String
  etype @?= Just "user.client-remove"
  (fromByteString . T.encodeUtf8 =<< eclient) @?= Just cid

wsAssertClientAdded ::
  (HasCallStack) =>
  ClientId ->
  Notification ->
  IO ()
wsAssertClientAdded cid n = do
  let j = Object $ NonEmpty.head (ntfPayload n)
  let etype = j ^? key "type" . _String
  let eclient = j ^? key "client" . key "id" . _String
  etype @?= Just "user.client-add"
  (fromByteString . T.encodeUtf8 =<< eclient) @?= Just cid

wsIsEventOfType ::
  (HasCallStack) =>
  Text ->
  Notification ->
  Bool
wsIsEventOfType t n = do
  let j = Object $ NonEmpty.head (ntfPayload n)
  let etype = j ^? key "type" . _String
  etype == Just t

assertMLSMessageEvent ::
  (HasCallStack) =>
  Qualified ConvOrSubConvId ->
  Qualified UserId ->
  ByteString ->
  Conv.Event ->
  IO ()
assertMLSMessageEvent qcs u message e = do
  evtConv e @?= (.conv) <$> qcs
  case qUnqualified qcs of
    Conv _ -> pure ()
    SubConv _ subconvId ->
      evtSubConv e @?= Just subconvId
  evtType e @?= MLSMessageAdd
  evtFrom e @?= EventFromUser u
  evtData e @?= EdMLSMessage message

wsAssertMemberJoinWithRole :: (HasCallStack) => Qualified ConvId -> Qualified UserId -> [Qualified UserId] -> RoleName -> Notification -> IO ()
wsAssertMemberJoinWithRole conv usr new role n = do
  let e = NonEmpty.head (WS.unpackPayload n)
  ntfTransient n @?= False
  assertJoinEvent conv usr new role e

assertJoinEvent :: Qualified ConvId -> Qualified UserId -> [Qualified UserId] -> RoleName -> Conv.Event -> IO ()
assertJoinEvent conv usr new role e = do
  evtConv e @?= conv
  evtType e @?= Conv.MemberJoin
  evtFrom e @?= EventFromUser usr
  fmap (sort . mMembers) (evtData e ^? _EdMembersJoin) @?= Just (sort (fmap (`SimpleMember` role) new))

-- FUTUREWORK: See if this one can be implemented in terms of:
--
-- checkConvMemberLeaveEvent :: HasCallStack => Qualified ConvId -> Qualified UserId -> WS.WebSocket -> TestM ()
--
-- or if they can be combined in general.
wsAssertMembersLeave ::
  (HasCallStack) =>
  Qualified ConvId ->
  Qualified UserId ->
  [Qualified UserId] ->
  Notification ->
  IO ()
wsAssertMembersLeave conv usr leaving n = do
  let e = NonEmpty.head (WS.unpackPayload n)
  ntfTransient n @?= False
  assertLeaveEvent conv usr leaving e

assertLeaveEvent ::
  Qualified ConvId ->
  Qualified UserId ->
  [Qualified UserId] ->
  Conv.Event ->
  IO ()
assertLeaveEvent conv usr leaving e = do
  evtConv e @?= conv
  evtType e @?= Conv.MemberLeave
  evtFrom e @?= EventFromUser usr
  fmap (sort . qualifiedUserIdList) (evtData e ^? _EdMembersLeave . _2) @?= Just (sort leaving)

wsAssertMemberUpdateWithRole :: Qualified ConvId -> Qualified UserId -> UserId -> RoleName -> Notification -> IO ()
wsAssertMemberUpdateWithRole conv usr target role n = do
  let e = NonEmpty.head (WS.unpackPayload n)
  ntfTransient n @?= False
  evtConv e @?= conv
  evtType e @?= MemberStateUpdate
  evtFrom e @?= EventFromUser usr
  case evtData e of
    Conv.EdMemberUpdate mis -> do
      assertEqual "target" (Qualified target (qDomain conv)) (misTarget mis)
      assertEqual "conversation_role" (Just role) (misConvRoleName mis)
    x -> assertFailure $ "Unexpected event data: " ++ show x

wsAssertConvAccessUpdate :: Qualified ConvId -> Qualified UserId -> ConversationAccessData -> Notification -> IO ()
wsAssertConvAccessUpdate conv usr new n = do
  let e = NonEmpty.head (WS.unpackPayload n)
  ntfTransient n @?= False
  evtConv e @?= conv
  evtType e @?= ConvAccessUpdate
  evtFrom e @?= EventFromUser usr
  evtData e @?= EdConvAccessUpdate new

wsAssertConvMessageTimerUpdate :: Qualified ConvId -> Qualified UserId -> ConversationMessageTimerUpdate -> Notification -> IO ()
wsAssertConvMessageTimerUpdate conv usr new n = do
  let e = NonEmpty.head (WS.unpackPayload n)
  ntfTransient n @?= False
  evtConv e @?= conv
  evtType e @?= ConvMessageTimerUpdate
  evtFrom e @?= EventFromUser usr
  evtData e @?= EdConvMessageTimerUpdate new

wsAssertMemberLeave :: Qualified ConvId -> Qualified UserId -> [Qualified UserId] -> EdMemberLeftReason -> Notification -> IO ()
wsAssertMemberLeave conv usr old reason n = do
  let e = NonEmpty.head (WS.unpackPayload n)
  ntfTransient n @?= False
  evtConv e @?= conv
  evtType e @?= Conv.MemberLeave
  evtFrom e @?= EventFromUser usr
  sorted (evtData e) @?= sorted (EdMembersLeave reason (QualifiedUserIdList old))
  where
    sorted (EdMembersLeave _ (QualifiedUserIdList m)) = EdMembersLeave reason (QualifiedUserIdList (sort m))
    sorted x = x

wsAssertTyping :: (HasCallStack) => Qualified ConvId -> Qualified UserId -> TypingStatus -> Notification -> IO ()
wsAssertTyping conv usr ts n = do
  let e = NonEmpty.head (WS.unpackPayload n)
  ntfTransient n @?= True
  evtConv e @?= conv
  evtType e @?= Conv.Typing
  evtFrom e @?= EventFromUser usr
  evtData e @?= EdTyping ts

assertNoMsg :: (HasCallStack) => WS.WebSocket -> (Notification -> Assertion) -> TestM ()
assertNoMsg ws f = do
  x <- WS.awaitMatch (1 # Second) ws f
  liftIO $ case x of
    Left _ -> pure () -- expected
    Right _ -> assertFailure "Unexpected message"

-------------------------------------------------------------------------------
-- Helpers

testResponse :: (HasCallStack) => Int -> Maybe TestErrorLabel -> Assertions ()
testResponse status mlabel = do
  const status === statusCode
  case mlabel of
    Just label -> responseJsonEither === const (Right label)
    Nothing -> (isLeft <$> responseJsonEither @TestErrorLabel) === const True

newtype TestErrorLabel = TestErrorLabel {fromTestErrorLabel :: Text}
  deriving (Eq, Show)

instance IsString TestErrorLabel where
  fromString = TestErrorLabel . cs

instance FromJSON TestErrorLabel where
  parseJSON = fmap TestErrorLabel . withObject "TestErrorLabel" (.: "label")

decodeConvCode :: Response (Maybe Lazy.ByteString) -> ConversationCodeInfo
decodeConvCode = responseJsonUnsafe

decodeConvCodeEvent :: Response (Maybe Lazy.ByteString) -> ConversationCodeInfo
decodeConvCodeEvent r = case responseJsonUnsafe r of
  (Event _ _ _ _ _ (EdConvCodeUpdate c)) -> c
  _ -> error "Failed to parse ConversationCode from Event"

decodeConvIdV9 :: (HasCallStack) => Response (Maybe Lazy.ByteString) -> ConvId
decodeConvIdV9 = qUnqualified . decodeQualifiedConvIdV9

decodeConvId :: (HasCallStack) => Response (Maybe Lazy.ByteString) -> ConvId
decodeConvId = qUnqualified . decodeQualifiedConvId

decodeQualifiedConvIdV9 :: (HasCallStack) => Response (Maybe Lazy.ByteString) -> Qualified ConvId
decodeQualifiedConvIdV9 = cnvQualifiedId . responseJsonUnsafe @(OwnConversation GroupConvType)

decodeQualifiedConvId :: (HasCallStack) => Response (Maybe Lazy.ByteString) -> Qualified ConvId
decodeQualifiedConvId = (.qualifiedId) . responseJsonUnsafe @(Conversation GroupConvType)

decodeConvIdList :: (HasCallStack) => Response (Maybe Lazy.ByteString) -> [ConvId]
decodeConvIdList = convList . responseJsonUnsafeWithMsg "conversation-ids"

zUser :: UserId -> Request -> Request
zUser = header "Z-User" . toByteString'

zClient :: ClientId -> Request -> Request
zClient = header "Z-Client" . toByteString'

zConn :: ByteString -> Request -> Request
zConn = header "Z-Connection"

zType :: ByteString -> Request -> Request
zType = header "Z-Type"

-- TODO: it'd be nicer to just take a list here and handle the cases with 0
-- users differently
connectUsers :: UserId -> NonEmpty UserId -> TestM ()
connectUsers u us = void $ connectUsersWith expect2xx u us

-- TODO: it'd be nicer to just take a list here and handle the cases with 0
-- users differently
connectLocalQualifiedUsers :: UserId -> NonEmpty (Qualified UserId) -> TestM ()
connectLocalQualifiedUsers u us = do
  localDomain <- viewFederationDomain
  let partitionMap = indexQualified . toList $ us
  -- FUTUREWORK: connect all users, not just those on the same domain as 'u'
  case LMap.lookup localDomain partitionMap of
    Nothing -> err
    Just [] -> err
    Just (x : xs) -> void $ connectUsersWith expect2xx u (x :| xs)
  where
    err = liftIO . assertFailure $ "No user on the domain with " ++ show u

connectUsersUnchecked ::
  UserId ->
  NonEmpty UserId ->
  TestM (NonEmpty (Response (Maybe Lazy.ByteString), Response (Maybe Lazy.ByteString)))
connectUsersUnchecked = connectUsersWith Imports.id

connectUsersWith ::
  (Request -> Request) ->
  UserId ->
  NonEmpty UserId ->
  TestM (NonEmpty (Response (Maybe Lazy.ByteString), Response (Maybe Lazy.ByteString)))
connectUsersWith fn u = mapM connectTo
  where
    connectTo v = do
      b <- view tsUnversionedBrig
      r1 <-
        post
          ( b
              . zUser u
              . zConn "conn"
              . paths ["v1", "connections"]
              . json (ConnectionRequest v (unsafeRange "chat"))
              . fn
          )
      r2 <-
        put
          ( b
              . zUser v
              . zConn "conn"
              . paths ["v1", "connections", toByteString' u]
              . json (ConnectionUpdate Accepted)
              . fn
          )
      pure (r1, r2)

connectWithRemoteUser ::
  (HasBrig m, MonadIO m, MonadHttp m, MonadCatch m, HasCallStack) =>
  UserId ->
  Qualified UserId ->
  m ()
connectWithRemoteUser self other = do
  let req = CreateConnectionForTest self other
  b <- viewBrig
  put
    ( b
        . zUser self
        . contentJson
        . zConn "conn"
        . paths ["i", "connections", "connection-update"]
        . json req
    )
    !!! const 200
      === statusCode

-- | A copy of 'postConnection' from Brig integration tests.
postConnection :: UserId -> UserId -> TestM ResponseLBS
postConnection from to = do
  brig <- view tsUnversionedBrig
  post $
    brig
      . paths ["v1", "connections"]
      . contentJson
      . body payload
      . zUser from
      . zConn "conn"
  where
    payload =
      RequestBodyLBS . encode $
        ConnectionRequest to (unsafeRange "some conv name")

-- | A copy of 'putConnection' from Brig integration tests.
putConnection :: UserId -> UserId -> Relation -> TestM ResponseLBS
putConnection from to r = do
  brig <- view tsUnversionedBrig
  put $
    brig
      . paths ["v1", "connections", toByteString' to]
      . contentJson
      . body payload
      . zUser from
      . zConn "conn"
  where
    payload = RequestBodyLBS . encode $ object ["status" .= r]

-- | A slightly modified copy of 'putConnection' from above.
putConnectionQualified :: Qualified UserId -> UserId -> Relation -> TestM ResponseLBS
putConnectionQualified fromQualified to r = do
  localDomain <- viewFederationDomain
  let (Qualified from qualifiedDomain) = fromQualified
  liftIO $
    assertEqual
      "The qualified user's domain is not local"
      localDomain
      qualifiedDomain
  brig <- view tsUnversionedBrig
  put $
    brig
      . paths ["v1", "connections", toByteString' to]
      . contentJson
      . body payload
      . zUser from
      . zConn "conn"
  where
    payload = RequestBodyLBS . encode $ object ["status" .= r]

-- | A copy of `assertConnections from Brig integration tests.
assertConnections :: (HasCallStack) => UserId -> [ConnectionStatus] -> TestM ()
assertConnections u cstat = do
  brig <- view tsUnversionedBrig
  resp <- listConnections brig u <!! const 200 === statusCode
  let cstat' :: [ConnectionStatus]
      cstat' = fmap status . clConnections . fromMaybe (error "bad response") . responseJsonMaybe $ resp
  unless (all (`elem` cstat') cstat) $
    error $
      "connection check failed: " <> show cstat <> " is not a subset of " <> show cstat'
  where
    status c = ConnectionStatus (ucFrom c) (qUnqualified $ ucTo c) (ucStatus c)
    listConnections brig usr = get $ brig . paths ["v1", "connections"] . zUser usr

randomUsers :: Int -> TestM [UserId]
randomUsers n = replicateM n randomUser

randomUserTuple :: (HasCallStack) => TestM (UserId, Qualified UserId)
randomUserTuple = do
  qUid <- randomQualifiedUser
  pure (qUnqualified qUid, qUid)

randomUser :: (HasCallStack) => TestM UserId
randomUser = qUnqualified <$> randomUser' False True True

randomQualifiedUser :: (HasCallStack) => TestM (Qualified UserId)
randomQualifiedUser = randomUser' False True True

randomQualifiedId :: (MonadIO m) => Domain -> m (Qualified (Id a))
randomQualifiedId domain = Qualified <$> randomId <*> pure domain

randomTeamCreator :: (HasCallStack) => TestM User
randomTeamCreator = randomUser'' True True True

randomUser' :: (HasCallStack) => Bool -> Bool -> Bool -> TestM (Qualified UserId)
randomUser' isCreator hasPassword hasEmail = userQualifiedId <$> randomUser'' isCreator hasPassword hasEmail

randomUser'' :: (HasCallStack) => Bool -> Bool -> Bool -> TestM User
randomUser'' isCreator hasPassword hasEmail = selfUser <$> randomUserProfile' isCreator hasPassword hasEmail

randomUserProfile' :: (HasCallStack) => Bool -> Bool -> Bool -> TestM SelfProfile
randomUserProfile' isCreator hasPassword hasEmail = do
  b <- viewBrig
  e <- liftIO randomEmail
  let p =
        object $
          ["name" .= fromEmail e]
            <> ["password" .= defPassword | hasPassword]
            <> ["email" .= fromEmail e | hasEmail]
            <> ["team" .= newNewTeam (unsafeRange "teamName") DefaultIcon | isCreator]
  responseJsonUnsafe <$> (post (b . path "/i/users" . json p) <!! const 201 === statusCode)

ephemeralUser :: (HasCallStack) => TestM UserId
ephemeralUser = do
  b <- viewBrig
  name <- UUID.toText <$> liftIO nextRandom
  let p = object ["name" .= name]
  r <- post (b . path "/register" . header "X-Forwarded-For" "127.0.0.42" . json p) <!! const 201 === statusCode
  user <- responseJsonError r
  pure $ User.userId user

randomClient :: (HasCallStack) => UserId -> LastPrekey -> TestM ClientId
randomClient uid lk = randomClientWithCaps uid lk Nothing

randomClientWithCaps :: (HasCallStack) => UserId -> LastPrekey -> Maybe ClientCapabilityList -> TestM ClientId
randomClientWithCaps uid lk caps = do
  b <- viewBrig
  resp <-
    post
      ( b
          . paths ["i", "clients", toByteString' uid]
          . queryItem "skip_reauth" "true"
          . json newClientBody
      )
      <!! const rStatus
        === statusCode
  client :: Client <- responseJsonError resp
  pure client.clientId
  where
    cType = PermanentClientType
    rStatus = 201
    newClientBody =
      (newClient cType lk)
        { newClientPassword = Just defPassword,
          newClientCapabilities = caps
        }

ensureDeletedState :: (HasCallStack) => Bool -> UserId -> UserId -> TestM ()
ensureDeletedState check from u = do
  state <- getDeletedState from u
  liftIO $ assertEqual "Unxpected deleted state" state (Just check)

getDeletedState :: (HasCallStack) => UserId -> UserId -> TestM (Maybe Bool)
getDeletedState from u = do
  b <- view tsUnversionedBrig
  fmap profileDeleted . responseJsonMaybe
    <$> get
      ( b
          . paths ["v1", "users", toByteString' u]
          . zUser from
          . zConn "conn"
      )

getClients :: UserId -> TestM ResponseLBS
getClients u = do
  b <- viewBrig
  get $
    b
      . paths ["clients"]
      . zUser u
      . zConn "conn"

getInternalClientsFull :: UserSet -> TestM UserClientsFull
getInternalClientsFull userSet = do
  b <- viewBrig
  res <-
    post $
      b
        . paths ["i", "clients", "full"]
        . zConn "conn"
        . json userSet
  responseJsonError res

ensureClientCaps :: (HasCallStack) => UserId -> ClientId -> Client.ClientCapabilityList -> TestM ()
ensureClientCaps uid cid caps = do
  UserClientsFull (Map.lookup uid -> (Just clnts)) <- getInternalClientsFull (UserSet $ Set.singleton uid)
  clnt <- assertOne . filter ((== cid) . (.clientId)) $ Set.toList clnts
  liftIO $ assertEqual ("ensureClientCaps: " <> show (uid, cid, caps)) (clientCapabilities clnt) caps

-- TODO: Refactor, as used also in brig
deleteClient :: UserId -> ClientId -> Maybe PlainTextPassword6 -> TestM ResponseLBS
deleteClient u c pw = do
  b <- viewBrig
  delete $
    b
      . paths ["clients", toByteString' c]
      . zUser u
      . zConn "conn"
      . contentJson
      . body payload
  where
    payload =
      RequestBodyLBS . encode $
        object
          [ "password" .= pw
          ]

randomUserWithClient :: LastPrekey -> TestM (UserId, ClientId)
randomUserWithClient lk = do
  (u, c) <- randomUserWithClientQualified lk
  pure (qUnqualified u, c)

randomUserWithClientQualified :: LastPrekey -> TestM (Qualified UserId, ClientId)
randomUserWithClientQualified lk = do
  u <- randomQualifiedUser
  c <- randomClient (qUnqualified u) lk
  pure (u, c)

fromBS :: (HasCallStack, FromByteString a, MonadIO m) => ByteString -> m a
fromBS bs =
  case fromByteString bs of
    Nothing -> liftIO $ assertFailure "fromBS: no parse"
    Just x -> pure x

convRange :: Maybe (Either [ConvId] ConvId) -> Maybe Int32 -> Request -> Request
convRange range size =
  maybe Imports.id (queryItem "size" . C.pack . show) size
    . case range of
      Just (Left l) -> queryItem "ids" (C.intercalate "," $ map toByteString' l)
      Just (Right c) -> queryItem "start" (toByteString' c)
      Nothing -> Imports.id

privateAccess :: [Access]
privateAccess = [PrivateAccess]

assertExpected :: (Eq a, Show a) => String -> a -> (Response (Maybe LByteString) -> Maybe a) -> Assertions ()
assertExpected msg expected tparser =
  assertResponse $ \res ->
    case tparser res of
      Nothing -> Just (addTitle "Parsing the response failed")
      Just parsed ->
        if parsed == expected
          then Nothing
          else Just (addTitle (unlines ["Expected: ", show expected, "But got:", show parsed]))
  where
    addTitle s = unlines [msg, s]

assertBroadcastMismatch ::
  Domain ->
  BroadcastAPI ->
  [(UserId, Set ClientId)] ->
  [(UserId, Set ClientId)] ->
  [(UserId, Set ClientId)] ->
  Assertions ()
assertBroadcastMismatch localDomain BroadcastQualified =
  \m r d -> assertMismatchQualified mempty (mk m) (mk r) (mk d) mempty
  where
    mk :: [(UserId, Set ClientId)] -> Client.QualifiedUserClients
    mk [] = mempty
    mk uc = Client.QualifiedUserClients . Map.singleton localDomain . Map.fromList $ uc
assertBroadcastMismatch _ _ = assertMismatch

assertMismatchWithMessage ::
  (HasCallStack) =>
  Maybe String ->
  [(UserId, Set ClientId)] ->
  [(UserId, Set ClientId)] ->
  [(UserId, Set ClientId)] ->
  Assertions ()
assertMismatchWithMessage mmsg missing redundant deleted = do
  assertExpected (formatMessage "missing") (userClients missing) (fmap missingClients . responseJsonMaybe)
  assertExpected (formatMessage "redundant") (userClients redundant) (fmap redundantClients . responseJsonMaybe)
  assertExpected (formatMessage "deleted") (userClients deleted) (fmap deletedClients . responseJsonMaybe)
  where
    userClients :: [(UserId, Set ClientId)] -> UserClients
    userClients = UserClients . Map.fromList

    formatMessage :: String -> String
    formatMessage = maybe Imports.id (\msg -> ((msg <> "\n") <>)) mmsg

assertMismatch ::
  (HasCallStack) =>
  [(UserId, Set ClientId)] ->
  [(UserId, Set ClientId)] ->
  [(UserId, Set ClientId)] ->
  Assertions ()
assertMismatch = assertMismatchWithMessage Nothing

assertMismatchQualified ::
  (HasCallStack) =>
  Client.QualifiedUserClients ->
  Client.QualifiedUserClients ->
  Client.QualifiedUserClients ->
  Client.QualifiedUserClients ->
  Client.QualifiedUserClients ->
  Assertions ()
assertMismatchQualified failureToSend missing redundant deleted failedToConfirm = do
  assertExpected "failed to send" failureToSend (fmap mssFailedToSend . responseJsonMaybe)
  assertExpected "missing" missing (fmap mssMissingClients . responseJsonMaybe)
  assertExpected "redundant" redundant (fmap mssRedundantClients . responseJsonMaybe)
  assertExpected "deleted" deleted (fmap mssDeletedClients . responseJsonMaybe)
  assertExpected "failed to confirm clients" failedToConfirm (fmap mssFailedToConfirmClients . responseJsonMaybe)

otrRecipients :: [(UserId, ClientId, Text)] -> OtrRecipients
otrRecipients =
  OtrRecipients
    . UserClientMap
    . fmap Map.fromList
    . foldr ((uncurry Map.insert . fmap pure) . (\(a, b, c) -> (a, (b, c)))) mempty

defPassword :: PlainTextPassword6
defPassword = plainTextPassword6Unsafe "topsecretdefaultpassword"

randomEmail :: (MonadIO m) => m EmailAddress
randomEmail = do
  uid <- liftIO nextRandom
  pure $ unsafeEmailAddress ("success+" <> UUID.toASCIIBytes uid) "simulator.amazonses.com"

-- TODO: Refactor, as used also in other services
retryWhileN :: (MonadIO m) => Int -> (a -> Bool) -> m a -> m a
retryWhileN n f m =
  retrying
    (constantDelay 1000000 <> limitRetries n)
    (const (pure . f))
    (const m)

-- | Changing this will break tests; all prekeys and client Id must match the same
-- fingerprint
someClientId :: ClientId
someClientId = ClientId 0xcc6e640e296e8bba

-- | Changing these will break tests; all prekeys and client Id must match the same
-- fingerprint
somePrekeys :: [UncheckedPrekeyBundle]
somePrekeys =
  [ UncheckedPrekeyBundle (PrekeyId 1) "pQABAQECoQBYIOjl7hw0D8YRNqkkBQETCxyr7/ywE/2R5RWcUPM+GJACA6EAoQBYILLf1TIwSB62q69Ojs/X1tzJ+dYHNAw4QbW/7TC5vSZqBPY=",
    UncheckedPrekeyBundle (PrekeyId 2) "pQABAQICoQBYIGoXawUQWQ9ZW+MXhvuo9ALOBUjLff8S5VdAokN29C1OA6EAoQBYILLf1TIwSB62q69Ojs/X1tzJ+dYHNAw4QbW/7TC5vSZqBPY=",
    UncheckedPrekeyBundle (PrekeyId 3) "pQABAQMCoQBYIEjdt+YWd3lHmG8pamULLMubAMZw556IO8kW7s1MLFytA6EAoQBYILLf1TIwSB62q69Ojs/X1tzJ+dYHNAw4QbW/7TC5vSZqBPY=",
    UncheckedPrekeyBundle (PrekeyId 4) "pQABAQQCoQBYIPIaOA3Xqfk4Lh2/pU88Owd2eW5eplHpywr+Mx4QGyiMA6EAoQBYILLf1TIwSB62q69Ojs/X1tzJ+dYHNAw4QbW/7TC5vSZqBPY=",
    UncheckedPrekeyBundle (PrekeyId 5) "pQABAQUCoQBYIHnafNR4Gh3ID71lYzToewEVag4EKskDFq+gaeraOlSJA6EAoQBYILLf1TIwSB62q69Ojs/X1tzJ+dYHNAw4QbW/7TC5vSZqBPY=",
    UncheckedPrekeyBundle (PrekeyId 6) "pQABAQYCoQBYIFXUkVftE7kK22waAzhOjOmJVex3EBTU8RHZFx2o1Ed8A6EAoQBYILLf1TIwSB62q69Ojs/X1tzJ+dYHNAw4QbW/7TC5vSZqBPY=",
    UncheckedPrekeyBundle (PrekeyId 7) "pQABAQcCoQBYIDXdN8VlKb5lbgPmoDPLPyqNIEyShG4oT/DlW0peRRZUA6EAoQBYILLf1TIwSB62q69Ojs/X1tzJ+dYHNAw4QbW/7TC5vSZqBPY=",
    UncheckedPrekeyBundle (PrekeyId 8) "pQABAQgCoQBYIJH1ewvIVV3yGqQvdr/QM9HARzMgo5ksOTRyKEuN2aZzA6EAoQBYILLf1TIwSB62q69Ojs/X1tzJ+dYHNAw4QbW/7TC5vSZqBPY=",
    UncheckedPrekeyBundle (PrekeyId 9) "pQABAQkCoQBYIFcAnXdx0M1Q1hoDDfgMK9r+Zchn8YlVHHaQwQYhRk1dA6EAoQBYILLf1TIwSB62q69Ojs/X1tzJ+dYHNAw4QbW/7TC5vSZqBPY=",
    UncheckedPrekeyBundle (PrekeyId 10) "pQABAQoCoQBYIGs3vyxwmzEZ+qKNy4wpFkxc+Bgkb0D76ZEbxeeh/9DVA6EAoQBYILLf1TIwSB62q69Ojs/X1tzJ+dYHNAw4QbW/7TC5vSZqBPY=",
    UncheckedPrekeyBundle (PrekeyId 11) "pQABAQsCoQBYIGUiBeOJALP5dkMduUZ/u6MDhHNrsrBUa3f0YlSSWZbzA6EAoQBYILLf1TIwSB62q69Ojs/X1tzJ+dYHNAw4QbW/7TC5vSZqBPY=",
    UncheckedPrekeyBundle (PrekeyId 12) "pQABAQwCoQBYIMp6QNNTPDZgL3DSSD/QWWnBI7LsTZp2RhY/HLqnIwRZA6EAoQBYILLf1TIwSB62q69Ojs/X1tzJ+dYHNAw4QbW/7TC5vSZqBPY=",
    UncheckedPrekeyBundle (PrekeyId 13) "pQABAQ0CoQBYIJXSSUrE5RCNyB5pg+m6vGwK7RvJ+rs9dsdHitxnfDhuA6EAoQBYILLf1TIwSB62q69Ojs/X1tzJ+dYHNAw4QbW/7TC5vSZqBPY=",
    UncheckedPrekeyBundle (PrekeyId 14) "pQABAQ4CoQBYIHmtOX7jCKBHFDysb4H0z/QWoCSaEyjerZaT/HOP8bgDA6EAoQBYILLf1TIwSB62q69Ojs/X1tzJ+dYHNAw4QbW/7TC5vSZqBPY=",
    UncheckedPrekeyBundle (PrekeyId 15) "pQABAQ8CoQBYIIaMCTcPKj2HuYQ7i9ZaxUw9j5Bz8TPjoAaTZ5eB0w1kA6EAoQBYILLf1TIwSB62q69Ojs/X1tzJ+dYHNAw4QbW/7TC5vSZqBPY=",
    UncheckedPrekeyBundle (PrekeyId 16) "pQABARACoQBYIHWAOacKuWH81moJVveJ0FSfipWocfspOIBhaU6VLWUsA6EAoQBYILLf1TIwSB62q69Ojs/X1tzJ+dYHNAw4QbW/7TC5vSZqBPY=",
    UncheckedPrekeyBundle (PrekeyId 17) "pQABARECoQBYIA8XtUXtnMxQslULnNAeHBIivlLRe/+qdh2j6nTfDAchA6EAoQBYILLf1TIwSB62q69Ojs/X1tzJ+dYHNAw4QbW/7TC5vSZqBPY=",
    UncheckedPrekeyBundle (PrekeyId 18) "pQABARICoQBYIGgzg6SzgTTOgnk48pa6y2Rgjy004DkeBo4CMld3Jlr6A6EAoQBYILLf1TIwSB62q69Ojs/X1tzJ+dYHNAw4QbW/7TC5vSZqBPY=",
    UncheckedPrekeyBundle (PrekeyId 19) "pQABARMCoQBYIEoEFiIpCHgn74CAD+GhIfIgbQtdCqQqkOXHWxRlG6Y6A6EAoQBYILLf1TIwSB62q69Ojs/X1tzJ+dYHNAw4QbW/7TC5vSZqBPY=",
    UncheckedPrekeyBundle (PrekeyId 20) "pQABARQCoQBYINVEwTRxNSe0rxZxon4Rifz2l4rtQZn7mHtKYCiFAK9IA6EAoQBYILLf1TIwSB62q69Ojs/X1tzJ+dYHNAw4QbW/7TC5vSZqBPY=",
    UncheckedPrekeyBundle (PrekeyId 21) "pQABARUCoQBYIN3aeX2Ayi2rPFbiaYb+O2rdHUpFhzRs2j28pCmbGpflA6EAoQBYILLf1TIwSB62q69Ojs/X1tzJ+dYHNAw4QbW/7TC5vSZqBPY=",
    UncheckedPrekeyBundle (PrekeyId 22) "pQABARYCoQBYIJe5OJ17YKQrNmIH3sE++r++4Z5ld36axqAMjjQ3jtQWA6EAoQBYILLf1TIwSB62q69Ojs/X1tzJ+dYHNAw4QbW/7TC5vSZqBPY=",
    UncheckedPrekeyBundle (PrekeyId 23) "pQABARcCoQBYIASE94LjK6Raipk/lN/YewouqO+kcQGpxIqP+iW2hyHiA6EAoQBYILLf1TIwSB62q69Ojs/X1tzJ+dYHNAw4QbW/7TC5vSZqBPY=",
    UncheckedPrekeyBundle (PrekeyId 24) "pQABARgYAqEAWCBZ222LpS6/99Btlw+83PihrA655skwsNevt//8oz5axQOhAKEAWCCy39UyMEgetquvTo7P19bcyfnWBzQMOEG1v+0wub0magT2",
    UncheckedPrekeyBundle (PrekeyId 25) "pQABARgZAqEAWCDGEwo61w4O8T8lyw0HdoOjGWBKQUNqo6+jSfrPR9alrAOhAKEAWCCy39UyMEgetquvTo7P19bcyfnWBzQMOEG1v+0wub0magT2",
    UncheckedPrekeyBundle (PrekeyId 26) "pQABARgaAqEAWCBMSQoQ6B35plC80i1O3AWlJSftCEbCbju97Iykg5+NWQOhAKEAWCCy39UyMEgetquvTo7P19bcyfnWBzQMOEG1v+0wub0magT2"
  ]

-- | Changing these will break tests; all prekeys and client Id must match the same
-- fingerprint
someLastPrekeys :: [LastPrekey]
someLastPrekeys =
  [ lastPrekey "pQABARn//wKhAFggnCcZIK1pbtlJf4wRQ44h4w7/sfSgj5oWXMQaUGYAJ/sDoQChAFgglacihnqg/YQJHkuHNFU7QD6Pb3KN4FnubaCF2EVOgRkE9g==",
    lastPrekey "pQABARn//wKhAFggwO2any+CjiGP8XFYrY67zHPvLgp+ysY5k7vci57aaLwDoQChAFgglacihnqg/YQJHkuHNFU7QD6Pb3KN4FnubaCF2EVOgRkE9g==",
    lastPrekey "pQABARn//wKhAFggoChErA5oTI5JT769hJV+VINmU8kougGdYqGd2U7hPa8DoQChAFgglacihnqg/YQJHkuHNFU7QD6Pb3KN4FnubaCF2EVOgRkE9g==",
    lastPrekey "pQABARn//wKhAFggPLk4BBJ8THVLGm7r0K7EJITRlJnt6bpNzM9GTNRYcCcDoQChAFgglacihnqg/YQJHkuHNFU7QD6Pb3KN4FnubaCF2EVOgRkE9g==",
    lastPrekey "pQABARn//wKhAFggqHASsRlZ1i8dESXRXBL2OvR+0yGUtqK9vJfzol1E+osDoQChAFgglacihnqg/YQJHkuHNFU7QD6Pb3KN4FnubaCF2EVOgRkE9g==",
    lastPrekey "pQABARn//wKhAFggx/N1YhKXSJYJQxhWgHSA4ASaJKIHDJfmEnojfnp9VQ8DoQChAFgglacihnqg/YQJHkuHNFU7QD6Pb3KN4FnubaCF2EVOgRkE9g==",
    lastPrekey "pQABARn//wKhAFggVL6QIpoqmtKxmB8HToiAPxfjSDEzJEUAoFKfhXou06YDoQChAFgglacihnqg/YQJHkuHNFU7QD6Pb3KN4FnubaCF2EVOgRkE9g==",
    lastPrekey "pQABARn//wKhAFggRs74/ViOrHN+aS2RbGCwC0sJv1Sp/Q0pmRB15s9DCBMDoQChAFgglacihnqg/YQJHkuHNFU7QD6Pb3KN4FnubaCF2EVOgRkE9g==",
    lastPrekey "pQABARn//wKhAFggtNO/hrwzt9M/1X6eK2sG6YFmA7BDqlFMEipbZOsg0vcDoQChAFgglacihnqg/YQJHkuHNFU7QD6Pb3KN4FnubaCF2EVOgRkE9g==",
    lastPrekey "pQABARn//wKhAFgg1rZEY6vbAnEz+Ern5kRny/uKiIrXTb/usQxGnceV2HADoQChAFgglacihnqg/YQJHkuHNFU7QD6Pb3KN4FnubaCF2EVOgRkE9g=="
  ]

mkProteusConv ::
  ConvId ->
  UserId ->
  RoleName ->
  [OtherMember] ->
  RemoteConversationView
mkProteusConv cnvId creator selfRole otherMembers =
  RemoteConversationView
    cnvId
    ( ConversationMetadata
        RegularConv
        (Just creator)
        []
        (Set.fromList [TeamMemberAccessRole, NonTeamMemberAccessRole])
        (Just "federated gossip")
        Nothing
        Nothing
        Nothing
        (Just GroupConversation)
        Nothing
        def
        Nothing
        def
    )
    (RemoteConvMembers selfRole otherMembers)
    ProtocolProteus

-- | ES is only refreshed occasionally; we don't want to wait for that in tests.
refreshIndex :: TestM ()
refreshIndex = do
  brig <- viewBrig
  post (brig . path "/i/index/refresh") !!! const 200 === statusCode

postSSOUser :: Text -> Bool -> UserSSOId -> TeamId -> TestM ResponseLBS
postSSOUser name hasEmail ssoid teamid = do
  brig <- viewBrig
  email <- randomEmail
  let o =
        object $
          [ "name" .= name,
            "cookie" .= defCookieLabel,
            "sso_id" .= ssoid,
            "team_id" .= teamid
          ]
            <> ["email" .= fromEmail email | hasEmail]
      bdy = Bilge.json o
  post (brig . path "/i/users" . bdy)

defCookieLabel :: CookieLabel
defCookieLabel = CookieLabel "auth"

class HasSettingsOverrides m where
  withSettingsOverrides :: (Opts.Opts -> Opts.Opts) -> m a -> m a

instance HasSettingsOverrides TestM where
  withSettingsOverrides f action = do
    ts :: TestSetup <- ask
    let opts = f (ts ^. tsGConf)
    liftIO . lowerCodensity $ do
      (galleyApp, _env) <- Run.mkApp opts -- FUTUREWORK: always call Run.closeApp at the end.
      port' <- withMockServer galleyApp
      liftIO $
        runReaderT
          (runTestM action)
          ( ts
              & tsUnversionedGalley .~ Bilge.host "127.0.0.1" . Bilge.port port'
              & tsFedGalleyClient .~ FedClient (ts ^. tsManager) (Endpoint "127.0.0.1" port')
          )

waitForMemberDeletion :: UserId -> TeamId -> UserId -> TestM ()
waitForMemberDeletion zusr tid uid = do
  maybeTimedOut <- timeout 2000000 loop
  liftIO $
    when (isNothing maybeTimedOut) $
      assertFailure "Timed out waiting for member deletion"
  where
    loop = do
      galley <- viewGalley
      res <- get (galley . paths ["teams", toByteString' tid, "members", toByteString' uid] . zUser zusr)
      case statusCode res of
        404 -> pure ()
        _ -> threadDelay 1000 >> loop

deleteTeamMember :: (MonadIO m, MonadCatch m, MonadHttp m) => (Request -> Request) -> TeamId -> UserId -> UserId -> m ()
deleteTeamMember g tid owner deletee =
  delete
    ( g
        . paths ["teams", toByteString' tid, "members", toByteString' deletee]
        . zUser owner
        . zConn "conn"
        . json (newTeamMemberDeleteData (Just defPassword))
    )
    !!! do
      const 202 === statusCode

deleteTeam :: UserId -> TeamId -> TestM ()
deleteTeam owner tid = do
  g <- viewGalley
  delete
    ( g
        . paths ["teams", toByteString' tid]
        . zUser owner
        . zConn "conn"
        . json (newTeamMemberDeleteData (Just defPassword))
    )
    !!! do
      const 202 === statusCode

upgradeClientToLH :: (HasCallStack) => UserId -> ClientId -> TestM ()
upgradeClientToLH zusr cid =
  putCapabilities zusr cid [ClientSupportsLegalholdImplicitConsent]

putCapabilities :: (HasCallStack) => UserId -> ClientId -> [ClientCapability] -> TestM ()
putCapabilities zusr cid caps = do
  brig <- viewBrig
  void $
    put
      ( brig
          . zUser zusr
          . paths ["clients", toByteString' cid]
          . json defUpdateClient {updateClientCapabilities = Just $ ClientCapabilityList $ Set.fromList caps}
          . expect2xx
      )

getUsersPrekeysClientUnqualified :: (HasCallStack) => UserId -> UserId -> ClientId -> TestM ResponseLBS
getUsersPrekeysClientUnqualified zusr uid cid = do
  brig <- view tsUnversionedBrig
  get
    ( brig
        . zUser zusr
        . paths ["v1", "users", toByteString' uid, "prekeys", toByteString' cid]
    )

getUsersPrekeyBundleUnqualified :: (HasCallStack) => UserId -> UserId -> TestM ResponseLBS
getUsersPrekeyBundleUnqualified zusr uid = do
  brig <- view tsUnversionedBrig
  get
    ( brig
        . zUser zusr
        . paths ["v1", "users", toByteString' uid, "prekeys"]
    )

getMultiUserPrekeyBundleUnqualified :: (HasCallStack) => UserId -> UserClients -> TestM ResponseLBS
getMultiUserPrekeyBundleUnqualified zusr userClients = do
  brig <- view tsUnversionedBrig
  post
    ( brig
        . zUser zusr
        . paths ["v1", "users", "prekeys"]
        . json userClients
    )

mkProfile :: Qualified UserId -> Name -> UserProfile
mkProfile quid name =
  UserProfile
    { profileQualifiedId = quid,
      profileName = name,
      profilePict = noPict,
      profileTextStatus = Nothing,
      profileAssets = mempty,
      profileAccentId = defaultAccentId,
      profileDeleted = False,
      profileService = Nothing,
      profileHandle = Nothing,
      profileExpire = Nothing,
      profileTeam = Nothing,
      profileEmail = Nothing,
      profileLegalholdStatus = defUserLegalHoldStatus,
      profileSupportedProtocols = defSupportedProtocols,
      profileType = UserTypeRegular,
      profileApp = Nothing,
      profileSearchable = True,
      profileContactStatus = Nothing
    }

-- mock federator

-- | Run the given action on a temporary galley instance with access to a mock
-- federator.
withTempMockFederator' ::
  (MonadIO m, MonadMask m, HasSettingsOverrides m) =>
  Mock LByteString ->
  m b ->
  m (b, [FederatedRequest])
withTempMockFederator' resp action = do
  let mock =
        def
          { handler = runMock (assertFailure . Text.unpack) $ do
              r <- resp
              pure (def {Mock.body = r})
          }
  Mock.withTempMockFederator
    mock
    $ \mockPort -> do
      withSettingsOverrides (\opts -> opts & Opts.federator ?~ Endpoint "127.0.0.1" (fromIntegral mockPort)) action

assertRight :: (MonadIO m, Show a, HasCallStack) => Either a b -> m b
assertRight = \case
  Left e -> liftIO $ assertFailure $ "Expected Right, got Left: " <> show e
  Right x -> pure x

-- | Run a probe several times, until a "good" value materializes or until patience runs out
-- (after ~2secs).
-- If all retries were unsuccessful, 'aFewTimes' will return the last obtained value, even
-- if it does not satisfy the predicate.
aFewTimes :: TestM a -> (a -> Bool) -> TestM a
aFewTimes action good = do
  env <- ask
  liftIO $
    retrying
      (exponentialBackoff 1000 <> limitRetries 11)
      (\_ -> pure . not . good)
      (\_ -> runReaderT (runTestM action) env)

aFewTimesAssertBool :: (HasCallStack) => String -> (a -> Bool) -> TestM a -> TestM ()
aFewTimesAssertBool msg good action = do
  result <- aFewTimes action good
  liftIO $ assertBool msg (good result)

checkUserDeleteEvent :: (HasCallStack) => UserId -> WS.Timeout -> WS.WebSocket -> TestM ()
checkUserDeleteEvent uid timeout_ w = WS.assertMatch_ timeout_ w $ \notif -> do
  let j = Object $ NonEmpty.head (ntfPayload notif)
  let etype = j ^? key "type" . _String
  let euser = j ^? key "id" . _String
  etype @?= Just "user.delete"
  euser @?= Just (UUID.toText (toUUID uid))

checkTeamMemberJoin :: (HasCallStack) => TeamId -> UserId -> WS.WebSocket -> TestM ()
checkTeamMemberJoin tid uid w = WS.assertMatch_ checkTimeout w $ \notif -> do
  ntfTransient notif @?= True
  let e = NonEmpty.head (WS.unpackPayload notif)
  e ^. eventTeam @?= tid
  e ^. eventData @?= EdMemberJoin uid

checkTeamMemberLeave :: (HasCallStack) => TeamId -> UserId -> WS.WebSocket -> TestM ()
checkTeamMemberLeave tid usr w = WS.assertMatch_ checkTimeout w $ \notif -> do
  ntfTransient notif @?= True
  let e = NonEmpty.head (WS.unpackPayload notif)
  e ^. eventTeam @?= tid
  e ^. eventData @?= EdMemberLeave usr

checkTeamUpdateEvent :: (HasCallStack, MonadIO m, MonadCatch m) => TeamId -> TeamUpdateData -> WS.WebSocket -> m ()
checkTeamUpdateEvent tid upd w = WS.assertMatch_ checkTimeout w $ \notif -> do
  ntfTransient notif @?= True
  let e = NonEmpty.head (WS.unpackPayload notif)
  e ^. eventTeam @?= tid
  e ^. eventData @?= EdTeamUpdate upd

checkConvCreateEvent :: (MonadIO m, MonadCatch m) => (HasCallStack) => ConvId -> WS.WebSocket -> m ()
checkConvCreateEvent cid w = WS.assertMatch_ checkTimeout w $ \notif -> do
  ntfTransient notif @?= False
  let e = NonEmpty.head (WS.unpackPayload notif)
  evtType e @?= Conv.ConvCreate
  case evtData e of
    Conv.EdConversation x -> (qUnqualified . cnvQualifiedId) x @?= cid
    Conv.EdConversationMeeting x -> (qUnqualified . cnvQualifiedId) x @?= cid
    other -> assertFailure $ "Unexpected event data: " <> show other

wsAssertConvCreate ::
  (HasCallStack) =>
  Qualified ConvId ->
  Qualified UserId ->
  Notification ->
  IO ()
wsAssertConvCreate conv eventFrom n = do
  let e = NonEmpty.head (WS.unpackPayload n)
  ntfTransient n @?= False
  evtConv e @?= conv
  evtType e @?= Conv.ConvCreate
  evtFrom e @?= EventFromUser eventFrom

wsAssertConvCreateWithRole ::
  (HasCallStack) =>
  Qualified ConvId ->
  Qualified UserId ->
  Qualified UserId ->
  [(Qualified UserId, RoleName)] ->
  Notification ->
  IO ()
wsAssertConvCreateWithRole conv eventFrom selfMember otherMembers n = do
  let e = NonEmpty.head (WS.unpackPayload n)
  ntfTransient n @?= False
  evtConv e @?= conv
  evtType e @?= Conv.ConvCreate
  evtFrom e @?= EventFromUser eventFrom
  fmap (memId . cmSelf) (getConvMembers (evtData e)) @?= Just selfMember
  fmap (sort . cmOthers) (getConvMembers (evtData e)) @?= Just (sort (toOtherMember <$> otherMembers))
  where
    toOtherMember (quid, role) = OtherMember quid Nothing role
    getConvMembers (Conv.EdConversation c) = Just (cnvMembers c)
    getConvMembers (Conv.EdConversationMeeting c) = Just (cnvMembers c)
    getConvMembers _ = Nothing

checkTeamDeleteEvent :: (HasCallStack) => TeamId -> WS.WebSocket -> TestM ()
checkTeamDeleteEvent tid w = WS.assertMatch_ checkTimeout w $ \notif -> do
  ntfTransient notif @?= False
  let e = NonEmpty.head (WS.unpackPayload notif)
  e ^. eventTeam @?= tid
  e ^. eventData @?= EdTeamDelete

checkConvDeleteEvent :: (HasCallStack) => Qualified ConvId -> TeamId -> WS.WebSocket -> TestM ()
checkConvDeleteEvent cid tid w = WS.assertMatch_ checkTimeout w $ \notif -> do
  ntfTransient notif @?= False
  let e = NonEmpty.head (WS.unpackPayload notif)
  evtType e @?= Conv.ConvDelete
  evtConv e @?= cid
  evtData e @?= Conv.EdConvDelete
  evtTeam e @?= (Just tid)

checkConvMemberLeaveEvent :: (HasCallStack) => Qualified ConvId -> Qualified UserId -> WS.WebSocket -> TestM ()
checkConvMemberLeaveEvent cid usr w = WS.assertMatch_ checkTimeout w $ \notif -> do
  ntfTransient notif @?= False
  let e = NonEmpty.head (WS.unpackPayload notif)
  evtConv e @?= cid
  evtType e @?= Conv.MemberLeave
  case evtData e of
    Conv.EdMembersLeave _ mm -> mm @?= Conv.QualifiedUserIdList [usr]
    other -> assertFailure $ "Unexpected event data: " <> show other

checkTimeout :: WS.Timeout
checkTimeout = 60 # Second

-- | The function is used in conjuction with 'withTempMockFederator' to mock
-- responses by Brig on the mocked side of federation.
mockedFederatedBrigResponse :: [(Qualified UserId, Text)] -> Mock LByteString
mockedFederatedBrigResponse users = do
  guardComponent Brig
  mockReply [mkProfile mem (Name name) | (mem, name) <- users]

parseFedRequest :: (FromJSON a) => FederatedRequest -> Either String a
parseFedRequest fr = eitherDecode (frBody fr)

assertOne :: (HasCallStack, MonadIO m, Show a) => [a] -> m a
assertOne [a] = pure a
assertOne xs = liftIO . error $ "Expected exactly one element, found " <> show xs

assertTwo :: (HasCallStack, Show a) => [a] -> (a, a)
assertTwo [a, b] = (a, b)
assertTwo xs = error $ "Expected two elements, found " <> show xs

assertJust :: (HasCallStack, MonadIO m) => Maybe a -> m a
assertJust (Just a) = pure a
assertJust Nothing = liftIO $ error "Expected Just, got Nothing"

iUpsertOne2OneConversation :: UpsertOne2OneConversationRequest -> TestM ResponseLBS
iUpsertOne2OneConversation req = do
  galley <- viewGalley
  post (galley . path "/i/conversations/one2one/upsert" . Bilge.json req)

createOne2OneConvWithRemote :: (HasCallStack) => Local UserId -> Remote UserId -> TestM ()
createOne2OneConvWithRemote localUser remoteUser = do
  let convId = one2OneConvId BaseProtocolProteusTag (tUntagged localUser) (tUntagged remoteUser)
      mkRequest actor =
        UpsertOne2OneConversationRequest
          { uooLocalUser = localUser,
            uooRemoteUser = remoteUser,
            uooActor = actor,
            uooActorDesiredMembership = Included,
            uooConvId = convId
          }

  iUpsertOne2OneConversation (mkRequest LocalActor) !!! const 200 === statusCode
  iUpsertOne2OneConversation (mkRequest RemoteActor) !!! const 200 === statusCode

generateRemoteAndConvId :: Bool -> Local UserId -> TestM (Remote UserId, Qualified ConvId)
generateRemoteAndConvId = generateRemoteAndConvIdWithDomain (Domain "far-away.example.com")

generateRemoteAndConvIdWithDomain :: Domain -> Bool -> Local UserId -> TestM (Remote UserId, Qualified ConvId)
generateRemoteAndConvIdWithDomain remoteDomain shouldBeLocal lUserId = do
  other <- Qualified <$> randomId <*> pure remoteDomain
  let convId = one2OneConvId BaseProtocolProteusTag (tUntagged lUserId) other
  if shouldBeLocal == isLocal lUserId convId
    then pure (qTagUnsafe other, convId)
    else generateRemoteAndConvIdWithDomain remoteDomain shouldBeLocal lUserId

spawn :: (HasCallStack) => CreateProcess -> Maybe ByteString -> IO ByteString
spawn cp minput = do
  (mout, ex) <- withCreateProcess
    cp
      { std_out = CreatePipe,
        std_in = if isJust minput then CreatePipe else Inherit
      }
    $ \minh mouth _ ph ->
      let writeInput = for_ ((,) <$> minput <*> minh) $ \(input, inh) ->
            BS.hPutStr inh input >> hClose inh
          readOutput = (,) <$> traverse BS.hGetContents mouth <*> waitForProcess ph
       in snd <$> concurrently writeInput readOutput
  case (mout, ex) of
    (Just out, ExitSuccess) -> pure out
    _ -> assertFailure "Process didn't finish successfully"

decodeMLSError :: (ParseMLS a) => ByteString -> IO a
decodeMLSError s = case decodeMLS' s of
  Left e -> assertFailure ("Could not parse MLS object: " <> Text.unpack e)
  Right x -> pure x

wsAssertConvReceiptModeUpdate :: Qualified ConvId -> Qualified UserId -> ReceiptMode -> Notification -> IO ()
wsAssertConvReceiptModeUpdate conv usr new n = do
  let e = NonEmpty.head (WS.unpackPayload n)
  ntfTransient n @?= False
  evtConv e @?= conv
  evtType e @?= ConvReceiptModeUpdate
  evtFrom e @?= EventFromUser usr
  evtData e @?= EdConvReceiptModeUpdate (ConversationReceiptModeUpdate new)

wsAssertBackendRemoveProposalWithEpoch :: (HasCallStack) => Qualified UserId -> Qualified ConvId -> LeafIndex -> Epoch -> Notification -> IO ByteString
wsAssertBackendRemoveProposalWithEpoch fromUser convId idx epoch n = do
  bs <- wsAssertBackendRemoveProposal fromUser (Conv <$> convId) idx n
  let msg = fromRight (error "Failed to parse Message") $ decodeMLS' @Message bs
  case msg.content of
    MessagePublic pmsg -> liftIO $ pmsg.content.value.epoch @?= epoch
    _ -> assertFailure "unexpected message content"
  pure bs

wsAssertBackendRemoveProposal :: (HasCallStack) => Qualified UserId -> Qualified ConvOrSubConvId -> LeafIndex -> Notification -> IO ByteString
wsAssertBackendRemoveProposal fromUser cnvOrSubCnv idx n = do
  let e = NonEmpty.head (WS.unpackPayload n)
  ntfTransient n @?= False
  evtConv e @?= (.conv) <$> cnvOrSubCnv
  evtType e @?= MLSMessageAdd
  evtFrom e @?= EventFromUser fromUser
  let bs = getMLSMessageData (evtData e)
  let msg = fromRight (error "Failed to parse Message") $ decodeMLS' @Message bs
  liftIO $ case msg.content of
    MessagePublic pmsg -> do
      pmsg.content.value.sender @?= SenderExternal 0
      case pmsg.content.value.content of
        FramedContentProposal prop -> case prop.value of
          RemoveProposal removedIdx -> removedIdx @?= idx
          otherProp -> assertFailure $ "Expected RemoveProposal but got " <> show otherProp
        otherPayload -> assertFailure $ "Expected ProposalMessage but got " <> show otherPayload
    _ -> assertFailure $ "Expected PublicMessage"
  pure bs
  where
    getMLSMessageData :: Conv.EventData -> ByteString
    getMLSMessageData (EdMLSMessage bs) = bs
    getMLSMessageData d = error ("Expected EdMLSMessage, but got " <> show d)

wsAssertAddProposal ::
  (HasCallStack) =>
  Qualified UserId ->
  Qualified ConvId ->
  Notification ->
  IO ByteString
wsAssertAddProposal fromUser convId n = do
  let e = NonEmpty.head (WS.unpackPayload n)
  ntfTransient n @?= False
  evtConv e @?= convId
  evtType e @?= MLSMessageAdd
  evtFrom e @?= EventFromUser fromUser
  let bs = getMLSMessageData (evtData e)
  let msg = fromRight (error "Failed to parse Message 'MLSPlaintext") $ decodeMLS' @Message bs
  liftIO $ case msg.content of
    MessagePublic pmsg -> do
      pmsg.content.value.sender @?= SenderNewMemberProposal
      case pmsg.content.value.content of
        FramedContentProposal prop -> case prop.value of
          AddProposal _ -> pure ()
          otherProp -> assertFailure $ "Expected AddProposal but got " <> show otherProp
        otherPayload -> assertFailure $ "Expected ProposalMessage but got " <> show otherPayload
    _ -> assertFailure $ "Expected PublicMessage"
  pure bs
  where
    getMLSMessageData :: Conv.EventData -> ByteString
    getMLSMessageData (EdMLSMessage bs) = bs
    getMLSMessageData d = error ("Excepected EdMLSMessage, but got " <> show d)

createAndConnectUsers :: [Maybe Text] -> TestM [Qualified UserId]
createAndConnectUsers domains = do
  localDomain <- viewFederationDomain
  users <- for domains $ maybe randomQualifiedUser (randomQualifiedId . Domain)
  let userPairs = do
        t <- tails users
        (a, others) <- maybeToList (uncons t)
        b <- others
        pure (a, b)
  for_ userPairs $ \(a, b) ->
    case (qDomain a == localDomain, qDomain b == localDomain) of
      (True, True) ->
        connectUsers (qUnqualified a) (pure (qUnqualified b))
      (True, False) -> connectWithRemoteUser (qUnqualified a) b
      (False, True) -> connectWithRemoteUser (qUnqualified b) a
      (False, False) -> pure ()
  pure users
