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

module API.User.Handles
  ( tests,
  )
where

import API.Search.Util qualified as Search
import API.Team.Util
import API.User.Util
import Bilge hiding (accept, timeout)
import Bilge.Assert
import Brig.Options qualified as Opt
import Control.Lens hiding (from, (#))
import Control.Monad.Catch (MonadCatch)
import Data.Aeson
import Data.Aeson.Lens
import Data.ByteString.Conversion
import Data.Handle (parseHandle)
import Data.Id
import Data.List.NonEmpty qualified as NonEmpty
import Data.Qualified (Qualified (..))
import Data.Set qualified as Set
import Data.UUID qualified as UUID
import Imports
import Network.Wai.Utilities.Error qualified as Error
import Network.Wai.Utilities.Error qualified as Wai
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 hiding (target)
import Wire.API.Team.Feature (FeatureStatus (..))
import Wire.API.Team.SearchVisibility
import Wire.API.User
import Wire.API.User.Handle

tests :: ConnectionLimit -> Timeout -> Opt.Opts -> Manager -> Brig -> Cannon -> Galley -> TestTree
tests _cl _at conf p b c g =
  testGroup
    "handles"
    [ test p "testHandleUpdate - handles/update" $ testHandleUpdate b c,
      test p "handles/race" $ testHandleRace b,
      test p "handles/query" $ testHandleQuery conf b,
      test p "handles/query - team-search-visibility SearchVisibilityStandard" $ testHandleQuerySearchVisibilityStandard conf b,
      test p "handles/query - team-search-visibility SearchVisibilityNoNameOutsideTeam" $ testHandleQuerySearchVisibilityNoNameOutsideTeam conf b g,
      test p "GET /handles/<handle> 200" $ testGetUserByUnqualifiedHandle b,
      test p "GET /handles/<handle> 404" $ testGetUserByUnqualifiedHandleFailure b,
      test p "GET /users/by-handle/<domain>/<handle> : 200" $ testGetUserByQualifiedHandle b,
      test p "GET /users/by-handle/<domain>/<handle> : 404" $ testGetUserByQualifiedHandleFailure b,
      test p "GET /users/by-handle/<domain>/<handle> : no federation" $ testGetUserByQualifiedHandleNoFederation conf b
    ]

-- The next line contains a mapping from the testHandleUpdate test to the following test standards:
-- @SF.Provisioning @TSFI.RESTfulAPI @S2
--
-- The test validates various updates to the user's handle. First, it attempts
-- to set invalid handles. This fails. Then it successfully sets a valid handle.
-- The user can retry setting the valid handle. The next scenario is for another
-- user to attempt to reuse an already used handle, which fails. Finally,
-- several scenarios of searching users by handle are explored, where users
-- appear by handle. A user can also free a handle and then reclaim it again.
testHandleUpdate :: Brig -> Cannon -> Http ()
testHandleUpdate brig cannon = do
  user <- randomUser brig
  let uid = userId user
      quid = userQualifiedId user
  -- Invalid handles are rejected
  let badHandles = ["ca$h", "w", "Capital", "wire"]
  forM_ badHandles $ \h -> do
    let upd = RequestBodyLBS . encode $ HandleUpdate h
    put (brig . path "/self/handle" . contentJson . zUser uid . zConn "c" . body upd) !!! do
      const 400 === statusCode
      const (Just "invalid-handle") === fmap Error.label . responseJsonMaybe
  -- Claim a valid handle & receive notification
  hdl <- randomHandle
  let update = RequestBodyLBS . encode $ HandleUpdate hdl
  WS.bracketR cannon uid $ \ws -> do
    put (brig . path "/self/handle" . contentJson . zUser uid . zConn "c" . body update)
      !!! const 200 === statusCode
    void . liftIO . WS.assertMatch (5 # Second) ws $ \n -> do
      let j = Object $ NonEmpty.head (ntfPayload n)
      j ^? key "type" . _String @?= Just "user.update"
      let u = j ^?! key "user"
      u ^? key "id" . _String @?= Just (UUID.toText (toUUID uid))
      u ^? key "handle" . _String @?= Just hdl
  -- The owner of the handle can always retry the update
  put (brig . path "/self/handle" . contentJson . zUser uid . zConn "c" . body update)
    !!! const 200 === statusCode
  Bilge.head (brig . paths ["handles", toByteString' hdl] . zUser uid)
    !!! const 200 === statusCode
  -- For other users, the handle is unavailable
  uid2 <- userId <$> randomUser brig
  put (brig . path "/self/handle" . contentJson . zUser uid2 . zConn "c" . body update) !!! do
    const 409 === statusCode
    const (Just "handle-exists") === fmap Error.label . responseJsonMaybe
  -- The owner appears by that handle in search
  Search.refreshIndex brig
  Search.assertCanFind brig uid2 quid hdl
  -- Change the handle again, thus freeing the old handle
  hdl2 <- randomHandle
  let update2 = RequestBodyLBS . encode $ HandleUpdate hdl2
  put (brig . path "/self/handle" . contentJson . zUser uid . zConn "c" . body update2)
    !!! const 200 === statusCode
  Bilge.head (brig . paths ["handles", toByteString' hdl] . zUser uid)
    !!! const 404 === statusCode
  -- The owner appears by the new handle in search
  Search.refreshIndex brig
  Search.assertCan'tFind brig uid2 quid hdl
  Search.assertCanFind brig uid2 quid hdl2
  -- Other users can immediately claim the old handle (the claim of the old handle is
  -- removed).
  put (brig . path "/self/handle" . contentJson . zUser uid2 . zConn "c" . body update) !!! do
    const 200 === statusCode
  -- The old handle can be claimed again immediately by the user who previously
  -- owned it (since the claim is either still active but his own, or expired).
  -- make sure 'hdl' is not used by 'uid2' already.
  hdl3 <- randomHandle
  let update3 = RequestBodyLBS . encode $ HandleUpdate hdl3
  put (brig . path "/self/handle" . contentJson . zUser uid2 . zConn "c" . body update3) !!! do
    const 200 === statusCode
  -- now 'uid2' takes 'hld' back.
  put (brig . path "/self/handle" . contentJson . zUser uid2 . zConn "c" . body update)
    !!! const 200 === statusCode

-- @END

testHandleRace :: Brig -> Http ()
testHandleRace brig = do
  us <- replicateM 10 (userId <$> randomUser brig)
  -- 10 races. In each race, 10 users try to claim the same handle.
  -- At most one of them should get the handle in each race
  -- (usually no-one due to the contention).
  void . replicateM 10 $ do
    hdl <- randomHandle
    let update = RequestBodyLBS . encode $ HandleUpdate hdl
    responses <- flip mapConcurrently us $ \u ->
      put (brig . path "/self/handle" . contentJson . zUser u . zConn "c" . body update)
    let statusCodes = map statusCode responses
    liftIO $ assertBool "At most one update should succeed" (length (filter (== 200) statusCodes) <= 1)
    liftIO $ assertBool "Failed updates should return 409" (Set.fromList (filter (/= 200) statusCodes) == Set.singleton 409)
    ps <- forM us $ \u -> responseJsonMaybe <$> get (brig . path "/self" . zUser u)
    let owners = catMaybes $ filter (maybe False ((== Just (fromJust (parseHandle hdl))) . userHandle)) ps
    liftIO $ assertBool "More than one owner of a handle" (length owners <= 1)

testHandleQuery :: Opt.Opts -> Brig -> Http ()
testHandleQuery opts brig = do
  uid <- userId <$> randomUser brig
  hdl <- randomHandle
  -- Query for the handle availability (must be free)
  Bilge.head (brig . paths ["handles", toByteString' hdl] . zUser uid)
    !!! const 404 === statusCode
  -- Set handle
  let update = RequestBodyLBS . encode $ HandleUpdate hdl
  put (brig . path "/self/handle" . contentJson . zUser uid . zConn "c" . body update)
    !!! const 200 === statusCode
  -- Query the updated profile
  get (brig . path "/self" . zUser uid) !!! do
    const 200 === statusCode
    const (Just (fromJust $ parseHandle hdl)) === (userHandle <=< responseJsonMaybe)
  -- Query for the handle availability (must be taken)
  Bilge.head (brig . paths ["handles", toByteString' hdl] . zUser uid)
    !!! const 200 === statusCode
  -- Query user profiles by handles
  get (apiVersion "v1" . brig . path "/users" . queryItem "handles" (toByteString' hdl) . zUser uid) !!! do
    const 200 === statusCode
    const (Just (fromJust $ parseHandle hdl)) === (profileHandle <=< listToMaybe <=< responseJsonMaybe)
  -- Bulk availability check
  hdl2 <- randomHandle
  hdl3 <- randomHandle
  checkHandles brig uid [hdl, hdl2, "InVa£iD", hdl3] 1 !!! do
    const 200 === statusCode
    const (Just [hdl2]) === responseJsonMaybe
  checkHandles brig uid [hdl2, hdl, hdl3] 3 !!! do
    const 200 === statusCode
    const (Just [hdl2, hdl3]) === responseJsonMaybe

  -- Let's check for availability outside the team when an option is given
  (_, user3, _) <- createPopulatedBindingTeamWithNamesAndHandles brig 0
  (_, user4, _) <- createPopulatedBindingTeamWithNamesAndHandles brig 0

  -- Usually, you can search outside your team
  assertCanFind brig user3 user4
  -- Usually, you can search outside your team but not if this config option is set
  let newOpts = opts & ((Opt.settingsLens . Opt.searchSameTeamOnlyLens) ?~ True)
  withSettingsOverrides newOpts $
    assertCannotFind brig user3 user4

testHandleQuerySearchVisibilityStandard :: Opt.Opts -> Brig -> Http ()
testHandleQuerySearchVisibilityStandard _opts brig = do
  (_, owner1, [member1]) <- createPopulatedBindingTeamWithNamesAndHandles brig 1
  (_, owner2, [member2]) <- createPopulatedBindingTeamWithNamesAndHandles brig 1
  extern <- randomUserWithHandle brig
  -- Assert that everyone can find each other:
  --   in the same or different team, by handle - direction does not matter
  assertCanFind brig owner1 owner2
  assertCanFind brig owner1 member1
  assertCanFind brig owner1 member2
  assertCanFind brig owner1 extern
  assertCanFind brig owner2 owner1
  assertCanFind brig member1 owner1
  assertCanFind brig member2 owner1
  assertCanFind brig extern owner1

testHandleQuerySearchVisibilityNoNameOutsideTeam :: Opt.Opts -> Brig -> Galley -> Http ()
testHandleQuerySearchVisibilityNoNameOutsideTeam _opts brig galley = do
  (tid1, owner1, [member1]) <- createPopulatedBindingTeamWithNamesAndHandles brig 1
  (_, owner2, [member2]) <- createPopulatedBindingTeamWithNamesAndHandles brig 1
  extern <- randomUserWithHandle brig
  setTeamTeamSearchVisibilityAvailable galley tid1 FeatureStatusEnabled
  setTeamSearchVisibility galley tid1 SearchVisibilityNoNameOutsideTeam
  -- this is the same as in 'testHandleQuerySearchVisibilityStandard' above, because we search
  -- for handles, not names.
  assertCanFind brig owner1 owner2
  assertCanFind brig owner1 member1
  assertCanFind brig owner1 member2
  assertCanFind brig owner1 extern
  assertCanFind brig owner2 owner1
  assertCanFind brig member1 owner1
  assertCanFind brig member2 owner1
  assertCanFind brig extern owner1

testGetUserByUnqualifiedHandle :: Brig -> Http ()
testGetUserByUnqualifiedHandle brig = do
  user <- randomUser brig
  handle <- randomHandle
  _ <- putHandle brig (userId user) handle
  requestingUser <- randomId
  get
    ( apiVersion "v1"
        . brig
        . paths ["users", "handles", toByteString' handle]
        . zUser requestingUser
    )
    !!! do
      const 200 === statusCode
      const (Right (UserHandleInfo (userQualifiedId user))) === responseJsonEither

testGetUserByUnqualifiedHandleFailure :: Brig -> Http ()
testGetUserByUnqualifiedHandleFailure brig = do
  handle <- randomHandle
  requestingUser <- randomId
  get
    ( apiVersion "v1"
        . brig
        . paths ["users", "handles", toByteString' handle]
        . zUser requestingUser
    )
    !!! do
      const 404 === statusCode
      const (Just "not-found") === fmap Error.label . responseJsonMaybe

testGetUserByQualifiedHandle :: Brig -> Http ()
testGetUserByQualifiedHandle brig = do
  user <- randomUser brig
  handle <- randomHandle
  let domain = qDomain (userQualifiedId user)
  _ <- putHandle brig (userId user) handle
  unconnectedUser <- randomUser brig
  profileForUnconnectedUser <-
    responseJsonError
      =<< get
        ( apiVersion "v1"
            . brig
            . paths ["users", "by-handle", toByteString' domain, toByteString' handle]
            . zUser (userId unconnectedUser)
            . expect2xx
        )
  liftIO $
    assertEqual
      "Id should match"
      (userQualifiedId user)
      (profileQualifiedId profileForUnconnectedUser)

  -- N.B. Internally this endpoint uses same implementation as getting a user
  -- profile by id. So, it is not necessary to test rest of the cases.
  liftIO $
    assertEqual
      "Email shouldn't be shown to unconnected user"
      Nothing
      (profileEmail profileForUnconnectedUser)

testGetUserByQualifiedHandleFailure :: Brig -> Http ()
testGetUserByQualifiedHandleFailure brig = do
  handle <- randomHandle
  qself <- userQualifiedId <$> randomUser brig
  get
    ( apiVersion "v1"
        . brig
        . paths
          [ "users",
            "by-handle",
            toByteString' (qDomain qself),
            toByteString' handle
          ]
        . zUser (qUnqualified qself)
    )
    !!! do
      const 404 === statusCode
      const (Just "not-found") === fmap Error.label . responseJsonMaybe

testGetUserByQualifiedHandleNoFederation :: Opt.Opts -> Brig -> Http ()
testGetUserByQualifiedHandleNoFederation opt brig = do
  let newOpts = opt {Opt.federatorInternal = Nothing}
  someUser <- randomUser brig
  withSettingsOverrides newOpts $
    get
      ( apiVersion "v1"
          . brig
          . paths ["users", "by-handle", "non-existant.example.com", "oh-a-handle"]
          . zUser (userId someUser)
      )
      !!! do
        const 400 === statusCode
        const "Bad Request" === statusMessage
        const (Right "federation-not-enabled") === fmap Wai.label . responseJsonEither

assertCanFind :: (MonadCatch m, MonadIO m, MonadHttp m, HasCallStack) => Brig -> User -> User -> m ()
assertCanFind brig from target = do
  liftIO $ assertBool "assertCanFind: Target must have a handle set" (isJust $ userHandle target)
  let targetHandle = fromMaybe (error "Impossible") (userHandle target)
  get (apiVersion "v1" . brig . path "/users" . queryItem "handles" (toByteString' targetHandle) . zUser (userId from)) !!! do
    const 200 === statusCode
    const (userHandle target) === (responseJsonMaybe >=> listToMaybe >=> profileHandle)

  get (apiVersion "v1" . brig . paths ["users", "handles", toByteString' targetHandle] . zUser (userId from)) !!! do
    const 200 === statusCode
    const (Just (UserHandleInfo $ userQualifiedId target)) === responseJsonMaybe

assertCannotFind :: (MonadCatch m, MonadIO m, MonadHttp m, HasCallStack) => Brig -> User -> User -> m ()
assertCannotFind brig from target = do
  liftIO $ assertBool "assertCannotFind: Target must have a handle set" (isJust $ userHandle target)
  let targetHandle = fromMaybe (error "Impossible") (userHandle target)
  get (apiVersion "v1" . brig . path "/users" . queryItem "handles" (toByteString' targetHandle) . zUser (userId from)) !!! do
    const 404 === statusCode
  get (apiVersion "v1" . brig . paths ["users", "handles", toByteString' targetHandle] . zUser (userId from)) !!! do
    const 404 === statusCode
