{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# 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.EnterpriseLoginSubsystem.Interpreter
  ( runEnterpriseLoginSubsystemWithConfig,
    runEnterpriseLoginSubsystem,
    EnterpriseLoginSubsystemConfig (..),
    EnterpriseLoginSubsystemEmailConfig (..),
  )
where

import Bilge hiding (delete)
import Control.Lens ((^.), (^..), (^?))
import Data.Aeson qualified as Aeson
import Data.Aeson.Encode.Pretty qualified as Aeson
import Data.ByteString.Conversion (toByteString')
import Data.ByteString.Lazy qualified as BL
import Data.Domain
import Data.Id
import Data.Qualified
import Data.Text.Encoding qualified as Text
import Data.Text.Internal.Builder (fromLazyText, fromText, toLazyText)
import Data.Text.Lazy.Builder (Builder)
import Data.Text.Lazy.Encoding as LT
import Imports hiding (lookup)
import Network.HTTP.Types.Method
import Network.Mail.Mime (Address (Address), Mail (mailHeaders, mailParts, mailTo), emptyMail, plainPart)
import Polysemy
import Polysemy.Error (Error, note, throw)
import Polysemy.Error qualified as Error
import Polysemy.Input (Input, input, inputs, runInputConst, runInputSem)
import Polysemy.TinyLog (TinyLog)
import Polysemy.TinyLog qualified as Log
import SAML2.WebSSO qualified as SAML
import System.Logger.Message qualified as Log
import Util.Options
import Wire.API.EnterpriseLogin
import Wire.API.Routes.Public.Brig.DomainVerification
import Wire.API.Routes.Version
import Wire.API.Team.Feature
import Wire.API.Team.Member
import Wire.API.User hiding (NewUser)
import Wire.API.User.IdentityProvider (providers)
import Wire.DomainRegistrationStore
import Wire.DomainVerificationChallengeStore
  ( DomainVerificationChallengeStore,
    mkStoredDomainVerificationChallenge,
  )
import Wire.DomainVerificationChallengeStore qualified as Challenge
import Wire.EmailSending (EmailSending, sendMail)
import Wire.EnterpriseLoginSubsystem
import Wire.EnterpriseLoginSubsystem.Error
import Wire.GalleyAPIAccess
import Wire.ParseException
import Wire.Rpc
import Wire.Sem.Random as Random
import Wire.SparAPIAccess
import Wire.TeamSubsystem
import Wire.UserKeyStore
import Wire.UserSubsystem

data EnterpriseLoginSubsystemEmailConfig = EnterpriseLoginSubsystemEmailConfig
  { auditEmailSender :: EmailAddress,
    auditEmailRecipient :: EmailAddress
  }

data EnterpriseLoginSubsystemConfig = EnterpriseLoginSubsystemConfig
  { emailConfig :: Maybe EnterpriseLoginSubsystemEmailConfig,
    wireServerEnterpriseEndpoint :: Endpoint
  }

runEnterpriseLoginSubsystemWithConfig ::
  ( Member DomainRegistrationStore r,
    Member DomainVerificationChallengeStore r,
    Member (Error EnterpriseLoginSubsystemError) r,
    Member (Error ParseException) r,
    Member GalleyAPIAccess r,
    Member SparAPIAccess r,
    Member TinyLog r,
    Member EmailSending r,
    Member Random r,
    Member Rpc r,
    Member UserKeyStore r,
    Member UserSubsystem r,
    Member (Input (Local ())) r,
    Member TeamSubsystem r
  ) =>
  EnterpriseLoginSubsystemConfig ->
  Sem (EnterpriseLoginSubsystem ': r) a ->
  Sem r a
runEnterpriseLoginSubsystemWithConfig config =
  runInputConst config
    . runEnterpriseLoginSubsystem
    . raiseUnder

runEnterpriseLoginSubsystem ::
  ( Member DomainRegistrationStore r,
    Member DomainVerificationChallengeStore r,
    Member (Error EnterpriseLoginSubsystemError) r,
    Member (Error ParseException) r,
    Member GalleyAPIAccess r,
    Member SparAPIAccess r,
    Member TinyLog r,
    Member (Input EnterpriseLoginSubsystemConfig) r,
    Member EmailSending r,
    Member Random r,
    Member Rpc r,
    Member UserKeyStore r,
    Member UserSubsystem r,
    Member (Input (Local ())) r,
    Member TeamSubsystem r
  ) =>
  Sem (EnterpriseLoginSubsystem ': r) a ->
  Sem r a
runEnterpriseLoginSubsystem = interpret $
  \case
    LockDomain domain -> lockDomainImpl domain
    UnlockDomain domain -> unlockDomainImpl domain
    PreAuthorizeDomain domain -> preAuthorizeImpl domain
    UnAuthorizeDomain domain -> unauthorizeImpl domain
    UpdateDomainRegistration domain update -> updateDomainRegistrationImpl domain update
    DeleteDomain domain -> deleteDomainImpl domain
    GetDomainRegistration domain -> getDomainRegistrationImpl domain
    UpdateDomainRedirect mAuthToken domain config ->
      runInputSem (wireServerEnterpriseEndpoint <$> input) $
        updateDomainRedirectImpl mAuthToken domain config
    UpdateTeamInvite lusr domain config ->
      runInputSem (wireServerEnterpriseEndpoint <$> input) $
        updateTeamInviteImpl lusr domain config
    GetDomainRegistrationPublic req ->
      getDomainRegistrationPublicImpl req
    CreateDomainVerificationChallenge domain ->
      runInputSem (wireServerEnterpriseEndpoint <$> input) $
        createDomainVerificationChallengeImpl domain
    VerifyChallenge mLusr domain challengeId challengeToken ->
      runInputSem (wireServerEnterpriseEndpoint <$> input) $
        verifyChallengeImpl mLusr domain challengeId challengeToken
    AuthorizeTeam lusr domain ownershipToken ->
      runInputSem (wireServerEnterpriseEndpoint <$> input) $
        authorizeTeamImpl lusr domain ownershipToken
    GetRegisteredDomains lusr tid ->
      runInputSem (wireServerEnterpriseEndpoint <$> input) $
        getRegisteredDomainsImpl lusr tid
    DeleteTeamDomain lusr tid domain -> deleteTeamDomainImpl lusr tid domain

deleteTeamDomainImpl ::
  ( Member (Error EnterpriseLoginSubsystemError) r,
    Member TinyLog r,
    Member UserSubsystem r,
    Member GalleyAPIAccess r,
    Member DomainRegistrationStore r,
    Member TeamSubsystem r
  ) =>
  Local UserId ->
  TeamId ->
  Domain ->
  Sem r ()
deleteTeamDomainImpl lusr tid domain = do
  void $ guardTeamAdminAccessWithTeamIdCheck (Just tid) lusr
  domainReg <- lookup domain >>= note EnterpriseLoginSubsystemErrorNotFound
  unless (domainReg.authorizedTeam == Just tid) $
    throw EnterpriseLoginSubsystemOperationForbidden
  delete domain

getRegisteredDomainsImpl ::
  ( Member (Error EnterpriseLoginSubsystemError) r,
    Member UserSubsystem r,
    Member GalleyAPIAccess r,
    Member (Log.Logger (Log.Msg -> Log.Msg)) r,
    Member DomainRegistrationStore r,
    Member TeamSubsystem r
  ) =>
  Local UserId ->
  TeamId ->
  Sem r (RegisteredDomains v)
getRegisteredDomainsImpl lusr tid = do
  void $ guardTeamAdminAccessWithTeamIdCheck (Just tid) lusr
  domains <- mkDomainRegistrationResponse <$$> lookupByTeam tid
  pure $ RegisteredDomains domains

authorizeTeamImpl ::
  ( Member TinyLog r,
    Member (Error EnterpriseLoginSubsystemError) r,
    Member UserSubsystem r,
    Member GalleyAPIAccess r,
    Member DomainRegistrationStore r,
    Member TeamSubsystem r
  ) =>
  Local UserId ->
  Domain ->
  DomainOwnershipToken ->
  Sem r ()
authorizeTeamImpl lusr domain (DomainOwnershipToken token) = do
  tid <- guardTeamAdminAccess lusr
  mDomainReg <- lookup domain
  domainReg <- checkDomainOwnership mDomainReg token
  when (domainReg.domainRedirect == Locked) $
    throw EnterpriseLoginSubsystemOperationForbidden
  upsert domainReg {authorizedTeam = Just tid}

checkDomainOwnership :: (Member (Error EnterpriseLoginSubsystemError) r) => Maybe DomainRegistration -> Token -> Sem r DomainRegistration
checkDomainOwnership mDomainReg ownershipToken = do
  domainReg <- note EnterpriseLoginSubsystemAuthFailure mDomainReg
  authTokenHash <- note EnterpriseLoginSubsystemAuthFailure domainReg.authTokenHash
  unless (hashToken ownershipToken == authTokenHash) $
    throw EnterpriseLoginSubsystemAuthFailure
  pure domainReg

createDomainVerificationChallengeImpl ::
  ( Member Random r,
    Member DomainVerificationChallengeStore r,
    Member (Error ParseException) r,
    Member (Input Endpoint) r,
    Member Rpc r,
    Member TinyLog r,
    Member DomainRegistrationStore r,
    Member (Error EnterpriseLoginSubsystemError) r
  ) =>
  Domain ->
  Sem r DomainVerificationChallenge
createDomainVerificationChallengeImpl domain = do
  dr <- lookup domain
  when (((.domainRedirect) <$> dr) == Just Locked) $
    throw EnterpriseLoginSubsystemOperationForbidden
  challengeId <- Id <$> Random.uuid
  token <- Token <$> Random.bytes 32
  dnsVerificationToken <- newDnsVerificationToken
  let challenge =
        DomainVerificationChallenge
          { challengeId,
            token,
            dnsVerificationToken
          }
  Challenge.insert (mkStoredDomainVerificationChallenge domain challenge)
  pure challenge

verifyChallengeImpl ::
  ( Member DomainVerificationChallengeStore r,
    Member DomainRegistrationStore r,
    Member (Error EnterpriseLoginSubsystemError) r,
    Member (Error ParseException) r,
    Member (Input Endpoint) r,
    Member Random r,
    Member Rpc r,
    Member TinyLog r,
    Member UserSubsystem r,
    Member GalleyAPIAccess r,
    Member TeamSubsystem r
  ) =>
  Maybe (Local UserId) ->
  Domain ->
  ChallengeId ->
  Token ->
  Sem r Token
verifyChallengeImpl mLusr domain challengeId challengeToken = do
  mCurrentEntry <- lookup domain
  when (((.domainRedirect) <$> mCurrentEntry) == Just Locked) $
    throw EnterpriseLoginSubsystemOperationForbidden
  case mLusr of
    Just lusr -> void $ guardTeamAdminAccess lusr
    Nothing -> unless (domainRegistrationForAnonymousAllowed mCurrentEntry) $ throw EnterpriseLoginSubsystemOperationForbidden
  challenge <- Challenge.lookup challengeId >>= note EnterpriseLoginSubsystemChallengeNotFound
  unless
    ( challenge.challengeTokenHash == hashToken challengeToken
        && challenge.domain == domain
    )
    $ do
      throw EnterpriseLoginSubsystemAuthFailure
  verifyDNSRecord domain challenge.dnsVerificationToken
  authToken <- Token <$> Random.bytes 32
  let domReg = fromMaybe (mkDomainRegistration domain) mCurrentEntry
  upsert $
    domReg
      { authTokenHash = Just $ hashToken authToken,
        dnsVerificationToken = Just challenge.dnsVerificationToken
      }
  Challenge.delete challengeId
  pure authToken
  where
    domainRegistrationForAnonymousAllowed :: Maybe DomainRegistration -> Bool
    domainRegistrationForAnonymousAllowed mDr = case (.domainRedirect) <$> mDr of
      Nothing -> False
      Just Locked -> False
      Just PreAuthorized -> True
      -- once the domain was registered before (meaning an entry exists other than Locked or Preauthorized)
      -- there is no need to preauthorize it again before verifying the DNS record
      Just _ -> True

deleteDomainImpl ::
  ( Member DomainRegistrationStore r,
    Member TinyLog r,
    Member (Input EnterpriseLoginSubsystemConfig) r,
    Member EmailSending r
  ) =>
  Domain ->
  Sem r ()
deleteDomainImpl domain = do
  mOld <- lookup domain
  sendAuditMail url "Domain deleted" mOld Nothing
  delete domain
  where
    url :: Builder
    url =
      "DELETE /i/domain-registration/"
        <> fromText (domainText domain)

unauthorizeImpl ::
  forall r.
  ( Member DomainRegistrationStore r,
    Member (Error EnterpriseLoginSubsystemError) r,
    Member TinyLog r,
    Member (Input EnterpriseLoginSubsystemConfig) r,
    Member EmailSending r
  ) =>
  Domain ->
  Sem r ()
unauthorizeImpl domain = do
  old <- lookupOrThrow domain
  let new = old {domainRedirect = None} :: DomainRegistration
  case old.domainRedirect of
    PreAuthorized -> audit old new *> upsert new
    Backend _ _ -> audit old new *> upsert new
    NoRegistration -> audit old new *> upsert new
    None -> pure ()
    Locked -> throw EnterpriseLoginSubsystemOperationForbidden
    SSO _ -> throw EnterpriseLoginSubsystemOperationForbidden
  where
    audit :: DomainRegistration -> DomainRegistration -> Sem r ()
    audit old new = sendAuditMail url "Domain unauthorized" (Just old) (Just new)

    url :: Builder
    url =
      "POST /i/domain-registration/"
        <> fromText (domainText domain)
        <> "/unauthorized"

updateDomainRegistrationImpl ::
  forall r.
  ( Member DomainRegistrationStore r,
    Member (Error EnterpriseLoginSubsystemError) r,
    Member TinyLog r,
    Member (Input EnterpriseLoginSubsystemConfig) r,
    Member EmailSending r
  ) =>
  Domain ->
  DomainRegistrationUpdate ->
  Sem r ()
updateDomainRegistrationImpl domain update = do
  validate update
  mOld <- lookup domain
  let old = fromMaybe (mkDomainRegistration domain) mOld
      new =
        old {teamInvite = update.teamInvite, domainRedirect = update.domainRedirect} :: DomainRegistration
  audit mOld new *> upsert new
  where
    audit :: Maybe DomainRegistration -> DomainRegistration -> Sem r ()
    audit mOld new = sendAuditMail url "Domain registration updated" mOld (Just new)

    url :: Builder
    url =
      "PUT /i/domain-registration/"
        <> fromText (domainText domain)

lockDomainImpl ::
  forall r.
  ( Member DomainRegistrationStore r,
    Member TinyLog r,
    Member (Input EnterpriseLoginSubsystemConfig) r,
    Member EmailSending r
  ) =>
  Domain ->
  Sem r ()
lockDomainImpl domain = do
  mOld <- lookup domain
  let new = (mkDomainRegistration domain) {domainRedirect = Locked} :: DomainRegistration
  audit mOld new *> upsert new
  where
    url :: Builder
    url =
      "POST /i/domain-registration/"
        <> fromText (domainText domain)
        <> "/lock"

    audit :: Maybe DomainRegistration -> DomainRegistration -> Sem r ()
    audit old new = sendAuditMail url "Domain locked" old (Just new)

unlockDomainImpl ::
  forall r.
  ( Member DomainRegistrationStore r,
    Member (Error EnterpriseLoginSubsystemError) r,
    Member TinyLog r,
    Member (Input EnterpriseLoginSubsystemConfig) r,
    Member EmailSending r
  ) =>
  Domain ->
  Sem r ()
unlockDomainImpl domain = do
  old <- lookupOrThrow domain
  let new = old {domainRedirect = None} :: DomainRegistration
  case old.domainRedirect of
    Locked -> audit old new *> upsert new
    _ -> throw EnterpriseLoginSubsystemOperationForbidden
  where
    url :: Builder
    url =
      "POST /i/domain-registration/"
        <> fromText (domainText domain)
        <> "/unlock"

    audit :: DomainRegistration -> DomainRegistration -> Sem r ()
    audit old new = sendAuditMail url "Domain locked" (Just old) (Just new)

preAuthorizeImpl ::
  forall r.
  ( Member DomainRegistrationStore r,
    Member (Error EnterpriseLoginSubsystemError) r,
    Member TinyLog r,
    Member (Input EnterpriseLoginSubsystemConfig) r,
    Member EmailSending r
  ) =>
  Domain ->
  Sem r ()
preAuthorizeImpl domain = do
  mOld <- lookup domain
  let old = fromMaybe (mkDomainRegistration domain) mOld
      new = old {domainRedirect = PreAuthorized} :: DomainRegistration
  case old.domainRedirect of
    PreAuthorized -> pure ()
    None -> audit mOld new *> upsert new
    _ -> throw $ EnterpriseLoginSubsystemOperationForbidden
  where
    url :: Builder
    url =
      "POST /i/domain-registration/"
        <> fromText (domainText domain)
        <> "/preauthorize"

    audit :: Maybe DomainRegistration -> DomainRegistration -> Sem r ()
    audit old new = sendAuditMail url "Domain locked" old (Just new)

getDomainRegistrationImpl ::
  ( Member DomainRegistrationStore r,
    Member TinyLog r
  ) =>
  Domain ->
  Sem r (Maybe (DomainRegistrationResponse v))
getDomainRegistrationImpl domain = mkDomainRegistrationResponse <$$> lookup domain

lookupOrThrow ::
  ( Member DomainRegistrationStore r,
    Member (Error EnterpriseLoginSubsystemError) r,
    Member TinyLog r
  ) =>
  Domain ->
  Sem r DomainRegistration
lookupOrThrow = lookup >=> Error.note EnterpriseLoginSubsystemErrorNotFound

newDnsVerificationToken ::
  ( Member (Error ParseException) r,
    Member (Input Endpoint) r,
    Member Rpc r
  ) =>
  Sem r DnsVerificationToken
newDnsVerificationToken =
  decodeBodyOrThrow
    =<< enterpriseRequest
      (method POST . paths ["i", "create-verification-token"] . expect2xx)

verifyDNSRecord ::
  ( Member (Error ParseException) r,
    Member (Error EnterpriseLoginSubsystemError) r,
    Member (Input Endpoint) r,
    Member Rpc r
  ) =>
  Domain ->
  DnsVerificationToken ->
  Sem r ()
verifyDNSRecord domain dnsToken = do
  verified <-
    decodeBodyOrThrow
      =<< enterpriseRequest
        ( method POST
            . paths
              [ "i",
                "verify-domain-token",
                toByteString' domain,
                toByteString' dnsToken
              ]
            . expect2xx
        )
  unless verified $
    throw EnterpriseLoginSubsystemDomainVerificationFailed

enterpriseRequest :: (Member Rpc r, Member (Input Endpoint) r) => (Request -> Request) -> Sem r (Response (Maybe LByteString))
enterpriseRequest req = do
  ep <- input
  rpcWithRetries "wireServerEnterprise" ep req

decodeBodyOrThrow :: forall a r. (Typeable a, Aeson.FromJSON a, Member (Error ParseException) r) => Response (Maybe BL.ByteString) -> Sem r a
decodeBodyOrThrow r = either (throw . ParseException "wireServerEnterprise") pure (responseJsonEither r)

validate :: (Member (Error EnterpriseLoginSubsystemError) r) => DomainRegistrationUpdate -> Sem r ()
validate dr = do
  case dr.domainRedirect of
    Locked -> when (dr.teamInvite /= Allowed) $ throw EnterpriseLoginSubsystemOperationForbidden
    Backend _ _ -> when (dr.teamInvite /= NotAllowed) $ throw EnterpriseLoginSubsystemOperationForbidden
    _ -> pure ()

mkAuditMail :: EmailAddress -> EmailAddress -> Text -> LText -> Mail
mkAuditMail from to subject bdy =
  (emptyMail (Address Nothing (fromEmail from)))
    { mailTo = [Address Nothing (fromEmail to)],
      mailHeaders =
        [ ("Subject", subject),
          ("X-Zeta-Purpose", "audit")
        ],
      mailParts = [[plainPart bdy]]
    }

sendAuditMail ::
  ( Member (Input EnterpriseLoginSubsystemConfig) r,
    Member TinyLog r,
    Member EmailSending r
  ) =>
  Builder ->
  Text ->
  Maybe DomainRegistration ->
  Maybe DomainRegistration ->
  Sem r ()
sendAuditMail url subject mBefore mAfter = do
  let encodeDomainRegistrationPretty =
        maybe
          "null"
          (Aeson.encodePretty . mkDomainRegistrationResponse @V10)
  let encodeDomainRegistration =
        maybe
          "null"
          (Aeson.encode . mkDomainRegistrationResponse @V10)
  let auditLog :: LText =
        toLazyText $
          url
            <> " called;\nOld value:\n"
            <> fromLazyText
              (LT.decodeUtf8 (encodeDomainRegistrationPretty mBefore))
            <> "\nNew value:\n"
            <> fromLazyText
              ( LT.decodeUtf8
                  ( encodeDomainRegistrationPretty
                      mAfter
                  )
              )
  Log.info $
    Log.msg (Log.val "Domain registration audit log")
      . Log.field "url" (LT.encodeUtf8 $ toLazyText url)
      . Log.field "old_value" (encodeDomainRegistration mBefore)
      . Log.field "new_value" (encodeDomainRegistration mAfter)
  mConfig <- inputs emailConfig
  for_ mConfig $ \config -> do
    let mail = mkAuditMail (config.auditEmailSender) (config.auditEmailRecipient) subject auditLog
    sendMail mail

updateDomainRedirectImpl ::
  ( Member (Error EnterpriseLoginSubsystemError) r,
    Member TinyLog r,
    Member DomainRegistrationStore r,
    Member (Input EnterpriseLoginSubsystemConfig) r,
    Member EmailSending r
  ) =>
  Token ->
  Domain ->
  DomainRedirectConfigV9 ->
  Sem r ()
updateDomainRedirectImpl token domain config = do
  mDomainReg <- lookup domain
  domainReg <- checkDomainOwnership mDomainReg token
  unless (isAllowed domainReg.domainRedirect) $
    throw EnterpriseLoginSubsystemOperationForbidden
  updateDomainRegistrationImpl domain $ computeUpdate domainReg
  where
    computeUpdate reg = case config of
      DomainRedirectConfigRemoveV9 ->
        DomainRegistrationUpdate PreAuthorized reg.teamInvite
      DomainRedirectConfigBackendV9 url webappUrl ->
        DomainRegistrationUpdate (Backend url webappUrl) NotAllowed
      DomainRedirectConfigNoRegistrationV9 ->
        DomainRegistrationUpdate NoRegistration reg.teamInvite

    isAllowed = \case
      PreAuthorized -> True
      Backend _ _ -> True
      NoRegistration -> True
      _ -> False

updateTeamInviteImpl ::
  forall r.
  ( Member (Error EnterpriseLoginSubsystemError) r,
    Member (Input EnterpriseLoginSubsystemConfig) r,
    Member DomainRegistrationStore r,
    Member EmailSending r,
    Member GalleyAPIAccess r,
    Member SparAPIAccess r,
    Member TinyLog r,
    Member UserSubsystem r,
    Member TeamSubsystem r
  ) =>
  Local UserId ->
  Domain ->
  TeamInviteConfig ->
  Sem r ()
updateTeamInviteImpl luid domain config = do
  tid <- guardTeamAdminAccess luid
  mbDomainReg <- lookup domain
  domainReg <- note EnterpriseLoginSubsystemOperationForbidden mbDomainReg
  unless (domainReg.authorizedTeam == Just tid) $
    throw EnterpriseLoginSubsystemOperationForbidden
  update <- validateUpdate tid domainReg config
  updateDomainRegistrationImpl domain update
  where
    validateUpdate :: TeamId -> DomainRegistration -> TeamInviteConfig -> Sem r DomainRegistrationUpdate
    validateUpdate tid domReg conf = do
      when (domReg.domainRedirect == Locked) $
        throw EnterpriseLoginSubsystemOperationForbidden
      when (isJust $ domReg.domainRedirect ^? _Backend) $
        throw EnterpriseLoginSubsystemOperationForbidden
      case conf.teamInvite of
        Team tidConfig | tidConfig /= tid -> throw EnterpriseLoginSubsystemOperationForbidden
        validTeamInvite -> case conf.domainRedirect of
          Just (TeamSso idpId) -> do
            validateIdPId tid idpId
            pure $ DomainRegistrationUpdate (SSO idpId) validTeamInvite
          Just TeamNone -> pure $ DomainRegistrationUpdate None validTeamInvite
          Just TeamNoRegistration -> pure $ DomainRegistrationUpdate NoRegistration validTeamInvite
          Nothing -> pure $ DomainRegistrationUpdate domReg.domainRedirect validTeamInvite

    validateIdPId ::
      TeamId ->
      SAML.IdPId ->
      Sem r ()
    validateIdPId tid idp = do
      idps <- getIdentityProviders tid
      unless (idp `elem` idps.providers ^.. traverse . SAML.idpId) $
        throw EnterpriseLoginSubsystemOperationForbidden

guardTeamAdminAccess ::
  forall r.
  ( Member (Error EnterpriseLoginSubsystemError) r,
    Member UserSubsystem r,
    Member GalleyAPIAccess r,
    Member TeamSubsystem r
  ) =>
  Local UserId ->
  Sem r TeamId
guardTeamAdminAccess = guardTeamAdminAccessWithTeamIdCheck Nothing

guardTeamAdminAccessWithTeamIdCheck ::
  forall r.
  ( Member (Error EnterpriseLoginSubsystemError) r,
    Member UserSubsystem r,
    Member GalleyAPIAccess r,
    Member TeamSubsystem r
  ) =>
  Maybe TeamId ->
  Local UserId ->
  Sem r TeamId
guardTeamAdminAccessWithTeamIdCheck mExpectedTeam luid = do
  profile <- getSelfProfile luid >>= note EnterpriseLoginSubsystemOperationForbidden
  tid <- note EnterpriseLoginSubsystemOperationForbidden profile.selfUser.userTeam
  when (any (/= tid) mExpectedTeam) $
    throw EnterpriseLoginSubsystemOperationForbidden
  teamMember <-
    internalGetTeamMember (tUnqualified luid) tid
      >>= note EnterpriseLoginSubsystemOperationForbidden
  validatePaymentStatus tid
  unless (isAdminOrOwner (teamMember ^. permissions)) $
    throw EnterpriseLoginSubsystemOperationForbidden
  pure tid
  where
    validatePaymentStatus :: TeamId -> Sem r ()
    validatePaymentStatus tid = do
      feature <- getFeatureConfigForTeam @_ @DomainRegistrationConfig tid
      when (feature.status /= FeatureStatusEnabled) $
        throw EnterpriseLoginSubsystemPaymentRequired

getDomainRegistrationPublicImpl ::
  ( Member UserKeyStore r,
    Member (Error EnterpriseLoginSubsystemError) r,
    Member DomainRegistrationStore r,
    Member TinyLog r,
    Member UserSubsystem r,
    Member (Input (Local ())) r
  ) =>
  GetDomainRegistrationRequest ->
  Sem r (DomainRedirectResponse v)
getDomainRegistrationPublicImpl (GetDomainRegistrationRequest email) = do
  -- check if the email belongs to a registered user
  mUser <- do
    mUid <- lookupKey (mkEmailKey email)
    mLuid <- for mUid (\uid -> flip qualifyAs uid <$> input)
    maybe (pure Nothing) (fmap (fmap selfUser) . getSelfProfile) mLuid

  domain <-
    either
      (const (throw EnterpriseLoginSubsystemInvalidDomain))
      pure
      $ mkDomain (Text.decodeUtf8 (domainPart email))
  mReg <- getDomainRegistrationImpl domain

  pure $ case (mUser, maybe None (.domainRedirect) mReg) of
    (Just _, Backend _ _) -> DomainRedirectResponse True NoRegistration
    (Just user, SSO _)
      | not (isSSOAccountFromTeam (mReg >>= (.authorizedTeam)) user) ->
          DomainRedirectResponse False NoRegistration
    (_, dr) -> DomainRedirectResponse False dr
  where
    isSSOAccountFromTeam :: Maybe TeamId -> User -> Bool
    isSSOAccountFromTeam Nothing _ = False
    isSSOAccountFromTeam (Just tid) user = any isSSOIdentity user.userIdentity && user.userTeam == Just tid
