-- 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 Brig.CanonicalInterpreter where

import Brig.AWS (amazonkaEnv, prekeyTable)
import Brig.App as App
import Brig.DeleteQueue.Interpreter as DQ
import Brig.Effects.ConnectionStore (ConnectionStore)
import Brig.Effects.ConnectionStore.Cassandra (connectionStoreToCassandra)
import Brig.IO.Intra (runEvents)
import Brig.Options (Settings (consumableNotifications), federationDomainConfigs, federationStrategy)
import Brig.Options qualified as Opt
import Brig.Template (InvitationUrlTemplates)
import Brig.User.Search.Index (IndexEnv (..))
import Cassandra qualified as Cas
import Control.Exception (ErrorCall)
import Control.Lens (to, (^.), _Just)
import Control.Monad.Catch (throwM)
import Data.Coerce (coerce)
import Data.Qualified (Local, toLocalUnsafe)
import Data.ZAuth.CryptoSign (CryptoSign, runCryptoSign)
import Hasql.Pool (UsageError)
import Hasql.Pool.Extended qualified as HasqlPoolExt
import Imports
import Network.Wai.Utilities.Error qualified as Wai
import Polysemy
import Polysemy.Async
import Polysemy.Conc
import Polysemy.Embed (runEmbedded)
import Polysemy.Error (Error, errorToIOFinal, mapError, runError)
import Polysemy.Input (Input, runInputConst)
import Polysemy.Internal.Kind
import Polysemy.Resource
import Polysemy.TinyLog (TinyLog)
import Wire.API.Error (ErrorS, errorToWai)
import Wire.API.Error.Galley
import Wire.API.Federation.Client qualified
import Wire.API.Federation.Error
import Wire.API.Team.Collaborator
import Wire.ActivationCodeStore (ActivationCodeStore)
import Wire.ActivationCodeStore.Cassandra (interpretActivationCodeStoreToCassandra)
import Wire.AppStore
import Wire.AppStore.Postgres
import Wire.AppSubsystem
import Wire.AppSubsystem.Interpreter
import Wire.AuthenticationSubsystem
import Wire.AuthenticationSubsystem.Config
import Wire.AuthenticationSubsystem.Interpreter
import Wire.BackendNotificationQueueAccess (BackendNotificationQueueAccess)
import Wire.BackendNotificationQueueAccess.RabbitMq (interpretBackendNotificationQueueAccess)
import Wire.BackendNotificationQueueAccess.RabbitMq qualified as BackendNotificationQueueAccess
import Wire.BackgroundJobsPublisher (BackgroundJobPublisher)
import Wire.BackgroundJobsPublisher.RabbitMQ (interpretBackgroundJobPublisherRabbitMQ)
import Wire.BlockListStore
import Wire.BlockListStore.Cassandra
import Wire.BudgetStore
import Wire.BudgetStore.Cassandra
import Wire.ClientStore (ClientStore)
import Wire.ClientStore.Cassandra
import Wire.ClientStore.DynamoDB (OptimisticLockEnv (..))
import Wire.ClientSubsystem
import Wire.ClientSubsystem.Error (clientErrorToHttpError)
import Wire.ClientSubsystem.Interpreter
import Wire.DeleteQueue
import Wire.DomainRegistrationStore
import Wire.DomainRegistrationStore.Cassandra
import Wire.DomainRegistrationStore.DualWrite
import Wire.DomainRegistrationStore.Postgres (interpretDomainRegistrationStoreToPostgres)
import Wire.DomainVerificationChallengeStore
import Wire.DomainVerificationChallengeStore.Cassandra
import Wire.DomainVerificationChallengeStore.DualWrite (interpretDomainVerificationChallengeStoreToCassandraAndPostgres)
import Wire.DomainVerificationChallengeStore.Postgres (interpretDomainVerificationChallengeStoreToPostgres)
import Wire.EmailSending
import Wire.EmailSending.SES
import Wire.EmailSending.SMTP
import Wire.EmailSubsystem
import Wire.EmailSubsystem.Interpreter
import Wire.EnterpriseLoginSubsystem
import Wire.EnterpriseLoginSubsystem.Error (EnterpriseLoginSubsystemError, enterpriseLoginSubsystemErrorToHttpError)
import Wire.EnterpriseLoginSubsystem.Interpreter
import Wire.EnterpriseLoginSubsystem.Null
import Wire.Error
import Wire.Events
import Wire.FederationAPIAccess qualified
import Wire.FederationAPIAccess.Interpreter (FederationAPIAccessConfig (..), interpretFederationAPIAccess)
import Wire.FederationConfigStore (FederationConfigStore)
import Wire.FederationConfigStore.Cassandra (interpretFederationDomainConfig, remotesMapFromCfgFile)
import Wire.GalleyAPIAccess (GalleyAPIAccess)
import Wire.GalleyAPIAccess.Rpc
import Wire.GundeckAPIAccess
import Wire.HashPassword
import Wire.HashPassword.Interpreter
import Wire.IndexedUserStore
import Wire.IndexedUserStore.ElasticSearch
import Wire.InvitationStore (InvitationStore)
import Wire.InvitationStore.Cassandra (interpretInvitationStoreToCassandra)
import Wire.JwtTools
import Wire.MigrationLock
import Wire.MlsKeyPackageStore (MlsKeyPackageStore)
import Wire.MlsKeyPackageStore.Cassandra (interpretMlsKeyPackageStoreToCassandra)
import Wire.MlsKeyPackageSubsystem (MlsKeyPackageSubsystem)
import Wire.MlsKeyPackageSubsystem.Interpreter (interpretMlsKeyPackageSubsystem)
import Wire.NotificationSubsystem
import Wire.NotificationSubsystem.Interpreter (defaultNotificationSubsystemConfig, runNotificationSubsystemGundeck)
import Wire.ParseException
import Wire.PasswordResetCodeStore (PasswordResetCodeStore)
import Wire.PasswordResetCodeStore.Cassandra (interpretClientToIO, passwordResetCodeStoreToCassandra)
import Wire.PasswordStore (PasswordStore)
import Wire.PasswordStore.Cassandra (interpretPasswordStore)
import Wire.PostgresMigrationOpts
import Wire.PropertyStore
import Wire.PropertyStore.Cassandra
import Wire.PropertySubsystem
import Wire.PropertySubsystem.Interpreter
import Wire.RateLimit
import Wire.RateLimit.Interpreter
import Wire.Rpc
import Wire.SAMLEmailSubsystem
import Wire.SAMLEmailSubsystem.Interpreter
import Wire.SFT (SFT, interpretSFT)
import Wire.Sem.Concurrency
import Wire.Sem.Concurrency.IO
import Wire.Sem.Delay
import Wire.Sem.Jwk
import Wire.Sem.Logger.TinyLog (loggerToTinyLogReqId)
import Wire.Sem.Metrics
import Wire.Sem.Metrics.IO (runMetricsToIO)
import Wire.Sem.Now (Now)
import Wire.Sem.Now.IO (nowToIOAction)
import Wire.Sem.Paging.Cassandra (InternalPaging)
import Wire.Sem.Random
import Wire.Sem.Random.IO
import Wire.SessionStore
import Wire.SessionStore.Cassandra (interpretSessionStoreCassandra)
import Wire.SparAPIAccess (SparAPIAccess)
import Wire.SparAPIAccess.Rpc
import Wire.TeamCollaboratorsStore
import Wire.TeamCollaboratorsStore.Postgres
import Wire.TeamCollaboratorsSubsystem
import Wire.TeamCollaboratorsSubsystem.Interpreter
import Wire.TeamInvitationSubsystem
import Wire.TeamInvitationSubsystem.Error
import Wire.TeamInvitationSubsystem.Interpreter
import Wire.TeamSubsystem
import Wire.TeamSubsystem.GalleyAPI
import Wire.UserGroupStore
import Wire.UserGroupStore.Postgres (interpretUserGroupStoreToPostgres)
import Wire.UserGroupSubsystem
import Wire.UserGroupSubsystem.Interpreter
import Wire.UserKeyStore
import Wire.UserKeyStore.Cassandra
import Wire.UserPendingActivationStore (UserPendingActivationStore)
import Wire.UserPendingActivationStore.Cassandra (userPendingActivationStoreToCassandra)
import Wire.UserStore
import Wire.UserStore.Cassandra
import Wire.UserStore.Postgres (interpretUserStorePostgres)
import Wire.UserSubsystem
import Wire.UserSubsystem.Error
import Wire.UserSubsystem.Interpreter
import Wire.VerificationCodeStore
import Wire.VerificationCodeStore.Cassandra
import Wire.VerificationCodeSubsystem
import Wire.VerificationCodeSubsystem.Interpreter

type BrigCanonicalEffects = NonRecursiveEffects1 `Append` RecursiveEffects `Append` NonRecursiveEffects2

type NonRecursiveEffects1 =
  '[ TeamInvitationSubsystem,
     EnterpriseLoginSubsystem,
     UserGroupSubsystem
   ]

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

type NonRecursiveEffects2 =
  '[ TeamCollaboratorsSubsystem
   ]
    `Append` BrigLowerLevelEffects

-- | These effects have interpreters which don't depend on each other
type BrigLowerLevelEffects =
  '[ SAMLEmailSubsystem,
     TeamSubsystem,
     TeamCollaboratorsStore,
     AppStore,
     EmailSubsystem,
     VerificationCodeSubsystem,
     PropertySubsystem,
     DeleteQueue,
     Wire.Events.Events,
     NotificationSubsystem,
     BackendNotificationQueueAccess,
     BackgroundJobPublisher,
     RateLimit,
     UserKeyStore,
     MlsKeyPackageSubsystem,
     MlsKeyPackageStore,
     UserStore,
     UserGroupStore,
     DomainRegistrationStore,
     DomainVerificationChallengeStore,
     Error AppSubsystemError,
     Error TeamCollaboratorsError,
     Error UsageError,
     Error EnterpriseLoginSubsystemError,
     Error MigrationLockError,
     Error UserSubsystemError,
     Error UserGroupSubsystemError,
     Error TeamInvitationSubsystemError,
     Error AuthenticationSubsystemError,
     Error Wire.API.Federation.Error.FederationError,
     Error VerificationCodeSubsystemError,
     Error PropertySubsystemError,
     Error RateLimitExceeded,
     ErrorS 'TeamMemberNotFound,
     ErrorS 'TeamNotFound,
     Error Wai.Error,
     Wire.FederationAPIAccess.FederationAPIAccess Wire.API.Federation.Client.FederatorClient,
     CryptoSign,
     HashPassword,
     ClientStore,
     IndexedUserStore,
     SessionStore,
     PasswordStore,
     VerificationCodeStore,
     ActivationCodeStore,
     InvitationStore,
     PropertyStore,
     SFT,
     ConnectionStore InternalPaging,
     Input Cas.ClientState,
     Input HasqlPoolExt.Pool,
     Input AppSubsystemConfig,
     Input UserSubsystemConfig,
     Input VerificationCodeThrottleTTL,
     Input (Local ()),
     Input (AuthenticationSubsystemConfig),
     Input InvitationUrlTemplates,
     Input ClientSubsystemConfig,
     GundeckAPIAccess,
     FederationConfigStore,
     Jwk,
     JwtTools,
     BlockListStore,
     BudgetStore,
     UserPendingActivationStore InternalPaging,
     Now,
     Delay,
     Random,
     PasswordResetCodeStore,
     GalleyAPIAccess,
     SparAPIAccess,
     EmailSending,
     Rpc,
     Metrics,
     Embed Cas.Client,
     Error ClientError,
     Error ParseException,
     Error ErrorCall,
     Error SomeException,
     Error HttpError,
     TinyLog,
     Embed HttpClientIO,
     Embed IO,
     Race,
     Async,
     Resource,
     Concurrency 'Unsafe,
     Final IO
   ]

-- These interpreters depend on each other, we use let recursion to solve that.
--
-- This terminates if and only if we do not create an action sequence at
-- runtime such that interpretation of actions results in a call cycle.
--
-- Cloned from "Wire.MiniBackend".
runRecursiveEffects ::
  (Members NonRecursiveEffects2 r) =>
  Sem (RecursiveEffects `Append` r) a ->
  Sem r a
runRecursiveEffects = runClient . runApp . runUser . runAuth
  where
    runAuth :: forall r. (Members NonRecursiveEffects2 r) => InterpreterFor AuthenticationSubsystem r
    runAuth = interpretAuthenticationSubsystem runUser

    runUser :: forall r. (Members NonRecursiveEffects2 r) => InterpreterFor UserSubsystem r
    runUser = runUserSubsystem runAuth runApp runClient

    runApp :: forall r. (Members NonRecursiveEffects2 r) => InterpreterFor AppSubsystem r
    runApp = runAppSubsystem runUser runAuth

    runClient :: forall r. (Members NonRecursiveEffects2 r) => InterpreterFor ClientSubsystem r
    runClient = runClientSubsystem runAuth runUser

runBrigToIO :: App.Env -> AppT BrigCanonicalEffects a -> IO a
runBrigToIO e (AppT ma) = do
  let blockedDomains =
        e
          ^. ( App.settingsLens
                 . Opt.customerExtensionsLens
                 . _Just
                 . to
                   ( coerce {- safely drop newtype wrapper -}
                       Opt.domainsBlockedForRegistration
                   )
             )
      userSubsystemConfig =
        UserSubsystemConfig
          { emailVisibilityConfig = e.settings.emailVisibility,
            defaultLocale = Opt.defaultUserLocale e.settings,
            searchSameTeamOnly = fromMaybe False e.settings.searchSameTeamOnly,
            maxTeamSize = e.settings.maxTeamSize,
            activationCodeTimeout = e.settings.activationTimeout,
            blockedDomains = blockedDomains
          }
      appSubsystemConfig = AppSubsystemConfig {defaultLocale = userSubsystemConfig.defaultLocale}
      teamInvitationSubsystemConfig =
        TeamInvitationSubsystemConfig
          { maxTeamSize = e.settings.maxTeamSize,
            teamInvitationTimeout = e.settings.teamInvitationTimeout,
            blockedDomains = blockedDomains
          }
      federationApiAccessConfig =
        FederationAPIAccessConfig
          { ownDomain = e.settings.federationDomain,
            federatorEndpoint = e.federator,
            http2Manager = e.http2Manager,
            requestId = e.requestId
          }
      propertySubsystemConfig =
        PropertySubsystemConfig
          { maxKeyLength = fromMaybe Opt.defMaxKeyLen e.settings.propertyMaxKeyLen,
            maxValueLength = fromMaybe Opt.defMaxValueLen e.settings.propertyMaxValueLen,
            maxProperties = 16
          }
      localUnit = toLocalUnsafe e.settings.federationDomain ()
      authenticationSubsystemConfig =
        AuthenticationSubsystemConfig
          { zauthEnv = e.zauthEnv,
            allowlistEmailDomains = e.settings.allowlistEmailDomains,
            local = localUnit,
            userCookieRenewAge = e.settings.userCookieRenewAge,
            userCookieLimit = e.settings.userCookieLimit,
            userCookieThrottle = e.settings.userCookieThrottle
          }
      mainESEnv = e.indexEnv ^. to idxElastic
      indexedUserStoreConfig =
        IndexedUserStoreConfig
          { conn =
              ESConn
                { env = mainESEnv,
                  indexName = e.indexEnv ^. to idxName
                },
            additionalConn =
              (e.indexEnv ^. to idxAdditionalName) <&> \additionalIndexName ->
                ESConn
                  { env = e.indexEnv ^. to idxAdditionalElastic . to (fromMaybe mainESEnv),
                    indexName = additionalIndexName
                  }
          }
      clientStoreCassandraEnv =
        ClientStoreCassandraEnv
          { prekeyLocking =
              maybe
                ( Right $
                    OptimisticLockEnv
                      { awsEnv = e.awsEnv ^. amazonkaEnv,
                        prekeyTable = e.awsEnv ^. Brig.AWS.prekeyTable
                      }
                )
                Left
                e.randomPrekeyLocalLock,
            casClient = e.casClient
          }
      clientSubsystemConfig =
        ClientSubsystemConfig
          { userMaxPermClients = fromMaybe Opt.defUserMaxPermClients e.settings.userMaxPermClients,
            consumableNotificationsEnabled = e.settings.consumableNotifications
          }
      backendNotificationQueueEnv =
        BackendNotificationQueueAccess.Env
          { channelMVar = e.rabbitmqChannel,
            logger = e.appLogger,
            local = localUnit,
            requestId = e.requestId
          }
      domainRegistrationStore = case e.postgresMigration.domainRegistration of
        CassandraStorage -> interpretDomainRegistrationStoreToCassandra e.casClient
        PostgresqlStorage -> interpretDomainRegistrationStoreToPostgres
        MigrationToPostgresql -> interpretDomainRegistrationStoreToCassandraAndPostgres e.casClient

      domainVerificationChallengeStore = case e.postgresMigration.domainRegistration of
        CassandraStorage -> interpretDomainVerificationChallengeStoreToCassandra e.settings.challengeTTL
        PostgresqlStorage -> interpretDomainVerificationChallengeStoreToPostgres e.settings.challengeTTL
        MigrationToPostgresql -> interpretDomainVerificationChallengeStoreToCassandraAndPostgres e.settings.challengeTTL

      userStoreInterpreter =
        case e.postgresMigration.user of
          CassandraStorage -> interpretUserStoreCassandra e.casClient
          PostgresqlStorage -> interpretUserStorePostgres
          MigrationToPostgresql -> error "Migration not implemented for user"

  ( either throwM pure
      <=< ( runFinal
              . unsafelyPerformConcurrency
              . resourceToIOFinal
              . asyncToIOFinal
              . interpretRace
              . embedToFinal
              . runEmbedded (runHttpClientIO e)
              . loggerToTinyLogReqId e.requestId e.appLogger
              . rethrowHttpErrorIO
              . runError @SomeException
              . mapError @ErrorCall SomeException
              . mapError @ParseException SomeException
              . mapError clientErrorToHttpError
              . interpretClientToIO e.casClient
              . runMetricsToIO
              . runRpcWithHttp e.httpManager e.requestId
              . emailSendingInterpreter e
              . interpretSparAPIAccessToRpc e.sparEndpoint
              . interpretGalleyAPIAccessToRpc e.disabledVersions e.galleyEndpoint
              . passwordResetCodeStoreToCassandra @Cas.Client
              . randomToIO
              . runDelay
              . nowToIOAction e.currentTime
              . userPendingActivationStoreToCassandra
              . budgetStoreToCassandra @Cas.Client
              . interpretBlockListStoreToCassandra e.casClient
              . interpretJwtTools
              . interpretJwk
              . interpretFederationDomainConfig e.casClient e.settings.federationStrategy (foldMap (remotesMapFromCfgFile . fmap (.federationDomainConfig)) e.settings.federationDomainConfigs)
              . runGundeckAPIAccess e.gundeckEndpoint
              . runInputConst clientSubsystemConfig
              . runInputConst (invitationUrlTemplates e)
              . runInputConst authenticationSubsystemConfig
              . runInputConst localUnit
              . runInputConst (fromIntegral $ Opt.twoFACodeGenerationDelaySecs e.settings)
              . runInputConst userSubsystemConfig
              . runInputConst appSubsystemConfig
              . runInputConst e.hasqlPool
              . runInputConst e.casClient
              . connectionStoreToCassandra
              . interpretSFT e.httpManager
              . interpretPropertyStoreCassandra e.casClient
              . interpretInvitationStoreToCassandra e.casClient
              . interpretActivationCodeStoreToCassandra e.casClient
              . interpretVerificationCodeStoreCassandra e.casClient
              . interpretPasswordStore e.casClient
              . interpretSessionStoreCassandra e.casClient
              . interpretIndexedUserStoreES indexedUserStoreConfig
              . interpretClientStoreCassandra clientStoreCassandraEnv
              . runHashPassword e.settings.passwordHashingOptions
              . runCryptoSign
              . interpretFederationAPIAccess federationApiAccessConfig
              . mapError StdError -- Wai.Error
              . mapError (const $ errorToWai @'TeamNotFound) -- ErrorS 'TeamNotFound
              . mapError (const $ errorToWai @'TeamMemberNotFound) -- ErrorS 'TeamMemberNotFound
              . mapError rateLimitExceededToHttpError
              . mapError propertySubsystemErrorToHttpError
              . mapError verificationCodeSubsystemErrorToHttpError
              . mapError (StdError . federationErrorToWai)
              . mapError authenticationSubsystemErrorToHttpError
              . mapError teamInvitationErrorToHttpError
              . mapError userGroupSubsystemErrorToHttpError
              . mapError userSubsystemErrorToHttpError
              . mapError migrationLockErrorToHttpError
              . mapError enterpriseLoginSubsystemErrorToHttpError
              . mapError postgresUsageErrorToHttpError
              . mapError teamCollaboratorsSubsystemErrorToHttpError
              . mapError appSubsystemErrorToHttpError
              . domainVerificationChallengeStore
              . domainRegistrationStore
              . interpretUserGroupStoreToPostgres
              . userStoreInterpreter
              . interpretMlsKeyPackageStoreToCassandra e.casClient
              . interpretMlsKeyPackageSubsystem e.settings.keyPackageMaximumLifetime e.keyPackageLocalLock
              . interpretUserKeyStoreCassandra e.casClient
              . interpretRateLimit e.rateLimitEnv
              . interpretBackgroundJobPublisherRabbitMQ e.requestId e.amqpJobsPublisherChannel
              . interpretBackendNotificationQueueAccess (Just backendNotificationQueueEnv)
              . runNotificationSubsystemGundeck (defaultNotificationSubsystemConfig e.requestId)
              . runEvents
              . runDeleteQueue e.internalEvents
              . interpretPropertySubsystem propertySubsystemConfig
              . interpretVerificationCodeSubsystem
              . emailSubsystemInterpreter e.userTemplates e.teamTemplates e.templateBrandingAsMap
              . interpretAppStoreToPostgres
              . interpretTeamCollaboratorsStoreToPostgres
              . interpretTeamSubsystemToGalleyAPI
              . samlEmailSubsystemInterpreter
              . interpretTeamCollaboratorsSubsystem
              . runRecursiveEffects
              . interpretUserGroupSubsystem
              . maybe
                runEnterpriseLoginSubsystemNoConfig
                runEnterpriseLoginSubsystemWithConfig
                (mkEnterpriseLoginSubsystemConfig e)
              . runTeamInvitationSubsystem teamInvitationSubsystemConfig
          )
    )
    $ runReaderT ma e

mkEnterpriseLoginSubsystemEmailConfig :: Env -> Maybe EnterpriseLoginSubsystemEmailConfig
mkEnterpriseLoginSubsystemEmailConfig env = do
  recipient <- env.settings.auditLogEmailRecipient
  let sender = env.emailSender
  pure
    EnterpriseLoginSubsystemEmailConfig
      { auditEmailSender = sender,
        auditEmailRecipient = recipient
      }

mkEnterpriseLoginSubsystemConfig :: Env -> Maybe EnterpriseLoginSubsystemConfig
mkEnterpriseLoginSubsystemConfig env = do
  endpoint <- env.wireServerEnterpriseEndpoint
  pure
    EnterpriseLoginSubsystemConfig
      { emailConfig = mkEnterpriseLoginSubsystemEmailConfig env,
        wireServerEnterpriseEndpoint = endpoint
      }

rethrowHttpErrorIO :: (Member (Final IO) r) => InterpreterFor (Error HttpError) r
rethrowHttpErrorIO act = do
  eithError <- errorToIOFinal act
  case eithError of
    Left err -> embedToFinal $ throwM $ err
    Right a -> pure a

emailSendingInterpreter :: (Member (Embed IO) r) => Env -> InterpreterFor EmailSending r
emailSendingInterpreter e = do
  case e.smtpEnv of
    Just smtp -> emailViaSMTPInterpreter e.appLogger smtp
    Nothing -> emailViaSESInterpreter (e.awsEnv ^. amazonkaEnv)
