{-# LANGUAGE ApplicativeDo #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE StrictData #-}
{-# 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 Wire.API.Team.Feature
  ( FeatureStatus (..),
    featureName,
    featureNameBS,
    LockStatus (..),
    DbConfig (..),
    DbFeature (..),
    dbFeatureLockStatus,
    dbFeatureStatus,
    dbFeatureConfig,
    dbFeatureModConfig,
    featureToDB,
    resolveDbFeature,
    LockableFeature (..),
    defUnlockedFeature,
    defLockedFeature,
    setLockableFeatureLockStatus,
    setLockableFeatureStatus,
    LockableFeaturePatch (..),
    Feature (..),
    forgetLock,
    withLockStatus,
    FeatureTTL,
    FeatureTTLDays,
    FeatureTTL' (..),
    FeatureTTLUnit (..),
    EnforceAppLock (..),
    IsFeatureConfig (..),
    ParseDbFeature (..),
    FeatureSingleton (..),
    DeprecatedFeatureName,
    LockStatusResponse (..),
    One2OneCalls (..),
    -- Features
    LegalholdConfig (..),
    SSOConfig (..),
    SearchVisibilityAvailableConfig (..),
    SelfDeletingMessagesConfigB (..),
    SelfDeletingMessagesConfig,
    RequireExternalEmailVerificationConfig (..),
    DigitalSignaturesConfig (..),
    ConferenceCallingConfigB (..),
    ConferenceCallingConfig,
    GuestLinksConfig (..),
    ExposeInvitationURLsToTeamAdminConfig (..),
    SndFactorPasswordChallengeConfig (..),
    SearchVisibilityInboundConfig (..),
    ClassifiedDomainsConfig (..),
    AppLockConfig,
    AppLockConfigB (..),
    FileSharingConfig (..),
    MLSConfigB (..),
    MLSConfig,
    ChannelsConfig,
    ChannelsConfigB (..),
    ChannelPermissions (..),
    PreventAdminlessGroupsConfig,
    PreventAdminlessGroupsConfigB (..),
    PreventAdminlessTimeout (..),
    mkPreventAdminlessTimeoutDays,
    PreventAdminlessGroupsPromotionStrategy (..),
    OutlookCalIntegrationConfig (..),
    UseProxyOnMobile (..),
    MlsE2EIdConfigB (..),
    MlsE2EIdConfig,
    MlsMigrationConfigB (..),
    MlsMigrationConfig,
    EnforceFileDownloadLocationConfigB (..),
    EnforceFileDownloadLocationConfig,
    LimitedEventFanoutConfig (..),
    DomainRegistrationConfig (..),
    CellsConfig,
    CellsConfigB (..),
    CellsProperty (..),
    CellsPropertyStatus (..),
    CellsUsers (..),
    CellsCollaboraStatus (..),
    CellsPublicLinks (..),
    CellsConfigStorage (..),
    CellsRecycle (..),
    CellsMetadata (..),
    CellsNamespaces (..),
    CellsUserMetaTags (..),
    CellsInternalConfig,
    CellsInternalConfigB (..),
    CellsCollabora (..),
    CollaboraEdition (..),
    CellsBackend (..),
    QuotaBytes (..),
    CellsStorage (..),
    NumBytes (..),
    AllowedGlobalOperationsConfig (..),
    AssetAuditLogConfig (..),
    ConsumableNotificationsConfig (..),
    ChatBubblesConfig (..),
    AppsConfig (..),
    SimplifiedUserConnectionRequestQRCodeConfig (..),
    StealthUsersConfig (..),
    MeetingsConfig (..),
    MeetingsPremiumConfig (..),
    BackgroundEffectsConfig (..),
    Features,
    AllFeatures,
    NpProject (..),
    npProject,
    NpUpdate (..),
    npUpdate,
    AllTeamFeatures,
    parseDbFeature,
    serialiseDbFeature,
    mkAllFeatures,
    TeamFeatureMigrationState (..),
    isCellsFeatureConfigEvent,
    ConfiguredFeatureFlags (..),
  )
where

import Barbies
import Barbies.Bare
import Cassandra.CQL qualified as Cass
import Control.Applicative
import Control.Lens ((?~))
import Data.Aeson qualified as A
import Data.Aeson.Types qualified as A
import Data.Attoparsec.ByteString qualified as Parser
import Data.ByteString (fromStrict)
import Data.ByteString.Conversion
import Data.ByteString.UTF8 qualified as UTF8
import Data.Coerce (coerce)
import Data.Default
import Data.Domain (Domain)
import Data.Either.Extra (maybeToEither)
import Data.Id
import Data.Json.Util
import Data.Kind
import Data.Map qualified as M
import Data.Misc (Duration (..), DurationLiteral, HttpsUrl (..), durationLiteralText, durationLiteralValue, mkDurationLiteral, unsafeDurationLiteral)
import Data.Monoid hiding (All, First)
import Data.OpenApi qualified as S
import Data.Proxy
import Data.SOP
import Data.Schema
import Data.Scientific (toBoundedInteger)
import Data.Semigroup hiding (All)
import Data.Text qualified as T
import Data.Text.Encoding qualified as T
import Data.Text.Encoding.Error
import Data.Text.Lazy qualified as TL
import Data.Text.Lazy.Encoding qualified as TL
import Data.Text.Read qualified as TR
import Data.Time
import Deriving.Aeson
import GHC.TypeLits
import Generics.SOP qualified as GSOP
import Imports hiding (All, First)
import Servant (FromHttpApiData (..), ToHttpApiData (..))
import Test.QuickCheck (choose, frequency, getPrintableString)
import Test.QuickCheck.Arbitrary (arbitrary)
import Test.QuickCheck.Gen (suchThat)
import URI.ByteString.QQ qualified as URI.QQ
import Wire.API.Conversation.Protocol
import Wire.API.MLS.CipherSuite
import Wire.API.PostgresMarshall
import Wire.API.Routes.Named hiding (unnamed)
import Wire.API.Routes.Version
import Wire.API.Routes.Versioned
import Wire.API.Team.Feature.Profunctor
import Wire.Arbitrary (Arbitrary, GenericUniform (..))

----------------------------------------------------------------------
-- FeatureTag

-- | Checklist for adding a new feature
--
-- Assume we want to add a new feature called @dummy@. Every appearance of
-- @dummy@ or @Dummy@ in the following has to be replaced with the actual name
-- of the feature being added.
--
-- 1. Create a new type in this module for the feature configuration, called
-- @DummyConfig@. If your feature doesn't have a config besides being 'status'
-- and 'lockStatus', then the config should be a unit type, e.g. @data
-- DummyConfig = DummyConfig@. Otherwise, make a "bare barbie" record. Derive
-- 'Eq', 'Show', 'Generic', 'Arbitrary', 'RenderableSymbol' and
-- 'ParseDbFeature'. Implement a 'ToSchema' instance for the 'Covered' version
-- of the config type. Add a singleton. Add the config type to 'Features'.
--
-- 2. Implement 'GetFeatureConfig' and 'SetFeatureConfig' in
-- 'Galley.API.Teams.Features'. Empty instances will work fine unless this
-- feature requires custom logic.
--
-- 3. Add a public route to 'Wire.API.Routes.Public.Galley.Feature' and the
-- corresponding implementation in 'Galley.API.Public.Feature'.
--
-- 4. Add an internal route in 'Wire.API.Routes.Internal.Galley' and the
-- corresponding implementation in 'Galley.API.Internal'.
--
-- 5. If the feature should be configurable via Stern add routes to Stern.API.
-- Manually check that the swagger looks okay and works.
--
-- 6. In 'Galley.Types.Team', add a new data instance @DummyDefaults@ to
-- represent the server-wide feature defaults read from the configuration file.
-- In most cases, this should be a newtype over 'LockableFeature DummyConfig'.
-- Then derive all the instances like for the other features in that module.
-- Note that 'ParseFeatureDefaults' can be derived either via 'OptionalField'
-- or 'RequiredField', depending on whether the feature configuration should be
-- optional or required.
--
-- 7. If necessary, add configuration for the feature in
-- 'galley.integration.yaml', update the config map in
-- 'charts/galley/templates/configmap.yaml' and set defaults in
-- 'charts/galley/values.yaml'. Make sure that the configuration for CI matches
-- the local one, or adjust 'hack/helm_vars/wire-server/values.yaml'
-- accordingly.
--
-- 8. Add the default values of this feature in 'testAllFeatures'
-- ('Test.FeatureFlags'). Add feature-specific integration tests.
--
-- 9. Add a section to the documentation at an appropriate place
-- (e.g. 'docs/src/developer/reference/config-options.md' (if applicable) or
-- 'docs/src/understand/team-feature-settings.md')
class
  ( Default cfg,
    -- \| Should be "pure MyFeatureConfig" if the feature doesn't have config,
    -- which results in a trivial empty schema and the "config" field being
    -- omitted/ignored in the JSON encoder / parser.
    ToObjectSchema cfg,
    ToSchema cfg,
    Default (LockableFeature cfg),
    KnownSymbol (FeatureSymbol cfg),
    NpProject cfg Features,
    ParseDbFeature cfg
  ) =>
  IsFeatureConfig cfg
  where
  type FeatureSymbol cfg :: Symbol
  featureSingleton :: FeatureSingleton cfg

data FeatureSingleton cfg where
  FeatureSingletonGuestLinksConfig :: FeatureSingleton GuestLinksConfig
  FeatureSingletonLegalholdConfig :: FeatureSingleton LegalholdConfig
  FeatureSingletonSSOConfig :: FeatureSingleton SSOConfig
  FeatureSingletonSearchVisibilityAvailableConfig :: FeatureSingleton SearchVisibilityAvailableConfig
  FeatureSingletonRequireExternalEmailVerificationConfig :: FeatureSingleton RequireExternalEmailVerificationConfig
  FeatureSingletonDigitalSignaturesConfig :: FeatureSingleton DigitalSignaturesConfig
  FeatureSingletonConferenceCallingConfig :: FeatureSingleton ConferenceCallingConfig
  FeatureSingletonSndFactorPasswordChallengeConfig :: FeatureSingleton SndFactorPasswordChallengeConfig
  FeatureSingletonSearchVisibilityInboundConfig :: FeatureSingleton SearchVisibilityInboundConfig
  FeatureSingletonClassifiedDomainsConfig :: FeatureSingleton ClassifiedDomainsConfig
  FeatureSingletonAppLockConfig :: FeatureSingleton AppLockConfig
  FeatureSingletonSelfDeletingMessagesConfig :: FeatureSingleton SelfDeletingMessagesConfig
  FeatureSingletonFileSharingConfig :: FeatureSingleton FileSharingConfig
  FeatureSingletonMLSConfig :: FeatureSingleton MLSConfig
  FeatureSingletonExposeInvitationURLsToTeamAdminConfig :: FeatureSingleton ExposeInvitationURLsToTeamAdminConfig
  FeatureSingletonOutlookCalIntegrationConfig :: FeatureSingleton OutlookCalIntegrationConfig
  FeatureSingletonMlsE2EIdConfig :: FeatureSingleton MlsE2EIdConfig
  FeatureSingletonMlsMigrationConfig :: FeatureSingleton MlsMigrationConfig
  FeatureSingletonEnforceFileDownloadLocationConfig :: FeatureSingleton EnforceFileDownloadLocationConfig
  FeatureSingletonLimitedEventFanoutConfig :: FeatureSingleton LimitedEventFanoutConfig
  FeatureSingletonDomainRegistrationConfig :: FeatureSingleton DomainRegistrationConfig
  FeatureSingletonChannelsConfig :: FeatureSingleton ChannelsConfig
  FeatureSingletonPreventAdminlessGroupsConfig :: FeatureSingleton PreventAdminlessGroupsConfig
  FeatureSingletonCellsConfig :: FeatureSingleton CellsConfig
  FeatureSingletonAllowedGlobalOperationsConfig :: FeatureSingleton AllowedGlobalOperationsConfig
  FeatureSingletonConsumableNotificationsConfig :: FeatureSingleton ConsumableNotificationsConfig
  FeatureSingletonChatBubblesConfig :: FeatureSingleton ChatBubblesConfig
  FeatureSingletonAppsConfig :: FeatureSingleton AppsConfig
  FeatureSingletonSimplifiedUserConnectionRequestQRCodeConfig :: FeatureSingleton SimplifiedUserConnectionRequestQRCodeConfig
  FeatureSingletonAssetAuditLogConfig :: FeatureSingleton AssetAuditLogConfig
  FeatureSingletonStealthUsersConfig :: FeatureSingleton StealthUsersConfig
  FeatureSingletonCellsInternalConfig :: FeatureSingleton CellsInternalConfig
  FeatureSingletonMeetingsConfig :: FeatureSingleton MeetingsConfig
  FeatureSingletonMeetingsPremiumConfig :: FeatureSingleton MeetingsPremiumConfig
  FeatureSingletonBackgroundEffectsConfig :: FeatureSingleton BackgroundEffectsConfig

type family DeprecatedFeatureName (v :: Version) (cfg :: Type) :: Symbol

featureName :: forall cfg. (IsFeatureConfig cfg) => Text
featureName = T.pack $ symbolVal (Proxy @(FeatureSymbol cfg))

featureNameBS :: forall cfg. (IsFeatureConfig cfg) => ByteString
featureNameBS = UTF8.fromString $ symbolVal (Proxy @(FeatureSymbol cfg))

--------------------------------------------------------------------------------
-- DbFeature

-- | Feature data stored in the database, as a function of its default values.
newtype DbFeature cfg = DbFeature
  {applyDbFeature :: LockableFeature cfg -> LockableFeature cfg}
  deriving (Semigroup, Monoid) via Endo (LockableFeature cfg)

instance Default (DbFeature cfg) where
  def = mempty

dbFeatureLockStatus :: LockStatus -> DbFeature cfg
dbFeatureLockStatus s = DbFeature $ \w -> w {lockStatus = s}

dbFeatureStatus :: FeatureStatus -> DbFeature cfg
dbFeatureStatus s = DbFeature $ \w -> w {status = s}

dbFeatureConfig :: cfg -> DbFeature cfg
dbFeatureConfig c = DbFeature $ \w -> w {config = c}

dbFeatureModConfig :: (cfg -> cfg) -> DbFeature cfg
dbFeatureModConfig f = DbFeature $ \w -> w {config = f w.config}

featureToDB :: LockableFeature cfg -> DbFeature cfg
featureToDB = DbFeature . const

resolveDbFeature :: LockableFeature cfg -> DbFeature cfg -> LockableFeature cfg
resolveDbFeature defFeature dbFeature =
  let feat = applyDbFeature dbFeature defFeature
   in case feat.lockStatus of
        LockStatusLocked -> defFeature {lockStatus = LockStatusLocked}
        LockStatusUnlocked -> feat

newtype DbConfig = DbConfig {unDbConfig :: A.Value}
  deriving newtype (Arbitrary)
  deriving (Eq, Show)

instance PostgresMarshall A.Value DbConfig where
  postgresMarshall = unDbConfig

instance PostgresUnmarshall A.Value DbConfig where
  postgresUnmarshall = Right . DbConfig

instance Default DbConfig where
  def = DbConfig (A.object [])

instance Cass.Cql DbConfig where
  ctype = Cass.Tagged Cass.TextColumn

  fromCql (Cass.CqlText t) = fmap DbConfig . A.eitherDecode' . TL.encodeUtf8 . TL.fromStrict $ t
  fromCql _ = Left "service key pem: blob expected"

  toCql (DbConfig c) = Cass.CqlText . TL.toStrict . TL.decodeUtf8 . A.encode $ c

----------------------------------------------------------------------
-- LockableFeature

-- Note [unsettable features]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~
--
-- Some feature flags (e.g. sso) don't have a lock status stored in the
-- database. Instead, they are considered unlocked by default, but behave as if
-- they were locked, since they lack a public PUT endpoint.
--
-- This trick has caused a lot of confusion in the past, and cannot be extended
-- to flags that have non-trivial configuration. For this reason, we are in the
-- process of changing this mechanism to make it work like every other feature.
--
-- That means that such features will afterwards be toggled by setting their
-- lock status instead. And we'll have some logic in place to make the default
-- status when unlocked be enabled. This achieves a similar behaviour but with
-- fewer exceptional code paths.
--
-- See the implementation of 'computeFeature' for 'ConferenceCallingConfig' for
-- an example of this mechanism in practice.

data LockableFeature cfg = LockableFeature
  { status :: FeatureStatus,
    lockStatus :: LockStatus,
    config :: cfg
  }
  deriving stock (Eq, Show)
  deriving (ToJSON, FromJSON, S.ToSchema) via Schema (LockableFeature cfg)

instance (Default (LockableFeature cfg)) => Default (Feature cfg) where
  def = forgetLock def

setLockableFeatureLockStatus :: LockableFeature cfg -> LockStatus -> LockableFeature cfg
setLockableFeatureLockStatus LockableFeature {..} s = LockableFeature {lockStatus = s, ..}

setLockableFeatureStatus :: LockableFeature cfg -> FeatureStatus -> LockableFeature cfg
setLockableFeatureStatus LockableFeature {..} s = LockableFeature {status = s, ..}

-- | A feature that is disabled and locked.
defLockedFeature :: (Default cfg) => LockableFeature cfg
defLockedFeature =
  LockableFeature
    { status = FeatureStatusDisabled,
      lockStatus = LockStatusLocked,
      config = def
    }

-- | A feature that is enabled and unlocked.
defUnlockedFeature :: (Default cfg) => LockableFeature cfg
defUnlockedFeature =
  LockableFeature
    { status = FeatureStatusEnabled,
      lockStatus = LockStatusUnlocked,
      config = def
    }

instance (Typeable cfg, IsFeatureConfig cfg) => ToSchema (LockableFeature cfg) where
  schema =
    object $
      LockableFeature
        <$> (.status) .= field "status" schema
        <*> (.lockStatus) .= field "lockStatus" schema
        <*> (.config) .= objectSchema @cfg
        <* const FeatureTTLUnlimited
          .= optField
            "ttl"
            (schema :: ValueSchema NamedSwaggerDoc FeatureTTL)

instance (Arbitrary cfg, IsFeatureConfig cfg) => Arbitrary (LockableFeature cfg) where
  arbitrary = LockableFeature <$> arbitrary <*> arbitrary <*> arbitrary

----------------------------------------------------------------------
-- LockableFeaturePatch

data LockableFeaturePatch (cfg :: Type) = LockableFeaturePatch
  { status :: Maybe FeatureStatus,
    lockStatus :: Maybe LockStatus,
    config :: Maybe cfg
  }
  deriving stock (Eq, Show)
  deriving (ToJSON, FromJSON, S.ToSchema) via (Schema (LockableFeaturePatch cfg))

instance Default (LockableFeaturePatch cfg) where
  def = LockableFeaturePatch Nothing Nothing Nothing

-- | The ToJSON implementation of `LockableFeaturePatch` will encode the trivial config as `"config": {}`
-- when the value is a `Just`, if it's `Nothing` it will be omitted, which is the important part.
instance (Typeable cfg, ToSchema cfg) => ToSchema (LockableFeaturePatch cfg) where
  schema =
    object $
      LockableFeaturePatch
        <$> (.status) .= maybe_ (optField "status" schema)
        <*> (.lockStatus) .= maybe_ (optField "lockStatus" schema)
        <*> (.config) .= maybe_ (optField "config" schema)
        <* const FeatureTTLUnlimited
          .= optField
            "ttl"
            (schema :: ValueSchema NamedSwaggerDoc FeatureTTL)

instance (Arbitrary cfg, IsFeatureConfig cfg) => Arbitrary (LockableFeaturePatch cfg) where
  arbitrary = LockableFeaturePatch <$> arbitrary <*> arbitrary <*> arbitrary

----------------------------------------------------------------------
-- Feature

data Feature (cfg :: Type) = Feature
  { status :: FeatureStatus,
    config :: cfg
  }
  deriving stock (Eq, Show, Generic, Typeable, Functor)
  deriving (ToJSON, FromJSON, S.ToSchema) via (Schema (Feature cfg))

instance (Arbitrary cfg) => Arbitrary (Feature cfg) where
  arbitrary = Feature <$> arbitrary <*> arbitrary

forgetLock :: LockableFeature a -> Feature a
forgetLock ws = Feature ws.status ws.config

withLockStatus :: LockStatus -> Feature a -> LockableFeature a
withLockStatus ls (Feature s c) = LockableFeature s ls c

instance (Typeable cfg, ToObjectSchema cfg) => ToSchema (Feature cfg) where
  schema =
    object $
      Feature
        <$> (.status) .= field "status" schema
        <*> (.config) .= objectSchema @cfg
        <* const FeatureTTLUnlimited
          .= optField
            "ttl"
            (schema :: ValueSchema NamedSwaggerDoc FeatureTTL)

instance
  (Typeable cfg, Typeable v, ToObjectSchema (Versioned v cfg)) =>
  ToSchema (Versioned v (Feature cfg))
  where
  schema = Versioned . fmap unVersioned <$> (fmap Versioned . unVersioned) .= schema @(Feature (Versioned v cfg))

----------------------------------------------------------------------
-- FeatureTTL

-- Using Word to avoid dealing with negative numbers.
-- Ideally we would also not support zero.
-- Currently a TTL=0 is ignored on the cassandra side.
data FeatureTTL' (u :: FeatureTTLUnit)
  = -- | actually, unit depends on phantom type.
    FeatureTTLSeconds Word
  | FeatureTTLUnlimited
  deriving stock (Eq, Show, Generic)

data FeatureTTLUnit = FeatureTTLUnitSeconds | FeatureTTLUnitDays

type FeatureTTL = FeatureTTL' 'FeatureTTLUnitSeconds

type FeatureTTLDays = FeatureTTL' 'FeatureTTLUnitDays

instance Arbitrary FeatureTTL where
  arbitrary =
    (nonZero <$> arbitrary)
      `suchThat` ( \case
                     -- A very short TTL (<= 2) can cause race conditions in the integration tests
                     FeatureTTLSeconds n -> n > 2
                     _ -> True
                 )
    where
      nonZero 0 = FeatureTTLUnlimited
      nonZero n = FeatureTTLSeconds n

instance ToSchema FeatureTTL where
  schema = mkSchema ttlDoc toTTL fromTTL
    where
      ttlDoc :: NamedSwaggerDoc
      ttlDoc = swaggerDoc @Word & S.schema . S.example ?~ "unlimited"

      toTTL :: A.Value -> A.Parser FeatureTTL
      toTTL v = parseUnlimited v <|> parseSeconds v

      parseUnlimited :: A.Value -> A.Parser FeatureTTL
      parseUnlimited =
        A.withText "FeatureTTL" $
          \t ->
            if t == "unlimited" || t == "0"
              then pure FeatureTTLUnlimited
              else A.parseFail "Expected ''unlimited' or '0'."

      parseSeconds :: A.Value -> A.Parser FeatureTTL
      parseSeconds = A.withScientific "FeatureTTL" $
        \s -> case toBoundedInteger s of
          Just 0 -> error "impossible (this would have parsed in `parseUnlimited` above)."
          Just i -> pure . FeatureTTLSeconds $ i
          Nothing -> A.parseFail "Expected an positive integer."

      fromTTL :: FeatureTTL -> Maybe A.Value
      fromTTL FeatureTTLUnlimited = Just "unlimited"
      fromTTL (FeatureTTLSeconds 0) = Nothing -- Should be unlimited
      fromTTL (FeatureTTLSeconds s) = Just $ A.toJSON s

instance ToHttpApiData (FeatureTTL' u) where
  toQueryParam = T.decodeUtf8 . toByteString'

instance FromHttpApiData (FeatureTTL' u) where
  parseQueryParam = maybeToEither invalidTTLErrorString . fromByteString . T.encodeUtf8

instance S.ToParamSchema (FeatureTTL' u) where
  toParamSchema _ = S.toParamSchema (Proxy @Text)

instance ToByteString (FeatureTTL' u) where
  builder FeatureTTLUnlimited = "unlimited"
  builder (FeatureTTLSeconds d) = (builder . TL.pack . show) d

instance FromByteString (FeatureTTL' u) where
  parser =
    Parser.takeByteString >>= \b ->
      case T.decodeUtf8' b of
        Right "unlimited" -> pure FeatureTTLUnlimited
        Right d -> case readEither . T.unpack $ d of
          Left _ -> fail $ T.unpack invalidTTLErrorString
          Right d' -> pure . FeatureTTLSeconds $ d'
        Left _ -> fail $ T.unpack invalidTTLErrorString

instance Cass.Cql FeatureTTL where
  ctype = Cass.Tagged Cass.IntColumn

  -- Passing TTL = 0 to Cassandra removes the TTL.
  -- It does not instantly revert back.
  fromCql (Cass.CqlInt 0) = pure FeatureTTLUnlimited
  fromCql (Cass.CqlInt n) = pure . FeatureTTLSeconds . fromIntegral $ n
  fromCql _ = Left "fromCql: TTLValue: CqlInt expected"

  toCql FeatureTTLUnlimited = Cass.CqlInt 0
  toCql (FeatureTTLSeconds d) = Cass.CqlInt . fromIntegral $ d

invalidTTLErrorString :: Text
invalidTTLErrorString = "Invalid FeatureTTLSeconds: must be a positive integer or 'unlimited.'"

-- LockStatus

data LockStatus = LockStatusLocked | LockStatusUnlocked
  deriving stock (Eq, Show, Generic)
  deriving (Arbitrary) via (GenericUniform LockStatus)
  deriving (ToJSON, FromJSON, S.ToSchema) via (Schema LockStatus)

instance FromHttpApiData LockStatus where
  parseUrlPiece = maybeToEither "Invalid lock status" . fromByteString . T.encodeUtf8

instance ToSchema LockStatus where
  schema =
    enum @Text $
      mconcat
        [ element "locked" LockStatusLocked,
          element "unlocked" LockStatusUnlocked
        ]

instance S.ToParamSchema LockStatus where
  toParamSchema _ = mempty & S.type_ ?~ S.OpenApiString & S.enum_ ?~ ["locked", "unlocked"]

instance ToByteString LockStatus where
  builder LockStatusLocked = "locked"
  builder LockStatusUnlocked = "unlocked"

instance FromByteString LockStatus where
  parser =
    Parser.takeByteString >>= \b ->
      case T.decodeUtf8' b of
        Right "locked" -> pure LockStatusLocked
        Right "unlocked" -> pure LockStatusUnlocked
        Right t -> fail $ "Invalid LockStatus: " <> T.unpack t
        Left e -> fail $ "Invalid LockStatus: " <> show e

instance Cass.Cql LockStatus where
  ctype = Cass.Tagged Cass.IntColumn

  fromCql (Cass.CqlInt n) = case n of
    0 -> pure LockStatusLocked
    1 -> pure LockStatusUnlocked
    _ -> Left "fromCql: Invalid LockStatus"
  fromCql _ = Left "fromCql: LockStatus: CqlInt expected"

  toCql LockStatusLocked = Cass.CqlInt 0
  toCql LockStatusUnlocked = Cass.CqlInt 1

instance PostgresMarshall Int32 LockStatus where
  postgresMarshall LockStatusLocked = 0
  postgresMarshall LockStatusUnlocked = 1

instance PostgresUnmarshall Int32 LockStatus where
  postgresUnmarshall 0 = Right LockStatusLocked
  postgresUnmarshall 1 = Right LockStatusUnlocked
  postgresUnmarshall _ = Left "invalid lockStatus"

newtype LockStatusResponse = LockStatusResponse {_unlockStatus :: LockStatus}
  deriving stock (Eq, Show, Generic)
  deriving (Arbitrary) via (GenericUniform LockStatus)
  deriving (ToJSON, FromJSON, S.ToSchema) via (Schema LockStatusResponse)

instance ToSchema LockStatusResponse where
  schema =
    object $
      LockStatusResponse
        <$> _unlockStatus .= field "lockStatus" schema

--------------------------------------------------------------------------------
-- GuestLinks feature

data GuestLinksConfig = GuestLinksConfig
  deriving (Eq, Show, Generic, GSOP.Generic)
  deriving (Arbitrary) via (GenericUniform GuestLinksConfig)
  deriving (RenderableSymbol) via (RenderableTypeName GuestLinksConfig)
  deriving (ParseDbFeature, Default) via TrivialFeature GuestLinksConfig

instance ToSchema GuestLinksConfig where
  schema = object objectSchema

instance Default (LockableFeature GuestLinksConfig) where
  def = defUnlockedFeature

instance ToObjectSchema GuestLinksConfig where
  objectSchema = pure GuestLinksConfig

instance IsFeatureConfig GuestLinksConfig where
  type FeatureSymbol GuestLinksConfig = "conversationGuestLinks"
  featureSingleton = FeatureSingletonGuestLinksConfig

--------------------------------------------------------------------------------
-- Legalhold feature

data LegalholdConfig = LegalholdConfig
  deriving (Eq, Show, Generic, GSOP.Generic)
  deriving (Arbitrary) via (GenericUniform LegalholdConfig)
  deriving (RenderableSymbol) via (RenderableTypeName LegalholdConfig)
  deriving (ParseDbFeature, Default) via TrivialFeature LegalholdConfig

instance Default (LockableFeature LegalholdConfig) where
  def = defUnlockedFeature {status = FeatureStatusDisabled}

instance ToObjectSchema LegalholdConfig where
  objectSchema = pure LegalholdConfig

instance IsFeatureConfig LegalholdConfig where
  type FeatureSymbol LegalholdConfig = "legalhold"
  featureSingleton = FeatureSingletonLegalholdConfig

instance ToSchema LegalholdConfig where
  schema = object objectSchema

--------------------------------------------------------------------------------
-- SSO feature

-- | This feature does not have a PUT endpoint. See Note [unsettable features].
data SSOConfig = SSOConfig
  deriving (Eq, Show, Generic, GSOP.Generic)
  deriving (Arbitrary) via (GenericUniform SSOConfig)
  deriving (RenderableSymbol) via (RenderableTypeName SSOConfig)
  deriving (ParseDbFeature, Default) via TrivialFeature SSOConfig

instance Default (LockableFeature SSOConfig) where
  def = defUnlockedFeature {status = FeatureStatusDisabled}

instance ToObjectSchema SSOConfig where
  objectSchema = pure SSOConfig

instance IsFeatureConfig SSOConfig where
  type FeatureSymbol SSOConfig = "sso"
  featureSingleton = FeatureSingletonSSOConfig

instance ToSchema SSOConfig where
  schema = object objectSchema

--------------------------------------------------------------------------------
-- SearchVisibility available feature

-- | Wether a team is allowed to change search visibility
-- See the handle of PUT /teams/:tid/search-visibility
data SearchVisibilityAvailableConfig = SearchVisibilityAvailableConfig
  deriving (Eq, Show, Generic, GSOP.Generic)
  deriving (Arbitrary) via (GenericUniform SearchVisibilityAvailableConfig)
  deriving (RenderableSymbol) via (RenderableTypeName SearchVisibilityAvailableConfig)
  deriving (ParseDbFeature, Default) via TrivialFeature SearchVisibilityAvailableConfig

instance Default (LockableFeature SearchVisibilityAvailableConfig) where
  def = defUnlockedFeature {status = FeatureStatusDisabled}

instance ToObjectSchema SearchVisibilityAvailableConfig where
  objectSchema = pure SearchVisibilityAvailableConfig

instance IsFeatureConfig SearchVisibilityAvailableConfig where
  type FeatureSymbol SearchVisibilityAvailableConfig = "searchVisibility"
  featureSingleton = FeatureSingletonSearchVisibilityAvailableConfig

instance ToSchema SearchVisibilityAvailableConfig where
  schema = object objectSchema

type instance DeprecatedFeatureName V2 SearchVisibilityAvailableConfig = "search-visibility"

--------------------------------------------------------------------------------
-- RequireExternalEmailVerification feature

-- | Controls whether externally managed email addresses (from SAML or SCIM)
-- must be verified by the user, or are auto-activated. When disabled, no
-- verification email is sent, but the address is still activated immediately
-- and can receive later account notifications such as new-device emails.
-- The external feature name is kept for backward compatibility.
--
-- (This feature does not have a PUT endpoint. See Note [unsettable features].)
data RequireExternalEmailVerificationConfig = RequireExternalEmailVerificationConfig
  deriving (Eq, Show, Generic, GSOP.Generic)
  deriving (Arbitrary) via (GenericUniform RequireExternalEmailVerificationConfig)
  deriving (RenderableSymbol) via (RenderableTypeName RequireExternalEmailVerificationConfig)
  deriving (ParseDbFeature, Default) via (TrivialFeature RequireExternalEmailVerificationConfig)

instance ToSchema RequireExternalEmailVerificationConfig where
  schema = object objectSchema

instance Default (LockableFeature RequireExternalEmailVerificationConfig) where
  def = defUnlockedFeature

instance ToObjectSchema RequireExternalEmailVerificationConfig where
  objectSchema = pure RequireExternalEmailVerificationConfig

instance IsFeatureConfig RequireExternalEmailVerificationConfig where
  type FeatureSymbol RequireExternalEmailVerificationConfig = "validateSAMLemails"
  featureSingleton = FeatureSingletonRequireExternalEmailVerificationConfig

type instance DeprecatedFeatureName V2 RequireExternalEmailVerificationConfig = "validate-saml-emails"

--------------------------------------------------------------------------------
-- DigitalSignatures feature

-- | This feature does not have a PUT endpoint. See Note [unsettable features].
data DigitalSignaturesConfig = DigitalSignaturesConfig
  deriving (Eq, Show, Generic, GSOP.Generic)
  deriving (Arbitrary) via (GenericUniform DigitalSignaturesConfig)
  deriving (RenderableSymbol) via (RenderableTypeName DigitalSignaturesConfig)
  deriving (ParseDbFeature, Default) via (TrivialFeature DigitalSignaturesConfig)

instance Default (LockableFeature DigitalSignaturesConfig) where
  def = defUnlockedFeature {status = FeatureStatusDisabled}

instance ToObjectSchema DigitalSignaturesConfig where
  objectSchema = pure DigitalSignaturesConfig

instance IsFeatureConfig DigitalSignaturesConfig where
  type FeatureSymbol DigitalSignaturesConfig = "digitalSignatures"
  featureSingleton = FeatureSingletonDigitalSignaturesConfig

type instance DeprecatedFeatureName V2 DigitalSignaturesConfig = "digital-signatures"

instance ToSchema DigitalSignaturesConfig where
  schema = object objectSchema

--------------------------------------------------------------------------------
-- ConferenceCalling feature

data One2OneCalls = One2OneCallsTurn | One2OneCallsSft
  deriving stock (Eq, Show, Generic)
  deriving (Arbitrary) via (GenericUniform One2OneCalls)

one2OneCallsFromUseSftFlag :: Bool -> One2OneCalls
one2OneCallsFromUseSftFlag False = One2OneCallsTurn
one2OneCallsFromUseSftFlag True = One2OneCallsSft

one2OneCallsSchema :: ValueSchema SwaggerDoc One2OneCalls
one2OneCallsSchema = one2OneCallsFromUseSftFlag <$> (== One2OneCallsSft) .= unnamed schema

instance Default One2OneCalls where
  def = One2OneCallsTurn

instance Cass.Cql One2OneCalls where
  ctype = Cass.Tagged Cass.IntColumn

  fromCql (Cass.CqlInt n) = case n of
    0 -> pure One2OneCallsTurn
    1 -> pure One2OneCallsSft
    _ -> Left "fromCql: Invalid One2OneCalls"
  fromCql _ = Left "fromCql: One2OneCalls: CqlInt expected"

  toCql One2OneCallsTurn = Cass.CqlInt 0
  toCql One2OneCallsSft = Cass.CqlInt 1

data ConferenceCallingConfigB t f = ConferenceCallingConfig
  { one2OneCalls :: Wear t f One2OneCalls
  }
  deriving (BareB, Generic)

deriving instance FunctorB (ConferenceCallingConfigB Covered)

deriving instance ApplicativeB (ConferenceCallingConfigB Covered)

deriving instance TraversableB (ConferenceCallingConfigB Covered)

type ConferenceCallingConfig = ConferenceCallingConfigB Bare Identity

deriving instance (Eq ConferenceCallingConfig)

deriving instance (Show ConferenceCallingConfig)

deriving via (GenericUniform ConferenceCallingConfig) instance (Arbitrary ConferenceCallingConfig)

deriving via (RenderableTypeName ConferenceCallingConfig) instance (RenderableSymbol ConferenceCallingConfig)

deriving via (BarbieFeature ConferenceCallingConfigB) instance (ParseDbFeature ConferenceCallingConfig)

deriving via (BarbieFeature ConferenceCallingConfigB) instance (ToSchema ConferenceCallingConfig)

instance Default ConferenceCallingConfig where
  def = ConferenceCallingConfig def

instance Default (LockableFeature ConferenceCallingConfig) where
  def = defLockedFeature {status = FeatureStatusEnabled}

instance ToObjectSchema ConferenceCallingConfig where
  objectSchema = fromMaybe def <$> optField "config" schema

instance IsFeatureConfig ConferenceCallingConfig where
  type FeatureSymbol ConferenceCallingConfig = "conferenceCalling"
  featureSingleton = FeatureSingletonConferenceCallingConfig

instance (Typeable f, OptWithDefault f) => ToSchema (ConferenceCallingConfigB Covered f) where
  schema =
    object $
      ConferenceCallingConfig
        <$> one2OneCalls
          .= fromOpt
            (optField "useSFTForOneToOneCalls" one2OneCallsSchema)

--------------------------------------------------------------------------------
-- SndFactorPasswordChallenge feature

data SndFactorPasswordChallengeConfig = SndFactorPasswordChallengeConfig
  deriving (Eq, Show, Generic, GSOP.Generic)
  deriving (Arbitrary) via (GenericUniform SndFactorPasswordChallengeConfig)
  deriving (RenderableSymbol) via (RenderableTypeName SndFactorPasswordChallengeConfig)
  deriving (ParseDbFeature, Default) via (TrivialFeature SndFactorPasswordChallengeConfig)

instance ToSchema SndFactorPasswordChallengeConfig where
  schema = object objectSchema

instance Default (LockableFeature SndFactorPasswordChallengeConfig) where
  def = defLockedFeature

instance ToObjectSchema SndFactorPasswordChallengeConfig where
  objectSchema = pure SndFactorPasswordChallengeConfig

instance IsFeatureConfig SndFactorPasswordChallengeConfig where
  type FeatureSymbol SndFactorPasswordChallengeConfig = "sndFactorPasswordChallenge"
  featureSingleton = FeatureSingletonSndFactorPasswordChallengeConfig

--------------------------------------------------------------------------------
-- SearchVisibilityInbound feature

data SearchVisibilityInboundConfig = SearchVisibilityInboundConfig
  deriving (Eq, Show, Generic, GSOP.Generic)
  deriving (Arbitrary) via (GenericUniform SearchVisibilityInboundConfig)
  deriving (S.ToSchema) via Schema SearchVisibilityInboundConfig
  deriving (RenderableSymbol) via (RenderableTypeName SearchVisibilityInboundConfig)
  deriving (ParseDbFeature, Default) via (TrivialFeature SearchVisibilityInboundConfig)

instance Default (LockableFeature SearchVisibilityInboundConfig) where
  def = defUnlockedFeature {status = FeatureStatusDisabled}

instance ToObjectSchema SearchVisibilityInboundConfig where
  objectSchema = pure SearchVisibilityInboundConfig

instance IsFeatureConfig SearchVisibilityInboundConfig where
  type FeatureSymbol SearchVisibilityInboundConfig = "searchVisibilityInbound"
  featureSingleton = FeatureSingletonSearchVisibilityInboundConfig

instance ToSchema SearchVisibilityInboundConfig where
  schema = object objectSchema

----------------------------------------------------------------------
-- ClassifiedDomains feature

-- | This feature is quite special, in that it does not have any database
-- state. Its value cannot be updated dynamically, and is always set to the
-- server default taken from the backend configuration.
data ClassifiedDomainsConfig = ClassifiedDomainsConfig
  { classifiedDomainsDomains :: [Domain]
  }
  deriving stock (Show, Eq, Generic)
  deriving (ToJSON, FromJSON, S.ToSchema) via (Schema ClassifiedDomainsConfig)
  deriving (RenderableSymbol) via (RenderableTypeName ClassifiedDomainsConfig)

instance ParseDbFeature ClassifiedDomainsConfig where
  parseDbConfig _ = fail "ClassifiedDomainsConfig cannot be parsed from the DB"
  serialiseDbConfig = DbConfig . schemaToJSON

instance Default ClassifiedDomainsConfig where
  def = ClassifiedDomainsConfig []

deriving via (GenericUniform ClassifiedDomainsConfig) instance Arbitrary ClassifiedDomainsConfig

instance ToSchema ClassifiedDomainsConfig where
  schema =
    object $
      ClassifiedDomainsConfig
        <$> classifiedDomainsDomains .= field "domains" (array schema)

instance Default (LockableFeature ClassifiedDomainsConfig) where
  def = defUnlockedFeature {status = FeatureStatusDisabled}

instance ToObjectSchema ClassifiedDomainsConfig where
  objectSchema = field "config" schema

instance IsFeatureConfig ClassifiedDomainsConfig where
  type FeatureSymbol ClassifiedDomainsConfig = "classifiedDomains"
  featureSingleton = FeatureSingletonClassifiedDomainsConfig

----------------------------------------------------------------------
-- AppLock feature

data AppLockConfigB t f = AppLockConfig
  { enforce :: Wear t f EnforceAppLock,
    timeout :: Wear t f Int32
  }
  deriving (Generic, BareB)

instance FunctorB (AppLockConfigB Covered)

instance ApplicativeB (AppLockConfigB Covered)

instance TraversableB (AppLockConfigB Covered)

type AppLockConfig = AppLockConfigB Bare Identity

deriving instance Eq AppLockConfig

deriving instance Show AppLockConfig

deriving via RenderableTypeName AppLockConfig instance RenderableSymbol AppLockConfig

deriving via (GenericUniform AppLockConfig) instance Arbitrary AppLockConfig

deriving via (BarbieFeature AppLockConfigB) instance ParseDbFeature AppLockConfig

deriving via (BarbieFeature AppLockConfigB) instance ToSchema AppLockConfig

instance Default AppLockConfig where
  def = AppLockConfig (EnforceAppLock False) 60

instance (Typeable f, FieldF f) => ToSchema (AppLockConfigB Covered f) where
  schema =
    object $
      AppLockConfig
        <$> (.enforce) .= fieldF "enforceAppLock" schema
        <*> (.timeout) .= fieldF "inactivityTimeoutSecs" schema

instance Default (LockableFeature AppLockConfig) where
  def = defUnlockedFeature

instance ToObjectSchema AppLockConfig where
  objectSchema = field "config" schema

instance IsFeatureConfig AppLockConfig where
  type FeatureSymbol AppLockConfig = "appLock"
  featureSingleton = FeatureSingletonAppLockConfig

newtype EnforceAppLock = EnforceAppLock Bool
  deriving stock (Eq, Show, Ord, Generic)
  deriving newtype (Arbitrary)
  deriving (FromJSON, ToJSON) via (Schema EnforceAppLock)

instance ToSchema EnforceAppLock where
  schema = EnforceAppLock <$> (\(EnforceAppLock v) -> v) .= schema

--------------------------------------------------------------------------------
-- FileSharing feature

data FileSharingConfig = FileSharingConfig
  deriving (Eq, Show, Generic, GSOP.Generic)
  deriving (Arbitrary) via (GenericUniform FileSharingConfig)
  deriving (RenderableSymbol) via (RenderableTypeName FileSharingConfig)
  deriving (ParseDbFeature) via (TrivialFeature FileSharingConfig)

instance Default FileSharingConfig where
  def = FileSharingConfig

instance Default (LockableFeature FileSharingConfig) where
  def = defUnlockedFeature

instance ToObjectSchema FileSharingConfig where
  objectSchema = pure FileSharingConfig

instance IsFeatureConfig FileSharingConfig where
  type FeatureSymbol FileSharingConfig = "fileSharing"
  featureSingleton = FeatureSingletonFileSharingConfig

instance ToSchema FileSharingConfig where
  schema = object objectSchema

----------------------------------------------------------------------
-- SelfDeletingMessagesConfig

data SelfDeletingMessagesConfigB t f = SelfDeletingMessagesConfig
  { sdmEnforcedTimeoutSeconds :: Wear t f Int32
  }
  deriving (BareB, Generic)

instance FunctorB (SelfDeletingMessagesConfigB Covered)

instance ApplicativeB (SelfDeletingMessagesConfigB Covered)

instance TraversableB (SelfDeletingMessagesConfigB Covered)

type SelfDeletingMessagesConfig = SelfDeletingMessagesConfigB Bare Identity

deriving instance (Eq SelfDeletingMessagesConfig)

deriving instance (Show SelfDeletingMessagesConfig)

deriving via (GenericUniform SelfDeletingMessagesConfig) instance (Arbitrary SelfDeletingMessagesConfig)

deriving via (RenderableTypeName SelfDeletingMessagesConfig) instance (RenderableSymbol SelfDeletingMessagesConfig)

deriving via (BarbieFeature SelfDeletingMessagesConfigB) instance (ParseDbFeature SelfDeletingMessagesConfig)

deriving via (BarbieFeature SelfDeletingMessagesConfigB) instance (ToSchema SelfDeletingMessagesConfig)

instance Default SelfDeletingMessagesConfig where
  def = SelfDeletingMessagesConfig 0

instance (Typeable f, FieldF f) => ToSchema (SelfDeletingMessagesConfigB Covered f) where
  schema =
    object $
      SelfDeletingMessagesConfig
        <$> sdmEnforcedTimeoutSeconds .= fieldF "enforcedTimeoutSeconds" schema

instance Default (LockableFeature SelfDeletingMessagesConfig) where
  def = defUnlockedFeature

instance ToObjectSchema SelfDeletingMessagesConfig where
  objectSchema = field "config" schema

instance IsFeatureConfig SelfDeletingMessagesConfig where
  type FeatureSymbol SelfDeletingMessagesConfig = "selfDeletingMessages"
  featureSingleton = FeatureSingletonSelfDeletingMessagesConfig

----------------------------------------------------------------------
-- MLSConfig

data MLSConfigB t f = MLSConfig
  { mlsProtocolToggleUsers :: Wear t f [UserId],
    mlsDefaultProtocol :: Wear t f ProtocolTag,
    mlsAllowedCipherSuites :: Wear t f [CipherSuiteTag],
    mlsDefaultCipherSuite :: Wear t f CipherSuiteTag,
    mlsSupportedProtocols :: Wear t f [ProtocolTag],
    mlsGroupInfoDiagnostics :: Any
  }
  deriving (Generic, BareB)

deriving instance FunctorB (MLSConfigB Covered)

deriving instance ApplicativeB (MLSConfigB Covered)

deriving instance TraversableB (MLSConfigB Covered)

type MLSConfig = MLSConfigB Bare Identity

deriving instance Eq MLSConfig

deriving instance Show MLSConfig

deriving via (RenderableTypeName MLSConfig) instance (RenderableSymbol MLSConfig)

deriving via (GenericUniform MLSConfig) instance (Arbitrary MLSConfig)

deriving via (BarbieFeature MLSConfigB) instance (ParseDbFeature MLSConfig)

deriving via (BarbieFeature MLSConfigB) instance (ToSchema MLSConfig)

instance Default MLSConfig where
  def =
    MLSConfig
      { mlsProtocolToggleUsers = [],
        mlsDefaultProtocol = ProtocolProteusTag,
        mlsAllowedCipherSuites = [MLS_128_DHKEMP256_AES128GCM_SHA256_P256],
        mlsDefaultCipherSuite = MLS_128_DHKEMP256_AES128GCM_SHA256_P256,
        mlsSupportedProtocols = [ProtocolProteusTag, ProtocolMLSTag],
        mlsGroupInfoDiagnostics = Any False
      }

instance (Typeable f, FieldF f) => ToSchema (MLSConfigB Covered f) where
  schema =
    object $
      MLSConfig
        <$> mlsProtocolToggleUsers
          .= ( fieldWithDocModifierF
                 "protocolToggleUsers"
                 (S.description ?~ "allowlist of users that may change protocols")
                 (array schema)
             )
        <*> mlsDefaultProtocol .= fieldF "defaultProtocol" schema
        <*> mlsAllowedCipherSuites .= fieldF "allowedCipherSuites" (array schema)
        <*> mlsDefaultCipherSuite .= fieldF "defaultCipherSuite" schema
        <*> mlsSupportedProtocols .= fieldF "supportedProtocols" (array schema)
        <*> (getAny . mlsGroupInfoDiagnostics)
          .= fmap (Any . fromMaybe False) (optField "groupInfoDiagnostics" schema)

instance Default (LockableFeature MLSConfig) where
  def = defUnlockedFeature {status = FeatureStatusDisabled}

instance ToObjectSchema MLSConfig where
  objectSchema = field "config" schema

instance IsFeatureConfig MLSConfig where
  type FeatureSymbol MLSConfig = "mls"
  featureSingleton = FeatureSingletonMLSConfig

----------------------------------------------------------------------
-- ChannelsConfig

data ChannelsConfigB t f = ChannelsConfig
  { allowedToCreateChannels :: Wear t f ChannelPermissions,
    allowedToOpenChannels :: Wear t f ChannelPermissions
  }
  deriving (Generic, BareB)

deriving instance FunctorB (ChannelsConfigB Covered)

deriving instance ApplicativeB (ChannelsConfigB Covered)

deriving instance TraversableB (ChannelsConfigB Covered)

type ChannelsConfig = ChannelsConfigB Bare Identity

deriving instance Eq ChannelsConfig

deriving instance Show ChannelsConfig

deriving via (RenderableTypeName ChannelsConfig) instance (RenderableSymbol ChannelsConfig)

deriving via (GenericUniform ChannelsConfig) instance (Arbitrary ChannelsConfig)

deriving via (BarbieFeature ChannelsConfigB) instance (ParseDbFeature ChannelsConfig)

deriving via (BarbieFeature ChannelsConfigB) instance (ToSchema ChannelsConfig)

instance Default ChannelsConfig where
  def = ChannelsConfig TeamMembers TeamMembers

data ChannelPermissions = TeamMembers | Everyone | Admins
  deriving (Show, Eq, Generic)
  deriving (ToJSON, FromJSON, S.ToSchema) via Schema ChannelPermissions
  deriving (Arbitrary) via (GenericUniform ChannelPermissions)

instance ToSchema ChannelPermissions where
  schema =
    enum @Text $
      mconcat
        [ element "team-members" TeamMembers,
          element "everyone" Everyone,
          element "admins" Admins
        ]

instance (Typeable f, FieldF f) => ToSchema (ChannelsConfigB Covered f) where
  schema =
    object $
      ChannelsConfig
        <$> allowedToCreateChannels .= fieldF "allowed_to_create_channels" schema
        <*> allowedToOpenChannels .= fieldF "allowed_to_open_channels" schema

instance Default (LockableFeature ChannelsConfig) where
  def = defLockedFeature

instance ToObjectSchema ChannelsConfig where
  objectSchema = field "config" schema

instance IsFeatureConfig ChannelsConfig where
  type FeatureSymbol ChannelsConfig = "channels"
  featureSingleton = FeatureSingletonChannelsConfig

----------------------------------------------------------------------
-- PreventAdminlessGroupsConfig

data PreventAdminlessGroupsPromotionStrategy
  = PromotionStrategyAlphabetical
  | PromotionStrategyRandom
  | PromotionStrategyAll
  deriving (Show, Eq, Generic)
  deriving (ToJSON, FromJSON, S.ToSchema) via Schema PreventAdminlessGroupsPromotionStrategy
  deriving (Arbitrary) via (GenericUniform PreventAdminlessGroupsPromotionStrategy)

instance ToSchema PreventAdminlessGroupsPromotionStrategy where
  schema =
    enum @Text $
      mconcat
        [ element "alphabetical" PromotionStrategyAlphabetical,
          element "random" PromotionStrategyRandom,
          element "all" PromotionStrategyAll
        ]

newtype PreventAdminlessTimeout = PreventAdminlessTimeout
  { preventAdminlessTimeoutLiteral :: DurationLiteral
  }
  deriving stock (Show, Eq, Generic)

instance Arbitrary PreventAdminlessTimeout where
  arbitrary = mkPreventAdminlessTimeoutDays <$> choose (0, 30)

mkPreventAdminlessTimeout :: Text -> Either String PreventAdminlessTimeout
mkPreventAdminlessTimeout txt = do
  timeout <- mkDurationLiteral txt
  let wrapped = PreventAdminlessTimeout timeout
      picoseconds = diffTimeToPicoseconds (duration (durationLiteralValue timeout))
      days = preventAdminlessTimeoutDaysInteger wrapped
  if picoseconds < 0
    then Left "Duration must not be negative"
    else
      if days > toInteger (maxBound :: Word)
        then Left "Duration is too large to represent as legacy day timeout"
        else pure wrapped

mkPreventAdminlessTimeoutDays :: Word -> PreventAdminlessTimeout
mkPreventAdminlessTimeoutDays days =
  PreventAdminlessTimeout
    ( unsafeDurationLiteral
        (T.pack (show days) <> "d")
        ( Duration . picosecondsToDiffTime $
            toInteger days * preventAdminlessDayPicoseconds
        )
    )

validatePreventAdminlessTimeout :: DurationLiteral -> A.Parser DurationLiteral
validatePreventAdminlessTimeout =
  fmap preventAdminlessTimeoutLiteral
    . either fail pure
    . mkPreventAdminlessTimeout
    . durationLiteralText

preventAdminlessTimeoutSchema :: ValueSchema NamedSwaggerDoc PreventAdminlessTimeout
preventAdminlessTimeoutSchema =
  PreventAdminlessTimeout
    <$> preventAdminlessTimeoutLiteral
      .= (schema @DurationLiteral `withParser` validatePreventAdminlessTimeout)

preventAdminlessTimeoutDays :: PreventAdminlessTimeout -> Word
preventAdminlessTimeoutDays =
  fromInteger
    . min (toInteger (maxBound :: Word))
    . preventAdminlessTimeoutDaysInteger

preventAdminlessTimeoutDaysInteger :: PreventAdminlessTimeout -> Integer
preventAdminlessTimeoutDaysInteger timeout =
  -- Legacy clients only understand whole days. Round up so positive sub-day
  -- durations such as "1s" are not exposed as 0 days.
  ceilingDiv
    (diffTimeToPicoseconds . duration . durationLiteralValue $ preventAdminlessTimeoutLiteral timeout)
    preventAdminlessDayPicoseconds

preventAdminlessDayPicoseconds :: Integer
preventAdminlessDayPicoseconds = 86_400 * 1_000_000_000_000

ceilingDiv :: Integer -> Integer -> Integer
ceilingDiv x y
  | x <= 0 = 0
  | otherwise = (x + y - 1) `div` y

pickPreventAdminlessTimeout :: Maybe PreventAdminlessTimeout -> Maybe Word -> Maybe PreventAdminlessTimeout
pickPreventAdminlessTimeout (Just timeout) _ = Just timeout
pickPreventAdminlessTimeout Nothing (Just days) = Just (mkPreventAdminlessTimeoutDays days)
pickPreventAdminlessTimeout Nothing Nothing = Nothing

pickPreventAdminlessTimeouts :: Maybe [PreventAdminlessTimeout] -> Maybe [Word] -> Maybe [PreventAdminlessTimeout]
pickPreventAdminlessTimeouts (Just timeouts) _ = Just timeouts
pickPreventAdminlessTimeouts Nothing (Just days) = Just (mkPreventAdminlessTimeoutDays <$> days)
pickPreventAdminlessTimeouts Nothing Nothing = Nothing

publicPreventAdminlessTimeoutField :: Text -> Text -> ObjectSchema SwaggerDoc PreventAdminlessTimeout
publicPreventAdminlessTimeoutField legacyName durationName =
  ( pickPreventAdminlessTimeout
      <$> Just .= maybe_ (optField durationName preventAdminlessTimeoutSchema)
      <*> (Just . preventAdminlessTimeoutDays) .= maybe_ (optField legacyName schema)
  )
    `withParser` maybe (fail missingField) pure
  where
    missingField =
      "Missing '" <> T.unpack durationName <> "' or legacy '" <> T.unpack legacyName <> "'"

publicPreventAdminlessTimeoutsField :: Text -> Text -> ObjectSchema SwaggerDoc [PreventAdminlessTimeout]
publicPreventAdminlessTimeoutsField legacyName durationName =
  ( pickPreventAdminlessTimeouts
      <$> Just .= maybe_ (optField durationName (array preventAdminlessTimeoutSchema))
      <*> (Just . fmap preventAdminlessTimeoutDays) .= maybe_ (optField legacyName (array schema))
  )
    `withParser` maybe (fail missingField) pure
  where
    missingField =
      "Missing '" <> T.unpack durationName <> "' or legacy '" <> T.unpack legacyName <> "'"

dbPreventAdminlessTimeoutField :: Text -> Text -> ObjectSchema SwaggerDoc (Maybe PreventAdminlessTimeout)
dbPreventAdminlessTimeoutField legacyName durationName =
  pickPreventAdminlessTimeout
    <$> id .= maybe_ (optField durationName preventAdminlessTimeoutSchema)
    <*> const Nothing .= maybe_ (optField legacyName schema)

dbPreventAdminlessTimeoutsField :: Text -> Text -> ObjectSchema SwaggerDoc (Maybe [PreventAdminlessTimeout])
dbPreventAdminlessTimeoutsField legacyName durationName =
  pickPreventAdminlessTimeouts
    <$> id .= maybe_ (optField durationName (array preventAdminlessTimeoutSchema))
    <*> const Nothing .= maybe_ (optField legacyName (array schema))

class (Functor f) => PreventAdminlessTimeoutFieldF f where
  preventAdminlessTimeoutFieldF ::
    Text ->
    Text ->
    ObjectSchema SwaggerDoc (f PreventAdminlessTimeout)

  preventAdminlessTimeoutsFieldF ::
    Text ->
    Text ->
    ObjectSchema SwaggerDoc (f [PreventAdminlessTimeout])

instance PreventAdminlessTimeoutFieldF Identity where
  preventAdminlessTimeoutFieldF legacyName durationName =
    Identity <$> runIdentity .= publicPreventAdminlessTimeoutField legacyName durationName

  preventAdminlessTimeoutsFieldF legacyName durationName =
    Identity <$> runIdentity .= publicPreventAdminlessTimeoutsField legacyName durationName

instance PreventAdminlessTimeoutFieldF Maybe where
  preventAdminlessTimeoutFieldF = dbPreventAdminlessTimeoutField

  preventAdminlessTimeoutsFieldF = dbPreventAdminlessTimeoutsField

data PreventAdminlessGroupsConfigB t f = PreventAdminlessGroupsConfig
  { promotionStrategy :: Wear t f PreventAdminlessGroupsPromotionStrategy,
    deletionTimeout :: Wear t f PreventAdminlessTimeout,
    reminderTimeouts :: Wear t f [PreventAdminlessTimeout]
  }
  deriving (Generic, BareB)

deriving instance FunctorB (PreventAdminlessGroupsConfigB Covered)

deriving instance ApplicativeB (PreventAdminlessGroupsConfigB Covered)

deriving instance TraversableB (PreventAdminlessGroupsConfigB Covered)

type PreventAdminlessGroupsConfig = PreventAdminlessGroupsConfigB Bare Identity

deriving instance Eq PreventAdminlessGroupsConfig

deriving instance Show PreventAdminlessGroupsConfig

deriving via (RenderableTypeName PreventAdminlessGroupsConfig) instance (RenderableSymbol PreventAdminlessGroupsConfig)

deriving via (GenericUniform PreventAdminlessGroupsConfig) instance (Arbitrary PreventAdminlessGroupsConfig)

deriving via (BarbieFeature PreventAdminlessGroupsConfigB) instance (ParseDbFeature PreventAdminlessGroupsConfig)

deriving via (BarbieFeature PreventAdminlessGroupsConfigB) instance (ToSchema PreventAdminlessGroupsConfig)

instance Default PreventAdminlessGroupsConfig where
  def =
    PreventAdminlessGroupsConfig
      { promotionStrategy = PromotionStrategyAlphabetical,
        deletionTimeout = mkPreventAdminlessTimeoutDays 7,
        reminderTimeouts = mkPreventAdminlessTimeoutDays <$> [2, 4, 6]
      }

instance (Typeable f, FieldF f, PreventAdminlessTimeoutFieldF f) => ToSchema (PreventAdminlessGroupsConfigB Covered f) where
  schema =
    object $
      PreventAdminlessGroupsConfig
        <$> promotionStrategy .= fieldF "promotionStrategy" schema
        <*> deletionTimeout .= preventAdminlessTimeoutFieldF "deletionTimeout" "deletionTimeoutDuration"
        <*> reminderTimeouts .= preventAdminlessTimeoutsFieldF "reminderTimeouts" "reminderTimeoutDurations"

instance ToSchema (Versioned V16 PreventAdminlessGroupsConfig) where
  schema =
    object $
      Versioned
        <$> unVersioned .= oldPreventAdminlessGroupsConfigObjectSchema

instance ToObjectSchema (Versioned V16 PreventAdminlessGroupsConfig) where
  objectSchema = field "config" schema

instance ToSchema (Versioned V17 PreventAdminlessGroupsConfig) where
  schema =
    object $
      Versioned
        <$> unVersioned .= durationPreventAdminlessGroupsConfigObjectSchema

instance ToObjectSchema (Versioned V17 PreventAdminlessGroupsConfig) where
  objectSchema = field "config" schema

oldPreventAdminlessGroupsConfigObjectSchema :: ObjectSchema SwaggerDoc PreventAdminlessGroupsConfig
oldPreventAdminlessGroupsConfigObjectSchema =
  PreventAdminlessGroupsConfig
    <$> promotionStrategy .= field "promotionStrategy" schema
    <*> deletionTimeout .= oldPreventAdminlessTimeoutField "deletionTimeout"
    <*> reminderTimeouts .= oldPreventAdminlessTimeoutsField "reminderTimeouts"

oldPreventAdminlessTimeoutField :: Text -> ObjectSchema SwaggerDoc PreventAdminlessTimeout
oldPreventAdminlessTimeoutField name = preventAdminlessTimeoutDays .= (mkPreventAdminlessTimeoutDays <$> field name schema)

oldPreventAdminlessTimeoutsField :: Text -> ObjectSchema SwaggerDoc [PreventAdminlessTimeout]
oldPreventAdminlessTimeoutsField name = fmap preventAdminlessTimeoutDays .= (fmap mkPreventAdminlessTimeoutDays <$> field name (array schema))

durationPreventAdminlessGroupsConfigObjectSchema :: ObjectSchema SwaggerDoc PreventAdminlessGroupsConfig
durationPreventAdminlessGroupsConfigObjectSchema =
  PreventAdminlessGroupsConfig
    <$> promotionStrategy .= field "promotionStrategy" schema
    <*> deletionTimeout .= field "deletionTimeoutDuration" preventAdminlessTimeoutSchema
    <*> reminderTimeouts .= field "reminderTimeoutDurations" (array preventAdminlessTimeoutSchema)

instance Default (LockableFeature PreventAdminlessGroupsConfig) where
  def = defUnlockedFeature {status = FeatureStatusDisabled}

instance ToObjectSchema PreventAdminlessGroupsConfig where
  objectSchema = field "config" schema

instance IsFeatureConfig PreventAdminlessGroupsConfig where
  type FeatureSymbol PreventAdminlessGroupsConfig = "preventAdminlessGroups"
  featureSingleton = FeatureSingletonPreventAdminlessGroupsConfig

----------------------------------------------------------------------
-- ExposeInvitationURLsToTeamAdminConfig

data ExposeInvitationURLsToTeamAdminConfig = ExposeInvitationURLsToTeamAdminConfig
  deriving (Show, Eq, Generic, GSOP.Generic)
  deriving (Arbitrary) via (GenericUniform ExposeInvitationURLsToTeamAdminConfig)
  deriving (RenderableSymbol) via (RenderableTypeName ExposeInvitationURLsToTeamAdminConfig)
  deriving (Default, ParseDbFeature) via (TrivialFeature ExposeInvitationURLsToTeamAdminConfig)

instance Default (LockableFeature ExposeInvitationURLsToTeamAdminConfig) where
  def = defLockedFeature

instance ToObjectSchema ExposeInvitationURLsToTeamAdminConfig where
  objectSchema = pure ExposeInvitationURLsToTeamAdminConfig

instance IsFeatureConfig ExposeInvitationURLsToTeamAdminConfig where
  type FeatureSymbol ExposeInvitationURLsToTeamAdminConfig = "exposeInvitationURLsToTeamAdmin"
  featureSingleton = FeatureSingletonExposeInvitationURLsToTeamAdminConfig

instance ToSchema ExposeInvitationURLsToTeamAdminConfig where
  schema = object objectSchema

----------------------------------------------------------------------
-- OutlookCalIntegrationConfig

-- | This feature setting only applies to the Outlook Calendar extension for Wire.
-- As it is an external service, it should only be configured through this feature flag and otherwise ignored by the backend.
data OutlookCalIntegrationConfig = OutlookCalIntegrationConfig
  deriving (Eq, Show, Generic, GSOP.Generic)
  deriving (Arbitrary) via (GenericUniform OutlookCalIntegrationConfig)
  deriving (RenderableSymbol) via (RenderableTypeName OutlookCalIntegrationConfig)
  deriving (Default, ParseDbFeature) via (TrivialFeature OutlookCalIntegrationConfig)

instance Default (LockableFeature OutlookCalIntegrationConfig) where
  def = defLockedFeature

instance ToObjectSchema OutlookCalIntegrationConfig where
  objectSchema = pure OutlookCalIntegrationConfig

instance IsFeatureConfig OutlookCalIntegrationConfig where
  type FeatureSymbol OutlookCalIntegrationConfig = "outlookCalIntegration"
  featureSingleton = FeatureSingletonOutlookCalIntegrationConfig

instance ToSchema OutlookCalIntegrationConfig where
  schema = object objectSchema

----------------------------------------------------------------------
-- MlsE2EIdConfig

newtype UseProxyOnMobile = UseProxyOnMobile {unUseProxyOnMobile :: Bool}
  deriving (Eq, Show, Generic)
  deriving (Arbitrary) via (GenericUniform UseProxyOnMobile)
  deriving (Semigroup) via First Bool
  deriving (ToSchema) via Bool

-- | This instance is necessary to derive ApplicativeB below, but it isn't
-- actually used.
instance Monoid UseProxyOnMobile where
  mempty = error "Internal error: UseProxyOnMobile is not a monoid"

instance Default UseProxyOnMobile where
  def = UseProxyOnMobile False

data MlsE2EIdConfigB t f = MlsE2EIdConfig
  { verificationExpiration :: Wear t f NominalDiffTime,
    acmeDiscoveryUrl :: Alt Maybe HttpsUrl,
    crlProxy :: Alt Maybe HttpsUrl,
    useProxyOnMobile :: UseProxyOnMobile
  }
  deriving (BareB, Generic)

deriving instance FunctorB (MlsE2EIdConfigB Covered)

deriving instance ApplicativeB (MlsE2EIdConfigB Covered)

deriving instance TraversableB (MlsE2EIdConfigB Covered)

type MlsE2EIdConfig = MlsE2EIdConfigB Bare Identity

deriving via (RenderableTypeName MlsE2EIdConfig) instance (RenderableSymbol MlsE2EIdConfig)

deriving via (BarbieFeature MlsE2EIdConfigB) instance ParseDbFeature MlsE2EIdConfig

deriving via (BarbieFeature MlsE2EIdConfigB) instance ToSchema MlsE2EIdConfig

deriving instance Eq MlsE2EIdConfig

deriving instance Show MlsE2EIdConfig

instance Default MlsE2EIdConfig where
  def = MlsE2EIdConfig (fromIntegral @Int (60 * 60 * 24)) empty empty def

instance Arbitrary MlsE2EIdConfig where
  arbitrary =
    MlsE2EIdConfig
      <$> (fromIntegral <$> (arbitrary @Word32))
      <*> arbitrary
      <*> fmap (Alt . pure) arbitrary
      <*> arbitrary

instance (Typeable f, FieldF f) => ToSchema (MlsE2EIdConfigB Covered f) where
  schema =
    object $
      MlsE2EIdConfig
        <$> ( (fmap toSeconds . verificationExpiration)
                .= fieldWithDocModifierF
                  "verificationExpiration"
                  (description ?~ veDesc)
                  (fromSeconds <$> schema)
            )
        <*> (getAlt . acmeDiscoveryUrl)
          .= fmap Alt (maybe_ (optField "acmeDiscoveryUrl" schema))
        <*> (getAlt . crlProxy) .= fmap Alt (maybe_ (optField "crlProxy" schema))
        <*> useProxyOnMobile .= fmap (fromMaybe def) (optField "useProxyOnMobile" schema)
    where
      fromSeconds :: Int -> NominalDiffTime
      fromSeconds = fromIntegral

      toSeconds :: NominalDiffTime -> Int
      toSeconds = truncate

      veDesc :: Text
      veDesc =
        "When a client first tries to fetch or renew a certificate, \
        \they may need to login to an identity provider (IdP) depending on their IdP domain authentication policy. \
        \The user may have a grace period during which they can \"snooze\" this login. \
        \The duration of this grace period (in seconds) is set in the `verificationDuration` parameter, \
        \which is enforced separately by each client. \
        \After the grace period has expired, the client will not allow the user to use the application \
        \until they have logged to refresh the certificate. The default value is 1 day (86400s). \
        \The client enrolls using the Automatic Certificate Management Environment (ACME) protocol. \
        \The `acmeDiscoveryUrl` parameter must be set to the HTTPS URL of the ACME server discovery endpoint for \
        \this team. It is of the form \"https://acme.{backendDomain}/acme/{provisionerName}/discovery\". For example: \
        \`https://acme.example.com/acme/provisioner1/discovery`."

instance Default (LockableFeature MlsE2EIdConfig) where
  def = defLockedFeature

instance ToObjectSchema MlsE2EIdConfig where
  objectSchema = field "config" schema

instance IsFeatureConfig MlsE2EIdConfig where
  type FeatureSymbol MlsE2EIdConfig = "mlsE2EId"
  featureSingleton = FeatureSingletonMlsE2EIdConfig

----------------------------------------------------------------------
-- MlsMigration

data MlsMigrationConfigB t f = MlsMigrationConfig
  { startTime :: Wear t f (Maybe UTCTime),
    finaliseRegardlessAfter :: Wear t f (Maybe UTCTime)
  }
  deriving (BareB, Generic)

deriving instance FunctorB (MlsMigrationConfigB Covered)

deriving instance ApplicativeB (MlsMigrationConfigB Covered)

deriving instance TraversableB (MlsMigrationConfigB Covered)

type MlsMigrationConfig = MlsMigrationConfigB Bare Identity

deriving instance Eq MlsMigrationConfig

deriving instance Show MlsMigrationConfig

deriving via (BarbieFeature MlsMigrationConfigB) instance (ParseDbFeature MlsMigrationConfig)

deriving via (BarbieFeature MlsMigrationConfigB) instance (ToSchema MlsMigrationConfig)

deriving via (RenderableTypeName MlsMigrationConfig) instance (RenderableSymbol MlsMigrationConfig)

instance Default MlsMigrationConfig where
  def = MlsMigrationConfig Nothing Nothing

instance Arbitrary MlsMigrationConfig where
  arbitrary = do
    startTime <- fmap fromUTCTimeMillis <$> arbitrary
    finaliseRegardlessAfter <- fmap fromUTCTimeMillis <$> arbitrary
    pure
      MlsMigrationConfig
        { startTime = startTime,
          finaliseRegardlessAfter = finaliseRegardlessAfter
        }

instance (Typeable f, NestedMaybe f) => ToSchema (MlsMigrationConfigB Covered f) where
  schema =
    object $
      MlsMigrationConfig
        <$> startTime .= nestedMaybeField "startTime" (unnamed utcTimeSchema)
        <*> finaliseRegardlessAfter .= nestedMaybeField "finaliseRegardlessAfter" (unnamed utcTimeSchema)

instance Default (LockableFeature MlsMigrationConfig) where
  def = defLockedFeature

instance ToObjectSchema MlsMigrationConfig where
  objectSchema = field "config" schema

instance IsFeatureConfig MlsMigrationConfig where
  type FeatureSymbol MlsMigrationConfig = "mlsMigration"
  featureSingleton = FeatureSingletonMlsMigrationConfig

----------------------------------------------------------------------
-- EnforceFileDownloadLocationConfig

data EnforceFileDownloadLocationConfigB t f = EnforceFileDownloadLocationConfig
  { enforcedDownloadLocation :: Wear t f (Maybe Text)
  }
  deriving (BareB, Generic)

deriving instance FunctorB (EnforceFileDownloadLocationConfigB Covered)

deriving instance ApplicativeB (EnforceFileDownloadLocationConfigB Covered)

deriving instance TraversableB (EnforceFileDownloadLocationConfigB Covered)

type EnforceFileDownloadLocationConfig = EnforceFileDownloadLocationConfigB Bare Identity

deriving instance (Eq EnforceFileDownloadLocationConfig)

deriving instance (Eq (EnforceFileDownloadLocationConfigB Covered Maybe))

deriving instance (Show EnforceFileDownloadLocationConfig)

deriving instance (Show (EnforceFileDownloadLocationConfigB Covered Maybe))

deriving via (RenderableTypeName EnforceFileDownloadLocationConfig) instance (RenderableSymbol EnforceFileDownloadLocationConfig)

deriving via (BarbieFeature EnforceFileDownloadLocationConfigB) instance (ToSchema EnforceFileDownloadLocationConfig)

deriving via (BarbieFeature EnforceFileDownloadLocationConfigB) instance (ParseDbFeature EnforceFileDownloadLocationConfig)

instance Default EnforceFileDownloadLocationConfig where
  def = EnforceFileDownloadLocationConfig Nothing

instance Arbitrary EnforceFileDownloadLocationConfig where
  arbitrary = EnforceFileDownloadLocationConfig . fmap (T.pack . getPrintableString) <$> arbitrary

instance (Typeable f, NestedMaybe f) => ToSchema (EnforceFileDownloadLocationConfigB Covered f) where
  schema =
    object $
      EnforceFileDownloadLocationConfig
        <$> enforcedDownloadLocation .= nestedMaybeField "enforcedDownloadLocation" (unnamed schema)

instance Default (LockableFeature EnforceFileDownloadLocationConfig) where
  def = defLockedFeature

instance ToObjectSchema EnforceFileDownloadLocationConfig where
  objectSchema = field "config" schema

instance IsFeatureConfig EnforceFileDownloadLocationConfig where
  type FeatureSymbol EnforceFileDownloadLocationConfig = "enforceFileDownloadLocation"
  featureSingleton = FeatureSingletonEnforceFileDownloadLocationConfig

----------------------------------------------------------------------
-- Guarding the fanout of events when a team member is deleted.
--
-- FUTUREWORK: This is a transient flag that is to be removed after about 6
-- months of its introduction, namely once all clients get a chance to adapt to
-- a limited event fanout.

-- | This feature does not have a PUT endpoint. See Note [unsettable features].
data LimitedEventFanoutConfig = LimitedEventFanoutConfig
  deriving (Eq, Show, Generic, GSOP.Generic)
  deriving (Arbitrary) via (GenericUniform LimitedEventFanoutConfig)
  deriving (RenderableSymbol) via (RenderableTypeName LimitedEventFanoutConfig)
  deriving (Default, ParseDbFeature) via (TrivialFeature LimitedEventFanoutConfig)

instance Default (LockableFeature LimitedEventFanoutConfig) where
  def = defUnlockedFeature

instance ToObjectSchema LimitedEventFanoutConfig where
  objectSchema = pure LimitedEventFanoutConfig

instance IsFeatureConfig LimitedEventFanoutConfig where
  type FeatureSymbol LimitedEventFanoutConfig = "limitedEventFanout"
  featureSingleton = FeatureSingletonLimitedEventFanoutConfig

instance ToSchema LimitedEventFanoutConfig where
  schema = object objectSchema

--------------------------------------------------------------------------------
-- DomainRegistration feature

-- | This feature does not have a PUT endpoint. See Note [unsettable features].
data DomainRegistrationConfig = DomainRegistrationConfig
  deriving (Eq, Show, Generic, GSOP.Generic)
  deriving (Arbitrary) via (GenericUniform DomainRegistrationConfig)
  deriving (RenderableSymbol) via (RenderableTypeName DomainRegistrationConfig)
  deriving (Default, ParseDbFeature) via (TrivialFeature DomainRegistrationConfig)

instance ToSchema DomainRegistrationConfig where
  schema = object objectSchema

instance Default (LockableFeature DomainRegistrationConfig) where
  def = defLockedFeature

instance ToObjectSchema DomainRegistrationConfig where
  objectSchema = pure DomainRegistrationConfig

instance IsFeatureConfig DomainRegistrationConfig where
  type FeatureSymbol DomainRegistrationConfig = "domainRegistration"
  featureSingleton = FeatureSingletonDomainRegistrationConfig

--------------------------------------------------------------------------------
-- Cells feature

data CellsPropertyStatus = Enabled | Disabled | Enforced
  deriving (Show, Eq, Generic)
  deriving (ToJSON, FromJSON, S.ToSchema) via Schema CellsPropertyStatus
  deriving (Arbitrary) via (GenericUniform CellsPropertyStatus)

instance ToSchema CellsPropertyStatus where
  schema =
    enum @Text $
      mconcat
        [ element "enabled" Enabled,
          element "disabled" Disabled,
          element "enforced" Enforced
        ]

data CellsProperty = CellsProperty
  { enabled :: Bool,
    default_ :: CellsPropertyStatus
  }
  deriving (Show, Eq, Generic)
  deriving (ToJSON, FromJSON, S.ToSchema) via Schema CellsProperty
  deriving (Arbitrary) via (GenericUniform CellsProperty)

instance ToSchema CellsProperty where
  schema =
    object $
      CellsProperty
        <$> (.enabled) .= field "enabled" schema
        <*> (.default_) .= field "default" schema

data CellsUsers = CellsUsers
  { externals :: Bool,
    guests :: Bool
  }
  deriving (Show, Eq, Generic)
  deriving (ToJSON, FromJSON, S.ToSchema) via Schema CellsUsers
  deriving (Arbitrary) via (GenericUniform CellsUsers)

instance ToSchema CellsUsers where
  schema =
    object $
      CellsUsers
        <$> (.externals) .= field "externals" schema
        <*> (.guests) .= field "guests" schema

newtype CellsCollaboraStatus = CellsCollaboraStatus {enabled :: Bool}
  deriving (Show, Eq, Generic)
  deriving (ToJSON, FromJSON, S.ToSchema) via Schema CellsCollaboraStatus
  deriving (Arbitrary) via (GenericUniform CellsCollaboraStatus)

instance ToSchema CellsCollaboraStatus where
  schema =
    object $
      CellsCollaboraStatus
        <$> (.enabled) .= field "enabled" schema

data CellsPublicLinks = CellsPublicLinks
  { enableFiles :: Bool,
    enableFolders :: Bool,
    enforcePassword :: Bool,
    enforceExpirationMax :: Int64,
    enforceExpirationDefault :: Int64
  }
  deriving (Show, Eq, Generic)
  deriving (ToJSON, FromJSON, S.ToSchema) via Schema CellsPublicLinks
  deriving (Arbitrary) via (GenericUniform CellsPublicLinks)

instance ToSchema CellsPublicLinks where
  schema =
    object $
      CellsPublicLinks
        <$> enableFiles .= field "enableFiles" schema
        <*> enableFolders .= field "enableFolders" schema
        <*> enforcePassword .= field "enforcePassword" schema
        <*> enforceExpirationMax .= field "enforceExpirationMax" schema
        <*> enforceExpirationDefault .= field "enforceExpirationDefault" schema

data CellsRecycle = CellsRecycle
  { autoPurgeDays :: Int,
    disable :: Bool,
    allowSkip :: Bool
  }
  deriving (Show, Eq, Generic)
  deriving (ToJSON, FromJSON, S.ToSchema) via Schema CellsRecycle
  deriving (Arbitrary) via (GenericUniform CellsRecycle)

instance ToSchema CellsRecycle where
  schema =
    object $
      CellsRecycle
        <$> autoPurgeDays .= field "autoPurgeDays" schema
        <*> disable .= field "disable" schema
        <*> allowSkip .= field "allowSkip" schema

data CellsConfigStorage = CellsConfigStorage
  { perFileQuotaBytes :: NumBytes,
    recycle :: CellsRecycle
  }
  deriving (Eq, Show, Generic)
  deriving (ToJSON, FromJSON, S.ToSchema) via Schema CellsConfigStorage
  deriving (Arbitrary) via (GenericUniform CellsConfigStorage)

instance ToSchema CellsConfigStorage where
  schema =
    object $
      CellsConfigStorage
        <$> perFileQuotaBytes .= field "perFileQuotaBytes" schema
        <*> recycle .= field "recycle" schema

data CellsUserMetaTags = CellsUserMetaTags
  { defaultValues :: [Text],
    allowFreeValues :: Bool
  }
  deriving (Eq, Show, Generic)
  deriving (ToJSON, FromJSON, S.ToSchema) via Schema CellsUserMetaTags
  deriving (Arbitrary) via (GenericUniform CellsUserMetaTags)

instance ToSchema CellsUserMetaTags where
  schema =
    object $
      CellsUserMetaTags
        <$> defaultValues .= field "defaultValues" (array schema)
        <*> allowFreeValues .= field "allowFreeValues" schema

newtype CellsNamespaces = CellsNamespaces {usermetaTags :: CellsUserMetaTags}
  deriving (Eq, Show, Generic)
  deriving (ToJSON, FromJSON, S.ToSchema) via Schema CellsNamespaces
  deriving (Arbitrary) via (GenericUniform CellsNamespaces)

instance ToSchema CellsNamespaces where
  schema =
    object $
      CellsNamespaces
        <$> usermetaTags .= field "usermetaTags" schema

newtype CellsMetadata = CellsMetadata {namespaces :: CellsNamespaces}
  deriving (Eq, Show, Generic)
  deriving (ToJSON, FromJSON, S.ToSchema) via Schema CellsMetadata
  deriving (Arbitrary) via (GenericUniform CellsMetadata)

instance ToSchema CellsMetadata where
  schema =
    object $
      CellsMetadata
        <$> namespaces .= field "namespaces" schema

data CellsConfigB t f = CellsConfig
  { channels :: Wear t f CellsProperty,
    groups :: Wear t f CellsProperty,
    one2one :: Wear t f CellsProperty,
    users :: Wear t f CellsUsers,
    collabora :: Wear t f CellsCollaboraStatus,
    publicLinks :: Wear t f CellsPublicLinks,
    storage :: Wear t f CellsConfigStorage,
    metadata :: Wear t f CellsMetadata
  }
  deriving (Generic, BareB)

deriving instance FunctorB (CellsConfigB Covered)

deriving instance ApplicativeB (CellsConfigB Covered)

deriving instance TraversableB (CellsConfigB Covered)

type CellsConfig = CellsConfigB Bare Identity

deriving instance Eq CellsConfig

deriving instance Show CellsConfig

deriving via (RenderableTypeName CellsConfig) instance (RenderableSymbol CellsConfig)

deriving via (GenericUniform CellsConfig) instance (Arbitrary CellsConfig)

deriving via (BarbieFeature CellsConfigB) instance (ParseDbFeature CellsConfig)

deriving via (BarbieFeature CellsConfigB) instance (ToSchema CellsConfig)

instance Default CellsConfig where
  def =
    CellsConfig
      { channels = CellsProperty {enabled = True, default_ = Enabled},
        groups = CellsProperty {enabled = True, default_ = Enabled},
        one2one = CellsProperty {enabled = True, default_ = Enabled},
        users = CellsUsers {externals = True, guests = False},
        collabora = CellsCollaboraStatus {enabled = False},
        publicLinks =
          CellsPublicLinks
            { enableFiles = True,
              enableFolders = True,
              enforcePassword = False,
              enforceExpirationMax = 0,
              enforceExpirationDefault = 0
            },
        storage =
          CellsConfigStorage
            { perFileQuotaBytes = NumBytes $ BigIntString 100000000, -- 100MB
              recycle =
                CellsRecycle
                  { autoPurgeDays = 30,
                    disable = False,
                    allowSkip = False
                  }
            },
        metadata =
          CellsMetadata
            { namespaces =
                CellsNamespaces
                  { usermetaTags =
                      CellsUserMetaTags
                        { defaultValues = [],
                          allowFreeValues = True
                        }
                  }
            }
      }

instance (Typeable f, FieldF f) => ToSchema (CellsConfigB Covered f) where
  schema =
    objectWithDocModifier (S.schema . S.example ?~ schemaToJSON (def @CellsConfig)) $
      CellsConfig
        <$> channels .= fieldF "channels" schema
        <*> groups .= fieldF "groups" schema
        <*> one2one .= fieldF "one2one" schema
        <*> users .= fieldF "users" schema
        <*> (.collabora) .= fieldF "collabora" schema
        <*> publicLinks .= fieldF "publicLinks" schema
        <*> (.storage) .= fieldF "storage" schema
        <*> metadata .= fieldF "metadata" schema

instance ToSchema (Versioned V13 CellsConfig) where
  schema = object objectSchema

instance ToObjectSchema (Versioned V13 CellsConfig) where
  objectSchema = pure $ Versioned def

instance Default (LockableFeature CellsConfig) where
  def = defLockedFeature

instance ToObjectSchema CellsConfig where
  objectSchema = field "config" schema

instance IsFeatureConfig CellsConfig where
  type FeatureSymbol CellsConfig = "cells"
  featureSingleton = FeatureSingletonCellsConfig

----------------------------------------------------------------------
-- Cells Internal

data CollaboraEdition = No | Code | Cool
  deriving (Show, Eq, Generic)
  deriving (ToJSON, FromJSON, S.ToSchema) via Schema CollaboraEdition
  deriving (Arbitrary) via (GenericUniform CollaboraEdition)

instance ToSchema CollaboraEdition where
  schema =
    enum @Text $
      mconcat
        [ element "NO" No,
          element "CODE" Code,
          element "COOL" Cool
        ]

newtype CellsCollabora = CellsCollabora
  { edition :: CollaboraEdition
  }
  deriving (Show, Eq, Generic)
  deriving (ToJSON, FromJSON, S.ToSchema) via Schema CellsCollabora
  deriving (Arbitrary) via (GenericUniform CellsCollabora)

instance ToSchema CellsCollabora where
  schema =
    object $
      CellsCollabora
        <$> edition .= field "edition" schema

newtype CellsBackend = CellsBackend
  { url :: HttpsUrl
  }
  deriving (Show, Eq, Generic)
  deriving (ToJSON, FromJSON, S.ToSchema) via Schema CellsBackend
  deriving newtype (Arbitrary)

instance ToSchema CellsBackend where
  schema = object $ CellsBackend <$> url .= field "url" schema

newtype NumBytes = NumBytes {unNumBytes :: BigIntString}
  deriving newtype (Show, Eq)
  deriving (ToJSON, FromJSON, S.ToSchema) via Schema NumBytes

instance Arbitrary NumBytes where
  arbitrary = NumBytes . BigIntString <$> choose (0 :: Integer, 99999999999999999999999999)

instance ToSchema NumBytes where
  schema =
    NumBytes
      <$> unNumBytes
        .= withParser
          schema
          ( \n@(BigIntString i) -> do
              when (i < 0) $
                fail "numBytes must be non-negative"
              pure n
          )

data QuotaBytes
  = QuotaBytesFinite NumBytes
  | QuotaBytesUnlimited
  deriving stock (Show, Eq)

instance Arbitrary QuotaBytes where
  arbitrary =
    frequency
      [ (1, pure QuotaBytesUnlimited),
        (9, QuotaBytesFinite <$> arbitrary)
      ]

instance ToSchema QuotaBytes where
  schema = mkSchema quotaBytesDoc parseQuotaBytes quotaBytesToValue
    where
      quotaBytesDoc :: NamedSwaggerDoc
      quotaBytesDoc = swaggerDoc @Text & S.schema . S.example ?~ "-1"

      quotaBytesToValue :: QuotaBytes -> Maybe A.Value
      quotaBytesToValue QuotaBytesUnlimited = Just $ A.String "-1"
      quotaBytesToValue (QuotaBytesFinite n) = Just $ A.toJSON n

      parseQuotaBytes :: A.Value -> A.Parser QuotaBytes
      parseQuotaBytes = A.withText "QuotaBytes" $ \txt ->
        case TR.signed TR.decimal txt :: Either String (Integer, Text) of
          Left err -> fail err
          Right (n, rest) -> do
            unless (T.null rest) $
              fail "value must be an integer string without decimals"
            if n < 0
              then pure QuotaBytesUnlimited
              else QuotaBytesFinite <$> schemaParseJSON (A.String txt)

data CellsStorage = CellsStorage
  { totalLimitBytes :: Maybe QuotaBytes,
    perUserQuotaBytes :: QuotaBytes
  }
  deriving (Show, Eq, Generic)
  deriving (ToJSON, FromJSON, S.ToSchema) via Schema CellsStorage
  deriving (Arbitrary) via (GenericUniform CellsStorage)

instance ToSchema CellsStorage where
  schema =
    object $
      CellsStorage
        <$> totalLimitBytes .= maybe_ (optField "totalLimitBytes" schema)
        <*> perUserQuotaBytes .= field "perUserQuotaBytes" schema

data CellsInternalConfigB t f = CellsInternalConfig
  { backend :: Wear t f CellsBackend,
    collabora :: Wear t f CellsCollabora,
    storage :: Wear t f CellsStorage
  }
  deriving (Generic, BareB)

deriving instance FunctorB (CellsInternalConfigB Covered)

deriving instance ApplicativeB (CellsInternalConfigB Covered)

deriving instance TraversableB (CellsInternalConfigB Covered)

type CellsInternalConfig = CellsInternalConfigB Bare Identity

deriving instance Eq CellsInternalConfig

deriving instance Show CellsInternalConfig

deriving via (RenderableTypeName CellsInternalConfig) instance (RenderableSymbol CellsInternalConfig)

deriving via (GenericUniform CellsInternalConfig) instance (Arbitrary CellsInternalConfig)

deriving via (BarbieFeature CellsInternalConfigB) instance (ParseDbFeature CellsInternalConfig)

deriving via (BarbieFeature CellsInternalConfigB) instance (ToSchema CellsInternalConfig)

instance Default CellsInternalConfig where
  def =
    CellsInternalConfig
      { backend = CellsBackend $ HttpsUrl [URI.QQ.uri|https://cells-beta.wire.com|],
        collabora = CellsCollabora Cool,
        storage =
          CellsStorage
            { totalLimitBytes = Just $ QuotaBytesFinite $ NumBytes $ BigIntString 1000000000000, -- 1 TB
              perUserQuotaBytes = QuotaBytesUnlimited
            }
      }

instance (Typeable f, FieldF f) => ToSchema (CellsInternalConfigB Covered f) where
  schema =
    object $
      CellsInternalConfig
        <$> backend .= fieldF "backend" schema
        <*> (.collabora) .= fieldF "collabora" schema
        <*> (.storage) .= fieldF "storage" schema

instance Default (LockableFeature CellsInternalConfig) where
  def = defUnlockedFeature

instance ToObjectSchema CellsInternalConfig where
  objectSchema = field "config" schema

instance IsFeatureConfig CellsInternalConfig where
  type FeatureSymbol CellsInternalConfig = "cellsInternal"
  featureSingleton = FeatureSingletonCellsInternalConfig

--------------------------------------------------------------------------------
-- Allowed Global Operations feature

-- | This feature does not have a database state, see ClassifiedDomainsConfig.
data AllowedGlobalOperationsConfig = AllowedGlobalOperationsConfig
  { mlsConversationReset :: Bool
  }
  deriving (Show, Eq, Generic, GSOP.Generic)
  deriving (Arbitrary) via (GenericUniform AllowedGlobalOperationsConfig)
  deriving (ToJSON, FromJSON, S.ToSchema) via (Schema AllowedGlobalOperationsConfig)
  deriving (RenderableSymbol) via (RenderableTypeName AllowedGlobalOperationsConfig)

instance ParseDbFeature AllowedGlobalOperationsConfig where
  parseDbConfig _ = fail "AllowedGlobalOperationsConfig cannot be parsed from the DB"
  serialiseDbConfig = DbConfig . schemaToJSON

instance Default AllowedGlobalOperationsConfig where
  def = AllowedGlobalOperationsConfig {mlsConversationReset = False}

instance ToSchema AllowedGlobalOperationsConfig where
  schema =
    object $
      AllowedGlobalOperationsConfig
        <$> mlsConversationReset .= field "mlsConversationReset" schema

instance Default (LockableFeature AllowedGlobalOperationsConfig) where
  def = defLockedFeature {status = FeatureStatusEnabled}

instance ToObjectSchema AllowedGlobalOperationsConfig where
  objectSchema = field "config" schema

instance IsFeatureConfig AllowedGlobalOperationsConfig where
  type FeatureSymbol AllowedGlobalOperationsConfig = "allowedGlobalOperations"

  featureSingleton = FeatureSingletonAllowedGlobalOperationsConfig

--------------------------------------------------------------------------------
-- Asset Audit Log feature

-- | This feature does not have a database state and does not carry a config
-- payload. It is always locked; only its status can be toggled via server
-- configuration (Helm values).
data AssetAuditLogConfig = AssetAuditLogConfig
  deriving (Eq, Show, Generic, GSOP.Generic)
  deriving (Arbitrary) via (GenericUniform AssetAuditLogConfig)
  deriving (RenderableSymbol) via (RenderableTypeName AssetAuditLogConfig)

instance ParseDbFeature AssetAuditLogConfig where
  parseDbConfig _ = fail "AssetAuditLogConfig cannot be parsed from the DB"
  serialiseDbConfig = DbConfig . schemaToJSON

instance ToSchema AssetAuditLogConfig where
  schema = object objectSchema

instance Default AssetAuditLogConfig where
  def = AssetAuditLogConfig

instance Default (LockableFeature AssetAuditLogConfig) where
  def = defLockedFeature

instance ToObjectSchema AssetAuditLogConfig where
  objectSchema = pure AssetAuditLogConfig

instance IsFeatureConfig AssetAuditLogConfig where
  type FeatureSymbol AssetAuditLogConfig = "assetAuditLog"
  featureSingleton = FeatureSingletonAssetAuditLogConfig

--------------------------------------------------------------------------------
-- ConsumableNotifications feature

-- | This feature does not have a PUT endpoint. See Note [unsettable features].
data ConsumableNotificationsConfig = ConsumableNotificationsConfig
  deriving (Eq, Show, Generic, GSOP.Generic)
  deriving (Arbitrary) via (GenericUniform ConsumableNotificationsConfig)
  deriving (RenderableSymbol) via (RenderableTypeName ConsumableNotificationsConfig)
  deriving (Default, ParseDbFeature) via (TrivialFeature ConsumableNotificationsConfig)

instance ToSchema ConsumableNotificationsConfig where
  schema = object objectSchema

instance Default (LockableFeature ConsumableNotificationsConfig) where
  def = defLockedFeature

instance ToObjectSchema ConsumableNotificationsConfig where
  objectSchema = pure ConsumableNotificationsConfig

instance IsFeatureConfig ConsumableNotificationsConfig where
  type FeatureSymbol ConsumableNotificationsConfig = "consumableNotifications"
  featureSingleton = FeatureSingletonConsumableNotificationsConfig

--------------------------------------------------------------------------------
-- Chat Bubbles Feature

data ChatBubblesConfig = ChatBubblesConfig
  deriving (Eq, Show, Generic, GSOP.Generic)
  deriving (Arbitrary) via (GenericUniform ChatBubblesConfig)
  deriving (RenderableSymbol) via (RenderableTypeName ChatBubblesConfig)
  deriving (ParseDbFeature, Default) via TrivialFeature ChatBubblesConfig

instance ToSchema ChatBubblesConfig where
  schema = object objectSchema

instance Default (LockableFeature ChatBubblesConfig) where
  def = defLockedFeature

instance ToObjectSchema ChatBubblesConfig where
  objectSchema = pure ChatBubblesConfig

instance IsFeatureConfig ChatBubblesConfig where
  type FeatureSymbol ChatBubblesConfig = "chatBubbles"
  featureSingleton = FeatureSingletonChatBubblesConfig

-------------------------------------------------------------------------------
-- Apps Feature

data AppsConfig = AppsConfig
  deriving (Eq, Show, Generic, GSOP.Generic)
  deriving (Arbitrary) via (GenericUniform AppsConfig)
  deriving (RenderableSymbol) via (RenderableTypeName AppsConfig)
  deriving (ParseDbFeature, Default) via TrivialFeature AppsConfig

instance ToSchema AppsConfig where
  schema = object objectSchema

instance Default (LockableFeature AppsConfig) where
  def = defLockedFeature

instance ToObjectSchema AppsConfig where
  objectSchema = pure AppsConfig

instance IsFeatureConfig AppsConfig where
  type FeatureSymbol AppsConfig = "apps"
  featureSingleton = FeatureSingletonAppsConfig

--------------------------------------------------------------------------------
-- "Simplified User Connection Request QR Code" Feature
--
-- If it's enabled, clients render QR codes in the user profile pages to
-- simplify connection requests by other users.

data SimplifiedUserConnectionRequestQRCodeConfig = SimplifiedUserConnectionRequestQRCodeConfig
  deriving (Eq, Show, Generic, GSOP.Generic)
  deriving (Arbitrary) via (GenericUniform SimplifiedUserConnectionRequestQRCodeConfig)
  deriving (RenderableSymbol) via (RenderableTypeName SimplifiedUserConnectionRequestQRCodeConfig)
  deriving (ParseDbFeature, Default) via TrivialFeature SimplifiedUserConnectionRequestQRCodeConfig

instance ToSchema SimplifiedUserConnectionRequestQRCodeConfig where
  schema = object objectSchema

instance Default (LockableFeature SimplifiedUserConnectionRequestQRCodeConfig) where
  def = defUnlockedFeature

instance ToObjectSchema SimplifiedUserConnectionRequestQRCodeConfig where
  objectSchema = pure SimplifiedUserConnectionRequestQRCodeConfig

instance IsFeatureConfig SimplifiedUserConnectionRequestQRCodeConfig where
  type FeatureSymbol SimplifiedUserConnectionRequestQRCodeConfig = "simplifiedUserConnectionRequestQRCode"
  featureSingleton = FeatureSingletonSimplifiedUserConnectionRequestQRCodeConfig

--------------------------------------------------------------------------------
-- Stealth Users

data StealthUsersConfig = StealthUsersConfig
  deriving (Eq, Show, Generic, GSOP.Generic)
  deriving (Arbitrary) via (GenericUniform StealthUsersConfig)
  deriving (RenderableSymbol) via (RenderableTypeName StealthUsersConfig)
  deriving (ParseDbFeature, Default) via TrivialFeature StealthUsersConfig

instance ToSchema StealthUsersConfig where
  schema = object objectSchema

instance Default (LockableFeature StealthUsersConfig) where
  def = defLockedFeature

instance ToObjectSchema StealthUsersConfig where
  objectSchema = pure StealthUsersConfig

instance IsFeatureConfig StealthUsersConfig where
  type FeatureSymbol StealthUsersConfig = "stealthUsers"
  featureSingleton = FeatureSingletonStealthUsersConfig

--------------------------------------------------------------------------------
-- Meetings Feature
--
-- Controls whether meetings functionality is available. When enabled, users can
-- create and manage meetings. When disabled, meetings endpoints are not accessible.

data MeetingsConfig = MeetingsConfig
  deriving (Eq, Show, Generic, GSOP.Generic)
  deriving (Arbitrary) via (GenericUniform MeetingsConfig)
  deriving (RenderableSymbol) via (RenderableTypeName MeetingsConfig)
  deriving (ParseDbFeature, Default) via TrivialFeature MeetingsConfig

instance ToSchema MeetingsConfig where
  schema = object objectSchema

instance Default (LockableFeature MeetingsConfig) where
  def = defLockedFeature

instance IsFeatureConfig MeetingsConfig where
  type FeatureSymbol MeetingsConfig = "meetings"
  featureSingleton = FeatureSingletonMeetingsConfig

instance ToObjectSchema MeetingsConfig where
  objectSchema = pure MeetingsConfig

--------------------------------------------------------------------------------
-- MeetingPremium Feature
--
-- /Deprecated (WPB-26771)./ This feature flag no longer affects meeting
-- behaviour: team meetings are always non-trial. It is kept solely for API
-- compatibility (the public\/internal endpoints still exist) and defaults to
-- /enabled and locked/. Scheduled for removal in a future release.

{-# DEPRECATED MeetingsPremiumConfig "Deprecated (WPB-26771): no longer affects meeting trial status; kept for API compatibility." #-}

data MeetingsPremiumConfig = MeetingsPremiumConfig
  deriving (Eq, Show, Generic, GSOP.Generic)
  deriving (Arbitrary) via (GenericUniform MeetingsPremiumConfig)
  deriving (RenderableSymbol) via (RenderableTypeName MeetingsPremiumConfig)
  deriving (ParseDbFeature, Default) via TrivialFeature MeetingsPremiumConfig

instance ToSchema MeetingsPremiumConfig where
  schema = object objectSchema

instance Default (LockableFeature MeetingsPremiumConfig) where
  def = defLockedFeature {status = FeatureStatusEnabled}

instance IsFeatureConfig MeetingsPremiumConfig where
  type FeatureSymbol MeetingsPremiumConfig = "meetingsPremium"
  featureSingleton = FeatureSingletonMeetingsPremiumConfig

instance ToObjectSchema MeetingsPremiumConfig where
  objectSchema = pure MeetingsPremiumConfig

--------------------------------------------------------------------------------
-- BackgroundEffects Feature
--
-- Controls whether background effects are available in meetings.

data BackgroundEffectsConfig = BackgroundEffectsConfig
  deriving (Eq, Show, Generic, GSOP.Generic)
  deriving (Arbitrary) via (GenericUniform BackgroundEffectsConfig)
  deriving (RenderableSymbol) via (RenderableTypeName BackgroundEffectsConfig)
  deriving (ParseDbFeature, Default) via TrivialFeature BackgroundEffectsConfig

instance ToSchema BackgroundEffectsConfig where
  schema = object objectSchema

instance Default (LockableFeature BackgroundEffectsConfig) where
  def = defLockedFeature

instance IsFeatureConfig BackgroundEffectsConfig where
  type FeatureSymbol BackgroundEffectsConfig = "backgroundEffects"
  featureSingleton = FeatureSingletonBackgroundEffectsConfig

instance ToObjectSchema BackgroundEffectsConfig where
  objectSchema = pure BackgroundEffectsConfig

---------------------------------------------------------------------------------
-- FeatureStatus

data FeatureStatus
  = FeatureStatusEnabled
  | FeatureStatusDisabled
  deriving stock (Eq, Ord, Enum, Bounded, Show, Generic)
  deriving (Arbitrary) via (GenericUniform FeatureStatus)
  deriving (ToJSON, FromJSON, S.ToSchema) via (Schema FeatureStatus)

instance S.ToParamSchema FeatureStatus where
  toParamSchema _ =
    mempty
      { S._schemaType = Just S.OpenApiString,
        S._schemaEnum = Just (A.String . toQueryParam <$> [(minBound :: FeatureStatus) ..])
      }

instance FromHttpApiData FeatureStatus where
  parseUrlPiece =
    maybe (Left "must be 'enabled' or 'disabled'") Right
      . fromByteString'
      . fromStrict
      . T.encodeUtf8

instance ToHttpApiData FeatureStatus where
  toUrlPiece = T.decodeUtf8With lenientDecode . toByteString'

instance ToSchema FeatureStatus where
  schema =
    enum @Text $
      mconcat
        [ element "enabled" FeatureStatusEnabled,
          element "disabled" FeatureStatusDisabled
        ]

instance ToByteString FeatureStatus where
  builder FeatureStatusEnabled = "enabled"
  builder FeatureStatusDisabled = "disabled"

instance FromByteString FeatureStatus where
  parser =
    Parser.takeByteString >>= \b ->
      case T.decodeUtf8' b of
        Right "enabled" -> pure FeatureStatusEnabled
        Right "disabled" -> pure FeatureStatusDisabled
        Right t -> fail $ "Invalid FeatureStatus: " <> T.unpack t
        Left e -> fail $ "Invalid FeatureStatus: " <> show e

instance Cass.Cql FeatureStatus where
  ctype = Cass.Tagged Cass.IntColumn

  fromCql (Cass.CqlInt n) = mapLeft T.unpack $ postgresUnmarshall n
  fromCql _ = Left "fromCql: FeatureStatus: CqlInt expected"

  toCql = Cass.CqlInt . postgresMarshall

instance PostgresMarshall Int32 FeatureStatus where
  postgresMarshall = \case
    FeatureStatusDisabled -> 0
    FeatureStatusEnabled -> 1

instance PostgresUnmarshall Int32 FeatureStatus where
  postgresUnmarshall = \case
    0 -> Right FeatureStatusDisabled
    1 -> Right FeatureStatusEnabled
    n -> Left $ "Invalid FeatureStatus: " <> T.pack (show n)

-- | list of available features config types
type Features :: [Type]
type Features =
  [ LegalholdConfig,
    SSOConfig,
    SearchVisibilityAvailableConfig,
    SearchVisibilityInboundConfig,
    RequireExternalEmailVerificationConfig,
    DigitalSignaturesConfig,
    AppLockConfig,
    FileSharingConfig,
    ClassifiedDomainsConfig,
    ConferenceCallingConfig,
    SelfDeletingMessagesConfig,
    GuestLinksConfig,
    SndFactorPasswordChallengeConfig,
    MLSConfig,
    ExposeInvitationURLsToTeamAdminConfig,
    OutlookCalIntegrationConfig,
    MlsE2EIdConfig,
    MlsMigrationConfig,
    EnforceFileDownloadLocationConfig,
    LimitedEventFanoutConfig,
    DomainRegistrationConfig,
    ChannelsConfig,
    PreventAdminlessGroupsConfig,
    CellsConfig,
    AllowedGlobalOperationsConfig,
    ConsumableNotificationsConfig,
    ChatBubblesConfig,
    AppsConfig,
    SimplifiedUserConnectionRequestQRCodeConfig,
    AssetAuditLogConfig,
    StealthUsersConfig,
    CellsInternalConfig,
    MeetingsConfig,
    MeetingsPremiumConfig,
    BackgroundEffectsConfig
  ]

-- | list of available features as a record
type AllFeatures f = NP f Features

-- | 'AllFeatures' specialised to the 'LockableFeature' functor
type AllTeamFeatures = AllFeatures LockableFeature

class (Default (LockableFeature cfg)) => LockableFeatureDefault cfg

instance (Default (LockableFeature cfg)) => LockableFeatureDefault cfg

instance Default AllTeamFeatures where
  def = hcpure (Proxy @LockableFeatureDefault) def

-- | object schema for nary products
class HObjectSchema c xs where
  hobjectSchema :: (forall cfg. (c cfg) => ObjectSchema SwaggerDoc (f cfg)) -> ObjectSchema SwaggerDoc (NP f xs)

instance HObjectSchema c '[] where
  hobjectSchema _ = pure Nil

instance (HObjectSchema c xs, c x) => HObjectSchema c ((x :: Type) : xs) where
  hobjectSchema f = (:*) <$> hd .= f <*> tl .= hobjectSchema @c @xs f

-- | constraint synonym  for 'ToSchema' 'AllTeamFeatures'
class (Typeable cfg, IsFeatureConfig cfg, ToSchema cfg) => FeatureFieldConstraints cfg

instance (Typeable cfg, IsFeatureConfig cfg, ToSchema cfg) => FeatureFieldConstraints cfg

instance ToSchema AllTeamFeatures where
  schema =
    object $ hobjectSchema @FeatureFieldConstraints featureField
    where
      featureField ::
        forall cfg.
        (FeatureFieldConstraints cfg) =>
        ObjectSchema SwaggerDoc (LockableFeature cfg)
      featureField = field (T.pack (symbolVal (Proxy @(FeatureSymbol cfg)))) schema

class (Arbitrary cfg, IsFeatureConfig cfg) => ArbitraryFeatureConfig cfg

instance (Arbitrary cfg, IsFeatureConfig cfg) => ArbitraryFeatureConfig cfg

instance Arbitrary AllTeamFeatures where
  arbitrary = hsequence' $ hcpure (Proxy @ArbitraryFeatureConfig) (Comp arbitrary)

-- | FUTUREWORK: 'NpProject' and 'NpUpdate' can be useful for more than
-- features. Maybe they should be moved somewhere else.
class NpProject x xs where
  npProject' :: Proxy x -> NP f xs -> f x

instance {-# OVERLAPPING #-} NpProject x (x : xs) where
  npProject' _ (x :* _) = x

instance (NpProject x xs) => NpProject x (y : xs) where
  npProject' p (_ :* xs) = npProject' p xs

instance (TypeError ('ShowType x :<>: 'Text " not found in the Features list")) => NpProject x '[] where
  npProject' = error "npProject': someone naughty removed the type error constraint"

-- | Get the first field of a given type out of an @'NP' f xs@.
npProject :: forall x f xs. (NpProject x xs) => NP f xs -> f x
npProject = npProject' (Proxy @x)

class NpUpdate x xs where
  npUpdate' :: Proxy x -> f x -> NP f xs -> NP f xs

instance {-# OVERLAPPING #-} NpUpdate x (x : xs) where
  npUpdate' _ x (_ :* xs) = x :* xs

instance (NpUpdate x xs) => NpUpdate x (y : xs) where
  npUpdate' p x (y :* xs) = y :* npUpdate' p x xs

instance (TypeError ('ShowType x :<>: 'Text " not found in the Features list")) => NpUpdate x '[] where
  npUpdate' = error "npUpdate': someone naughty removed the type error constraint"

-- | Update the first field of a given type in an @'NP' f xs@.
npUpdate :: forall x f xs. (NpUpdate x xs) => f x -> NP f xs -> NP f xs
npUpdate = npUpdate' (Proxy @x)

deriving via (Schema AllTeamFeatures) instance (FromJSON AllTeamFeatures)

deriving via (Schema AllTeamFeatures) instance (ToJSON AllTeamFeatures)

deriving via (Schema AllTeamFeatures) instance (S.ToSchema AllTeamFeatures)

--------------------------------------------------------------------------------
-- DB feature parsing

-- Note [default values for configuration fields]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
--
-- When reading values for configuration types with multiple fields, we fall
-- back to default values for each field independently, instead of treating the
-- whole configuration as a single value that can be set or not.
--
-- In most cases, either strategy would produce the same result, because there
-- is no way to set only *some* fields using the public API. However, that can
-- happen when a feature flag changes over time and gains new fields, as it has
-- been the case for mlsE2EId.
--
-- Therefore, we use the first strategy consistently for all feature flags,
-- even when it does not matter.

class ParseDbFeature cfg where
  parseDbConfig :: DbConfig -> A.Parser (cfg -> cfg)
  serialiseDbConfig :: cfg -> DbConfig

newtype TrivialFeature cfg = TrivialFeature cfg

instance (GSOP.IsProductType cfg '[]) => ParseDbFeature (TrivialFeature cfg) where
  parseDbConfig _ = pure id
  serialiseDbConfig _ = def

instance (GSOP.IsProductType cfg '[]) => Default (TrivialFeature cfg) where
  def = TrivialFeature (GSOP.productTypeTo Nil)

newtype BarbieFeature b = BarbieFeature {unBarbieFeature :: b Bare Identity}

instance
  ( BareB b,
    ApplicativeB (b Covered),
    ToSchema (b Covered Maybe)
  ) =>
  ParseDbFeature (BarbieFeature b)
  where
  parseDbConfig (DbConfig v) = do
    cfg <- schemaParseJSON v
    pure $ \(BarbieFeature defCfg) -> BarbieFeature (applyConfig defCfg cfg)
    where
      f :: Maybe a -> Identity a -> Identity a
      f m (Identity x) = Identity $ fromMaybe x m

      applyConfig :: b Bare Identity -> b Covered Maybe -> b Bare Identity
      applyConfig cfg1 cfg2 = bstrip $ bzipWith f cfg2 (bcover cfg1)
  serialiseDbConfig =
    DbConfig
      . schemaToJSON
      . bmap (Just . runIdentity)
      . bcover
      . unBarbieFeature

instance (BareB b, ToSchema (b Covered Identity)) => ToSchema (BarbieFeature b) where
  schema = (bcover . unBarbieFeature) .= fmap (BarbieFeature . bstrip) schema

parseDbFeature ::
  forall cfg.
  (ParseDbFeature cfg) =>
  LockableFeaturePatch DbConfig ->
  A.Parser (DbFeature cfg)
parseDbFeature feat =
  do
    f <- maybe (pure id) parseDbConfig feat.config
    pure $
      foldMap dbFeatureStatus feat.status
        <> foldMap dbFeatureLockStatus feat.lockStatus
        <> dbFeatureModConfig f

serialiseDbFeature :: (IsFeatureConfig cfg) => LockableFeature cfg -> LockableFeaturePatch DbConfig
serialiseDbFeature feat =
  LockableFeaturePatch
    { status = Just feat.status,
      lockStatus = Just feat.lockStatus,
      config = Just $ serialiseDbConfig feat.config
    }

-- | Convert a map indexed by feature name to an NP value.
mkAllFeatures ::
  forall cfgs.
  ( All IsFeatureConfig cfgs,
    All ParseDbFeature cfgs
  ) =>
  Map Text (LockableFeaturePatch DbConfig) ->
  A.Parser (NP DbFeature cfgs)
mkAllFeatures m =
  hctraverse' (Proxy @ParseDbFeature) (parseDbFeature . unK) $
    hcpure (Proxy @IsFeatureConfig) get
  where
    get :: forall cfg. (IsFeatureConfig cfg) => K (LockableFeaturePatch DbConfig) cfg
    get = K $ M.findWithDefault def (featureName @cfg) m

isCellsFeatureConfigEvent :: forall cfg. (IsFeatureConfig cfg) => Bool
isCellsFeatureConfigEvent =
  featureName @cfg `elem` [featureName @CellsConfig, featureName @CellsInternalConfig]

--------------------------------------------------------------------------------
-- Team Feature Migration

data TeamFeatureMigrationState = MigrationNotStarted | MigrationInProgress | MigrationCompleted
  deriving stock (Eq, Show, Generic)
  deriving (Arbitrary) via (GenericUniform TeamFeatureMigrationState)
  deriving (FromJSON, ToJSON, S.ToSchema) via (Schema TeamFeatureMigrationState)

instance Default TeamFeatureMigrationState where
  def = MigrationNotStarted

instance ToSchema TeamFeatureMigrationState where
  schema =
    enum @Text $
      mconcat
        [ element "not_started" MigrationNotStarted,
          element "in_progress" MigrationInProgress,
          element "completed" MigrationCompleted
        ]

instance Cass.Cql TeamFeatureMigrationState where
  ctype = Cass.Tagged Cass.IntColumn

  fromCql (Cass.CqlInt n) = case n of
    0 -> pure MigrationNotStarted
    1 -> pure MigrationInProgress
    2 -> pure MigrationCompleted
    _ -> Left "fromCql: Invalid TeamFeatureMigrationState value"
  fromCql _ = Left "fromCql: TeamFeatureMigrationState: CqlInt or CqlNull expected"

  toCql MigrationNotStarted = Cass.CqlInt 0
  toCql MigrationInProgress = Cass.CqlInt 1
  toCql MigrationCompleted = Cass.CqlInt 2

--------------------------------------------------------------------------------
-- ConfiguredFeatureFlags

-- | Reflects feature flags (it is a placeholder for 'FeatureFlags' in 'Wire.API.Team.FeatureFlags', which would be costly to generate)
newtype ConfiguredFeatureFlags = ConfiguredFeatureFlags {unConfiguredFeatureFlags :: A.Value}
  deriving stock (Eq, Show, Generic)
  deriving (Arbitrary) via (GenericUniform ConfiguredFeatureFlags)
  deriving (FromJSON, ToJSON, S.ToSchema) via (Schema ConfiguredFeatureFlags)

instance ToSchema ConfiguredFeatureFlags where
  schema = named "ConfiguredFeatureFlags" $ coerce jsonValue
