{-# OPTIONS_GHC -Wno-ambiguous-fields #-}

-- 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 Test.User where

import API.Brig
import API.BrigInternal as I
import API.Common
import API.GalleyInternal
import qualified API.Spar as Spar
import Control.Monad.Codensity
import Control.Monad.Reader
import qualified Data.Aeson as Aeson
import qualified Data.UUID as UUID
import qualified Data.UUID.V4 as UUID
import SetupHelpers
import Testlib.Prelude
import Testlib.ResourcePool
import Testlib.VersionedFed

testSupportedProtocols :: (HasCallStack) => OneOf Domain (FedDomain 1) -> App ()
testSupportedProtocols bobDomain = do
  alice <- randomUser OwnDomain def
  alice %. "supported_protocols" `shouldMatchSet` ["proteus"]

  bob <- randomUser bobDomain def

  do
    -- bob sees default supported protocols for alice
    u <- getUser bob alice >>= getJSON 200
    u %. "supported_protocols" `shouldMatch` ["proteus"]

    p <- getUserSupportedProtocols bob alice >>= getJSON 200
    p `shouldMatch` ["proteus"]

  -- alice updates her supported protocols
  bindResponse (putUserSupportedProtocols alice ["proteus", "mls"]) $ \resp ->
    resp.status `shouldMatchInt` 200

  do
    -- bob sees the updated list
    u <- getUser bob alice >>= getJSON 200
    u %. "supported_protocols" `shouldMatchSet` ["proteus", "mls"]

    p <- getUserSupportedProtocols bob alice >>= getJSON 200
    p `shouldMatch` ["proteus", "mls"]

  -- invalid protocol name in update
  bindResponse (putUserSupportedProtocols alice ["proteus", "mls", "mixed"]) $ \resp -> do
    resp.status `shouldMatchInt` 400
    resp.json %. "label" `shouldMatch` "bad-request"

testCreateUserSupportedProtocols :: (HasCallStack) => App ()
testCreateUserSupportedProtocols = do
  alice <- randomUser OwnDomain def {supportedProtocols = Just ["proteus", "mls"]}
  bindResponse (getUserSupportedProtocols alice alice) $ \resp -> do
    resp.status `shouldMatchInt` 200
    resp.json `shouldMatchSet` ["proteus", "mls"]

  bindResponse (createUser OwnDomain def {supportedProtocols = Just ["proteus", "mixed"]}) $ \resp -> do
    resp.status `shouldMatchInt` 400
    resp.json %. "label" `shouldMatch` "bad-request"

testRemoveMlsSupportShouldFail :: (HasCallStack) => App ()
testRemoveMlsSupportShouldFail = do
  alice <- randomUser OwnDomain def {supportedProtocols = Just ["proteus", "mls"]}
  bindResponse (getUserSupportedProtocols alice alice) $ \resp -> do
    resp.status `shouldMatchInt` 200
    resp.json `shouldMatchSet` ["proteus", "mls"]

  putUserSupportedProtocols alice ["proteus"] `bindResponse` \resp -> do
    resp.status `shouldMatchInt` 409
    resp.json %. "label" `shouldMatch` "mls-protocol-error"

  bindResponse (getUserSupportedProtocols alice alice) $ \resp -> do
    resp.status `shouldMatchInt` 200
    resp.json `shouldMatchSet` ["proteus", "mls"]

-- | For now this only tests attempts to update /self/handle in E2EId-enabled teams.  More
-- tests can be found under `/services/brig/test/integration` (and should be moved here).
testUpdateHandle :: (HasCallStack) => App ()
testUpdateHandle = do
  -- create team with one member, without scim, but with `mlsE2EId` enabled.
  (owner, team, [mem1]) <- createTeam OwnDomain 2
  mem1id <- asString $ mem1 %. "id"

  let featureName = "mlsE2EId"
  bindResponse (getTeamFeature owner team featureName) $ \resp -> do
    resp.status `shouldMatchInt` 200
    resp.json %. "status" `shouldMatch` "disabled"
  assertSuccess =<< setTeamFeatureStatus owner team featureName "enabled"
  bindResponse (getTeamFeature owner team featureName) $ \resp -> do
    resp.status `shouldMatchInt` 200
    resp.json %. "status" `shouldMatch` "enabled"

  -- all as expected here.  (see the second time we check this at the end of the test for an
  -- explanation why we care.)
  bindResponse (getSelf mem1) $ \resp -> do
    resp.status `shouldMatchInt` 200
    resp.json %. "managed_by" `shouldMatch` "wire"
  bindResponse (getUsersId owner [mem1id]) $ \resp -> do
    resp.status `shouldMatchInt` 200
    mb <- (assertOne =<< asList resp.json) %. "managed_by"
    mb `shouldMatch` "wire"

  -- mem1 attempts to update handle for the first time => success
  --
  -- this is desired, because without SCIM users need to pick their own handles initially.
  -- moreover it is fine, because if `handle == NULL`, no mls E2Eid client certs can be
  -- created.
  handle <- UUID.toString <$> liftIO UUID.nextRandom
  bindResponse (putHandle mem1 handle) $ \resp -> do
    resp.status `shouldMatchInt` 200
  bindResponse (putHandle mem1 handle) $ \resp -> do
    -- idempotency
    resp.status `shouldMatchInt` 200

  -- mem1 attempts to update handle again => failure
  handle2 <- UUID.toString <$> liftIO UUID.nextRandom
  bindResponse (putHandle mem1 handle2) $ \resp -> do
    resp.status `shouldMatchInt` 403
    resp.json %. "label" `shouldMatch` "managed-by-scim"

  -- now self thinks it is managed by "scim", so clients can block change attempts to handle,
  -- display name without adding E2EId-specific logic.  this is just a hack, though: `GET
  -- /self` is the only place where this is happening, other end-points still report the truth
  -- that is still stored correctly in the DB.
  --
  -- details: https://wearezeta.atlassian.net/browse/WPB-6189.
  -- FUTUREWORK: figure out a better way for clients to detect E2EId (V6?)
  bindResponse (getSelf mem1) $ \resp -> do
    resp.status `shouldMatchInt` 200
    resp.json %. "managed_by" `shouldMatch` "scim"
  bindResponse (getUsersId owner [mem1id]) $ \resp -> do
    resp.status `shouldMatchInt` 200
    mb <- (assertOne =<< asList resp.json) %. "managed_by"
    mb `shouldMatch` "wire"
  bindResponse (Spar.getScimTokens owner) $ \resp -> do
    resp.status `shouldMatchInt` 200
    resp.json %. "tokens" `shouldMatch` ([] @String)

-- | For now this only tests attempts to update one's own display name, email address, or
-- language in E2EId-enabled teams (ie., everything except handle).  More tests can be found
-- under `/services/brig/test/integration` (and should be moved here).
testUpdateSelf :: (HasCallStack) => Tagged "mode" TestUpdateSelfMode -> App ()
testUpdateSelf (MkTagged mode) = do
  -- create team with one member, without scim, but with `mlsE2EId` enabled.
  (owner, team, [mem1]) <- createTeam OwnDomain 2

  let featureName = "mlsE2EId"
  bindResponse (getTeamFeature owner team featureName) $ \resp -> do
    resp.status `shouldMatchInt` 200
    resp.json %. "status" `shouldMatch` "disabled"
  assertSuccess =<< setTeamFeatureStatus owner team featureName "enabled"
  bindResponse (getTeamFeature owner team featureName) $ \resp -> do
    resp.status `shouldMatchInt` 200
    resp.json %. "status" `shouldMatch` "enabled"

  case mode of
    TestUpdateDisplayName -> do
      -- blocked unconditionally
      someDisplayName <- UUID.toString <$> liftIO UUID.nextRandom
      before <- getSelf mem1
      bindResponse (putSelf mem1 def {name = Just someDisplayName}) $ \resp -> do
        resp.status `shouldMatchInt` 403
        resp.json %. "label" `shouldMatch` "managed-by-scim"
      after <- getSelf mem1
      void $ (before.json %. "name") `shouldMatch` (after.json %. "name")
    TestUpdateEmailAddress -> do
      -- allowed unconditionally *for owner* (this is a bit off-topic: team members can't
      -- change their email addresses themselves under any conditions)
      newEmail <- (<> "@example.com") . UUID.toString <$> liftIO UUID.nextRandom
      bindResponse (putUserEmail owner owner newEmail) $ \resp -> do
        resp.status `shouldMatchInt` 200
      getSelf owner `bindResponse` \resp -> do
        resp.status `shouldMatchInt` 200
        resp.json %. "email_unvalidated" `shouldMatch` newEmail
    TestUpdateLocale -> do
      -- scim maps "User.preferredLanguage" to brig's locale field.  allowed unconditionally.
      -- we try two languages to make sure it doesn't work because it's already the active
      -- locale.
      forM_ ["en-GB", "hi", "de-DE", "de", "he"] $ \newLocale -> do
        bindResponse (putSelfLocale mem1 newLocale) $ \resp -> do
          resp.status `shouldMatchInt` 200
        getSelf mem1 `bindResponse` \resp -> do
          resp.status `shouldMatchInt` 200
          resp.json %. "locale" `shouldMatch` newLocale

data TestUpdateSelfMode
  = TestUpdateDisplayName
  | TestUpdateEmailAddress
  | TestUpdateLocale
  deriving (Eq, Show, Generic)

testActivateAccountWithPhoneV5 :: (HasCallStack) => App ()
testActivateAccountWithPhoneV5 = do
  let dom = OwnDomain
  let phone = "+4912345678"
  let reqBody = Aeson.object ["phone" .= phone]
  activateUserV5 dom reqBody `bindResponse` \resp -> do
    resp.status `shouldMatchInt` 400
    resp.json %. "label" `shouldMatch` "bad-request"

testMigratingPasswordHashingAlgorithm :: (HasCallStack) => App ()
testMigratingPasswordHashingAlgorithm = do
  let argon2idOpts =
        object
          [ "algorithm" .= "argon2id",
            "iterations" .= (1 :: Int),
            "memory" .= (128 :: Int),
            "parallelism" .= (1 :: Int)
          ]
      cfgArgon2id =
        def
          { brigCfg =
              setField "settings.setPasswordHashingOptions" argon2idOpts
                >=> removeField "optSettings.setSuspendInactiveUsers",
            galleyCfg = setField "settings.passwordHashingOptions" argon2idOpts
          }
      cfgScrypt =
        def
          { brigCfg =
              setField "settings.setPasswordHashingOptions.algorithm" "scrypt"
                >=> removeField "optSettings.setSuspendInactiveUsers",
            galleyCfg = setField "settings.passwordHashingOptions.algorithm" "scrypt"
          }
  resourcePool <- asks (.resourcePool)
  runCodensity (acquireResources 1 resourcePool) $ \[testBackend] -> do
    let domain = testBackend.berDomain
    email1 <- randomEmail
    password1 <- randomString 20

    email2 <- randomEmail
    password2 <- randomString 20

    runCodensity (startDynamicBackend testBackend cfgScrypt) $ \_ -> do
      void $ randomUser domain (def {email = Just email1, password = Just password1})
      login domain email1 password1 >>= assertSuccess

    runCodensity (startDynamicBackend testBackend cfgArgon2id) $ \_ -> do
      login domain email1 password1 >>= assertSuccess

      -- Create second user to ensure that we're testing migrating back. This is
      -- not really needed because the login above rehashes the password, but it
      -- makes the test clearer.
      void $ randomUser domain (def {email = Just email2, password = Just password2})
      login domain email2 password2 >>= assertSuccess

    -- Check that both users can still login with Scrypt in case the operator
    -- wants to rollback the config.
    runCodensity (startDynamicBackend testBackend cfgScrypt) $ \_ -> do
      login domain email1 password1 >>= assertSuccess
      login domain email2 password2 >>= assertSuccess

testUpdateEmailForEmailDomainForAnotherBackend :: (HasCallStack) => App ()
testUpdateEmailForEmailDomainForAnotherBackend = forM_ [ExplicitVersion 8, Versioned] \version -> do
  emailDomain <- randomDomain
  user <- randomUser OwnDomain def
  email <- user %. "email" & asString
  (cookie, token) <- bindResponse (login user email defPassword) $ \resp -> do
    resp.status `shouldMatchInt` 200
    token <- resp.json %. "access_token" & asString
    let cookie = fromJust $ getCookie "zuid" resp
    pure ("zuid=" <> cookie, token)

  I.domainRegistrationPreAuthorize OwnDomain emailDomain >>= assertStatus 204
  setup <- setupOwnershipTokenForBackend OwnDomain emailDomain
  updateDomainRedirect
    OwnDomain
    version
    emailDomain
    (Just setup.ownershipToken)
    (mkDomainRedirectBackend version "https://example.com" "https://webapp.example.com")
    >>= assertStatus 200

  let newEmail = "galadriel@" <> emailDomain
  updateEmail user newEmail cookie token `bindResponse` \resp -> do
    resp.status `shouldMatchInt` 403
    resp.json %. "label" `shouldMatch` "condition-failed"

  bindResponse (getActivationCode user newEmail) $ \resp -> do
    resp.status `shouldMatchInt` 404
    resp.json %. "label" `shouldMatch` "not-found"

  bindResponse (getSelf user) $ \resp -> do
    resp.json %. "email" `shouldMatch` email

testActivateEmailForEmailDomainForAnotherBackend :: (HasCallStack) => App ()
testActivateEmailForEmailDomainForAnotherBackend = do
  tid <- randomId
  sso <- randomId
  object
    [ "domain_redirect" .= "backend",
      "backend"
        .= object
          [ "config_url" .= "https://example.com",
            "webapp_url" .= "https://webapp.example.com"
          ],
      "team_invite"
        .= "not-allowed"
    ]
    & testActivateEmailShouldBeAllowed False
  object
    [ "domain_redirect" .= "none",
      "team_invite" .= "allowed"
    ]
    & testActivateEmailShouldBeAllowed True
  object
    [ "domain_redirect" .= "no-registration",
      "team_invite" .= "team",
      "team" .= tid
    ]
    & testActivateEmailShouldBeAllowed False
  object
    [ "domain_redirect" .= "no-registration",
      "team_invite" .= "not-allowed"
    ]
    & testActivateEmailShouldBeAllowed False
  object
    [ "domain_redirect" .= "sso",
      "sso_code" .= sso,
      "team_invite" .= "not-allowed"
    ]
    & testActivateEmailShouldBeAllowed False
  object
    [ "domain_redirect" .= "sso",
      "sso_code" .= sso,
      "team_invite" .= "team",
      "team" .= tid
    ]
    & testActivateEmailShouldBeAllowed False
  where
    testActivateEmailShouldBeAllowed :: (HasCallStack) => Bool -> Value -> App ()
    testActivateEmailShouldBeAllowed activateAllowed update = do
      emailDomain <- randomDomain
      user <- randomUser OwnDomain def
      email <- user %. "email" & asString
      (cookie, token) <- bindResponse (login user email defPassword) $ \resp -> do
        resp.status `shouldMatchInt` 200
        token <- resp.json %. "access_token" & asString
        let cookie = fromJust $ getCookie "zuid" resp
        pure ("zuid=" <> cookie, token)

      let newEmail = "galadriel@" <> emailDomain
      updateEmail user newEmail cookie token >>= assertSuccess

      (key, code) <- bindResponse (getActivationCode user newEmail) $ \resp -> do
        resp.status `shouldMatchInt` 200
        (,)
          <$> (resp.json %. "key" & asString)
          <*> (resp.json %. "code" & asString)

      I.updateDomainRegistration OwnDomain emailDomain update >>= assertSuccess

      if activateAllowed
        then do
          API.Brig.activate user key code >>= assertSuccess
          getSelf user `bindResponse` \resp -> do
            resp.json %. "email" `shouldMatch` newEmail
        else do
          API.Brig.activate user key code `bindResponse` \resp -> do
            resp.status `shouldMatchInt` 403
            resp.json %. "label" `shouldMatch` "condition-failed"

          getSelf user `bindResponse` \resp -> do
            resp.json %. "email" `shouldMatch` email

testPasswordChange :: (HasCallStack) => App ()
testPasswordChange =
  withModifiedBackend
    def
      { brigCfg =
          -- Disable password hashing rate limiting, so we can create enable services quickly
          setField @_ @Int "optSettings.setPasswordHashingRateLimit.userLimit.inverseRate" 0
      }
    $ \domain -> do
      user <- randomUser domain def
      email <- asString $ user %. "email"
      newPassword <- randomString 20

      putPassword user defPassword defPassword `bindResponse` \resp -> do
        resp.status `shouldMatchInt` 409
        resp.json %. "label" `shouldMatch` "password-must-differ"

      putPassword user defPassword newPassword >>= assertSuccess

      login domain email defPassword `bindResponse` \resp -> do
        resp.status `shouldMatchInt` 403
        resp.json %. "label" `shouldMatch` "invalid-credentials"
      login domain email newPassword >>= assertSuccess

testEphemeralUserCreation :: (HasCallStack) => TaggedBool "ephemeral-user-creation-enabled" -> App ()
testEphemeralUserCreation (TaggedBool enabled) = do
  withModifiedBackend
    def
      { brigCfg = setField "optSettings.setEphemeralUserCreationEnabled" enabled
      }
    $ \domain -> do
      registerEphemeralUser domain `bindResponse` \resp -> do
        if enabled
          then do
            resp.status `shouldMatchInt` 201
          else do
            resp.status `shouldMatchInt` 403
            resp.json %. "label" `shouldMatch` "ephemeral-user-creation-disabled"

        registerUserWithEmail domain >>= assertSuccess
  where
    registerEphemeralUser domain = addUser domain def
    registerUserWithEmail domain = addUser domain def {email = Just ("user@" <> domain)}

testSuspendNonExistingUser :: (HasCallStack) => App ()
testSuspendNonExistingUser = do
  existingUser <- randomUser OwnDomain def
  uid <- randomId
  dom <- asString OwnDomain
  let quid = object ["domain" .= dom, "id" .= uid]
  I.setAccountStatus quid "suspended" >>= assertStatus 404
  getUser existingUser quid >>= assertStatus 404
