-- 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.Event.FeatureConfig
  ( Event (..),
    EventType (..),
    mkUpdateEvent,
  )
where

import Data.Aeson (toJSON)
import Data.Aeson qualified as A
import Data.Aeson.KeyMap qualified as KeyMap
import Data.Json.Util (ToJSONObject (toJSONObject))
import Data.OpenApi qualified as S
import Data.Schema
import Imports
import Test.QuickCheck.Gen
import Wire.API.Team.Feature
import Wire.Arbitrary (Arbitrary (..), GenericUniform (..))

data Event = Event
  { Event -> EventType
_eventType :: EventType,
    Event -> Text
_eventFeatureName :: Text,
    Event -> Value
_eventData :: A.Value
  }
  deriving (Event -> Event -> Bool
(Event -> Event -> Bool) -> (Event -> Event -> Bool) -> Eq Event
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Event -> Event -> Bool
== :: Event -> Event -> Bool
$c/= :: Event -> Event -> Bool
/= :: Event -> Event -> Bool
Eq, Int -> Event -> ShowS
[Event] -> ShowS
Event -> String
(Int -> Event -> ShowS)
-> (Event -> String) -> ([Event] -> ShowS) -> Show Event
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Event -> ShowS
showsPrec :: Int -> Event -> ShowS
$cshow :: Event -> String
show :: Event -> String
$cshowList :: [Event] -> ShowS
showList :: [Event] -> ShowS
Show, (forall x. Event -> Rep Event x)
-> (forall x. Rep Event x -> Event) -> Generic Event
forall x. Rep Event x -> Event
forall x. Event -> Rep Event x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Event -> Rep Event x
from :: forall x. Event -> Rep Event x
$cto :: forall x. Rep Event x -> Event
to :: forall x. Rep Event x -> Event
Generic)
  deriving ([Event] -> Value
[Event] -> Encoding
Event -> Value
Event -> Encoding
(Event -> Value)
-> (Event -> Encoding)
-> ([Event] -> Value)
-> ([Event] -> Encoding)
-> ToJSON Event
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
$ctoJSON :: Event -> Value
toJSON :: Event -> Value
$ctoEncoding :: Event -> Encoding
toEncoding :: Event -> Encoding
$ctoJSONList :: [Event] -> Value
toJSONList :: [Event] -> Value
$ctoEncodingList :: [Event] -> Encoding
toEncodingList :: [Event] -> Encoding
A.ToJSON, Value -> Parser [Event]
Value -> Parser Event
(Value -> Parser Event)
-> (Value -> Parser [Event]) -> FromJSON Event
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
$cparseJSON :: Value -> Parser Event
parseJSON :: Value -> Parser Event
$cparseJSONList :: Value -> Parser [Event]
parseJSONList :: Value -> Parser [Event]
A.FromJSON) via Schema Event

arbitraryFeature :: forall cfg. (IsFeatureConfig cfg, Arbitrary cfg) => Gen A.Value
arbitraryFeature :: forall cfg. (IsFeatureConfig cfg, Arbitrary cfg) => Gen Value
arbitraryFeature = LockableFeature cfg -> Value
forall a. ToJSON a => a -> Value
toJSON (LockableFeature cfg -> Value)
-> Gen (LockableFeature cfg) -> Gen Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Arbitrary a => Gen a
arbitrary @(LockableFeature cfg)

class AllArbitraryFeatures cfgs where
  allArbitraryFeatures :: [Gen A.Value]

instance AllArbitraryFeatures '[] where
  allArbitraryFeatures :: [Gen Value]
allArbitraryFeatures = []

instance
  ( IsFeatureConfig cfg,
    Arbitrary cfg,
    AllArbitraryFeatures cfgs
  ) =>
  AllArbitraryFeatures (cfg : cfgs)
  where
  allArbitraryFeatures :: [Gen Value]
allArbitraryFeatures = forall cfg. (IsFeatureConfig cfg, Arbitrary cfg) => Gen Value
arbitraryFeature @cfg Gen Value -> [Gen Value] -> [Gen Value]
forall a. a -> [a] -> [a]
: forall (cfgs :: [*]). AllArbitraryFeatures cfgs => [Gen Value]
forall {k} (cfgs :: k). AllArbitraryFeatures cfgs => [Gen Value]
allArbitraryFeatures @cfgs

instance Arbitrary Event where
  arbitrary :: Gen Event
arbitrary =
    EventType -> Text -> Value -> Event
Event
      (EventType -> Text -> Value -> Event)
-> Gen EventType -> Gen (Text -> Value -> Event)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen EventType
forall a. Arbitrary a => Gen a
arbitrary
      Gen (Text -> Value -> Event) -> Gen Text -> Gen (Value -> Event)
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen Text
forall a. Arbitrary a => Gen a
arbitrary
      Gen (Value -> Event) -> Gen Value -> Gen Event
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [Gen Value] -> Gen Value
forall a. [Gen a] -> Gen a
oneof (forall (cfgs :: [*]). AllArbitraryFeatures cfgs => [Gen Value]
forall {k} (cfgs :: k). AllArbitraryFeatures cfgs => [Gen Value]
allArbitraryFeatures @Features)

data EventType = Update
  deriving (EventType -> EventType -> Bool
(EventType -> EventType -> Bool)
-> (EventType -> EventType -> Bool) -> Eq EventType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: EventType -> EventType -> Bool
== :: EventType -> EventType -> Bool
$c/= :: EventType -> EventType -> Bool
/= :: EventType -> EventType -> Bool
Eq, Int -> EventType -> ShowS
[EventType] -> ShowS
EventType -> String
(Int -> EventType -> ShowS)
-> (EventType -> String)
-> ([EventType] -> ShowS)
-> Show EventType
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> EventType -> ShowS
showsPrec :: Int -> EventType -> ShowS
$cshow :: EventType -> String
show :: EventType -> String
$cshowList :: [EventType] -> ShowS
showList :: [EventType] -> ShowS
Show, (forall x. EventType -> Rep EventType x)
-> (forall x. Rep EventType x -> EventType) -> Generic EventType
forall x. Rep EventType x -> EventType
forall x. EventType -> Rep EventType x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. EventType -> Rep EventType x
from :: forall x. EventType -> Rep EventType x
$cto :: forall x. Rep EventType x -> EventType
to :: forall x. Rep EventType x -> EventType
Generic)
  deriving (Gen EventType
Gen EventType -> (EventType -> [EventType]) -> Arbitrary EventType
EventType -> [EventType]
forall a. Gen a -> (a -> [a]) -> Arbitrary a
$carbitrary :: Gen EventType
arbitrary :: Gen EventType
$cshrink :: EventType -> [EventType]
shrink :: EventType -> [EventType]
Arbitrary) via GenericUniform EventType

instance ToSchema EventType where
  schema :: ValueSchema NamedSwaggerDoc EventType
schema =
    forall v doc a b.
(With v, HasEnum v doc) =>
Text
-> SchemaP [Value] v (Alt Maybe v) a b
-> SchemaP doc Value Value a b
enum @Text Text
"EventType" (SchemaP [Value] Text (Alt Maybe Text) EventType EventType
 -> ValueSchema NamedSwaggerDoc EventType)
-> SchemaP [Value] Text (Alt Maybe Text) EventType EventType
-> ValueSchema NamedSwaggerDoc EventType
forall a b. (a -> b) -> a -> b
$
      [SchemaP [Value] Text (Alt Maybe Text) EventType EventType]
-> SchemaP [Value] Text (Alt Maybe Text) EventType EventType
forall a. Monoid a => [a] -> a
mconcat
        [ Text
-> EventType
-> SchemaP [Value] Text (Alt Maybe Text) EventType EventType
forall a b.
(ToJSON a, Eq a, Eq b) =>
a -> b -> SchemaP [Value] a (Alt Maybe a) b b
element Text
"feature-config.update" EventType
Update
        ]

eventObjectSchema :: ObjectSchema SwaggerDoc Event
eventObjectSchema :: ObjectSchema SwaggerDoc Event
eventObjectSchema =
  EventType -> Text -> Value -> Event
Event
    (EventType -> Text -> Value -> Event)
-> SchemaP SwaggerDoc Object [Pair] Event EventType
-> SchemaP SwaggerDoc Object [Pair] Event (Text -> Value -> Event)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Event -> EventType
_eventType (Event -> EventType)
-> SchemaP SwaggerDoc Object [Pair] EventType EventType
-> SchemaP SwaggerDoc Object [Pair] Event EventType
forall (p :: * -> * -> *) a a' b.
Profunctor p =>
(a -> a') -> p a' b -> p a b
.= Text
-> ValueSchema NamedSwaggerDoc EventType
-> SchemaP SwaggerDoc Object [Pair] EventType EventType
forall doc' doc a b.
HasField doc' doc =>
Text
-> SchemaP doc' Value Value a b -> SchemaP doc Object [Pair] a b
field Text
"type" ValueSchema NamedSwaggerDoc EventType
forall a. ToSchema a => ValueSchema NamedSwaggerDoc a
schema
    SchemaP SwaggerDoc Object [Pair] Event (Text -> Value -> Event)
-> SchemaP SwaggerDoc Object [Pair] Event Text
-> SchemaP SwaggerDoc Object [Pair] Event (Value -> Event)
forall a b.
SchemaP SwaggerDoc Object [Pair] Event (a -> b)
-> SchemaP SwaggerDoc Object [Pair] Event a
-> SchemaP SwaggerDoc Object [Pair] Event b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Event -> Text
_eventFeatureName (Event -> Text)
-> SchemaP SwaggerDoc Object [Pair] Text Text
-> SchemaP SwaggerDoc Object [Pair] Event Text
forall (p :: * -> * -> *) a a' b.
Profunctor p =>
(a -> a') -> p a' b -> p a b
.= Text
-> SchemaP NamedSwaggerDoc Value Value Text Text
-> SchemaP SwaggerDoc Object [Pair] Text Text
forall doc' doc a b.
HasField doc' doc =>
Text
-> SchemaP doc' Value Value a b -> SchemaP doc Object [Pair] a b
field Text
"name" SchemaP NamedSwaggerDoc Value Value Text Text
forall a. ToSchema a => ValueSchema NamedSwaggerDoc a
schema
    SchemaP SwaggerDoc Object [Pair] Event (Value -> Event)
-> SchemaP SwaggerDoc Object [Pair] Event Value
-> ObjectSchema SwaggerDoc Event
forall a b.
SchemaP SwaggerDoc Object [Pair] Event (a -> b)
-> SchemaP SwaggerDoc Object [Pair] Event a
-> SchemaP SwaggerDoc Object [Pair] Event b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Event -> Value
_eventData (Event -> Value)
-> SchemaP SwaggerDoc Object [Pair] Value Value
-> SchemaP SwaggerDoc Object [Pair] Event Value
forall (p :: * -> * -> *) a a' b.
Profunctor p =>
(a -> a') -> p a' b -> p a b
.= Text
-> SchemaP SwaggerDoc Value Value Value Value
-> SchemaP SwaggerDoc Object [Pair] Value Value
forall doc' doc a b.
HasField doc' doc =>
Text
-> SchemaP doc' Value Value a b -> SchemaP doc Object [Pair] a b
field Text
"data" SchemaP SwaggerDoc Value Value Value Value
jsonValue

instance ToSchema Event where
  schema :: ValueSchema NamedSwaggerDoc Event
schema =
    Text
-> ObjectSchema SwaggerDoc Event
-> ValueSchema NamedSwaggerDoc Event
forall doc doc' a b.
HasObject doc doc' =>
Text
-> SchemaP doc Object [Pair] a b -> SchemaP doc' Value Value a b
object Text
"Event" ObjectSchema SwaggerDoc Event
eventObjectSchema

instance ToJSONObject Event where
  toJSONObject :: Event -> Object
toJSONObject =
    [Pair] -> Object
forall v. [(Key, v)] -> KeyMap v
KeyMap.fromList
      ([Pair] -> Object) -> (Event -> [Pair]) -> Event -> Object
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Pair] -> Maybe [Pair] -> [Pair]
forall a. a -> Maybe a -> a
fromMaybe []
      (Maybe [Pair] -> [Pair])
-> (Event -> Maybe [Pair]) -> Event -> [Pair]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ObjectSchema SwaggerDoc Event -> Event -> Maybe [Pair]
forall ss v m a b. SchemaP ss v m a b -> a -> Maybe m
schemaOut ObjectSchema SwaggerDoc Event
eventObjectSchema

instance S.ToSchema Event where
  declareNamedSchema :: Proxy Event -> Declare (Definitions Schema) NamedSchema
declareNamedSchema = Proxy Event -> Declare (Definitions Schema) NamedSchema
forall a.
ToSchema a =>
Proxy a -> Declare (Definitions Schema) NamedSchema
schemaToSwagger

mkUpdateEvent :: forall cfg. (IsFeatureConfig cfg) => LockableFeature cfg -> Event
mkUpdateEvent :: forall cfg. IsFeatureConfig cfg => LockableFeature cfg -> Event
mkUpdateEvent LockableFeature cfg
ws = EventType -> Text -> Value -> Event
Event EventType
Update (forall cfg. IsFeatureConfig cfg => Text
featureName @cfg) (LockableFeature cfg -> Value
forall a. ToJSON a => a -> Value
toJSON LockableFeature cfg
ws)