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

{-# HLINT ignore "Use head" #-}

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

module API.User.Client
  ( tests,
  )
where

import API.Team.Util qualified as Util
import API.User.Util
import API.User.Util qualified as Util
import Bilge hiding (accept, head, timeout)
import Bilge.Assert
import Brig.Options as Opt
import Cassandra qualified as DB
import Control.Lens hiding (Wrapped, (#))
import Crypto.JWT hiding (Ed25519, header, params)
import Data.Aeson
import Data.Aeson qualified as A
import Data.Aeson.KeyMap qualified as M
import Data.Aeson.Lens
import Data.ByteString.Conversion
import Data.Code qualified as Code
import Data.Coerce (coerce)
import Data.Default
import Data.Domain (Domain (..))
import Data.Handle
import Data.Id
import Data.List.NonEmpty qualified as NonEmpty
import Data.Map qualified as Map
import Data.Nonce (isValidBase64UrlEncodedUUID)
import Data.Qualified (Qualified (..))
import Data.Range (unsafeRange)
import Data.Set qualified as Set
import Data.String.Conversions
import Data.Text.Ascii (AsciiChars (validate), encodeBase64UrlUnpadded, toText)
import Data.Text.Encoding qualified as T
import Data.Time.Clock.POSIX
import Data.UUID (toByteString)
import Data.UUID qualified as UUID
import Data.Vector qualified as Vec
import Imports
import Network.Wai.Utilities.Error qualified as Error
import System.Logger qualified as Log
import Test.QuickCheck (arbitrary, generate)
import Test.Tasty hiding (Timeout)
import Test.Tasty.Cannon hiding (Cannon, Timeout)
import Test.Tasty.Cannon qualified as WS
import Test.Tasty.HUnit
import UnliftIO (mapConcurrently)
import Util
import Util.Timeout
import Wire.API.Internal.Notification
import Wire.API.MLS.CipherSuite
import Wire.API.Routes.Version
import Wire.API.Routes.Versioned
import Wire.API.Team.Feature qualified as Public
import Wire.API.User
import Wire.API.User qualified as Public
import Wire.API.User.Auth
import Wire.API.User.Client
import Wire.API.User.Client.DPoPAccessToken
import Wire.API.User.Client.Prekey
import Wire.API.UserMap (QualifiedUserMap (..), UserMap (..), WrappedQualifiedUserMap)
import Wire.API.Wrapped (Wrapped (..))
import Wire.VerificationCode qualified as Code
import Wire.VerificationCodeGen

tests :: ConnectionLimit -> Timeout -> Opt.Opts -> Manager -> DB.ClientState -> Nginz -> Brig -> Cannon -> Galley -> TestTree
tests _cl _at opts p db n b c g =
  testGroup
    "client"
    [ test p "get /users/:uid/clients - 200" $ testGetUserClientsUnqualified opts b,
      test p "get /users/<localdomain>/:uid/clients - 200" $ testGetUserClientsQualified opts b,
      test p "get /users/:uid/prekeys - 200" $ testGetUserPrekeys b,
      test p "get /users/<localdomain>/:uid/prekeys - 200" $ testGetUserPrekeysQualified b opts,
      test p "get /users/:domain/:uid/prekeys - 422" $ testGetUserPrekeysInvalidDomain b,
      test p "get /users/:uid/prekeys/:client - 200" $ testGetClientPrekey b,
      test p "get /users/<localdomain>/:uid/prekeys/:client - 200" $ testGetClientPrekeyQualified b opts,
      test p "post /users/prekeys" $ testMultiUserGetPrekeys b,
      test p "post /users/list-prekeys" $ testMultiUserGetPrekeysQualified b opts,
      test p "post /users/list-prekeys@v4" $ testMultiUserGetPrekeysQualifiedV4 b opts,
      test p "post /users/list-clients - 200" $ testListClientsBulk opts b,
      test p "post /users/list-clients/v2 - 200" $ testListClientsBulkV2 opts b,
      test p "post /users/list-prekeys - clients without prekeys" $ testClientsWithoutPrekeys b c db opts,
      test p "post /users/list-prekeys@v4 - clients without prekeys" $ testClientsWithoutPrekeysV4 b c db opts,
      test p "post /users/list-prekeys@v4 - clients without prekeys fail to list" $ testClientsWithoutPrekeysFailToListV4 b c db opts,
      test p "post /clients - 201 (pwd)" $ testAddGetClient def {addWithPassword = True} b c,
      test p "post /clients - 201 (no pwd)" $ testAddGetClient def {addWithPassword = False} b c,
      testGroup
        "post /clients - verification code"
        [ test p "success" $ testAddGetClientVerificationCode db b g,
          test p "testAddGetClientMissingCode - missing code" $ testAddGetClientMissingCode b g,
          test p "testAddGetClientWrongCode - wrong code" $ testAddGetClientWrongCode b g,
          test p "testAddGetClientCodeExpired - expired code" $ testAddGetClientCodeExpired db opts b g
        ],
      test p "post /clients - 201 (with mls keys)" $ testAddGetClient def {addWithMLSKeys = True} b c,
      test p "post /clients - 403" $ testClientReauthentication b,
      test p "get /clients - 200" $ testListClients b,
      test p "get /clients/:client/prekeys - 200" $ testListPrekeyIds b,
      test p "testTooManyClients - post /clients - 400" $ testTooManyClients opts b,
      test p "testPrekeysNotEmptyRandomPrekeys - client/prekeys not empty" $ testPrekeysNotEmptyRandomPrekeys opts b,
      test p "testRegularPrekeysCannotBeSentAsLastPrekeys - lastprekeys not bogus" $ testRegularPrekeysCannotBeSentAsLastPrekeys b,
      test p "testRegularPrekeysCannotBeSentAsLastPrekeysDuringUpdate - lastprekeys not bogus during update" $ testRegularPrekeysCannotBeSentAsLastPrekeysDuringUpdate b,
      test p "testRemoveClient - delete /clients/:client - 200 (pwd)" $ testRemoveClient True b c,
      test p "testRemoveClient - delete /clients/:client - 200 (no pwd)" $ testRemoveClient False b c,
      test p "testRemoveClientShortPwd - delete /clients/:client - 400 (short pwd)" $ testRemoveClientShortPwd b,
      test p "testRemoveClientIncorrectPwd - delete /clients/:client - 403 (incorrect pwd)" $ testRemoveClientIncorrectPwd b,
      test p "put /clients/:client - 200" $ testUpdateClient opts b,
      test p "put /clients/:client - 200 (mls keys)" $ testMLSPublicKeyUpdate b,
      test p "get /clients/:client - 404" $ testMissingClient b,
      test p "get /clients/:client - 200" $ testMLSClient b,
      test p "testAddMultipleTemporary - post /clients - 200 multiple temporary" $ testAddMultipleTemporary b g c,
      test p "client/prekeys/race" $ testPreKeyRace b,
      test p "get/head nonce/clients" $ testNewNonce b,
      testGroup
        "post /clients/:cid/access-token"
        [ test p "success" $ testCreateAccessToken opts n b,
          test p "proof missing" $ testCreateAccessTokenMissingProof b,
          test p "no nonce" $ testCreateAccessTokenNoNonce b
        ]
    ]

testAddGetClientVerificationCode :: DB.ClientState -> Brig -> Galley -> Http ()
testAddGetClientVerificationCode db brig galley = do
  (u, tid) <- Util.createUserWithTeam' brig
  let uid = userId u
  let Just email = userEmail u
  let checkLoginSucceeds b = login brig b PersistentCookie !!! const 200 === statusCode
  let addClient' :: Maybe Code.Value -> Http Client
      addClient' codeValue = responseJsonError =<< addClient brig uid (defNewClientWithVerificationCode codeValue PermanentClientType [head somePrekeys] (head someLastPrekeys))

  Util.setTeamFeatureLockStatus @Public.SndFactorPasswordChallengeConfig galley tid Public.LockStatusUnlocked
  Util.setTeamSndFactorPasswordChallenge galley tid Public.FeatureStatusEnabled
  Util.generateVerificationCode brig (Public.SendVerificationCode Public.Login email)
  let k = mkKey email
  codeValue <- Code.codeValue <$$> lookupCode db k Code.AccountLogin
  checkLoginSucceeds $
    MkLogin (LoginByEmail email) defPassword (Just defCookieLabel) codeValue
  c :: Client <- addClient' codeValue
  getClient brig uid c.clientId !!! do
    const 200 === statusCode
    const (Just c) === responseJsonMaybe

-- @SF.Channel @TSFI.RESTfulAPI @S2
--
-- Test that device cannot be added with missing second factor email verification code when this feature is enabled
testAddGetClientMissingCode :: Brig -> Galley -> Http ()
testAddGetClientMissingCode brig galley = do
  (u, tid) <- Util.createUserWithTeam' brig
  let uid = userId u
  let Just email = userEmail u
  let addClient' codeValue = addClient brig uid (defNewClientWithVerificationCode codeValue PermanentClientType [head somePrekeys] (head someLastPrekeys))

  Util.setTeamFeatureLockStatus @Public.SndFactorPasswordChallengeConfig galley tid Public.LockStatusUnlocked
  Util.setTeamSndFactorPasswordChallenge galley tid Public.FeatureStatusEnabled
  Util.generateVerificationCode brig (Public.SendVerificationCode Public.Login email)
  addClient' Nothing !!! do
    const 403 === statusCode
    const (Just "code-authentication-required") === fmap Error.label . responseJsonMaybe

-- @END

-- @SF.Channel @TSFI.RESTfulAPI @S2
--
-- Test that device cannot be added with wrong second factor email verification code when this feature is enabled
testAddGetClientWrongCode :: Brig -> Galley -> Http ()
testAddGetClientWrongCode brig galley = do
  (u, tid) <- Util.createUserWithTeam' brig
  let uid = userId u
  let Just email = userEmail u
  let addClient' codeValue = addClient brig uid (defNewClientWithVerificationCode codeValue PermanentClientType [head somePrekeys] (head someLastPrekeys))

  Util.setTeamFeatureLockStatus @Public.SndFactorPasswordChallengeConfig galley tid Public.LockStatusUnlocked
  Util.setTeamSndFactorPasswordChallenge galley tid Public.FeatureStatusEnabled
  Util.generateVerificationCode brig (Public.SendVerificationCode Public.Login email)
  let wrongCode = Code.Value $ unsafeRange (fromRight undefined (validate "123456"))
  addClient' (Just wrongCode) !!! do
    const 403 === statusCode
    const (Just "code-authentication-failed") === fmap Error.label . responseJsonMaybe

-- @END

-- @SF.Channel @TSFI.RESTfulAPI @S2
--
-- Test that device cannot be added with expired second factor email verification code when this feature is enabled
testAddGetClientCodeExpired :: DB.ClientState -> Opt.Opts -> Brig -> Galley -> Http ()
testAddGetClientCodeExpired db opts brig galley = do
  (u, tid) <- Util.createUserWithTeam' brig
  let uid = userId u
  let Just email = userEmail u
  let checkLoginSucceeds b = login brig b PersistentCookie !!! const 200 === statusCode
  let addClient' codeValue = addClient brig uid (defNewClientWithVerificationCode codeValue PermanentClientType [head somePrekeys] (head someLastPrekeys))

  Util.setTeamFeatureLockStatus @Public.SndFactorPasswordChallengeConfig galley tid Public.LockStatusUnlocked
  Util.setTeamSndFactorPasswordChallenge galley tid Public.FeatureStatusEnabled
  Util.generateVerificationCode brig (Public.SendVerificationCode Public.Login email)
  let k = mkKey email
  codeValue <- (.codeValue) <$$> lookupCode db k Code.AccountLogin
  checkLoginSucceeds $
    MkLogin (LoginByEmail email) defPassword (Just defCookieLabel) codeValue
  let timeout = round (verificationTimeout opts.settings)
  threadDelay $ ((timeout + 1) * 1000_000)
  addClient' codeValue !!! do
    const 403 === statusCode
    const (Just "code-authentication-failed") === fmap Error.label . responseJsonMaybe

-- @END

data AddGetClient = AddGetClient
  { addWithPassword :: Bool,
    addWithMLSKeys :: Bool
  }

instance Default AddGetClient where
  def = AddGetClient True False

testAddGetClient :: AddGetClient -> Brig -> Cannon -> Http ()
testAddGetClient params brig cannon = do
  uid <- userId <$> randomUser' (addWithPassword params) brig
  let new =
        (defNewClient TemporaryClientType [somePrekeys !! 0] (someLastPrekeys !! 0))
          { newClientMLSPublicKeys = keys
          }
      keys
        | addWithMLSKeys params = Map.fromList [(Ed25519, "aGVsbG8gd29ybGQ=")]
        | otherwise = mempty
  let rq =
        addClientReq brig uid new
          . header "X-Forwarded-For" "127.0.0.1" -- Fake IP to test IpAddr parsing.
  c :: Client <- WS.bracketR cannon uid $ \ws -> do
    c :: Client <-
      responseJsonError
        =<< ( post rq <!! do
                const 201 === statusCode
                const True === isJust . getHeader "Location"
            )
    void . liftIO . WS.assertMatch (5 # Second) ws $ \n -> do
      let j = Object $ NonEmpty.head (ntfPayload n)
      let etype = j ^? key "type" . _String
      let eclient = j ^? key "client"
      etype @?= Just "user.client-add"
      fmap fromJSON eclient @?= Just (Success (Versioned @'V6 c))
    pure c
  liftIO $ clientMLSPublicKeys c @?= keys
  getClient brig uid c.clientId !!! do
    const 200 === statusCode
    const (Just c) === responseJsonMaybe

testGetUserClientsUnqualified :: Opt.Opts -> Brig -> Http ()
testGetUserClientsUnqualified _opts brig = do
  uid1 <- userId <$> randomUser brig
  let (pk11, lk11) = (somePrekeys !! 0, someLastPrekeys !! 0)
  let (pk12, lk12) = (somePrekeys !! 1, someLastPrekeys !! 1)
  let (pk13, lk13) = (somePrekeys !! 2, someLastPrekeys !! 2)
  _c11 :: Client <- responseJsonError =<< addClient brig uid1 (defNewClient PermanentClientType [pk11] lk11)
  _c12 :: Client <- responseJsonError =<< addClient brig uid1 (defNewClient PermanentClientType [pk12] lk12)
  _c13 :: Client <- responseJsonError =<< addClient brig uid1 (defNewClient TemporaryClientType [pk13] lk13)
  getUserClientsUnqualified brig uid1 !!! do
    const 200 === statusCode
    assertTrue_ $ \res -> do
      let clients :: [PubClient] = responseJsonUnsafe res
       in length clients == 3

testGetUserClientsQualified :: Opt.Opts -> Brig -> Http ()
testGetUserClientsQualified opts brig = do
  uid1 <- userId <$> randomUser brig
  uid2 <- userId <$> randomUser brig
  let (pk11, lk11) = (somePrekeys !! 0, someLastPrekeys !! 0)
  let (pk12, lk12) = (somePrekeys !! 1, someLastPrekeys !! 1)
  let (pk13, lk13) = (somePrekeys !! 2, someLastPrekeys !! 2)
  _c11 :: Client <- responseJsonError =<< addClient brig uid1 (defNewClient PermanentClientType [pk11] lk11)
  _c12 :: Client <- responseJsonError =<< addClient brig uid1 (defNewClient PermanentClientType [pk12] lk12)
  _c13 :: Client <- responseJsonError =<< addClient brig uid1 (defNewClient TemporaryClientType [pk13] lk13)
  let localdomain = opts.settings.federationDomain
  getUserClientsQualified brig uid2 localdomain uid1 !!! do
    const 200 === statusCode
    assertTrue_ $ \res -> do
      let clients :: [PubClient] = responseJsonUnsafe res
       in length clients == 3

testClientReauthentication :: Brig -> Http ()
testClientReauthentication brig = do
  let (pk1, lk1) = (somePrekeys !! 0, someLastPrekeys !! 0)
  let (pk2, lk2) = (somePrekeys !! 1, someLastPrekeys !! 1)
  let (pk3, lk3) = (somePrekeys !! 2, someLastPrekeys !! 2)
  let payload1 =
        (defNewClient PermanentClientType [pk1] lk1)
          { newClientPassword = Nothing
          }
  let payload2 =
        (defNewClient PermanentClientType [pk2] lk2)
          { newClientPassword = Nothing
          }
  let payload3 =
        (defNewClient TemporaryClientType [pk3] lk3)
          { newClientPassword = Nothing
          }
  -- User with password
  uid <- userId <$> randomUser brig
  -- The first client never requires authentication
  c :: Client <- responseJsonError =<< (addClient brig uid payload1 <!! const 201 === statusCode)
  -- Adding a second client requires reauthentication, if a password is set.
  addClient brig uid payload2 !!! do
    const 403 === statusCode
    const (Just "missing-auth") === (fmap Error.label . responseJsonMaybe)
  -- Removing a client requires reauthentication, if a password is set.
  deleteClient brig uid c.clientId Nothing !!! const 403 === statusCode
  -- User without a password
  uid2 <- userId <$> createAnonUser "Mr. X" brig
  c2 :: Client <- responseJsonError =<< (addClient brig uid2 payload1 <!! const 201 === statusCode)
  c3 :: Client <- responseJsonError =<< (addClient brig uid2 payload2 <!! const 201 === statusCode)
  deleteClient brig uid2 c2.clientId Nothing !!! const 200 === statusCode
  deleteClient brig uid2 c3.clientId Nothing !!! const 200 === statusCode
  -- Temporary client can always be deleted without a password
  c4 :: Client <- responseJsonError =<< addClient brig uid payload3
  deleteClient brig uid c4.clientId Nothing !!! const 200 === statusCode
  c5 :: Client <- responseJsonError =<< addClient brig uid2 payload3
  deleteClient brig uid2 c5.clientId Nothing !!! const 200 === statusCode

testListClients :: Brig -> Http ()
testListClients brig = do
  uid <- userId <$> randomUser brig
  let (pk1, lk1) = (somePrekeys !! 0, someLastPrekeys !! 0)
  let (pk2, lk2) = (somePrekeys !! 1, someLastPrekeys !! 1)
  let (pk3, lk3) = (somePrekeys !! 2, someLastPrekeys !! 2)
  c1 :: Client <- responseJsonError =<< addClient brig uid (defNewClient PermanentClientType [pk1] lk1)
  c2 :: Client <- responseJsonError =<< addClient brig uid (defNewClient PermanentClientType [pk2] lk2)
  c3 :: Client <- responseJsonError =<< addClient brig uid (defNewClient TemporaryClientType [pk3] lk3)

  let pks = Map.fromList [(Ed25519, "random")]
  void $ putClient brig uid c1.clientId pks
  let c1' = c1 {clientMLSPublicKeys = pks}
  let clients = sortBy (compare `on` (.clientId)) [c1', c2, c3]

  get
    ( brig
        . path "clients"
        . zUser uid
    )
    !!! do
      const 200 === statusCode
      const (Just clients) === responseJsonMaybe

testMLSClient :: Brig -> Http ()
testMLSClient brig = do
  uid <- userId <$> randomUser brig
  let (pk1, lk1) = (somePrekeys !! 0, someLastPrekeys !! 0)
  let (pk2, lk2) = (somePrekeys !! 1, someLastPrekeys !! 1)
  -- An MLS client
  c1 :: Client <- responseJsonError =<< addClient brig uid (defNewClient PermanentClientType [pk1] lk1)
  -- Non-MLS client
  c2 :: Client <- responseJsonError =<< addClient brig uid (defNewClient PermanentClientType [pk2] lk2)

  let pks = Map.fromList [(Ed25519, "random")]
  void $ putClient brig uid c1.clientId pks

  -- Assert that adding MLS public keys to one client does not affect the other
  -- client
  getClient brig uid c2.clientId !!! do
    const 200 === statusCode
    const (Just c2) === responseJsonMaybe

testListClientsBulk :: Opt.Opts -> Brig -> Http ()
testListClientsBulk opts brig = do
  uid1 <- userId <$> randomUser brig
  let (pk11, lk11) = (somePrekeys !! 0, someLastPrekeys !! 0)
  let (pk12, lk12) = (somePrekeys !! 1, someLastPrekeys !! 1)
  let (pk13, lk13) = (somePrekeys !! 2, someLastPrekeys !! 2)
  c11 :: Client <- responseJsonError =<< addClient brig uid1 (defNewClient PermanentClientType [pk11] lk11)
  c12 :: Client <- responseJsonError =<< addClient brig uid1 (defNewClient PermanentClientType [pk12] lk12)
  c13 :: Client <- responseJsonError =<< addClient brig uid1 (defNewClient TemporaryClientType [pk13] lk13)

  uid2 <- userId <$> randomUser brig
  let (pk21, lk21) = (somePrekeys !! 3, someLastPrekeys !! 3)
  let (pk22, lk22) = (somePrekeys !! 4, someLastPrekeys !! 4)
  c21 :: Client <- responseJsonError =<< addClient brig uid2 (defNewClient PermanentClientType [pk21] lk21)
  c22 :: Client <- responseJsonError =<< addClient brig uid2 (defNewClient PermanentClientType [pk22] lk22)

  let domain = opts.settings.federationDomain
  uid3 <- userId <$> randomUser brig
  let mkPubClient cl = PubClient cl.clientId (clientClass cl)
  let expectedResponse :: QualifiedUserMap (Set PubClient) =
        QualifiedUserMap $
          Map.singleton
            domain
            ( UserMap $
                Map.fromList
                  [ (uid1, Set.fromList $ mkPubClient <$> [c11, c12, c13]),
                    (uid2, Set.fromList $ mkPubClient <$> [c21, c22])
                  ]
            )
  post
    ( apiVersion "v1"
        . brig
        . paths ["users", "list-clients"]
        . zUser uid3
        . contentJson
        . body (RequestBodyLBS $ encode [Qualified uid1 domain, Qualified uid2 domain])
    )
    !!! do
      const 200 === statusCode
      const (Just expectedResponse) === responseJsonMaybe

testClientsWithoutPrekeys :: Brig -> Cannon -> DB.ClientState -> Opt.Opts -> Http ()
testClientsWithoutPrekeys brig cannon db opts = do
  uid1 <- userId <$> randomUser brig
  let (pk11, lk11) = (somePrekeys !! 0, someLastPrekeys !! 0)
  c11 :: Client <- responseJsonError =<< addClient brig uid1 (defNewClient PermanentClientType [pk11] lk11)
  let (pk12, lk12) = (somePrekeys !! 1, someLastPrekeys !! 1)
  c12 :: Client <- responseJsonError =<< addClient brig uid1 (defNewClient PermanentClientType [pk12] lk12)

  -- Simulating loss of all prekeys from c11 (due e.g. DB problems, business
  -- logic prevents this from happening)
  let removeClientKeys :: DB.PrepQuery DB.W (UserId, ClientId) ()
      removeClientKeys = "DELETE FROM prekeys where user = ? and client = ?"
  liftIO $
    DB.runClient db $
      DB.write removeClientKeys (DB.params DB.LocalQuorum (uid1, c11.clientId))

  uid2 <- userId <$> randomUser brig

  let domain = opts.settings.federationDomain

  let userClients =
        QualifiedUserClients $
          Map.singleton domain $
            Map.singleton uid1 $
              Set.fromList [c11.clientId, c12.clientId]

  WS.bracketR cannon uid1 $ \ws -> do
    getClient brig uid1 c11.clientId !!! do
      const 200 === statusCode

    post
      ( apiVersion "v3"
          . brig
          . paths ["users", "list-prekeys"]
          . contentJson
          . body (RequestBodyLBS $ encode userClients)
          . zUser uid2
      )
      !!! do
        const 200 === statusCode
        const
          ( Right $
              expectedClientMap
                domain
                uid1
                [ (c11.clientId, Nothing),
                  (c12.clientId, Just pk12)
                ]
          )
          === responseJsonEither

    getClient brig uid1 c11.clientId !!! do
      const 404 === statusCode

    liftIO . WS.assertMatch (5 # Second) ws $ \n -> do
      let ob = Object $ NonEmpty.head (ntfPayload n)
      ob ^? key "type" . _String
        @?= Just "user.client-remove"
      ( fromByteString . T.encodeUtf8
          =<< (ob ^? key "client" . key "id" . _String)
        )
        @?= Just c11.clientId

  post
    ( apiVersion "v3"
        . brig
        . paths ["users", "list-prekeys"]
        . contentJson
        . body (RequestBodyLBS $ encode userClients)
        . zUser uid2
    )
    !!! do
      const 200 === statusCode
      const
        ( Right $
            expectedClientMap
              domain
              uid1
              [ (c11.clientId, Nothing),
                (c12.clientId, Just (unpackLastPrekey lk12))
              ]
        )
        === responseJsonEither
  where
    expectedClientMap :: Domain -> UserId -> [(ClientId, Maybe UncheckedPrekeyBundle)] -> QualifiedUserClientPrekeyMap
    expectedClientMap domain u xs =
      mkQualifiedUserClientPrekeyMap $
        Map.singleton domain $
          mkUserClientPrekeyMap $
            Map.singleton u $
              Map.fromList xs

testClientsWithoutPrekeysV4 :: Brig -> Cannon -> DB.ClientState -> Opt.Opts -> Http ()
testClientsWithoutPrekeysV4 brig cannon db opts = do
  uid1 <- userId <$> randomUser brig
  let (pk11, lk11) = (somePrekeys !! 0, someLastPrekeys !! 0)
  c11 :: Client <- responseJsonError =<< addClient brig uid1 (defNewClient PermanentClientType [pk11] lk11)
  let (pk12, lk12) = (somePrekeys !! 1, someLastPrekeys !! 1)
  c12 :: Client <- responseJsonError =<< addClient brig uid1 (defNewClient PermanentClientType [pk12] lk12)

  -- Simulating loss of all prekeys from c11 (due e.g. DB problems, business
  -- logic prevents this from happening)
  let removeClientKeys :: DB.PrepQuery DB.W (UserId, ClientId) ()
      removeClientKeys = "DELETE FROM prekeys where user = ? and client = ?"
  liftIO $
    DB.runClient db $
      DB.write removeClientKeys (DB.params DB.LocalQuorum (uid1, c11.clientId))

  uid2 <- userId <$> randomUser brig

  let domain = opts.settings.federationDomain

  let userClients =
        QualifiedUserClients $
          Map.singleton domain $
            Map.singleton uid1 $
              Set.fromList [c11.clientId, c12.clientId]

  WS.bracketR cannon uid1 $ \ws -> do
    getClient brig uid1 c11.clientId !!! do
      const 200 === statusCode

    post
      ( brig
          . paths ["users", "list-prekeys"]
          . contentJson
          . body (RequestBodyLBS $ encode userClients)
          . zUser uid2
      )
      !!! do
        const 200 === statusCode
        const
          ( Right $
              expectedClientMapClientsWithoutPrekeys
                domain
                uid1
                [ (c11.clientId, Nothing),
                  (c12.clientId, Just pk12)
                ]
                Nothing
          )
          === responseJsonEither

    getClient brig uid1 c11.clientId !!! do
      const 404 === statusCode

    liftIO . WS.assertMatch (5 # Second) ws $ \n -> do
      let ob = Object $ NonEmpty.head (ntfPayload n)
      ob ^? key "type" . _String
        @?= Just "user.client-remove"
      (fromByteString . T.encodeUtf8 =<< (ob ^? key "client" . key "id" . _String))
        @?= Just c11.clientId

  post
    ( brig
        . paths ["users", "list-prekeys"]
        . contentJson
        . body (RequestBodyLBS $ encode userClients)
        . zUser uid2
    )
    !!! do
      const 200 === statusCode
      const
        ( Right $
            expectedClientMapClientsWithoutPrekeys
              domain
              uid1
              [ (c11.clientId, Nothing),
                (c12.clientId, Just (unpackLastPrekey lk12))
              ]
              Nothing
        )
        === responseJsonEither

expectedClientMapClientsWithoutPrekeys :: Domain -> UserId -> [(ClientId, Maybe UncheckedPrekeyBundle)] -> Maybe [Qualified UserId] -> QualifiedUserClientPrekeyMapV4
expectedClientMapClientsWithoutPrekeys domain u xs failed =
  QualifiedUserClientPrekeyMapV4
    { qualifiedUserClientPrekeys =
        coerce $
          mkQualifiedUserClientPrekeyMap $
            Map.singleton domain $
              mkUserClientPrekeyMap $
                Map.singleton u $
                  Map.fromList xs,
      failedToList = failed
    }

testClientsWithoutPrekeysFailToListV4 :: Brig -> Cannon -> DB.ClientState -> Opt.Opts -> Http ()
testClientsWithoutPrekeysFailToListV4 brig cannon db opts = do
  uid1 <- userId <$> randomUser brig
  let (pk11, lk11) = (somePrekeys !! 0, someLastPrekeys !! 0)
  c11 :: Client <- responseJsonError =<< addClient brig uid1 (defNewClient PermanentClientType [pk11] lk11)
  let (pk12, lk12) = (somePrekeys !! 1, someLastPrekeys !! 1)
  c12 :: Client <- responseJsonError =<< addClient brig uid1 (defNewClient PermanentClientType [pk12] lk12)

  -- Simulating loss of all prekeys from c11 (due e.g. DB problems, business
  -- logic prevents this from happening)
  let removeClientKeys :: DB.PrepQuery DB.W (UserId, ClientId) ()
      removeClientKeys = "DELETE FROM prekeys where user = ? and client = ?"
  liftIO $
    DB.runClient db $
      DB.write removeClientKeys (DB.params DB.LocalQuorum (uid1, c11.clientId))

  uid2 <- fakeRemoteUser

  let domain = opts.settings.federationDomain

  let userClients1 =
        QualifiedUserClients $
          Map.singleton domain $
            Map.singleton uid1 $
              Set.fromList [c11.clientId, c12.clientId]
      userClients2 =
        QualifiedUserClients $
          Map.fromList
            [ ( qDomain uid2,
                Map.singleton (qUnqualified uid2) mempty
              )
            ]

  WS.bracketR cannon uid1 $ \ws -> do
    getClient brig uid1 c11.clientId !!! do
      const 200 === statusCode

    post
      ( brig
          . paths ["users", "list-prekeys"]
          . contentJson
          . body (RequestBodyLBS $ encode userClients1)
          . zUser (qUnqualified uid2)
      )
      !!! do
        const 200 === statusCode
        const
          ( Right $
              expectedClientMapClientsWithoutPrekeys
                domain
                uid1
                [ (c11.clientId, Nothing),
                  (c12.clientId, Just pk12)
                ]
                Nothing
          )
          === responseJsonEither

    getClient brig uid1 c11.clientId !!! do
      const 404 === statusCode

    liftIO . WS.assertMatch (5 # Second) ws $ \n -> do
      let ob = Object $ NonEmpty.head (ntfPayload n)
      ob ^? key "type" . _String
        @?= Just "user.client-remove"
      (fromByteString . T.encodeUtf8 =<< (ob ^? key "client" . key "id" . _String))
        @?= Just c11.clientId

  post
    ( brig
        . paths ["users", "list-prekeys"]
        . contentJson
        . body (RequestBodyLBS $ encode userClients2)
        . zUser (qUnqualified uid2)
    )
    !!! do
      const 200 === statusCode
      const
        ( Right $
            QualifiedUserClientPrekeyMapV4
              { qualifiedUserClientPrekeys = QualifiedUserClientMap Map.empty,
                failedToList = pure [uid2]
              }
        )
        === responseJsonEither

testListClientsBulkV2 :: Opt.Opts -> Brig -> Http ()
testListClientsBulkV2 opts brig = do
  uid1 <- userId <$> randomUser brig
  let (pk11, lk11) = (somePrekeys !! 0, someLastPrekeys !! 0)
  let (pk12, lk12) = (somePrekeys !! 1, someLastPrekeys !! 1)
  let (pk13, lk13) = (somePrekeys !! 2, someLastPrekeys !! 2)
  c11 :: Client <- responseJsonError =<< addClient brig uid1 (defNewClient PermanentClientType [pk11] lk11)
  c12 :: Client <- responseJsonError =<< addClient brig uid1 (defNewClient PermanentClientType [pk12] lk12)
  c13 :: Client <- responseJsonError =<< addClient brig uid1 (defNewClient TemporaryClientType [pk13] lk13)

  uid2 <- userId <$> randomUser brig
  let (pk21, lk21) = (somePrekeys !! 3, someLastPrekeys !! 3)
  let (pk22, lk22) = (somePrekeys !! 4, someLastPrekeys !! 4)
  c21 :: Client <- responseJsonError =<< addClient brig uid2 (defNewClient PermanentClientType [pk21] lk21)
  c22 :: Client <- responseJsonError =<< addClient brig uid2 (defNewClient PermanentClientType [pk22] lk22)

  let domain = opts.settings.federationDomain
  uid3 <- userId <$> randomUser brig
  let mkPubClient cl = PubClient cl.clientId cl.clientClass
  let expectedResponse :: WrappedQualifiedUserMap (Set PubClient) =
        Wrapped . QualifiedUserMap $
          Map.singleton
            domain
            ( UserMap $
                Map.fromList
                  [ (uid1, Set.fromList $ mkPubClient <$> [c11, c12, c13]),
                    (uid2, Set.fromList $ mkPubClient <$> [c21, c22])
                  ]
            )
  post
    ( apiVersion "v1"
        . brig
        . paths ["users", "list-clients", "v2"]
        . zUser uid3
        . contentJson
        . body (RequestBodyLBS $ encode (LimitedQualifiedUserIdList @20 (unsafeRange [Qualified uid1 domain, Qualified uid2 domain])))
    )
    !!! do
      const 200 === statusCode
      const (Just expectedResponse) === responseJsonMaybe

testListPrekeyIds :: Brig -> Http ()
testListPrekeyIds brig = do
  uid <- userId <$> randomUser brig
  let new = defNewClient PermanentClientType [somePrekeys !! 0] (someLastPrekeys !! 0)
  c :: Client <- responseJsonError =<< addClient brig uid new
  let pks = [PrekeyId 1, lastPrekeyId]
  get
    ( brig
        . paths ["clients", toByteString' c.clientId, "prekeys"]
        . zUser uid
    )
    !!! do
      const 200 === statusCode
      const (Just pks) === fmap sort . responseJsonMaybe

generateClients :: Int -> Brig -> Http [(UserId, Client, ClientPrekey, ClientPrekey)]
generateClients n brig = do
  for [1 .. n] $ \i -> do
    uid <- userId <$> randomUser brig
    let new = defNewClient TemporaryClientType [somePrekeys !! i] (someLastPrekeys !! i)
    c :: Client <- responseJsonError =<< addClient brig uid new
    let cpk = ClientPrekey c.clientId (somePrekeys !! i)
    let lpk = ClientPrekey c.clientId (unpackLastPrekey (someLastPrekeys !! i))
    pure (uid, c, lpk, cpk)

testGetUserPrekeys :: Brig -> Http ()
testGetUserPrekeys brig = do
  [(uid, _c, lpk, cpk)] <- generateClients 1 brig
  get (apiVersion "v1" . brig . paths ["users", toByteString' uid, "prekeys"] . zUser uid) !!! do
    const 200 === statusCode
    const (Just $ PrekeyBundle uid [cpk]) === responseJsonMaybe
  -- prekeys are deleted when retrieved, except the last one
  replicateM_ 2 $
    get (apiVersion "v1" . brig . paths ["users", toByteString' uid, "prekeys"] . zUser uid) !!! do
      const 200 === statusCode
      const (Just $ PrekeyBundle uid [lpk]) === responseJsonMaybe

testGetUserPrekeysQualified :: Brig -> Opt.Opts -> Http ()
testGetUserPrekeysQualified brig opts = do
  let domain = opts.settings.federationDomain
  [(uid, _c, _lpk, cpk)] <- generateClients 1 brig
  get (brig . paths ["users", toByteString' domain, toByteString' uid, "prekeys"] . zUser uid) !!! do
    const 200 === statusCode
    const (Just $ PrekeyBundle uid [cpk]) === responseJsonMaybe

testGetUserPrekeysInvalidDomain :: Brig -> Http ()
testGetUserPrekeysInvalidDomain brig = do
  [(uid, _c, _lpk, _)] <- generateClients 1 brig
  get (brig . paths ["users", "invalid.example.com", toByteString' uid, "prekeys"] . zUser uid) !!! do
    const 422 === statusCode

testGetClientPrekey :: Brig -> Http ()
testGetClientPrekey brig = do
  [(uid, c, _lpk, cpk)] <- generateClients 1 brig
  get (apiVersion "v1" . brig . paths ["users", toByteString' uid, "prekeys", toByteString' c.clientId] . zUser uid) !!! do
    const 200 === statusCode
    const (Just $ cpk) === responseJsonMaybe

testGetClientPrekeyQualified :: Brig -> Opt.Opts -> Http ()
testGetClientPrekeyQualified brig opts = do
  let domain = opts.settings.federationDomain
  [(uid, c, _lpk, cpk)] <- generateClients 1 brig
  get (brig . paths ["users", toByteString' domain, toByteString' uid, "prekeys", toByteString' c.clientId] . zUser uid) !!! do
    const 200 === statusCode
    const (Just $ cpk) === responseJsonMaybe

testMultiUserGetPrekeys :: Brig -> Http ()
testMultiUserGetPrekeys brig = do
  xs <- generateClients 3 brig
  let userClients =
        UserClients $
          Map.fromList $
            xs <&> \(uid, c, _lpk, _cpk) ->
              (uid, Set.fromList [c.clientId])

  let expectedUserClientMap =
        mkUserClientPrekeyMap $
          Map.fromList $
            xs <&> \(uid, c, _lpk, cpk) ->
              (uid, Map.singleton c.clientId (Just (prekeyData cpk)))

  uid <- userId <$> randomUser brig

  post
    ( apiVersion "v1"
        . brig
        . paths ["users", "prekeys"]
        . contentJson
        . body (RequestBodyLBS $ encode userClients)
        . zUser uid
    )
    !!! do
      const 200 === statusCode
      const (Right $ expectedUserClientMap) === responseJsonEither

testMultiUserGetPrekeysQualified :: Brig -> Opt.Opts -> Http ()
testMultiUserGetPrekeysQualified brig opts = do
  let domain = opts.settings.federationDomain

  xs <- generateClients 3 brig
  let userClients =
        QualifiedUserClients $
          Map.singleton domain $
            Map.fromList $
              xs <&> \(uid, c, _lpk, _cpk) ->
                (uid, Set.fromList [c.clientId])

  uid <- userId <$> randomUser brig

  let expectedUserClientMap =
        mkQualifiedUserClientPrekeyMap $
          Map.singleton domain $
            mkUserClientPrekeyMap $
              Map.fromList $
                xs <&> \(uid', c, _lpk, cpk) ->
                  (uid', Map.singleton c.clientId (Just (prekeyData cpk)))

  post
    ( apiVersion "v2"
        . brig
        . paths ["users", "list-prekeys"]
        . contentJson
        . body (RequestBodyLBS $ encode userClients)
        . zUser uid
    )
    !!! do
      const 200 === statusCode
      const (Right $ expectedUserClientMap) === responseJsonEither

testMultiUserGetPrekeysQualifiedV4 :: Brig -> Opt.Opts -> Http ()
testMultiUserGetPrekeysQualifiedV4 brig opts = do
  let domain = opts.settings.federationDomain

  xs <- generateClients 3 brig
  let userClients =
        QualifiedUserClients $
          Map.singleton domain $
            Map.fromList $
              xs <&> \(uid, c, _lpk, _cpk) ->
                (uid, Set.fromList [c.clientId])

  uid <- userId <$> randomUser brig

  let expectedUserClientMap =
        QualifiedUserClientPrekeyMapV4
          { qualifiedUserClientPrekeys =
              coerce $
                mkQualifiedUserClientPrekeyMap $
                  Map.singleton domain $
                    mkUserClientPrekeyMap $
                      Map.fromList $
                        xs <&> \(uid', c, _lpk, cpk) ->
                          (uid', Map.singleton c.clientId (Just (prekeyData cpk))),
            failedToList = Nothing
          }

  post
    ( brig
        . paths ["users", "list-prekeys"]
        . contentJson
        . body (RequestBodyLBS $ encode userClients)
        . zUser uid
    )
    !!! do
      const 200 === statusCode
      const (Right $ expectedUserClientMap) === responseJsonEither

-- The testTooManyClients test conforms to the following testing standards:
-- @SF.Provisioning @TSFI.RESTfulAPI @S2
--
-- The test validates the upper bound on the number of permanent clients per
-- user. It does so by trying to create one permanent client more than allowed.
-- The expected outcome is that all the clients up to the limit are successfully
-- created, but the one over the limit is not (error `404 too-many-clients`).
testTooManyClients :: Opt.Opts -> Brig -> Http ()
testTooManyClients opts brig = do
  uid <- userId <$> randomUser brig
  -- We can always change the permanent client limit
  let newOpts = opts & settingsLens . userMaxPermClientsLens ?~ 1
  withSettingsOverrides newOpts $ do
    -- There is only one temporary client, adding a new one
    -- replaces the previous one.
    forM_ [0 .. (3 :: Int)] $ \i ->
      let pk = somePrekeys !! i
          lk = someLastPrekeys !! i
       in addClient brig uid (defNewClient TemporaryClientType [pk] lk) !!! const 201 === statusCode
    -- We can't add more permanent clients than configured
    addClient brig uid (defNewClient PermanentClientType [somePrekeys !! 10] (someLastPrekeys !! 10)) !!! do
      const 201 === statusCode
    addClient brig uid (defNewClient PermanentClientType [somePrekeys !! 11] (someLastPrekeys !! 11)) !!! do
      const 403 === statusCode
      const (Just "too-many-clients") === fmap Error.label . responseJsonMaybe
      const (Just "application/json") === getHeader "Content-Type"

-- Ensure that the list of prekeys for a user does not become empty, and the
-- last resort prekey keeps being returned if it's the only key left.
-- Test with featureFlag randomPrekeys=true
testPrekeysNotEmptyRandomPrekeys :: Opt.Opts -> Brig -> Http ()
testPrekeysNotEmptyRandomPrekeys opts brig = do
  -- Run the test for randomPrekeys (not dynamoDB locking)
  let newOpts = opts {Opt.randomPrekeys = Just True}
  ensurePrekeysNotEmpty newOpts
  where
    ensurePrekeysNotEmpty :: Opt.Opts -> Http ()
    ensurePrekeysNotEmpty newOpts = withSettingsOverrides newOpts $ do
      lgr <- Log.new Log.defSettings
      uid <- userId <$> randomUser brig
      -- Create a client with 1 regular prekey and 1 last resort prekey
      c :: Client <- responseJsonError =<< addClient brig uid (defNewClient PermanentClientType [somePrekeys !! 10] (someLastPrekeys !! 10))
      -- Claim the first regular one
      _rs1 <- getPreKey brig uid uid c.clientId <!! const 200 === statusCode
      -- Claim again; this should give the last resort one
      rs2 <- getPreKey brig uid uid c.clientId <!! const 200 === statusCode
      let pId2 = prekeyId . prekeyData <$> responseJsonMaybe rs2
      liftIO $ assertEqual "last prekey rs2" (Just lastPrekeyId) pId2
      liftIO $ Log.warn lgr (Log.msg (Log.val "First claim of last resort successful, claim again..."))
      -- Claim again; this should (again) give the last resort one
      rs3 <- getPreKey brig uid uid c.clientId <!! const 200 === statusCode
      let pId3 = prekeyId . prekeyData <$> responseJsonMaybe rs3
      liftIO $ assertEqual "last prekey rs3" (Just lastPrekeyId) pId3

testRegularPrekeysCannotBeSentAsLastPrekeys :: Brig -> Http ()
testRegularPrekeysCannotBeSentAsLastPrekeys brig = do
  uid <- userId <$> randomUser brig
  -- The parser should reject a normal prekey in the lastPrekey field
  addClient brig uid (defNewClient PermanentClientType [head somePrekeys] fakeLastPrekey) !!! const 400 === statusCode

testRegularPrekeysCannotBeSentAsLastPrekeysDuringUpdate :: Brig -> Http ()
testRegularPrekeysCannotBeSentAsLastPrekeysDuringUpdate brig = do
  uid <- userId <$> randomUser brig
  c :: Client <- responseJsonError =<< addClient brig uid (defNewClient PermanentClientType [head somePrekeys] (someLastPrekeys !! 11)) <!! const 201 === statusCode
  let newPrekey = somePrekeys !! 2
  let update =
        defUpdateClient
          { updateClientPrekeys = [newPrekey],
            updateClientLastKey = Just fakeLastPrekey,
            updateClientLabel = Just "label"
          }
  -- The parser should reject a normal prekey in the lastPrekey field
  put
    ( brig
        . paths ["clients", toByteString' c.clientId]
        . zUser uid
        . contentJson
        . body (RequestBodyLBS $ encode update)
    )
    !!! const 400
      === statusCode

-- @END

-- The testRemoveClient test conforms to the following testing standards:
-- @SF.Provisioning @TSFI.RESTfulAPI @S2
--
-- This test validates creating and deleting a client. A client is created and
-- consequently deleted. Deleting a second time yields response 404 not found.
-- Prekeys and cookies are not there anymore once the client is deleted.
testRemoveClient :: Bool -> Brig -> Cannon -> Http ()
testRemoveClient hasPwd brig cannon = do
  u <- randomUser' hasPwd brig
  let uid = userId u
  let Just email = userEmail u
  -- Permanent client with attached cookie
  when hasPwd $ do
    login brig (defEmailLogin email) PersistentCookie
      !!! const 200
        === statusCode
    numCookies <- countCookies brig uid defCookieLabel
    liftIO $ Just 1 @=? numCookies
  c :: Client <- responseJsonError =<< addClient brig uid (client PermanentClientType (someLastPrekeys !! 10))
  when hasPwd $ do
    -- Missing password
    deleteClient brig uid c.clientId Nothing !!! const 403 === statusCode
  -- Success
  WS.bracketR cannon uid $ \ws -> do
    deleteClient brig uid c.clientId (if hasPwd then Just defPasswordText else Nothing)
      !!! const 200
        === statusCode
    void . liftIO . WS.assertMatch (5 # Second) ws $ \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 c.clientId
  -- Not found on retry
  deleteClient brig uid c.clientId Nothing !!! const 404 === statusCode
  -- Prekeys are gone
  getPreKey brig uid uid c.clientId !!! const 404 === statusCode
  -- Cookies are gone
  numCookies' <- countCookies brig (userId u) defCookieLabel
  liftIO $ Just 0 @=? numCookies'
  where
    client ty lk =
      (defNewClient ty [somePrekeys !! 0] lk)
        { newClientLabel = Just "Nexus 5x",
          newClientCookie = Just defCookieLabel
        }

-- @END

-- The testRemoveClientShortPwd test conforms to the following testing standards:
-- @SF.Provisioning @TSFI.RESTfulAPI @S2
--
-- The test checks if a client can be deleted by providing a too short password.
-- This is done by using a single-character password, whereas the minimum is 6
-- characters. The client deletion attempt fails as expected.
testRemoveClientShortPwd :: Brig -> Http ()
testRemoveClientShortPwd brig = do
  u <- randomUser brig
  let uid = userId u
  let Just email = userEmail u
  -- Permanent client with attached cookie
  login brig (defEmailLogin email) PersistentCookie
    !!! const 200
      === statusCode
  numCookies <- countCookies brig uid defCookieLabel
  liftIO $ Just 1 @=? numCookies
  c :: Client <- responseJsonError =<< addClient brig uid (client PermanentClientType (someLastPrekeys !! 10))
  resp <-
    deleteClient brig uid c.clientId (Just "a")
      <!! const 400
        === statusCode
  err :: Object <- responseJsonError resp
  liftIO $ do
    (err ^. at "code") @?= Just (Number 400)
    (err ^. at "label") @?= Just (String "bad-request")
    (err ^. at "message") @?= Just (String "Error in $.password: outside range [6, 1024]")
  where
    client ty lk =
      (defNewClient ty [somePrekeys !! 0] lk)
        { newClientLabel = Just "Nexus 5x",
          newClientCookie = Just defCookieLabel
        }

-- @END

-- The testRemoveClientIncorrectPwd test conforms to the following testing standards:
-- @SF.Provisioning @TSFI.RESTfulAPI @S2
--
-- The test checks if a client can be deleted by providing a syntax-valid, but
-- incorrect password. The client deletion attempt fails with a 403 error
-- response.
testRemoveClientIncorrectPwd :: Brig -> Http ()
testRemoveClientIncorrectPwd brig = do
  u <- randomUser brig
  let uid = userId u
  let Just email = userEmail u
  -- Permanent client with attached cookie
  login brig (defEmailLogin email) PersistentCookie
    !!! const 200
      === statusCode
  numCookies <- countCookies brig uid defCookieLabel
  liftIO $ Just 1 @=? numCookies
  c :: Client <- responseJsonError =<< addClient brig uid (client PermanentClientType (someLastPrekeys !! 10))
  resp <-
    deleteClient brig uid c.clientId (Just "abcdef")
      <!! const 403
        === statusCode
  err :: Object <- responseJsonError resp
  liftIO $ do
    (err ^. at "code") @?= Just (Number 403)
    (err ^. at "label") @?= Just (String "invalid-credentials")
    (err ^. at "message") @?= Just (String "Authentication failed")
  where
    client ty lk =
      (defNewClient ty [somePrekeys !! 0] lk)
        { newClientLabel = Just "Nexus 5x",
          newClientCookie = Just defCookieLabel
        }

-- @END

testUpdateClient :: Opt.Opts -> Brig -> Http ()
testUpdateClient opts brig = do
  uid <- userId <$> randomUser brig
  let clt =
        (defNewClient TemporaryClientType [somePrekeys !! 0] (someLastPrekeys !! 0))
          { newClientClass = Just PhoneClient,
            newClientModel = Just "featurephone"
          }
  c :: Client <- responseJsonError =<< addClient brig uid clt
  get (apiVersion "v1" . brig . paths ["users", toByteString' uid, "prekeys", toByteString' c.clientId] . zUser uid) !!! do
    const 200 === statusCode
    const (Just $ ClientPrekey c.clientId (somePrekeys !! 0)) === responseJsonMaybe
  getClient brig uid c.clientId !!! do
    const 200 === statusCode
    const (Just "Test Device") === (clientLabel <=< responseJsonMaybe)
    const (Just PhoneClient) === (clientClass <=< responseJsonMaybe)
    const (Just "featurephone") === (clientModel <=< responseJsonMaybe)
  let newPrekey = somePrekeys !! 2
  let update =
        defUpdateClient
          { updateClientPrekeys = [newPrekey],
            updateClientLabel = Just "label"
          }
  put
    ( brig
        . paths ["clients", toByteString' c.clientId]
        . zUser uid
        . contentJson
        . body (RequestBodyLBS $ encode update)
    )
    !!! const 200
      === statusCode
  get (apiVersion "v1" . brig . paths ["users", toByteString' uid, "prekeys", toByteString' c.clientId] . zUser uid) !!! do
    const 200 === statusCode
    const (Just $ ClientPrekey c.clientId newPrekey) === responseJsonMaybe

  -- check if label has been updated
  getClient brig uid c.clientId !!! do
    const 200 === statusCode
    const (Just "label") === (clientLabel <=< responseJsonMaybe)

  -- via `/users/:uid/clients/:client`, only `id` and `class` are visible:
  get (apiVersion "v1" . brig . paths ["users", toByteString' uid, "clients", toByteString' c.clientId]) !!! do
    const 200 === statusCode
    const (Just c.clientId) === (fmap pubClientId . responseJsonMaybe)
    const (Just PhoneClient) === (pubClientClass <=< responseJsonMaybe)
    const Nothing === (preview (key "label") <=< responseJsonMaybe @Value)
    const Nothing === (preview (key "mls_public_keys") <=< responseJsonMaybe @Value)

  -- via `/users/:domain/:uid/clients/:client`, only `id` and `class` are visible:
  let localdomain = opts.settings.federationDomain
  get (brig . paths ["users", toByteString' localdomain, toByteString' uid, "clients", toByteString' c.clientId]) !!! do
    const 200 === statusCode
    const (Just c.clientId) === (fmap pubClientId . responseJsonMaybe)
    const (Just PhoneClient) === (pubClientClass <=< responseJsonMaybe)
    const Nothing === (preview (key "label") <=< responseJsonMaybe @Value)
    const Nothing === (preview (key "mls_public_keys") <=< responseJsonMaybe @Value)

  let update' = defUpdateClient

  -- empty update should be a no-op
  put
    ( apiVersion "v1"
        . brig
        . paths ["clients", toByteString' c.clientId]
        . zUser uid
        . contentJson
        . body (RequestBodyLBS $ encode update')
    )
    !!! const 200
      === statusCode

  -- check if label is still present
  getClient brig uid c.clientId !!! do
    const 200 === statusCode
    const (Just "label") === (clientLabel <=< responseJsonMaybe)

  -- update supported client capabilities work
  let checkUpdate :: (HasCallStack) => Maybe [ClientCapability] -> Bool -> [ClientCapability] -> Http ()
      checkUpdate capsIn respStatusOk capsOut = do
        let update'' = defUpdateClient {updateClientCapabilities = ClientCapabilityList . Set.fromList <$> capsIn}
        put
          ( apiVersion "v1"
              . brig
              . paths ["clients", toByteString' c.clientId]
              . zUser uid
              . contentJson
              . body (RequestBodyLBS $ encode update'')
          )
          !!! if respStatusOk
            then do
              const 200 === statusCode
            else do
              const 409 === statusCode
              const (Just "client-capabilities-cannot-be-removed") === fmap Error.label . responseJsonMaybe

        getClientCapabilities brig uid c.clientId !!! do
          const 200 === statusCode
          const (Just (ClientCapabilityList (Set.fromList capsOut))) === responseJsonMaybe

  checkUpdate (Just [ClientSupportsLegalholdImplicitConsent]) True [ClientSupportsLegalholdImplicitConsent]
  checkUpdate Nothing True [ClientSupportsLegalholdImplicitConsent]
  checkUpdate (Just []) False [ClientSupportsLegalholdImplicitConsent]

  -- update supported client capabilities don't break prekeys or label
  do
    let checkClientLabel :: (HasCallStack) => Http ()
        checkClientLabel = do
          getClient brig uid c.clientId !!! do
            const 200 === statusCode
            const (Just label) === (clientLabel <=< responseJsonMaybe)

        flushClientPrekey :: (HasCallStack) => Http (Maybe ClientPrekey)
        flushClientPrekey = do
          responseJsonMaybe
            <$> ( get
                    (apiVersion "v1" . brig . paths ["users", toByteString' uid, "prekeys", toByteString' c.clientId] . zUser uid)
                    <!! const 200
                      === statusCode
                )

        checkClientPrekeys :: (HasCallStack) => UncheckedPrekeyBundle -> Http ()
        checkClientPrekeys expectedPrekey = do
          flushClientPrekey >>= \case
            Nothing -> error "unexpected."
            Just (ClientPrekey cid' prekey') -> liftIO $ do
              assertEqual "" c.clientId cid'
              assertEqual "" expectedPrekey prekey'

        caps = Just $ ClientCapabilityList $ Set.fromList [ClientSupportsLegalholdImplicitConsent]

        label = "label-bc1b7b0c-b7bf-11eb-9a1d-233d397f934a"
        prekey = somePrekeys !! 4
        lastprekey = someLastPrekeys !! 4

    void $ flushClientPrekey >> flushClientPrekey
    put
      ( brig
          . paths ["clients", toByteString' c.clientId]
          . zUser uid
          . json
            defUpdateClient
              { updateClientPrekeys = [prekey],
                updateClientLastKey = Just lastprekey,
                updateClientLabel = Just label
              }
      )
      !!! const 200
        === statusCode
    checkClientLabel
    put
      ( brig
          . paths ["clients", toByteString' c.clientId]
          . zUser uid
          . json defUpdateClient {updateClientCapabilities = caps}
      )
      !!! const 200
        === statusCode
    checkClientLabel
    checkClientPrekeys prekey
    checkClientPrekeys (unpackLastPrekey lastprekey)

testMLSPublicKeyUpdate :: Brig -> Http ()
testMLSPublicKeyUpdate brig = do
  uid <- userId <$> randomUser brig
  let clt =
        (defNewClient TemporaryClientType [somePrekeys !! 0] (someLastPrekeys !! 0))
          { newClientClass = Just PhoneClient,
            newClientModel = Just "featurephone"
          }
  c :: Client <- responseJsonError =<< addClient brig uid clt
  let keys = Map.fromList [(Ed25519, "aGVsbG8gd29ybGQ=")]
  putClient brig uid c.clientId keys !!! const 200 === statusCode
  c' <- responseJsonError =<< getClient brig uid c.clientId <!! const 200 === statusCode
  liftIO $ clientMLSPublicKeys c' @?= keys
  -- adding the key again should fail
  putClient brig uid c.clientId keys !!! const 400 === statusCode

testMissingClient :: Brig -> Http ()
testMissingClient brig = do
  uid <- userId <$> randomUser brig
  c <- liftIO $ generate arbitrary
  getClient brig uid c !!! do
    const 404 === statusCode
    -- This is unfortunate, but fixing this breaks clients.
    const Nothing === responseBody
    const ["text/plain;charset=utf-8"]
      === map snd
        . filter ((== "Content-Type") . fst)
        . responseHeaders

-- The testAddMultipleTemporary test conforms to the following testing standards:
-- @SF.Provisioning @TSFI.RESTfulAPI @S2
-- Legacy (galley)
--
-- Add temporary client, check that all services (both galley and
-- brig) have registered it.  Add second temporary client, check
-- again.  (NB: temp clients replace each other, there can always be
-- at most one per account.)
testAddMultipleTemporary :: (HasCallStack) => Brig -> Galley -> Cannon -> Http ()
testAddMultipleTemporary brig galley cannon = do
  uid <- userId <$> randomUser brig
  let clt1 =
        (defNewClient TemporaryClientType [somePrekeys !! 0] (someLastPrekeys !! 0))
          { newClientClass = Just PhoneClient,
            newClientModel = Just "featurephone1"
          }

  client :: Client <- responseJsonError =<< addClient brig uid clt1

  brigClients1 <- numOfBrigClients uid
  galleyClients1 <- numOfGalleyClients uid
  liftIO $ assertEqual "Too many clients found" (Just 1) brigClients1
  liftIO $ assertEqual "Too many clients found" (Just 1) galleyClients1
  let clt2 =
        (defNewClient TemporaryClientType [somePrekeys !! 1] (someLastPrekeys !! 1))
          { newClientClass = Just PhoneClient,
            newClientModel = Just "featurephone2"
          }

  brigClients2 <- numOfBrigClients uid
  liftIO $ assertEqual "Too many clients found" (Just 1) brigClients2

  WS.bracketR cannon uid $ \ws -> do
    _ <- addClient brig uid clt2
    void . liftIO . WS.assertMatch (5 # Second) ws $ \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 client.clientId

  galleyClients2 <- numOfGalleyClients uid
  liftIO $ assertEqual "Too many clients found" (Just 1) galleyClients2
  where
    numOfBrigClients u = do
      r <-
        get $
          brig
            . path "clients"
            . zUser u
      pure $ Vec.length <$> (preview _Array =<< responseJsonMaybe @Value r)
    numOfGalleyClients u = do
      r <-
        get $
          galley
            . path "i/test/clients"
            . zUser u
      pure $ Vec.length <$> (preview _Array =<< responseJsonMaybe @Value r)

-- @END

testPreKeyRace :: Brig -> Http ()
testPreKeyRace brig = do
  uid <- userId <$> randomUser brig
  let pks = map (\i -> somePrekeys !! i) [1 .. 10]
  c :: Client <- responseJsonError =<< addClient brig uid (defNewClient PermanentClientType pks (someLastPrekeys !! 0))
  pks' <- flip mapConcurrently pks $ \_ -> do
    rs <- getPreKey brig uid uid c.clientId <!! const 200 === statusCode
    pure $ prekeyId . prekeyData <$> responseJsonMaybe rs
  -- We should not hand out regular prekeys more than once (i.e. at most once).
  let actual = catMaybes pks'
  liftIO $ assertEqual "insufficient prekeys" (length pks) (length actual)
  let regular = filter (/= lastPrekeyId) actual
  liftIO $ assertEqual "duplicate prekeys" (length regular) (length (nub regular))
  deleteClient brig uid c.clientId (Just defPasswordText) !!! const 200 === statusCode

testNewNonce :: Brig -> Http ()
testNewNonce brig = do
  n1 <- check Util.getNonce 204
  n2 <- check Util.headNonce 200
  lift $ assertBool "nonces should not be equal" (n1 /= n2)
  where
    check f status = do
      uid <- userId <$> randomUser brig
      cid <- randomClient
      response <- f brig uid cid <!! const status === statusCode
      let nonceBs = getHeader "Replay-Nonce" response
      liftIO $ do
        assertBool "Replay-Nonce header should contain a valid base64url encoded uuidv4" $ any isValidBase64UrlEncodedUUID nonceBs
        Just "no-store" @=? getHeader "Cache-Control" response
      pure nonceBs

data DPoPClaimsSet = DPoPClaimsSet
  { jwtClaims :: ClaimsSet,
    claimNonce :: Text,
    claimHtm :: Text,
    claimHtu :: Text,
    claimChal :: Text,
    claimHandle :: Text,
    claimDisplayName :: Text,
    claimTeamId :: Text
  }
  deriving (Eq, Show, Generic)

instance HasClaimsSet DPoPClaimsSet where
  claimsSet f s = fmap (\a' -> s {jwtClaims = a'}) (f (jwtClaims s))

instance A.FromJSON DPoPClaimsSet where
  parseJSON = A.withObject "OAuthClaimsSet" $ \o ->
    DPoPClaimsSet
      <$> A.parseJSON (A.Object o)
      <*> o A..: "nonce"
      <*> o A..: "htm"
      <*> o A..: "htu"
      <*> o A..: "chal"
      <*> o A..: "handle"
      <*> o A..: "name"
      <*> o A..: "team"

instance A.ToJSON DPoPClaimsSet where
  toJSON s =
    ins "nonce" (claimNonce s) (A.toJSON (jwtClaims s))
      & ins "htm" (claimHtm s)
      & ins "htu" (claimHtu s)
      & ins "chal" (claimChal s)
      & ins "handle" (claimHandle s)
      & ins "name" (claimDisplayName s)
      & ins "team" (claimTeamId s)
    where
      ins k v (Object o) = Object $ M.insert k (A.toJSON v) o
      ins _ _ a = a

testCreateAccessToken :: Opt.Opts -> Nginz -> Brig -> Http ()
testCreateAccessToken opts n brig = do
  let localDomain = opts.settings.federationDomain
  (u, tid) <- Util.createUserWithTeam' brig
  handle <- do
    Just h <- userHandle <$> Util.setRandomHandle brig u
    pure $ "wireapp://%40" <> fromHandle h <> "@" <> cs (toByteString' localDomain)
  let uid = userId u
  let Just email = userEmail u
  -- convert the user Id into 16 octets of binary and then base64url
  let uidBS = Data.UUID.toByteString (toUUID uid)
  let uidB64 = encodeBase64UrlUnpadded (cs uidBS)
  rs <-
    login n (defEmailLogin email) PersistentCookie
      <!! const 200 === statusCode
  let t = decodeToken rs
  cid <- createClientForUser brig uid
  nonceResponse <- Util.headNonceNginz n t cid <!! const 200 === statusCode
  let nonceBs = cs $ fromMaybe (error "invalid nonce") $ getHeader "Replay-Nonce" nonceResponse
  now <- liftIO $ posixSecondsToUTCTime . fromInteger <$> (floor <$> getPOSIXTime)
  let clientIdentity = cs $ "wireapp://" <> cs (toText uidB64) <> "!" <> toByteString' cid <> "@" <> toByteString' localDomain
  let httpsUrl = cs $ "https://" <> toByteString' localDomain <> "/clients/" <> toByteString' cid <> "/access-token"
  let expClaim = NumericDate $ addUTCTime 10 now
  let claimsSet' =
        emptyClaimsSet
          & claimIat ?~ NumericDate now
          & claimExp ?~ expClaim
          & claimNbf ?~ NumericDate now
          & claimSub ?~ fromMaybe (error "invalid sub claim") ((clientIdentity :: Text) ^? stringOrUri)
          & claimJti ?~ "6fc59e7f-b666-4ffc-b738-4f4760c884ca"
          & claimAud ?~ (maybe (error "invalid sub claim") (Audience . (: [])) (("https://wire.com/acme/challenge/abcd" :: Text) ^? stringOrUri))
  let dpopClaims =
        DPoPClaimsSet
          claimsSet'
          nonceBs
          "POST"
          httpsUrl
          "wa2VrkCtW1sauJ2D3uKY8rc7y4kl4usH"
          handle
          (fromName u.userDisplayName)
          (UUID.toText (toUUID tid))
  signedOrError <- fmap encodeCompact <$> liftIO (signProofEcdsaP256 dpopClaims)
  case signedOrError of
    Left err -> liftIO $ assertFailure $ "failed to sign claims: " <> show err
    Right signed -> do
      let accessControlExposeHeaders = maybe "" cs $ getHeader "Access-Control-Expose-Headers" nonceResponse
      liftIO $ assertBool "Access-Control-Expose-Headers should contain Replay-Nonce" $ "Replay-Nonce" `isInfixOf` accessControlExposeHeaders
      let proof = Just $ Proof (cs signed)
      response <- Util.createAccessTokenNginz n t cid proof
      let accessToken = fromRight (error $ "failed to create token: " <> show response) $ responseJsonEither response
      liftIO $ datrType accessToken @?= DPoP
  where
    -- FUTUREWORK: parameterize the signing algorithm
    _signProof :: DPoPClaimsSet -> IO (Either JWTError SignedJWT)
    _signProof claims = runJOSE $ do
      algo <- bestJWSAlg jwkKey
      let h =
            newJWSHeaderProtected algo
              & (jwk ?~ HeaderParam RequiredProtection jwkPubKey)
              & (typ ?~ HeaderParam RequiredProtection "dpop+jwt")
      signJWT jwkKey h claims

    signProofEcdsaP256 :: DPoPClaimsSet -> IO (Either JWTError SignedJWT)
    signProofEcdsaP256 claims = runJOSE $ do
      algo <- bestJWSAlg jwkKeyBundleEcdsaP256
      let h =
            newJWSHeaderProtected algo
              & (jwk ?~ HeaderParam RequiredProtection jwkPublicKeyEcdsaP256)
              & (typ ?~ HeaderParam RequiredProtection "dpop+jwt")
      signJWT jwkKeyBundleEcdsaP256 h claims

    jwkKey :: JWK
    jwkKey = do
      fromMaybe (error "invalid jwk") . A.decode $
        "{\"kty\":\"OKP\",\"d\":\"9RVey-A7ENCO5e9fDiPf8An1gkVBmAhFgu4WZMVwS-A\",\"crv\":\"Ed25519\",\"x\":\"nLJGN-Oa6Jsq3KclZggLl7UvAVdmB0Q6C3N5BCgphHw\"}"

    jwkPubKey :: JWK
    jwkPubKey = do
      fromMaybe (error "invalid jwk") . A.decode $
        "{\"kty\":\"OKP\",\"crv\":\"Ed25519\",\"x\":\"nLJGN-Oa6Jsq3KclZggLl7UvAVdmB0Q6C3N5BCgphHw\"}"

    jwkKeyBundleEcdsaP256 :: JWK
    jwkKeyBundleEcdsaP256 = do
      fromMaybe (error "invalid jwk") . A.decode $
        "{\"kty\":\"EC\",\"alg\":\"ES256\",\"crv\":\"P-256\",\"x\":\"hcYjloNodyCLF_rQd_HIszSpa2J-vzrgntneAJW5pA8\",\"y\":\"6MXxnHq1FmAWCc6A7YValxvekicBv53ARTQO35mRKJ8\",\"d\":\"yz1weEXJbJao6wLiml8fahLt3BnJxdHWfbpUB0i8GLo\"}"

    jwkPublicKeyEcdsaP256 :: JWK
    jwkPublicKeyEcdsaP256 = do
      fromMaybe (error "invalid jwk") . A.decode $
        "{\"kty\":\"EC\",\"alg\":\"ES256\",\"crv\":\"P-256\",\"x\":\"hcYjloNodyCLF_rQd_HIszSpa2J-vzrgntneAJW5pA8\",\"y\":\"6MXxnHq1FmAWCc6A7YValxvekicBv53ARTQO35mRKJ8\"}"

testCreateAccessTokenMissingProof :: Brig -> Http ()
testCreateAccessTokenMissingProof brig = do
  uid <- userId <$> randomUser brig
  cid <- createClientForUser brig uid
  let mProof = Nothing
  Util.createAccessToken brig uid "some_host_name" cid mProof
    !!! do
      const 400 === statusCode

testCreateAccessTokenNoNonce :: Brig -> Http ()
testCreateAccessTokenNoNonce brig = do
  (u, _) <- Util.createUserWithTeam' brig
  void $ Util.setRandomHandle brig u
  let uid = userId u
  cid <- createClientForUser brig uid
  Util.createAccessToken brig uid "some_host_name" cid (Just $ Proof "xxxx.yyyy.zzzz")
    !!! do
      const 400 === statusCode
      const (Just "client-token-bad-nonce") === fmap Error.label . responseJsonMaybe

createClientForUser :: Brig -> UserId -> Http ClientId
createClientForUser brig uid = do
  c :: Client <-
    responseJsonError
      =<< addClient
        brig
        uid
        (defNewClient PermanentClientType [head somePrekeys] (head someLastPrekeys))
  pure c.clientId
