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

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

import Brig.API.Auth
import Brig.API.Connection qualified as API
import Brig.API.Error
import Brig.API.Handler
import Brig.API.MLS.KeyPackages.Validation
import Brig.API.OAuth (internalOauthAPI)
import Brig.API.Types
import Brig.API.User qualified as API
import Brig.App as App
import Brig.Data.Activation
import Brig.Data.Connection qualified as Data
import Brig.Options hiding (internalEvents)
import Brig.Provider.API qualified as Provider
import Brig.Team.API qualified as Team
import Brig.User.EJPD qualified
import Brig.User.Search.Index qualified as Search
import Control.Error hiding (bool)
import Control.Lens (preview, to, _Just)
import Control.Lens.Extras (is)
import Data.ByteString.Conversion (toByteString)
import Data.Code qualified as Code
import Data.CommaSeparatedList
import Data.Default
import Data.Domain (Domain)
import Data.Handle
import Data.HavePendingInvitations
import Data.Id as Id
import Data.Map.Strict qualified as Map
import Data.Misc (PlainTextPassword8)
import Data.Qualified
import Data.Set qualified as Set
import Data.Text qualified as T
import Data.Time.Clock.System
import Data.ZAuth.CryptoSign (CryptoSign)
import Imports hiding (head)
import Network.Wai.Utilities as Utilities
import Polysemy
import Polysemy.Error qualified as Polysemy
import Polysemy.Input (Input, input)
import Polysemy.TinyLog (TinyLog)
import Servant hiding (Handler, JSON, addHeader, respond)
import Servant.OpenApi.Internal.Orphans ()
import System.Logger.Class qualified as Log
import Wire.API.Connection
import Wire.API.EnterpriseLogin hiding (domain)
import Wire.API.Error
import Wire.API.Error.Brig qualified as E
import Wire.API.Federation.Error (FederationError (..))
import Wire.API.MLS.CipherSuite
import Wire.API.Routes.FederationDomainConfig
import Wire.API.Routes.Internal.Brig as BrigIRoutes
import Wire.API.Routes.Internal.Brig.Connection
import Wire.API.Routes.Named
import Wire.API.Team.Export
import Wire.API.Team.Feature
import Wire.API.Team.LegalHold.Internal
import Wire.API.User
import Wire.API.User.Activation
import Wire.API.User.Client
import Wire.API.User.RichInfo
import Wire.API.UserEvent
import Wire.API.UserGroup (UserGroup)
import Wire.API.UserGroup.Pagination
import Wire.API.UserMap
import Wire.ActivationCodeStore (ActivationCodeStore)
import Wire.ActivationCodeStore qualified as ActivationCode
import Wire.AppStore (AppStore)
import Wire.AppStore qualified as AppStore
import Wire.AppSubsystem (AppSubsystem)
import Wire.AppSubsystem qualified as AppSubsystem
import Wire.AuthenticationSubsystem (AuthenticationSubsystem)
import Wire.AuthenticationSubsystem.Config (AuthenticationSubsystemConfig)
import Wire.BlockListStore (BlockListStore)
import Wire.ClientStore (ClientStore)
import Wire.ClientStore qualified as ClientStore
import Wire.ClientSubsystem (ClientSubsystem, ReAuthPolicy (ReAuthPolicy))
import Wire.ClientSubsystem qualified as ClientSubsystem
import Wire.DomainRegistrationStore hiding (domain)
import Wire.EmailSubsystem (EmailSubsystem)
import Wire.EnterpriseLoginSubsystem
import Wire.EnterpriseLoginSubsystem.Error (EnterpriseLoginSubsystemError (EnterpriseLoginSubsystemErrorNotFound))
import Wire.Events (Events)
import Wire.Events qualified as Events
import Wire.FederationConfigStore
  ( AddFederationRemoteResult (..),
    AddFederationRemoteTeamResult (..),
    FederationConfigStore,
    UpdateFederationResult (..),
  )
import Wire.FederationConfigStore qualified as E
import Wire.GalleyAPIAccess (GalleyAPIAccess)
import Wire.HashPassword (HashPassword)
import Wire.IndexedUserStore (IndexedUserStore, getTeamSize)
import Wire.InvitationStore
import Wire.MlsKeyPackageSubsystem (MlsKeyPackageSubsystem)
import Wire.MlsKeyPackageSubsystem qualified as Mls
import Wire.NotificationSubsystem
import Wire.PasswordResetCodeStore (PasswordResetCodeStore)
import Wire.PropertySubsystem
import Wire.RateLimit
import Wire.Rpc
import Wire.SAMLEmailSubsystem (SAMLEmailSubsystem, sendSAMLIdPChanged)
import Wire.Sem.Concurrency
import Wire.Sem.Now (Now)
import Wire.Sem.Random (Random)
import Wire.SparAPIAccess (SparAPIAccess)
import Wire.StoredUser (StoredUser (..))
import Wire.TeamInvitationSubsystem
import Wire.TeamSubsystem (TeamSubsystem)
import Wire.UserGroupSubsystem
import Wire.UserKeyStore
import Wire.UserPendingActivationStore (UserPendingActivationStore)
import Wire.UserStore as UserStore
import Wire.UserSubsystem
import Wire.UserSubsystem qualified as User
import Wire.UserSubsystem qualified as UserSubsystem
import Wire.UserSubsystem.Error
import Wire.UserSubsystem.UserSubsystemConfig
import Wire.VerificationCode
import Wire.VerificationCodeGen
import Wire.VerificationCodeSubsystem

servantSitemap ::
  forall r p.
  ( Member BlockListStore r,
    Member (Concurrency 'Unsafe) r,
    Member (Embed HttpClientIO) r,
    Member FederationConfigStore r,
    Member AuthenticationSubsystem r,
    Member GalleyAPIAccess r,
    Member NotificationSubsystem r,
    Member UserSubsystem r,
    Member UserGroupSubsystem r,
    Member TeamSubsystem r,
    Member TeamInvitationSubsystem r,
    Member UserStore r,
    Member InvitationStore r,
    Member UserKeyStore r,
    Member Rpc r,
    Member TinyLog r,
    Member (UserPendingActivationStore p) r,
    Member EmailSubsystem r,
    Member VerificationCodeSubsystem r,
    Member Events r,
    Member PasswordResetCodeStore r,
    Member PropertySubsystem r,
    Member (Input (Local ())) r,
    Member IndexedUserStore r,
    Member (Polysemy.Error UserSubsystemError) r,
    Member HashPassword r,
    Member (Embed IO) r,
    Member ActivationCodeStore r,
    Member (Input UserSubsystemConfig) r,
    Member (Polysemy.Error EnterpriseLoginSubsystemError) r,
    Member EnterpriseLoginSubsystem r,
    Member DomainRegistrationStore r,
    Member SparAPIAccess r,
    Member RateLimit r,
    Member (Input AuthenticationSubsystemConfig) r,
    Member Now r,
    Member CryptoSign r,
    Member Random r,
    Member SAMLEmailSubsystem r,
    Member AppStore r,
    Member AppSubsystem r,
    Member ClientStore r,
    Member ClientSubsystem r,
    Member MlsKeyPackageSubsystem r
  ) =>
  ServerT BrigIRoutes.API (Handler r)
servantSitemap =
  istatusAPI
    :<|> ejpdAPI
    :<|> accountAPI
    :<|> mlsAPI
    :<|> Named @"get-verification-code" getVerificationCode
    :<|> teamsAPI
    :<|> userAPI
    :<|> clientAPI
    :<|> authAPI
    :<|> internalOauthAPI
    :<|> internalSearchIndexAPI
    :<|> federationRemotesAPI
    :<|> Provider.internalProviderAPI
    :<|> enterpriseLoginApi
    :<|> samlIdPApi
    :<|> Named @"i-delete-app" deleteAppH
    :<|> Named @"i-get-app-ids" getAppIdsH

istatusAPI :: forall r. ServerT BrigIRoutes.IStatusAPI (Handler r)
istatusAPI = Named @"get-status" (pure NoContent)

ejpdAPI ::
  ( Member GalleyAPIAccess r,
    Member NotificationSubsystem r,
    Member Rpc r,
    Member TeamSubsystem r,
    Member UserSubsystem r,
    Member (Input (Local ())) r
  ) =>
  ServerT BrigIRoutes.EJPDRequest (Handler r)
ejpdAPI = Named @"ejpd-request" Brig.User.EJPD.ejpdRequest

mlsAPI :: (Member ClientStore r, Member MlsKeyPackageSubsystem r) => ServerT BrigIRoutes.MLSAPI (Handler r)
mlsAPI =
  Named @"get-mls-clients" getMLSClientsH
    :<|> Named @"get-mls-client" getMLSClientH

accountAPI ::
  ( Member BlockListStore r,
    Member GalleyAPIAccess r,
    Member AuthenticationSubsystem r,
    Member (UserPendingActivationStore p) r,
    Member (Embed HttpClientIO) r,
    Member NotificationSubsystem r,
    Member UserSubsystem r,
    Member UserGroupSubsystem r,
    Member UserKeyStore r,
    Member (Input (Local ())) r,
    Member UserStore r,
    Member TinyLog r,
    Member EmailSubsystem r,
    Member PropertySubsystem r,
    Member Events r,
    Member PasswordResetCodeStore r,
    Member HashPassword r,
    Member InvitationStore r,
    Member (Embed IO) r,
    Member ActivationCodeStore r,
    Member (Polysemy.Error UserSubsystemError) r,
    Member (Input UserSubsystemConfig) r,
    Member DomainRegistrationStore r,
    Member RateLimit r,
    Member SparAPIAccess r,
    Member EnterpriseLoginSubsystem r,
    Member (Concurrency Unsafe) r,
    Member ClientStore r,
    Member ClientSubsystem r
  ) =>
  ServerT BrigIRoutes.AccountAPI (Handler r)
accountAPI =
  Named @"get-account-conference-calling-config" getAccountConferenceCallingConfig
    :<|> Named @"i-put-account-conference-calling-config" putAccountConferenceCallingConfig
    :<|> Named @"i-delete-account-conference-calling-config" deleteAccountConferenceCallingConfig
    :<|> Named @"i-get-all-connections-unqualified" getConnectionsStatusUnqualified
    :<|> Named @"i-get-all-connections" getConnectionsStatus
    :<|> Named @"createUserNoVerify" createUserNoVerify
    :<|> Named @"createUserNoVerifySpar" createUserNoVerifySpar
    :<|> Named @"putSelfEmail" changeSelfEmailMaybeSendH
    :<|> Named @"iDeleteUser" deleteUserNoAuthH
    :<|> Named @"iPutUserStatus" changeAccountStatusH
    :<|> Named @"iGetUserStatus" getAccountStatusH
    :<|> Named @"iGetUsersByVariousKeys" listActivatedAccountsH
    :<|> Named @"iGetUserContacts" getContactListH
    :<|> Named @"iGetUserActivationCode" getActivationCode
    :<|> Named @"iGetUserPasswordResetCode" getPasswordResetCodeH
    :<|> Named @"iRevokeIdentity" revokeIdentityH
    :<|> Named @"iHeadBlacklist" checkBlacklist
    :<|> Named @"iDeleteBlacklist" deleteFromBlacklist
    :<|> Named @"iPostBlacklist" addBlacklist
    :<|> Named @"iPutUserSsoId" updateSSOIdH
    :<|> Named @"iDeleteUserSsoId" deleteSSOIdH
    :<|> Named @"iPutManagedBy" updateManagedByH
    :<|> Named @"iDeletePendingEmailUpdate" deletePendingEmailUpdateH
    :<|> Named @"iPutRichInfo" updateRichInfoH
    :<|> Named @"iPutHandle" updateHandleH
    :<|> Named @"iPutUserName" updateUserNameH
    :<|> Named @"iGetRichInfo" getRichInfoH
    :<|> Named @"iHeadHandle" checkHandleInternalH
    :<|> Named @"iConnectionUpdate" updateConnectionInternalH
    :<|> Named @"iListClients" internalListClientsH
    :<|> Named @"iListClientsFull" internalListFullClientsH
    :<|> Named @"iAddClient" addClientInternalH
    :<|> Named @"iLegalholdAddClient" legalHoldClientRequestedH
    :<|> Named @"iLegalholdDeleteClient" removeLegalHoldClientH
    :<|> Named @"i-get-accounts-by" getAccountsByInternalH
    :<|> Named @"i-create-group-full" createGroupInternalH
    :<|> Named @"i-get-group" getGroupInternalH
    :<|> Named @"i-get-groups" getGroupsInternalH
    :<|> Named @"i-update-group" updateGroupInternalH
    :<|> Named @"i-delete-group-managed" deleteGroupManagedInternalH

teamsAPI ::
  ( Member GalleyAPIAccess r,
    Member (UserPendingActivationStore p) r,
    Member BlockListStore r,
    Member UserKeyStore r,
    Member UserStore r,
    Member (Concurrency 'Unsafe) r,
    Member TinyLog r,
    Member InvitationStore r,
    Member TeamInvitationSubsystem r,
    Member UserSubsystem r,
    Member TeamSubsystem r,
    Member (Polysemy.Error UserSubsystemError) r,
    Member Events r,
    Member (Input (Local ())) r,
    Member IndexedUserStore r,
    Member AuthenticationSubsystem r
  ) =>
  ServerT BrigIRoutes.TeamsAPI (Handler r)
teamsAPI =
  Named @"updateSearchVisibilityInbound" (lift . liftSem . updateTeamSearchVisibilityInbound)
    :<|> Named @"get-invitation-by-email" Team.getInvitationByEmail
    :<|> Named @"get-invitation-code" (\tid iid -> lift . liftSem $ Team.getInvitationCode tid iid)
    :<|> Named @"suspend-team" Team.suspendTeam
    :<|> Named @"unsuspend-team" Team.unsuspendTeam
    :<|> Named @"team-size" (lift . liftSem . getTeamSize)
    :<|> Named @"create-invitations-via-scim" Team.createInvitationViaScim

userAPI :: (Member UserSubsystem r) => ServerT BrigIRoutes.UserAPI (Handler r)
userAPI =
  Named @"i-update-user-locale" updateLocale
    :<|> Named @"i-delete-user-locale" deleteLocale
    :<|> Named @"i-get-default-locale" getDefaultUserLocale
    :<|> Named @"get-user-export-data" getUserExportDataH
    :<|> Named @"i-check-admin-get-team-id" checkAdminGetTeamId

clientAPI :: (Member ClientStore r) => ServerT BrigIRoutes.ClientAPI (Handler r)
clientAPI = Named @"update-client-last-active" updateClientLastActive

authAPI ::
  ( Member GalleyAPIAccess r,
    Member TinyLog r,
    Member Events r,
    Member UserSubsystem r,
    Member AuthenticationSubsystem r,
    Member (Input AuthenticationSubsystemConfig) r,
    Member (Concurrency Unsafe) r,
    Member Now r,
    Member CryptoSign r,
    Member Random r,
    Member UserStore r
  ) =>
  ServerT BrigIRoutes.AuthAPI (Handler r)
authAPI =
  Named @"legalhold-login" legalHoldLogin
    :<|> Named @"sso-login" ssoLogin
    :<|> Named @"login-code" getLoginCode
    :<|> Named @"reauthenticate"
      ( \uid reauth ->
          -- changing this end-point would involve providing a `Local` type from a user id that is
          -- captured from the path, not pulled from the http header.  this is certainly feasible,
          -- but running qualifyLocal here is easier.
          qualifyLocal uid >>= \luid -> reauthenticate luid reauth
      )

federationRemotesAPI ::
  (Member FederationConfigStore r) =>
  ServerT BrigIRoutes.FederationRemotesAPI (Handler r)
federationRemotesAPI =
  Named @"add-federation-remotes" addFederationRemote
    :<|> Named @"get-federation-remotes" getFederationRemotes
    :<|> Named @"update-federation-remotes" updateFederationRemote
    :<|> Named @"add-federation-remote-team" addFederationRemoteTeam
    :<|> Named @"get-federation-remote-teams" getFederationRemoteTeams
    :<|> Named @"delete-federation-remote-team" deleteFederationRemoteTeam

deleteFederationRemoteTeam :: (Member FederationConfigStore r) => Domain -> TeamId -> (Handler r) ()
deleteFederationRemoteTeam domain teamId =
  lift $ liftSem $ E.removeFederationRemoteTeam domain teamId

getFederationRemoteTeams :: (Member FederationConfigStore r) => Domain -> (Handler r) [FederationRemoteTeam]
getFederationRemoteTeams domain =
  lift $ liftSem $ E.getFederationRemoteTeams domain

addFederationRemoteTeam ::
  (Member FederationConfigStore r) =>
  Domain ->
  FederationRemoteTeam ->
  (Handler r) ()
addFederationRemoteTeam domain rt =
  lift (liftSem $ E.addFederationRemoteTeam domain rt.teamId) >>= \case
    AddFederationRemoteTeamSuccess -> pure ()
    AddFederationRemoteTeamDomainNotFound ->
      throwError . fedError . FederationUnexpectedError $
        "Federation domain does not exist.  Please add it first."
    AddFederationRemoteTeamRestrictionAllowAll ->
      throwError . fedError . FederationUnexpectedError $
        "Federation is not configured to be restricted by teams. Therefore adding a team to a \
        \remote domain is not allowed."

getFederationRemotes :: (Member FederationConfigStore r) => (Handler r) FederationDomainConfigs
getFederationRemotes = lift $ liftSem $ E.getFederationConfigs

addFederationRemote ::
  (Member FederationConfigStore r) =>
  FederationDomainConfig ->
  (Handler r) ()
addFederationRemote fedDomConf = do
  lift (liftSem $ E.addFederationConfig fedDomConf) >>= \case
    AddFederationRemoteSuccess -> pure ()
    AddFederationRemoteMaxRemotesReached ->
      throwError . fedError . FederationUnexpectedError $
        "Maximum number of remote backends reached.  If you need to create more connections, \
        \please contact wire.com."
    AddFederationRemoteDivergingConfig cfg ->
      throwError . fedError . FederationUnexpectedError $
        "keeping track of remote domains in the brig config file is deprecated, but as long as we \
        \do that, adding a domain with different settings than in the config file is not allowed.  want "
          <> ( "Just "
                 <> T.pack (show fedDomConf)
                 <> "or Nothing, "
             )
          <> ( "got "
                 <> T.pack (show (Map.lookup (domain fedDomConf) cfg))
             )

updateFederationRemote :: (Member FederationConfigStore r) => Domain -> FederationDomainConfig -> (Handler r) ()
updateFederationRemote dom fedcfg = do
  if (dom /= fedcfg.domain)
    then
      throwError . fedError . FederationUnexpectedError . T.pack $
        "federation domain of a given peer cannot be changed from " <> show (domain fedcfg) <> " to " <> show dom <> "."
    else
      lift (liftSem (E.updateFederationConfig fedcfg)) >>= \case
        UpdateFederationSuccess -> pure ()
        UpdateFederationRemoteNotFound ->
          throwError . fedError . FederationUnexpectedError . T.pack $
            "federation domain does not exist and cannot be updated: " <> show (dom, fedcfg)
        UpdateFederationRemoteDivergingConfig ->
          throwError . fedError . FederationUnexpectedError $
            "keeping track of remote domains in the brig config file is deprecated, but as long as we \
            \do that, removing or updating items listed in the config file is not allowed."

getAccountConferenceCallingConfig :: (Member UserStore r) => UserId -> Handler r (Feature ConferenceCallingConfig)
getAccountConferenceCallingConfig uid = do
  mStatus <- lift $ liftSem $ UserStore.lookupFeatureConferenceCalling uid
  mDefStatus <- preview (App.settingsLens . featureFlagsLens . _Just . to conferenceCalling . to forNull)
  pure $ def {status = mStatus <|> mDefStatus ?: (def :: LockableFeature ConferenceCallingConfig).status}

putAccountConferenceCallingConfig :: (Member UserStore r) => UserId -> Feature ConferenceCallingConfig -> Handler r NoContent
putAccountConferenceCallingConfig uid feat = do
  lift . liftSem $ UserStore.updateFeatureConferenceCalling uid (Just feat.status) $> NoContent

deleteAccountConferenceCallingConfig :: (Member UserStore r) => UserId -> Handler r NoContent
deleteAccountConferenceCallingConfig uid =
  lift . liftSem $ UserStore.updateFeatureConferenceCalling uid Nothing $> NoContent

getMLSClientH :: (Member ClientStore r, Member MlsKeyPackageSubsystem r) => UserId -> ClientId -> CipherSuite -> Handler r ClientInfo
getMLSClientH usr cid suite = do
  lusr <- qualifyLocal usr
  suiteTag <- maybe (mlsProtocolError "Unknown ciphersuite") pure (cipherSuiteTag suite)
  lift $ getMLSClient lusr cid suiteTag

getMLSClientsH :: (Member ClientStore r, Member MlsKeyPackageSubsystem r) => UserId -> CipherSuite -> Handler r (Set ClientInfo)
getMLSClientsH usr suite = do
  lusr <- qualifyLocal usr
  suiteTag <- maybe (mlsProtocolError "Unknown ciphersuite") pure (cipherSuiteTag suite)
  allClients <- lift (liftSem (ClientStore.lookupClientIds usr))
  clientInfos <- lift $ traverse (\c -> getMLSClient lusr c suiteTag) (toList allClients)
  pure $ Set.fromList clientInfos

getMLSClient ::
  (Member ClientStore r, Member MlsKeyPackageSubsystem r) =>
  Local UserId ->
  ClientId ->
  CipherSuiteTag ->
  AppT r ClientInfo
getMLSClient lusr cid suiteTag = do
  numKeyPackages <- liftSem $ Mls.countMlsKeyPackages (tUnqualified lusr) cid suiteTag
  mc <- liftSem $ ClientStore.lookupClient (tUnqualified lusr) cid
  let keys = foldMap (.clientMLSPublicKeys) mc
      ss = csSignatureScheme suiteTag
  pure
    ClientInfo
      { clientId = cid,
        hasKeyPackages = numKeyPackages > 0,
        mlsSignatureKey = Map.lookup ss keys
      }

getVerificationCode :: forall r. (Member VerificationCodeSubsystem r, Member UserSubsystem r, Member (Input (Local ())) r) => UserId -> VerificationAction -> Handler r (Maybe Code.Value)
getVerificationCode uid action = runMaybeT do
  getBy <- lift . lift . liftSem . qualifyLocal' $ getByNoFilters {getByUserId = [uid], includePendingInvitations = NoPendingInvitations}
  user <- MaybeT . fmap listToMaybe . lift . liftSem $ User.getAccountsBy getBy
  email <- MaybeT . pure $ userEmail user
  let key = mkKey email
  code <- MaybeT . lift . liftSem $ internalLookupCode key (scopeFromAction action)
  pure code.codeValue

internalSearchIndexAPI :: forall r. (Member UserSubsystem r) => ServerT BrigIRoutes.ISearchIndexAPI (Handler r)
internalSearchIndexAPI =
  Named @"indexRefresh" (NoContent <$ lift (wrapClient Search.refreshIndexes))
    :<|> Named @"update-search-index" (\uid -> lift $ liftSem $ UserSubsystem.internalUpdateSearchIndex uid $> NoContent)

enterpriseLoginApi ::
  ( Member EnterpriseLoginSubsystem r,
    Member (Polysemy.Error EnterpriseLoginSubsystemError) r
  ) =>
  ServerT BrigIRoutes.EnterpriseLoginApi (Handler r)
enterpriseLoginApi =
  Named @"domain-registration-lock" (fmap (const NoContent) . lift . liftSem . lockDomain)
    :<|> Named @"domain-registration-unlock" (fmap (const NoContent) . lift . liftSem . unlockDomain)
    :<|> Named @"domain-registration-pre-authorize" (fmap (const NoContent) . lift . liftSem . preAuthorizeDomain)
    :<|> Named @"domain-registration-unauthorize" (fmap (const NoContent) . lift . liftSem . unAuthorizeDomain)
    :<|> Named @"domain-registration-update" (\d p -> fmap (const NoContent) . lift . liftSem $ updateDomainRegistration d p)
    :<|> Named @"domain-registration-delete" (fmap (const NoContent) . lift . liftSem . deleteDomain)
    :<|> Named @"domain-registration-get" getDomainRegistrationH

samlIdPApi :: (Member SAMLEmailSubsystem r) => ServerT SAMLIdPAPI (Handler r)
samlIdPApi = Named @"send-idp-changed-email" (lift . liftSem . sendSAMLIdPChanged)

---------------------------------------------------------------------------
-- Handlers

getDomainRegistrationH ::
  ( Member EnterpriseLoginSubsystem r,
    Member (Polysemy.Error EnterpriseLoginSubsystemError) r
  ) =>
  Domain ->
  Handler r (DomainRegistrationResponse v)
getDomainRegistrationH domain =
  lift . liftSem $
    getDomainRegistration domain
      >>= Polysemy.note EnterpriseLoginSubsystemErrorNotFound

-- | Add a client without authentication checks
addClientInternalH ::
  (Member ClientSubsystem r) =>
  UserId ->
  Maybe Bool ->
  NewClient ->
  Maybe ConnId ->
  (Handler r) Client
addClientInternalH usr mSkipReAuth new connId = do
  let policy
        | mSkipReAuth == Just True = ReAuthPolicy $ \_ _ -> False
        | otherwise = def
  lusr <- qualifyLocal usr
  lift $ liftSem $ ClientSubsystem.addClientWithPolicy policy lusr connId new

legalHoldClientRequestedH :: (Member ClientSubsystem r) => UserId -> LegalHoldClientRequest -> (Handler r) NoContent
legalHoldClientRequestedH targetUser clientRequest = do
  lift $ liftSem $ NoContent <$ ClientSubsystem.publishLegalHoldClientRequested targetUser clientRequest

removeLegalHoldClientH ::
  (Member ClientSubsystem r) =>
  UserId ->
  (Handler r) NoContent
removeLegalHoldClientH uid = do
  lift $ liftSem $ NoContent <$ ClientSubsystem.removeLegalHoldClient uid

internalListClientsH :: (Member ClientStore r) => UserSet -> (Handler r) UserClients
internalListClientsH (UserSet usrs) =
  lift . liftSem $ ClientStore.lookupClientIdsBulk (Set.toList usrs)

internalListFullClientsH :: (Member ClientStore r) => UserSet -> (Handler r) UserClientsFull
internalListFullClientsH (UserSet usrs) =
  lift . liftSem $
    UserClientsFull . userMap <$> ClientStore.lookupClientsBulk (Set.toList usrs)

createUserNoVerify ::
  ( Member BlockListStore r,
    Member GalleyAPIAccess r,
    Member (UserPendingActivationStore p) r,
    Member TinyLog r,
    Member Events r,
    Member InvitationStore r,
    Member UserKeyStore r,
    Member UserStore r,
    Member UserSubsystem r,
    Member (Input (Local ())) r,
    Member HashPassword r,
    Member PasswordResetCodeStore r,
    Member ActivationCodeStore r,
    Member RateLimit r
  ) =>
  NewUser PlainTextPassword8 ->
  (Handler r) (Either RegisterError SelfProfile)
createUserNoVerify uData = lift . runExceptT $ do
  result <- API.createUser RateLimitInternal uData
  let acc = createdAccount result
  let uid = userId acc
  let eac = createdEmailActivation result
  for_ eac $ \adata ->
    let key = ActivateKey $ activationKey adata
        code = activationCode adata
     in API.activate key code (Just uid) !>> activationErrorToRegisterError
  pure . SelfProfile $ acc

createUserNoVerifySpar ::
  ( Member GalleyAPIAccess r,
    Member TinyLog r,
    Member UserSubsystem r,
    Member Events r,
    Member PasswordResetCodeStore r,
    Member UserStore r,
    Member UserKeyStore r
  ) =>
  NewUserSpar ->
  (Handler r) (Either CreateUserSparError SelfProfile)
createUserNoVerifySpar uData =
  lift . runExceptT $ do
    result <- API.createUserSpar uData
    let acc = createdAccount result
    let uid = userId acc
    let eac = createdEmailActivation result
    for_ eac $ \adata ->
      let key = ActivateKey $ activationKey adata
          code = activationCode adata
       in API.activate key code (Just uid) !>> CreateUserSparRegistrationError . activationErrorToRegisterError
    pure . SelfProfile $ acc

deleteUserNoAuthH ::
  ( Member (Embed HttpClientIO) r,
    Member NotificationSubsystem r,
    Member InvitationStore r,
    Member UserStore r,
    Member TinyLog r,
    Member UserKeyStore r,
    Member Events r,
    Member UserSubsystem r,
    Member PropertySubsystem r,
    Member AuthenticationSubsystem r,
    Member UserGroupSubsystem r,
    Member ClientStore r
  ) =>
  UserId ->
  (Handler r) DeleteUserResponse
deleteUserNoAuthH uid = do
  luid <- qualifyLocal uid
  r <- lift $ API.ensureAccountDeleted luid
  case r of
    NoUser -> throwStd (errorToWai @'E.UserNotFound)
    AccountAlreadyDeleted -> pure UserResponseAccountAlreadyDeleted
    AccountDeleted -> pure UserResponseAccountDeleted

changeSelfEmailMaybeSendH ::
  ( Member BlockListStore r,
    Member UserKeyStore r,
    Member EmailSubsystem r,
    Member UserSubsystem r,
    Member UserStore r,
    Member ActivationCodeStore r,
    Member (Polysemy.Error UserSubsystemError) r,
    Member (Input UserSubsystemConfig) r,
    Member TinyLog r,
    Member DomainRegistrationStore r,
    Member SparAPIAccess r,
    Member EnterpriseLoginSubsystem r,
    Member Events r,
    Member GalleyAPIAccess r,
    Member PasswordResetCodeStore r
  ) =>
  UserId ->
  EmailUpdate ->
  Maybe EmailActivation ->
  -- validate if needed? (deprecated, use EmailActivation query param)
  Maybe Bool ->
  -- auto activate email? (deprecated, use EmailActivation query param)
  Maybe Bool ->
  (Handler r) ChangeEmailResponse
changeSelfEmailMaybeSendH uid body mbEmailActivation (fromMaybe False -> validate) (fromMaybe False -> autoActivate) = do
  let email = euEmail body
  luid <- qualifyLocal uid
  needsActivation <-
    isNothing <$> runMaybeT do
      domain <- hoistMaybe . hush $ emailDomain email
      domReg <- MaybeT . lift . liftSem $ getDomainRegistration domain
      profile <- MaybeT . lift . liftSem $ getSelfProfile luid
      tid <- hoistMaybe . userTeam $ selfUser profile
      guard (domReg.authorizedTeam == Just tid)
      guard (domReg.domainRedirect & is _SSO)

  let emailActivation = fromMaybe activationDeprecated mbEmailActivation
      activationDeprecated
        | autoActivate || not needsActivation = AutoActivate
        | validate = SendActivationEmail
        | otherwise = error $ "impossible: `Spar.Intra.Brig.updateEmail` is the only call side.  details: " <> show (autoActivate, needsActivation, validate)

  -- Note: `UpdateOriginType` is hard coded to `UpdateOriginScim` here, so we implicitly assume that the endpoint of this handler is only used by SCIM.
  changeSelfEmailMaybeSend uid emailActivation email UpdateOriginScim

changeSelfEmailMaybeSend ::
  ( Member BlockListStore r,
    Member UserKeyStore r,
    Member EmailSubsystem r,
    Member UserSubsystem r,
    Member UserStore r,
    Member ActivationCodeStore r,
    Member (Polysemy.Error UserSubsystemError) r,
    Member (Input UserSubsystemConfig) r,
    Member TinyLog r,
    Member DomainRegistrationStore r,
    Member SparAPIAccess r,
    Member GalleyAPIAccess r,
    Member Events r,
    Member PasswordResetCodeStore r
  ) =>
  UserId ->
  EmailActivation ->
  EmailAddress ->
  UpdateOriginType ->
  (Handler r) ChangeEmailResponse
changeSelfEmailMaybeSend u activation email allowScim = do
  lusr <- qualifyLocal u
  case activation of
    SendActivationEmail ->
      lift . liftSem $ UserSubsystem.requestEmailChange lusr email allowScim
    AutoActivate -> do
      (lift . liftSem)
        (UserSubsystem.createEmailChangeToken lusr email allowScim)
        >>= \case
          ChangeEmailIdempotent -> pure ChangeEmailResponseIdempotent
          ChangeEmailNeedsActivation (_, Activation k c, _) -> do
            API.activateNoVerifyEmailDomain (ActivateKey k) c (Just u) !>> actError $> ChangeEmailResponseActivated

-- Historically, this end-point was two end-points with distinct matching routes
-- (distinguished by query params), and it was only allowed to pass one param per call.  This
-- handler allows up to 4 lists of various user keys, and returns the union of the lookups.
-- Empty lists are forbidden for backwards compatibility.
listActivatedAccountsH ::
  ( Member (Input (Local ())) r,
    Member UserSubsystem r
  ) =>
  Maybe (CommaSeparatedList UserId) ->
  Maybe (CommaSeparatedList Handle) ->
  Maybe (CommaSeparatedList EmailAddress) ->
  Maybe Bool ->
  Handler r [User]
listActivatedAccountsH
  (maybe [] fromCommaSeparatedList -> uids)
  (maybe [] fromCommaSeparatedList -> handles)
  (maybe [] fromCommaSeparatedList -> emails)
  (maybe NoPendingInvitations fromBool -> include) = do
    when (length uids + length handles + length emails == 0) $ do
      throwStd (notFound "no user keys")
    lift $ liftSem do
      loc <- input
      byEmails <- getAccountsByEmailNoFilter $ loc $> emails
      others <-
        getAccountsBy $
          loc
            $> def
              { includePendingInvitations = include,
                getByUserId = uids,
                getByHandle = handles
              }
      pure $ filter (\u -> u.userStatus /= Deleted) $ others <> byEmails

getActivationCode ::
  ( Member ActivationCodeStore r,
    Member (Embed IO) r
  ) =>
  EmailAddress ->
  Handler r GetActivationCodeResp
getActivationCode email = do
  apair <- lift . liftSem $ API.lookupActivationCode email
  maybe (throwStd activationKeyNotFound) (pure . GetActivationCodeResp) apair

getPasswordResetCodeH ::
  (Member AuthenticationSubsystem r) =>
  EmailAddress ->
  Handler r GetPasswordResetCodeResp
getPasswordResetCodeH email = getPasswordResetCode email

getPasswordResetCode ::
  (Member AuthenticationSubsystem r) =>
  EmailAddress ->
  Handler r GetPasswordResetCodeResp
getPasswordResetCode email =
  (GetPasswordResetCodeResp <$$> lift (API.lookupPasswordResetCode email))
    >>= maybe (throwStd (errorToWai @'E.InvalidPasswordResetKey)) pure

changeAccountStatusH ::
  ( Member UserSubsystem r,
    Member Events r,
    Member (Concurrency Unsafe) r,
    Member AuthenticationSubsystem r,
    Member UserStore r
  ) =>
  UserId ->
  AccountStatusUpdate ->
  (Handler r) NoContent
changeAccountStatusH usr (suStatus -> status) = do
  Log.info $ (Log.msg (Log.val "Change Account Status")) . Log.field "usr" (toByteString usr) . Log.field "status" (show status)
  API.changeSingleAccountStatus usr status !>> accountStatusError -- FUTUREWORK: use CanThrow and related machinery
  pure NoContent

getAccountStatusH :: (Member UserStore r) => UserId -> (Handler r) AccountStatusResp
getAccountStatusH uid = do
  status <- lift $ liftSem $ lookupStatus uid
  maybe
    (throwStd (errorToWai @'E.UserNotFound))
    (pure . AccountStatusResp)
    status

getConnectionsStatusUnqualified :: ConnectionsStatusRequest -> Maybe Relation -> (Handler r) [ConnectionStatus]
getConnectionsStatusUnqualified ConnectionsStatusRequest {csrFrom, csrTo} flt = lift $ do
  r <- wrapClient $ maybe (API.lookupConnectionStatus' csrFrom) (API.lookupConnectionStatus csrFrom) csrTo
  pure $ maybe r (filterByRelation r) flt
  where
    filterByRelation l rel = filter ((== rel) . csStatus) l

getConnectionsStatus :: ConnectionsStatusRequestV2 -> (Handler r) [ConnectionStatusV2]
getConnectionsStatus (ConnectionsStatusRequestV2 froms mtos mrel) = do
  loc <- qualifyLocal ()
  conns <- lift $ case mtos of
    Nothing -> wrapClient . Data.lookupAllStatuses =<< qualifyLocal froms
    Just tos -> do
      let getStatusesForOneDomain =
            wrapClient
              <$> foldQualified
                loc
                (Data.lookupLocalConnectionStatuses froms)
                (Data.lookupRemoteConnectionStatuses froms)
      concat <$> mapM getStatusesForOneDomain (bucketQualified tos)
  pure $ maybe conns (filterByRelation conns) mrel
  where
    filterByRelation l rel = filter ((== rel) . csv2Status) l

revokeIdentityH ::
  ( Member UserSubsystem r,
    Member UserKeyStore r,
    Member UserStore r
  ) =>
  EmailAddress ->
  Handler r NoContent
revokeIdentityH email = lift $ NoContent <$ API.revokeIdentity email

updateConnectionInternalH ::
  ( Member GalleyAPIAccess r,
    Member NotificationSubsystem r,
    Member TinyLog r,
    Member (Embed HttpClientIO) r,
    Member UserStore r
  ) =>
  UpdateConnectionsInternal ->
  (Handler r) NoContent
updateConnectionInternalH updateConn = do
  API.updateConnectionInternal updateConn !>> connError
  pure NoContent

checkBlacklist :: (Member BlockListStore r) => EmailAddress -> Handler r CheckBlacklistResponse
checkBlacklist email = lift $ bool NotBlacklisted YesBlacklisted <$> API.isBlacklisted email

deleteFromBlacklist :: (Member BlockListStore r) => EmailAddress -> Handler r NoContent
deleteFromBlacklist email = lift $ NoContent <$ API.blacklistDelete email

addBlacklist :: (Member BlockListStore r) => EmailAddress -> Handler r NoContent
addBlacklist email = lift $ NoContent <$ API.blacklistInsert email

updateSSOIdH ::
  ( Member UserSubsystem r,
    Member Events r,
    Member UserStore r
  ) =>
  UserId ->
  UserSSOId ->
  (Handler r) UpdateSSOIdResponse
updateSSOIdH uid ssoid = lift $ do
  success <- liftSem $ UserStore.updateSSOId uid (Just ssoid)
  liftSem $
    if success
      then do
        UserSubsystem.internalUpdateSearchIndex uid
        Events.generateUserEvent uid Nothing (UserUpdated ((emptyUserUpdatedData uid) {eupSSOId = Just ssoid}))
        pure UpdateSSOIdSuccess
      else pure UpdateSSOIdNotFound

deleteSSOIdH ::
  ( Member UserSubsystem r,
    Member Events r,
    Member UserStore r
  ) =>
  UserId ->
  (Handler r) UpdateSSOIdResponse
deleteSSOIdH uid = lift $ do
  success <- liftSem $ UserStore.updateSSOId uid Nothing
  if success
    then liftSem $ do
      UserSubsystem.internalUpdateSearchIndex uid
      Events.generateUserEvent uid Nothing (UserUpdated ((emptyUserUpdatedData uid) {eupSSOIdRemoved = True}))
      pure UpdateSSOIdSuccess
    else pure UpdateSSOIdNotFound

updateManagedByH :: (Member UserStore r) => UserId -> ManagedByUpdate -> (Handler r) NoContent
updateManagedByH uid (ManagedByUpdate managedBy) = do
  NoContent <$ lift (liftSem $ UserStore.updateManagedBy uid managedBy)

deletePendingEmailUpdateH ::
  ( Member UserStore r,
    Member ActivationCodeStore r
  ) =>
  UserId ->
  (Handler r) NoContent
deletePendingEmailUpdateH uid = do
  mUser <- lift . liftSem $ UserStore.getUser uid
  for_ (emailUnvalidated =<< mUser) $ \email ->
    lift . liftSem $ do
      ActivationCode.deleteActivationCode (mkEmailKey email)
      UserStore.deleteEmailUnvalidated uid
  pure NoContent

updateRichInfoH :: (Member UserStore r) => UserId -> RichInfoUpdate -> (Handler r) NoContent
updateRichInfoH uid rup =
  NoContent <$ do
    let (unRichInfoAssocList -> richInfo) = normalizeRichInfoAssocList . riuRichInfo $ rup
    maxSize <- asks (.settings.richInfoLimit)
    when (richInfoSize (RichInfo (mkRichInfoAssocList richInfo)) > maxSize) $ throwStd tooLargeRichInfo
    -- FUTUREWORK: send an event
    -- Intra.onUserEvent uid (Just conn) (richInfoUpdate uid ri)
    lift $ liftSem $ UserStore.updateRichInfo uid (mkRichInfoAssocList richInfo)

updateLocale :: (Member UserSubsystem r) => UserId -> LocaleUpdate -> (Handler r) LocaleUpdate
updateLocale uid upd@(LocaleUpdate locale) = do
  qUid <- qualifyLocal uid
  lift . liftSem $ updateUserProfile qUid Nothing UpdateOriginScim def {locale = Just locale}
  pure upd

deleteLocale :: (Member UserSubsystem r) => UserId -> (Handler r) NoContent
deleteLocale uid = do
  defLoc <- defaultUserLocale <$> asks (.settings)
  qUid <- qualifyLocal uid
  lift . liftSem $ updateUserProfile qUid Nothing UpdateOriginScim def {locale = Just defLoc}
  pure NoContent

getDefaultUserLocale :: (Handler r) LocaleUpdate
getDefaultUserLocale = do
  defLocale <- defaultUserLocale <$> asks (.settings)
  pure $ LocaleUpdate defLocale

checkAdminGetTeamId :: (Member UserSubsystem r) => UserId -> Handler r TeamId
checkAdminGetTeamId uid = lift . liftSem $ UserSubsystem.checkUserIsAdmin uid

updateClientLastActive :: (Member ClientStore r) => UserId -> ClientId -> Handler r ()
updateClientLastActive u c = do
  sysTime <- liftIO getSystemTime
  -- round up to the next multiple of a week
  let week = 604800
  let now =
        systemToUTCTime $
          sysTime
            { systemSeconds = systemSeconds sysTime + (week - systemSeconds sysTime `mod` week),
              systemNanoseconds = 0
            }
  lift . liftSem $ ClientStore.updateLastActive u c now

getRichInfoH :: (Member UserStore r) => UserId -> Handler r RichInfo
getRichInfoH uid =
  RichInfo . fromMaybe mempty
    <$> lift (liftSem $ UserStore.getRichInfo uid)

updateHandleH ::
  (Member UserSubsystem r) =>
  UserId ->
  HandleUpdate ->
  Handler r NoContent
updateHandleH uid (HandleUpdate handleUpd) =
  NoContent <$ do
    quid <- qualifyLocal uid
    lift . liftSem $ UserSubsystem.updateHandle quid Nothing UpdateOriginScim handleUpd

updateUserNameH ::
  (Member UserSubsystem r) =>
  UserId ->
  NameUpdate ->
  (Handler r) NoContent
updateUserNameH uid (NameUpdate nameUpd) =
  NoContent <$ do
    luid <- qualifyLocal uid
    name <- either (const $ throwStd (errorToWai @'E.InvalidUser)) pure $ mkName nameUpd
    lift (liftSem $ User.getAccountNoFilter luid) >>= \case
      Just _ -> lift . liftSem $ updateUserProfile luid Nothing UpdateOriginScim (def {name = Just name})
      Nothing -> throwStd (errorToWai @'E.InvalidUser)

checkHandleInternalH :: (Member UserSubsystem r) => Handle -> Handler r CheckHandleResponse
checkHandleInternalH h = lift $ liftSem do
  API.checkHandle (fromHandle h) <&> \case
    API.CheckHandleFound -> CheckHandleResponseFound
    API.CheckHandleNotFound -> CheckHandleResponseNotFound

getContactListH :: UserId -> (Handler r) UserIds
getContactListH uid = lift . wrapClient $ UserIds <$> API.lookupContactList uid

getUserExportDataH ::
  (Member UserSubsystem r) =>
  UserId ->
  Handler r (Maybe TeamExportUser)
getUserExportDataH = lift . liftSem . getUserExportData

getAccountsByInternalH ::
  ( Member UserSubsystem r,
    Member (Input (Local ())) r
  ) =>
  GetBy ->
  Handler r [User]
getAccountsByInternalH getByData = do
  loc <- lift $ liftSem input
  lift . liftSem $ getAccountsBy (qualifyAs loc getByData)

createGroupInternalH ::
  (Member UserGroupSubsystem r) =>
  CreateGroupInternalRequest ->
  Handler r UserGroup
createGroupInternalH req =
  lift . liftSem $
    createGroupInternal
      req.managedBy
      req.teamId
      req.creatorUserId
      req.newGroup

getGroupInternalH ::
  (Member UserGroupSubsystem r) =>
  TeamId ->
  UserGroupId ->
  Bool ->
  Handler r (Maybe UserGroup)
getGroupInternalH tid uid includeChannels =
  lift . liftSem $ getGroupInternal tid uid includeChannels

getGroupsInternalH ::
  (Member UserGroupSubsystem r) =>
  TeamId ->
  Maybe T.Text ->
  Maybe ManagedBy ->
  Word ->
  Maybe Word ->
  Handler r UserGroupPageWithMembers
getGroupsInternalH tid nameContains managedBy startIndex mbCount =
  lift . liftSem $ getGroupsInternal tid nameContains managedBy startIndex mbCount

updateGroupInternalH ::
  (Member UserGroupSubsystem r) =>
  UpdateGroupInternalRequest ->
  Handler r ()
updateGroupInternalH req =
  lift . liftSem $ resetUserGroupInternal req

deleteGroupManagedInternalH ::
  (Member UserGroupSubsystem r) =>
  TeamId ->
  UserGroupId ->
  ManagedBy ->
  Handler r NoContent
deleteGroupManagedInternalH tid gid managedBy = do
  lift . liftSem $ deleteGroupManaged managedBy tid gid
  pure NoContent

deleteAppH :: (Member AppSubsystem r) => TeamId -> UserId -> Handler r NoContent
deleteAppH tid uid = lift . liftSem $ AppSubsystem.internalDeleteApp tid uid >> pure NoContent

getAppIdsH :: (Member AppStore r) => TeamId -> Handler r [UserId]
getAppIdsH tid = lift . liftSem $ map (.id) <$> AppStore.getApps tid
