{-# LANGUAGE RecordWildCards #-}
{-# 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 Wire.UserSubsystem.Interpreter
  ( runUserSubsystem,
    UserSubsystemConfig (..),
  )
where

import Cassandra.Util (Writetime (Writetime))
import Control.Error.Util (hush)
import Control.Lens (view, (^.))
import Control.Monad.Extra (partitionM)
import Control.Monad.Trans.Maybe
import Data.CaseInsensitive qualified as CI
import Data.Domain
import Data.Handle (Handle)
import Data.Handle qualified as Handle
import Data.Id
import Data.Json.Util
import Data.LegalHold
import Data.List.Extra (nubOrd)
import Data.Map.Strict qualified as Map
import Data.Misc (HttpsUrl, PlainTextPassword6, mkHttpsUrl)
import Data.Qualified
import Data.Range
import Data.Set qualified as Set
import Data.Time.Clock
import Database.Bloodhound qualified as ES
import Imports
import Polysemy
import Polysemy.Error
import Polysemy.Input
import Polysemy.TinyLog (TinyLog)
import Polysemy.TinyLog qualified as Log
import SAML2.WebSSO qualified as SAML
import Servant.Client.Core
import System.Logger.Message qualified as Log
import Wire.API.EnterpriseLogin
import Wire.API.Federation.API
import Wire.API.Federation.API.Brig qualified as FedBrig
import Wire.API.Federation.Error
import Wire.API.MLS.CipherSuite (CipherSuiteTag, csSignatureScheme)
import Wire.API.Routes.FederationDomainConfig
import Wire.API.Routes.Internal.Galley.TeamFeatureNoConfigMulti (TeamStatus (..))
import Wire.API.Team.Export
import Wire.API.Team.Feature
import Wire.API.Team.Member
import Wire.API.Team.Member.Info (TeamMemberInfo (..), TeamMemberInfoList (members))
import Wire.API.Team.Permission qualified as Permission
import Wire.API.Team.Role (Role, defaultRole, permissionsToRole)
import Wire.API.Team.SearchVisibility
import Wire.API.Team.Size
import Wire.API.User as User
import Wire.API.User.Client qualified as UserClient
import Wire.API.User.RichInfo
import Wire.API.User.Search
import Wire.API.UserEvent
import Wire.AppStore (AppStore)
import Wire.AppStore qualified as AppStore
import Wire.AppSubsystem
import Wire.AppSubsystem.Interpreter
import Wire.AuthenticationSubsystem
import Wire.BlockListStore as BlockList
import Wire.ClientStore (ClientStore)
import Wire.ClientStore qualified as ClientStore
import Wire.ClientSubsystem (ClientSubsystem)
import Wire.ClientSubsystem qualified as ClientSubsystem
import Wire.DeleteQueue
import Wire.DomainRegistrationStore qualified as DRS
import Wire.Events
import Wire.FederationAPIAccess
import Wire.FederationConfigStore
import Wire.GalleyAPIAccess
import Wire.GalleyAPIAccess qualified as GalleyAPIAccess
import Wire.IndexedUserStore (IndexedUserStore)
import Wire.IndexedUserStore qualified as IndexedUserStore
import Wire.IndexedUserStore.Bulk.ElasticSearch (teamSearchVisibilityInbound)
import Wire.InvitationStore
import Wire.MlsKeyPackageSubsystem (MlsKeyPackageSubsystem)
import Wire.MlsKeyPackageSubsystem qualified as Mls
import Wire.Sem.Concurrency
import Wire.Sem.Metrics
import Wire.Sem.Metrics qualified as Metrics
import Wire.Sem.Now (Now)
import Wire.Sem.Now qualified as Now
import Wire.StoredUser
import Wire.TeamSubsystem
import Wire.UserGroupStore (UserGroupStore, getUserGroupIdsForUsers)
import Wire.UserKeyStore
import Wire.UserSearch.Metrics
import Wire.UserSearch.Types
import Wire.UserStore as UserStore
import Wire.UserStore.IndexUser
import Wire.UserSubsystem as UserSubsystem
import Wire.UserSubsystem.Error
import Wire.UserSubsystem.HandleBlacklist
import Wire.UserSubsystem.UserSubsystemConfig
import Witherable (wither)

runUserSubsystem ::
  ( Member AppStore r,
    Member UserStore r,
    Member ClientStore r,
    Member MlsKeyPackageSubsystem r,
    Member UserKeyStore r,
    Member GalleyAPIAccess r,
    Member BlockListStore r,
    Member DRS.DomainRegistrationStore r,
    Member (Concurrency 'Unsafe) r,
    Member (Error FederationError) r,
    Member (Error UserSubsystemError) r,
    Member (FederationAPIAccess fedM) r,
    Member DeleteQueue r,
    Member Events r,
    Member Now r,
    RunClient (fedM 'Brig),
    FederationMonad fedM,
    Typeable fedM,
    Member IndexedUserStore r,
    Member FederationConfigStore r,
    Member Metrics r,
    Member InvitationStore r,
    Member TinyLog r,
    Member (Input UserSubsystemConfig) r,
    Member TeamSubsystem r,
    Member UserGroupStore r,
    Member (Input (Local any)) r
  ) =>
  InterpreterFor AuthenticationSubsystem (AppSubsystem ': ClientSubsystem ': r) ->
  InterpreterFor AppSubsystem (ClientSubsystem ': r) ->
  InterpreterFor ClientSubsystem r ->
  Sem (UserSubsystem ': r) a ->
  Sem r a
runUserSubsystem authInterpreter appInterpreter clientInterpreter =
  interpret $
    clientInterpreter . appInterpreter . authInterpreter . \case
      GetUserProfiles self others ->
        getUserProfilesImpl self others
      GetLocalUserProfiles others ->
        getLocalUserProfilesImpl others
      GetLocalAppProfiles self ltid ->
        getLocalAppProfilesImpl self ltid
      GetAccountsBy getBy ->
        getAccountsByImpl getBy
      GetAccountsByEmailNoFilter emails ->
        getAccountsByEmailNoFilterImpl emails
      GetSelfProfile self ->
        getSelfProfileImpl self
      GetUserProfilesWithErrors self others ->
        getUserProfilesWithErrorsImpl self others
      UpdateUserProfile self mconn mb update ->
        updateUserProfileImpl self mconn mb update
      CheckHandle uhandle ->
        checkHandleImpl uhandle
      CheckHandles hdls cnt ->
        checkHandlesImpl hdls cnt
      UpdateHandle uid mconn mb uhandle ->
        updateHandleImpl uid mconn mb uhandle
      LookupLocaleWithDefault luid ->
        lookupLocaleOrDefaultImpl luid
      GuardRegisterActivateUserEmailDomain email ->
        guardRegisterActivateUserEmailDomainImpl email
      GuardUpgradePersonalUserToTeamEmailDomain email ->
        guardUpgradePersonalUserToTeamEmailDomainImpl email
      IsBlocked email ->
        isBlockedImpl email
      BlockListDelete email ->
        blockListDeleteImpl email
      BlockListInsert email ->
        blockListInsertImpl email
      UpdateTeamSearchVisibilityInbound status ->
        updateTeamSearchVisibilityInboundImpl status
      SearchUsers luid query mDomain mMaxResults mTypes ->
        searchUsersImpl luid query mDomain mMaxResults mTypes
      IsUsersContactable users mlsAvailable allowedCipherSuites ->
        isUsersContactableImpl users mlsAvailable allowedCipherSuites
      BrowseTeam uid browseTeamFilters mMaxResults mPagingState ->
        browseTeamImpl uid browseTeamFilters mMaxResults mPagingState
      InternalUpdateSearchIndex uid ->
        syncUserIndex uid
      AcceptTeamInvitation luid pwd code ->
        acceptTeamInvitationImpl luid pwd code
      InternalFindTeamInvitation mEmailKey code ->
        internalFindTeamInvitationImpl mEmailKey code
      GetUserExportData uid -> getUserExportDataImpl uid
      RemoveEmailEither luid -> removeEmailEitherImpl luid
      UserSubsystem.GetUserTeam uid -> getUserTeamImpl uid
      CheckUserIsAdmin uid -> checkUserIsAdminImpl uid
      UserSubsystem.SetUserSearchable luid uid searchability -> setUserSearchableImpl luid uid searchability

isUsersContactableImpl ::
  forall r.
  (Member ClientStore r, Member MlsKeyPackageSubsystem r) =>
  Map UserId (Set BaseProtocolTag, Set UserClient.Client) ->
  Bool ->
  Set CipherSuiteTag ->
  Sem r (Map UserId Bool)
isUsersContactableImpl users mlsAvailable allowedCipherSuites = do
  let prekeyRequests =
        [ (uid, client.clientId)
        | (uid, (protocols, clients)) <- Map.toList users,
          Set.member BaseProtocolProteusTag protocols,
          client <- Set.toList clients
        ]
      mlsRequests =
        [ (uid, client.clientId, ciphersuite)
        | mlsAvailable,
          (uid, (protocols, clients)) <- Map.toList users,
          Set.member BaseProtocolMLSTag protocols,
          client <- Set.toList clients,
          ciphersuite <- Set.toList allowedCipherSuites,
          Map.member
            (csSignatureScheme ciphersuite)
            client.clientMLSPublicKeys
        ]
  prekeyPresence <- ClientStore.lookupPrekeyPresenceBulk prekeyRequests
  mlsPresence <- Mls.hasMlsKeyPackagesBulk mlsRequests
  pure $ Map.mapWithKey (isContactable prekeyPresence mlsPresence) users
  where
    isContactable prekeyPresence mlsPresence uid (protocols, clients) =
      let proteusReady =
            Set.member BaseProtocolProteusTag protocols
              && any (\client -> Set.member (uid, client.clientId) prekeyPresence) clients
          mlsReady =
            mlsAvailable
              && Set.member BaseProtocolMLSTag protocols
              && any
                ( \client ->
                    any
                      ( \ciphersuite ->
                          Map.member (csSignatureScheme ciphersuite) client.clientMLSPublicKeys
                            && Set.member (uid, client.clientId, ciphersuite) mlsPresence
                      )
                      allowedCipherSuites
                )
                clients
       in proteusReady || mlsReady

scimExtId :: StoredUser -> Maybe Text
scimExtId su = do
  m <- su.managedBy
  i <- su.identity
  sso <- ssoIdentity i
  scimExternalId m sso

userToIdPIssuer :: StoredUser -> Maybe HttpsUrl
userToIdPIssuer su = case su.identity >>= ssoIdentity of
  Just (UserSSOId (SAML.UserRef issuer _)) ->
    either (const Nothing) Just . mkHttpsUrl $ issuer ^. SAML.fromIssuer
  Just _ -> Nothing
  Nothing -> Nothing

samlNamedId :: StoredUser -> Maybe Text
samlNamedId su =
  su.identity >>= ssoIdentity >>= \case
    (UserSSOId (SAML.UserRef _idp nameId)) -> Just . CI.original . SAML.unsafeShowNameID $ nameId
    (UserScimExternalId _) -> Nothing

internalFindTeamInvitationImpl ::
  ( Member InvitationStore r,
    Member (Error UserSubsystemError) r,
    Member (Input UserSubsystemConfig) r,
    Member (GalleyAPIAccess) r,
    Member IndexedUserStore r,
    Member TinyLog r,
    Member DRS.DomainRegistrationStore r
  ) =>
  Maybe EmailKey ->
  InvitationCode ->
  Sem r StoredInvitation
internalFindTeamInvitationImpl Nothing _ = throw UserSubsystemMissingIdentity
internalFindTeamInvitationImpl (Just e) c =
  lookupInvitationByCode c >>= \case
    Just inv -> do
      if e == mkEmailKey (inv.email)
        then ensureMemberCanJoin inv.teamId $> inv
        else throw UserSubsystemInvalidInvitationCode
    Nothing -> throw UserSubsystemInvalidInvitationCode
  where
    ensureMemberCanJoin tid = do
      let throwGuardFailed = throw . UserSubsystemGuardFailed
      mDomreg <-
        emailDomain e.emailKeyOrig
          -- The error is impossible as long as we use the same parser for both `EmailAddress` and
          -- `Domain`.
          & either (throwGuardFailed . InvalidDomain) DRS.lookup
      for_ mDomreg $ \domreg -> case domreg.teamInvite of
        Allowed -> pure ()
        Team allowedTeam | allowedTeam == tid -> pure ()
        Team _ -> throwGuardFailed TeamInviteRestrictedToOtherTeam
        NotAllowed -> throwGuardFailed TeamInviteSetToNotAllowed

      maxSize <- maxTeamSize <$> input
      teamSize <- teamSizeTotal <$> IndexedUserStore.getTeamSize tid
      when (teamSize >= fromIntegral maxSize) $
        throw UserSubsystemTooManyTeamMembers
      -- FUTUREWORK: The above can easily be done/tested in the intra call.
      --             Remove after the next release.
      mAddUserError <- checkUserCanJoinTeam tid
      maybe (pure ()) (throw . UserSubsystemUserNotAllowedToJoinTeam) mAddUserError

guardRegisterActivateUserEmailDomainImpl ::
  forall r.
  ( Member DRS.DomainRegistrationStore r,
    Member (Error UserSubsystemError) r,
    Member TinyLog r
  ) =>
  EmailAddress ->
  Sem r ()
guardRegisterActivateUserEmailDomainImpl email = do
  let throwGuardFailed = throw . UserSubsystemGuardFailed
  mReg <-
    emailDomain email
      -- The error is impossible as long as we use the same parser for both `EmailAddress` and
      -- `Domain`.
      & either (throwGuardFailed . InvalidDomain) DRS.lookup
  for_ mReg $ \reg -> do
    case reg.domainRedirect of
      None -> pure ()
      Locked -> pure ()
      SSO _ -> throwGuardFailed DomRedirSetToSSO
      Backend _ _ -> throwGuardFailed DomRedirSetToBackend
      NoRegistration -> throwGuardFailed DomRedirSetToNoRegistration
      PreAuthorized -> pure ()

guardUpgradePersonalUserToTeamEmailDomainImpl ::
  forall r.
  ( Member DRS.DomainRegistrationStore r,
    Member (Error UserSubsystemError) r,
    Member TinyLog r
  ) =>
  EmailAddress ->
  Sem r ()
guardUpgradePersonalUserToTeamEmailDomainImpl email = do
  let throwGuardFailed = throw . UserSubsystemGuardFailed
  mReg <-
    emailDomain email
      -- The error is impossible as long as we use the same parser for both `EmailAddress` and
      -- `Domain`.
      & either (throwGuardFailed . InvalidDomain) DRS.lookup
  for_ mReg $ \reg -> do
    case (reg.domainRedirect, reg.teamInvite) of
      (NoRegistration, _) -> throwGuardFailed DomRedirSetToNoRegistration
      (Backend {}, _) -> throwGuardFailed DomRedirSetToBackend
      (SSO {}, _) -> throwGuardFailed DomRedirSetToSSO
      (_, NotAllowed) -> throwGuardFailed TeamInviteSetToNotAllowed
      (_, Team _) -> throwGuardFailed TeamInviteRestrictedToOtherTeam
      _ -> pure ()

isBlockedImpl :: (Member BlockListStore r) => EmailAddress -> Sem r Bool
isBlockedImpl = BlockList.exists . mkEmailKey

blockListDeleteImpl :: (Member BlockListStore r) => EmailAddress -> Sem r ()
blockListDeleteImpl = BlockList.delete . mkEmailKey

blockListInsertImpl :: (Member BlockListStore r) => EmailAddress -> Sem r ()
blockListInsertImpl = BlockList.insert . mkEmailKey

lookupLocaleOrDefaultImpl :: (Member UserStore r, Member (Input UserSubsystemConfig) r) => Local UserId -> Sem r (Maybe Locale)
lookupLocaleOrDefaultImpl luid = do
  mLangCountry <- UserStore.lookupLocale (tUnqualified luid)
  defLocale <- inputs (.defaultLocale)
  pure (toLocale defLocale <$> mLangCountry)

-- | Obtain user profiles for a list of users as they can be seen by
-- a given user 'self'. If 'self' is an unknown 'UserId', return '[]'.
getUserProfilesImpl ::
  ( Member (Input UserSubsystemConfig) r,
    Member UserStore r,
    Member (Concurrency 'Unsafe) r, -- FUTUREWORK: subsystems should implement concurrency inside interpreters, not depend on this dangerous effect.
    Member (Error FederationError) r,
    Member (FederationAPIAccess fedM) r,
    Member DeleteQueue r,
    Member Now r,
    Member (Input (Local any)) r,
    RunClient (fedM 'Brig),
    FederationMonad fedM,
    Typeable fedM,
    Member AppSubsystem r,
    Member TeamSubsystem r
  ) =>
  -- | User 'self' on whose behalf the profiles are requested.
  Local UserId ->
  -- | The users ('others') for which to obtain the profiles.
  [Qualified UserId] ->
  Sem r [UserProfile]
getUserProfilesImpl self others =
  concat
    <$> unsafePooledMapConcurrentlyN
      8
      (getUserProfilesFromDomain self)
      (bucketQualified others)

getLocalUserProfilesImpl ::
  forall r any.
  ( Member UserStore r,
    Member (Input UserSubsystemConfig) r,
    Member DeleteQueue r,
    Member Now r,
    Member (Concurrency Unsafe) r,
    Member (Input (Local any)) r,
    Member TeamSubsystem r,
    Member AppSubsystem r
  ) =>
  Local [UserId] ->
  Sem r [UserProfile]
getLocalUserProfilesImpl = getUserProfilesLocalPart Nothing

getLocalAppProfilesImpl ::
  forall r any.
  ( Member AppStore r,
    Member UserStore r,
    Member (Input UserSubsystemConfig) r,
    Member DeleteQueue r,
    Member (Error UserSubsystemError) r,
    Member Now r,
    Member (Concurrency Unsafe) r,
    Member (Input (Local any)) r,
    Member AppSubsystem r,
    Member TeamSubsystem r
  ) =>
  Local UserId ->
  TeamId ->
  Sem r [UserProfile]
getLocalAppProfilesImpl self tid = do
  UserStore.getUserTeam (tUnqualified self) >>= \requestingUserTeam ->
    unless (requestingUserTeam == Just tid) $
      throw UserSubsystemProfileNotFound

  let ltid = qualifyAs self tid
  apps <- AppStore.getApps tid
  profiles <- getUserProfilesLocalPart Nothing (ltid $> map (.id) apps)
  let appsMap :: Map UserId AppStore.StoredApp
      appsMap = Map.fromList ((\app -> (app.id, app)) <$> apps)

      injectPreloadedApp :: UserProfile -> UserProfile
      injectPreloadedApp profile =
        let key = qUnqualified profile.profileQualifiedId
         in case Map.lookup key appsMap of
              Just app -> profile {profileApp = Just (storedAppToAppInfo app)}
              Nothing -> profile

  pure (injectPreloadedApp <$> profiles)

getUserProfilesFromDomain ::
  ( Member (Error FederationError) r,
    Member (Input UserSubsystemConfig) r,
    Member (FederationAPIAccess fedM) r,
    Member DeleteQueue r,
    Member Now r,
    Member UserStore r,
    RunClient (fedM 'Brig),
    FederationMonad fedM,
    Typeable fedM,
    Member (Input (Local any)) r,
    Member (Concurrency Unsafe) r,
    Member TeamSubsystem r,
    Member AppSubsystem r
  ) =>
  Local UserId ->
  Qualified [UserId] ->
  Sem r [UserProfile]
getUserProfilesFromDomain self uids = do
  foldQualified
    self
    (getUserProfilesLocalPart (Just self))
    getUserProfilesRemotePart
    uids

getUserProfilesRemotePart ::
  ( Member (FederationAPIAccess fedM) r,
    Member (Error FederationError) r,
    RunClient (fedM 'Brig),
    FederationMonad fedM,
    Typeable fedM
  ) =>
  Remote [UserId] ->
  Sem r [UserProfile]
getUserProfilesRemotePart ruids = do
  runFederated ruids $ fedClient @'Brig @"get-users-by-ids" (tUnqualified ruids)

getUserProfilesLocalPart ::
  forall r any.
  ( Member UserStore r,
    Member (Input UserSubsystemConfig) r,
    Member DeleteQueue r,
    Member Now r,
    Member (Concurrency Unsafe) r,
    Member (Input (Local any)) r,
    Member AppSubsystem r,
    Member TeamSubsystem r
  ) =>
  Maybe (Local UserId) ->
  Local [UserId] ->
  Sem r [UserProfile]
getUserProfilesLocalPart requestingUser luids = do
  emailVisibilityConfig <- inputs emailVisibilityConfig
  requestingUserInfo <- join <$> traverse getRequestingUserInfo requestingUser
  let canSeeEmails = maybe False (isAdminOrOwner . view (newTeamMember . nPermissions) . snd) requestingUserInfo
      emailVisibilityConfigWithViewer = case emailVisibilityConfig of
        EmailVisibleToSelf | canSeeEmails -> EmailVisibleIfOnSameTeam requestingUserInfo
        EmailVisibleToSelf -> EmailVisibleToSelf
        EmailVisibleIfOnTeam -> EmailVisibleIfOnTeam
        EmailVisibleIfOnSameTeam () -> EmailVisibleIfOnSameTeam requestingUserInfo
  injectAppsIntoUserProfiles . catMaybes
    -- FUTUREWORK: (in the interpreters where it makes sense) pull paginated lists from the DB,
    -- not just single rows.
    =<< unsafePooledForConcurrentlyN 8 (sequence luids) (getLocalUserProfileInternal emailVisibilityConfigWithViewer)
  where
    getRequestingUserInfo :: Local UserId -> Sem r (Maybe (TeamId, TeamMember))
    getRequestingUserInfo self = do
      -- FUTUREWORK: it is an internal error for the two lookups (for 'User' and 'TeamMember')
      -- to return 'Nothing'.  we could throw errors here if that happens, rather than just
      -- returning an empty profile list from 'lookupProfiles'.
      mUser <- getUser $ tUnqualified self
      let mUserNotPending = do
            user <- mUser
            guard $ not (hasPendingInvitation user)
            pure user
      case mUserNotPending >>= (.teamId) of
        Nothing -> pure Nothing
        Just tid -> (tid,) <$$> internalGetTeamMember (tUnqualified self) tid

getLocalUserProfileInternal ::
  forall r.
  ( Member UserStore r,
    Member DeleteQueue r,
    Member Now r,
    Member (Input UserSubsystemConfig) r,
    Member TeamSubsystem r
  ) =>
  EmailVisibilityConfigWithViewer ->
  Local UserId ->
  Sem r (Maybe UserProfile)
getLocalUserProfileInternal emailVisibilityConfigWithViewer luid = do
  let domain = tDomain luid
  locale <- inputs Wire.UserSubsystem.UserSubsystemConfig.defaultLocale
  runMaybeT $ do
    storedUser <- MaybeT $ getUser (tUnqualified luid)
    guard $ not (hasPendingInvitation storedUser)
    lhs :: UserLegalHoldStatus <- do
      teamMember <- lift $ join <$> (internalGetTeamMember storedUser.id `mapM` storedUser.teamId)
      pure $ maybe defUserLegalHoldStatus (view legalHoldStatus) teamMember
    let user = mkUserFromStored domain locale storedUser
        usrProfile = mkUserProfile emailVisibilityConfigWithViewer user Nothing lhs
    lift $ deleteLocalIfExpired user
    pure $ usrProfile

getSelfProfileImpl ::
  ( Member (Input UserSubsystemConfig) r,
    Member UserStore r,
    Member GalleyAPIAccess r
  ) =>
  Local UserId ->
  Sem r (Maybe SelfProfile)
getSelfProfileImpl self = do
  defLocale <- inputs Wire.UserSubsystem.UserSubsystemConfig.defaultLocale
  mStoredUser <- getUser (tUnqualified self)
  mHackedUser <- traverse hackForBlockingHandleChangeForE2EIdTeams mStoredUser
  let mUser = mkUserFromStored (tDomain self) defLocale <$> mHackedUser
  pure (SelfProfile <$> mUser)
  where
    -- \| This is a hack!
    --
    -- Background:
    -- - https://wearezeta.atlassian.net/browse/WPB-6189.
    -- - comments in `testUpdateHandle` in `/integration`.
    --
    -- FUTUREWORK: figure out a better way for clients to detect E2EId (V6?)
    hackForBlockingHandleChangeForE2EIdTeams :: (Member GalleyAPIAccess r) => StoredUser -> Sem r StoredUser
    hackForBlockingHandleChangeForE2EIdTeams user = do
      e2eid <- hasE2EId user
      pure $
        if e2eid && isJust user.handle
          then user {managedBy = Just ManagedByScim}
          else user

-- | ephemeral users past their expiry date are queued for deletion
deleteLocalIfExpired :: forall r. (Member DeleteQueue r, Member Now r) => User -> Sem r ()
deleteLocalIfExpired user =
  case user.userExpire of
    Nothing -> pure ()
    Just (fromUTCTimeMillis -> e) -> do
      t <- Now.get
      when (diffUTCTime e t < 0) $
        enqueueUserDeletion (qUnqualified user.userQualifiedId)

getUserProfilesWithErrorsImpl ::
  forall r fedM any.
  ( Member UserStore r,
    Member (Concurrency 'Unsafe) r, -- FUTUREWORK: subsystems should implement concurrency inside interpreters, not depend on this dangerous effect.
    Member (Input UserSubsystemConfig) r,
    Member (FederationAPIAccess fedM) r,
    Member DeleteQueue r,
    Member Now r,
    RunClient (fedM 'Brig),
    FederationMonad fedM,
    Typeable fedM,
    Member TeamSubsystem r,
    Member (Input (Local any)) r,
    Member AppSubsystem r
  ) =>
  Local UserId ->
  [Qualified UserId] ->
  Sem r ([(Qualified UserId, FederationError)], [UserProfile])
getUserProfilesWithErrorsImpl self others = do
  (errs, profs_) <- aggregate ([], []) <$> unsafePooledMapConcurrentlyN 8 go (bucketQualified others)
  (errs,) <$> injectAppsIntoUserProfiles profs_
  where
    go :: Qualified [UserId] -> Sem r (Either (FederationError, Qualified [UserId]) [UserProfile])
    go bucket = runError (getUserProfilesFromDomain self bucket) <&> mapLeft (,bucket)
    -- this function will partition the Eithers into a list of pairs such that
    -- - the left side will contain a list of users with a federation error 'Left's
    -- - the right side will contain a list of user profiles obtained from the 'Right's
    -- - the left side will have to transform a pair of error and user ids into a list
    --   of users ids paired with errors; this is done by just pairing all of them with
    --   the same error
    aggregate ::
      ( inp ~ [Either (FederationError, Qualified [UserId]) [UserProfile]],
        outp ~ ([(Qualified UserId, FederationError)], [UserProfile])
      ) =>
      (outp -> inp -> outp)
    aggregate acc [] = acc
    aggregate (accL, accR) (Right prof : buckets) = aggregate (accL, prof <> accR) buckets
    aggregate (accL, accR) (Left e : buckets) = aggregate (renderBucketError e <> accL, accR) buckets

    renderBucketError :: (FederationError, Qualified [UserId]) -> [(Qualified UserId, FederationError)]
    renderBucketError (e, qlist) = (,e) . (flip Qualified (qDomain qlist)) <$> qUnqualified qlist

-- | Consult `AppSubsystem` to get `AppInfo`s info for `UserProfile`'s
-- `app` attribute.
--
-- NOTE ON PERFORMANCE: this function calls `getApp` once per user
-- profile.  we could call `getApps` once instead, build a map from
-- that, and look up `AppInfo` for all profiles in memory.  There is a
-- trade-off between memory usage and database IO, and we should
-- measure this before we make a change.
injectAppsIntoUserProfiles ::
  (Member AppSubsystem r, Member (Input (Local x0)) r) =>
  [UserProfile] -> Sem r [UserProfile]
injectAppsIntoUserProfiles = mapM \uprof -> do
  mbluid :: Maybe (Local UserId) <- do
    localDom <- input
    pure $ foldQualified localDom Just (const Nothing) uprof.profileQualifiedId

  mbApp :: Maybe AppInfo <- case (uprof.profileDeleted, uprof.profileType, mbluid, uprof.profileTeam) of
    (False, UserTypeApp, Just luid, Just tid) -> Just <$> getApp luid tid (tUnqualified luid)
    _ -> pure Nothing

  pure (uprof {profileApp = mbApp})

-- | Some fields cannot be overwritten by clients for scim-managed users; some others if e2eid
-- is used.  If a client attempts to overwrite any of these, throw `UserSubsystem*ManagedByScim`.
guardLockedFields ::
  ( Member (Error UserSubsystemError) r,
    Member GalleyAPIAccess r
  ) =>
  StoredUser ->
  UpdateOriginType ->
  UserProfileUpdate ->
  Sem r ()
guardLockedFields user updateOrigin (MkUserProfileUpdate {..}) = do
  let idempName = isNothing name || name == Just user.name
      idempLocale = isNothing locale || locale == user.locale
      scimConflict = updateOrigin == UpdateOriginWireClient && user.managedBy == Just ManagedByScim
      updateByScim = updateOrigin == UpdateOriginScim && user.managedBy == Just ManagedByScim
  e2eid <- hasE2EId user
  when ((scimConflict || (e2eid && not updateByScim)) && not idempName) do
    throw UserSubsystemDisplayNameManagedByScim
  when (scimConflict {- e2eid does not matter, it's not part of the e2eid cert! -} && not idempLocale) do
    throw UserSubsystemLocaleManagedByScim

guardLockedHandleField ::
  ( Member GalleyAPIAccess r,
    Member (Error UserSubsystemError) r
  ) =>
  StoredUser ->
  UpdateOriginType ->
  Handle ->
  Sem r ()
guardLockedHandleField user updateOrigin handle = do
  let idemp = Just handle == user.handle
      scimConflict = updateOrigin == UpdateOriginWireClient && user.managedBy == Just ManagedByScim
      updateByScim = updateOrigin == UpdateOriginScim && user.managedBy == Just ManagedByScim
      hasHandle = isJust user.handle
  e2eid <- hasE2EId user
  when ((scimConflict || (e2eid && hasHandle && not updateByScim)) && not idemp) do
    throw UserSubsystemHandleManagedByScim

updateUserProfileImpl ::
  ( Member UserStore r,
    Member (Error UserSubsystemError) r,
    Member Events r,
    Member GalleyAPIAccess r,
    Member IndexedUserStore r,
    Member Metrics r
  ) =>
  Local UserId ->
  Maybe ConnId ->
  UpdateOriginType ->
  UserProfileUpdate ->
  Sem r ()
updateUserProfileImpl (tUnqualified -> uid) mconn updateOrigin update = do
  user <- getUser uid >>= note UserSubsystemProfileNotFound
  guardMlsSupport user
  guardLockedFields user updateOrigin update
  mapError (\StoredUserUpdateHandleExists -> UserSubsystemHandleExists) $
    updateUser uid (storedUserUpdate update)
  let interestingToUpdateIndex = isJust update.name || isJust update.accentId
  when interestingToUpdateIndex $ syncUserIndex uid
  generateUserEvent uid mconn (mkProfileUpdateEvent uid update)
  where
    guardMlsSupport user = for_ update.supportedProtocols $ \protocols -> do
      let currentProtocols = fromMaybe mempty user.supportedProtocols
      let diff = currentProtocols `Set.difference` protocols
      when (BaseProtocolMLSTag `Set.member` diff) $
        throw UserSubsystemMlsRemovalNotAllowed

storedUserUpdate :: UserProfileUpdate -> StoredUserUpdate
storedUserUpdate update =
  MkStoredUserUpdate
    { name = update.name,
      textStatus = update.textStatus,
      pict = update.pict,
      assets = update.assets,
      accentId = update.accentId,
      locale = update.locale,
      supportedProtocols = update.supportedProtocols
    }

mkProfileUpdateEvent :: UserId -> UserProfileUpdate -> UserEvent
mkProfileUpdateEvent uid update =
  UserUpdated $
    (emptyUserUpdatedData uid)
      { eupName = update.name,
        eupTextStatus = update.textStatus,
        eupPict = update.pict,
        eupAccentId = update.accentId,
        eupAssets = update.assets,
        eupLocale = update.locale,
        eupSupportedProtocols = update.supportedProtocols
      }

mkProfileUpdateHandleEvent :: UserId -> Handle -> UserEvent
mkProfileUpdateHandleEvent uid handle =
  UserUpdated $ (emptyUserUpdatedData uid) {eupHandle = Just handle}

--------------------------------------------------------------------------------
-- Update Handle

updateHandleImpl ::
  ( Member (Error UserSubsystemError) r,
    Member GalleyAPIAccess r,
    Member Events r,
    Member UserStore r,
    Member IndexedUserStore r,
    Member Metrics r
  ) =>
  Local UserId ->
  Maybe ConnId ->
  UpdateOriginType ->
  Text ->
  Sem r ()
updateHandleImpl (tUnqualified -> uid) mconn updateOrigin uhandle = do
  newHandle :: Handle <- note UserSubsystemInvalidHandle $ Handle.parseHandle uhandle
  when (isBlacklistedHandle newHandle) $
    throw UserSubsystemInvalidHandle
  user <- getUser uid >>= note UserSubsystemNoIdentity
  guardLockedHandleField user updateOrigin newHandle
  when (isNothing user.identity) $
    throw UserSubsystemNoIdentity
  mapError (\StoredUserUpdateHandleExists -> UserSubsystemHandleExists) $
    UserStore.updateUserHandle uid (MkStoredUserHandleUpdate user.handle newHandle)
  syncUserIndex uid
  generateUserEvent uid mconn (mkProfileUpdateHandleEvent uid newHandle)

checkHandleImpl :: (Member (Error UserSubsystemError) r, Member UserStore r) => Text -> Sem r CheckHandleResp
checkHandleImpl uhandle = do
  xhandle :: Handle <- Handle.parseHandle uhandle & maybe (throw UserSubsystemInvalidHandle) pure
  when (isBlacklistedHandle xhandle) $
    throw UserSubsystemInvalidHandle
  owner <- lookupHandle xhandle
  if isJust owner
    then -- Handle is taken (=> getHandleInfo will return 200)
      pure CheckHandleFound
    else -- Handle is free and can be taken
      pure CheckHandleNotFound

hasE2EId :: (Member GalleyAPIAccess r) => StoredUser -> Sem r Bool
hasE2EId user =
  -- FUTUREWORK(mangoiv): we should use a function 'getSingleFeatureForUser'
  (.status) . npProject @MlsE2EIdConfig
    <$> getAllTeamFeaturesForUser (Just user.id) <&> \case
      FeatureStatusEnabled -> True
      FeatureStatusDisabled -> False

--------------------------------------------------------------------------------
-- Check Handles

-- | checks for handles @check@ to be available and returns
--   at maximum @num@ of them
checkHandlesImpl :: (Member UserStore r) => [Handle] -> Word -> Sem r [Handle]
checkHandlesImpl check num = reverse <$> collectFree [] check num
  where
    collectFree free _ 0 = pure free
    collectFree free [] _ = pure free
    collectFree free (h : hs) n =
      if isBlacklistedHandle h
        then collectFree free hs n
        else do
          owner <- glimpseHandle h
          case owner of
            Nothing -> collectFree (h : free) hs (n - 1)
            Just _ -> collectFree free hs n

-------------------------------------------------------------------------------
-- Search

syncUserIndex ::
  forall r.
  ( Member UserStore r,
    Member GalleyAPIAccess r,
    Member IndexedUserStore r,
    Member Metrics r
  ) =>
  UserId ->
  Sem r ()
syncUserIndex uid =
  getIndexUser uid
    >>= maybe deleteFromIndex upsert
  where
    deleteFromIndex :: Sem r ()
    deleteFromIndex = do
      Metrics.incCounter indexDeleteCounter
      IndexedUserStore.upsert (userIdToDocId uid) (emptyUserDoc uid) ES.NoVersionControl

    upsert :: IndexUser -> Sem r ()
    upsert indexUser = do
      vis <-
        maybe
          (pure defaultSearchVisibilityInbound)
          teamSearchVisibilityInbound
          indexUser.teamId
      tm <- maybe (pure Nothing) selectTeamMember indexUser.teamId
      let mRole = tm >>= mkRoleWithWriteTime
          userDoc = indexUserToDoc vis (value <$> mRole) indexUser
          version = ES.ExternalGT . ES.ExternalDocVersion . docVersion $ indexUserToVersion mRole indexUser
      Metrics.incCounter indexUpdateCounter
      IndexedUserStore.upsert (userIdToDocId uid) userDoc version

    selectTeamMember :: TeamId -> Sem r (Maybe TeamMemberInfo)
    selectTeamMember tid = do
      listToMaybe . members <$> selectTeamMemberInfos tid [uid]

    mkRoleWithWriteTime :: TeamMemberInfo -> Maybe (WithWritetime Role)
    mkRoleWithWriteTime info =
      ( \role ->
          WithWriteTime
            { value = role,
              writetime = Writetime $ fromUTCTimeMillis info.permissionsWriteTime
            }
      )
        <$> permissionsToRole info.permissions

updateTeamSearchVisibilityInboundImpl :: (Member IndexedUserStore r) => TeamStatus SearchVisibilityInboundConfig -> Sem r ()
updateTeamSearchVisibilityInboundImpl teamStatus =
  IndexedUserStore.updateTeamSearchVisibilityInbound teamStatus.team $
    searchVisibilityInboundFromFeatureStatus teamStatus.status

searchUsersImpl ::
  forall r fedM.
  ( Member UserStore r,
    Member GalleyAPIAccess r,
    Member (Error UserSubsystemError) r,
    Member IndexedUserStore r,
    Member FederationConfigStore r,
    RunClient (fedM 'Brig),
    Member (FederationAPIAccess fedM) r,
    FederationMonad fedM,
    Typeable fedM,
    Member TinyLog r,
    Member (Error FederationError) r,
    Member (Input UserSubsystemConfig) r,
    Member TeamSubsystem r
  ) =>
  Local UserId ->
  Text ->
  Maybe Domain ->
  Maybe (Range 1 500 Int32) ->
  Maybe [UserTypeFilter] ->
  Sem r (SearchResult Contact)
searchUsersImpl searcherId searchTerm maybeDomain maybeMaxResults mTypes = do
  let searcher = tUnqualified searcherId
  mUser <- UserStore.getUser searcher
  -- this excludes ephemeral users
  unless ((mUser >>= (.status)) == Just Active) $ throw UserSubsystemInsufficientPermissions
  let mSearcherTeamId = mUser >>= (.teamId)
  for_ mSearcherTeamId $ \tid ->
    ensurePermissions searcher tid [SearchContacts]
  let qDomain = Qualified () (fromMaybe (tDomain searcherId) maybeDomain)
  foldQualified
    searcherId
    (\_ -> searchLocally ((,mSearcherTeamId) <$> searcherId) searchTerm maybeMaxResults mTypes)
    (\rdom -> searchRemotely rdom mSearcherTeamId searchTerm mTypes)
    qDomain

searchLocally ::
  forall r.
  ( Member GalleyAPIAccess r,
    Member UserStore r,
    Member IndexedUserStore r,
    Member (Input UserSubsystemConfig) r
  ) =>
  Local (UserId, Maybe TeamId) ->
  Text ->
  Maybe (Range 1 500 Int32) ->
  Maybe [UserTypeFilter] ->
  Sem r (SearchResult Contact)
searchLocally searcher searchTerm maybeMaxResults mTypes = do
  let maxResults = maybe 15 (fromIntegral . fromRange) maybeMaxResults
  let (searcherId, searcherTeamId) = (fst <$> searcher, snd <$> searcher)
  teamSearchInfo <- mkTeamSearchInfo (tUnqualified searcherTeamId)

  maybeExactHandleMatch <- exactHandleSearch
  let exactHandleMatchCount = length maybeExactHandleMatch
      esMaxResults = maxResults - exactHandleMatchCount

  esResult <-
    if esMaxResults > 0
      then
        IndexedUserStore.searchUsers
          (tUnqualified searcherId)
          (tUnqualified searcherTeamId)
          teamSearchInfo
          searchTerm
          esMaxResults
          mTypes
      else pure $ SearchResult 0 0 0 [] FullSearch Nothing Nothing

  let esContacts = map userDocToContact' (searchResults esResult)
      -- Prepend results matching exact handle and results from ES.
      allContacts = case maybeExactHandleMatch of
        Nothing -> esContacts
        Just exactHandleMatch -> exactHandleMatch : filter (\c -> c.contactQualifiedId /= exactHandleMatch.contactQualifiedId) esContacts
  pure $
    esResult
      { searchResults = allContacts,
        searchFound = exactHandleMatchCount + searchFound esResult,
        searchReturned = exactHandleMatchCount + searchReturned esResult
      }
  where
    handleTeamVisibility :: TeamId -> TeamSearchVisibility -> TeamSearchInfo
    handleTeamVisibility _ SearchVisibilityStandard = AllUsers
    handleTeamVisibility t SearchVisibilityNoNameOutsideTeam = TeamOnly t

    userDocToContact' :: UserDoc -> Contact
    userDocToContact' userDoc =
      runIdentity $
        userDocToContact
          (tUntagged $ qualifyAs searcher userDoc.udId)
          (Identity . maybe "" fromName)
          userDoc

    mkTeamSearchInfo :: Maybe TeamId -> Sem r TeamSearchInfo
    mkTeamSearchInfo searcherTeamId = do
      config <- input
      case searcherTeamId of
        Nothing -> pure NoTeam
        Just t ->
          -- This flag in brig overrules any flag on galley - it is system wide
          if config.searchSameTeamOnly
            then pure (TeamOnly t)
            else do
              -- For team users, we need to check the visibility flag
              handleTeamVisibility t <$> GalleyAPIAccess.getTeamSearchVisibility t

    exactHandleSearch :: Sem r (Maybe Contact)
    exactHandleSearch = runMaybeT $ do
      handle <- hoistMaybe $ Handle.parseHandle searchTerm
      owner <- MaybeT $ UserStore.lookupHandle handle
      storedUser <- MaybeT $ UserStore.getUser owner
      config <- lift input
      let isContactVisible =
            (config.searchSameTeamOnly && (snd . tUnqualified $ searcher) == storedUser.teamId)
              || (not config.searchSameTeamOnly)
      if isContactVisible && fromMaybe True storedUser.searchable
        then do
          pure $
            Contact
              { contactQualifiedId = Qualified storedUser.id (tDomain searcher),
                contactName = fromName storedUser.name,
                contactHandle = Handle.fromHandle <$> storedUser.handle,
                contactColorId = Just . fromIntegral . fromColourId $ storedUser.accentId,
                contactTeam = storedUser.teamId,
                contactType = inferUserType storedUser.serviceId storedUser.userType
              }
        else hoistMaybe Nothing

searchRemotely ::
  ( Member FederationConfigStore r,
    RunClient (fedM 'Brig),
    Member (FederationAPIAccess fedM) r,
    FederationMonad fedM,
    Typeable fedM,
    Member TinyLog r,
    Member (Error FederationError) r
  ) =>
  Remote x ->
  Maybe TeamId ->
  Text ->
  Maybe [UserTypeFilter] ->
  Sem r (SearchResult Contact)
searchRemotely rDom mTid searchTerm mTypes = do
  let domain = tDomain rDom
  Log.info $
    Log.msg (Log.val "searchRemotely")
      . Log.field "domain" (show domain)
      . Log.field "searchTerm" searchTerm
  mFedCnf <- getFederationConfig domain
  let onlyInTeams = case restriction <$> mFedCnf of
        Just FederationRestrictionAllowAll -> Nothing
        Just (FederationRestrictionByTeam teams) -> Just teams
        -- if we are not federating at all, we also do not allow to search any remote teams
        Nothing -> Just []

  searchResponse <-
    runFederated rDom $
      fedClient @'Brig @"search-users" (FedBrig.SearchRequest searchTerm mTid onlyInTeams mTypes)
  let contacts = searchResponse.contacts
  let count = length contacts
  pure
    SearchResult
      { searchResults = contacts,
        searchFound = count,
        searchReturned = count,
        searchTook = 0,
        searchPolicy = searchResponse.searchPolicy,
        searchPagingState = Nothing,
        searchHasMore = Nothing
      }

browseTeamImpl ::
  ( Member (Error UserSubsystemError) r,
    Member IndexedUserStore r,
    Member TeamSubsystem r,
    Member UserGroupStore r
  ) =>
  UserId ->
  BrowseTeamFilters ->
  Maybe (Range 1 500 Int) ->
  Maybe PagingState ->
  Sem r (SearchResult TeamContact)
browseTeamImpl uid filters mMaxResults mPagingState = do
  -- limit this to team admins to reduce risk of involuntary DOS attacks. (also,
  -- this way we don't need to worry about revealing confidential user data to
  -- other team members.)
  ensurePermissions uid filters.teamId [Permission.AddTeamMember]

  let maxResults = maybe 15 fromRange mMaxResults
  result <- IndexedUserStore.paginateTeamMembers filters maxResults mPagingState
  let docs = result.searchResults
      uids = fmap (.udId) docs
  ugMap <- getUserGroupIdsForUsers (toList uids)
  for result $ \userDoc -> do
    let ugids = fromMaybe [] (Map.lookup userDoc.udId ugMap)
    pure $ userDocToTeamContact ugids userDoc

getAccountsByEmailNoFilterImpl ::
  forall r.
  ( Member UserStore r,
    Member UserKeyStore r,
    Member (Input UserSubsystemConfig) r
  ) =>
  Local [EmailAddress] ->
  Sem r [User]
getAccountsByEmailNoFilterImpl (tSplit -> (domain, emails)) = do
  config <- input
  nubOrd <$> flip foldMap emails \ek -> do
    mactiveUid <- lookupKey (mkEmailKey ek)
    getUsers (nubOrd . catMaybes $ [mactiveUid])
      <&> map (mkUserFromStored domain config.defaultLocale)

--------------------------------------------------------------------------------
-- getting user accounts by different criteria

getAccountsByImpl ::
  forall r.
  ( Member UserStore r,
    Member DeleteQueue r,
    Member (Input UserSubsystemConfig) r,
    Member InvitationStore r
  ) =>
  Local GetBy ->
  Sem r [User]
getAccountsByImpl (tSplit -> (domain, GetBy {..})) = do
  storedToExtAcc <- do
    config <- input
    pure $ mkUserFromStored domain config.defaultLocale

  handleUserIds :: [UserId] <-
    wither lookupHandle getByHandle

  accsByIds :: [User] <-
    getUsers (nubOrd $ handleUserIds <> getByUserId)
      <&> map storedToExtAcc

  afterGC :: [User] <-
    if includeUsersWithExpiredInvitations
      then pure accsByIds
      else garbageCollect accsByIds

  pure $ filter weWant afterGC
  where
    weWant :: User -> Bool
    weWant user = applyPendingInvitationsFilter user && applyIdentityFilter user

    applyPendingInvitationsFilter :: User -> Bool
    applyPendingInvitationsFilter user =
      case (includePendingInvitations, user.userStatus) of
        (NoPendingInvitations, PendingInvitation) -> False
        _ -> True

    applyIdentityFilter :: User -> Bool
    applyIdentityFilter user =
      case (user.userType, includeUsersWithoutIdentity, user.userIdentity) of
        (UserTypeApp, _, _) -> True
        (_, False, Nothing) -> False
        _ -> True

    -- user invited via scim expires together with its invitation. the UserSubsystem interface
    -- semantics hides the fact that pending users have no TTL field. we chose to emulate this
    -- in this convoluted way (by making the invitation expire and then checking if it's still
    -- there when looking up pending users), because adding TTLs would have been a much bigger
    -- change in the database schema (`enqueueUserDeletion` would need to happen purely based
    -- on TTL values in cassandra, and there is too much application logic involved there).
    --
    -- we could also delete these users here and run a background process that scans for
    -- pending users without invitation. we chose not to because enqueuing the user deletion
    -- here is very cheap, and avoids database traffic if the user is looked up again. if the
    -- background job is reliably taking care of this, there is no strong reason to keep this
    -- function.
    --
    -- there are certainly other ways to improve this, but they probably involve a non-trivial
    -- database schema re-design.
    garbageCollect :: [User] -> Sem r [User]
    garbageCollect users = do
      (gcUsers, safeUser) <- partitionM toBeGarbageCollected users
      mapM_ (enqueueUserDeletion . qUnqualified . userQualifiedId) gcUsers
      pure safeUser

    toBeGarbageCollected :: User -> Sem r Bool
    toBeGarbageCollected user =
      case (emailIdentity =<< user.userIdentity, user.userStatus) of
        (Just email, PendingInvitation) ->
          isNothing . listToMaybe <$> lookupInvitationsByEmail email
        _ -> pure False

acceptTeamInvitationImpl ::
  ( Member (Input UserSubsystemConfig) r,
    Member UserStore r,
    Member GalleyAPIAccess r,
    Member (Error UserSubsystemError) r,
    Member InvitationStore r,
    Member IndexedUserStore r,
    Member Metrics r,
    Member Events r,
    Member AuthenticationSubsystem r,
    Member TinyLog r,
    Member DRS.DomainRegistrationStore r
  ) =>
  Local UserId ->
  PlainTextPassword6 ->
  InvitationCode ->
  Sem r ()
acceptTeamInvitationImpl luid pw code = do
  mSelfProfile <- getSelfProfileImpl luid
  let mEmailKey = mkEmailKey <$> (userEmail . selfUser =<< mSelfProfile)
      mTid = mSelfProfile >>= userTeam . selfUser
  verifyUserPasswordError luid pw
  inv <- internalFindTeamInvitationImpl mEmailKey code
  let tid = inv.teamId
  let minvmeta = (,inv.createdAt) <$> inv.createdBy
      uid = tUnqualified luid
  for_ mTid $ \userTid ->
    unless (tid == userTid) $
      throw UserSubsystemCannotJoinMultipleTeams
  added <- GalleyAPIAccess.addTeamMember uid tid minvmeta (fromMaybe defaultRole inv.role)
  unless added $ throw UserSubsystemTooManyTeamMembers
  updateUserTeam uid tid
  deleteInvitation inv.teamId inv.invitationId
  for_ (userEmail . selfUser =<< mSelfProfile) $ \email ->
    deletePendingScimUser tid email uid
  syncUserIndex uid
  generateUserEvent uid Nothing (teamUpdated uid tid)

getUserExportDataImpl :: (Member UserStore r, Member ClientSubsystem r) => UserId -> Sem r (Maybe TeamExportUser)
getUserExportDataImpl uid = fmap hush . runError @() $ do
  su <- UserStore.getUser uid >>= note ()
  mRichInfo <- UserStore.getRichInfo uid
  timestamps <- ClientSubsystem.internalGetActivityTimestamps uid
  -- Make sure the list of timestamps is non-empty so that 'maximum' is
  -- well-defined and returns 'Nothing' when no valid timestamps are present.
  let lastActive = maximum (Nothing : timestamps)
  let numClients = length timestamps
  pure $
    TeamExportUser
      { tExportDisplayName = su.name,
        tExportHandle = su.handle,
        tExportEmail = su.email,
        tExportRole = Nothing,
        tExportCreatedOn = Nothing,
        tExportInvitedBy = Nothing,
        tExportIdpIssuer = userToIdPIssuer su,
        tExportManagedBy = fromMaybe ManagedByWire su.managedBy,
        tExportSAMLNamedId = fromMaybe "" (samlNamedId su),
        tExportSCIMExternalId = fromMaybe "" (scimExtId su),
        tExportSCIMRichInfo = fmap RichInfo mRichInfo,
        tExportUserId = uid,
        tExportNumDevices = numClients,
        tExportLastActive = lastActive,
        tExportStatus = su.status
      }

removeEmailEitherImpl ::
  ( Member UserKeyStore r,
    Member UserStore r,
    Member Events r,
    Member IndexedUserStore r,
    Member (Input UserSubsystemConfig) r,
    Member GalleyAPIAccess r,
    Member Metrics r
  ) =>
  Local UserId ->
  Sem r (Either UserSubsystemError ())
removeEmailEitherImpl lusr = runError $ do
  let uid = tUnqualified lusr
  ident <- getSelfProfileImpl lusr >>= note UserSubsystemProfileNotFound
  case ident.selfUser.userIdentity of
    Just (SSOIdentity (UserSSOId _) (Just e)) -> do
      deleteKey $ mkEmailKey e
      deleteEmail uid
      generateUserEvent uid Nothing (emailRemoved uid e)
      syncUserIndex uid
    Just _ -> throw UserSubsystemLastIdentity
    Nothing -> throw UserSubsystemNoIdentity

getUserTeamImpl :: (Member UserStore r) => UserId -> Sem r (Maybe TeamId)
getUserTeamImpl = UserStore.getUserTeam

checkUserIsAdminImpl ::
  (Member TeamSubsystem r, Member UserStore r, Member (Error UserSubsystemError) r) =>
  UserId ->
  Sem r TeamId
checkUserIsAdminImpl uid = do
  tid <- maybe (throw UserSubsystemInsufficientPermissions) pure =<< UserStore.getUserTeam uid
  ensurePermissions uid tid [CreateUpdateDeleteIdp]
  pure tid

setUserSearchableImpl ::
  ( Member UserStore r,
    Member (Error UserSubsystemError) r,
    Member TeamSubsystem r,
    Member GalleyAPIAccess r,
    Member IndexedUserStore r,
    Member Metrics r
  ) =>
  Local UserId ->
  UserId ->
  SetSearchable ->
  Sem r ()
setUserSearchableImpl luid uid searchable = do
  tid <- maybe (throw UserSubsystemInsufficientPermissions) pure =<< UserStore.getUserTeam uid
  ensurePermissions (tUnqualified luid) tid [SetMemberSearchable]
  UserStore.setUserSearchable uid searchable
  syncUserIndex uid
