{-# LANGUAGE UndecidableSuperClasses #-}
{-# OPTIONS_GHC -Wno-ambiguous-fields #-}
{-# OPTIONS_GHC -Wno-deprecations #-}

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

module Galley.API.Teams.Features
  ( setFeature,
    setFeatureInternal,
    patchFeatureInternal,
    updateLockStatus,
    GetFeatureConfig (..),
    SetFeatureConfig (..),
    guardMlsE2EIdConfig,
  )
where

import Control.Lens
import Data.ByteString.Conversion (toByteString')
import Data.ByteString.UTF8 qualified as UTF8
import Data.Default
import Data.Id
import Data.Json.Util
import Data.Kind
import Data.Qualified
import Galley.API.LegalHold qualified as LegalHold
import Galley.API.LegalHold.Team qualified as LegalHold
import Galley.App
import Galley.Types.Error (InternalError)
import Imports
import Polysemy
import Polysemy.Error
import Polysemy.Input
import Polysemy.TinyLog qualified as P
import System.Logger.Class qualified as Log
import Wire.API.Conversation.Config (ConversationSubsystemConfig)
import Wire.API.Conversation.Role (Action (RemoveConversationMember))
import Wire.API.Error (ErrorS)
import Wire.API.Error.Galley
import Wire.API.Event.FeatureConfig
import Wire.API.Federation.Client (FederatorClient)
import Wire.API.Federation.Error
import Wire.API.Routes.Internal.Galley.TeamFeatureNoConfigMulti qualified as Multi
import Wire.API.Team.Feature
import Wire.API.Team.FeatureFlags
import Wire.API.Team.Member
import Wire.API.User (AccountStatus (..))
import Wire.BackendNotificationQueueAccess
import Wire.BrigAPIAccess (BrigAPIAccess, getAppIdsForTeam, setAccountStatus, updateSearchVisibilityInbound)
import Wire.CodeStore
import Wire.ConversationStore (ConversationStore, MLSCommitLockStore)
import Wire.ConversationSubsystem
import Wire.ExternalAccess (ExternalAccess)
import Wire.FeaturesConfigSubsystem (FeaturesConfigSubsystem, getDbFeatureRawInternal, getFeatureForTeam)
import Wire.FeaturesConfigSubsystem.Types
import Wire.FeaturesConfigSubsystem.Utils (resolveServerFeature)
import Wire.FederationAPIAccess (FederationAPIAccess)
import Wire.FederationSubsystem (FederationSubsystem)
import Wire.FireAndForget
import Wire.JobSubsystem (JobSubsystem, cancelAdminlessJobsForTeam, scheduleAdminlessSetupJob)
import Wire.LegalHoldStore (LegalHoldStore)
import Wire.NotificationSubsystem
import Wire.Options.Galley
import Wire.ProposalStore (ProposalStore)
import Wire.Sem.Now (Now)
import Wire.Sem.Paging
import Wire.Sem.Paging.Cassandra
import Wire.Sem.Random (Random)
import Wire.TeamCollaboratorsSubsystem
import Wire.TeamFeatureStore
import Wire.TeamMemberStore (TeamMemberStore)
import Wire.TeamStore (TeamStore)
import Wire.TeamStore qualified as SearchVisibilityData
import Wire.TeamSubsystem (TeamSubsystem)
import Wire.TeamSubsystem qualified as TeamSubsystem
import Wire.Util

type ComputeFeatureConstraints cfg r = (Member FeaturesConfigSubsystem r)

patchFeatureInternal ::
  forall cfg r.
  ( Typeable cfg,
    SetFeatureConfig cfg,
    ComputeFeatureConstraints cfg r,
    SetFeatureForTeamConstraints cfg r,
    Member TeamFeatureStore r,
    Member P.TinyLog r,
    Member NotificationSubsystem r,
    Member TeamSubsystem r,
    GetFeatureConfigEffects r
  ) =>
  TeamId ->
  LockableFeaturePatch cfg ->
  Sem r (LockableFeature cfg)
patchFeatureInternal tid patch = do
  TeamSubsystem.assertTeamExists tid
  dbFeature <- getDbFeatureRawInternal tid
  defFeature :: LockableFeature cfg <- resolveServerFeature
  let dbFeatureWithDefaults = dbFeature.applyDbFeature defFeature
  let patchedFeature = applyPatch dbFeatureWithDefaults
  prepareFeature tid patchedFeature
  patchDbFeature tid patch
  (returnedFeature :: LockableFeature cfg) <- getFeatureForTeam tid
  afterFeatureSet @cfg Nothing tid dbFeatureWithDefaults returnedFeature
  pushFeatureEvent @cfg tid (mkUpdateEvent tid returnedFeature)
  pure returnedFeature
  where
    applyPatch :: LockableFeature cfg -> LockableFeature cfg
    applyPatch current =
      current
        { status = fromMaybe current.status patch.status,
          lockStatus = fromMaybe current.lockStatus patch.lockStatus,
          config = fromMaybe current.config patch.config
        }

setFeature ::
  forall cfg r.
  ( Typeable cfg,
    SetFeatureConfig cfg,
    ComputeFeatureConstraints cfg r,
    SetFeatureForTeamConstraints cfg r,
    Member (Error TeamFeatureError) r,
    Member (ErrorS OperationDenied) r,
    Member (ErrorS 'NotATeamMember) r,
    Member TeamFeatureStore r,
    Member P.TinyLog r,
    Member NotificationSubsystem r,
    Member TeamSubsystem r,
    Member (Input (Local ())) r
  ) =>
  UserId ->
  TeamId ->
  Feature cfg ->
  Sem r (LockableFeature cfg)
setFeature uid tid feat = do
  lusr <- qualifyLocal uid
  zusrMembership <- TeamSubsystem.internalGetTeamMember uid tid
  void $ TeamSubsystem.permissionCheck ChangeTeamFeature zusrMembership
  setFeatureUnchecked (Just lusr) tid feat

setFeatureInternal ::
  forall cfg r.
  ( Typeable cfg,
    SetFeatureConfig cfg,
    ComputeFeatureConstraints cfg r,
    SetFeatureForTeamConstraints cfg r,
    Member (Error TeamFeatureError) r,
    Member TeamFeatureStore r,
    Member P.TinyLog r,
    Member NotificationSubsystem r,
    Member TeamSubsystem r
  ) =>
  TeamId ->
  Feature cfg ->
  Sem r (LockableFeature cfg)
setFeatureInternal tid feat = do
  TeamSubsystem.assertTeamExists tid
  setFeatureUnchecked Nothing tid feat

setFeatureUnchecked ::
  forall cfg r.
  ( Typeable cfg,
    SetFeatureConfig cfg,
    ComputeFeatureConstraints cfg r,
    SetFeatureForTeamConstraints cfg r,
    Member (Error TeamFeatureError) r,
    Member TeamFeatureStore r,
    Member (P.Logger (Log.Msg -> Log.Msg)) r,
    Member NotificationSubsystem r,
    Member TeamSubsystem r
  ) =>
  Maybe (Local UserId) ->
  TeamId ->
  Feature cfg ->
  Sem r (LockableFeature cfg)
setFeatureUnchecked originUser tid feat = do
  (feat0 :: LockableFeature cfg) <- getFeatureForTeam tid
  guardLockStatus feat0.lockStatus
  setFeatureForTeam @cfg originUser tid feat0 (withLockStatus feat0.lockStatus feat)

updateLockStatus ::
  forall cfg r.
  ( IsFeatureConfig cfg,
    Member TeamFeatureStore r,
    Member TeamSubsystem r
  ) =>
  TeamId ->
  LockStatus ->
  Sem r LockStatusResponse
updateLockStatus tid lockStatus = do
  TeamSubsystem.assertTeamExists tid
  setFeatureLockStatus @cfg tid lockStatus
  pure $ LockStatusResponse lockStatus

persistFeature ::
  forall cfg r.
  ( GetFeatureConfig cfg,
    ComputeFeatureConstraints cfg r,
    Member TeamFeatureStore r
  ) =>
  TeamId ->
  LockableFeature cfg ->
  Sem r (LockableFeature cfg)
persistFeature tid feat = do
  setDbFeature tid feat
  getFeatureForTeam tid

pushFeatureEvent ::
  forall cfg r.
  ( IsFeatureConfig cfg,
    Member NotificationSubsystem r,
    Member TeamSubsystem r,
    Member P.TinyLog r
  ) =>
  TeamId ->
  Event ->
  Sem r ()
pushFeatureEvent tid event = do
  memList <- TeamSubsystem.getTeamMembersForFanout tid
  if ((memList ^. teamMemberListType) == ListTruncated)
    then do
      P.warn $
        Log.field "action" (Log.val "Features.pushFeatureConfigEvent")
          . Log.field "feature" (Log.val (toByteString' . _eventFeatureName $ event))
          . Log.field "team" (Log.val (UTF8.fromString . show $ tid))
          . Log.msg @Text "Fanout limit exceeded. Events will not be sent."
    else do
      let recipients = membersToRecipients Nothing (memList ^. teamMembers)
      pushNotifications
        [def {json = toJSONObject event, recipients, isCellsEvent = isCellsFeatureConfigEvent @cfg}]

guardLockStatus ::
  forall r.
  (Member (Error TeamFeatureError) r) =>
  LockStatus ->
  Sem r ()
guardLockStatus = \case
  LockStatusUnlocked -> pure ()
  LockStatusLocked -> throw FeatureLocked

setFeatureForTeam ::
  forall cfg r.
  ( Typeable cfg,
    SetFeatureConfig cfg,
    SetFeatureForTeamConstraints cfg r,
    ComputeFeatureConstraints cfg r,
    Member P.TinyLog r,
    Member NotificationSubsystem r,
    Member TeamFeatureStore r,
    Member TeamSubsystem r
  ) =>
  Maybe (Local UserId) ->
  TeamId ->
  LockableFeature cfg ->
  LockableFeature cfg ->
  Sem r (LockableFeature cfg)
setFeatureForTeam originUser tid oldFeature feat = do
  prepareFeature tid feat
  newFeat <- persistFeature tid feat
  afterFeatureSet @cfg originUser tid oldFeature newFeat
  pushFeatureEvent @cfg tid (mkUpdateEvent tid newFeat)
  pure newFeat

-------------------------------------------------------------------------------
-- SetFeatureConfig instances

-- | Don't export methods of this typeclass
class (GetFeatureConfig cfg) => SetFeatureConfig cfg where
  type SetFeatureForTeamConstraints cfg (r :: EffectRow) :: Constraint
  type SetFeatureForTeamConstraints cfg (r :: EffectRow) = ()

  -- | This method takes a feature about to be set, performs the required
  -- checks, makes any related updates via the internal API, then finally
  -- returns the feature to be persisted and pushed to clients.
  --
  -- The default simply returns the original feature unchanged, which should be
  -- enough for most features.
  prepareFeature ::
    (SetFeatureForTeamConstraints cfg r) =>
    TeamId ->
    LockableFeature cfg ->
    Sem r ()
  default prepareFeature :: TeamId -> LockableFeature cfg -> Sem r ()
  prepareFeature _tid _feat = pure ()

  afterFeatureSet ::
    (SetFeatureForTeamConstraints cfg r) =>
    Maybe (Local UserId) ->
    TeamId ->
    LockableFeature cfg ->
    LockableFeature cfg ->
    Sem r ()
  default afterFeatureSet ::
    Maybe (Local UserId) ->
    TeamId ->
    LockableFeature cfg ->
    LockableFeature cfg ->
    Sem r ()
  afterFeatureSet _originUser _tid _oldFeature _newFeature = pure ()

instance SetFeatureConfig SSOConfig where
  type
    SetFeatureForTeamConstraints SSOConfig (r :: EffectRow) =
      ( Member (Input Opts) r,
        Member (Error TeamFeatureError) r
      )

  prepareFeature _tid feat = do
    case feat.status of
      FeatureStatusEnabled -> pure ()
      FeatureStatusDisabled -> throw DisableSsoNotImplemented

instance SetFeatureConfig SearchVisibilityAvailableConfig where
  type
    SetFeatureForTeamConstraints SearchVisibilityAvailableConfig (r :: EffectRow) =
      ( Member TeamStore r,
        Member (Input Opts) r
      )

  prepareFeature tid feat = do
    case feat.status of
      FeatureStatusEnabled -> pure ()
      FeatureStatusDisabled -> SearchVisibilityData.resetSearchVisibility tid

instance SetFeatureConfig RequireExternalEmailVerificationConfig

instance SetFeatureConfig DigitalSignaturesConfig

instance SetFeatureConfig LegalholdConfig where
  type
    SetFeatureForTeamConstraints LegalholdConfig (r :: EffectRow) =
      ( Bounded (PagingBounds InternalPaging TeamMember),
        Member BackendNotificationQueueAccess r,
        Member BrigAPIAccess r,
        Member CodeStore r,
        Member ConversationStore r,
        Member (Error FederationError) r,
        Member (Error InternalError) r,
        Member (ErrorS ('ActionDenied 'RemoveConversationMember)) r,
        Member (ErrorS 'CannotEnableLegalHoldServiceLargeTeam) r,
        Member (ErrorS 'NotATeamMember) r,
        Member (Error TeamFeatureError) r,
        Member (ErrorS 'LegalHoldNotEnabled) r,
        Member (ErrorS 'LegalHoldDisableUnimplemented) r,
        Member (ErrorS 'LegalHoldServiceNotRegistered) r,
        Member (ErrorS 'UserLegalHoldIllegalOperation) r,
        Member (ErrorS 'LegalHoldCouldNotBlockConnections) r,
        Member ExternalAccess r,
        Member (FederationAPIAccess FederatorClient) r,
        Member FireAndForget r,
        Member NotificationSubsystem r,
        Member ConversationSubsystem r,
        Member (Input (Local ())) r,
        Member (Input (FeatureDefaults LegalholdConfig)) r,
        Member (Input Env) r,
        Member Now r,
        Member LegalHoldStore r,
        Member ProposalStore r,
        Member TeamFeatureStore r,
        Member TeamStore r,
        Member (TeamMemberStore InternalPaging) r,
        Member P.TinyLog r,
        Member Random r,
        Member (Embed IO) r,
        Member TeamCollaboratorsSubsystem r,
        Member MLSCommitLockStore r,
        Member (Input FanoutLimit) r,
        Member FederationSubsystem r,
        Member TeamSubsystem r,
        Member (Input ConversationSubsystemConfig) r
      )

  prepareFeature tid feat = do
    -- this extra do is to encapsulate the assertions running before the actual operation.
    -- enabling LH for teams is only allowed in normal operation; disabled-permanently and
    -- whitelist-teams have no or their own way to do that, resp.
    featureLegalHold <- input @(FeatureDefaults LegalholdConfig)
    case featureLegalHold of
      FeatureLegalHoldDisabledByDefault -> do
        pure ()
      FeatureLegalHoldDisabledPermanently -> do
        throw LegalHoldFeatureFlagNotEnabled
      FeatureLegalHoldWhitelistTeamsAndImplicitConsent -> do
        throw LegalHoldWhitelistedOnly

    case feat.status of
      FeatureStatusDisabled -> LegalHold.removeSettings' @InternalPaging tid
      FeatureStatusEnabled -> LegalHold.ensureNotTooLargeToActivateLegalHold tid

instance SetFeatureConfig FileSharingConfig

instance SetFeatureConfig AppLockConfig where
  type SetFeatureForTeamConstraints AppLockConfig r = Member (Error TeamFeatureError) r

  prepareFeature _tid feat = do
    when (feat.config.timeout < 30) $
      throw AppLockInactivityTimeoutTooLow

instance SetFeatureConfig ConferenceCallingConfig

instance SetFeatureConfig SelfDeletingMessagesConfig

instance SetFeatureConfig GuestLinksConfig

instance SetFeatureConfig SndFactorPasswordChallengeConfig

instance SetFeatureConfig SearchVisibilityInboundConfig where
  type SetFeatureForTeamConstraints SearchVisibilityInboundConfig (r :: EffectRow) = (Member BrigAPIAccess r)
  prepareFeature tid feat = do
    updateSearchVisibilityInbound $ Multi.TeamStatus tid feat.status

instance SetFeatureConfig MLSConfig where
  type
    SetFeatureForTeamConstraints MLSConfig (r :: EffectRow) =
      ( Member (Input Opts) r,
        Member TeamFeatureStore r,
        Member FeaturesConfigSubsystem r,
        Member (Error TeamFeatureError) r
      )
  prepareFeature tid feat = do
    (mlsMigrationConfig :: LockableFeature MlsMigrationConfig) <- getFeatureForTeam tid
    unless
      ( -- default protocol needs to be included in supported protocols
        feat.config.mlsDefaultProtocol `elem` feat.config.mlsSupportedProtocols
          -- when MLS migration is enabled, MLS needs to be enabled as well
          && (mlsMigrationConfig.status == FeatureStatusDisabled || feat.status == FeatureStatusEnabled)
      )
      $ throw MLSProtocolMismatch

instance SetFeatureConfig ChannelsConfig

instance SetFeatureConfig PreventAdminlessGroupsConfig where
  type SetFeatureForTeamConstraints PreventAdminlessGroupsConfig r = Member JobSubsystem r

  afterFeatureSet originUser tid oldFeature newFeature =
    case (oldFeature.status, newFeature.status) of
      (FeatureStatusDisabled, FeatureStatusEnabled) ->
        scheduleAdminlessSetupJob originUser tid
      (FeatureStatusEnabled, FeatureStatusDisabled) ->
        cancelAdminlessJobsForTeam tid
      (FeatureStatusEnabled, FeatureStatusEnabled)
        | oldFeature.config /= newFeature.config -> do
            cancelAdminlessJobsForTeam tid
            scheduleAdminlessSetupJob originUser tid
        | otherwise -> pure ()
      _ -> pure ()

instance SetFeatureConfig ExposeInvitationURLsToTeamAdminConfig

instance SetFeatureConfig OutlookCalIntegrationConfig

instance SetFeatureConfig MlsE2EIdConfig

guardMlsE2EIdConfig ::
  forall r a.
  (Member (Error TeamFeatureError) r) =>
  (UserId -> TeamId -> Feature MlsE2EIdConfig -> Sem r a) ->
  UserId ->
  TeamId ->
  Feature MlsE2EIdConfig ->
  Sem r a
guardMlsE2EIdConfig handler uid tid feat = do
  when (isNothing (getAlt feat.config.crlProxy)) $ throw MLSE2EIDMissingCrlProxy
  handler uid tid feat

instance SetFeatureConfig MlsMigrationConfig where
  type
    SetFeatureForTeamConstraints MlsMigrationConfig (r :: EffectRow) =
      ( Member (Input Opts) r,
        Member (Error TeamFeatureError) r,
        Member TeamFeatureStore r,
        Member FeaturesConfigSubsystem r
      )
  prepareFeature tid feat = do
    (mlsConfig :: LockableFeature MLSConfig) <- getFeatureForTeam tid
    unless
      ( -- when MLS migration is enabled, MLS needs to be enabled as well
        feat.status == FeatureStatusDisabled || mlsConfig.status == FeatureStatusEnabled
      )
      $ throw MLSProtocolMismatch

instance SetFeatureConfig EnforceFileDownloadLocationConfig where
  type
    SetFeatureForTeamConstraints EnforceFileDownloadLocationConfig r =
      (Member (Error TeamFeatureError) r)

  prepareFeature _ feat = do
    -- empty download location is not allowed
    -- this is consistent with all other features, and least surprising for clients
    when (feat.config.enforcedDownloadLocation == Just "") $ do
      throw EmptyDownloadLocation

instance SetFeatureConfig LimitedEventFanoutConfig

instance SetFeatureConfig DomainRegistrationConfig

instance SetFeatureConfig CellsConfig

instance SetFeatureConfig CellsInternalConfig where
  type
    SetFeatureForTeamConstraints CellsInternalConfig r =
      (Member (Error TeamFeatureError) r)

  prepareFeature _ feat = do
    unless (feat.status == FeatureStatusEnabled && feat.lockStatus == LockStatusUnlocked) $ do
      throw InvalidStatusUpdate

instance SetFeatureConfig ConsumableNotificationsConfig

instance SetFeatureConfig ChatBubblesConfig

instance SetFeatureConfig AppsConfig where
  type
    SetFeatureForTeamConstraints AppsConfig (r :: EffectRow) =
      (Member BrigAPIAccess r)

  prepareFeature tid feat = case feat.status of
    -- WPB-25579: re-enabling the feature must NOT re-activate apps.  An app may
    -- have been suspended for reasons other than this feature being disabled
    -- (e.g. suspended individually), so we never blanket-reactivate here.
    FeatureStatusEnabled ->
      -- Do nothing.  Some apps may have been suspended for reasons
      -- unrelated to the feature flag flipping.
      pure ()
    FeatureStatusDisabled -> do
      appIds <- getAppIdsForTeam tid
      -- NB: this is not terribly efficient, but it's a rarely called operation
      -- with usually small numbers of apps.  tweak opportunities: (a) only call
      -- this loop if enablement actually changes; (b) loop over all
      -- appIds in postgres with one query.
      for_ appIds $ \uid -> setAccountStatus uid Suspended

instance SetFeatureConfig SimplifiedUserConnectionRequestQRCodeConfig

instance SetFeatureConfig StealthUsersConfig

instance SetFeatureConfig MeetingsConfig

instance SetFeatureConfig MeetingsPremiumConfig

instance SetFeatureConfig BackgroundEffectsConfig
