{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE RecordWildCards #-}
{-# HLINT ignore "Use $>" #-}
-- Disabling to stop warnings on HasCallStack
{-# OPTIONS_GHC -Wno-redundant-constraints #-}
{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
{-# OPTIONS_GHC -fplugin=Polysemy.Plugin #-}

-- 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/>.

-- | The API types, handlers, and WAI 'Application' for whole Spar.
--
-- Note: handlers are defined here, but API types are reexported from "Spar.API.Types". The
-- SCIM branch of the API is fully defined in "Spar.Scim".
module Spar.API
  ( -- * Server
    Spar.API.app,
    api,

    -- * API types
    SparAPI,

    -- ** Individual API pieces
    APIAuthReqPrecheck,
    APIAuthReq,
    APIAuthResp,
    IdpGet,
    IdpGetAll,
    IdpCreate,
    IdpDelete,

    -- * published to enable testing

    -- FUTUREWORK: This module should be split into two: Servant handler
    -- subtilities and the functions that do the actual work.
    idpCreate,
    idpCreateV7,
    idpDelete,
    idpUpdate,
    authresp,
  )
where

import Cassandra as Cas
import Control.Lens hiding ((.=))
import qualified Data.ByteString as SBS
import Data.ByteString.Builder (toLazyByteString)
import Data.ByteString.Conversion
import Data.Domain (Domain, domainText)
import Data.HavePendingInvitations
import Data.Id
import qualified Data.List.NonEmpty as NE
import qualified Data.Map as Map
import Data.Proxy
import Data.Range
import Data.Text.Encoding.Error
import qualified Data.Text.Lazy as T
import Data.Text.Lazy.Encoding
import Data.Time
import qualified Data.UUID as UUID
import qualified Data.X509 as X509
import Data.X509.Extended
import Imports
import Network.Wai (Request, requestHeaders)
import qualified Network.Wai.Utilities.Error as Wai
import Network.Wai.Utilities.Request
import Network.Wai.Utilities.Server (defaultRequestIdHeaderName)
import Polysemy
import Polysemy.Error
import Polysemy.Input
import qualified SAML2.WebSSO as SAML
import Servant
import qualified Servant.Multipart as Multipart
import Servant.Server.Experimental.Auth
import Spar.App
import Spar.CanonicalInterpreter
import Spar.Error
import qualified Spar.Intra.RpcApp as Intra
import Spar.Options
import Spar.Orphans ()
import Spar.Scim hiding (handle)
import Spar.Sem.AReqIDStore (AReqIDStore)
import Spar.Sem.AssIDStore (AssIDStore)
import Spar.Sem.SAML2 (SAML2)
import qualified Spar.Sem.SAML2 as SAML2
import Spar.Sem.SAMLUserStore (SAMLUserStore)
import qualified Spar.Sem.SAMLUserStore as SAMLUserStore
import Spar.Sem.ScimTokenStore (ScimTokenStore)
import qualified Spar.Sem.ScimTokenStore as ScimTokenStore
import System.Logger (Msg)
import qualified System.Logger as Log
import qualified URI.ByteString as URI
import Wire.API.Routes.Internal.Brig (IdpChangedNotification (IdPCreated, IdPDeleted, IdPUpdated))
import Wire.API.Routes.Internal.Spar
import Wire.API.Routes.Named
import Wire.API.Routes.Public (ZHostValue)
import Wire.API.Routes.Public.Spar
import Wire.API.Team.Member (HiddenPerm (CreateUpdateDeleteIdp, ReadIdp))
import Wire.API.User
import Wire.API.User.Auth (CookieLabel)
import Wire.API.User.IdentityProvider
import Wire.API.User.Saml
import Wire.BrigAPIAccess (BrigAPIAccess)
import qualified Wire.BrigAPIAccess as BrigAPIAccess
import Wire.DefaultSsoStore (DefaultSsoCode)
import qualified Wire.DefaultSsoStore as DefaultSsoCode
import Wire.GalleyAPIAccess (GalleyAPIAccess)
import Wire.IdPConfigStore (IdPConfigStore, Replaced (..), Replacing (..))
import qualified Wire.IdPConfigStore as IdPConfigStore
import Wire.IdPRawMetadataStore (IdPRawMetadataStore)
import qualified Wire.IdPRawMetadataStore as IdPRawMetadataStore
import Wire.IdPSubsystem (IdPSubsystem)
import qualified Wire.IdPSubsystem as IdPSubsystem
import Wire.Reporter (Reporter)
import Wire.SamlProtocolSettings (SamlProtocolSettings)
import qualified Wire.SamlProtocolSettings as SamlProtocolSettings
import Wire.ScimExternalIdStore (ScimExternalIdStore)
import Wire.ScimSubsystem
import Wire.ScimUserTimesStore (ScimUserTimesStore)
import qualified Wire.ScimUserTimesStore as ScimUserTimesStore
import Wire.Sem.Logger (Logger)
import qualified Wire.Sem.Logger as Logger
import Wire.Sem.Now (Now)
import Wire.Sem.Random (Random)
import qualified Wire.Sem.Random as Random
import Wire.VerdictFormatStore (VerdictFormatStore)
import qualified Wire.VerdictFormatStore as VerdictFormatStore

app :: Env -> Application
app ctx0 req cont = do
  let rid = getRequestId defaultRequestIdHeaderName req
  let ctx = ctx0 {sparCtxRequestId = rid}
  SAML.setHttpCachePolicy
    ( serveWithContext
        (Proxy @SparAPI)
        (authContext ctx)
        ( hoistServerWithContext
            (Proxy @SparAPI)
            (Proxy @'[AuthHandler Request TeamId])
            (runSparToHandler ctx)
            (api $ sparCtxOpts ctx) ::
            Server SparAPI
        )
    )
    req
    cont

api ::
  ( Member GalleyAPIAccess r,
    Member BrigAPIAccess r,
    Member (Input Opts) r,
    Member AssIDStore r,
    Member AReqIDStore r,
    Member VerdictFormatStore r,
    Member ScimExternalIdStore r,
    Member ScimUserTimesStore r,
    Member ScimTokenStore r,
    Member ScimSubsystem r,
    Member IdPSubsystem r,
    Member DefaultSsoCode r,
    Member IdPConfigStore r,
    Member IdPRawMetadataStore r,
    Member SAMLUserStore r,
    Member Random r,
    Member (Error SparError) r,
    Member SAML2 r,
    Member Now r,
    Member SamlProtocolSettings r,
    Member (Logger String) r,
    Member Reporter r,
    Member
      ( -- TODO(sandy): Only necessary for 'fromExceptionSem' in 'apiScim'
        Final IO
      )
      r,
    Member ScimSubsystem r,
    Member (Logger (Msg -> Msg)) r
  ) =>
  Opts ->
  ServerT SparAPI (Sem r)
api opts =
  apiSSO opts
    :<|> apiIDP opts
    :<|> apiScim
    :<|> apiINTERNAL

apiSSO ::
  ( Member GalleyAPIAccess r,
    Member (Logger String) r,
    Member (Logger (Msg -> Msg)) r,
    Member (Input Opts) r,
    Member BrigAPIAccess r,
    Member AssIDStore r,
    Member VerdictFormatStore r,
    Member AReqIDStore r,
    Member ScimTokenStore r,
    Member ScimExternalIdStore r,
    Member DefaultSsoCode r,
    Member IdPConfigStore r,
    Member IdPSubsystem r,
    Member Random r,
    Member (Error SparError) r,
    Member SAML2 r,
    Member SamlProtocolSettings r,
    Member Reporter r,
    Member ScimSubsystem r,
    Member SAMLUserStore r
  ) =>
  Opts ->
  ServerT APISSO (Sem r)
apiSSO opts =
  Named @"sso-metadata" (getMetadata Nothing)
    :<|> Named @"sso-team-metadata" (\mbHost tid -> getMetadata (Just tid) mbHost)
    :<|> Named @"auth-req-precheck" (authreqPrecheck opts.saml)
    :<|> Named @"auth-req" (authreq opts.saml (maxttlAuthreqDiffTime opts))
    :<|> Named @"auth-resp-legacy" (authresp Nothing)
    :<|> Named @"auth-resp" (authresp . Just)
    :<|> Named @"sso-settings" ssoSettings
    :<|> Named @"sso-get-by-email" getSsoCodeByEmail

apiIDP ::
  ( Member Random r,
    Member (Logger String) r,
    Member (Logger (Msg -> Msg)) r,
    Member (Input Opts) r,
    Member GalleyAPIAccess r,
    Member BrigAPIAccess r,
    Member ScimTokenStore r,
    Member IdPConfigStore r,
    Member IdPRawMetadataStore r,
    Member SAMLUserStore r,
    Member (Error SparError) r
  ) =>
  Opts ->
  ServerT APIIDP (Sem r)
apiIDP opts =
  Named @"idp-get" idpGet -- get, json, captures idp id
    :<|> Named @"idp-get-raw" idpGetRaw -- get, raw xml, capture idp id
    :<|> Named @"idp-get-all" idpGetAll -- get, json
    :<|> Named @"idp-create@v7" (idpCreateV7 opts.saml)
    :<|> Named @"idp-create" (idpCreate opts.saml) -- post, created
    :<|> Named @"idp-update" (idpUpdate opts.saml) -- put, okay
    :<|> Named @"idp-delete" (idpDelete opts.saml) -- delete, no content

apiINTERNAL ::
  ( Member ScimTokenStore r,
    Member DefaultSsoCode r,
    Member IdPConfigStore r,
    Member (Error SparError) r,
    Member SAMLUserStore r,
    Member ScimUserTimesStore r,
    Member (Logger (Msg -> Msg)) r,
    Member Random r,
    Member GalleyAPIAccess r,
    Member BrigAPIAccess r
  ) =>
  ServerT InternalAPI (Sem r)
apiINTERNAL =
  Named @"i_status" internalStatus
    :<|> Named @"i_delete_team" internalDeleteTeam
    :<|> Named @"i_put_sso_settings" internalPutSsoSettings
    :<|> Named @"i_post_scim_user_info" internalGetScimUserInfo
    :<|> Named @"i_get_identity_providers" idpGetAllByTeamId

appName :: Text
appName = "spar"

----------------------------------------------------------------------------
-- SSO API

-- | NB: not providing a team id here (route `Named "sso-metadata"`) is deprecated.  Some IdPs
-- do not allow setting different IdP issuer urls for different SPs, but only support one
-- global issuer url.  Adding the team id here allows us to scope this global issuer url
-- inside the team, ie. use it once per team, not once per instance.
getMetadata ::
  forall r.
  ( Member SAML2 r,
    Member SamlProtocolSettings r,
    Member (Error SparError) r
  ) =>
  Maybe TeamId ->
  Maybe ZHostValue ->
  Sem r SAML.SPMetadata
getMetadata mbTid mbHost = do
  let err :: Sem r any
      err = throwSparSem (SparSPNotFound "")

  let iss :: Sem r SAML.Issuer
      iss = SamlProtocolSettings.spIssuer mbTid mbHost >>= maybe err pure

      rsp :: Sem r URI.URI
      rsp = SamlProtocolSettings.responseURI mbTid mbHost >>= maybe err pure

      contactList :: Sem r [SAML.ContactPerson]
      contactList = SamlProtocolSettings.contactPersons mbHost

  SAML2.meta appName iss rsp contactList

authreqPrecheck ::
  ( Member IdPConfigStore r,
    Member (Error SparError) r,
    Member (Logger (Msg -> Msg)) r
  ) =>
  SAML.Config ->
  Maybe URI.URI ->
  Maybe URI.URI ->
  Maybe CookieLabel ->
  SAML.IdPId ->
  Maybe ZHostValue ->
  Sem r NoContent
authreqPrecheck samlConfig msucc merr mlabel idpid mbHost =
  validateAuthreqParams msucc merr mlabel *> do
    idp <- IdPConfigStore.getConfig idpid
    checkMultiIngressDomain samlConfig mbHost idp
    pure NoContent

authreq ::
  forall r.
  ( Member Random r,
    Member (Input Opts) r,
    Member (Logger String) r,
    Member (Logger (Msg -> Msg)) r,
    Member AssIDStore r,
    Member VerdictFormatStore r,
    Member AReqIDStore r,
    Member SAML2 r,
    Member SamlProtocolSettings r,
    Member (Error SparError) r,
    Member IdPConfigStore r
  ) =>
  SAML.Config ->
  NominalDiffTime ->
  Maybe URI.URI ->
  Maybe URI.URI ->
  Maybe CookieLabel ->
  SAML.IdPId ->
  Maybe ZHostValue ->
  Sem r (SAML.FormRedirect SAML.AuthnRequest)
authreq samlConfig authreqttl msucc merr mlabel idpid mbHost = do
  vformat <- validateAuthreqParams msucc merr mlabel
  form@(SAML.FormRedirect _ ((^. SAML.rqID) -> reqid)) <- do
    idp :: IdP <- IdPConfigStore.getConfig idpid

    checkMultiIngressDomain samlConfig mbHost idp

    let err :: Sem r any
        err = throwSparSem (SparSPNotFound "")

    let mbtid :: Maybe TeamId
        mbtid = case fromMaybe defWireIdPAPIVersion (idp ^. SAML.idpExtraInfo . apiVersion) of
          WireIdPAPIV1 -> Nothing
          WireIdPAPIV2 -> Just $ idp ^. SAML.idpExtraInfo . team
        iss :: Sem r SAML.Issuer
        iss = SamlProtocolSettings.spIssuer mbtid mbHost >>= maybe err pure
    SAML2.authReq authreqttl iss idpid
  VerdictFormatStore.store authreqttl reqid vformat
  pure form

checkMultiIngressDomain ::
  ( Member (Logger (Msg -> Msg)) r,
    Member (Error SparError) r
  ) =>
  SAML.Config ->
  Maybe ZHostValue ->
  IdP ->
  Sem r ()
checkMultiIngressDomain samlConfig mbHost idp = when (SAML.isMultiIngressConfig samlConfig) $ do
  let idpDomain = idp._idpExtraInfo._domain
  case (idpDomain, mbHost) of
    (Just expectedDomain, Just host)
      | host == expectedDomain -> pure ()
    _ -> do
      let idpIdTxt = idpIdToText idp._idpId
      Logger.debug $
        Log.msg ("Multi-ingress domain guard rejected IdP access" :: ByteString)
          . Log.field "idp" idpIdTxt
          . Log.field "idp_domain" (maybe "None" domainText idpDomain)
          . Log.field "request_host" (maybe "None" domainText mbHost)
      throwSparSem (SparIdPNotFound idpIdTxt)

idpIdToText :: SAML.IdPId -> T.Text
idpIdToText = T.pack . UUID.toString . SAML.fromIdPId

redirectURLMaxLength :: Int
redirectURLMaxLength = 140

validateAuthreqParams :: (Member (Error SparError) r) => Maybe URI.URI -> Maybe URI.URI -> Maybe CookieLabel -> Sem r VerdictFormat
validateAuthreqParams msucc merr mlabel = case (msucc, merr) of
  (Nothing, Nothing) -> pure $ VerdictFormatWeb mlabel
  (Just ok, Just err) -> do
    validateRedirectURL `mapM_` [ok, err]
    pure $ VerdictFormatMobile ok err mlabel
  _ -> throwSparSem $ SparBadInitiateLoginQueryParams "need-both-redirect-urls"

validateRedirectURL :: (Member (Error SparError) r) => URI.URI -> Sem r ()
validateRedirectURL uri = do
  unless ((SBS.take 4 . URI.schemeBS . URI.uriScheme $ uri) == "wire") $ do
    throwSparSem $ SparBadInitiateLoginQueryParams "invalid-schema"
  unless (SBS.length (URI.serializeURIRef' uri) <= redirectURLMaxLength) $ do
    throwSparSem $ SparBadInitiateLoginQueryParams "url-too-long"

authresp ::
  forall r.
  ( Member Random r,
    Member (Logger String) r,
    Member (Logger (Msg -> Msg)) r,
    Member (Input Opts) r,
    Member GalleyAPIAccess r,
    Member BrigAPIAccess r,
    Member AssIDStore r,
    Member VerdictFormatStore r,
    Member AReqIDStore r,
    Member ScimTokenStore r,
    Member ScimExternalIdStore r,
    Member IdPConfigStore r,
    Member SAML2 r,
    Member SamlProtocolSettings r,
    Member (Error SparError) r,
    Member Reporter r,
    Member SAMLUserStore r
  ) =>
  Maybe TeamId ->
  SAML.AuthnResponseBody ->
  Maybe ZHostValue ->
  Sem r Void
authresp mbtid arbody mbHost = do
  let err :: Sem r any
      err = throwSparSem (SparSPNotFound "")

  let iss :: Sem r SAML.Issuer
      iss = SamlProtocolSettings.spIssuer mbtid mbHost >>= maybe err pure

      rsp :: Sem r URI.URI
      rsp = SamlProtocolSettings.responseURI mbtid mbHost >>= maybe err pure

  logErrors $ SAML2.authResp mbtid iss rsp go arbody
  where
    go :: NE.NonEmpty SAML.Assertion -> IdP -> SAML.AccessVerdict -> Sem r Void
    go assertions idp verdict = do
      assertCertsAllowlisted (idp ^. SAML.idpMetadata)
      case verdict of
        SAML.AccessDenied (shouldRedirectToInit -> True) ->
          redirectToInit idp
        _ -> do
          SAML.ResponseVerdict result <- verdictHandler assertions verdict idp mbHost
          throw @SparError $ SAML.CustomServant result

    -- Whenever at least one of the denied reasons is `DeniedNoInResponseTo`, try again.
    -- there may be other reasons that will make the redirect less likely to result in a
    -- positive authentication, but better be lenient wrt what the IdP sends us here, it is
    -- about to get thrown away anyway.
    shouldRedirectToInit :: [SAML.DeniedReason] -> Bool
    shouldRedirectToInit = any (\case SAML.DeniedNoInResponseTo -> True; _ -> False)

    redirectToInit :: IdP -> Sem r Void
    redirectToInit idp = do
      throw (SAML.CustomError (SparRequestMissingTryIdpInitiatedLogin initiateLoginEndPointText))
      where
        -- FUTUREWORK: success_url and error_url (used to distinguish between mobile and web)
        -- are missing in this flow.  maybe the mobile browser can start app.wire.com, and
        -- app.wire.com finds the app for us?  server-side solutions probably exist, but are
        -- likely to make everything more complicated, both now and in the long run.  see
        -- `APIAuthReq` route.
        success_url = Nothing
        error_url = Nothing
        cookie_label = Nothing

        initiateLoginEndPoint :: URI
        initiateLoginEndPoint =
          ( safeLink'
              linkURI
              (Proxy @SparAPI)
              (Proxy @("sso" :> "initiate-login" :> APIAuthReq))
          )
            success_url
            error_url
            cookie_label
            (idp ^. SAML.idpId)

        initiateLoginEndPointText :: T.Text
        initiateLoginEndPointText =
          T.pack ("/" <> uriPath initiateLoginEndPoint <> uriQuery initiateLoginEndPoint)

    logErrors :: Sem r Void -> Sem r Void
    logErrors action = catch @SparError action $ \case
      e@(SAML.CustomServant _) ->
        -- this is where the "you're ok, please come in" redirect response is coming from
        throw e
      e@(SAML.CustomError (SparRequestMissingTryIdpInitiatedLogin _)) -> do
        -- redirect to /sso/initiate-login
        throw e
      e -> do
        -- something went wrong, log and fail
        throw @SparError
          . SAML.CustomServant
          $ errorPage
            e
            (Multipart.inputs (SAML.authnResponseBodyRaw arbody))

ssoSettings :: (Member DefaultSsoCode r) => Sem r SsoSettings
ssoSettings =
  SsoSettings <$> DefaultSsoCode.get

getSsoCodeByEmail :: (Member IdPSubsystem r) => Maybe ZHostValue -> GetByEmailReq -> Sem r (Maybe SAML.IdPId)
getSsoCodeByEmail mbHost (GetByEmailReq emailAddr) =
  IdPSubsystem.getSsoCodeByEmail mbHost emailAddr

----------------------------------------------------------------------------
-- IdPConfigStore API

authHandler :: Env -> AuthHandler Request TeamId
authHandler ctx = mkAuthHandler $ \req -> (either throwError' pure =<<) $ runSparToHandler ctx $ runError $ do
  bs <- maybe (throwSparSem SparMissingZUsr) pure $ lookup "Z-User" (requestHeaders req)
  uid <- maybe (throwSparSem $ SparNoPermission "[internal error] Can't parse Z-User header") pure $ fromByteString bs
  BrigAPIAccess.checkAdminGetTeamId uid >>= either (\e -> throwSparSem $ SparNoPermission (Wai.message e)) pure
  where
    throwError' se = Spar.Error.sparToServerErrorWithLogging (sparCtxLogger ctx) se >>= throwError

authContext :: Env -> Servant.Context (AuthHandler Request TeamId ': '[])
authContext e = authHandler e :. EmptyContext

idpGet ::
  ( Member Random r,
    Member (Logger (Msg -> Msg)) r,
    Member GalleyAPIAccess r,
    Member BrigAPIAccess r,
    Member IdPConfigStore r,
    Member (Error SparError) r
  ) =>
  Maybe UserId ->
  SAML.IdPId ->
  Sem r IdP
idpGet zusr idpid = withDebugLog "idpGet" (Just . show . (^. SAML.idpId)) $ do
  idp <- IdPConfigStore.getConfig idpid
  _ <- authorizeIdP zusr idp
  pure idp

idpGetRaw ::
  ( Member GalleyAPIAccess r,
    Member BrigAPIAccess r,
    Member IdPConfigStore r,
    Member IdPRawMetadataStore r,
    Member (Error SparError) r
  ) =>
  Maybe UserId ->
  SAML.IdPId ->
  Sem r RawIdPMetadata
idpGetRaw zusr idpid = do
  idp <- IdPConfigStore.getConfig idpid
  _ <- authorizeIdP zusr idp
  IdPRawMetadataStore.get idpid >>= \case
    Just txt -> pure $ RawIdPMetadata txt
    Nothing -> throwSparSem $ SparIdPNotFound (idpIdToText idpid)

idpGetAll ::
  ( Member Random r,
    Member (Logger (Msg -> Msg)) r,
    Member GalleyAPIAccess r,
    Member BrigAPIAccess r,
    Member IdPConfigStore r,
    Member (Error SparError) r
  ) =>
  Maybe UserId ->
  Sem r IdPList
idpGetAll zusr = withDebugLog "idpGetAll" (const Nothing) $ do
  teamid <- Intra.getZUsrCheckPerm zusr ReadIdp
  idpGetAllByTeamId teamid

idpGetAllByTeamId ::
  ( Member Random r,
    Member (Logger (Msg -> Msg)) r,
    Member GalleyAPIAccess r,
    Member BrigAPIAccess r,
    Member IdPConfigStore r,
    Member (Error SparError) r
  ) =>
  TeamId ->
  Sem r IdPList
idpGetAllByTeamId tid = do
  providers <- IdPConfigStore.getConfigsByTeam tid
  pure IdPList {..}

-- | Delete empty IdPs, or if @"purge=true"@ in the HTTP query, delete all users
-- *synchronously* on brig and spar, and the IdP once it's empty.
--
-- The @"purge"@ query parameter is as a quick work-around until we have something better.  It
-- may very well time out, but it processes the users under the 'IdP' in chunks of 2000, so no
-- matter what the team size, it shouldn't choke any servers, just the client (which is
-- probably curl running locally on one of the spar instances).
-- https://github.com/zinfra/backend-issues/issues/1314
idpDelete ::
  forall r.
  ( Member Random r,
    Member (Logger (Msg -> Msg)) r,
    Member GalleyAPIAccess r,
    Member BrigAPIAccess r,
    Member ScimTokenStore r,
    Member SAMLUserStore r,
    Member IdPConfigStore r,
    Member IdPRawMetadataStore r,
    Member (Error SparError) r
  ) =>
  SAML.Config ->
  Maybe UserId ->
  SAML.IdPId ->
  Maybe Bool ->
  Sem r NoContent
idpDelete samlConfig mbzusr idpid (fromMaybe False -> purge) = withDebugLog "idpDelete" (const Nothing) $ do
  idp <- IdPConfigStore.getConfig idpid
  (zusr, teamId) <- authorizeIdP mbzusr idp
  let issuer = idp ^. SAML.idpMetadata . SAML.edIssuer
  whenM (idpDoesAuthSelf idp zusr) $ throwSparSem SparIdPCannotDeleteOwnIdp
  SAMLUserStore.getAllByIssuerPaginated issuer >>= assertEmptyOrPurge teamId
  updateOldIssuers idp
  updateReplacingIdP idp
  -- Delete tokens associated with given IdP (we rely on the fact that
  -- each IdP has exactly one team so we can look up all tokens
  -- associated with the team and then filter them)
  tokens <- ScimTokenStore.lookupByTeam teamId
  for_ tokens $ \ScimTokenInfo {..} ->
    when (stiIdP == Just idpid) $ ScimTokenStore.delete teamId stiId
  -- Delete IdP config
  do
    IdPConfigStore.deleteConfig idp
    IdPRawMetadataStore.delete idpid
    when (SAML.isMultiIngressConfig samlConfig) $
      BrigAPIAccess.sendSAMLIdPChangedEmail $
        IdPDeleted zusr idp
  logIdPAction
    "IdP deleted"
    idp
    mbzusr
    id
  pure NoContent
  where
    assertEmptyOrPurge :: TeamId -> Cas.Page (SAML.UserRef, UserId) -> Sem r ()
    assertEmptyOrPurge teamId page = do
      forM_ (Cas.result page) $ \(uref, uid) -> do
        mAccount <- BrigAPIAccess.getAccount NoPendingInvitations uid
        let mUserTeam = userTeam =<< mAccount
        when (mUserTeam == Just teamId) $ do
          if purge
            then do
              SAMLUserStore.delete uid uref
              void $ BrigAPIAccess.deleteUser uid
            else do
              throwSparSem SparIdPHasBoundUsers
      when (Cas.hasMore page) $
        SAMLUserStore.nextPage page
          >>= assertEmptyOrPurge teamId

    updateOldIssuers :: IdP -> Sem r ()
    updateOldIssuers _ = pure ()
    -- we *could* update @idp ^. SAML.idpExtraInfo . wiReplacedBy@ to not keep the idp about
    -- to be deleted in its old issuers list, but it's tricky to avoid race conditions, and
    -- there is little to be gained here: we only use old issuers to find users that have not
    -- been migrated yet, and if an old user points to a deleted idp, it just means that we
    -- won't find any users to migrate.  still, doesn't hurt much to look either.  so we
    -- leave old issuers dangling for now.

    updateReplacingIdP :: IdP -> Sem r ()
    updateReplacingIdP idp = forM_ (idp ^. SAML.idpExtraInfo . oldIssuers) $ \oldIssuer -> do
      iid <-
        view SAML.idpId <$> case fromMaybe defWireIdPAPIVersion $ idp ^. SAML.idpExtraInfo . apiVersion of
          WireIdPAPIV1 -> IdPConfigStore.getIdPByIssuerV1 oldIssuer
          WireIdPAPIV2 -> IdPConfigStore.getIdPByIssuerV2 oldIssuer (idp ^. SAML.idpExtraInfo . team)
      IdPConfigStore.clearReplacedBy $ Replaced iid

    idpDoesAuthSelf :: IdP -> UserId -> Sem r Bool
    idpDoesAuthSelf idp uid = do
      let idpIssuer = idp ^. SAML.idpMetadata . SAML.edIssuer
      mUserIssuer <- (>>= userIssuer) <$> BrigAPIAccess.getAccount NoPendingInvitations uid
      pure $ mUserIssuer == Just idpIssuer

-- | We generate a new UUID for each IdP used as IdPConfig's path, thereby ensuring uniqueness.
--
-- The human-readable name argument `mHandle` is guaranteed to be unique for historical
-- reasons.  At some point, we wanted to use it to refer to IdPs in the backend API.  The new
-- idea is to use the IdP ID instead, and use names only for UI purposes (`ES branch` is
-- easier to remember than `6a410704-b147-11ef-9cb0-33193c475ba4`).
--
-- Related docs:
-- (on associating scim peers with idps) https://docs.wire.com/understand/single-sign-on/understand/main.html#associating-scim-tokens-with-saml-idps-for-authentication
-- (internal) https://wearezeta.atlassian.net/wiki/spaces/PAD/pages/1107001440/2024-03-27+scim+user+provisioning+and+saml2+sso+associating+scim+peers+and+saml2+idps
idpCreate ::
  ( Member Random r,
    Member (Logger (Msg -> Msg)) r,
    Member (Input Opts) r,
    Member GalleyAPIAccess r,
    Member BrigAPIAccess r,
    Member ScimTokenStore r,
    Member IdPConfigStore r,
    Member IdPRawMetadataStore r,
    Member (Error SparError) r
  ) =>
  SAML.Config ->
  TeamId ->
  Maybe UserId ->
  Maybe ZHostValue ->
  IdPMetadataInfo ->
  Maybe SAML.IdPId ->
  Maybe WireIdPAPIVersion ->
  Maybe (Range 1 32 Text) ->
  Sem r IdP
idpCreate samlConfig tid zUser uncheckedMbHost (IdPMetadataValue rawIdpMetadata idpmeta) mReplaces (fromMaybe defWireIdPAPIVersion -> apiversion) mHandle = withDebugLog "idpCreateXML" (Just . show . (^. SAML.idpId)) $ do
  let mbHost = filterMultiIngressZHost (samlConfig._cfgDomainConfigs) uncheckedMbHost
  Intra.assertSSOEnabled tid
  guardMultiIngressDuplicateDomain tid mbHost
  assertCertsAllowlisted idpmeta
  idp <-
    maybe (IdPConfigStore.newHandle tid) (pure . IdPHandle . fromRange) mHandle
      >>= validateNewIdP apiversion idpmeta tid mReplaces mbHost
  IdPRawMetadataStore.store (idp ^. SAML.idpId) rawIdpMetadata
  IdPConfigStore.insertConfig idp
  forM_ mReplaces $ \replaces ->
    IdPConfigStore.setReplacedBy (Replaced replaces) (Replacing (idp ^. SAML.idpId))
  when (SAML.isMultiIngressConfig samlConfig) $
    BrigAPIAccess.sendSAMLIdPChangedEmail $
      IdPCreated zUser idp
  logIdPAction
    "IdP created"
    idp
    zUser
    (Log.field "replaces" (maybe "None" (UUID.toString . SAML.fromIdPId) mReplaces))
  pure idp
  where
    -- Ensure that the domain is not in use by an existing IDP
    guardMultiIngressDuplicateDomain ::
      ( Member (Error SparError) r,
        Member IdPConfigStore r
      ) =>
      TeamId ->
      Maybe ZHostValue ->
      Sem r ()
    guardMultiIngressDuplicateDomain _teamId Nothing = pure ()
    guardMultiIngressDuplicateDomain teamId (Just zHost) = do
      idps <- IdPConfigStore.getConfigsByTeam teamId
      let domains = idps ^.. traverse . SAML.idpExtraInfo . domain . _Just
      when (zHost `elem` domains) $
        throwSparSem SparIdPDomainInUse

logIdPAction :: (Member (Logger (Msg -> Msg)) r) => String -> IdP -> Maybe UserId -> (Msg -> Msg) -> Sem r ()
logIdPAction msg idp zUser additionalFields =
  Logger.info $
    Log.msg (msg)
      . Log.field "team" (idp ^. SAML.idpExtraInfo . team . to idToText)
      . Log.field "idpId" (idp ^. SAML.idpId . to SAML.fromIdPId . to UUID.toString)
      . Log.field "issuer" (idp ^. SAML.idpMetadata . SAML.edIssuer . SAML.fromIssuer . to URI.serializeURIRef')
      . Log.field "domain" (idp ^. SAML.idpExtraInfo . domain . to (maybe "None" domainText))
      . Log.field "user" (maybe "None" idToText zUser)
      . Log.field "certificates" (idp ^. SAML.idpMetadata . SAML.edCertAuthnResponse . to (intercalate ";; " . map certToString . toList))
      . Log.field "idp-endpoint" (idp ^. SAML.idpMetadata . SAML.edRequestURI . to URI.serializeURIRef')
      . additionalFields

-- | Only return a ZHost when multi-ingress is configured and the host value is a configured domain
filterMultiIngressZHost :: Either SAML.MultiIngressDomainConfig (Map Domain SAML.MultiIngressDomainConfig) -> Maybe ZHostValue -> Maybe ZHostValue
filterMultiIngressZHost (Right domainMap) (Just zHost) | zHost `Map.member` domainMap = Just zHost
filterMultiIngressZHost _ _ = Nothing

idpCreateV7 ::
  ( Member Random r,
    Member (Logger (Msg -> Msg)) r,
    Member (Input Opts) r,
    Member GalleyAPIAccess r,
    Member BrigAPIAccess r,
    Member ScimTokenStore r,
    Member IdPConfigStore r,
    Member IdPRawMetadataStore r,
    Member (Error SparError) r
  ) =>
  SAML.Config ->
  TeamId ->
  Maybe UserId ->
  IdPMetadataInfo ->
  Maybe SAML.IdPId ->
  Maybe WireIdPAPIVersion ->
  Maybe (Range 1 32 Text) ->
  Sem r IdP
idpCreateV7 samlConfig tid zUser idpmeta mReplaces mApiversion mHandle = do
  assertNoScimOrNoIdP
  idpCreate samlConfig tid zUser Nothing idpmeta mReplaces mApiversion mHandle
  where
    -- In teams with a scim access token, only one IdP is allowed.  The reason is that scim user
    -- data contains no information about the idp issuer, only the user name, so no valid saml
    -- credentials can be created. Only relevant for api versions 0..6.
    assertNoScimOrNoIdP ::
      ( Member ScimTokenStore r,
        Member (Error SparError) r,
        Member IdPConfigStore r
      ) =>
      Sem r ()
    assertNoScimOrNoIdP = do
      numTokens <- length <$> ScimTokenStore.lookupByTeam tid
      numIdps <- length <$> IdPConfigStore.getConfigsByTeam tid
      when (numTokens > 0 && numIdps > 0) $
        throwSparSem $
          SparProvisioningMoreThanOneIdP ScimTokenAndSecondIdpForbidden

-- | Check that issuer is not used anywhere in the system ('WireIdPAPIV1', here it is a
-- database key for finding IdPs), or anywhere in this team ('WireIdPAPIV2'), that request
-- URI is https, that the replacement IdPId, if present, points to our team, and possibly
-- other things (see source code for the definitive answer).
--
-- About the @mReplaces@ argument: the information whether the idp is replacing an old one is
-- in query parameter, because the body can be both XML and JSON.  The JSON body could carry
-- the replaced idp id fine, but the XML is defined in the SAML standard and cannot be
-- changed.  NB: if you want to replace an IdP by one with the same issuer, you probably
-- want to use `PUT` instead of `POST`.
--
-- FUTUREWORK: find out if anybody uses the XML body type and drop it if not.
--
-- FUTUREWORK: using the same issuer for two teams even in `WireIdPAPIV1` may be possible, but
-- only if we stop supporting implicit user creating via SAML.  If unknown users present IdP
-- credentials, the issuer is our only way of finding the team in which the user must be
-- created.
--
-- FUTUREWORK: move this to the saml2-web-sso package.  (same probably goes for get, create,
-- update, delete of idps.)
validateNewIdP ::
  forall m r.
  (HasCallStack, m ~ Sem r) =>
  ( Member Random r,
    Member (Logger (Msg -> Msg)) r,
    Member IdPConfigStore r,
    Member (Error SparError) r
  ) =>
  WireIdPAPIVersion ->
  SAML.IdPMetadata ->
  TeamId ->
  Maybe SAML.IdPId ->
  Maybe ZHostValue ->
  IdPHandle ->
  m IdP
validateNewIdP apiversion _idpMetadata teamId mReplaces idpDomain idHandle = withDebugLog "validateNewIdP" (Just . show . (^. SAML.idpId)) $ do
  _idpId <- SAML.IdPId <$> Random.uuid
  oldIssuersList :: [SAML.Issuer] <- case mReplaces of
    Nothing -> pure []
    Just replaces -> do
      idp <- IdPConfigStore.getConfig replaces
      pure $ (idp ^. SAML.idpMetadata . SAML.edIssuer) : (idp ^. SAML.idpExtraInfo . oldIssuers)
  let requri = _idpMetadata ^. SAML.edRequestURI
      _idpExtraInfo = WireIdP teamId (Just apiversion) oldIssuersList Nothing idHandle idpDomain
  enforceHttps requri
  mbIdp <- case apiversion of
    WireIdPAPIV1 -> IdPConfigStore.getIdPByIssuerV1Maybe (_idpMetadata ^. SAML.edIssuer)
    WireIdPAPIV2 -> IdPConfigStore.getIdPByIssuerV2Maybe (_idpMetadata ^. SAML.edIssuer) teamId
  Logger.log Logger.Debug . Log.msg $ show (apiversion, _idpMetadata, teamId, mReplaces)
  Logger.log Logger.Debug . Log.msg $ show (_idpId, oldIssuersList, mbIdp)

  let failWithIdPClash :: m ()
      failWithIdPClash = throwSparSem . SparNewIdPAlreadyInUse $ case apiversion of
        WireIdPAPIV1 ->
          "you can't create an IdP with api_version v1 if the issuer is already in use on the wire instance."
        WireIdPAPIV2 ->
          -- idp was found by lookup with teamid, so it's in the same team.
          "you can't create an IdP with api_version v1 if the issuer is already in use in your team."

  unless (isNothing mbIdp) failWithIdPClash

  pure SAML.IdPConfig {..}

-- | FUTUREWORK: 'idpUpdateXML' is only factored out of this function for symmetry with
-- 'idpCreate', which is not a good reason.  make this one function and pass around
-- 'IdPMetadataInfo' directly where convenient.
idpUpdate ::
  ( Member Random r,
    Member (Logger (Msg -> Msg)) r,
    Member (Input Opts) r,
    Member GalleyAPIAccess r,
    Member BrigAPIAccess r,
    Member IdPConfigStore r,
    Member IdPRawMetadataStore r,
    Member (Error SparError) r
  ) =>
  SAML.Config ->
  Maybe UserId ->
  Maybe ZHostValue ->
  IdPMetadataInfo ->
  SAML.IdPId ->
  Maybe (Range 1 32 Text) ->
  Sem r IdP
idpUpdate samlConfig zusr uncheckedMbHost (IdPMetadataValue raw xml) =
  let mbHost = filterMultiIngressZHost (samlConfig._cfgDomainConfigs) uncheckedMbHost
   in idpUpdateXML samlConfig zusr mbHost raw xml

idpUpdateXML ::
  ( Member Random r,
    Member (Logger (Msg -> Msg)) r,
    Member (Input Opts) r,
    Member GalleyAPIAccess r,
    Member BrigAPIAccess r,
    Member IdPConfigStore r,
    Member IdPRawMetadataStore r,
    Member (Error SparError) r
  ) =>
  SAML.Config ->
  Maybe UserId ->
  Maybe ZHostValue ->
  Text ->
  SAML.IdPMetadata ->
  SAML.IdPId ->
  Maybe (Range 1 32 Text) ->
  Sem r IdP
idpUpdateXML samlConfig mbZUsr mDomain raw idpmeta idpid mHandle = withDebugLog "idpUpdateXML" (Just . show . (^. SAML.idpId)) $ do
  (zUsr, teamid, idp, previousIdP) <- validateIdPUpdate mbZUsr idpmeta idpid
  Intra.assertSSOEnabled teamid
  assertCertsAllowlisted idpmeta
  guardMultiIngressDuplicateDomain teamid mDomain idpid
  IdPRawMetadataStore.store (idp ^. SAML.idpId) raw
  let idp' :: IdP = case mHandle of
        Just idpHandle -> idp & (SAML.idpExtraInfo . handle) .~ IdPHandle (fromRange idpHandle)
        Nothing -> idp
      idp'' :: IdP = idp' & (SAML.idpExtraInfo . domain) .~ mDomain
  -- (if raw metadata is stored and then spar goes out, raw metadata won't match the
  -- structured idp config.  since this will lead to a 5xx response, the client is expected to
  -- try again, which would clean up cassandra state.)
  IdPConfigStore.insertConfig idp''
  -- if the IdP issuer is updated, the old issuer must be removed explicitly.
  -- if this step is ommitted (due to a crash) resending the update request should fix the inconsistent state.
  let mbteamid = case fromMaybe defWireIdPAPIVersion $ idp'' ^. SAML.idpExtraInfo . apiVersion of
        WireIdPAPIV1 -> Nothing
        WireIdPAPIV2 -> Just teamid
  forM_ (idp'' ^. SAML.idpExtraInfo . oldIssuers) (flip IdPConfigStore.deleteIssuer mbteamid)
  when (SAML.isMultiIngressConfig samlConfig) $
    BrigAPIAccess.sendSAMLIdPChangedEmail $
      IdPUpdated zUsr previousIdP idp''
  logIdPUpdate zUsr idp'' previousIdP
  pure idp''
  where
    -- Ensure that the domain is not in use by an existing IDP
    guardMultiIngressDuplicateDomain ::
      ( Member (Error SparError) r,
        Member IdPConfigStore r
      ) =>
      TeamId ->
      Maybe ZHostValue ->
      SAML.IdPId ->
      Sem r ()
    guardMultiIngressDuplicateDomain _teamId Nothing _ = pure ()
    guardMultiIngressDuplicateDomain teamId (Just zHost) idpId = do
      idps <- IdPConfigStore.getConfigsByTeam teamId
      let otherIdpsOnSameDomain =
            any
              (\idp -> (idp ^. SAML.idpExtraInfo . domain) == (Just zHost) && (idp ^. SAML.idpId) /= idpId)
              idps
      when otherIdpsOnSameDomain $
        throwSparSem SparIdPDomainInUse

    -- We cannot simply call `logIdPAction` here, because we need diffs for
    -- some values (old vs. new)
    logIdPUpdate :: (Member (Logger (Msg -> Msg)) r) => UserId -> IdP -> IdP -> Sem r ()
    logIdPUpdate zUsr idp previousIdP =
      let (removedCerts, newCerts) =
            compareNonEmpty
              (previousIdP ^. SAML.idpMetadata . SAML.edCertAuthnResponse)
              (idp ^. SAML.idpMetadata . SAML.edCertAuthnResponse)
       in Logger.info $
            Log.msg ("IdP updated" :: String)
              . Log.field "team" (idp ^. SAML.idpExtraInfo . team . to idToText)
              . Log.field "idpId" (idp ^. SAML.idpId . to SAML.fromIdPId . to UUID.toString)
              . logChangeableScalar
                "issuer"
                URI.serializeURIRef'
                (previousIdP ^. SAML.idpMetadata . SAML.edIssuer . SAML.fromIssuer)
                (idp ^. SAML.idpMetadata . SAML.edIssuer . SAML.fromIssuer)
              . logChangeableScalar
                "domain"
                (maybe "None" domainText)
                (previousIdP ^. SAML.idpExtraInfo . domain)
                (idp ^. SAML.idpExtraInfo . domain)
              . Log.field "user" (idToText zUsr)
              . logChangeableScalar
                "idp-endpoint"
                URI.serializeURIRef'
                (previousIdP ^. SAML.idpMetadata . SAML.edRequestURI)
                (idp ^. SAML.idpMetadata . SAML.edRequestURI)
              . logCertField "certificates" (idp ^. SAML.idpMetadata . SAML.edCertAuthnResponse . to toList)
              . logCertField "new-certificates" newCerts
              . logCertField "removed-certificates" removedCerts

    logChangeableScalar :: (Eq a, Log.ToBytes b) => ByteString -> (a -> b) -> a -> a -> Msg -> Msg
    logChangeableScalar baseFieldName toFieldVal old new
      | old /= new =
          Log.field ("old-" <> baseFieldName) (toFieldVal old)
            . Log.field ("new-" <> baseFieldName) (toFieldVal new)
    logChangeableScalar baseFieldName toFieldVal old _new =
      Log.field baseFieldName (toFieldVal old)

    logCertField :: ByteString -> [X509.SignedCertificate] -> Msg -> Msg
    logCertField fieldName certs
      | not (null certs) =
          Log.field fieldName ((intercalate ";; " . map certToString) certs)
    logCertField _ _ = id

    compareNonEmpty :: (Eq a) => NE.NonEmpty a -> NE.NonEmpty a -> ([a], [a])
    compareNonEmpty xs ys =
      let l = nub . toList $ xs
          r = nub . toList $ ys
          onlyL = l \\ r
          onlyR = r \\ l
       in (onlyL, onlyR)

-- | Check that: idp id is valid; calling user is admin in that idp's home team; team id in
-- new metainfo doesn't change; new issuer (if changed) is not in use anywhere else (except as
-- an earlier IdP under the same ID); request uri is https.  Keep track of old issuer in extra
-- info if issuer has changed.
validateIdPUpdate ::
  forall m r.
  (HasCallStack, m ~ Sem r) =>
  ( Member Random r,
    Member (Logger (Msg -> Msg)) r,
    Member GalleyAPIAccess r,
    Member BrigAPIAccess r,
    Member IdPConfigStore r,
    Member (Error SparError) r
  ) =>
  Maybe UserId ->
  SAML.IdPMetadata ->
  SAML.IdPId ->
  m (UserId, TeamId, IdP, IdP)
validateIdPUpdate mbZUsr _idpMetadata _idpId = withDebugLog "validateIdPUpdate" (Just . show . (_3 %~ (^. SAML.idpId))) $ do
  previousIdP <- IdPConfigStore.getConfig _idpId
  (zusr, teamId) <- authorizeIdP mbZUsr previousIdP
  unless (previousIdP ^. SAML.idpExtraInfo . team == teamId) $
    throw errUnknownIdP
  _idpExtraInfo <- do
    let previousIssuer = previousIdP ^. SAML.idpMetadata . SAML.edIssuer
        newIssuer = _idpMetadata ^. SAML.edIssuer
    if previousIssuer == newIssuer
      then do
        -- idempotency
        pure $ previousIdP ^. SAML.idpExtraInfo
      else do
        idpIssuerInUse <-
          ( case fromMaybe defWireIdPAPIVersion $ previousIdP ^. SAML.idpExtraInfo . apiVersion of
              WireIdPAPIV1 -> IdPConfigStore.getIdPByIssuerV1Maybe newIssuer
              WireIdPAPIV2 -> IdPConfigStore.getIdPByIssuerV2Maybe newIssuer teamId
          )
            <&> ( \case
                    Just idpFound -> idpFound ^. SAML.idpId /= _idpId
                    Nothing -> False
                )
        if idpIssuerInUse
          then throwSparSem SparIdPIssuerInUse
          else
            pure $
              previousIdP ^. SAML.idpExtraInfo
                & oldIssuers
                  %~ (filterNotNewIssuer newIssuer) . nub . (previousIssuer :)

  let requri = _idpMetadata ^. SAML.edRequestURI
  enforceHttps requri
  pure (zusr, teamId, SAML.IdPConfig {..}, previousIdP)
  where
    -- If the new issuer was previously used, it has to be removed from the list of old issuers,
    -- to prevent it from getting deleted in a later step
    filterNotNewIssuer :: SAML.Issuer -> [SAML.Issuer] -> [SAML.Issuer]
    filterNotNewIssuer newIssuer = filter (/= newIssuer)

    errUnknownIdP = SAML.UnknownIdP $ enc uri
      where
        enc =
          decodeUtf8With lenientDecode
            . toLazyByteString
            . URI.serializeURIRef
        uri = _idpMetadata ^. SAML.edIssuer . SAML.fromIssuer

withDebugLog :: (Member (Logger (Msg -> Msg)) r) => String -> (a -> Maybe String) -> Sem r a -> Sem r a
withDebugLog msg showval action = do
  Logger.log Logger.Debug . Log.msg $ "entering " ++ msg
  val <- action
  let mshowedval = showval val
  Logger.log Logger.Debug . Log.msg $ "leaving " ++ msg ++ mconcat [": " ++ fromJust mshowedval | isJust mshowedval]
  pure val

authorizeIdP ::
  ( HasCallStack,
    ( Member GalleyAPIAccess r,
      Member BrigAPIAccess r,
      Member (Error SparError) r
    )
  ) =>
  Maybe UserId ->
  IdP ->
  Sem r (UserId, TeamId)
authorizeIdP Nothing _ =
  throw
    ( SAML.CustomError $
        SparNoPermission (T.pack $ show CreateUpdateDeleteIdp)
    )
authorizeIdP (Just zusr) idp = do
  let teamid = idp ^. SAML.idpExtraInfo . team
  Intra.assertHasPermission teamid CreateUpdateDeleteIdp zusr
  pure (zusr, teamid)

enforceHttps :: (Member (Error SparError) r) => URI.URI -> Sem r ()
enforceHttps uri =
  unless ((uri ^. URI.uriSchemeL . URI.schemeBSL) == "https") $ do
    throwSparSem . SparNewIdPWantHttps . T.fromStrict . SAML.renderURI $ uri

----------------------------------------------------------------------------
-- Internal API

internalStatus :: Sem r NoContent
internalStatus = pure NoContent

-- | Cleanup handler that is called by Galley whenever a team is about to
-- get deleted.
internalDeleteTeam ::
  ( Member ScimTokenStore r,
    Member IdPConfigStore r,
    Member SAMLUserStore r
  ) =>
  TeamId ->
  Sem r NoContent
internalDeleteTeam teamId = do
  deleteTeam teamId
  pure NoContent

internalPutSsoSettings ::
  ( Member DefaultSsoCode r,
    Member (Error SparError) r,
    Member IdPConfigStore r
  ) =>
  SsoSettings ->
  Sem r NoContent
internalPutSsoSettings SsoSettings {defaultSsoCode = Nothing} = do
  DefaultSsoCode.delete
  pure NoContent
internalPutSsoSettings SsoSettings {defaultSsoCode = Just code} =
  -- this can throw a 404, which is not quite right,
  -- but it's an internal endpoint and the message clearly says
  -- "Could not find IdP".
  IdPConfigStore.getConfig code
    *> DefaultSsoCode.store code
      $> NoContent

internalGetScimUserInfo :: (Member ScimUserTimesStore r) => UserId -> Sem r ScimUserInfo
internalGetScimUserInfo uid = do
  t <- fmap fst <$> ScimUserTimesStore.read uid
  pure $ ScimUserInfo uid t
