-- 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/>.
{-# LANGUAGE StandaloneKindSignatures #-}
{-# LANGUAGE TemplateHaskell #-}
-- Ignore unused `genSingletons` Template Haskell results
{-# 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 (..))

-- | We use this type family instead of a sum type to be able to define
-- individual effects per conversation action. See 'HasConversationActionEffects'.
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