-- This file is part of the Wire Server implementation.
--
-- Copyright (C) 2023 Wire Swiss GmbH <opensource@wire.com>
--
-- This program is free software: you can redistribute it and/or modify it under
-- the terms of the GNU Affero General Public License as published by the Free
-- Software Foundation, either version 3 of the License, or (at your option) any
-- later version.
--
-- This program is distributed in the hope that it will be useful, but WITHOUT
-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more
-- details.
--
-- You should have received a copy of the GNU Affero General Public License along
-- with this program. If not, see <https://www.gnu.org/licenses/>.
module Test.LegalHold where

import API.Brig
import API.BrigCommon as BrigC
import qualified API.BrigInternal as BrigI
import API.Common
import API.Galley
import API.GalleyInternal hiding (getConversation)
import Control.Error (MaybeT (MaybeT), runMaybeT)
import Control.Lens ((.~), (^?), (^?!))
import Control.Monad.Extra (findM)
import Control.Monad.Reader (asks, local)
import Control.Monad.Trans.Class (lift)
import Data.Aeson.Lens
import qualified Data.ByteString.Char8 as BS8
import Data.ByteString.Lazy (LazyByteString)
import Data.List.Extra (trim)
import qualified Data.Map as Map
import qualified Data.ProtoLens as Proto
import Data.ProtoLens.Labels ()
import qualified Data.Set as Set
import qualified Data.Text as T
import GHC.Stack
import MLS.Util
import Network.Wai (Request (pathInfo, requestMethod))
import Notifications
import Numeric.Lens (hex)
import qualified Proto.Otr as Proto
import qualified Proto.Otr_Fields as Proto
import SetupHelpers
import Testlib.MockIntegrationService
import Testlib.Prekeys
import Testlib.Prelude
import UnliftIO (Chan, readChan, timeout)

testLHPreventAddingNonConsentingUsers :: (HasCallStack) => LhApiVersion -> App ()
testLHPreventAddingNonConsentingUsers v = do
  withMockServer def (lhMockAppV v) $ \lhDomAndPort _chan -> do
    (owner, tid, [alice, alex]) <- createTeam OwnDomain 3
    for_ [owner, alice, alex] getSelfConversation

    legalholdWhitelistTeam tid owner >>= assertSuccess
    legalholdIsTeamInWhitelist tid owner >>= assertSuccess
    postLegalHoldSettings tid owner (mkLegalHoldSettings lhDomAndPort) >>= assertStatus 201

    george <- randomUser OwnDomain def
    georgeQId <- objQidObject george
    hannes <- randomUser OwnDomain def
    hannesQId <- objQidObject hannes
    for_ [george, hannes] getSelfConversation

    connectUsers [alice, george, hannes]
    connectUsers [alex, george, hannes]
    conv <- postConversation alice (defProteus {qualifiedUsers = [alex], team = Just tid}) >>= getJSON 201

    -- the guest should be added to the conversation
    bindResponse (addMembers alice conv def {users = [georgeQId]}) $ \resp -> do
      resp.status `shouldMatchInt` 200
      resp.json %. "type" `shouldMatch` "conversation.member-join"

    -- assert that the guest is in the conversation
    checkConvHasOtherMembers conv alice [alex, george]

    -- now request legalhold for alex (but not alice)
    requestLegalHoldDevice tid owner alex >>= assertSuccess

    -- the guest should not be removed from the conversation before approving
    checkConvHasOtherMembers conv alice [alex, george]

    -- it should be possible to add the another guest while the LH device is not approved
    addMembers alex conv def {users = [hannesQId]} `bindResponse` \resp -> do
      resp.status `shouldMatchInt` 200
      resp.json %. "type" `shouldMatch` "conversation.member-join"
    checkConvHasOtherMembers conv alice [alex, george, hannes]

    approveLegalHoldDevice tid alex defPassword >>= assertSuccess
    -- the guest should be removed from the conversation
    checkConvHasOtherMembers conv alice [alex]

    -- it should not be possible neither for alex nor for alice to add the guest back
    addMembers alex conv def {users = [georgeQId]}
      >>= assertLabel 403 "not-connected"

    addMembers alice conv def {users = [georgeQId]}
      >>= assertLabel 403 "missing-legalhold-consent"
  where
    checkConvHasOtherMembers :: (HasCallStack) => Value -> Value -> [Value] -> App ()
    checkConvHasOtherMembers conv u us =
      bindResponse (getConversation u conv) $ \resp -> do
        resp.status `shouldMatchInt` 200
        mems <-
          resp.json %. "members.others"
            & asList >>= traverse \m -> do
              m %. "qualified_id"
        mems `shouldMatchSet` forM us (\m -> m %. "qualified_id")

testLHGetAndUpdateSettings :: (HasCallStack) => Consent -> LhApiVersion -> App ()
testLHGetAndUpdateSettings consent v = ensureLHFeatureConfigForServer consent $ \dom -> do
  withMockServer def (lhMockAppV v) $ \lhDomAndPort _chan -> do
    (owner, tid, [alice]) <- createTeam dom 2
    for_ [owner, alice] getSelfConversation

    stranger <- randomUser dom def
    void $ getSelfConversation stranger

    let getSettingsWorks :: (HasCallStack) => Value -> String -> App ()
        getSettingsWorks target status = bindResponse (getLegalHoldSettings tid target) $ \resp -> do
          resp.status `shouldMatchInt` 200
          resp.json %. "status" `shouldMatch` status

        getSettingsFails :: (HasCallStack) => Value -> App ()
        getSettingsFails target = bindResponse (getLegalHoldSettings tid target) $ \resp -> do
          resp.status `shouldMatchInt` 403
          resp.json %. "label" `shouldMatch` "no-team-member"

    getSettingsFails stranger
    getSettingsWorks owner "disabled"
    getSettingsWorks alice "disabled"

    whitelistOrEnableLHForTeam consent dom tid owner

    getSettingsFails stranger
    getSettingsWorks owner "not_configured"
    getSettingsWorks alice "not_configured"

    let lhSettings = mkLegalHoldSettings lhDomAndPort
    bindResponse (postLegalHoldSettings tid owner lhSettings) $ \resp -> do
      resp.status `shouldMatchInt` 201

    bindResponse (getLegalHoldSettings tid alice) $ \resp ->
      do
        resp.status `shouldMatchInt` 200
        assertFieldMissing resp.json "label"
        (resp.json %. "settings" %. "auth_token") `shouldMatch` (lhSettings %. "auth_token")
        (resp.json %. "settings" %. "base_url") `shouldMatch` (lhSettings %. "base_url")
        (resp.json %. "settings" %. "public_key" >>= asString <&> trim)
          `shouldMatch` (lhSettings %. "public_key")
        (resp.json %. "settings" %. "team_id") `shouldMatch` tid
        (resp.json %. "settings" %. "fingerprint" >>= asString <&> length)
          `shouldNotMatch` (0 :: Int)

testLHMessageExchange ::
  (HasCallStack) =>
  TaggedBool "clients1New" ->
  TaggedBool "clients2New" ->
  App ()
testLHMessageExchange (TaggedBool clients1New) (TaggedBool clients2New) = do
  -- We used to throw LegalholdConflictsOldClients if clients didn't have LH capability, but we
  -- don't do that any more because that broke things.
  -- Related: https://github.com/wireapp/wire-server/pull/4056
  withMockServer def lhMockApp $ \lhDomAndPort _chan -> do
    (owner, tid, [mem1, mem2]) <- createTeam OwnDomain 3
    for_ [owner, mem1, mem2] getSelfConversation

    let clientSettings :: Bool -> AddClient
        clientSettings allnew =
          if allnew
            then def {acapabilities = Just ["legalhold-implicit-consent"]} -- (is should be the default)
            else def {acapabilities = Nothing}
    void $ addClient (mem1 %. "qualified_id") (clientSettings clients1New) >>= getJSON 201
    void $ addClient (mem2 %. "qualified_id") (clientSettings clients2New) >>= getJSON 201

    legalholdWhitelistTeam tid owner >>= assertSuccess
    legalholdIsTeamInWhitelist tid owner >>= assertSuccess
    postLegalHoldSettings tid owner (mkLegalHoldSettings lhDomAndPort) >>= assertStatus 201

    conv <- postConversation mem1 (defProteus {qualifiedUsers = [mem2], team = Just tid}) >>= getJSON 201

    let getClients :: Value -> App [Value]
        getClients mem = do
          res <- getClientsQualified mem OwnDomain mem
          val <- getJSON 200 res
          asList val

        assertMessageSendingWorks :: (HasCallStack) => App ()
        assertMessageSendingWorks = do
          clients1 <- getClients mem1
          clients2 <- getClients mem2

          clientIds1 <- traverse objId clients1
          clientIds2 <- traverse objId clients2

          proteusRecipients <- mkProteusRecipients mem1 [(mem1, clientIds1), (mem2, clientIds2)] "hey there"

          let proteusMsg senderClient =
                Proto.defMessage @Proto.QualifiedNewOtrMessage
                  & #sender . Proto.client .~ (senderClient ^?! hex)
                  & #recipients .~ [proteusRecipients]
                  & #reportAll .~ Proto.defMessage

              sender clients =
                let senderClient = head $ filter (\c -> c ^? key (fromString "type") /= Just (toJSON "legalhold")) clients
                 in T.unpack $ senderClient ^?! key (fromString "id") . _String
          postProteusMessage mem1 (conv %. "qualified_id") (proteusMsg (sender clients1)) >>= assertSuccess
          postProteusMessage mem2 (conv %. "qualified_id") (proteusMsg (sender clients2)) >>= assertSuccess

    assertMessageSendingWorks

    requestLegalHoldDevice tid owner mem1 >>= assertSuccess
    assertMessageSendingWorks

    requestLegalHoldDevice tid owner mem2 >>= assertSuccess
    assertMessageSendingWorks

    approveLegalHoldDevice tid (mem1 %. "qualified_id") defPassword >>= assertSuccess
    fmap length (getClients mem1) `shouldMatchInt` 2
    assertMessageSendingWorks

    approveLegalHoldDevice tid (mem2 %. "qualified_id") defPassword >>= assertSuccess
    fmap length (getClients mem2) `shouldMatchInt` 2
    assertMessageSendingWorks

data TestClaimKeys
  = TCKConsentMissing -- (team not whitelisted, that is)
  | TCKConsentAndNewClients
  deriving (Show, Generic)

data LHApprovedOrPending
  = LHApproved
  | LHPending
  deriving (Show, Generic)

-- | Cannot fetch prekeys of LH users if requester has not given consent or has old clients.
testLHClaimKeys :: LHApprovedOrPending -> TestClaimKeys -> App ()
testLHClaimKeys approvedOrPending testmode = do
  withMockServer def lhMockApp $ \lhDomAndPort _chan -> do
    (lowner, ltid, [lmem]) <- createTeam OwnDomain 2
    (powner, ptid, [pmem]) <- createTeam OwnDomain 2
    for_ [lowner, lmem, powner, pmem] getSelfConversation

    legalholdWhitelistTeam ltid lowner >>= assertSuccess
    legalholdIsTeamInWhitelist ltid lowner >>= assertSuccess
    postLegalHoldSettings ltid lowner (mkLegalHoldSettings lhDomAndPort) >>= assertStatus 201

    requestLegalHoldDevice ltid lowner lmem >>= assertSuccess
    case approvedOrPending of
      LHApproved -> approveLegalHoldDevice ltid (lmem %. "qualified_id") defPassword >>= assertSuccess
      LHPending -> pure ()

    pks <- getPrekeys 10
    lpk <- getLastPrekey
    let addc caps = addClient pmem (settings caps) >>= assertSuccess
        settings caps =
          def
            { prekeys = Just pks,
              lastPrekey = Just lpk,
              acapabilities = caps
            }
     in addc $ Just ["legalhold-implicit-consent"]

    case testmode of
      TCKConsentMissing -> pure ()
      TCKConsentAndNewClients -> do
        legalholdWhitelistTeam ptid powner >>= assertSuccess
        legalholdIsTeamInWhitelist ptid powner >>= assertSuccess

    llhdevs :: [String] <- do
      let getCls :: Value -> App [String]
          getCls mem = do
            res <- getClientsQualified mem OwnDomain mem
            val <- getJSON 200 res
            cls <- asList val
            objId `mapM` cls
      getCls lmem

    let assertResp :: (HasCallStack) => Response -> App ()
        assertResp resp = case (testmode, llhdevs) of
          (TCKConsentMissing, (_ : _)) -> do
            resp.status `shouldMatchInt` 403
            resp.json %. "label" `shouldMatch` "missing-legalhold-consent"
          (TCKConsentAndNewClients, (_ : _)) -> do
            resp.status `shouldMatchInt` 200
          (_, []) -> do
            -- no lh devices: no reason to be shy!
            resp.status `shouldMatchInt` 200

    bindResponse (getUsersPrekeyBundle pmem (lmem %. "qualified_id")) assertResp
    case llhdevs of
      [llhdev] ->
        -- retrieve lh client if /a
        bindResponse (getUsersPrekeysClient pmem (lmem %. "qualified_id") llhdev) assertResp
      [] ->
        -- we're probably doing the LHPending thing right now
        pure ()
      bad@(_ : _ : _) ->
        -- fail if there is more than one.
        assertFailure ("impossible -- more than one LH device: " <> show bad)

    slmemdom <- asString $ lmem %. "qualified_id.domain"
    slmemid <- asString $ lmem %. "qualified_id.id"
    let userClients = Map.fromList [(slmemdom, Map.fromList [(slmemid, Set.fromList llhdevs)])]
    bindResponse (getMultiUserPrekeyBundle pmem userClients) $ assertResp

testLHAddClientManually :: App ()
testLHAddClientManually = do
  (_owner, _tid, [mem1]) <- createTeam OwnDomain 2
  for_ [_owner, mem1] getSelfConversation

  bindResponse (addClient mem1 def {ctype = "legalhold"}) $ \resp -> do
    assertLabel 400 "client-error" resp
    -- we usually don't test the human-readable "message", but in this case it is important to
    -- make sure the reason is the right one, and not eg. "LH service not present", or some
    -- other unspecific client error.
    resp.json %. "message" `shouldMatch` "LegalHold clients cannot be added manually. LegalHold must be enabled on this user by an admin"

testLHDeleteClientManually :: App ()
testLHDeleteClientManually = do
  (_owner, _tid, [mem1]) <- createTeam OwnDomain 2
  for_ [_owner, mem1] getSelfConversation

  cid <- bindResponse (BrigI.addClient mem1 def {ctype = "legalhold"}) $ \resp -> do
    resp.status `shouldMatchInt` 201
    asString =<< resp.json %. "id"
  bindResponse (deleteClient mem1 cid) $ \resp -> do
    resp.status `shouldMatchInt` 400
    resp.json %. "label" `shouldMatch` "client-error"
    -- we usually don't test the human-readable "message", but in this case it is important to
    -- make sure the reason is the right one, and not eg. "LH service not present", or some
    -- other unspecific client error.
    resp.json %. "message" `shouldMatch` "LegalHold clients cannot be deleted. LegalHold must be disabled on this user by an admin"

testLHRequestDevice :: Consent -> LhApiVersion -> App ()
testLHRequestDevice consent v = ensureLHFeatureConfigForServer consent $ \dom -> do
  (alice, tid, [bob]) <- createTeam dom 2
  for_ [alice, bob] getSelfConversation

  let reqNotEnabled requester requestee =
        requestLegalHoldDevice tid requester requestee
          >>= assertLabel 403 "legalhold-not-enabled"

  reqNotEnabled alice bob

  lpk <- getLastPrekey
  pks <- replicateM 3 getPrekey

  withMockServer def (lhMockAppWithPrekeys v MkCreateMock {nextLastPrey = pure lpk, somePrekeys = pure pks}) \lhDomAndPort _chan -> do
    let statusShouldBe :: (HasCallStack) => String -> App ()
        statusShouldBe status =
          legalholdUserStatus tid alice bob `bindResponse` \resp -> do
            resp.status `shouldMatchInt` 200
            resp.json %. "status" `shouldMatch` status

    -- the user has not agreed to be under legalhold
    for_ [alice, bob] \requester -> do
      reqNotEnabled requester bob
      statusShouldBe "no_consent"

    whitelistOrEnableLHForTeam consent dom tid alice
    postLegalHoldSettings tid alice (mkLegalHoldSettings lhDomAndPort) >>= assertSuccess
    statusShouldBe case consent of
      Implicit -> "disabled"
      Explicit -> "no_consent"

    let expected = case consent of
          Implicit -> 204
          Explicit -> 201
     in consentToLegalHold tid bob defPassword >>= assertStatus expected
    requestLegalHoldDevice tid alice bob >>= assertStatus 201
    statusShouldBe "pending"

    -- requesting twice should be idempotent wrt the approval
    -- mind that requesting twice means two "user.legalhold-request" notifications
    -- for the clients of the user under legalhold (bob)
    requestLegalHoldDevice tid alice bob >>= assertStatus 204
    statusShouldBe "pending"

    [bobc1, bobc2] <- replicateM 2 do
      objId $ addClient bob def `bindResponse` getJSON 201
    for_ [bobc1, bobc2] \client ->
      awaitNotificationClient bob client noValue isUserLegalholdRequestNotif >>= \notif -> do
        notif %. "payload.0.last_prekey" `shouldMatch` lpk
        notif %. "payload.0.id" `shouldMatch` objId bob

-- | pops a channel until it finds an event that returns a 'Just'
--   upon running the matcher function
checkChan :: (HasCallStack) => Chan t -> (t -> App (Maybe a)) -> App a
checkChan chan match = do
  tSecs <- asks ((* 1_000_000) . timeOutSeconds)

  maybe (assertFailure "checkChan: timed out") pure =<< timeout tSecs do
    let go = readChan chan >>= match >>= maybe go pure
    go

-- | like 'checkChan' but throws away the request and decodes the body
checkChanVal :: (HasCallStack) => Chan (t, LazyByteString) -> (Value -> MaybeT App a) -> App a
checkChanVal chan match = checkChan chan \(_, bs) -> runMaybeT do
  MaybeT (pure (decode bs)) >>= match

testLHApproveDevice :: Consent -> App ()
testLHApproveDevice consent = ensureLHFeatureConfigForServer consent $ \dom -> do
  -- team users
  -- alice (boss) and bob and charlie (member)
  (alice, tid, [bob, charlie]) <- createTeam dom 3
  for_ [alice, bob, charlie] getSelfConversation

  -- ollie the outsider
  ollie <- do
    o <- randomUser dom def
    connectTwoUsers o alice
    pure o

  -- sandy the stranger
  sandy <- randomUser dom def
  for_ [ollie, sandy] getSelfConversation

  whitelistOrEnableLHForTeam consent dom tid alice
  approveLegalHoldDevice tid (bob %. "qualified_id") defPassword
    >>= assertLabel 412 "legalhold-not-pending"

  withMockServer def lhMockApp \lhDomAndPort chan -> do
    postLegalHoldSettings tid alice (mkLegalHoldSettings lhDomAndPort)
      >>= assertStatus 201
    let expected = case consent of
          Implicit -> 204
          Explicit -> 201
     in consentToLegalHold tid bob defPassword >>= assertStatus expected
    requestLegalHoldDevice tid alice bob
      >>= assertStatus 201

    let uidsAndTidMatch val = do
          actualTid <-
            lookupFieldM val "team_id"
              >>= lift
              . asString
          actualUid <-
            lookupFieldM val "user_id"
              >>= lift
              . asString
          bobUid <- lift $ objId bob

          -- we pass the check on equality
          unless ((actualTid, actualUid) == (tid, bobUid)) do
            mzero

    checkChanVal chan uidsAndTidMatch

    -- the team owner cannot approve for bob
    approveLegalHoldDevice' tid alice bob defPassword
      >>= assertLabel 403 "access-denied"
    -- bob needs to provide a password
    approveLegalHoldDevice tid bob "wrong-password"
      >>= assertLabel 403 "access-denied"
    -- now bob finally found his password
    approveLegalHoldDevice tid bob defPassword
      >>= assertStatus 200

    let matchAuthToken val =
          lookupFieldM val "refresh_token"
            >>= lift
            . asString

    checkChanVal chan matchAuthToken
      >>= renewToken bob
      >>= assertStatus 200

    lhdId <- lhDeviceIdOf bob

    legalholdUserStatus tid alice bob `bindResponse` \resp -> do
      resp.status `shouldMatchInt` 200
      resp.json %. "client.id" `shouldMatch` lhdId
      resp.json %. "status" `shouldMatch` "enabled"

    replicateM 2 do
      objId $ addClient bob def `bindResponse` getJSON 201
      >>= traverse_ \client ->
        awaitNotificationClient bob client noValue isUserClientAddNotif >>= \notif -> do
          notif %. "payload.0.client.type" `shouldMatch` "legalhold"
          notif %. "payload.0.client.class" `shouldMatch` "legalhold"

    -- the other team members receive a notification about the
    -- legalhold device being approved in their team
    for_ [alice, charlie] \user -> do
      awaitNotification user noValue isUserLegalholdEnabledNotif >>= \notif -> do
        notif %. "payload.0.id" `shouldMatch` objId bob
    for_ [ollie, sandy] \outsider -> do
      outsiderClient <- objId $ addClient outsider def `bindResponse` getJSON 201
      assertNoNotifications outsider outsiderClient Nothing isUserLegalholdEnabledNotif

testLHGetDeviceStatus :: (HasCallStack) => Consent -> LhApiVersion -> App ()
testLHGetDeviceStatus consent v = ensureLHFeatureConfigForServer consent $ \dom -> do
  -- team users
  -- alice (team owner) and bob (member)
  (alice, tid, [bob]) <- createTeam dom 2
  for_ [alice, bob] getSelfConversation

  for_ [alice, bob] \user -> do
    legalholdUserStatus tid alice user `bindResponse` \resp -> do
      resp.status `shouldMatchInt` 200
      resp.json %. "status" `shouldMatch` "no_consent"

  lpk <- getLastPrekey
  pks <- replicateM 3 getPrekey

  withMockServer
    def
    do lhMockAppWithPrekeys v MkCreateMock {nextLastPrey = pure lpk, somePrekeys = pure pks}
    \lhDomAndPort _chan -> do
      whitelistOrEnableLHForTeam consent dom tid alice
      legalholdUserStatus tid alice bob `bindResponse` \resp -> do
        resp.status `shouldMatchInt` 200
        resp.json %. "status" `shouldMatch` case consent of
          Implicit -> "disabled"
          Explicit -> "no_consent"

        lookupField resp.json "last_prekey"
          >>= assertNothing
        runMaybeT (lookupFieldM resp.json "client" >>= flip lookupFieldM "id")
          >>= assertNothing

      -- the status messages for these have already been tested
      postLegalHoldSettings tid alice (mkLegalHoldSettings lhDomAndPort)
        >>= assertStatus 201

      let expected = case consent of
            Implicit -> 204
            Explicit -> 201
       in consentToLegalHold tid bob defPassword >>= assertStatus expected
      requestLegalHoldDevice tid alice bob
        >>= assertStatus 201

      approveLegalHoldDevice tid bob defPassword
        >>= assertStatus 200

      lhdId <- lhDeviceIdOf bob
      legalholdUserStatus tid alice bob `bindResponse` \resp -> do
        resp.status `shouldMatchInt` 200
        resp.json %. "status" `shouldMatch` "enabled"
        resp.json %. "last_prekey" `shouldMatch` lpk
        resp.json %. "client.id" `shouldMatch` lhdId

      requestLegalHoldDevice tid alice bob
        >>= assertLabel 409 "legalhold-already-enabled"

-- | this sets the timeout to a higher number; we need
--   this because the SQS queue on the brig is super slow
--   and that's why client.remove events arrive really late
--
--   FUTUREWORK(mangoiv): improve the speed of internal
--   event queuing
setTimeoutTo :: Int -> Env -> Env
setTimeoutTo tSecs env = env {timeOutSeconds = tSecs}

testLHDisableForUser :: (HasCallStack) => Consent -> App ()
testLHDisableForUser consent = ensureLHFeatureConfigForServer consent $ \dom -> do
  (alice, tid, [bob]) <- createTeam dom 2
  for_ [alice, bob] getSelfConversation

  withMockServer def lhMockApp \lhDomAndPort chan -> do
    setUpLHDevice consent dom tid alice bob lhDomAndPort

    awaitNotification bob noValue isUserClientAddNotif >>= \notif -> do
      notif %. "payload.0.client.type" `shouldMatch` "legalhold"
      notif %. "payload.0.client.class" `shouldMatch` "legalhold"

    -- only an admin can disable legalhold
    disableLegalHold tid bob bob defPassword
      >>= assertLabel 403 "operation-denied"

    disableLegalHold tid alice bob "fix ((\"the password always is \" <>) . show)"
      >>= assertLabel 403 "access-denied"

    disableLegalHold tid alice bob defPassword
      >>= assertStatus 200

    checkChan chan \(req, _) -> runMaybeT do
      unless
        do
          BS8.unpack req.requestMethod
            == "POST"
            && req.pathInfo
            == (T.pack <$> ["legalhold", "remove"])
        mzero

    void $ local (setTimeoutTo 90) do
      awaitNotification bob noValue isUserClientRemoveNotif
        *> awaitNotification bob noValue isUserLegalholdDisabledNotif

    bobId <- objId bob
    lhClients <-
      BrigI.getClientsFull bob [bobId] `bindResponse` \resp -> do
        resp.json %. bobId
          & asList
            >>= filterM \val -> (== "legalhold") <$> (val %. "type" & asString)

    shouldBeEmpty lhClients

testLHEnablePerTeam :: (HasCallStack) => Consent -> LhApiVersion -> App ()
testLHEnablePerTeam consent v = ensureLHFeatureConfigForServer consent $ \dom -> do
  -- team users
  -- alice (team owner) and bob (member)
  (alice, tid, [bob]) <- createTeam dom 2
  for_ [alice, bob] getSelfConversation

  legalholdIsEnabled tid alice `bindResponse` \resp -> do
    resp.status `shouldMatchInt` 200
    resp.json %. "lockStatus" `shouldMatch` "unlocked"
    resp.json %. "status" `shouldMatch` "disabled"

  withMockServer def (lhMockAppV v) \lhDomAndPort _chan -> do
    setUpLHDevice consent dom tid alice bob lhDomAndPort

    legalholdUserStatus tid alice bob `bindResponse` \resp -> do
      resp.status `shouldMatchInt` 200
      resp.json %. "status" `shouldMatch` "enabled"

      putLegalholdStatus tid alice "disabled"
        `bindResponse` case consent of
          Implicit -> assertLabel 403 "legalhold-whitelisted-only"
          Explicit -> assertStatus 200

    -- the put doesn't have any influence on the status being "enabled"
    legalholdUserStatus tid alice bob `bindResponse` \resp -> do
      resp.status `shouldMatchInt` 200
      resp.json %. "status" `shouldMatch` case consent of
        Implicit -> "enabled"
        Explicit -> "disabled"

testLHGetMembersIncludesStatus :: LhApiVersion -> App ()
testLHGetMembersIncludesStatus v = do
  -- team users
  -- alice (team owner) and bob (member)
  (alice, tid, [bob]) <- createTeam OwnDomain 2
  for_ [alice, bob] getSelfConversation

  let statusShouldBe :: String -> App ()
      statusShouldBe status = do
        getTeamMembers alice tid `bindResponse` \resp -> do
          resp.status `shouldMatchInt` 200
          [bobMember] <-
            resp.json %. "members"
              & asList >>= filterM \u -> do
                (==) <$> asString (u %. "user") <*> objId bob
          bobMember %. "legalhold_status" `shouldMatch` status

  statusShouldBe "no_consent"
  withMockServer def (lhMockAppV v) \lhDomAndPort _chan -> do
    statusShouldBe "no_consent"

    legalholdWhitelistTeam tid alice
      >>= assertStatus 200

    -- the status messages for these have already been tested
    postLegalHoldSettings tid alice (mkLegalHoldSettings lhDomAndPort)
      >>= assertStatus 201

    -- legalhold has been requested but is disabled
    statusShouldBe "disabled"

    requestLegalHoldDevice tid alice bob
      >>= assertStatus 201

    -- legalhold has been set to pending after requesting device
    statusShouldBe "pending"

    approveLegalHoldDevice tid bob defPassword
      >>= assertStatus 200

    -- bob has accepted the legalhold device
    statusShouldBe "enabled"

testLHConnectionsWithNonConsentingUsers :: LhApiVersion -> App ()
testLHConnectionsWithNonConsentingUsers v = do
  (alice, tid, []) <- createTeam OwnDomain 1
  bob <- randomUser OwnDomain def
  carl <- randomUser OwnDomain def
  dee <- randomUser OwnDomain def
  for_ [alice, bob, carl, dee] getSelfConversation

  legalholdWhitelistTeam tid alice
    >>= assertStatus 200

  withMockServer def (lhMockAppV v) \lhDomAndPort _chan -> do
    postLegalHoldSettings tid alice (mkLegalHoldSettings lhDomAndPort)
      >>= assertStatus 201

    requestLegalHoldDevice tid alice alice
      >>= assertStatus 201

    -- Connections are not blocked before LH is approved by alice
    connectTwoUsers alice bob
    bobConvId <- getConnection alice bob `bindResponse` \resp -> resp.json %. "qualified_conversation"

    postConnection dee alice >>= assertSuccess
    deeConvId <- getConnection alice dee `bindResponse` \resp -> resp.json %. "qualified_conversation"

    approveLegalHoldDevice tid alice defPassword
      >>= assertStatus 200

    -- Connections with bob and dee are now in missing-legalhold-consent state
    -- and the 1:1 convs are broken
    assertConnection alice bob "missing-legalhold-consent"
    assertConnection bob alice "missing-legalhold-consent"
    getConversation bob bobConvId
      >>= assertLabel 403 "access-denied"

    assertConnection alice dee "missing-legalhold-consent"
    assertConnection dee alice "missing-legalhold-consent"
    getConversation dee deeConvId
      >>= assertLabel 403 "access-denied"

    -- Connections are blocked after alice approves the LH device
    postConnection carl alice
      >>= assertLabel 403 "missing-legalhold-consent"
    postConnection alice carl
      >>= assertLabel 403 "missing-legalhold-consent"

    disableLegalHold tid alice alice defPassword
      >>= assertStatus 200

    -- Disabling LH restores connection status and 1:1 convs
    assertConnection alice bob "accepted"
    assertConnection bob alice "accepted"
    getConversation bob bobConvId `bindResponse` \resp -> do
      resp.status `shouldMatchInt` 200
      resp.json %. "members.others.0.qualified_id" `shouldMatch` objQidObject alice

    assertConnection alice dee "pending"
    assertConnection dee alice "sent"
    getConversation dee deeConvId `bindResponse` \resp -> do
      resp.status `shouldMatchInt` 200
      resp.json %. "members.others.0.qualified_id" `shouldMatch` objQidObject alice

testLHConnectionsWithConsentingUsers :: LhApiVersion -> App ()
testLHConnectionsWithConsentingUsers v = do
  (alice, teamA, []) <- createTeam OwnDomain 1
  (bob, teamB, [barbara]) <- createTeam OwnDomain 2
  for_ [alice, bob, barbara] getSelfConversation

  legalholdWhitelistTeam teamA alice
    >>= assertStatus 200
  legalholdWhitelistTeam teamB bob
    >>= assertStatus 200

  withMockServer def (lhMockAppV v) \lhDomAndPort _chan -> do
    postLegalHoldSettings teamA alice (mkLegalHoldSettings lhDomAndPort)
      >>= assertStatus 201

    requestLegalHoldDevice teamA alice alice
      >>= assertStatus 201

    -- Connections are not blocked before LH is approved by alice
    connectTwoUsers alice bob

    approveLegalHoldDevice teamA alice defPassword
      >>= assertStatus 200

    -- Connection with bob is now in whatever state
    getConnection bob alice `bindResponse` \resp -> do
      resp.status `shouldMatchInt` 200
      resp.json %. "status" `shouldMatch` "accepted"

    -- Connections are not blocked after alice approves the LH device because
    -- teamB has implicit consent
    connectTwoUsers alice barbara

data GroupConvAdmin
  = LegalholderIsAdmin
  | PeerIsAdmin
  | BothAreAdmins
  deriving (Show, Generic)

-- | If a member of an existing conversation is assigned a LH device, users are removed from
-- the conversation until policy conflicts are resolved.
--
-- As to who gets to stay:
-- - admins will stay over members
-- - local members will stay over remote members.
testLHNoConsentRemoveFromGroup :: LHApprovedOrPending -> GroupConvAdmin -> App ()
testLHNoConsentRemoveFromGroup approvedOrPending admin = do
  (alice, tidAlice, []) <- createTeam OwnDomain 1
  (bob, tidBob, []) <- createTeam OwnDomain 1
  for_ [alice, bob] getSelfConversation

  legalholdWhitelistTeam tidAlice alice >>= assertStatus 200
  withMockServer def lhMockApp \lhDomAndPort _chan -> do
    postLegalHoldSettings tidAlice alice (mkLegalHoldSettings lhDomAndPort) >>= assertStatus 201
    withWebSockets [alice, bob] \[aws, bws] -> do
      connectTwoUsers alice bob
      qConvId <- do
        let (inviter, tidInviter, invitee, inviteeRole) = case admin of
              LegalholderIsAdmin -> (alice, tidAlice, bob, "wire_member")
              BothAreAdmins -> (alice, tidAlice, bob, "wire_admin")
              PeerIsAdmin -> (bob, tidBob, alice, "wire_member")

        let createConv = defProteus {qualifiedUsers = [invitee], newUsersRole = inviteeRole, team = Just tidInviter}
        postConversation inviter createConv `bindResponse` \resp -> do
          otherMembers <- resp.json %. "members.others" & asList
          selfMember <- resp.json %. "members.self"
          otherMember <- findM (\m -> (==) <$> m %. "qualified_id" <*> invitee %. "qualified_id") otherMembers
          selfMember %. "conversation_role" `shouldMatch` "wire_admin"
          otherMember %. "conversation_role" `shouldMatch` case admin of
            BothAreAdmins -> "wire_admin"
            PeerIsAdmin -> "wire_member"
            LegalholderIsAdmin -> "wire_member"
          resp.json %. "qualified_id"
      let convId = objId qConvId
      for_ [aws, bws] \ws -> do
        awaitMatch isConvCreateNotifNotSelf ws >>= \pl -> pl %. "payload.0.conversation" `shouldMatch` convId

      for_ [alice, bob] \user ->
        getConversation user qConvId >>= assertStatus 200

      requestLegalHoldDevice tidAlice alice alice >>= assertStatus 201
      case approvedOrPending of
        LHApproved -> approveLegalHoldDevice tidAlice alice defPassword >>= assertStatus 200
        LHPending -> pure ()

      legalholdUserStatus tidAlice alice alice `bindResponse` \resp -> do
        resp.status `shouldMatchInt` 200
        resp.json %. "status" `shouldMatch` case approvedOrPending of
          LHApproved -> "enabled"
          LHPending -> "pending"

      case admin of
        LegalholderIsAdmin -> do
          case approvedOrPending of
            LHApproved -> for_ [aws, bws] do awaitMatch (isConvLeaveNotifWithLeaver bob)
            LHPending -> pure ()
          getConversation alice qConvId >>= assertStatus 200
          getConversation bob qConvId >>= case approvedOrPending of
            LHApproved -> assertLabel 403 "access-denied"
            LHPending -> assertStatus 200
        PeerIsAdmin -> do
          case approvedOrPending of
            LHApproved -> for_ [aws, bws] do awaitMatch (isConvLeaveNotifWithLeaver alice)
            LHPending -> pure ()
          getConversation bob qConvId >>= assertStatus 200
          getConversation alice qConvId >>= case approvedOrPending of
            LHApproved -> assertLabel 403 "access-denied"
            LHPending -> assertStatus 200
        BothAreAdmins -> do
          case approvedOrPending of
            LHApproved -> for_ [aws, bws] do awaitMatch (isConvLeaveNotifWithLeaver bob)
            LHPending -> pure ()
          getConversation alice qConvId >>= assertStatus 200
          getConversation bob qConvId >>= case approvedOrPending of
            LHApproved -> assertLabel 403 "access-denied"
            LHPending -> assertStatus 200

testLHHappyFlow :: (HasCallStack) => Consent -> LhApiVersion -> App ()
testLHHappyFlow consent v = ensureLHFeatureConfigForServer consent $ \dom -> do
  (alice, tid, [bob]) <- createTeam dom 2
  for_ [alice, bob] getSelfConversation

  let statusShouldBe :: (HasCallStack) => String -> App ()
      statusShouldBe status =
        legalholdUserStatus tid alice bob `bindResponse` \resp -> do
          resp.status `shouldMatchInt` 200
          resp.json %. "status" `shouldMatch` status

  whitelistOrEnableLHForTeam consent dom tid alice
  lpk <- getLastPrekey
  pks <- replicateM 3 getPrekey

  let ourLHMockApp = lhMockAppWithPrekeys v MkCreateMock {nextLastPrey = pure lpk, somePrekeys = pure pks}
  withMockServer def ourLHMockApp \lhDomAndPort _chan -> do
    statusShouldBe $ case consent of
      Implicit -> "disabled"
      Explicit -> "no_consent"

    consentToLegalHold tid bob defPassword >>= assertStatus case consent of
      Implicit -> 204
      Explicit -> 201
    statusShouldBe "disabled"

    postLegalHoldSettings tid alice (mkLegalHoldSettings lhDomAndPort) >>= assertStatus 201
    statusShouldBe "disabled"

    -- members cannot request LH devices
    requestLegalHoldDevice tid bob alice >>= assertLabel 403 "operation-denied"
    requestLegalHoldDevice tid bob bob >>= assertLabel 403 "operation-denied"

    -- owners can; bob should now have a pending request
    requestLegalHoldDevice tid alice bob >>= assertStatus 201
    statusShouldBe "pending"

    -- owner cannot approve on behalf on user under legalhold
    approveLegalHoldDevice' tid alice bob defPassword >>= assertLabel 403 "access-denied"

    -- user can approve the request, however
    approveLegalHoldDevice tid bob defPassword `bindResponse` \resp -> do
      resp.status `shouldMatchInt` 200

    legalholdUserStatus tid alice bob `bindResponse` \resp -> do
      resp.status `shouldMatchInt` 200
      resp.json %. "status" `shouldMatch` "enabled"
      _ <-
        resp.json
          `lookupField` "client.id"
          >>= assertJust "client id is present"
      resp.json %. "last_prekey" `shouldMatch` lpk

    -- user cannot delete their own LH device
    disableLegalHold tid bob bob defPassword >>= assertLabel 403 "operation-denied"
    legalholdUserStatus tid alice bob `bindResponse` \resp -> do
      resp.status `shouldMatchInt` 200
      resp.json %. "status" `shouldMatch` "enabled"

    -- admin can delete LH device
    disableLegalHold tid alice bob defPassword >>= assertSuccess
    legalholdUserStatus tid alice bob `bindResponse` \resp -> do
      resp.status `shouldMatchInt` 200
      resp.json %. "status" `shouldMatch` "disabled"

testLHGetStatus :: LhApiVersion -> App ()
testLHGetStatus v = do
  (alice, tid, [bob]) <- createTeam OwnDomain 2
  (charlie, _tidCharlie, [debora]) <- createTeam OwnDomain 2

  emil <- randomUser OwnDomain def

  for_ [alice, bob, charlie, debora, emil] getSelfConversation

  let check :: (HasCallStack) => (MakesValue getter, MakesValue target) => getter -> target -> String -> App ()
      check getter target status = do
        profile <- getUser getter target >>= getJSON 200
        pStatus <- profile %. "legalhold_status" & asString
        status `shouldMatch` pStatus

  for_ [alice, bob, charlie, debora, emil] \u -> do
    check u bob "no_consent"
    check u emil "no_consent"
  legalholdWhitelistTeam tid alice >>= assertStatus 200
  withMockServer def (lhMockAppV v) \lhDomAndPort _chan -> do
    postLegalHoldSettings tid alice (mkLegalHoldSettings lhDomAndPort) >>= assertStatus 201
    for_ [alice, bob, charlie, debora, emil] \u -> do
      check u bob "disabled"
    requestLegalHoldDevice tid alice bob >>= assertStatus 201
    check debora bob "pending"
    approveLegalHoldDevice tid bob defPassword >>= assertStatus 200
    check debora bob "enabled"

testLHCannotCreateGroupWithUsersInConflict :: LhApiVersion -> App ()
testLHCannotCreateGroupWithUsersInConflict v = do
  (alice, tidAlice, [bob]) <- createTeam OwnDomain 2
  (charlie, _tidCharlie, [debora]) <- createTeam OwnDomain 2
  for_ [alice, bob, charlie, debora] getSelfConversation

  legalholdWhitelistTeam tidAlice alice >>= assertStatus 200
  connectTwoUsers bob charlie
  connectTwoUsers bob debora
  withMockServer def (lhMockAppV v) \lhDomAndPort _chan -> do
    postLegalHoldSettings tidAlice alice (mkLegalHoldSettings lhDomAndPort) >>= assertStatus 201
    postConversation bob defProteus {qualifiedUsers = [charlie, alice], newUsersRole = "wire_member", team = Just tidAlice}
      >>= assertStatus 201

    requestLegalHoldDevice tidAlice alice alice >>= assertStatus 201
    approveLegalHoldDevice tidAlice alice defPassword >>= assertStatus 200
    legalholdUserStatus tidAlice alice alice `bindResponse` \resp -> do
      resp.status `shouldMatchInt` 200
      resp.json %. "status" `shouldMatch` "enabled"

    postConversation bob defProteus {qualifiedUsers = [debora, alice], newUsersRole = "wire_member", team = Just tidAlice}
      >>= assertLabel 403 "missing-legalhold-consent"

testLHNoConsentCannotBeInvited :: (HasCallStack) => LhApiVersion -> App ()
testLHNoConsentCannotBeInvited v = do
  -- team that is legalhold whitelisted
  (legalholder, tidLH, userLHNotActivated : _) <- createTeam OwnDomain 2
  for_ [legalholder, userLHNotActivated] getSelfConversation
  legalholdWhitelistTeam tidLH legalholder >>= assertStatus 200

  -- team without legalhold
  (peer, _tidPeer, [peer2, peer3]) <- createTeam OwnDomain 3
  for_ [peer, peer2, peer3] getSelfConversation

  connectUsers [peer, userLHNotActivated]
  connectUsers [peer2, userLHNotActivated]

  withMockServer def (lhMockAppV v) \lhDomAndPort _chan -> do
    postLegalHoldSettings tidLH legalholder (mkLegalHoldSettings lhDomAndPort) >>= assertStatus 201
    cid <- postConversation userLHNotActivated defProteus {qualifiedUsers = [legalholder], newUsersRole = "wire_admin", team = Just tidLH} >>= getJSON 201
    addMembers userLHNotActivated cid (def {users = [peer], role = Just "wire_admin"}) >>= assertSuccess

    -- activate legalhold for legalholder
    requestLegalHoldDevice tidLH legalholder legalholder >>= assertSuccess
    legalholdUserStatus tidLH legalholder legalholder `bindResponse` \resp -> do
      resp.status `shouldMatchInt` 200
      resp.json %. "status" `shouldMatch` "pending"

    addMembers userLHNotActivated cid (def {users = [peer2]}) >>= assertSuccess

    approveLegalHoldDevice tidLH (legalholder %. "qualified_id") defPassword >>= assertSuccess
    legalholdUserStatus tidLH legalholder legalholder `bindResponse` \resp -> do
      resp.status `shouldMatchInt` 200
      resp.json %. "status" `shouldMatch` "enabled"

    addMembers userLHNotActivated cid (def {users = [peer3]}) >>= assertLabel 403 "not-connected"

testLHDisableBeforeApproval :: (HasCallStack) => LhApiVersion -> App ()
testLHDisableBeforeApproval v = do
  (alice, tid, [bob]) <- createTeam OwnDomain 2
  for_ [alice, bob] getSelfConversation

  legalholdWhitelistTeam tid alice >>= assertStatus 200

  withMockServer def (lhMockAppV v) \lhDomAndPort _chan -> do
    postLegalHoldSettings tid alice (mkLegalHoldSettings lhDomAndPort) >>= assertStatus 201

    -- alice requests a legalhold device for bob and sets his status to "pending"
    requestLegalHoldDevice tid alice bob >>= assertSuccess
    let getBob'sStatus = (getUser bob bob >>= getJSON 200) %. "legalhold_status" & asString
    getBob'sStatus `shouldMatch` "pending"

    -- alice disables legalhold. the status for bob should now not be pending anymore
    disableLegalHold tid alice bob defPassword
      >>= assertStatus 200
    getBob'sStatus `shouldMatch` "disabled"

-- ---------
-- WPB-10783
-- ---------
testBlockLHForMLSUsers :: (HasCallStack) => App ()
testBlockLHForMLSUsers = do
  -- scenario 1:
  -- if charlie is in any MLS conversation, he cannot approve to be put under legalhold
  (charlie, tid, []) <- createTeam OwnDomain 1
  void $ getSelfConversation charlie
  [charlie1] <- traverse (createMLSClient def) [charlie]
  convId <- createNewGroup def charlie1
  void $ createAddCommit charlie1 convId [charlie] >>= sendAndConsumeCommitBundle

  legalholdWhitelistTeam tid charlie >>= assertStatus 200
  withMockServer def lhMockApp \lhDomAndPort _chan -> do
    postLegalHoldSettings tid charlie (mkLegalHoldSettings lhDomAndPort) >>= assertStatus 201
    requestLegalHoldDevice tid charlie charlie `bindResponse` do
      assertLabel 409 "mls-legal-hold-not-allowed"

-- ---------
-- WPB-10772
-- ---------

--  | scenario 2.1:
-- charlie first is put under legalhold and after that wants to join an MLS conversation
-- claiming a keypackage of charlie to add them to a conversation should not be possible
testBlockClaimingKeyPackageForLHUsers :: (HasCallStack) => App ()
testBlockClaimingKeyPackageForLHUsers = do
  (alice, tid, [charlie]) <- createTeam OwnDomain 2
  for_ [alice, charlie] getSelfConversation
  [alice1, charlie1] <- traverse (createMLSClient def) [alice, charlie]
  _ <- uploadNewKeyPackage def charlie1
  _ <- createNewGroup def alice1
  legalholdWhitelistTeam tid alice >>= assertStatus 200
  withMockServer def lhMockApp \lhDomAndPort _chan -> do
    postLegalHoldSettings tid alice (mkLegalHoldSettings lhDomAndPort) >>= assertStatus 201
    requestLegalHoldDevice tid alice charlie >>= assertSuccess
    approveLegalHoldDevice tid (charlie %. "qualified_id") defPassword >>= assertSuccess
    profile <- getUser alice charlie >>= getJSON 200
    pStatus <- profile %. "legalhold_status" & asString
    pStatus `shouldMatch` "enabled"

    claimKeyPackages def alice1 charlie
      `bindResponse` assertLabel 409 "mls-legal-hold-not-allowed"

-- | scenario 2.2:
-- charlie is put under legalhold but creates an MLS Group himself
-- since he doesn't need to claim his own keypackage to do so, this would succeed
-- we need to check upon group creation if the user is under legalhold and reject
-- the operation if they are
testBlockCreateMLSConvForLHUsers :: (HasCallStack) => LhApiVersion -> App ()
testBlockCreateMLSConvForLHUsers v = do
  (alice, tid, [charlie]) <- createTeam OwnDomain 2
  for_ [alice, charlie] getSelfConversation
  [alice1, charlie1] <- traverse (createMLSClient def) [alice, charlie]
  _ <- uploadNewKeyPackage def alice1
  legalholdWhitelistTeam tid alice >>= assertStatus 200
  withMockServer def (lhMockAppV v) \lhDomAndPort _chan -> do
    postLegalHoldSettings tid alice (mkLegalHoldSettings lhDomAndPort) >>= assertStatus 201
    requestLegalHoldDevice tid alice charlie >>= assertSuccess
    approveLegalHoldDevice tid (charlie %. "qualified_id") defPassword >>= assertSuccess
    profile <- getUser alice charlie >>= getJSON 200
    pStatus <- profile %. "legalhold_status" & asString
    pStatus `shouldMatch` "enabled"

    -- charlie tries to create a group and should fail when POSTing the add commit
    convId <- createNewGroup def charlie1

    void
      -- we try to add alice since adding charlie himself would trigger 2.1
      -- since he'd try to claim his own keypackages
      $ createAddCommit charlie1 convId [alice]
      >>= \mp ->
        postMLSCommitBundle mp.sender (mkBundle mp)
          `bindResponse` assertLabel 409 "mls-legal-hold-not-allowed"

    -- (unsurprisingly) this same thing should also work in the one2one case

    respJson <- getMLSOne2OneConversation alice charlie >>= getJSON 200
    createGroup def alice1 =<< objConvId (respJson %. "conversation")

    void
      -- we try to add alice since adding charlie himself would trigger 2.1
      -- since he'd try to claim his own keypackages
      $ createAddCommit charlie1 convId [alice]
      >>= \mp ->
        postMLSCommitBundle mp.sender (mkBundle mp)
          `bindResponse` assertLabel 409 "mls-legal-hold-not-allowed"

testLHApiV1 :: App ()
testLHApiV1 = do
  (alice, tid, [bob]) <- createTeam OwnDomain 2
  for_ [alice, bob] getSelfConversation

  legalholdWhitelistTeam tid alice >>= assertSuccess

  withMockServer def (lhMockAppV V1) \lhDomAndPort chan -> do
    postLegalHoldSettings tid alice (mkLegalHoldSettings lhDomAndPort) >>= assertStatus 201

    checkChan chan \(req, _) -> runMaybeT . lift $ do
      BS8.unpack req.requestMethod `shouldMatch` "GET"
      req.pathInfo `shouldMatch` (T.pack <$> ["legalhold", "status"])

    requestLegalHoldDevice tid alice bob >>= assertStatus 201

    checkChan chan \(req, _) -> runMaybeT . lift $ do
      BS8.unpack req.requestMethod `shouldMatch` "GET"
      req.pathInfo `shouldMatch` (T.pack <$> ["legalhold", "api-version"])

    checkChan chan \(req, body) -> runMaybeT . lift $ do
      BS8.unpack req.requestMethod `shouldMatch` "POST"
      req.pathInfo `shouldMatch` (T.pack <$> ["legalhold", "v1", "initiate"])
      let (Just (value :: Value)) = decode body
      value %. "team_id" `shouldMatch` tid
      value %. "qualified_user_id.id" `shouldMatch` objId bob
      value %. "qualified_user_id.domain" `shouldMatch` objDomain bob

    approveLegalHoldDevice tid (bob %. "qualified_id") defPassword >>= assertSuccess

    checkChan chan \(req, _) -> runMaybeT . lift $ do
      BS8.unpack req.requestMethod `shouldMatch` "GET"
      req.pathInfo `shouldMatch` (T.pack <$> ["legalhold", "api-version"])

    checkChan chan \(req, body) -> runMaybeT . lift $ do
      BS8.unpack req.requestMethod `shouldMatch` "POST"
      req.pathInfo `shouldMatch` (T.pack <$> ["legalhold", "v1", "confirm"])
      let (Just (value :: Value)) = decode body
      value %. "team_id" `shouldMatch` tid
      value %. "qualified_user_id.id" `shouldMatch` objId bob
      value %. "qualified_user_id.domain" `shouldMatch` objDomain bob
      (isJust <$> value `lookupField` "client_id") `shouldMatch` True

    disableLegalHold tid alice bob defPassword >>= assertStatus 200

    checkChan chan \(req, _) -> runMaybeT . lift $ do
      BS8.unpack req.requestMethod `shouldMatch` "GET"
      req.pathInfo `shouldMatch` (T.pack <$> ["legalhold", "api-version"])

    checkChan chan \(req, body) -> runMaybeT . lift $ do
      BS8.unpack req.requestMethod `shouldMatch` "POST"
      req.pathInfo `shouldMatch` (T.pack <$> ["legalhold", "v1", "remove"])
      let (Just (value :: Value)) = decode body
      value %. "team_id" `shouldMatch` tid
      value %. "qualified_user_id.id" `shouldMatch` objId bob
      value %. "qualified_user_id.domain" `shouldMatch` objDomain bob

testNoCommonVersion :: App ()
testNoCommonVersion = do
  (alice, tid, [bob]) <- createTeam OwnDomain 2
  for_ [alice, bob] getSelfConversation

  legalholdWhitelistTeam tid alice >>= assertSuccess

  withMockServer def lhMockNoCommonVersion \lhDomAndPort _ -> do
    legalholdWhitelistTeam tid alice >>= assertStatus 200
    postLegalHoldSettings tid alice (mkLegalHoldSettings lhDomAndPort) >>= assertSuccess

    bindResponse (requestLegalHoldDevice tid alice bob) $ \resp -> do
      resp.status `shouldMatchInt` 500
      resp.json %. "label" `shouldMatch` "server-error"

-- | LH can be configured in a way that does not require users to give preliminary consent to
-- LH when being added to a team.  The user still has to approve the LH device before the
-- recording starts.  This is called "implicit consent", was introduced to accomodate specific
-- work flows, and there is some hope that it'll be removed in the future.
--
-- Explicit consent requires users to consent on entering the team, and then approve the
-- actual being put under recording again if it happens.
--
-- This flag allows to make tests run through both configurations with minimal adjustment.
data Consent = Implicit | Explicit
  deriving (Eq, Show, Generic)

-- | Ensure that the LH config is as expected: Either by expecting it from the
-- current server's config. Or, by creating a new one.
ensureLHFeatureConfigForServer :: Consent -> (String {- domain -} -> App ()) -> App ()
ensureLHFeatureConfigForServer Implicit app = do
  -- This should be set in the server's config file. Thus, we only assert here
  -- (to guard against accidential change.)
  cfg <- readServiceConfig Galley
  (cfg %. "settings.featureFlags.legalhold") `shouldMatch` "whitelist-teams-and-implicit-consent"
  app =<< asString OwnDomain
ensureLHFeatureConfigForServer Explicit app =
  withModifiedBackend (def {galleyCfg = upd}) app
  where
    upd = setField "settings.featureFlags.legalhold" "disabled-by-default"

whitelistOrEnableLHForTeam :: (HasCallStack, MakesValue tid, MakesValue user, MakesValue dom) => Consent -> dom -> tid -> user -> App ()
whitelistOrEnableLHForTeam consent dom tid user = do
  case consent of
    Implicit -> do
      legalholdWhitelistTeam tid user >>= assertSuccess
      legalholdIsTeamInWhitelist tid user >>= assertSuccess
    Explicit -> do
      -- legalhold has implicit lock status "unlocked", so it just needs to be enabled:
      let payload = object ["status" .= "enabled"]
      API.GalleyInternal.setTeamFeatureConfig dom tid "legalhold" payload >>= assertSuccess

-- | setup a legalhold device for @uid@, authorised by @owner@
--   at the specified port
setUpLHDevice ::
  (HasCallStack, MakesValue dom, MakesValue tid, MakesValue owner, MakesValue uid) =>
  Consent ->
  dom ->
  tid ->
  owner ->
  uid ->
  -- | the host and port the LH service is running on
  (String, Int) ->
  App ()
setUpLHDevice consent dom tid alice bob lhPort = do
  whitelistOrEnableLHForTeam consent dom tid alice

  -- the status messages for these have already been tested
  postLegalHoldSettings tid alice (mkLegalHoldSettings lhPort)
    >>= assertStatus 201

  let expected = case consent of
        Implicit -> 204
        Explicit -> 201
   in consentToLegalHold tid bob defPassword >>= assertStatus expected
  requestLegalHoldDevice tid alice bob
    >>= assertStatus 201

  approveLegalHoldDevice tid bob defPassword
    >>= assertStatus 200
