{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE StrictData #-}

-- 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.User.Client
  ( -- * ClientCapability
    ClientCapability (..),
    ClientCapabilityList (..),

    -- * ClientInfo
    ClientInfo (..),

    -- * UserClients
    UserClientMap (..),
    UserClientPrekeyMap (..),
    mkUserClientPrekeyMap,
    QualifiedUserClientMap (..),
    QualifiedUserClientPrekeyMap (..),
    QualifiedUserClientPrekeyMapV4 (..),
    mkQualifiedUserClientPrekeyMap,
    qualifiedUserClientPrekeyMapFromList,
    UserClientsFull (..),
    UserClients (..),
    mkUserClients,
    QualifiedUserClients (..),
    qualifiedUserClientsValueSchema,
    filterClients,
    filterClientsFull,

    -- * Client
    Client (..),
    clientSchema,
    PubClient (..),
    toPubClient,
    ClientType (..),
    ClientClass (..),
    MLSPublicKeys,
    supportsConsumableNotifications,

    -- * New/Update/Remove Client
    NewClient (..),
    newClient,
    UpdateClient (..),
    defUpdateClient,
    RmClient (..),

    -- * re-exports
    Latitude (..),
    Longitude (..),

    -- * List of MLS client ids
    ClientList (..),
  )
where

import Cassandra qualified as C
import Control.Applicative
import Control.Lens hiding (element, enum, set, (#), (.=))
import Data.Aeson (FromJSON (..), ToJSON (..))
import Data.Aeson qualified as A
import Data.Aeson.Key qualified as Key
import Data.Aeson.KeyMap qualified as KeyMap
import Data.Bifunctor (second)
import Data.Code qualified as Code
import Data.Coerce
import Data.Domain (Domain)
import Data.Id
import Data.Json.Util
import Data.Map.Strict qualified as Map
import Data.Misc (Latitude (..), Longitude (..), PlainTextPassword6)
import Data.OpenApi hiding (Schema, ToSchema, nullable, schema)
import Data.OpenApi qualified as Swagger hiding (nullable)
import Data.Qualified
import Data.SOP hiding (fn)
import Data.Schema
import Data.Set qualified as Set
import Data.Text.Encoding qualified as T
import Data.Time.Clock
import Data.UUID (toASCIIBytes)
import Deriving.Swagger
  ( CustomSwagger,
    FieldLabelModifier,
    LowerCase,
    StripPrefix,
  )
import Imports
import Wire.API.MLS.CipherSuite
import Wire.API.Routes.MultiVerb
import Wire.API.Routes.Version
import Wire.API.Routes.Versioned
import Wire.API.User.Auth
import Wire.API.User.Client.Prekey as Prekey
import Wire.Arbitrary (Arbitrary (arbitrary), GenericUniform (..), generateExample, mapOf', setOf')

----------------------------------------------------------------------
-- ClientCapability, ClientCapabilityList

-- | Names of capabilities clients can claim to support in order to be treated differently by
-- the backend.
--
-- **The cost of capability keywords**
--
-- Avoid this wherever possible.  Adding capability keywords in the backend code makes testing
-- exponentially more expensive (in principle, you should always test all combinations of
-- supported capabilitiess.  But even if you only test those known to occur in the wild, it will
-- still make your life harder.)
--
-- Consider dropping support for clients without ancient capabilitiess if you have "enough" clients
-- that are younger.  This will always be disruptive for a minority of users, but maybe this
-- can be mitigated by giving those users clear feedback that they need to upgrade in order to
-- get their expected UX back.
--
-- **An alternative design**
--
-- Consider replacing 'ClientCapability' with platform and version in formation (I
-- played with @data Platform = Android | IOS | WebApp | TeamSettings | AccountPages@ and
-- @Version@ from the `semver` package in https://github.com/wireapp/wire-server/pull/1503,
-- but ended up deciding against it).  This data could be passed in a similar way as the
-- 'ClientCapabilityList' is now (similar end-point, different path, different body
-- type), and the two approaches could be used in parallel indefinitely.
--
-- Capability keywords reveal the minimum amount of information necessary to handle the client,
-- making it harder to fingerprint and track clients; they are straight-forward and
-- self-documenting (to an extent), and make it easier to release a capability on the backend and
-- clients independently.
--
-- Platform/version info is if you have many different capability keywords, even though it
-- doesn't solve the problem of having to explore the entire capability space in your tests.
-- They give you a better idea of the time line, and how to gently discontinue support for
-- ancient capabilities.
data ClientCapability
  = -- | Clients have minimum support for LH, but not for explicit consent.  Implicit consent
    -- is granted via the galley server config and cassandra table `galley.legalhold_whitelisted`.
    ClientSupportsLegalholdImplicitConsent
  | ClientSupportsConsumableNotifications
  deriving stock (Eq, Ord, Bounded, Enum, Show, Generic)
  deriving (Arbitrary) via (GenericUniform ClientCapability)
  deriving (ToJSON, FromJSON, Swagger.ToSchema) via Schema ClientCapability

instance ToSchema ClientCapability where
  schema =
    enum @Text $
      element "legalhold-implicit-consent" ClientSupportsLegalholdImplicitConsent
        <> element "consumable-notifications" ClientSupportsConsumableNotifications

data ClientCapabilityV7 = ClientSupportsLegalholdImplicitConsentV7
  deriving (Eq)

capabilitySchemaV7 :: ValueSchema NamedSwaggerDoc ClientCapabilityV7
capabilitySchemaV7 =
  enum @Text $
    element "legalhold-implicit-consent" ClientSupportsLegalholdImplicitConsentV7

clientCapabilityFromV7 :: ClientCapabilityV7 -> ClientCapability
clientCapabilityFromV7 ClientSupportsLegalholdImplicitConsentV7 = ClientSupportsLegalholdImplicitConsent

instance C.Cql ClientCapability where
  ctype = C.Tagged C.IntColumn

  toCql ClientSupportsLegalholdImplicitConsent = C.CqlInt 1
  toCql ClientSupportsConsumableNotifications = C.CqlInt 2

  fromCql (C.CqlInt i) = case i of
    1 -> pure ClientSupportsLegalholdImplicitConsent
    2 -> pure ClientSupportsConsumableNotifications
    n -> Left $ "Unexpected ClientCapability value: " ++ show n
  fromCql _ = Left "ClientCapability value: int expected"

-- FUTUREWORK: add golden tests for this?
newtype ClientCapabilityList = ClientCapabilityList {fromClientCapabilityList :: Set ClientCapability}
  deriving stock (Eq, Ord, Show, Generic)
  deriving newtype (Semigroup, Monoid)
  deriving (Arbitrary) via (GenericUniform ClientCapabilityList)
  deriving (ToJSON, FromJSON, Swagger.ToSchema) via (Schema ClientCapabilityList)

instance ToSchema ClientCapabilityList where
  schema = capabilitiesSchema Nothing

instance ToSchema (Versioned V6 ClientCapabilityList) where
  schema =
    object $
      Versioned
        <$> unVersioned .= field "capabilities" (capabilitiesSchema (Just V6))

instance ToSchema (Versioned V7 ClientCapabilityList) where
  schema =
    Versioned
      <$> unVersioned .= capabilitiesSchema (Just V7)

capabilitiesSchema ::
  Maybe Version ->
  ValueSchema NamedSwaggerDoc ClientCapabilityList
capabilitiesSchema mVersion =
  named (versionedName mVersion "ClientCapabilityList") $
    ClientCapabilityList
      <$> (Set.toList . fromClientCapabilityList) .= (Set.fromList <$> listSchema)
  where
    listSchema :: ValueSchema SwaggerDoc [ClientCapability]
    listSchema =
      case mVersion of
        Just v
          | v <= V7 ->
              map clientCapabilityFromV7
                <$> mapMaybe toCapabilityV7 .= array (capabilitySchemaV7)
        _ -> array schema

    toCapabilityV7 :: ClientCapability -> Maybe ClientCapabilityV7
    toCapabilityV7 ClientSupportsConsumableNotifications = Nothing
    toCapabilityV7 ClientSupportsLegalholdImplicitConsent = Just ClientSupportsLegalholdImplicitConsentV7

--------------------------------------------------------------------------------
-- UserClientMap

newtype UserClientMap a = UserClientMap
  { userClientMap :: Map UserId (Map ClientId a)
  }
  deriving stock (Eq, Show, Functor, Foldable, Traversable)
  deriving newtype (Semigroup, Monoid)
  deriving (FromJSON, ToJSON, Swagger.ToSchema) via Schema (UserClientMap a)

instance (ToSchema a) => ToSchema (UserClientMap a) where
  schema = userClientMapSchema schema

class WrapName doc where
  wrapName :: doc -> (Text -> Text) -> SwaggerDoc -> doc

instance WrapName SwaggerDoc where
  wrapName _ _ = id

instance WrapName NamedSwaggerDoc where
  wrapName d f = fmap (Swagger.NamedSchema (Just (f (maybe "" ("_" <>) (getName d)))))

userClientMapSchema ::
  (WrapName doc, HasSchemaRef doc) =>
  ValueSchema doc a ->
  ValueSchema doc (UserClientMap a)
userClientMapSchema sch =
  over doc (wrapName (schemaDoc sch) ("UserClientMap" <>)) $
    UserClientMap <$> userClientMap .= map_ (map_ sch)

newtype UserClientPrekeyMap = UserClientPrekeyMap
  {getUserClientPrekeyMap :: UserClientMap (Maybe UncheckedPrekeyBundle)}
  deriving stock (Eq, Show)
  deriving newtype (Arbitrary, Semigroup, Monoid)
  deriving (FromJSON, ToJSON, Swagger.ToSchema) via Schema UserClientPrekeyMap

mkUserClientPrekeyMap :: Map UserId (Map ClientId (Maybe UncheckedPrekeyBundle)) -> UserClientPrekeyMap
mkUserClientPrekeyMap = coerce

instance ToSchema UserClientPrekeyMap where
  schema = UserClientPrekeyMap <$> getUserClientPrekeyMap .= addDoc sch
    where
      sch =
        named "UserClientPrekeyMap" $
          userClientMapSchema (nullable (unnamed schema))
      addDoc =
        Swagger.schema . Swagger.example
          ?~ toJSON
            ( Map.singleton
                (generateExample @UserId)
                ( Map.singleton
                    (ClientId 4940483633899001999)
                    (Just (UncheckedPrekeyBundle (PrekeyId 1) "pQABAQECoQBYIOjl7hw0D8YRNq..."))
                )
            )

instance (Arbitrary a) => Arbitrary (UserClientMap a) where
  arbitrary = UserClientMap <$> mapOf' arbitrary (mapOf' arbitrary arbitrary)

newtype QualifiedUserClientMap a = QualifiedUserClientMap
  { qualifiedUserClientMap :: Map Domain (Map UserId (Map ClientId a))
  }
  deriving stock (Eq, Show, Functor)
  deriving (FromJSON, ToJSON, Swagger.ToSchema) via Schema (QualifiedUserClientMap a)

instance (Semigroup a) => Semigroup (QualifiedUserClientMap a) where
  (QualifiedUserClientMap m1) <> (QualifiedUserClientMap m2) =
    QualifiedUserClientMap $ Map.unionWith (Map.unionWith (Map.unionWith (<>))) m1 m2

instance (Semigroup (QualifiedUserClientMap a)) => Monoid (QualifiedUserClientMap a) where
  mempty = QualifiedUserClientMap mempty

instance (Arbitrary a) => Arbitrary (QualifiedUserClientMap a) where
  arbitrary = QualifiedUserClientMap <$> mapOf' arbitrary (mapOf' arbitrary (mapOf' arbitrary arbitrary))

instance (ToSchema a) => ToSchema (QualifiedUserClientMap a) where
  schema = qualifiedUserClientMapSchema schema

qualifiedUserClientMapSchema ::
  ValueSchema NamedSwaggerDoc a ->
  ValueSchema NamedSwaggerDoc (QualifiedUserClientMap a)
qualifiedUserClientMapSchema sch =
  addDoc . named nm $
    QualifiedUserClientMap <$> qualifiedUserClientMap .= map_ (map_ (map_ sch))
  where
    innerSchema = userClientMapSchema sch
    nm = "QualifiedUserClientMap" <> maybe "" ("_" <>) (getName (schemaDoc sch))
    addDoc =
      Swagger.schema . Swagger.example
        ?~ toJSON
          ( Map.singleton
              ("domain1.example.com" :: Text)
              (schemaDoc innerSchema ^. Swagger.schema . Swagger.example)
          )

data QualifiedUserClientPrekeyMapV4 = QualifiedUserClientPrekeyMapV4
  { qualifiedUserClientPrekeys :: QualifiedUserClientMap (Maybe UncheckedPrekeyBundle),
    failedToList :: Maybe [Qualified UserId]
  }
  deriving stock (Eq, Show)
  deriving (FromJSON, ToJSON, Swagger.ToSchema) via Schema QualifiedUserClientPrekeyMapV4

instance Arbitrary QualifiedUserClientPrekeyMapV4 where
  arbitrary =
    QualifiedUserClientPrekeyMapV4
      <$> arbitrary
      <*> arbitrary

instance ToSchema QualifiedUserClientPrekeyMapV4 where
  schema =
    object $
      QualifiedUserClientPrekeyMapV4
        <$> fmap to' (from' .= field "qualified_user_client_prekeys" (map_ schema))
        <*> failedToList .= maybe_ (optField "failed_to_list" (array schema))
    where
      from' :: QualifiedUserClientPrekeyMapV4 -> Map Domain UserClientPrekeyMap
      from' = coerce . qualifiedUserClientPrekeys
      to' :: Map Domain UserClientPrekeyMap -> QualifiedUserClientMap (Maybe UncheckedPrekeyBundle)
      to' = coerce

newtype QualifiedUserClientPrekeyMap = QualifiedUserClientPrekeyMap
  { getQualifiedUserClientPrekeyMap :: QualifiedUserClientMap (Maybe UncheckedPrekeyBundle)
  }
  deriving stock (Eq, Show)
  deriving newtype (Arbitrary)
  deriving (FromJSON, ToJSON, Swagger.ToSchema) via Schema QualifiedUserClientPrekeyMap
  deriving (Semigroup, Monoid) via (QualifiedUserClientMap (Alt Maybe UncheckedPrekeyBundle))

instance ToSchema QualifiedUserClientPrekeyMap where
  schema =
    named "QualifiedUserClientPrekeyMap" $
      mkQualifiedUserClientPrekeyMap <$> unmk .= map_ schema
    where
      unmk :: QualifiedUserClientPrekeyMap -> Map Domain UserClientPrekeyMap
      unmk = coerce

mkQualifiedUserClientPrekeyMap :: Map Domain UserClientPrekeyMap -> QualifiedUserClientPrekeyMap
mkQualifiedUserClientPrekeyMap = coerce

qualifiedUserClientPrekeyMapFromList ::
  [Qualified UserClientPrekeyMap] ->
  QualifiedUserClientPrekeyMap
qualifiedUserClientPrekeyMapFromList =
  mkQualifiedUserClientPrekeyMap . Map.fromList . map qToPair

--------------------------------------------------------------------------------
-- ClientInfo

-- | A client, together with extra information about it relative to a given ciphersuite.
data ClientInfo = ClientInfo
  { -- | The ID of this client.
    clientId :: ClientId,
    -- | The signature key for the given ciphersuite.
    mlsSignatureKey :: Maybe ByteString,
    -- | Whether this client has any key packages for the given ciphersuite.
    hasKeyPackages :: Bool
  }
  deriving stock (Eq, Ord, Show)
  deriving (Swagger.ToSchema, FromJSON, ToJSON) via Schema ClientInfo

instance ToSchema ClientInfo where
  schema =
    object $
      ClientInfo
        <$> (.clientId) .= field "id" schema
        <*> (.mlsSignatureKey) .= maybe_ (optField "mls_signature_key" base64Schema)
        <*> (.hasKeyPackages) .= field "mls" schema

--------------------------------------------------------------------------------
-- UserClients

newtype UserClientsFull = UserClientsFull
  { userClientsFull :: Map UserId (Set Client)
  }
  deriving stock (Eq, Show, Generic)
  deriving newtype (Semigroup, Monoid)

-- | Json rendering of `UserClientsFull` is dynamic in the object fields, so it's unclear how
-- machine-generated swagger would look like.  We just leave the manual aeson instances in
-- place and write something in English into the docs here.
instance Swagger.ToSchema UserClientsFull where
  declareNamedSchema _ = do
    pure $
      NamedSchema (Just "UserClientsFull") $
        mempty
          & type_ ?~ OpenApiObject
          & description ?~ "Dictionary object of `Client` objects indexed by `UserId`."
          & example ?~ "{\"1355c55a-0ac8-11ee-97ee-db1a6351f093\": <Client object>, ...}"

instance ToJSON UserClientsFull where
  toJSON =
    toJSON . Map.foldrWithKey' fn Map.empty . userClientsFull
    where
      fn u c m =
        let k = T.decodeLatin1 (toASCIIBytes (toUUID u))
         in Map.insert k c m

instance FromJSON UserClientsFull where
  parseJSON =
    A.withObject "UserClientsFull" (fmap UserClientsFull . foldrM fn Map.empty . KeyMap.toList)
    where
      fn (k, v) m = Map.insert <$> parseJSON (A.String $ Key.toText k) <*> parseJSON v <*> pure m

instance Arbitrary UserClientsFull where
  arbitrary = UserClientsFull <$> mapOf' arbitrary (setOf' arbitrary)

newtype UserClients = UserClients
  { userClients :: Map UserId (Set ClientId)
  }
  deriving stock (Eq, Show, Generic)
  deriving newtype (Semigroup, Monoid)
  deriving (ToJSON, FromJSON, Swagger.ToSchema) via Schema UserClients

mkUserClients :: [(UserId, [ClientId])] -> UserClients
mkUserClients xs = UserClients $ Map.fromList (xs <&> second Set.fromList)

instance ToSchema UserClients where
  schema =
    addDoc . named "UserClients" $ UserClients <$> userClients .= map_ (set schema)
    where
      addDoc sch =
        sch
          & Swagger.schema . Swagger.description ?~ "Map of user id to list of client ids."
          & Swagger.schema . Swagger.example
            ?~ toJSON
              ( Map.fromList
                  [ (generateExample @UserId, [ClientId 1684636986166846496, ClientId 4940483633899001999]),
                    (generateExample @UserId, [ClientId 6987438498444556166, ClientId 7940473633839002939])
                  ]
              )

instance Arbitrary UserClients where
  arbitrary = UserClients <$> mapOf' arbitrary (setOf' arbitrary)

filterClients :: (Set ClientId -> Bool) -> UserClients -> UserClients
filterClients p (UserClients c) = UserClients $ Map.filter p c

filterClientsFull :: (Set Client -> Bool) -> UserClientsFull -> UserClientsFull
filterClientsFull p (UserClientsFull c) = UserClientsFull $ Map.filter p c

newtype QualifiedUserClients = QualifiedUserClients
  { qualifiedUserClients :: Map Domain (Map UserId (Set ClientId))
  }
  deriving stock (Eq, Show, Generic)
  deriving (FromJSON, ToJSON, Swagger.ToSchema) via (Schema QualifiedUserClients)

instance Semigroup QualifiedUserClients where
  (QualifiedUserClients m1) <> (QualifiedUserClients m2) =
    QualifiedUserClients $ Map.unionWith (Map.unionWith (<>)) m1 m2

instance Monoid QualifiedUserClients where
  mempty = QualifiedUserClients mempty

instance Arbitrary QualifiedUserClients where
  arbitrary = QualifiedUserClients <$> mapOf' arbitrary (mapOf' arbitrary (setOf' arbitrary))

qualifiedUserClientsValueSchema :: ValueSchema SwaggerDoc QualifiedUserClients
qualifiedUserClientsValueSchema =
  QualifiedUserClients <$> qualifiedUserClients .= map_ (map_ (set schema))

instance ToSchema QualifiedUserClients where
  schema =
    addDoc . named "QualifiedUserClients" $ qualifiedUserClientsValueSchema
    where
      addDoc sch =
        sch
          & Swagger.schema . Swagger.description ?~ "Map of Domain to UserClients"
          & Swagger.schema . Swagger.example
            ?~ toJSON
              ( Map.singleton
                  ("domain1.example.com" :: Text)
                  (view (Swagger.schema . Swagger.example) (schema @UserClients))
              )

--------------------------------------------------------------------------------
-- Client

data Client = Client
  { clientId :: ClientId,
    clientType :: ClientType,
    clientTime :: UTCTimeMillis,
    clientClass :: Maybe ClientClass,
    clientLabel :: Maybe Text,
    clientCookie :: Maybe CookieLabel,
    clientModel :: Maybe Text,
    clientCapabilities :: ClientCapabilityList,
    clientMLSPublicKeys :: MLSPublicKeys,
    clientLastActive :: Maybe UTCTime
  }
  deriving stock (Eq, Show, Generic, Ord)
  deriving (Arbitrary) via (GenericUniform Client)
  deriving (FromJSON, ToJSON, Swagger.ToSchema) via Schema Client

type MLSPublicKeys = Map SignatureSchemeTag ByteString

supportsConsumableNotifications :: Client -> Bool
supportsConsumableNotifications c =
  ClientSupportsConsumableNotifications `Set.member` c.clientCapabilities.fromClientCapabilityList

mlsPublicKeysSchema :: ValueSchema NamedSwaggerDoc MLSPublicKeys
mlsPublicKeysSchema =
  mapSchema
    & doc
      %~ ( (description ?~ "Mapping from signature scheme (tags) to public key data")
             . (example ?~ toJSON (Map.fromList $ map (,exampleValue) keys))
         )
    & named "MLSPublicKeys"
  where
    keys :: [SignatureSchemeTag]
    keys = [minBound .. maxBound]

    exampleValue :: A.Value
    exampleValue = fromMaybe (toJSON ("base64==" :: Text)) (base64Schema ^. doc . example)

    mapSchema :: ValueSchema SwaggerDoc MLSPublicKeys
    mapSchema = map_ base64Schema

clientSchema :: Maybe Version -> ValueSchema NamedSwaggerDoc Client
clientSchema mVersion =
  versionedObject mVersion $
    Client
      <$> (.clientId) .= field "id" schema
      <*> clientType .= field "type" schema
      <*> clientTime .= field "time" schema
      <*> clientClass .= maybe_ (optField "class" schema)
      <*> clientLabel .= maybe_ (optField "label" schema)
      <*> clientCookie .= maybe_ (optField "cookie" schema)
      <*> clientModel .= maybe_ (optField "model" schema)
      <*> clientCapabilities .= (fromMaybe mempty <$> optField "capabilities" caps)
      <*> clientMLSPublicKeys .= mlsPublicKeysFieldSchema
      <*> clientLastActive .= maybe_ (optField "last_active" utcTimeSchema)
  where
    caps :: ValueSchema NamedSwaggerDoc ClientCapabilityList
    caps = case mVersion of
      -- broken capability serialisation for backwards compatibility
      Just v
        | v <= V6 ->
            dimap Versioned unVersioned $ schema @(Versioned V6 ClientCapabilityList)
        | v == V7 ->
            dimap Versioned unVersioned $ schema @(Versioned V7 ClientCapabilityList)
      _ -> schema @ClientCapabilityList

instance ToSchema Client where
  schema = clientSchema Nothing

instance ToSchema (Versioned 'V6 Client) where
  schema = Versioned <$> unVersioned .= clientSchema (Just V6)

instance ToSchema (Versioned 'V7 Client) where
  schema = Versioned <$> unVersioned .= clientSchema (Just V7)

instance {-# OVERLAPPING #-} ToSchema (Versioned 'V6 [Client]) where
  schema =
    Versioned
      <$> unVersioned
        .= named "ClientListV6" (array (clientSchema (Just V6)))

instance {-# OVERLAPPING #-} ToSchema (Versioned 'V7 [Client]) where
  schema =
    Versioned
      <$> unVersioned
        .= named "ClientListV7" (array (clientSchema (Just V7)))

mlsPublicKeysFieldSchema :: ObjectSchema SwaggerDoc MLSPublicKeys
mlsPublicKeysFieldSchema = fromMaybe mempty <$> optField "mls_public_keys" mlsPublicKeysSchema

instance AsHeaders '[ClientId] Client Client where
  toHeaders c = (I c.clientId :* Nil, c)
  fromHeaders = snd

--------------------------------------------------------------------------------
-- ClientList

-- | Client list for internal API.
data ClientList = ClientList {clClients :: [ClientId]}
  deriving stock (Eq, Show, Generic)
  deriving (Arbitrary) via (GenericUniform ClientList)
  deriving (FromJSON, ToJSON, Swagger.ToSchema) via Schema ClientList

instance ToSchema ClientList where
  schema =
    object $
      ClientList
        <$> clClients
          .= field "client_ids" (array schema)

--------------------------------------------------------------------------------
-- PubClient

data PubClient = PubClient
  { pubClientId :: ClientId,
    pubClientClass :: Maybe ClientClass
  }
  deriving stock (Eq, Show, Generic, Ord)
  deriving (Arbitrary) via (GenericUniform PubClient)
  deriving (Swagger.ToSchema) via (CustomSwagger '[FieldLabelModifier (StripPrefix "pubClient", LowerCase)] PubClient)
  deriving (FromJSON, ToJSON) via Schema PubClient

instance ToSchema PubClient where
  schema =
    object $
      PubClient
        <$> pubClientId .= field "id" schema
        <*> pubClientClass .= maybe_ (optField "class" schema)

toPubClient :: Client -> PubClient
toPubClient client =
  PubClient
    { pubClientId = client.clientId,
      pubClientClass = client.clientClass
    }

--------------------------------------------------------------------------------
-- Client Type/Class

-- Note [LegalHold]
-- ~~~~~~~~~~~~~~~~
--
-- Short feature description:
-- LegalHold is an enterprise feature, enabled on a per-team basis, and within a
-- team on a per-user basis
--
-- A LegalHoldClient is a client outside that user's control (but under the
-- control of that team's business)
--
-- Users need to click "accept" before a LegalHoldClient is added to their
-- account.
--
-- Any user interacting with a user which has a LegalHoldClient will upon
-- first interaction receive a warning, have the option of cancelling the
-- interaction, and on an ongoing basis see a visual indication in all
-- conversations where such a device is active.

data ClientType
  = TemporaryClientType
  | PermanentClientType
  | LegalHoldClientType -- see Note [LegalHold]
  deriving stock (Eq, Ord, Show, Generic)
  deriving (Arbitrary) via (GenericUniform ClientType)
  deriving (FromJSON, ToJSON, Swagger.ToSchema) via Schema ClientType

instance ToSchema ClientType where
  schema =
    enum @Text $
      element "temporary" TemporaryClientType
        <> element "permanent" PermanentClientType
        <> element "legalhold" LegalHoldClientType

instance C.Cql ClientType where
  ctype = C.Tagged C.IntColumn
  toCql TemporaryClientType = C.CqlInt 0
  toCql PermanentClientType = C.CqlInt 1
  toCql LegalHoldClientType = C.CqlInt 2

  fromCql (C.CqlInt 0) = pure TemporaryClientType
  fromCql (C.CqlInt 1) = pure PermanentClientType
  fromCql (C.CqlInt 2) = pure LegalHoldClientType
  fromCql _ = Left "ClientType: Int [0, 2] expected"

data ClientClass
  = PhoneClient
  | TabletClient
  | DesktopClient
  | LegalHoldClient -- see Note [LegalHold]
  deriving stock (Eq, Ord, Show, Generic)
  deriving (Arbitrary) via (GenericUniform ClientClass)
  deriving (FromJSON, ToJSON, Swagger.ToSchema) via Schema ClientClass

instance ToSchema ClientClass where
  schema =
    enum @Text $
      element "phone" PhoneClient
        <> element "tablet" TabletClient
        <> element "desktop" DesktopClient
        <> element "legalhold" LegalHoldClient

instance C.Cql ClientClass where
  ctype = C.Tagged C.IntColumn
  toCql PhoneClient = C.CqlInt 0
  toCql TabletClient = C.CqlInt 1
  toCql DesktopClient = C.CqlInt 2
  toCql LegalHoldClient = C.CqlInt 3

  fromCql (C.CqlInt 0) = pure PhoneClient
  fromCql (C.CqlInt 1) = pure TabletClient
  fromCql (C.CqlInt 2) = pure DesktopClient
  fromCql (C.CqlInt 3) = pure LegalHoldClient
  fromCql _ = Left "ClientClass: Int [0, 3] expected"

--------------------------------------------------------------------------------
-- NewClient

data NewClient = NewClient
  { newClientPrekeys :: [UncheckedPrekeyBundle],
    newClientLastKey :: LastPrekey,
    newClientType :: ClientType,
    newClientLabel :: Maybe Text,
    newClientClass :: Maybe ClientClass,
    newClientCookie :: Maybe CookieLabel,
    newClientPassword :: Maybe PlainTextPassword6,
    newClientModel :: Maybe Text,
    newClientCapabilities :: Maybe ClientCapabilityList,
    newClientMLSPublicKeys :: MLSPublicKeys,
    newClientVerificationCode :: Maybe Code.Value
  }
  deriving stock (Eq, Show, Generic)
  deriving (Arbitrary) via (GenericUniform NewClient)
  deriving (FromJSON, ToJSON, Swagger.ToSchema) via Schema NewClient

newClientSchema :: Maybe Version -> ValueSchema NamedSwaggerDoc NewClient
newClientSchema mVersion =
  object $
    NewClient
      <$> newClientPrekeys
        .= fieldWithDocModifier
          "prekeys"
          (description ?~ "Prekeys for other clients to establish OTR sessions.")
          (array schema)
      <*> newClientLastKey
        .= fieldWithDocModifier
          "lastkey"
          ( description
              ?~ "The last resort prekey for other clients to establish OTR sessions. \
                 \This key must have the ID 0xFFFF and is never deleted."
          )
          schema
      <*> newClientType
        .= fieldWithDocModifier
          "type"
          ( description
              ?~ "The type of client to register. A user may have no more than \
                 \7 (seven) permanent clients and 1 (one) temporary client. When the \
                 \limit of permanent clients is reached, an error is returned. \
                 \When a temporary client already exists, it is replaced."
          )
          schema
      <*> newClientLabel .= maybe_ (optField "label" schema)
      <*> newClientClass
        .= maybe_
          ( optFieldWithDocModifier
              "class"
              ( description
                  ?~ "The device class this client belongs to. \
                     \Either 'phone', 'tablet', or 'desktop'."
              )
              schema
          )
      <*> newClientCookie
        .= maybe_
          ( optFieldWithDocModifier
              "cookie"
              (description ?~ "The cookie label, i.e. the label used when logging in.")
              schema
          )
      <*> newClientPassword
        .= maybe_
          ( optFieldWithDocModifier
              "password"
              ( description
                  ?~ "The password of the authenticated user for verification. \
                     \Note: Required for registration of the 2nd, 3rd, ... client."
              )
              schema
          )
      <*> newClientModel .= maybe_ (optField "model" schema)
      <*> newClientCapabilities
        .= maybe_
          ( optFieldWithDocModifier
              "capabilities"
              ( description
                  ?~ "Hints provided by the client for the backend so it can \
                     \behave in a backwards-compatible way."
              )
              (capabilitiesSchema mVersion)
          )
      <*> newClientMLSPublicKeys .= mlsPublicKeysFieldSchema
      <*> newClientVerificationCode .= maybe_ (optField "verification_code" schema)

instance ToSchema NewClient where
  schema = newClientSchema Nothing

instance ToSchema (Versioned 'V6 NewClient) where
  schema = Versioned <$> unVersioned .= newClientSchema (Just V6)

instance ToSchema (Versioned 'V7 NewClient) where
  schema = Versioned <$> unVersioned .= newClientSchema (Just V7)

newClient :: ClientType -> LastPrekey -> NewClient
newClient t k =
  NewClient
    { newClientPrekeys = [],
      newClientLastKey = k,
      newClientType = t,
      newClientLabel = Nothing,
      newClientClass = if t == LegalHoldClientType then Just LegalHoldClient else Nothing,
      newClientCookie = Nothing,
      newClientPassword = Nothing,
      newClientModel = Nothing,
      newClientCapabilities = Nothing,
      newClientMLSPublicKeys = mempty,
      newClientVerificationCode = Nothing
    }

--------------------------------------------------------------------------------
-- UpdateClient

data UpdateClient = UpdateClient
  { updateClientPrekeys :: [UncheckedPrekeyBundle],
    updateClientLastKey :: Maybe LastPrekey,
    updateClientLabel :: Maybe Text,
    -- | see haddocks for 'ClientCapability'
    updateClientCapabilities :: Maybe ClientCapabilityList,
    updateClientMLSPublicKeys :: MLSPublicKeys
  }
  deriving stock (Eq, Show, Generic)
  deriving (Arbitrary) via (GenericUniform UpdateClient)
  deriving (FromJSON, ToJSON, Swagger.ToSchema) via Schema UpdateClient

defUpdateClient :: UpdateClient
defUpdateClient =
  UpdateClient
    { updateClientPrekeys = [],
      updateClientLastKey = Nothing,
      updateClientLabel = Nothing,
      updateClientCapabilities = Nothing,
      updateClientMLSPublicKeys = mempty
    }

updateClientSchema :: Maybe Version -> ValueSchema NamedSwaggerDoc UpdateClient
updateClientSchema mVersion =
  object $
    UpdateClient
      <$> updateClientPrekeys
        .= ( fromMaybe []
               <$> optFieldWithDocModifier
                 "prekeys"
                 (description ?~ "New prekeys for other clients to establish OTR sessions.")
                 (array schema)
           )
      <*> updateClientLastKey
        .= maybe_
          ( optFieldWithDocModifier
              "lastkey"
              (description ?~ "New last-resort prekey.")
              schema
          )
      <*> updateClientLabel
        .= maybe_
          ( optFieldWithDocModifier
              "label"
              (description ?~ "A new name for this client.")
              schema
          )
      <*> updateClientCapabilities
        .= maybe_
          ( optFieldWithDocModifier
              "capabilities"
              (description ?~ "Hints provided by the client for the backend so it can behave in a backwards-compatible way.")
              (capabilitiesSchema mVersion)
          )
      <*> updateClientMLSPublicKeys .= mlsPublicKeysFieldSchema

instance ToSchema UpdateClient where
  schema = updateClientSchema Nothing

instance ToSchema (Versioned 'V6 UpdateClient) where
  schema = Versioned <$> unVersioned .= updateClientSchema (Just V6)

instance ToSchema (Versioned 'V7 UpdateClient) where
  schema = Versioned <$> unVersioned .= updateClientSchema (Just V7)

--------------------------------------------------------------------------------
-- RmClient

newtype RmClient = RmClient
  { rmPassword :: Maybe PlainTextPassword6
  }
  deriving stock (Eq, Show, Generic)
  deriving newtype (Arbitrary)
  deriving (FromJSON, ToJSON, Swagger.ToSchema) via Schema RmClient

instance ToSchema RmClient where
  schema =
    object $
      RmClient
        <$> rmPassword
          .= optFieldWithDocModifier
            "password"
            ( description
                ?~ "The password of the authenticated user for verification. \
                   \The password is not required for deleting temporary clients. \
                   \or if the user has only SAML credentials."
            )
            (maybeWithDefault A.Null schema)
