{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeAbstractions #-}
{-# 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.MiniBackend
  ( -- * Mini backends
    MiniBackend (..),
    AllErrors,
    MiniBackendEffects,
    interpretFederationStack,
    runFederationStack,
    interpretNoFederationStack,
    interpretNoFederationStackState,
    runNoFederationStack,
    runAllErrorsUnsafe,
    runNoFederationStackUserSubsystemErrorEither,
    runErrorUnsafe,
    miniLocale,
    defaultAuthenticationSubsystemConfig,
    defaultZAuthSettings,
    userSubsystemErrorEitherUnsafe,

    -- * Mini events
    MiniEvent (..),

    -- * Quickcheck helpers
    NotPendingStoredUser (..),
    NotPendingEmptyIdentityStoredUser (..),
    PendingNotEmptyIdentityStoredUser (..),
    NotPendingSSOIdWithEmailStoredUser (..),
    PendingStoredUser (..),
    ActiveStoredUser (..),
  )
where

import Data.Default (Default (def))
import Data.Domain
import Data.Id
import Data.LanguageCodes (ISO639_1 (EN))
import Data.LegalHold (defUserLegalHoldStatus)
import Data.Map.Lazy qualified as LM
import Data.Map.Strict qualified as M
import Data.Proxy
import Data.Qualified
import Data.Tagged (Tagged)
import Data.Time
import Data.Type.Equality
import Data.Vector qualified as Vector
import Data.ZAuth.Creation
import Data.ZAuth.CryptoSign
import GHC.Generics
import Imports
import Polysemy
import Polysemy.Error
import Polysemy.Input
import Polysemy.Internal
import Polysemy.State
import Polysemy.TinyLog
import Servant.Client.Core hiding (ClientError)
import System.Logger qualified as Log
import Test.QuickCheck
import Type.Reflection
import Wire.API.Allowlists (AllowlistEmailDomains)
import Wire.API.Conversation.Config (ConversationSubsystemConfig (..))
import Wire.API.Error (ErrorS)
import Wire.API.Error.Galley (GalleyError (TeamMemberNotFound, TeamNotFound))
import Wire.API.Federation.API
import Wire.API.Federation.Component
import Wire.API.Federation.Error
import Wire.API.Password
import Wire.API.Team.Collaborator
import Wire.API.Team.Feature
import Wire.API.Team.Member hiding (userId)
import Wire.API.User as User hiding (DeleteUser)
import Wire.API.User.Activation (ActivationCode)
import Wire.API.User.IdentityProvider
import Wire.API.User.Password
import Wire.ActivationCodeStore
import Wire.AppStore
import Wire.AppSubsystem
import Wire.AppSubsystem.Interpreter
import Wire.AuthenticationSubsystem
import Wire.AuthenticationSubsystem.Config
import Wire.AuthenticationSubsystem.Cookie.Limit
import Wire.AuthenticationSubsystem.Interpreter
import Wire.BackendNotificationQueueAccess (BackendNotificationQueueAccess)
import Wire.BlockListStore
import Wire.BrigAPIAccess (BrigAPIAccess)
import Wire.ClientStore
import Wire.ClientSubsystem
import Wire.ClientSubsystem.Interpreter
import Wire.ConversationSubsystem (ConversationSubsystem)
import Wire.DeleteQueue
import Wire.DeleteQueue.InMemory
import Wire.DomainRegistrationStore qualified as DRS
import Wire.EmailSubsystem (EmailSubsystem)
import Wire.Events
import Wire.FederationAPIAccess
import Wire.FederationAPIAccess.Interpreter as FI
import Wire.FederationConfigStore
import Wire.GalleyAPIAccess
import Wire.HashPassword (HashPassword)
import Wire.IndexedUserStore
import Wire.InternalEvent hiding (DeleteUser)
import Wire.InvitationStore
import Wire.MlsKeyPackageSubsystem
import Wire.MockInterpreters
import Wire.NotificationSubsystem
import Wire.PasswordResetCodeStore
import Wire.PasswordStore
import Wire.RateLimit
import Wire.Sem.Concurrency
import Wire.Sem.Concurrency.Sequential
import Wire.Sem.Metrics
import Wire.Sem.Metrics.IO (ignoreMetrics)
import Wire.Sem.Now hiding (get)
import Wire.Sem.Random (Random)
import Wire.SessionStore (SessionStore)
import Wire.SparAPIAccess
import Wire.StoredUser
import Wire.TeamCollaboratorsStore
import Wire.TeamCollaboratorsSubsystem
import Wire.TeamCollaboratorsSubsystem.Interpreter
import Wire.TeamSubsystem (TeamSubsystem)
import Wire.TeamSubsystem.GalleyAPI
import Wire.UserClientIndexStore (UserClientIndexStore)
import Wire.UserGroupStore (UserGroupStore)
import Wire.UserKeyStore
import Wire.UserStore
import Wire.UserSubsystem
import Wire.UserSubsystem.Error
import Wire.UserSubsystem.Interpreter
import Wire.VerificationCodeStore
import Wire.VerificationCodeSubsystem
import Wire.VerificationCodeSubsystem.Interpreter

newtype PendingNotEmptyIdentityStoredUser = PendingNotEmptyIdentityStoredUser StoredUser
  deriving (Show, Eq)

instance Arbitrary PendingNotEmptyIdentityStoredUser where
  arbitrary = do
    user <- arbitrary `suchThat` \user -> isJust user.identity && user.userType /= Just UserTypeApp
    pure $ PendingNotEmptyIdentityStoredUser (user {status = Just PendingInvitation})

newtype NotPendingEmptyIdentityStoredUser = NotPendingEmptyIdentityStoredUser StoredUser
  deriving (Show, Eq)

instance Arbitrary NotPendingEmptyIdentityStoredUser where
  arbitrary = do
    user <- arbitrary `suchThat` \user -> isNothing user.identity && user.userType /= Just UserTypeApp
    notPendingStatus <- elements (Nothing : map Just [Active, Suspended, Ephemeral])
    pure $ NotPendingEmptyIdentityStoredUser (user {status = notPendingStatus})

newtype PendingStoredUser = PendingStoredUser StoredUser
  deriving (Show, Eq)

instance Arbitrary PendingStoredUser where
  arbitrary = do
    user <- arbitrary
    pure $ PendingStoredUser (user {status = Just PendingInvitation})

newtype NotPendingStoredUser = NotPendingStoredUser StoredUser
  deriving (Show, Eq)

instance Arbitrary NotPendingStoredUser where
  arbitrary = do
    user <- arbitrary `suchThat` \user -> isJust user.identity && user.userType /= Just UserTypeApp
    notPendingStatus <- elements (Nothing : map Just [Active, Suspended, Ephemeral])
    pure $ NotPendingStoredUser (user {status = notPendingStatus})

newtype NotPendingSSOIdWithEmailStoredUser = NotPendingSSOIdWithEmailStoredUser StoredUser
  deriving (Show, Eq)

instance Arbitrary NotPendingSSOIdWithEmailStoredUser where
  arbitrary = do
    user <- arbitrary `suchThat` isSsoIsNotApp
    notPendingStatus <- elements (Nothing : map Just [Active, Suspended, Ephemeral])
    e <- arbitrary
    pure $
      NotPendingSSOIdWithEmailStoredUser
        ( user
            { activated = True,
              status = notPendingStatus,
              email = Just e
            }
        )
    where
      isSsoIsNotApp user =
        fmap isUserSSOId user.ssoId == Just True
          && user.userType /= Just UserTypeApp

newtype ActiveStoredUser = ActiveStoredUser StoredUser
  deriving (Show, Eq)

instance Arbitrary ActiveStoredUser where
  arbitrary = do
    user <- arbitrary
    pure $
      ActiveStoredUser
        ( user
            { status = Just Active,
              activated = True,
              serviceId = Nothing
            }
        )

type AllErrors =
  [ Error UserSubsystemError,
    Error AppSubsystemError,
    Error FederationError,
    Error AuthenticationSubsystemError,
    Error VerificationCodeSubsystemError,
    Error RateLimitExceeded,
    Error TeamCollaboratorsError,
    Error ClientError
  ]

type MiniBackendEffects =
  AuthUserAppRecursiveEffects
    `Append` '[TeamCollaboratorsSubsystem]
    `Append` MiniBackendLowerEffects

type AuthUserAppRecursiveEffects = '[AuthenticationSubsystem, UserSubsystem, AppSubsystem, ClientSubsystem]

----------------------------------------------------------------------
-- lower effect interpreters (hierarchically)

data MiniBackendParams r = MiniBackendParams
  { maybeFederationAPIAccess ::
      InterpreterFor
        (FederationAPIAccess MiniFederationMonad)
        (Logger (Log.Msg -> Log.Msg) : Concurrency 'Unsafe : r),
    localBackend :: MiniBackend,
    teams :: Map TeamId [TeamMember],
    galleyConfigs :: AllTeamFeatures,
    usrCfg :: UserSubsystemConfig,
    appCfg :: AppSubsystemConfig,
    conversationCfg :: ConversationSubsystemConfig
  }

-- | `MiniBackendLowerEffects` is not a long, flat list, but a tree of effects.  This way we
-- can work on a subtree without having to debug the entire vast list.  Makes for much better
-- error messages.
--
-- FUTUREWORK: it'd be nice to have a steeper hierarchy of effects here, and maybe not
-- organize along effect types ("all `State`s"), but the domain ("everything about block
-- lists").
type MiniBackendLowerEffects =
  '[ ClientSubsystem,
     Input ConversationSubsystemConfig,
     BrigAPIAccess,
     UserClientIndexStore,
     BackendNotificationQueueAccess,
     ConversationSubsystem,
     TeamSubsystem,
     EmailSubsystem,
     NotificationSubsystem,
     VerificationCodeSubsystem,
     GalleyAPIAccess,
     SparAPIAccess,
     ClientStore,
     MlsKeyPackageSubsystem,
     InvitationStore,
     PasswordStore,
     ActivationCodeStore,
     BlockListStore,
     UserStore,
     AppStore,
     TeamCollaboratorsStore,
     UserKeyStore,
     IndexedUserStore,
     FederationConfigStore,
     DRS.DomainRegistrationStore,
     PasswordResetCodeStore,
     VerificationCodeStore,
     SessionStore,
     UserGroupStore,
     RateLimit,
     HashPassword,
     DeleteQueue,
     Events,
     CryptoSign,
     Random,
     Now,
     ErrorS 'TeamMemberNotFound,
     ErrorS 'TeamNotFound
   ]
    `Append` InputEffects
    `Append` '[ Metrics
              ]
    `Append` StateEffects
    `Append` '[ FederationAPIAccess MiniFederationMonad,
                TinyLog,
                Concurrency 'Unsafe
              ]

miniBackendLowerEffectsInterpreters ::
  forall r a.
  (Members AllErrors r) =>
  MiniBackendParams r ->
  Sem (MiniBackendLowerEffects `Append` r) a ->
  Sem r (MiniBackend, a)
miniBackendLowerEffectsInterpreters mb@(MiniBackendParams {..}) =
  sequentiallyPerformConcurrency
    . noopLogger
    . maybeFederationAPIAccess
    . stateEffectsInterpreters mb
    . ignoreMetrics
    . inputEffectsInterpreters usrCfg appCfg localBackend.teamIdps
    . fmap (either (error . show) Imports.id)
    . runError @(Tagged 'TeamNotFound ())
    . fmap (either (error . show) Imports.id)
    . runError @(Tagged 'TeamMemberNotFound ())
    . interpretNowConst (UTCTime (ModifiedJulianDay 0) 0)
    . runRandomPure
    . runCryptoSignUnsafe
    . miniEventInterpreter
    . inMemoryDeleteQueueInterpreter
    . staticHashPasswordInterpreter
    . noRateLimit
    . userGroupStoreTestInterpreter
    . runInMemorySessionStore
    . runInMemoryVerificationCodeStore
    . runInMemoryPasswordResetCodeStore
    . inMemoryDomainRegistrationStoreInterpreter
    . runFederationConfigStoreInMemory
    . inMemoryIndexedUserStoreInterpreter
    . inMemoryUserKeyStoreInterpreter
    . inMemoryTeamCollaboratorsStoreInterpreter
    . inMemoryAppStoreInterpreter
    . inMemoryUserStoreInterpreter
    . inMemoryBlockListStoreInterpreter
    . inMemoryActivationCodeStoreInterpreter
    . runInMemoryPasswordStoreInterpreter
    . inMemoryInvitationStoreInterpreter
    . mockMlsKeyPackageSubsystem
    . runInMemoryClientStoreInterpreter
    . miniSparAPIAccess
    . miniGalleyAPIAccess teams galleyConfigs
    . interpretVerificationCodeSubsystem
    . inMemoryNotificationSubsystemInterpreter
    . noopEmailSubsystemInterpreter
    . interpretTeamSubsystemToGalleyAPI
    . mockConversationSubsystem
    . mockBackendNotificationQueueAccess
    . mockUserClientIndexStore
    . mockBrigAPIAccess
    . runInputConst conversationCfg
    . runClientSubsystem undefined undefined
  where
    -- Mock BrigAPIAccess interpreter for tests
    mockBrigAPIAccess :: forall r'. InterpreterFor BrigAPIAccess r'
    mockBrigAPIAccess = interpret $ \case
      _ -> error "Unimplemented BrigAPIAccess operation in mock"
    -- Mock UserClientIndexStore interpreter for tests
    mockUserClientIndexStore :: forall r'. InterpreterFor UserClientIndexStore r'
    mockUserClientIndexStore = interpret $ \case
      _ -> error "Unimplemented UserClientIndexStore operation in mock"
    -- Mock BackendNotificationQueueAccess interpreter for tests
    mockBackendNotificationQueueAccess :: forall r'. InterpreterFor BackendNotificationQueueAccess r'
    mockBackendNotificationQueueAccess = interpret $ \case
      _ -> error "Unimplemented BackendNotificationQueueAccess operation in mock"
    -- Mock ConversationSubsystem interpreter for tests
    mockConversationSubsystem :: forall r'. InterpreterFor ConversationSubsystem r'
    mockConversationSubsystem = interpretH $ \case
      _ -> error "Unimplemented ConversationSubsystem operation in mock"
    mockMlsKeyPackageSubsystem :: forall r'. InterpreterFor MlsKeyPackageSubsystem r'
    mockMlsKeyPackageSubsystem = interpret $ \case
      HasMlsKeyPackages {} -> pure False
      HasMlsKeyPackagesBulk {} -> pure mempty
      _ -> error "Unimplemented MlsKeyPackageSubsystem operation in mock"

type StateEffects =
  '[ State [Push],
     State (Map (TeamId) [TeamCollaborator]),
     State (Map (TeamId, InvitationId) StoredInvitation),
     State (Map InvitationCode StoredInvitation),
     State (Map (TeamId, EmailAddress) [UserId]),
     State (Map EmailKey (Maybe UserId, ActivationCode)),
     State [EmailKey],
     State [StoredUser],
     State (Map UserId Password),
     State UserGroupInMemState,
     State [StoredApp],
     State UserIndex,
     State (Map EmailKey UserId),
     State [DRS.StoredDomainRegistration],
     State [InternalNotification],
     State MiniBackend,
     State [MiniEvent],
     State UTCTime
   ]

stateEffectsInterpreters :: forall r r' a. MiniBackendParams r' -> Sem (StateEffects `Append` r) a -> Sem r (MiniBackend, a)
stateEffectsInterpreters MiniBackendParams {..} =
  evalState defaultTime
    . evalState []
    . runState localBackend
    . evalState []
    . evalState []
    . liftUserKeyStoreState
    . liftIndexedUserStoreState
    . liftAppStoreState
    . liftUserGroupStoreState
    . liftUserPasswordState
    . liftUserStoreState
    . liftBlockListStoreState
    . liftActivationCodeStoreState
    . liftPendingScimUserStoreState
    . liftInvitationInfoStoreState
    . liftInvitationStoreState
    . liftTeamCollaboratorsStoreState
    . liftPushNotificationsState

type InputEffects =
  '[ Input UserSubsystemConfig,
     Input AppSubsystemConfig,
     Input (Maybe AllowlistEmailDomains),
     Input (Map TeamId IdPList),
     Input VerificationCodeThrottleTTL,
     Input AuthenticationSubsystemConfig,
     Input ClientSubsystemConfig,
     Input (Local ())
   ]

defaultZAuthSettings :: ZAuthSettings
defaultZAuthSettings =
  ZAuthSettings
    1
    (UserTokenTimeout (60 * 60 * 24 * 28)) -- 28 days
    (SessionTokenTimeout (60 * 60 * 24)) -- 1 day
    (AccessTokenTimeout 900) -- 15 minutes
    (ProviderTokenTimeout (60 * 60 * 24 * 7)) -- 7 days
    (LegalHoldUserTokenTimeout (60 * 60 * 24 * 56)) -- 56 days
    (LegalHoldAccessTokenTimeout (60 * 15)) -- 15 minutes

defaultZAuthEnv :: ZAuthEnv
defaultZAuthEnv =
  ZAuthEnv
    { private =
        SigningKey
          { keyIdx = 1,
            key = read "Z-x7AIRMxXYbY2BBan0dFUH0WR_hUqoNF_EJzQ7cSdBrLBirXOBCsdTEKibIJ1WGgeshXkGdYMWh7EMsJ_X9UA=="
          },
      publicKeys = Vector.singleton $ read "aywYq1zgQrHUxComyCdVhoHrIV5BnWDFoexDLCf1_VA=",
      settings = defaultZAuthSettings
    }

defaultAuthenticationSubsystemConfig :: AuthenticationSubsystemConfig
defaultAuthenticationSubsystemConfig =
  AuthenticationSubsystemConfig
    { zauthEnv = defaultZAuthEnv,
      allowlistEmailDomains = Nothing,
      local = defaultLocalDomain,
      userCookieRenewAge = 2,
      userCookieLimit = 5,
      userCookieThrottle = StdDevThrottle 5 3
    }

defaultLocalDomain :: Local ()
defaultLocalDomain = (toLocalUnsafe (Domain "localdomain") ())

defaultClientSubsystemConfig :: ClientSubsystemConfig
defaultClientSubsystemConfig =
  ClientSubsystemConfig
    { userMaxPermClients = 7,
      consumableNotificationsEnabled = False
    }

inputEffectsInterpreters ::
  forall r a.
  UserSubsystemConfig ->
  AppSubsystemConfig ->
  Map TeamId IdPList ->
  Sem (InputEffects `Append` r) a ->
  Sem r a
inputEffectsInterpreters usrCfg appCfg teamIdps =
  runInputConst defaultLocalDomain
    . runInputConst defaultClientSubsystemConfig
    . runInputConst defaultAuthenticationSubsystemConfig
    . runInputConst (VerificationCodeThrottleTTL 60)
    . runInputConst teamIdps
    . runInputConst Nothing
    . runInputConst appCfg
    . runInputConst usrCfg

----------------------------------------------------------------------

-- | a type representing the state of a single backend
data MiniBackend = MkMiniBackend
  { -- | this is morally the same as the users stored in the actual backend
    --   invariant: for each key, the user.id and the key are the same
    users :: [StoredUser],
    userPasswords :: Map UserId Password,
    apps :: [StoredApp],
    userIndex :: UserIndex,
    userKeys :: Map EmailKey UserId,
    passwordResetCodes :: Map PasswordResetKey (PRQueryData Identity),
    blockList :: [EmailKey],
    activationCodes :: Map EmailKey (Maybe UserId, ActivationCode),
    invitationInfos :: Map InvitationCode StoredInvitation,
    invitations :: Map (TeamId, InvitationId) StoredInvitation,
    pendingScimUsers :: Map (TeamId, EmailAddress) [UserId],
    teamIdps :: Map TeamId IdPList,
    teamCollaborators :: Map TeamId [TeamCollaborator],
    pushNotifications :: [Push],
    userGroups :: UserGroupInMemState
  }
  deriving stock (Show, Generic)

instance Default MiniBackend where
  def =
    MkMiniBackend
      { users = mempty,
        userPasswords = mempty,
        apps = mempty,
        userIndex = emptyIndex,
        userKeys = mempty,
        passwordResetCodes = mempty,
        blockList = mempty,
        activationCodes = mempty,
        invitationInfos = mempty,
        invitations = mempty,
        pendingScimUsers = mempty,
        teamIdps = mempty,
        teamCollaborators = mempty,
        pushNotifications = mempty,
        userGroups = mempty
      }

-- | represents an entire federated, stateful world of backends
newtype MiniFederation = MkMiniFederation
  { -- | represents the state of the backends, mapped from their domains
    backends :: Map Domain MiniBackend
  }

data MiniContext = MkMiniContext
  { -- | the domain that is receiving the request
    ownDomain :: Domain
  }

newtype MiniFederationMonad comp a = MkMiniFederationMonad
  {unMiniFederation :: Sem [Input MiniContext, State MiniFederation] a}
  deriving newtype (Functor, Applicative, Monad)

instance RunClient (MiniFederationMonad comp) where
  runRequestAcceptStatus _acceptableStatuses _req = error "MiniFederation does not support servant client"
  throwClientError _err = error "MiniFederation does not support servant client"

data SubsystemOperationList where
  TNil :: SubsystemOperationList
  (:::) :: (Typeable a) => (Component, Text, a) -> SubsystemOperationList -> SubsystemOperationList

infixr 5 :::

lookupSubsystemOperation ::
  (Typeable a) =>
  -- | The type to compare to
  (Component, Text, Proxy a) ->
  -- | what to return when none of the types match
  a ->
  -- | the types to try
  SubsystemOperationList ->
  a
lookupSubsystemOperation goal@(goalComp, goalRoute, Proxy @goalType) a = \case
  TNil -> a
  (comp, route, client) ::: xs -> case eqTypeRep (typeRep @goalType) (typeOf client) of
    Just HRefl | comp == goalComp && route == goalRoute -> client
    _ -> lookupSubsystemOperation goal a xs

instance FederationMonad MiniFederationMonad where
  fedClientWithProxy (Proxy @name) (Proxy @api) (_ :: Proxy (MiniFederationMonad comp)) =
    lookupSubsystemOperation
      (componentVal @comp, nameVal @name, Proxy @(Client (MiniFederationMonad comp) api))
      do
        error
          "The testsuite has evaluated a tuple of component, route and client that is\
          \ not covered by the MiniFederation implementation of FederationMonad"
      do
        (Brig, "get-users-by-ids", miniGetUsersByIds)
          ::: (Brig, "get-user-by-id", miniGetUserById)
          ::: TNil

miniLocale :: Locale
miniLocale =
  Locale
    { lLanguage = Language EN,
      lCountry = Nothing
    }

-- | runs a stateful backend, returns the state and puts it back into the
--   federated global state
runOnOwnBackend :: Sem '[Input Domain, State MiniBackend] a -> MiniFederationMonad comp a
runOnOwnBackend = MkMiniFederationMonad . runOnOwnBackend' . subsume_

-- | Runs action in the context of a single backend, without access to others.
runOnOwnBackend' ::
  (Member (Input MiniContext) r, Member (State MiniFederation) r) =>
  Sem (Input Domain ': State MiniBackend ': r) a ->
  Sem r a
runOnOwnBackend' act = do
  ownDomain <- inputs (.ownDomain)
  ownBackend <-
    fromMaybe (error "tried to lookup domain that is not part of the backends' state")
      <$> gets (M.lookup ownDomain . backends)
  (newBackend, res) <- runState ownBackend $ runInputConst ownDomain act
  modify (\minifed -> minifed {backends = M.insert ownDomain newBackend (minifed.backends)})
  pure res

miniGetAllProfiles ::
  (Member (Input Domain) r, Member (State MiniBackend) r) =>
  Sem r [UserProfile]
miniGetAllProfiles = do
  users <- gets (.users)
  dom <- input
  pure $
    map
      (\u -> mkUserProfileWithEmail Nothing (mkUserFromStored dom miniLocale u) Nothing defUserLegalHoldStatus)
      users

miniGetUsersByIds :: [UserId] -> MiniFederationMonad 'Brig [UserProfile]
miniGetUsersByIds userIds = runOnOwnBackend do
  usersById :: LM.Map UserId UserProfile <-
    M.fromList . map (\user -> (user.profileQualifiedId.qUnqualified, user)) <$> miniGetAllProfiles
  pure $ mapMaybe (flip M.lookup usersById) userIds

miniGetUserById :: UserId -> MiniFederationMonad 'Brig (Maybe UserProfile)
miniGetUserById uid =
  runOnOwnBackend $
    find (\u -> u.profileQualifiedId.qUnqualified == uid) <$> miniGetAllProfiles

runMiniFederation :: Domain -> Map Domain MiniBackend -> MiniFederationMonad c a -> a
runMiniFederation ownDomain backends =
  run
    . evalState MkMiniFederation {backends = backends}
    . runInputConst MkMiniContext {ownDomain = ownDomain}
    . unMiniFederation

runFederationStack ::
  (HasCallStack) =>
  MiniBackend ->
  Map Domain MiniBackend ->
  Map TeamId [TeamMember] ->
  UserSubsystemConfig ->
  Sem (MiniBackendEffects `Append` AllErrors) a ->
  a
runFederationStack localBackend fedBackends teamMember cfg =
  runAllErrorsUnsafe
    . interpretFederationStack
      localBackend
      fedBackends
      teamMember
      cfg

interpretFederationStack ::
  (HasCallStack, Members AllErrors r) =>
  -- | the local backend
  MiniBackend ->
  -- | the available backends
  Map Domain MiniBackend ->
  Map TeamId [TeamMember] ->
  UserSubsystemConfig ->
  Sem (MiniBackendEffects `Append` r) a ->
  Sem r a
interpretFederationStack localBackend remoteBackends teams cfg =
  snd <$$> interpretFederationStackState localBackend remoteBackends teams cfg

interpretFederationStackState ::
  (HasCallStack, Members AllErrors r) =>
  -- | the local backend
  MiniBackend ->
  -- | the available backends
  Map Domain MiniBackend ->
  Map TeamId [TeamMember] ->
  UserSubsystemConfig ->
  Sem (MiniBackendEffects `Append` r) a ->
  Sem r (MiniBackend, a)
interpretFederationStackState localBackend backends teams usrCfg =
  interpretMaybeFederationStackState
    MiniBackendParams
      { maybeFederationAPIAccess = (miniFederationAPIAccess backends),
        localBackend = localBackend,
        galleyConfigs = def,
        appCfg = def,
        conversationCfg =
          ConversationSubsystemConfig
            { listClientsUsingBrig = False,
              legalholdDefaults = def,
              mlsKeys = Nothing,
              maxConvSize = 10,
              federationProtocols = Nothing
            },
        ..
      }

runNoFederationStack ::
  MiniBackend ->
  Map TeamId [TeamMember] ->
  UserSubsystemConfig ->
  Sem (MiniBackendEffects `Append` AllErrors) a ->
  a
runNoFederationStack localBackend teams cfg =
  -- (A 'runNoFederationStackEither' variant of this that returns 'AllErrors' in an 'Either'
  -- would be nice, but is complicated by the fact that we not only have 'UserSubsystemErrors',
  -- but other errors as well.  Maybe just wait with this until we have a better idea how we
  -- want to do errors?)
  runAllErrorsUnsafe . interpretNoFederationStack localBackend teams def cfg

runNoFederationStackUserSubsystemErrorEither ::
  MiniBackend ->
  Map TeamId [TeamMember] ->
  UserSubsystemConfig ->
  Sem (MiniBackendEffects `Append` AllErrors) a ->
  Either UserSubsystemError a
runNoFederationStackUserSubsystemErrorEither localBackend teams cfg =
  run . userSubsystemErrorEitherUnsafe . interpretNoFederationStack localBackend teams def cfg

userSubsystemErrorEitherUnsafe :: Sem AllErrors a -> Sem '[] (Either UserSubsystemError a)
userSubsystemErrorEitherUnsafe =
  runErrorUnsafe
    . runErrorUnsafe
    . runErrorUnsafe
    . runErrorUnsafe
    . runErrorUnsafe
    . runErrorUnsafe
    . runErrorUnsafe
    . runError

interpretNoFederationStack ::
  (Members AllErrors r) =>
  MiniBackend ->
  Map TeamId [TeamMember] ->
  AllTeamFeatures ->
  UserSubsystemConfig ->
  Sem (MiniBackendEffects `Append` r) a ->
  Sem r a
interpretNoFederationStack localBackend teams galleyConfigs cfg =
  snd <$$> interpretNoFederationStackState localBackend teams galleyConfigs cfg

interpretNoFederationStackState ::
  (Members AllErrors r) =>
  MiniBackend ->
  Map TeamId [TeamMember] ->
  AllTeamFeatures ->
  UserSubsystemConfig ->
  Sem (MiniBackendEffects `Append` r) a ->
  Sem r (MiniBackend, a)
interpretNoFederationStackState localBackend teams galleyConfigs usrCfg =
  interpretMaybeFederationStackState
    MiniBackendParams
      { maybeFederationAPIAccess = emptyFederationAPIAcesss,
        localBackend = localBackend,
        galleyConfigs = galleyConfigs,
        appCfg = def,
        conversationCfg =
          ConversationSubsystemConfig
            { listClientsUsingBrig = False,
              legalholdDefaults = def,
              mlsKeys = Nothing,
              maxConvSize = 10,
              federationProtocols = Nothing
            },
        ..
      }

interpretMaybeFederationStackState ::
  (Members AllErrors r) =>
  MiniBackendParams r ->
  Sem (MiniBackendEffects `Append` r) a ->
  Sem r (MiniBackend, a)
interpretMaybeFederationStackState mb =
  miniBackendLowerEffectsInterpreters mb . interpretTeamCollaboratorsSubsystem . runRecursiveAuthUserApp

-- FUTUREWORK(fisx): it would be nice to have a definition of an
-- interpreter of all the subsystems combined, but since the
-- individual effect interpreters will have different needs for
-- lower-level effects, and since our effect stacks are generally
-- rather ad hoc, this is not a trivial task.  So for now we just
-- diplicate this function whenever we need it.
runRecursiveAuthUserApp ::
  (Members AllErrors r, Members (TeamCollaboratorsSubsystem ': MiniBackendLowerEffects) r) =>
  Sem (AuthenticationSubsystem ': UserSubsystem ': AppSubsystem ': ClientSubsystem ': r) a ->
  Sem r a
runRecursiveAuthUserApp = runClient . runApp . runUser . runAuth
  where
    runAuth :: forall r. (Members AllErrors r, Members (TeamCollaboratorsSubsystem ': MiniBackendLowerEffects) r) => InterpreterFor AuthenticationSubsystem r
    runAuth = interpretAuthenticationSubsystem runUser

    runUser :: forall r. (Members AllErrors r, Members (TeamCollaboratorsSubsystem ': MiniBackendLowerEffects) r) => InterpreterFor UserSubsystem r
    runUser = runUserSubsystem runAuth runApp runClient

    runApp :: forall r. (Members AllErrors r, Members (TeamCollaboratorsSubsystem ': MiniBackendLowerEffects) r) => InterpreterFor AppSubsystem r
    runApp = runAppSubsystem runUser runAuth

    runClient :: forall r. (Members AllErrors r, Members (TeamCollaboratorsSubsystem ': MiniBackendLowerEffects) r) => InterpreterFor ClientSubsystem r
    runClient = runClientSubsystem runAuth runUser

liftInvitationInfoStoreState :: (Member (State MiniBackend) r) => Sem (State (Map InvitationCode StoredInvitation) : r) a -> Sem r a
liftInvitationInfoStoreState = interpret \case
  Polysemy.State.Get -> gets (.invitationInfos)
  Put newAcs -> modify $ \b -> b {invitationInfos = newAcs}

liftInvitationStoreState :: (Member (State MiniBackend) r) => Sem (State (Map (TeamId, InvitationId) StoredInvitation) : r) a -> Sem r a
liftInvitationStoreState = interpret \case
  Polysemy.State.Get -> gets (.invitations)
  Put newInvs -> modify $ \b -> b {invitations = newInvs}

liftPendingScimUserStoreState :: (Member (State MiniBackend) r) => Sem (State (Map (TeamId, EmailAddress) [UserId]) : r) a -> Sem r a
liftPendingScimUserStoreState = interpret \case
  Polysemy.State.Get -> gets (.pendingScimUsers)
  Put newUsers -> modify $ \b -> b {pendingScimUsers = newUsers}

liftTeamCollaboratorsStoreState :: (Member (State MiniBackend) r) => Sem (State (Map TeamId [TeamCollaborator]) : r) a -> Sem r a
liftTeamCollaboratorsStoreState = interpret \case
  Polysemy.State.Get -> gets (.teamCollaborators)
  Put collaborators -> modify $ \b -> b {teamCollaborators = collaborators}

liftPushNotificationsState :: (Member (State MiniBackend) r) => Sem (State [Push] : r) a -> Sem r a
liftPushNotificationsState = interpret \case
  Polysemy.State.Get -> gets (.pushNotifications)
  Put pushes -> modify $ \b -> b {pushNotifications = pushes}

liftActivationCodeStoreState :: (Member (State MiniBackend) r) => Sem (State (Map EmailKey (Maybe UserId, ActivationCode)) : r) a -> Sem r a
liftActivationCodeStoreState = interpret \case
  Polysemy.State.Get -> gets (.activationCodes)
  Put newAcs -> modify $ \b -> b {activationCodes = newAcs}

liftBlockListStoreState :: (Member (State MiniBackend) r) => Sem (State [EmailKey] : r) a -> Sem r a
liftBlockListStoreState = interpret $ \case
  Polysemy.State.Get -> gets (.blockList)
  Put newBlockList -> modify $ \b -> b {blockList = newBlockList}

liftUserKeyStoreState :: (Member (State MiniBackend) r) => Sem (State (Map EmailKey UserId) : r) a -> Sem r a
liftUserKeyStoreState = interpret $ \case
  Polysemy.State.Get -> gets (.userKeys)
  Put newUserKeys -> modify $ \b -> b {userKeys = newUserKeys}

liftUserStoreState :: (Member (State MiniBackend) r) => Sem (State [StoredUser] : r) a -> Sem r a
liftUserStoreState = interpret $ \case
  Polysemy.State.Get -> gets (.users)
  Put newUsers -> modify $ \b -> (b :: MiniBackend) {users = newUsers}

liftUserPasswordState :: (Member (State MiniBackend) r) => Sem (State (Map UserId Password) : r) a -> Sem r a
liftUserPasswordState = interpret $ \case
  Polysemy.State.Get -> gets (.userPasswords)
  Put newPasswords -> modify $ \b -> (b :: MiniBackend) {userPasswords = newPasswords}

liftAppStoreState :: (Member (State MiniBackend) r) => Sem (State [StoredApp] : r) a -> Sem r a
liftAppStoreState = interpret $ \case
  Polysemy.State.Get -> gets (.apps)
  Put newApps -> modify $ \b -> (b :: MiniBackend) {apps = newApps}

liftUserGroupStoreState :: Sem (State UserGroupInMemState : State [StoredApp] : State UserIndex : State (Map EmailKey UserId) : State [DRS.StoredDomainRegistration] : State [InternalNotification] : State MiniBackend : State [MiniEvent] : r) a -> Sem (State [StoredApp] : State UserIndex : State (Map EmailKey UserId) : State [DRS.StoredDomainRegistration] : State [InternalNotification] : State MiniBackend : State [MiniEvent] : r) a
liftUserGroupStoreState = interpret $ \case
  Polysemy.State.Get -> Polysemy.State.gets @MiniBackend (.userGroups)
  Put newState -> modify $ \b -> (b :: MiniBackend) {userGroups = newState}

liftIndexedUserStoreState :: (Member (State MiniBackend) r) => Sem (State UserIndex : r) a -> Sem r a
liftIndexedUserStoreState = interpret $ \case
  Polysemy.State.Get -> gets (.userIndex)
  Put newUserIndex -> modify $ \b -> (b :: MiniBackend) {userIndex = newUserIndex}

runAllErrorsUnsafe :: forall a. (HasCallStack) => Sem AllErrors a -> a
runAllErrorsUnsafe = run . runErrorUnsafe . runErrorUnsafe . runErrorUnsafe . runErrorUnsafe . runErrorUnsafe . runErrorUnsafe . runErrorUnsafe . runErrorUnsafe

emptyFederationAPIAcesss :: InterpreterFor (FederationAPIAccess MiniFederationMonad) r
emptyFederationAPIAcesss = interpret $ \case
  _ -> error "uninterpreted effect: FederationAPIAccess"

miniFederationAPIAccess ::
  forall a r.
  (HasCallStack) =>
  Map Domain MiniBackend ->
  Sem (FederationAPIAccess MiniFederationMonad : r) a ->
  Sem r a
miniFederationAPIAccess online = do
  let runner :: FederatedActionRunner MiniFederationMonad r
      runner ownDomain rpc = pure . Right $ runMiniFederation ownDomain online rpc
  interpret \case
    RunFederatedEither remote rpc ->
      if isJust (M.lookup (qDomain $ tUntagged remote) online)
        then FI.runFederatedEither runner remote rpc
        else pure $ Left do FederationUnexpectedError "RunFederatedEither"
    RunFederatedConcurrentlyEither _remotes _rpc -> error "unimplemented: RunFederatedConcurrently"
    RunFederatedConcurrentlyBucketsEither _domain _rpc -> error "unimplemented: RunFederatedBucketed"
    IsFederationConfigured -> pure True
