{-# LANGUAGE StrictData #-}
{-# LANGUAGE TemplateHaskell #-}

-- 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 Wire.UserSubsystem
  ( module Wire.UserSubsystem,
    module Data.HavePendingInvitations,
    GetBy (..),
  )
where

import Control.Lens ((^.))
import Data.Default
import Data.Domain
import Data.Handle (Handle)
import Data.HavePendingInvitations
import Data.Id
import Data.Misc
import Data.Qualified
import Data.Range
import Imports
import Polysemy
import Polysemy.Error
import Polysemy.Input
import Polysemy.TinyLog (TinyLog)
import SAML2.WebSSO qualified as SAML
import Text.Email.Parser
import Wire.API.EnterpriseLogin
import Wire.API.Federation.Error
import Wire.API.MLS.CipherSuite (CipherSuiteTag)
import Wire.API.Routes.Internal.Brig (GetBy (..), getByNoFilters)
import Wire.API.Routes.Internal.Galley.TeamFeatureNoConfigMulti (TeamStatus)
import Wire.API.Team.Export (TeamExportUser)
import Wire.API.Team.Feature
import Wire.API.Team.Member (IsPerm (..), TeamMember)
import Wire.API.User
import Wire.API.User.Activation
import Wire.API.User.Client (Client)
import Wire.API.User.IdentityProvider hiding (domain, team)
import Wire.API.User.Search
import Wire.ActivationCodeStore
import Wire.Arbitrary
import Wire.BlockListStore
import Wire.BlockListStore qualified as BlockListStore
import Wire.DomainRegistrationStore (DomainRegistrationStore)
import Wire.DomainRegistrationStore qualified as DomainRegistrationStore
import Wire.EmailSubsystem
import Wire.InvitationStore
import Wire.SparAPIAccess (SparAPIAccess, getIdentityProviders)
import Wire.StoredUser qualified as SU
import Wire.TeamSubsystem
import Wire.UserKeyStore
import Wire.UserSearch.Types
import Wire.UserStore
import Wire.UserStore qualified as UserStore
import Wire.UserSubsystem.Error
import Wire.UserSubsystem.UserSubsystemConfig

-- | Who is performing this update operation / who is allowed to?  (Single source of truth:
-- users managed by SCIM can't be updated by clients and vice versa.)
data UpdateOriginType
  = -- | Call originates from the SCIM api in spar.
    UpdateOriginScim
  | -- | Call originates from wire client (mobile, web, or team-management).
    UpdateOriginWireClient
  deriving (Show, Eq, Ord, Generic)
  deriving (Arbitrary) via GenericUniform UpdateOriginType

-- | Simple updates (as opposed to, eg., handle, where we need to manage locks).
--
-- This is isomorphic to 'StoredUserUpdate', but we keep the two types separate because they
-- belong to different abstraction levels (UserSubsystem vs. UserStore), and they may
-- change independently in the future ('UserStoreUpdate' may grow more fields for other
-- operations).
data UserProfileUpdate = MkUserProfileUpdate
  { name :: Maybe Name,
    textStatus :: Maybe TextStatus,
    pict :: Maybe Pict, -- DEPRECATED
    assets :: Maybe [Asset],
    accentId :: Maybe ColourId,
    locale :: Maybe Locale,
    supportedProtocols :: Maybe (Set BaseProtocolTag)
  }
  deriving stock (Eq, Ord, Show, Generic)
  deriving (Arbitrary) via GenericUniform UserProfileUpdate

instance Default UserProfileUpdate where
  def =
    MkUserProfileUpdate
      { name = Nothing,
        textStatus = Nothing,
        pict = Nothing, -- DEPRECATED
        assets = Nothing,
        accentId = Nothing,
        locale = Nothing,
        supportedProtocols = Nothing
      }

-- | Outcome of email change invariant checks.
data ChangeEmailResult
  = -- | The request was successful, user needs to verify the new email address
    ChangeEmailNeedsActivation !(User, Activation, EmailAddress)
  | -- | The user asked to change the email address to the one already owned
    ChangeEmailIdempotent
  deriving (Show)

data UserSubsystem m a where
  -- | First arg is for authorization only.
  GetUserProfiles :: Local UserId -> [Qualified UserId] -> UserSubsystem m [UserProfile]
  -- | These give us partial success and hide concurrency in the interpreter.
  -- (Nit-pick: a better return type for this might be `([Qualified ([UserId],
  -- FederationError)], [UserProfile])`, and then we'd probably need a function of type
  -- `([Qualified ([UserId], FederationError)], [UserProfile]) -> ([(Qualified UserId,
  -- FederationError)], [UserProfile])` to maintain API compatibility.)
  GetUserProfilesWithErrors :: Local UserId -> [Qualified UserId] -> UserSubsystem m ([(Qualified UserId, FederationError)], [UserProfile])
  -- | Sometimes we don't have any identity of a requesting user, and local profiles are public.
  GetLocalUserProfiles :: Local [UserId] -> UserSubsystem m [UserProfile]
  -- | Get profiles for all app users in a team, touching only the apps table (efficient).
  GetLocalAppProfiles :: Local UserId -> TeamId -> UserSubsystem m [UserProfile]
  -- | Get the union of all user accounts matching the `GetBy` argument *and* having a non-empty UserIdentity.
  GetAccountsBy :: Local GetBy -> UserSubsystem m [User]
  -- | Get user accounts matching the `[EmailAddress]` argument (accounts with missing
  -- identity and accounts with status /= active included).
  GetAccountsByEmailNoFilter :: Local [EmailAddress] -> UserSubsystem m [User]
  -- | Get `SelfProfile` (it contains things not present in `UserProfile`).
  GetSelfProfile :: Local UserId -> UserSubsystem m (Maybe SelfProfile)
  -- | Simple updates (as opposed to, eg., handle, where we need to manage locks).  Empty fields are ignored (not deleted).
  UpdateUserProfile :: Local UserId -> Maybe ConnId -> UpdateOriginType -> UserProfileUpdate -> UserSubsystem m ()
  -- | Parse and lookup a handle.
  CheckHandle :: Text {- use Handle here? -} -> UserSubsystem m CheckHandleResp
  -- | Check a number of 'Handle's for availability and returns at most 'Word' amount of them
  CheckHandles :: [Handle] -> Word -> UserSubsystem m [Handle]
  -- | Parse and update a handle. Parsing may fail so this is effectful.
  UpdateHandle :: Local UserId -> Maybe ConnId -> UpdateOriginType -> Text {- use Handle here? -} -> UserSubsystem m ()
  -- | Return the user's locale (or the default locale if the users exists and has none).
  LookupLocaleWithDefault :: Local UserId -> UserSubsystem m (Maybe Locale)
  -- | Throw error if registered domain forbids user account creation under this email
  -- address.  (This may become internal to the interpreter once migration to wire-subsystems
  -- has progressed enough.)
  GuardRegisterActivateUserEmailDomain :: EmailAddress -> UserSubsystem m ()
  GuardUpgradePersonalUserToTeamEmailDomain :: EmailAddress -> UserSubsystem m ()
  -- | Check if an email is blocked.
  IsBlocked :: EmailAddress -> UserSubsystem m Bool
  -- | Remove an email from the block list.
  BlockListDelete :: EmailAddress -> UserSubsystem m ()
  -- | Add an email to the block list.
  BlockListInsert :: EmailAddress -> UserSubsystem m ()
  UpdateTeamSearchVisibilityInbound :: TeamStatus SearchVisibilityInboundConfig -> UserSubsystem m ()
  SearchUsers ::
    Local UserId ->
    Text ->
    Maybe Domain ->
    Maybe (Range 1 500 Int32) ->
    Maybe [UserTypeFilter] ->
    UserSubsystem m (SearchResult Contact)
  IsUsersContactable :: Map UserId (Set BaseProtocolTag, Set Client) -> Bool -> Set CipherSuiteTag -> UserSubsystem m (Map UserId Bool)
  BrowseTeam ::
    UserId ->
    BrowseTeamFilters ->
    Maybe (Range 1 500 Int) ->
    Maybe PagingState ->
    UserSubsystem m (SearchResult TeamContact)
  -- | (...  or does `AcceptTeamInvitation` belong into `TeamInvitationSubsystems`?)
  AcceptTeamInvitation :: Local UserId -> PlainTextPassword6 -> InvitationCode -> UserSubsystem m ()
  -- | The following "internal" functions exists to support migration in this susbystem, after the
  -- migration this would just be an internal detail of the subsystem
  InternalUpdateSearchIndex :: UserId -> UserSubsystem m ()
  InternalFindTeamInvitation :: Maybe EmailKey -> InvitationCode -> UserSubsystem m StoredInvitation
  GetUserExportData :: UserId -> UserSubsystem m (Maybe TeamExportUser)
  RemoveEmailEither :: Local UserId -> UserSubsystem m (Either UserSubsystemError ())
  GetUserTeam :: UserId -> UserSubsystem m (Maybe TeamId)
  CheckUserIsAdmin :: UserId -> UserSubsystem m TeamId
  SetUserSearchable :: Local UserId -> UserId -> SetSearchable -> UserSubsystem m ()

-- | the return type of 'CheckHandle'
data CheckHandleResp
  = CheckHandleFound
  | CheckHandleNotFound
  deriving stock (Eq, Ord, Show)

makeSem ''UserSubsystem

getUserProfile ::
  (Member UserSubsystem r) =>
  Local UserId ->
  Qualified UserId ->
  Sem r (Maybe UserProfile)
getUserProfile luid targetUser =
  listToMaybe <$> getUserProfiles luid [targetUser]

getLocalUserProfile ::
  (Member UserSubsystem r) =>
  Local UserId -> Sem r (Maybe UserProfile)
getLocalUserProfile targetUser =
  listToMaybe <$> getLocalUserProfiles ((: []) <$> targetUser)

getLocalAccountBy ::
  (Member UserSubsystem r) =>
  HavePendingInvitations ->
  Local UserId ->
  Sem r (Maybe User)
getLocalAccountBy includePendingInvitations uid =
  listToMaybe
    <$> getAccountsBy
      ( qualifyAs uid $
          def
            { getByUserId = [tUnqualified uid],
              includePendingInvitations
            }
      )

-- | Get user account by local user id (accounts with missing identity and accounts with
-- status /= active included).
getAccountNoFilter :: (Member UserSubsystem r) => Local UserId -> Sem r (Maybe User)
getAccountNoFilter uid =
  listToMaybe
    <$> getAccountsBy
      (qualifyAs uid $ getByNoFilters {getByUserId = [tUnqualified uid]})

getUserEmail :: (Member UserSubsystem r) => Local UserId -> Sem r (Maybe EmailAddress)
getUserEmail lusr =
  (>>= userEmail) <$> getLocalAccountBy WithPendingInvitations lusr

getLocalUserAccountByUserKey :: (Member UserSubsystem r) => Local EmailKey -> Sem r (Maybe User)
getLocalUserAccountByUserKey q@(tUnqualified -> ek) =
  listToMaybe <$> getAccountsByEmailNoFilter (qualifyAs q [emailKeyOrig ek])

-- | Call 'createEmailChangeToken' and process result: if email changes to
-- itself, succeed, if not, send validation email.
requestEmailChange ::
  forall r.
  ( Member BlockListStore r,
    Member UserKeyStore r,
    Member EmailSubsystem r,
    Member UserSubsystem r,
    Member UserStore r,
    Member (Error UserSubsystemError) r,
    Member ActivationCodeStore r,
    Member (Input UserSubsystemConfig) r,
    Member TinyLog r,
    Member DomainRegistrationStore r,
    Member SparAPIAccess r
  ) =>
  Local UserId ->
  EmailAddress ->
  UpdateOriginType ->
  Sem r ChangeEmailResponse
requestEmailChange lusr email allowScim = do
  let u = tUnqualified lusr
  team <- (>>= (.teamId)) <$> UserStore.getUser u
  guardRegisteredEmailDomain team
  guardBlockedDomainEmail
  createEmailChangeToken lusr email allowScim >>= \case
    ChangeEmailIdempotent ->
      pure ChangeEmailResponseIdempotent
    ChangeEmailNeedsActivation (usr, adata, en) -> do
      sendOutEmail usr adata en
      updateEmailUnvalidated u email
      internalUpdateSearchIndex u
      pure ChangeEmailResponseNeedsActivation
  where
    throwGuardFailed ::
      (Member (Error UserSubsystemError) r') =>
      GuardFailure ->
      Sem r' a
    throwGuardFailed = throw . UserSubsystemGuardFailed

    guardRegisteredEmailDomain ::
      Maybe TeamId ->
      Sem r ()
    guardRegisteredEmailDomain mTeam = do
      mReg <-
        emailDomain email
          -- The error is impossible as long as we use the same parser for both `EmailAddress` and
          -- `Domain`.
          & either (throwGuardFailed . InvalidDomain) DomainRegistrationStore.lookup
      for_ mReg $ \reg -> do
        case (reg.domainRedirect, reg.teamInvite) of
          (NoRegistration, _) -> throwGuardFailed DomRedirSetToNoRegistration
          (Backend {}, _) -> throwGuardFailed DomRedirSetToBackend
          (SSO idpId, _) -> do
            case mTeam of
              Nothing -> throwGuardFailed DomRedirSetToSSO
              Just tid -> do
                identityProviders <- getIdentityProviders tid
                unless (idpId `elem` ((^. SAML.idpId) <$> identityProviders.providers)) $
                  throwGuardFailed DomRedirSetToSSO
          (_, NotAllowed) -> throwGuardFailed TeamInviteSetToNotAllowed
          (_, Team tid) | mTeam /= Just tid -> throwGuardFailed TeamInviteRestrictedToOtherTeam
          _ -> pure ()
    sendOutEmail usr adata en = do
      (maybe sendActivationMail (const sendEmailAddressUpdateMail) usr.userIdentity)
        en
        (userDisplayName usr)
        (activationKey adata)
        (activationCode adata)
        (Just (userLocale usr))

    guardBlockedDomainEmail ::
      ( Member (Input UserSubsystemConfig) r',
        Member (Error UserSubsystemError) r'
      ) =>
      Sem r' ()
    guardBlockedDomainEmail = do
      eDomain <-
        either (throwGuardFailed . InvalidDomain) pure $
          emailDomain email
      blocked <- blockedDomains <$> input
      when (eDomain `elem` blocked) $
        throw UserSubsystemBlockedDomain

-- | Prepare changing the email (checking a number of invariants).
createEmailChangeToken ::
  ( Member BlockListStore r,
    Member UserKeyStore r,
    Member (Error UserSubsystemError) r,
    Member UserSubsystem r,
    Member ActivationCodeStore r,
    Member (Input UserSubsystemConfig) r
  ) =>
  Local UserId ->
  EmailAddress ->
  UpdateOriginType ->
  Sem r ChangeEmailResult
createEmailChangeToken lusr email updateOrigin = do
  let ek = mkEmailKey email
      u = tUnqualified lusr
  blocklisted <- BlockListStore.exists ek
  when blocklisted $ throw UserSubsystemChangeBlocklistedEmail
  available <- keyAvailable ek (Just u)
  unless available $ throw UserSubsystemEmailExists
  usr <-
    getLocalAccountBy WithPendingInvitations lusr
      >>= note UserSubsystemProfileNotFound
  case emailIdentity =<< userIdentity usr of
    -- The user already has an email address and the new one is exactly the same
    Just current | current == email -> pure ChangeEmailIdempotent
    _ -> do
      -- if the user is managed by SCIM, the email change must be initiated by SCIM
      -- they are not allowed to change their email address themselves in that case
      unless (userManagedBy usr /= ManagedByScim || updateOrigin == UpdateOriginScim) $
        throw UserSubsystemEmailManagedByScim
      actTimeout <- inputs (.activationCodeTimeout)
      act <- newActivationCode ek actTimeout (Just u)
      pure $ ChangeEmailNeedsActivation (usr, act, email)

------------------------------------------
-- FUTUREWORK: Pending functions for a team subsystem
------------------------------------------

ensurePermissions ::
  ( IsPerm TeamMember perm,
    Member (Error UserSubsystemError) r,
    Member TeamSubsystem r
  ) =>
  UserId ->
  TeamId ->
  [perm] ->
  Sem r ()
ensurePermissions u t perms = do
  m <- internalGetTeamMember u t
  unless (check m) $
    throw UserSubsystemInsufficientPermissions
  where
    check :: Maybe TeamMember -> Bool
    check (Just m) = all (hasPermission m) perms
    check Nothing = False
