{-# LANGUAGE StandaloneKindSignatures #-}
{-# LANGUAGE TemplateHaskell #-}
{-# OPTIONS_GHC -Wno-unused-top-binds #-}
module Wire.API.Conversation.Action
( ConversationAction,
ConversationActionTag (..),
SConversationActionTag (..),
SomeConversationAction (..),
conversationActionToEvent,
conversationActionPermission,
ConversationActionPermission,
sConversationActionPermission,
)
where
import Control.Lens hiding ((%~))
import Data.Aeson (FromJSON (..), ToJSON (..))
import Data.Aeson qualified as A
import Data.Aeson.KeyMap qualified as A
import Data.Id
import Data.Kind
import Data.OpenApi qualified as S
import Data.Qualified (Qualified)
import Data.Schema hiding (tag)
import Data.Singletons.TH
import Data.Time.Clock
import Imports
import Wire.API.Conversation
import Wire.API.Conversation.Action.Tag
import Wire.API.Conversation.Protocol (ProtocolTag)
import Wire.API.Conversation.Role
import Wire.API.Event.Conversation
import Wire.API.Event.LeaveReason
import Wire.API.MLS.SubConversation
import Wire.Arbitrary (Arbitrary (..))
type family ConversationAction (tag :: ConversationActionTag) :: Type where
ConversationAction 'ConversationJoinTag = ConversationJoin
ConversationAction 'ConversationLeaveTag = ()
ConversationAction 'ConversationMemberUpdateTag = ConversationMemberUpdate
ConversationAction 'ConversationDeleteTag = ()
ConversationAction 'ConversationRenameTag = ConversationRename
ConversationAction 'ConversationMessageTimerUpdateTag = ConversationMessageTimerUpdate
ConversationAction 'ConversationReceiptModeUpdateTag = ConversationReceiptModeUpdate
ConversationAction 'ConversationAccessDataTag = ConversationAccessData
ConversationAction 'ConversationRemoveMembersTag = ConversationRemoveMembers
ConversationAction 'ConversationUpdateProtocolTag = ProtocolTag
data SomeConversationAction where
SomeConversationAction :: Sing tag -> ConversationAction tag -> SomeConversationAction
instance Show SomeConversationAction where
show :: SomeConversationAction -> String
show (SomeConversationAction Sing tag
tag ConversationAction tag
action) =
String
"SomeConversationAction {tag = "
String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Demote ConversationActionTag -> String
forall a. Show a => a -> String
show (Sing tag -> Demote ConversationActionTag
forall k (a :: k). SingKind k => Sing a -> Demote k
forall (a :: ConversationActionTag).
Sing a -> Demote ConversationActionTag
fromSing Sing tag
tag)
String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
", action = "
String -> ShowS
forall a. Semigroup a => a -> a -> a
<> $(sCases ''ConversationActionTag [|tag|] [|show action|])
String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"}"
instance Eq SomeConversationAction where
(SomeConversationAction Sing tag
tag1 ConversationAction tag
action1) == :: SomeConversationAction -> SomeConversationAction -> Bool
== (SomeConversationAction Sing tag
tag2 ConversationAction tag
action2) =
case Sing tag
tag1 Sing tag -> Sing tag -> Decision (tag :~: tag)
forall k (a :: k) (b :: k).
SDecide k =>
Sing a -> Sing b -> Decision (a :~: b)
forall (a :: ConversationActionTag) (b :: ConversationActionTag).
Sing a -> Sing b -> Decision (a :~: b)
%~ Sing tag
tag2 of
Proved tag :~: tag
Refl -> $(sCases ''ConversationActionTag [|tag1|] [|action1 == action2|])
Disproved Refuted (tag :~: tag)
_ -> Bool
False
instance ToJSON SomeConversationAction where
toJSON :: SomeConversationAction -> Value
toJSON (SomeConversationAction Sing tag
sb ConversationAction tag
action) =
let tag :: Demote ConversationActionTag
tag = Sing tag -> Demote ConversationActionTag
forall k (a :: k). SingKind k => Sing a -> Demote k
forall (a :: ConversationActionTag).
Sing a -> Demote ConversationActionTag
fromSing Sing tag
sb
actionJSON :: Value
actionJSON = Value -> Maybe Value -> Value
forall a. a -> Maybe a -> a
fromMaybe Value
A.Null (Maybe Value -> Value) -> Maybe Value -> Value
forall a b. (a -> b) -> a -> b
$ SchemaP
NamedSwaggerDoc
Value
Value
(ConversationAction tag)
(ConversationAction tag)
-> ConversationAction tag -> Maybe Value
forall ss v m a b. SchemaP ss v m a b -> a -> Maybe m
schemaOut (Sing tag
-> SchemaP
NamedSwaggerDoc
Value
Value
(ConversationAction tag)
(ConversationAction tag)
forall (tag :: ConversationActionTag).
Sing tag -> ValueSchema NamedSwaggerDoc (ConversationAction tag)
conversationActionSchema Sing tag
sb) ConversationAction tag
action
in [Pair] -> Value
A.object [Key
"tag" Key -> ConversationActionTag -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
A..= Demote ConversationActionTag
ConversationActionTag
tag, Key
"action" Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
A..= Value
actionJSON]
instance S.ToSchema SomeConversationAction where
declareNamedSchema :: Proxy SomeConversationAction
-> Declare (Definitions Schema) NamedSchema
declareNamedSchema Proxy SomeConversationAction
_ = do
Referenced Schema
unitSchema <- Proxy () -> Declare (Definitions Schema) (Referenced Schema)
forall a.
ToSchema a =>
Proxy a -> Declare (Definitions Schema) (Referenced Schema)
S.declareSchemaRef (Proxy ()
forall {k} (t :: k). Proxy t
Proxy :: Proxy ())
Referenced Schema
conversationJoin <- Proxy ConversationJoin
-> Declare (Definitions Schema) (Referenced Schema)
forall a.
ToSchema a =>
Proxy a -> Declare (Definitions Schema) (Referenced Schema)
S.declareSchemaRef (Proxy ConversationJoin
forall {k} (t :: k). Proxy t
Proxy :: Proxy ConversationJoin)
Referenced Schema
conversationMemberUpdate <- Proxy ConversationMemberUpdate
-> Declare (Definitions Schema) (Referenced Schema)
forall a.
ToSchema a =>
Proxy a -> Declare (Definitions Schema) (Referenced Schema)
S.declareSchemaRef (Proxy ConversationMemberUpdate
forall {k} (t :: k). Proxy t
Proxy :: Proxy ConversationMemberUpdate)
Referenced Schema
conversationRename <- Proxy ConversationRename
-> Declare (Definitions Schema) (Referenced Schema)
forall a.
ToSchema a =>
Proxy a -> Declare (Definitions Schema) (Referenced Schema)
S.declareSchemaRef (Proxy ConversationRename
forall {k} (t :: k). Proxy t
Proxy :: Proxy ConversationRename)
Referenced Schema
conversationMessageTimerUpdate <- Proxy ConversationMessageTimerUpdate
-> Declare (Definitions Schema) (Referenced Schema)
forall a.
ToSchema a =>
Proxy a -> Declare (Definitions Schema) (Referenced Schema)
S.declareSchemaRef (Proxy ConversationMessageTimerUpdate
forall {k} (t :: k). Proxy t
Proxy :: Proxy ConversationMessageTimerUpdate)
Referenced Schema
conversationReceiptModeUpdate <- Proxy ConversationReceiptModeUpdate
-> Declare (Definitions Schema) (Referenced Schema)
forall a.
ToSchema a =>
Proxy a -> Declare (Definitions Schema) (Referenced Schema)
S.declareSchemaRef (Proxy ConversationReceiptModeUpdate
forall {k} (t :: k). Proxy t
Proxy :: Proxy ConversationReceiptModeUpdate)
Referenced Schema
conversationAccessData <- Proxy ConversationAccessData
-> Declare (Definitions Schema) (Referenced Schema)
forall a.
ToSchema a =>
Proxy a -> Declare (Definitions Schema) (Referenced Schema)
S.declareSchemaRef (Proxy ConversationAccessData
forall {k} (t :: k). Proxy t
Proxy :: Proxy ConversationAccessData)
Referenced Schema
conversationRemoveMembers <- Proxy ConversationRemoveMembers
-> Declare (Definitions Schema) (Referenced Schema)
forall a.
ToSchema a =>
Proxy a -> Declare (Definitions Schema) (Referenced Schema)
S.declareSchemaRef (Proxy ConversationRemoveMembers
forall {k} (t :: k). Proxy t
Proxy :: Proxy ConversationRemoveMembers)
Referenced Schema
protocolTag <- Proxy ProtocolTag
-> Declare (Definitions Schema) (Referenced Schema)
forall a.
ToSchema a =>
Proxy a -> Declare (Definitions Schema) (Referenced Schema)
S.declareSchemaRef (Proxy ProtocolTag
forall {k} (t :: k). Proxy t
Proxy :: Proxy ProtocolTag)
let schemas :: [Referenced Schema]
schemas =
[ (ConversationActionTag -> Value
forall a. ToJSON a => a -> Value
toJSON ConversationActionTag
ConversationJoinTag, Referenced Schema
conversationJoin),
(ConversationActionTag -> Value
forall a. ToJSON a => a -> Value
toJSON ConversationActionTag
ConversationLeaveTag, Referenced Schema
unitSchema),
(ConversationActionTag -> Value
forall a. ToJSON a => a -> Value
toJSON ConversationActionTag
ConversationMemberUpdateTag, Referenced Schema
conversationMemberUpdate),
(ConversationActionTag -> Value
forall a. ToJSON a => a -> Value
toJSON ConversationActionTag
ConversationDeleteTag, Referenced Schema
unitSchema),
(ConversationActionTag -> Value
forall a. ToJSON a => a -> Value
toJSON ConversationActionTag
ConversationRenameTag, Referenced Schema
conversationRename),
(ConversationActionTag -> Value
forall a. ToJSON a => a -> Value
toJSON ConversationActionTag
ConversationMessageTimerUpdateTag, Referenced Schema
conversationMessageTimerUpdate),
(ConversationActionTag -> Value
forall a. ToJSON a => a -> Value
toJSON ConversationActionTag
ConversationReceiptModeUpdateTag, Referenced Schema
conversationReceiptModeUpdate),
(ConversationActionTag -> Value
forall a. ToJSON a => a -> Value
toJSON ConversationActionTag
ConversationAccessDataTag, Referenced Schema
conversationAccessData),
(ConversationActionTag -> Value
forall a. ToJSON a => a -> Value
toJSON ConversationActionTag
ConversationRemoveMembersTag, Referenced Schema
conversationRemoveMembers),
(ConversationActionTag -> Value
forall a. ToJSON a => a -> Value
toJSON ConversationActionTag
ConversationUpdateProtocolTag, Referenced Schema
protocolTag)
]
[(Value, Referenced Schema)]
-> ((Value, Referenced Schema) -> Referenced Schema)
-> [Referenced Schema]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \(Value
t, Referenced Schema
a) ->
Schema -> Referenced Schema
forall a. a -> Referenced a
S.Inline (Schema -> Referenced Schema) -> Schema -> Referenced Schema
forall a b. (a -> b) -> a -> b
$
Schema
forall a. Monoid a => a
mempty
Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& (Maybe OpenApiType -> Identity (Maybe OpenApiType))
-> Schema -> Identity Schema
forall s a. HasType s a => Lens' s a
Lens' Schema (Maybe OpenApiType)
S.type_ ((Maybe OpenApiType -> Identity (Maybe OpenApiType))
-> Schema -> Identity Schema)
-> OpenApiType -> Schema -> Schema
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ OpenApiType
S.OpenApiObject
Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& (InsOrdHashMap Text (Referenced Schema)
-> Identity (InsOrdHashMap Text (Referenced Schema)))
-> Schema -> Identity Schema
forall s a. HasProperties s a => Lens' s a
Lens' Schema (InsOrdHashMap Text (Referenced Schema))
S.properties ((InsOrdHashMap Text (Referenced Schema)
-> Identity (InsOrdHashMap Text (Referenced Schema)))
-> Schema -> Identity Schema)
-> ((Maybe (IxValue (InsOrdHashMap Text (Referenced Schema)))
-> Identity (Maybe (Referenced Schema)))
-> InsOrdHashMap Text (Referenced Schema)
-> Identity (InsOrdHashMap Text (Referenced Schema)))
-> (Maybe (IxValue (InsOrdHashMap Text (Referenced Schema)))
-> Identity (Maybe (Referenced Schema)))
-> Schema
-> Identity Schema
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index (InsOrdHashMap Text (Referenced Schema))
-> Lens'
(InsOrdHashMap Text (Referenced Schema))
(Maybe (IxValue (InsOrdHashMap Text (Referenced Schema))))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at Index (InsOrdHashMap Text (Referenced Schema))
"tag" ((Maybe (IxValue (InsOrdHashMap Text (Referenced Schema)))
-> Identity (Maybe (Referenced Schema)))
-> Schema -> Identity Schema)
-> Referenced Schema -> Schema -> Schema
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ Schema -> Referenced Schema
forall a. a -> Referenced a
S.Inline (Schema
forall a. Monoid a => a
mempty Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& (Maybe OpenApiType -> Identity (Maybe OpenApiType))
-> Schema -> Identity Schema
forall s a. HasType s a => Lens' s a
Lens' Schema (Maybe OpenApiType)
S.type_ ((Maybe OpenApiType -> Identity (Maybe OpenApiType))
-> Schema -> Identity Schema)
-> OpenApiType -> Schema -> Schema
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ OpenApiType
S.OpenApiString Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& (Maybe [Value] -> Identity (Maybe [Value]))
-> Schema -> Identity Schema
forall s a. HasEnum s a => Lens' s a
Lens' Schema (Maybe [Value])
S.enum_ ((Maybe [Value] -> Identity (Maybe [Value]))
-> Schema -> Identity Schema)
-> [Value] -> Schema -> Schema
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ [Value
t])
Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& (InsOrdHashMap Text (Referenced Schema)
-> Identity (InsOrdHashMap Text (Referenced Schema)))
-> Schema -> Identity Schema
forall s a. HasProperties s a => Lens' s a
Lens' Schema (InsOrdHashMap Text (Referenced Schema))
S.properties ((InsOrdHashMap Text (Referenced Schema)
-> Identity (InsOrdHashMap Text (Referenced Schema)))
-> Schema -> Identity Schema)
-> ((Maybe (IxValue (InsOrdHashMap Text (Referenced Schema)))
-> Identity (Maybe (Referenced Schema)))
-> InsOrdHashMap Text (Referenced Schema)
-> Identity (InsOrdHashMap Text (Referenced Schema)))
-> (Maybe (IxValue (InsOrdHashMap Text (Referenced Schema)))
-> Identity (Maybe (Referenced Schema)))
-> Schema
-> Identity Schema
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index (InsOrdHashMap Text (Referenced Schema))
-> Lens'
(InsOrdHashMap Text (Referenced Schema))
(Maybe (IxValue (InsOrdHashMap Text (Referenced Schema))))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at Index (InsOrdHashMap Text (Referenced Schema))
"action" ((Maybe (IxValue (InsOrdHashMap Text (Referenced Schema)))
-> Identity (Maybe (Referenced Schema)))
-> Schema -> Identity Schema)
-> Referenced Schema -> Schema -> Schema
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ Referenced Schema
a
Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& ([Text] -> Identity [Text]) -> Schema -> Identity Schema
forall s a. HasRequired s a => Lens' s a
Lens' Schema [Text]
S.required (([Text] -> Identity [Text]) -> Schema -> Identity Schema)
-> [Text] -> Schema -> Schema
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [Text
"tag", Text
"action"]
NamedSchema -> Declare (Definitions Schema) NamedSchema
forall a. a -> DeclareT (Definitions Schema) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NamedSchema -> Declare (Definitions Schema) NamedSchema)
-> NamedSchema -> Declare (Definitions Schema) NamedSchema
forall a b. (a -> b) -> a -> b
$
Maybe Text -> Schema -> NamedSchema
S.NamedSchema (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"SomeConversationAction") (Schema -> NamedSchema) -> Schema -> NamedSchema
forall a b. (a -> b) -> a -> b
$
Schema
forall a. Monoid a => a
mempty Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& (Maybe [Referenced Schema] -> Identity (Maybe [Referenced Schema]))
-> Schema -> Identity Schema
forall s a. HasOneOf s a => Lens' s a
Lens' Schema (Maybe [Referenced Schema])
S.oneOf ((Maybe [Referenced Schema]
-> Identity (Maybe [Referenced Schema]))
-> Schema -> Identity Schema)
-> [Referenced Schema] -> Schema -> Schema
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ [Referenced Schema]
schemas
conversationActionSchema :: forall tag. Sing tag -> ValueSchema NamedSwaggerDoc (ConversationAction tag)
conversationActionSchema :: forall (tag :: ConversationActionTag).
Sing tag -> ValueSchema NamedSwaggerDoc (ConversationAction tag)
conversationActionSchema Sing tag
SConversationActionTag tag
SConversationJoinTag = forall a. ToSchema a => ValueSchema NamedSwaggerDoc a
schema @ConversationJoin
conversationActionSchema Sing tag
SConversationActionTag tag
SConversationLeaveTag =
Text
-> (NamedSwaggerDoc -> NamedSwaggerDoc)
-> ObjectSchema SwaggerDoc (ConversationAction tag)
-> SchemaP
NamedSwaggerDoc
Value
Value
(ConversationAction tag)
(ConversationAction tag)
forall doc doc' a.
HasObject doc doc' =>
Text -> (doc' -> doc') -> ObjectSchema doc a -> ValueSchema doc' a
objectWithDocModifier
Text
"ConversationLeave"
((Maybe Text -> Identity (Maybe Text))
-> NamedSwaggerDoc -> Identity NamedSwaggerDoc
forall s a. HasDescription s a => Lens' s a
Lens' NamedSwaggerDoc (Maybe Text)
S.description ((Maybe Text -> Identity (Maybe Text))
-> NamedSwaggerDoc -> Identity NamedSwaggerDoc)
-> Text -> NamedSwaggerDoc -> NamedSwaggerDoc
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ Text
"The action of some users leaving a conversation on their own")
(ObjectSchema SwaggerDoc (ConversationAction tag)
-> SchemaP
NamedSwaggerDoc
Value
Value
(ConversationAction tag)
(ConversationAction tag))
-> ObjectSchema SwaggerDoc (ConversationAction tag)
-> SchemaP
NamedSwaggerDoc
Value
Value
(ConversationAction tag)
(ConversationAction tag)
forall a b. (a -> b) -> a -> b
$ () -> SchemaP SwaggerDoc Object [Pair] () ()
forall a. a -> SchemaP SwaggerDoc Object [Pair] () a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
conversationActionSchema Sing tag
SConversationActionTag tag
SConversationRemoveMembersTag = ValueSchema NamedSwaggerDoc ConversationRemoveMembers
SchemaP
NamedSwaggerDoc
Value
Value
(ConversationAction tag)
(ConversationAction tag)
forall a. ToSchema a => ValueSchema NamedSwaggerDoc a
schema
conversationActionSchema Sing tag
SConversationActionTag tag
SConversationMemberUpdateTag = forall a. ToSchema a => ValueSchema NamedSwaggerDoc a
schema @ConversationMemberUpdate
conversationActionSchema Sing tag
SConversationActionTag tag
SConversationDeleteTag =
Text
-> (NamedSwaggerDoc -> NamedSwaggerDoc)
-> SchemaP SwaggerDoc Object [Pair] () ()
-> ValueSchema NamedSwaggerDoc ()
forall doc doc' a.
HasObject doc doc' =>
Text -> (doc' -> doc') -> ObjectSchema doc a -> ValueSchema doc' a
objectWithDocModifier
Text
"ConversationDelete"
((Maybe Text -> Identity (Maybe Text))
-> NamedSwaggerDoc -> Identity NamedSwaggerDoc
forall s a. HasDescription s a => Lens' s a
Lens' NamedSwaggerDoc (Maybe Text)
S.description ((Maybe Text -> Identity (Maybe Text))
-> NamedSwaggerDoc -> Identity NamedSwaggerDoc)
-> Text -> NamedSwaggerDoc -> NamedSwaggerDoc
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ Text
"The action of deleting a conversation")
(() -> SchemaP SwaggerDoc Object [Pair] () ()
forall a. a -> SchemaP SwaggerDoc Object [Pair] () a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
conversationActionSchema Sing tag
SConversationActionTag tag
SConversationRenameTag = ValueSchema NamedSwaggerDoc ConversationRename
SchemaP
NamedSwaggerDoc
Value
Value
(ConversationAction tag)
(ConversationAction tag)
forall a. ToSchema a => ValueSchema NamedSwaggerDoc a
schema
conversationActionSchema Sing tag
SConversationActionTag tag
SConversationMessageTimerUpdateTag = ValueSchema NamedSwaggerDoc ConversationMessageTimerUpdate
SchemaP
NamedSwaggerDoc
Value
Value
(ConversationAction tag)
(ConversationAction tag)
forall a. ToSchema a => ValueSchema NamedSwaggerDoc a
schema
conversationActionSchema Sing tag
SConversationActionTag tag
SConversationReceiptModeUpdateTag = ValueSchema NamedSwaggerDoc ConversationReceiptModeUpdate
SchemaP
NamedSwaggerDoc
Value
Value
(ConversationAction tag)
(ConversationAction tag)
forall a. ToSchema a => ValueSchema NamedSwaggerDoc a
schema
conversationActionSchema Sing tag
SConversationActionTag tag
SConversationAccessDataTag = ValueSchema NamedSwaggerDoc ConversationAccessData
SchemaP
NamedSwaggerDoc
Value
Value
(ConversationAction tag)
(ConversationAction tag)
forall a. ToSchema a => ValueSchema NamedSwaggerDoc a
schema
conversationActionSchema Sing tag
SConversationActionTag tag
SConversationUpdateProtocolTag = ValueSchema NamedSwaggerDoc ProtocolTag
SchemaP
NamedSwaggerDoc
Value
Value
(ConversationAction tag)
(ConversationAction tag)
forall a. ToSchema a => ValueSchema NamedSwaggerDoc a
schema
instance FromJSON SomeConversationAction where
parseJSON :: Value -> Parser SomeConversationAction
parseJSON = String
-> (Object -> Parser SomeConversationAction)
-> Value
-> Parser SomeConversationAction
forall a. String -> (Object -> Parser a) -> Value -> Parser a
A.withObject String
"SomeConversationAction" ((Object -> Parser SomeConversationAction)
-> Value -> Parser SomeConversationAction)
-> (Object -> Parser SomeConversationAction)
-> Value
-> Parser SomeConversationAction
forall a b. (a -> b) -> a -> b
$ \Object
ob -> do
Demote ConversationActionTag
tag <- Object
ob Object -> Key -> Parser (Demote ConversationActionTag)
forall a. FromJSON a => Object -> Key -> Parser a
A..: Key
"tag"
case Key -> Object -> Maybe Value
forall v. Key -> KeyMap v -> Maybe v
A.lookup Key
"action" Object
ob of
Maybe Value
Nothing -> String -> Parser SomeConversationAction
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"'action' property missing"
Just Value
actionValue ->
case Demote ConversationActionTag -> SomeSing ConversationActionTag
forall k. SingKind k => Demote k -> SomeSing k
toSing Demote ConversationActionTag
tag of
SomeSing Sing a
sb -> do
ConversationAction a
action <- SchemaP
NamedSwaggerDoc
Value
Value
(ConversationAction a)
(ConversationAction a)
-> Value -> Parser (ConversationAction a)
forall doc v v' a b. SchemaP doc v v' a b -> v -> Parser b
schemaIn (Sing a
-> SchemaP
NamedSwaggerDoc
Value
Value
(ConversationAction a)
(ConversationAction a)
forall (tag :: ConversationActionTag).
Sing tag -> ValueSchema NamedSwaggerDoc (ConversationAction tag)
conversationActionSchema Sing a
sb) Value
actionValue
SomeConversationAction -> Parser SomeConversationAction
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SomeConversationAction -> Parser SomeConversationAction)
-> SomeConversationAction -> Parser SomeConversationAction
forall a b. (a -> b) -> a -> b
$ Sing a -> ConversationAction a -> SomeConversationAction
forall (arg :: ConversationActionTag).
Sing arg -> ConversationAction arg -> SomeConversationAction
SomeConversationAction Sing a
sb ConversationAction a
action
instance Arbitrary SomeConversationAction where
arbitrary :: Gen SomeConversationAction
arbitrary = do
Demote ConversationActionTag
tag <- Gen (Demote ConversationActionTag)
forall a. Arbitrary a => Gen a
arbitrary
case Demote ConversationActionTag -> SomeSing ConversationActionTag
forall k. SingKind k => Demote k -> SomeSing k
toSing Demote ConversationActionTag
tag of
SomeSing Sing a
sb -> do
$(sCases ''ConversationActionTag [|sb|] [|SomeConversationAction sb <$> arbitrary|])
$( singletons
[d|
conversationActionPermission :: ConversationActionTag -> Action
conversationActionPermission ConversationJoinTag = AddConversationMember
conversationActionPermission ConversationLeaveTag = LeaveConversation
conversationActionPermission ConversationRemoveMembersTag = RemoveConversationMember
conversationActionPermission ConversationMemberUpdateTag = ModifyOtherConversationMember
conversationActionPermission ConversationDeleteTag = DeleteConversation
conversationActionPermission ConversationRenameTag = ModifyConversationName
conversationActionPermission ConversationMessageTimerUpdateTag = ModifyConversationMessageTimer
conversationActionPermission ConversationReceiptModeUpdateTag = ModifyConversationReceiptMode
conversationActionPermission ConversationAccessDataTag = ModifyConversationAccess
conversationActionPermission ConversationUpdateProtocolTag = LeaveConversation
|]
)
conversationActionToEvent ::
forall tag.
Sing tag ->
UTCTime ->
Qualified UserId ->
Qualified ConvId ->
Maybe SubConvId ->
ConversationAction tag ->
Event
conversationActionToEvent :: forall (tag :: ConversationActionTag).
Sing tag
-> UTCTime
-> Qualified UserId
-> Qualified ConvId
-> Maybe SubConvId
-> ConversationAction tag
-> Event
conversationActionToEvent Sing tag
tag UTCTime
now Qualified UserId
quid Qualified ConvId
qcnv Maybe SubConvId
subconv ConversationAction tag
action =
let edata :: EventData
edata = case Sing tag
tag of
Sing tag
SConversationActionTag tag
SConversationJoinTag ->
let ConversationJoin NonEmpty (Qualified UserId)
newMembers RoleName
role = ConversationAction tag
action
in SimpleMembers -> EventData
EdMembersJoin (SimpleMembers -> EventData) -> SimpleMembers -> EventData
forall a b. (a -> b) -> a -> b
$ [SimpleMember] -> SimpleMembers
SimpleMembers ((Qualified UserId -> SimpleMember)
-> [Qualified UserId] -> [SimpleMember]
forall a b. (a -> b) -> [a] -> [b]
map (Qualified UserId -> RoleName -> SimpleMember
`SimpleMember` RoleName
role) (NonEmpty (Qualified UserId) -> [Qualified UserId]
forall a. NonEmpty a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty (Qualified UserId)
newMembers))
Sing tag
SConversationActionTag tag
SConversationLeaveTag ->
EdMemberLeftReason -> QualifiedUserIdList -> EventData
EdMembersLeave EdMemberLeftReason
EdReasonLeft ([Qualified UserId] -> QualifiedUserIdList
QualifiedUserIdList [Qualified UserId
quid])
Sing tag
SConversationActionTag tag
SConversationRemoveMembersTag ->
EdMemberLeftReason -> QualifiedUserIdList -> EventData
EdMembersLeave (ConversationRemoveMembers -> EdMemberLeftReason
crmReason ConversationRemoveMembers
ConversationAction tag
action) ([Qualified UserId] -> QualifiedUserIdList
QualifiedUserIdList ([Qualified UserId] -> QualifiedUserIdList)
-> (ConversationAction tag -> [Qualified UserId])
-> ConversationAction tag
-> QualifiedUserIdList
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty (Qualified UserId) -> [Qualified UserId]
forall a. NonEmpty a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (NonEmpty (Qualified UserId) -> [Qualified UserId])
-> (ConversationRemoveMembers -> NonEmpty (Qualified UserId))
-> ConversationRemoveMembers
-> [Qualified UserId]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConversationRemoveMembers -> NonEmpty (Qualified UserId)
crmTargets (ConversationAction tag -> QualifiedUserIdList)
-> ConversationAction tag -> QualifiedUserIdList
forall a b. (a -> b) -> a -> b
$ ConversationAction tag
action)
Sing tag
SConversationActionTag tag
SConversationMemberUpdateTag ->
let ConversationMemberUpdate Qualified UserId
target (OtherMemberUpdate Maybe RoleName
role) = ConversationAction tag
action
update :: MemberUpdateData
update = Qualified UserId
-> Maybe MutedStatus
-> Maybe Text
-> Maybe Bool
-> Maybe Text
-> Maybe Bool
-> Maybe Text
-> Maybe RoleName
-> MemberUpdateData
MemberUpdateData Qualified UserId
target Maybe MutedStatus
forall a. Maybe a
Nothing Maybe Text
forall a. Maybe a
Nothing Maybe Bool
forall a. Maybe a
Nothing Maybe Text
forall a. Maybe a
Nothing Maybe Bool
forall a. Maybe a
Nothing Maybe Text
forall a. Maybe a
Nothing Maybe RoleName
role
in MemberUpdateData -> EventData
EdMemberUpdate MemberUpdateData
update
Sing tag
SConversationActionTag tag
SConversationDeleteTag -> EventData
EdConvDelete
Sing tag
SConversationActionTag tag
SConversationRenameTag -> ConversationRename -> EventData
EdConvRename ConversationRename
ConversationAction tag
action
Sing tag
SConversationActionTag tag
SConversationMessageTimerUpdateTag -> ConversationMessageTimerUpdate -> EventData
EdConvMessageTimerUpdate ConversationMessageTimerUpdate
ConversationAction tag
action
Sing tag
SConversationActionTag tag
SConversationReceiptModeUpdateTag -> ConversationReceiptModeUpdate -> EventData
EdConvReceiptModeUpdate ConversationReceiptModeUpdate
ConversationAction tag
action
Sing tag
SConversationActionTag tag
SConversationAccessDataTag -> ConversationAccessData -> EventData
EdConvAccessUpdate ConversationAccessData
ConversationAction tag
action
Sing tag
SConversationActionTag tag
SConversationUpdateProtocolTag -> ProtocolTag -> EventData
EdProtocolUpdate ProtocolTag
ConversationAction tag
action
in Qualified ConvId
-> Maybe SubConvId
-> Qualified UserId
-> UTCTime
-> EventData
-> Event
Event Qualified ConvId
qcnv Maybe SubConvId
subconv Qualified UserId
quid UTCTime
now EventData
edata