module Galley.API.MLS.SubConversation
( getSubConversation,
getLocalSubConversation,
deleteSubConversation,
deleteLocalSubConversation,
getSubConversationGroupInfo,
getSubConversationGroupInfoFromLocalConv,
leaveSubConversation,
HasLeaveSubConversationEffects,
LeaveSubConversationStaticErrors,
leaveLocalSubConversation,
MLSGetSubConvStaticErrors,
MLSDeleteSubConvStaticErrors,
)
where
import Control.Arrow
import Data.Id
import Data.Map qualified as Map
import Data.Qualified
import Data.Time.Clock
import Galley.API.MLS
import Galley.API.MLS.Conversation
import Galley.API.MLS.GroupInfo
import Galley.API.MLS.Removal
import Galley.API.MLS.Types
import Galley.API.MLS.Util
import Galley.API.Util
import Galley.App (Env)
import Galley.Data.Conversation qualified as Data
import Galley.Data.Conversation.Types
import Galley.Effects
import Galley.Effects.FederatorAccess
import Galley.Effects.MemberStore qualified as Eff
import Galley.Effects.SubConversationStore qualified as Eff
import Imports
import Polysemy
import Polysemy.Error
import Polysemy.Input
import Polysemy.Resource
import Polysemy.TinyLog
import Wire.API.Conversation hiding (Member)
import Wire.API.Conversation.Protocol
import Wire.API.Error
import Wire.API.Error.Galley
import Wire.API.Federation.API
import Wire.API.Federation.API.Galley
import Wire.API.Federation.Error
import Wire.API.MLS.Credential
import Wire.API.MLS.Group.Serialisation
import Wire.API.MLS.GroupInfo
import Wire.API.MLS.SubConversation
import Wire.NotificationSubsystem
type MLSGetSubConvStaticErrors =
'[ ErrorS 'ConvNotFound,
ErrorS 'ConvAccessDenied,
ErrorS 'MLSSubConvUnsupportedConvType
]
getSubConversation ::
( Members
'[ SubConversationStore,
ConversationStore,
ErrorS 'ConvNotFound,
ErrorS 'ConvAccessDenied,
ErrorS 'MLSSubConvUnsupportedConvType,
Error FederationError,
FederatorAccess
]
r
) =>
Local UserId ->
Qualified ConvId ->
SubConvId ->
Sem r PublicSubConversation
getSubConversation :: forall (r :: EffectRow).
Members
'[SubConversationStore, ConversationStore, ErrorS 'ConvNotFound,
ErrorS 'ConvAccessDenied, ErrorS 'MLSSubConvUnsupportedConvType,
Error FederationError, FederatorAccess]
r =>
Local UserId
-> Qualified ConvId -> SubConvId -> Sem r PublicSubConversation
getSubConversation Local UserId
lusr Qualified ConvId
qconv SubConvId
sconv = do
Local UserId
-> (Local ConvId -> Sem r PublicSubConversation)
-> (Remote ConvId -> Sem r PublicSubConversation)
-> Qualified ConvId
-> Sem r PublicSubConversation
forall x a b.
Local x -> (Local a -> b) -> (Remote a -> b) -> Qualified a -> b
foldQualified
Local UserId
lusr
(\Local ConvId
lcnv -> Qualified UserId
-> Local ConvId -> SubConvId -> Sem r PublicSubConversation
forall (r :: EffectRow).
Members
'[SubConversationStore, ConversationStore, ErrorS 'ConvNotFound,
ErrorS 'ConvAccessDenied, ErrorS 'MLSSubConvUnsupportedConvType]
r =>
Qualified UserId
-> Local ConvId -> SubConvId -> Sem r PublicSubConversation
getLocalSubConversation (Local UserId -> Qualified UserId
forall (t :: QTag) a. QualifiedWithTag t a -> Qualified a
tUntagged Local UserId
lusr) Local ConvId
lcnv SubConvId
sconv)
(\Remote ConvId
rcnv -> Local UserId
-> Remote ConvId -> SubConvId -> Sem r PublicSubConversation
forall (r :: EffectRow).
(Members
'[ErrorS 'ConvNotFound, ErrorS 'ConvAccessDenied,
ErrorS 'MLSSubConvUnsupportedConvType, FederatorAccess]
r,
RethrowErrors
'[ErrorS 'ConvNotFound, ErrorS 'ConvAccessDenied,
ErrorS 'MLSSubConvUnsupportedConvType]
r) =>
Local UserId
-> Remote ConvId -> SubConvId -> Sem r PublicSubConversation
getRemoteSubConversation Local UserId
lusr Remote ConvId
rcnv SubConvId
sconv)
Qualified ConvId
qconv
getLocalSubConversation ::
( Members
'[ SubConversationStore,
ConversationStore,
ErrorS 'ConvNotFound,
ErrorS 'ConvAccessDenied,
ErrorS 'MLSSubConvUnsupportedConvType
]
r
) =>
Qualified UserId ->
Local ConvId ->
SubConvId ->
Sem r PublicSubConversation
getLocalSubConversation :: forall (r :: EffectRow).
Members
'[SubConversationStore, ConversationStore, ErrorS 'ConvNotFound,
ErrorS 'ConvAccessDenied, ErrorS 'MLSSubConvUnsupportedConvType]
r =>
Qualified UserId
-> Local ConvId -> SubConvId -> Sem r PublicSubConversation
getLocalSubConversation Qualified UserId
qusr Local ConvId
lconv SubConvId
sconv = do
Conversation
c <- Qualified UserId -> Local ConvId -> Sem r Conversation
forall (r :: EffectRow).
(Member ConversationStore r, Member (ErrorS 'ConvNotFound) r,
Member (ErrorS 'ConvAccessDenied) r) =>
Qualified UserId -> Local ConvId -> Sem r Conversation
getConversationAndCheckMembership Qualified UserId
qusr Local ConvId
lconv
Bool -> Sem r () -> Sem r ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Conversation -> ConvType
Data.convType Conversation
c ConvType -> ConvType -> Bool
forall a. Eq a => a -> a -> Bool
== ConvType
RegularConv Bool -> Bool -> Bool
|| Conversation -> ConvType
Data.convType Conversation
c ConvType -> ConvType -> Bool
forall a. Eq a => a -> a -> Bool
== ConvType
One2OneConv) (Sem r () -> Sem r ()) -> Sem r () -> Sem r ()
forall a b. (a -> b) -> a -> b
$
forall {k} (e :: k) (r :: EffectRow) a.
Member (ErrorS e) r =>
Sem r a
forall (e :: GalleyError) (r :: EffectRow) a.
Member (ErrorS e) r =>
Sem r a
throwS @'MLSSubConvUnsupportedConvType
Maybe SubConversation
msub <- ConvId -> SubConvId -> Sem r (Maybe SubConversation)
forall (r :: EffectRow).
Member SubConversationStore r =>
ConvId -> SubConvId -> Sem r (Maybe SubConversation)
Eff.getSubConversation (Local ConvId -> ConvId
forall (t :: QTag) a. QualifiedWithTag t a -> a
tUnqualified Local ConvId
lconv) SubConvId
sconv
SubConversation
sub <- case Maybe SubConversation
msub of
Maybe SubConversation
Nothing -> do
(ConversationMLSData
_mlsMeta, MLSMigrationState
mlsProtocol) <- forall {k} (e :: k) (r :: EffectRow) a.
Member (ErrorS e) r =>
Maybe a -> Sem r a
forall (e :: GalleyError) (r :: EffectRow) a.
Member (ErrorS e) r =>
Maybe a -> Sem r a
noteS @'ConvNotFound (Conversation -> Maybe (ConversationMLSData, MLSMigrationState)
mlsMetadata Conversation
c)
case MLSMigrationState
mlsProtocol of
MLSMigrationState
MLSMigrationMixed -> forall {k} (e :: k) (r :: EffectRow) a.
Member (ErrorS e) r =>
Sem r a
forall (e :: GalleyError) (r :: EffectRow) a.
Member (ErrorS e) r =>
Sem r a
throwS @'MLSSubConvUnsupportedConvType
MLSMigrationState
MLSMigrationMLS -> () -> Sem r ()
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
SubConversation -> Sem r SubConversation
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Local ConvId -> SubConvId -> SubConversation
newSubConversationFromParent Local ConvId
lconv SubConvId
sconv)
Just SubConversation
sub -> SubConversation -> Sem r SubConversation
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SubConversation
sub
PublicSubConversation -> Sem r PublicSubConversation
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Qualified SubConversation -> PublicSubConversation
toPublicSubConv (QualifiedWithTag 'QLocal SubConversation
-> Qualified SubConversation
forall (t :: QTag) a. QualifiedWithTag t a -> Qualified a
tUntagged (Local ConvId
-> SubConversation -> QualifiedWithTag 'QLocal SubConversation
forall (t :: QTag) x a.
QualifiedWithTag t x -> a -> QualifiedWithTag t a
qualifyAs Local ConvId
lconv SubConversation
sub)))
getRemoteSubConversation ::
forall r.
( Members
'[ ErrorS 'ConvNotFound,
ErrorS 'ConvAccessDenied,
ErrorS 'MLSSubConvUnsupportedConvType,
FederatorAccess
]
r,
RethrowErrors MLSGetSubConvStaticErrors r
) =>
Local UserId ->
Remote ConvId ->
SubConvId ->
Sem r PublicSubConversation
getRemoteSubConversation :: forall (r :: EffectRow).
(Members
'[ErrorS 'ConvNotFound, ErrorS 'ConvAccessDenied,
ErrorS 'MLSSubConvUnsupportedConvType, FederatorAccess]
r,
RethrowErrors
'[ErrorS 'ConvNotFound, ErrorS 'ConvAccessDenied,
ErrorS 'MLSSubConvUnsupportedConvType]
r) =>
Local UserId
-> Remote ConvId -> SubConvId -> Sem r PublicSubConversation
getRemoteSubConversation Local UserId
lusr Remote ConvId
rcnv SubConvId
sconv = do
GetSubConversationsResponse
res <- Remote ConvId
-> FederatorClient 'Galley GetSubConversationsResponse
-> Sem r GetSubConversationsResponse
forall (r :: EffectRow) (c :: Component) x a.
(Member FederatorAccess r, KnownComponent c) =>
Remote x -> FederatorClient c a -> Sem r a
runFederated Remote ConvId
rcnv (FederatorClient 'Galley GetSubConversationsResponse
-> Sem r GetSubConversationsResponse)
-> FederatorClient 'Galley GetSubConversationsResponse
-> Sem r GetSubConversationsResponse
forall a b. (a -> b) -> a -> b
$ do
forall {k} (comp :: Component) (name :: k)
(fedM :: Component -> * -> *) (showcomp :: Symbol) api.
(showcomp ~ ShowComponent comp, HasFedEndpoint comp api name,
HasClient (fedM comp) api, KnownComponent comp, IsNamed name,
FederationMonad fedM, Typeable (Client (fedM comp) api)) =>
Client (fedM comp) api
forall (comp :: Component) (name :: Symbol)
(fedM :: Component -> * -> *) (showcomp :: Symbol) api.
(showcomp ~ ShowComponent comp, HasFedEndpoint comp api name,
HasClient (fedM comp) api, KnownComponent comp, IsNamed name,
FederationMonad fedM, Typeable (Client (fedM comp) api)) =>
Client (fedM comp) api
fedClient @'Galley @"get-sub-conversation" (GetSubConversationsRequest
-> FederatorClient 'Galley GetSubConversationsResponse)
-> GetSubConversationsRequest
-> FederatorClient 'Galley GetSubConversationsResponse
forall a b. (a -> b) -> a -> b
$
GetSubConversationsRequest
{ $sel:gsreqUser:GetSubConversationsRequest :: UserId
gsreqUser = Local UserId -> UserId
forall (t :: QTag) a. QualifiedWithTag t a -> a
tUnqualified Local UserId
lusr,
$sel:gsreqConv:GetSubConversationsRequest :: ConvId
gsreqConv = Remote ConvId -> ConvId
forall (t :: QTag) a. QualifiedWithTag t a -> a
tUnqualified Remote ConvId
rcnv,
$sel:gsreqSubConv:GetSubConversationsRequest :: SubConvId
gsreqSubConv = SubConvId
sconv
}
case GetSubConversationsResponse
res of
GetSubConversationsResponseError GalleyError
e ->
forall (effs :: EffectRow) (r :: EffectRow) a.
RethrowErrors effs r =>
GalleyError -> Sem r a
rethrowErrors @MLSGetSubConvStaticErrors @r GalleyError
e
GetSubConversationsResponseSuccess PublicSubConversation
subconv ->
PublicSubConversation -> Sem r PublicSubConversation
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure PublicSubConversation
subconv
getSubConversationGroupInfo ::
( Members
'[ ConversationStore,
Error FederationError,
FederatorAccess,
Input Env,
MemberStore,
SubConversationStore
]
r,
Members MLSGroupInfoStaticErrors r
) =>
Local UserId ->
Qualified ConvId ->
SubConvId ->
Sem r GroupInfoData
getSubConversationGroupInfo :: forall (r :: EffectRow).
(Members
'[ConversationStore, Error FederationError, FederatorAccess,
Input Env, MemberStore, SubConversationStore]
r,
Members MLSGroupInfoStaticErrors r) =>
Local UserId
-> Qualified ConvId -> SubConvId -> Sem r GroupInfoData
getSubConversationGroupInfo Local UserId
lusr Qualified ConvId
qcnvId SubConvId
subconv = do
Sem r ()
forall (r :: EffectRow).
(Member (Input Env) r, Member (ErrorS 'MLSNotEnabled) r) =>
Sem r ()
assertMLSEnabled
Local UserId
-> (Local ConvId -> Sem r GroupInfoData)
-> (Remote ConvId -> Sem r GroupInfoData)
-> Qualified ConvId
-> Sem r GroupInfoData
forall x a b.
Local x -> (Local a -> b) -> (Remote a -> b) -> Qualified a -> b
foldQualified
Local UserId
lusr
(Qualified UserId
-> SubConvId -> Local ConvId -> Sem r GroupInfoData
forall (r :: EffectRow).
(Members '[ConversationStore, SubConversationStore, MemberStore] r,
Members MLSGroupInfoStaticErrors r) =>
Qualified UserId
-> SubConvId -> Local ConvId -> Sem r GroupInfoData
getSubConversationGroupInfoFromLocalConv (Local UserId -> Qualified UserId
forall (t :: QTag) a. QualifiedWithTag t a -> Qualified a
tUntagged Local UserId
lusr) SubConvId
subconv)
(Local UserId -> Remote ConvOrSubConvId -> Sem r GroupInfoData
forall (r :: EffectRow).
(Member (Error FederationError) r, Member FederatorAccess r,
Members MLSGroupInfoStaticErrors r) =>
Local UserId -> Remote ConvOrSubConvId -> Sem r GroupInfoData
getGroupInfoFromRemoteConv Local UserId
lusr (Remote ConvOrSubConvId -> Sem r GroupInfoData)
-> (Remote ConvId -> Remote ConvOrSubConvId)
-> Remote ConvId
-> Sem r GroupInfoData
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ConvId -> ConvOrSubConvId)
-> Remote ConvId -> Remote ConvOrSubConvId
forall a b.
(a -> b)
-> QualifiedWithTag 'QRemote a -> QualifiedWithTag 'QRemote b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((ConvId -> SubConvId -> ConvOrSubConvId)
-> SubConvId -> ConvId -> ConvOrSubConvId
forall a b c. (a -> b -> c) -> b -> a -> c
flip ConvId -> SubConvId -> ConvOrSubConvId
forall c s. c -> s -> ConvOrSubChoice c s
SubConv SubConvId
subconv))
Qualified ConvId
qcnvId
getSubConversationGroupInfoFromLocalConv ::
( Members
'[ ConversationStore,
SubConversationStore,
MemberStore
]
r
) =>
(Members MLSGroupInfoStaticErrors r) =>
Qualified UserId ->
SubConvId ->
Local ConvId ->
Sem r GroupInfoData
getSubConversationGroupInfoFromLocalConv :: forall (r :: EffectRow).
(Members '[ConversationStore, SubConversationStore, MemberStore] r,
Members MLSGroupInfoStaticErrors r) =>
Qualified UserId
-> SubConvId -> Local ConvId -> Sem r GroupInfoData
getSubConversationGroupInfoFromLocalConv Qualified UserId
qusr SubConvId
subConvId Local ConvId
lcnvId = do
Sem r Conversation -> Sem r ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Sem r Conversation -> Sem r ()) -> Sem r Conversation -> Sem r ()
forall a b. (a -> b) -> a -> b
$ Qualified UserId -> Local ConvId -> Sem r Conversation
forall (r :: EffectRow).
(Member (ErrorS 'ConvNotFound) r, Member ConversationStore r,
Member MemberStore r) =>
Qualified UserId -> Local ConvId -> Sem r Conversation
getLocalConvForUser Qualified UserId
qusr Local ConvId
lcnvId
ConvId -> SubConvId -> Sem r (Maybe GroupInfoData)
forall (r :: EffectRow).
Member SubConversationStore r =>
ConvId -> SubConvId -> Sem r (Maybe GroupInfoData)
Eff.getSubConversationGroupInfo (Local ConvId -> ConvId
forall (t :: QTag) a. QualifiedWithTag t a -> a
tUnqualified Local ConvId
lcnvId) SubConvId
subConvId
Sem r (Maybe GroupInfoData)
-> (Maybe GroupInfoData -> Sem r GroupInfoData)
-> Sem r GroupInfoData
forall a b. Sem r a -> (a -> Sem r b) -> Sem r b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall {k} (e :: k) (r :: EffectRow) a.
Member (ErrorS e) r =>
Maybe a -> Sem r a
forall (e :: GalleyError) (r :: EffectRow) a.
Member (ErrorS e) r =>
Maybe a -> Sem r a
noteS @'MLSMissingGroupInfo
type MLSDeleteSubConvStaticErrors =
'[ ErrorS 'ConvAccessDenied,
ErrorS 'ConvNotFound,
ErrorS 'MLSNotEnabled,
ErrorS 'MLSStaleMessage
]
deleteSubConversation ::
( Members
'[ ConversationStore,
ErrorS 'ConvAccessDenied,
ErrorS 'ConvNotFound,
ErrorS 'MLSNotEnabled,
ErrorS 'MLSStaleMessage,
Error FederationError,
FederatorAccess,
Input Env,
MemberStore,
Resource,
SubConversationStore
]
r
) =>
Local UserId ->
Qualified ConvId ->
SubConvId ->
DeleteSubConversationRequest ->
Sem r ()
deleteSubConversation :: forall (r :: EffectRow).
Members
'[ConversationStore, ErrorS 'ConvAccessDenied,
ErrorS 'ConvNotFound, ErrorS 'MLSNotEnabled,
ErrorS 'MLSStaleMessage, Error FederationError, FederatorAccess,
Input Env, MemberStore, Resource, SubConversationStore]
r =>
Local UserId
-> Qualified ConvId
-> SubConvId
-> DeleteSubConversationRequest
-> Sem r ()
deleteSubConversation Local UserId
lusr Qualified ConvId
qconv SubConvId
sconv DeleteSubConversationRequest
dsc =
Local UserId
-> (Local ConvId -> Sem r ())
-> (Remote ConvId -> Sem r ())
-> Qualified ConvId
-> Sem r ()
forall x a b.
Local x -> (Local a -> b) -> (Remote a -> b) -> Qualified a -> b
foldQualified
Local UserId
lusr
(\Local ConvId
lcnv -> Qualified UserId
-> Local ConvId
-> SubConvId
-> DeleteSubConversationRequest
-> Sem r ()
forall (r :: EffectRow).
Members
'[ConversationStore, ErrorS 'ConvAccessDenied,
ErrorS 'ConvNotFound, ErrorS 'MLSNotEnabled,
ErrorS 'MLSStaleMessage, FederatorAccess, Input Env, MemberStore,
Resource, SubConversationStore]
r =>
Qualified UserId
-> Local ConvId
-> SubConvId
-> DeleteSubConversationRequest
-> Sem r ()
deleteLocalSubConversation (Local UserId -> Qualified UserId
forall (t :: QTag) a. QualifiedWithTag t a -> Qualified a
tUntagged Local UserId
lusr) Local ConvId
lcnv SubConvId
sconv DeleteSubConversationRequest
dsc)
(\Remote ConvId
rcnv -> Local UserId
-> Remote ConvId
-> SubConvId
-> DeleteSubConversationRequest
-> Sem r ()
forall (r :: EffectRow).
Members
'[ErrorS 'ConvAccessDenied, ErrorS 'ConvNotFound,
ErrorS 'MLSNotEnabled, ErrorS 'MLSStaleMessage,
Error FederationError, FederatorAccess, Input Env]
r =>
Local UserId
-> Remote ConvId
-> SubConvId
-> DeleteSubConversationRequest
-> Sem r ()
deleteRemoteSubConversation Local UserId
lusr Remote ConvId
rcnv SubConvId
sconv DeleteSubConversationRequest
dsc)
Qualified ConvId
qconv
deleteLocalSubConversation ::
( Members
'[ ConversationStore,
ErrorS 'ConvAccessDenied,
ErrorS 'ConvNotFound,
ErrorS 'MLSNotEnabled,
ErrorS 'MLSStaleMessage,
FederatorAccess,
Input Env,
MemberStore,
Resource,
SubConversationStore
]
r
) =>
Qualified UserId ->
Local ConvId ->
SubConvId ->
DeleteSubConversationRequest ->
Sem r ()
deleteLocalSubConversation :: forall (r :: EffectRow).
Members
'[ConversationStore, ErrorS 'ConvAccessDenied,
ErrorS 'ConvNotFound, ErrorS 'MLSNotEnabled,
ErrorS 'MLSStaleMessage, FederatorAccess, Input Env, MemberStore,
Resource, SubConversationStore]
r =>
Qualified UserId
-> Local ConvId
-> SubConvId
-> DeleteSubConversationRequest
-> Sem r ()
deleteLocalSubConversation Qualified UserId
qusr Local ConvId
lcnvId SubConvId
scnvId DeleteSubConversationRequest
dsc = do
Sem r ()
forall (r :: EffectRow).
(Member (Input Env) r, Member (ErrorS 'MLSNotEnabled) r) =>
Sem r ()
assertMLSEnabled
let cnvId :: ConvId
cnvId = Local ConvId -> ConvId
forall (t :: QTag) a. QualifiedWithTag t a -> a
tUnqualified Local ConvId
lcnvId
lConvOrSubId :: QualifiedWithTag 'QLocal ConvOrSubConvId
lConvOrSubId = Local ConvId
-> ConvOrSubConvId -> QualifiedWithTag 'QLocal ConvOrSubConvId
forall (t :: QTag) x a.
QualifiedWithTag t x -> a -> QualifiedWithTag t a
qualifyAs Local ConvId
lcnvId (ConvId -> SubConvId -> ConvOrSubConvId
forall c s. c -> s -> ConvOrSubChoice c s
SubConv ConvId
cnvId SubConvId
scnvId)
Conversation
cnv <- Qualified UserId -> Local ConvId -> Sem r Conversation
forall (r :: EffectRow).
(Member ConversationStore r, Member (ErrorS 'ConvNotFound) r,
Member (ErrorS 'ConvAccessDenied) r) =>
Qualified UserId -> Local ConvId -> Sem r Conversation
getConversationAndCheckMembership Qualified UserId
qusr Local ConvId
lcnvId
QualifiedWithTag 'QLocal ConvOrSubConvId
-> GroupId -> Epoch -> Sem r () -> Sem r ()
forall (r :: EffectRow) a.
Members
'[Resource, ConversationStore, ErrorS 'MLSStaleMessage,
SubConversationStore]
r =>
QualifiedWithTag 'QLocal ConvOrSubConvId
-> GroupId -> Epoch -> Sem r a -> Sem r a
withCommitLock QualifiedWithTag 'QLocal ConvOrSubConvId
lConvOrSubId (DeleteSubConversationRequest -> GroupId
dscGroupId DeleteSubConversationRequest
dsc) (DeleteSubConversationRequest -> Epoch
dscEpoch DeleteSubConversationRequest
dsc) (Sem r () -> Sem r ()) -> Sem r () -> Sem r ()
forall a b. (a -> b) -> a -> b
$ do
SubConversation
sconv <-
ConvId -> SubConvId -> Sem r (Maybe SubConversation)
forall (r :: EffectRow).
Member SubConversationStore r =>
ConvId -> SubConvId -> Sem r (Maybe SubConversation)
Eff.getSubConversation ConvId
cnvId SubConvId
scnvId
Sem r (Maybe SubConversation)
-> (Maybe SubConversation -> Sem r SubConversation)
-> Sem r SubConversation
forall a b. Sem r a -> (a -> Sem r b) -> Sem r b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall {k} (e :: k) (r :: EffectRow) a.
Member (ErrorS e) r =>
Maybe a -> Sem r a
forall (e :: GalleyError) (r :: EffectRow) a.
Member (ErrorS e) r =>
Maybe a -> Sem r a
noteS @'ConvNotFound
let (GroupId
gid, Epoch
epoch) = (ConversationMLSData -> GroupId
cnvmlsGroupId (ConversationMLSData -> GroupId)
-> (ConversationMLSData -> Epoch)
-> ConversationMLSData
-> (GroupId, Epoch)
forall b c c'. (b -> c) -> (b -> c') -> b -> (c, c')
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& ConversationMLSData -> Epoch
cnvmlsEpoch) (SubConversation -> ConversationMLSData
scMLSData SubConversation
sconv)
Bool -> Sem r () -> Sem r ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (DeleteSubConversationRequest -> GroupId
dscGroupId DeleteSubConversationRequest
dsc GroupId -> GroupId -> Bool
forall a. Eq a => a -> a -> Bool
== GroupId
gid) (Sem r () -> Sem r ()) -> Sem r () -> Sem r ()
forall a b. (a -> b) -> a -> b
$ forall {k} (e :: k) (r :: EffectRow) a.
Member (ErrorS e) r =>
Sem r a
forall (e :: GalleyError) (r :: EffectRow) a.
Member (ErrorS e) r =>
Sem r a
throwS @'ConvNotFound
Bool -> Sem r () -> Sem r ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (DeleteSubConversationRequest -> Epoch
dscEpoch DeleteSubConversationRequest
dsc Epoch -> Epoch -> Bool
forall a. Eq a => a -> a -> Bool
== Epoch
epoch) (Sem r () -> Sem r ()) -> Sem r () -> Sem r ()
forall a b. (a -> b) -> a -> b
$ forall {k} (e :: k) (r :: EffectRow) a.
Member (ErrorS e) r =>
Sem r a
forall (e :: GalleyError) (r :: EffectRow) a.
Member (ErrorS e) r =>
Sem r a
throwS @'MLSStaleMessage
GroupId -> Sem r ()
forall (r :: EffectRow).
Member MemberStore r =>
GroupId -> Sem r ()
Eff.removeAllMLSClients GroupId
gid
let newGid :: GroupId
newGid =
GroupId -> Either String GroupId -> GroupId
forall b a. b -> Either a b -> b
fromRight
( GroupIdParts -> GroupId
convToGroupId (GroupIdParts -> GroupId) -> GroupIdParts -> GroupId
forall a b. (a -> b) -> a -> b
$
ConvType -> Qualified ConvOrSubConvId -> GroupIdParts
groupIdParts
(Conversation -> ConvType
Data.convType Conversation
cnv)
((ConvId -> SubConvId -> ConvOrSubConvId)
-> SubConvId -> ConvId -> ConvOrSubConvId
forall a b c. (a -> b -> c) -> b -> a -> c
flip ConvId -> SubConvId -> ConvOrSubConvId
forall c s. c -> s -> ConvOrSubChoice c s
SubConv SubConvId
scnvId (ConvId -> ConvOrSubConvId)
-> Qualified ConvId -> Qualified ConvOrSubConvId
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Local ConvId -> Qualified ConvId
forall (t :: QTag) a. QualifiedWithTag t a -> Qualified a
tUntagged Local ConvId
lcnvId)
)
(Either String GroupId -> GroupId)
-> Either String GroupId -> GroupId
forall a b. (a -> b) -> a -> b
$ GroupId -> Either String GroupId
nextGenGroupId GroupId
gid
Sem r SubConversation -> Sem r ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Sem r SubConversation -> Sem r ())
-> Sem r SubConversation -> Sem r ()
forall a b. (a -> b) -> a -> b
$ ConvId -> SubConvId -> GroupId -> Sem r SubConversation
forall (r :: EffectRow).
Member SubConversationStore r =>
ConvId -> SubConvId -> GroupId -> Sem r SubConversation
Eff.createSubConversation ConvId
cnvId SubConvId
scnvId GroupId
newGid
deleteRemoteSubConversation ::
( Members
'[ ErrorS 'ConvAccessDenied,
ErrorS 'ConvNotFound,
ErrorS 'MLSNotEnabled,
ErrorS 'MLSStaleMessage,
Error FederationError,
FederatorAccess,
Input Env
]
r
) =>
Local UserId ->
Remote ConvId ->
SubConvId ->
DeleteSubConversationRequest ->
Sem r ()
deleteRemoteSubConversation :: forall (r :: EffectRow).
Members
'[ErrorS 'ConvAccessDenied, ErrorS 'ConvNotFound,
ErrorS 'MLSNotEnabled, ErrorS 'MLSStaleMessage,
Error FederationError, FederatorAccess, Input Env]
r =>
Local UserId
-> Remote ConvId
-> SubConvId
-> DeleteSubConversationRequest
-> Sem r ()
deleteRemoteSubConversation Local UserId
lusr Remote ConvId
rcnvId SubConvId
scnvId DeleteSubConversationRequest
dsc = do
Sem r ()
forall (r :: EffectRow).
(Member (Input Env) r, Member (ErrorS 'MLSNotEnabled) r) =>
Sem r ()
assertMLSEnabled
let deleteRequest :: DeleteSubConversationFedRequest
deleteRequest =
DeleteSubConversationFedRequest
{ $sel:dscreqUser:DeleteSubConversationFedRequest :: UserId
dscreqUser = Local UserId -> UserId
forall (t :: QTag) a. QualifiedWithTag t a -> a
tUnqualified Local UserId
lusr,
$sel:dscreqConv:DeleteSubConversationFedRequest :: ConvId
dscreqConv = Remote ConvId -> ConvId
forall (t :: QTag) a. QualifiedWithTag t a -> a
tUnqualified Remote ConvId
rcnvId,
$sel:dscreqSubConv:DeleteSubConversationFedRequest :: SubConvId
dscreqSubConv = SubConvId
scnvId,
$sel:dscreqGroupId:DeleteSubConversationFedRequest :: GroupId
dscreqGroupId = DeleteSubConversationRequest -> GroupId
dscGroupId DeleteSubConversationRequest
dsc,
$sel:dscreqEpoch:DeleteSubConversationFedRequest :: Epoch
dscreqEpoch = DeleteSubConversationRequest -> Epoch
dscEpoch DeleteSubConversationRequest
dsc
}
DeleteSubConversationResponse
response <-
Remote ConvId
-> FederatorClient 'Galley DeleteSubConversationResponse
-> Sem r DeleteSubConversationResponse
forall (r :: EffectRow) (c :: Component) x a.
(Member FederatorAccess r, KnownComponent c) =>
Remote x -> FederatorClient c a -> Sem r a
runFederated
Remote ConvId
rcnvId
(forall {k} (comp :: Component) (name :: k)
(fedM :: Component -> * -> *) (showcomp :: Symbol) api.
(showcomp ~ ShowComponent comp, HasFedEndpoint comp api name,
HasClient (fedM comp) api, KnownComponent comp, IsNamed name,
FederationMonad fedM, Typeable (Client (fedM comp) api)) =>
Client (fedM comp) api
forall (comp :: Component) (name :: Symbol)
(fedM :: Component -> * -> *) (showcomp :: Symbol) api.
(showcomp ~ ShowComponent comp, HasFedEndpoint comp api name,
HasClient (fedM comp) api, KnownComponent comp, IsNamed name,
FederationMonad fedM, Typeable (Client (fedM comp) api)) =>
Client (fedM comp) api
fedClient @'Galley @"delete-sub-conversation" DeleteSubConversationFedRequest
deleteRequest)
case DeleteSubConversationResponse
response of
DeleteSubConversationResponseError GalleyError
e -> forall (effs :: EffectRow) (r :: EffectRow) a.
RethrowErrors effs r =>
GalleyError -> Sem r a
rethrowErrors @MLSDeleteSubConvStaticErrors GalleyError
e
DeleteSubConversationResponse
DeleteSubConversationResponseSuccess -> () -> Sem r ()
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
type HasLeaveSubConversationEffects r =
( Members
'[ BackendNotificationQueueAccess,
ConversationStore,
ExternalAccess,
FederatorAccess,
NotificationSubsystem,
Input Env,
Input UTCTime,
MemberStore,
ProposalStore,
Random,
SubConversationStore,
TinyLog
]
r
)
type LeaveSubConversationStaticErrors =
'[ ErrorS 'ConvNotFound,
ErrorS 'ConvAccessDenied,
ErrorS 'MLSStaleMessage,
ErrorS 'MLSNotEnabled
]
leaveSubConversation ::
( HasLeaveSubConversationEffects r,
Member (Error MLSProtocolError) r,
Member (Error FederationError) r,
Member (ErrorS 'MLSStaleMessage) r,
Member (ErrorS 'MLSNotEnabled) r,
Member Resource r,
Members LeaveSubConversationStaticErrors r
) =>
Local UserId ->
ClientId ->
Qualified ConvId ->
SubConvId ->
Sem r ()
leaveSubConversation :: forall (r :: EffectRow).
(HasLeaveSubConversationEffects r,
Member (Error MLSProtocolError) r,
Member (Error FederationError) r,
Member (ErrorS 'MLSStaleMessage) r,
Member (ErrorS 'MLSNotEnabled) r, Member Resource r,
Members LeaveSubConversationStaticErrors r) =>
Local UserId
-> ClientId -> Qualified ConvId -> SubConvId -> Sem r ()
leaveSubConversation Local UserId
lusr ClientId
cli Qualified ConvId
qcnv SubConvId
sub =
Local UserId
-> (Local ConvId -> SubConvId -> Sem r ())
-> (Remote ConvId -> SubConvId -> Sem r ())
-> Qualified ConvId
-> SubConvId
-> Sem r ()
forall x a b.
Local x -> (Local a -> b) -> (Remote a -> b) -> Qualified a -> b
foldQualified
Local UserId
lusr
(ClientIdentity -> Local ConvId -> SubConvId -> Sem r ()
forall (r :: EffectRow).
(HasLeaveSubConversationEffects r,
Member (Error MLSProtocolError) r,
Member (ErrorS 'MLSStaleMessage) r,
Member (ErrorS 'MLSNotEnabled) r, Member (Error FederationError) r,
Member Resource r, Members LeaveSubConversationStaticErrors r) =>
ClientIdentity -> Local ConvId -> SubConvId -> Sem r ()
leaveLocalSubConversation ClientIdentity
cid)
(ClientIdentity -> Remote ConvId -> SubConvId -> Sem r ()
forall (r :: EffectRow).
Members
'[ErrorS 'ConvNotFound, ErrorS 'ConvAccessDenied,
Error FederationError, Error MLSProtocolError, FederatorAccess]
r =>
ClientIdentity -> Remote ConvId -> SubConvId -> Sem r ()
leaveRemoteSubConversation ClientIdentity
cid)
Qualified ConvId
qcnv
SubConvId
sub
where
cid :: ClientIdentity
cid = Qualified UserId -> ClientId -> ClientIdentity
mkClientIdentity (Local UserId -> Qualified UserId
forall (t :: QTag) a. QualifiedWithTag t a -> Qualified a
tUntagged Local UserId
lusr) ClientId
cli
leaveLocalSubConversation ::
( HasLeaveSubConversationEffects r,
Member (Error MLSProtocolError) r,
Member (ErrorS 'MLSStaleMessage) r,
Member (ErrorS 'MLSNotEnabled) r,
Member (Error FederationError) r,
Member Resource r,
Members LeaveSubConversationStaticErrors r
) =>
ClientIdentity ->
Local ConvId ->
SubConvId ->
Sem r ()
leaveLocalSubConversation :: forall (r :: EffectRow).
(HasLeaveSubConversationEffects r,
Member (Error MLSProtocolError) r,
Member (ErrorS 'MLSStaleMessage) r,
Member (ErrorS 'MLSNotEnabled) r, Member (Error FederationError) r,
Member Resource r, Members LeaveSubConversationStaticErrors r) =>
ClientIdentity -> Local ConvId -> SubConvId -> Sem r ()
leaveLocalSubConversation ClientIdentity
cid Local ConvId
lcnv SubConvId
sub = do
Sem r ()
forall (r :: EffectRow).
(Member (Input Env) r, Member (ErrorS 'MLSNotEnabled) r) =>
Sem r ()
assertMLSEnabled
Conversation
cnv <- Qualified UserId -> Local ConvId -> Sem r Conversation
forall (r :: EffectRow).
(Member ConversationStore r, Member (ErrorS 'ConvNotFound) r,
Member (ErrorS 'ConvAccessDenied) r) =>
Qualified UserId -> Local ConvId -> Sem r Conversation
getConversationAndCheckMembership (ClientIdentity -> Qualified UserId
cidQualifiedUser ClientIdentity
cid) Local ConvId
lcnv
MLSConversation
mlsConv <- forall {k} (e :: k) (r :: EffectRow) a.
Member (ErrorS e) r =>
Maybe a -> Sem r a
forall (e :: GalleyError) (r :: EffectRow) a.
Member (ErrorS e) r =>
Maybe a -> Sem r a
noteS @'ConvNotFound (Maybe MLSConversation -> Sem r MLSConversation)
-> Sem r (Maybe MLSConversation) -> Sem r MLSConversation
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Conversation -> Sem r (Maybe MLSConversation)
forall (r :: EffectRow).
Member MemberStore r =>
Conversation -> Sem r (Maybe MLSConversation)
mkMLSConversation Conversation
cnv
SubConversation
subConv <-
forall {k} (e :: k) (r :: EffectRow) a.
Member (ErrorS e) r =>
Maybe a -> Sem r a
forall (e :: GalleyError) (r :: EffectRow) a.
Member (ErrorS e) r =>
Maybe a -> Sem r a
noteS @'ConvNotFound
(Maybe SubConversation -> Sem r SubConversation)
-> Sem r (Maybe SubConversation) -> Sem r SubConversation
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ConvId -> SubConvId -> Sem r (Maybe SubConversation)
forall (r :: EffectRow).
Member SubConversationStore r =>
ConvId -> SubConvId -> Sem r (Maybe SubConversation)
Eff.getSubConversation (Local ConvId -> ConvId
forall (t :: QTag) a. QualifiedWithTag t a -> a
tUnqualified Local ConvId
lcnv) SubConvId
sub
LeafIndex
idx <-
MLSProtocolError -> Maybe LeafIndex -> Sem r LeafIndex
forall e (r :: EffectRow) a.
Member (Error e) r =>
e -> Maybe a -> Sem r a
note (Text -> MLSProtocolError
mlsProtocolError Text
"Client is not a member of the subconversation") (Maybe LeafIndex -> Sem r LeafIndex)
-> Maybe LeafIndex -> Sem r LeafIndex
forall a b. (a -> b) -> a -> b
$
ClientIdentity -> ClientMap -> Maybe LeafIndex
cmLookupIndex ClientIdentity
cid (SubConversation -> ClientMap
scMembers SubConversation
subConv)
let (GroupId
gid, Epoch
epoch) = (ConversationMLSData -> GroupId
cnvmlsGroupId (ConversationMLSData -> GroupId)
-> (ConversationMLSData -> Epoch)
-> ConversationMLSData
-> (GroupId, Epoch)
forall b c c'. (b -> c) -> (b -> c') -> b -> (c, c')
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& ConversationMLSData -> Epoch
cnvmlsEpoch) (SubConversation -> ConversationMLSData
scMLSData SubConversation
subConv)
GroupId -> Identity ClientIdentity -> Sem r ()
forall (r :: EffectRow) (f :: * -> *).
(Member MemberStore r, Foldable f) =>
GroupId -> f ClientIdentity -> Sem r ()
Eff.planClientRemoval GroupId
gid (ClientIdentity -> Identity ClientIdentity
forall a. a -> Identity a
Identity ClientIdentity
cid)
let cm :: ClientMap
cm = ClientIdentity -> ClientMap -> ClientMap
cmRemoveClient ClientIdentity
cid (SubConversation -> ClientMap
scMembers SubConversation
subConv)
if ClientMap -> Bool
forall k a. Map k a -> Bool
Map.null ClientMap
cm
then do
Qualified UserId
-> Local ConvId
-> SubConvId
-> DeleteSubConversationRequest
-> Sem r ()
forall (r :: EffectRow).
Members
'[ConversationStore, ErrorS 'ConvAccessDenied,
ErrorS 'ConvNotFound, ErrorS 'MLSNotEnabled,
ErrorS 'MLSStaleMessage, FederatorAccess, Input Env, MemberStore,
Resource, SubConversationStore]
r =>
Qualified UserId
-> Local ConvId
-> SubConvId
-> DeleteSubConversationRequest
-> Sem r ()
deleteLocalSubConversation
(ClientIdentity -> Qualified UserId
cidQualifiedUser ClientIdentity
cid)
Local ConvId
lcnv
SubConvId
sub
(DeleteSubConversationRequest -> Sem r ())
-> DeleteSubConversationRequest -> Sem r ()
forall a b. (a -> b) -> a -> b
$ GroupId -> Epoch -> DeleteSubConversationRequest
DeleteSubConversationRequest GroupId
gid Epoch
epoch
else
Local ConvOrSubConv
-> Identity LeafIndex -> Qualified UserId -> ClientMap -> Sem r ()
forall (r :: EffectRow) (t :: * -> *).
(Member (Error FederationError) r, Member (Input UTCTime) r,
Member (Logger (Msg -> Msg)) r,
Member BackendNotificationQueueAccess r, Member ExternalAccess r,
Member NotificationSubsystem r, Member ProposalStore r,
Member (Input Env) r, Member Random r, Foldable t) =>
Local ConvOrSubConv
-> t LeafIndex -> Qualified UserId -> ClientMap -> Sem r ()
createAndSendRemoveProposals
(Local ConvId -> ConvOrSubConv -> Local ConvOrSubConv
forall (t :: QTag) x a.
QualifiedWithTag t x -> a -> QualifiedWithTag t a
qualifyAs Local ConvId
lcnv (MLSConversation -> SubConversation -> ConvOrSubConv
forall c s. c -> s -> ConvOrSubChoice c s
SubConv MLSConversation
mlsConv SubConversation
subConv))
(LeafIndex -> Identity LeafIndex
forall a. a -> Identity a
Identity LeafIndex
idx)
(ClientIdentity -> Qualified UserId
cidQualifiedUser ClientIdentity
cid)
ClientMap
cm
leaveRemoteSubConversation ::
( Members
'[ ErrorS 'ConvNotFound,
ErrorS 'ConvAccessDenied,
Error FederationError,
Error MLSProtocolError,
FederatorAccess
]
r
) =>
ClientIdentity ->
Remote ConvId ->
SubConvId ->
Sem r ()
leaveRemoteSubConversation :: forall (r :: EffectRow).
Members
'[ErrorS 'ConvNotFound, ErrorS 'ConvAccessDenied,
Error FederationError, Error MLSProtocolError, FederatorAccess]
r =>
ClientIdentity -> Remote ConvId -> SubConvId -> Sem r ()
leaveRemoteSubConversation ClientIdentity
cid Remote ConvId
rcnv SubConvId
sub = do
LeaveSubConversationResponse
res <-
Remote ConvId
-> FederatorClient 'Galley LeaveSubConversationResponse
-> Sem r LeaveSubConversationResponse
forall (r :: EffectRow) (c :: Component) x a.
(Member FederatorAccess r, KnownComponent c) =>
Remote x -> FederatorClient c a -> Sem r a
runFederated Remote ConvId
rcnv (FederatorClient 'Galley LeaveSubConversationResponse
-> Sem r LeaveSubConversationResponse)
-> FederatorClient 'Galley LeaveSubConversationResponse
-> Sem r LeaveSubConversationResponse
forall a b. (a -> b) -> a -> b
$
forall {k} (comp :: Component) (name :: k)
(fedM :: Component -> * -> *) (showcomp :: Symbol) api.
(showcomp ~ ShowComponent comp, HasFedEndpoint comp api name,
HasClient (fedM comp) api, KnownComponent comp, IsNamed name,
FederationMonad fedM, Typeable (Client (fedM comp) api)) =>
Client (fedM comp) api
forall (comp :: Component) (name :: Symbol)
(fedM :: Component -> * -> *) (showcomp :: Symbol) api.
(showcomp ~ ShowComponent comp, HasFedEndpoint comp api name,
HasClient (fedM comp) api, KnownComponent comp, IsNamed name,
FederationMonad fedM, Typeable (Client (fedM comp) api)) =>
Client (fedM comp) api
fedClient @'Galley @"leave-sub-conversation" (LeaveSubConversationRequest
-> FederatorClient 'Galley LeaveSubConversationResponse)
-> LeaveSubConversationRequest
-> FederatorClient 'Galley LeaveSubConversationResponse
forall a b. (a -> b) -> a -> b
$
LeaveSubConversationRequest
{ $sel:lscrUser:LeaveSubConversationRequest :: UserId
lscrUser = ClientIdentity -> UserId
ciUser ClientIdentity
cid,
$sel:lscrClient:LeaveSubConversationRequest :: ClientId
lscrClient = ClientIdentity -> ClientId
ciClient ClientIdentity
cid,
$sel:lscrConv:LeaveSubConversationRequest :: ConvId
lscrConv = Remote ConvId -> ConvId
forall (t :: QTag) a. QualifiedWithTag t a -> a
tUnqualified Remote ConvId
rcnv,
$sel:lscrSubConv:LeaveSubConversationRequest :: SubConvId
lscrSubConv = SubConvId
sub
}
case LeaveSubConversationResponse
res of
LeaveSubConversationResponseError GalleyError
e ->
forall (effs :: EffectRow) (r :: EffectRow) a.
RethrowErrors effs r =>
GalleyError -> Sem r a
rethrowErrors @'[ErrorS 'ConvNotFound, ErrorS 'ConvAccessDenied] GalleyError
e
LeaveSubConversationResponseProtocolError Text
e ->
MLSProtocolError -> Sem r ()
forall e (r :: EffectRow) a. Member (Error e) r => e -> Sem r a
throw (Text -> MLSProtocolError
mlsProtocolError Text
e)
LeaveSubConversationResponse
LeaveSubConversationResponseOk -> () -> Sem r ()
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()