module Galley.API.MLS.Removal
( createAndSendRemoveProposals,
removeExtraneousClients,
removeClient,
RemoveUserIncludeMain (..),
removeUser,
)
where
import Data.Bifunctor
import Data.Id
import Data.Map qualified as Map
import Data.Proxy
import Data.Qualified
import Data.Set qualified as Set
import Data.Time
import Galley.API.MLS.Conversation
import Galley.API.MLS.Keys
import Galley.API.MLS.Propagate
import Galley.API.MLS.Types
import Galley.Data.Conversation.Types
import Galley.Data.Conversation.Types qualified as Data
import Galley.Effects
import Galley.Effects.MemberStore
import Galley.Effects.ProposalStore
import Galley.Effects.SubConversationStore
import Galley.Env
import Galley.Types.Conversations.Members
import Imports
import Polysemy
import Polysemy.Error
import Polysemy.Input
import Polysemy.TinyLog
import System.Logger qualified as Log
import Wire.API.Conversation.Protocol
import Wire.API.Federation.Error
import Wire.API.MLS.AuthenticatedContent
import Wire.API.MLS.CipherSuite
import Wire.API.MLS.Credential
import Wire.API.MLS.LeafNode
import Wire.API.MLS.Message
import Wire.API.MLS.Proposal
import Wire.API.MLS.Serialisation
import Wire.API.MLS.SubConversation
import Wire.NotificationSubsystem
import Wire.Sem.Random
createAndSendRemoveProposals ::
forall r t.
( Member (Error FederationError) r,
Member (Input UTCTime) r,
Member TinyLog 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 :: forall (r :: EffectRow) (t :: * -> *).
(Member (Error FederationError) r, Member (Input UTCTime) r,
Member TinyLog 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 ConvOrSubConv
lConvOrSubConv t LeafIndex
indices Qualified UserId
qusr ClientMap
cm = Sem r (Either () ()) -> Sem r ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Sem r (Either () ()) -> Sem r ())
-> (Sem (Error () : r) () -> Sem r (Either () ()))
-> Sem (Error () : r) ()
-> Sem r ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e (r :: EffectRow) a.
Sem (Error e : r) a -> Sem r (Either e a)
runError @() (Sem (Error () : r) () -> Sem r ())
-> Sem (Error () : r) () -> Sem r ()
forall a b. (a -> b) -> a -> b
$ do
let meta :: ConversationMLSData
meta = (Local ConvOrSubConv -> ConvOrSubConv
forall (t :: QTag) a. QualifiedWithTag t a -> a
tUnqualified Local ConvOrSubConv
lConvOrSubConv).mlsMeta
ActiveMLSConversationData
activeData <- ()
-> Maybe ActiveMLSConversationData
-> Sem (Error () : r) ActiveMLSConversationData
forall e (r :: EffectRow) a.
Member (Error e) r =>
e -> Maybe a -> Sem r a
note () (Maybe ActiveMLSConversationData
-> Sem (Error () : r) ActiveMLSConversationData)
-> Maybe ActiveMLSConversationData
-> Sem (Error () : r) ActiveMLSConversationData
forall a b. (a -> b) -> a -> b
$ ConversationMLSData -> Maybe ActiveMLSConversationData
cnvmlsActiveData ConversationMLSData
meta
let cs :: CipherSuiteTag
cs = ActiveMLSConversationData
activeData.ciphersuite
Maybe SomeKeyPair
mKeyPair <- SignatureSchemeTag -> Sem (Error () : r) (Maybe SomeKeyPair)
forall (r :: EffectRow).
Member (Input Env) r =>
SignatureSchemeTag -> Sem r (Maybe SomeKeyPair)
getMLSRemovalKey (CipherSuiteTag -> SignatureSchemeTag
csSignatureScheme CipherSuiteTag
cs)
case Maybe SomeKeyPair
mKeyPair of
Maybe SomeKeyPair
Nothing -> do
(Msg -> Msg) -> Sem (Error () : r) ()
forall msg (r :: EffectRow).
Member (Logger msg) r =>
msg -> Sem r ()
warn ((Msg -> Msg) -> Sem (Error () : r) ())
-> (Msg -> Msg) -> Sem (Error () : r) ()
forall a b. (a -> b) -> a -> b
$ Text -> Msg -> Msg
forall a. ToBytes a => a -> Msg -> Msg
Log.msg (Text
"No backend removal key is configured (See 'mlsPrivateKeyPaths' in galley's config). Not able to remove client from MLS conversation." :: Text)
Just (SomeKeyPair (Proxy ss
_ :: Proxy ss) KeyPair ss
kp) -> do
t LeafIndex
-> (LeafIndex -> Sem (Error () : r) ()) -> Sem (Error () : r) ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ t LeafIndex
indices ((LeafIndex -> Sem (Error () : r) ()) -> Sem (Error () : r) ())
-> (LeafIndex -> Sem (Error () : r) ()) -> Sem (Error () : r) ()
forall a b. (a -> b) -> a -> b
$ \LeafIndex
idx -> do
let proposal :: RawMLS Proposal
proposal = Proposal -> RawMLS Proposal
forall a. SerialiseMLS a => a -> RawMLS a
mkRawMLS (LeafIndex -> Proposal
RemoveProposal LeafIndex
idx)
PublicMessage
pmsg <-
(forall (mr :: * -> *). MonadRandom mr => mr PublicMessage)
-> Sem (Error () : r) PublicMessage
forall (r :: EffectRow) a.
Member Random r =>
(forall (mr :: * -> *). MonadRandom mr => mr a) -> Sem r a
liftRandom ((forall (mr :: * -> *). MonadRandom mr => mr PublicMessage)
-> Sem (Error () : r) PublicMessage)
-> (forall (mr :: * -> *). MonadRandom mr => mr PublicMessage)
-> Sem (Error () : r) PublicMessage
forall a b. (a -> b) -> a -> b
$
forall (ss :: SignatureSchemeTag) (m :: * -> *).
(IsSignatureScheme ss, MonadRandom m) =>
KeyPair ss
-> GroupId
-> Epoch
-> TaggedSender
-> FramedContentData
-> m PublicMessage
mkSignedPublicMessage @ss
KeyPair ss
kp
(ConversationMLSData -> GroupId
cnvmlsGroupId ConversationMLSData
meta)
(ConversationMLSData -> Epoch
cnvmlsEpoch ConversationMLSData
meta)
(LeafIndex -> TaggedSender
TaggedSenderExternal LeafIndex
0)
(RawMLS Proposal -> FramedContentData
FramedContentProposal RawMLS Proposal
proposal)
let msg :: RawMLS Message
msg = Message -> RawMLS Message
forall a. SerialiseMLS a => a -> RawMLS a
mkRawMLS (MessageContent -> Message
mkMessage (PublicMessage -> MessageContent
MessagePublic PublicMessage
pmsg))
GroupId
-> Epoch
-> ProposalRef
-> ProposalOrigin
-> RawMLS Proposal
-> Sem (Error () : r) ()
forall (r :: EffectRow).
Member ProposalStore r =>
GroupId
-> Epoch
-> ProposalRef
-> ProposalOrigin
-> RawMLS Proposal
-> Sem r ()
storeProposal
(ConversationMLSData -> GroupId
cnvmlsGroupId ConversationMLSData
meta)
(ConversationMLSData -> Epoch
cnvmlsEpoch ConversationMLSData
meta)
(CipherSuiteTag -> PublicMessage -> ProposalRef
publicMessageRef CipherSuiteTag
cs PublicMessage
pmsg)
ProposalOrigin
ProposalOriginBackend
RawMLS Proposal
proposal
Qualified UserId
-> Maybe ClientId
-> Local ConvOrSubConv
-> Maybe ConnId
-> RawMLS Message
-> ClientMap
-> Sem (Error () : r) ()
forall (r :: EffectRow).
(Member BackendNotificationQueueAccess r,
Member (Error FederationError) r, Member ExternalAccess r,
Member (Input UTCTime) r, Member TinyLog r,
Member NotificationSubsystem r) =>
Qualified UserId
-> Maybe ClientId
-> Local ConvOrSubConv
-> Maybe ConnId
-> RawMLS Message
-> ClientMap
-> Sem r ()
propagateMessage Qualified UserId
qusr Maybe ClientId
forall a. Maybe a
Nothing Local ConvOrSubConv
lConvOrSubConv Maybe ConnId
forall a. Maybe a
Nothing RawMLS Message
msg ClientMap
cm
removeClientsWithClientMapRecursively ::
( Member (Error FederationError) r,
Member (Input UTCTime) r,
Member TinyLog r,
Member BackendNotificationQueueAccess r,
Member ExternalAccess r,
Member NotificationSubsystem r,
Member MemberStore r,
Member ProposalStore r,
Member SubConversationStore r,
Member (Input Env) r,
Member Random r,
Functor f,
Foldable f
) =>
Local MLSConversation ->
(ConvOrSubConv -> f (ClientIdentity, LeafIndex)) ->
Qualified UserId ->
Sem r ()
removeClientsWithClientMapRecursively :: forall (r :: EffectRow) (f :: * -> *).
(Member (Error FederationError) r, Member (Input UTCTime) r,
Member TinyLog r, Member BackendNotificationQueueAccess r,
Member ExternalAccess r, Member NotificationSubsystem r,
Member MemberStore r, Member ProposalStore r,
Member SubConversationStore r, Member (Input Env) r,
Member Random r, Functor f, Foldable f) =>
Local MLSConversation
-> (ConvOrSubConv -> f (ClientIdentity, LeafIndex))
-> Qualified UserId
-> Sem r ()
removeClientsWithClientMapRecursively Local MLSConversation
lMlsConv ConvOrSubConv -> f (ClientIdentity, LeafIndex)
getClients Qualified UserId
qusr = do
let mainConv :: Local ConvOrSubConv
mainConv = (MLSConversation -> ConvOrSubConv)
-> Local MLSConversation -> Local ConvOrSubConv
forall a b.
(a -> b)
-> QualifiedWithTag 'QLocal a -> QualifiedWithTag 'QLocal b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap MLSConversation -> ConvOrSubConv
forall c s. c -> ConvOrSubChoice c s
Conv Local MLSConversation
lMlsConv
cm :: ClientMap
cm = MLSConversation -> ClientMap
mcMembers (Local MLSConversation -> MLSConversation
forall (t :: QTag) a. QualifiedWithTag t a -> a
tUnqualified Local MLSConversation
lMlsConv)
do
let gid :: GroupId
gid = ConversationMLSData -> GroupId
cnvmlsGroupId (ConversationMLSData -> GroupId)
-> (Local MLSConversation -> ConversationMLSData)
-> Local MLSConversation
-> GroupId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MLSConversation -> ConversationMLSData
mcMLSData (MLSConversation -> ConversationMLSData)
-> (Local MLSConversation -> MLSConversation)
-> Local MLSConversation
-> ConversationMLSData
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Local MLSConversation -> MLSConversation
forall (t :: QTag) a. QualifiedWithTag t a -> a
tUnqualified (Local MLSConversation -> GroupId)
-> Local MLSConversation -> GroupId
forall a b. (a -> b) -> a -> b
$ Local MLSConversation
lMlsConv
clients :: f (ClientIdentity, LeafIndex)
clients = ConvOrSubConv -> f (ClientIdentity, LeafIndex)
getClients (Local ConvOrSubConv -> ConvOrSubConv
forall (t :: QTag) a. QualifiedWithTag t a -> a
tUnqualified Local ConvOrSubConv
mainConv)
GroupId -> f ClientIdentity -> Sem r ()
forall (r :: EffectRow) (f :: * -> *).
(Member MemberStore r, Foldable f) =>
GroupId -> f ClientIdentity -> Sem r ()
planClientRemoval GroupId
gid (((ClientIdentity, LeafIndex) -> ClientIdentity)
-> f (ClientIdentity, LeafIndex) -> f ClientIdentity
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ClientIdentity, LeafIndex) -> ClientIdentity
forall a b. (a, b) -> a
fst f (ClientIdentity, LeafIndex)
clients)
Local ConvOrSubConv
-> f LeafIndex -> Qualified UserId -> ClientMap -> Sem r ()
forall (r :: EffectRow) (t :: * -> *).
(Member (Error FederationError) r, Member (Input UTCTime) r,
Member TinyLog 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 ConvOrSubConv
mainConv (((ClientIdentity, LeafIndex) -> LeafIndex)
-> f (ClientIdentity, LeafIndex) -> f LeafIndex
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ClientIdentity, LeafIndex) -> LeafIndex
forall a b. (a, b) -> b
snd f (ClientIdentity, LeafIndex)
clients) Qualified UserId
qusr ClientMap
cm
Local MLSConversation
-> (ConvOrSubConv -> f (ClientIdentity, LeafIndex))
-> Qualified UserId
-> Sem r ()
forall (r :: EffectRow) (f :: * -> *).
(Member (Error FederationError) r, Member (Input UTCTime) r,
Member TinyLog r, Member BackendNotificationQueueAccess r,
Member ExternalAccess r, Member NotificationSubsystem r,
Member MemberStore r, Member ProposalStore r,
Member SubConversationStore r, Member (Input Env) r,
Member Random r, Functor f, Foldable f) =>
Local MLSConversation
-> (ConvOrSubConv -> f (ClientIdentity, LeafIndex))
-> Qualified UserId
-> Sem r ()
removeClientsFromSubConvs Local MLSConversation
lMlsConv ConvOrSubConv -> f (ClientIdentity, LeafIndex)
getClients Qualified UserId
qusr
removeClientsFromSubConvs ::
( Member (Error FederationError) r,
Member (Input UTCTime) r,
Member TinyLog r,
Member BackendNotificationQueueAccess r,
Member ExternalAccess r,
Member NotificationSubsystem r,
Member MemberStore r,
Member ProposalStore r,
Member SubConversationStore r,
Member (Input Env) r,
Member Random r,
Functor f,
Foldable f
) =>
Local MLSConversation ->
(ConvOrSubConv -> f (ClientIdentity, LeafIndex)) ->
Qualified UserId ->
Sem r ()
removeClientsFromSubConvs :: forall (r :: EffectRow) (f :: * -> *).
(Member (Error FederationError) r, Member (Input UTCTime) r,
Member TinyLog r, Member BackendNotificationQueueAccess r,
Member ExternalAccess r, Member NotificationSubsystem r,
Member MemberStore r, Member ProposalStore r,
Member SubConversationStore r, Member (Input Env) r,
Member Random r, Functor f, Foldable f) =>
Local MLSConversation
-> (ConvOrSubConv -> f (ClientIdentity, LeafIndex))
-> Qualified UserId
-> Sem r ()
removeClientsFromSubConvs Local MLSConversation
lMlsConv ConvOrSubConv -> f (ClientIdentity, LeafIndex)
getClients Qualified UserId
qusr = do
let cm :: ClientMap
cm = MLSConversation -> ClientMap
mcMembers (Local MLSConversation -> MLSConversation
forall (t :: QTag) a. QualifiedWithTag t a -> a
tUnqualified Local MLSConversation
lMlsConv)
[SubConversation]
subs <- ConvId -> Sem r [SubConversation]
forall (r :: EffectRow).
Member SubConversationStore r =>
ConvId -> Sem r [SubConversation]
listSubConversations' (MLSConversation -> ConvId
mcId (Local MLSConversation -> MLSConversation
forall (t :: QTag) a. QualifiedWithTag t a -> a
tUnqualified Local MLSConversation
lMlsConv))
[SubConversation] -> (SubConversation -> Sem r ()) -> Sem r ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [SubConversation]
subs ((SubConversation -> Sem r ()) -> Sem r ())
-> (SubConversation -> Sem r ()) -> Sem r ()
forall a b. (a -> b) -> a -> b
$ \SubConversation
sub -> do
let subConv :: Local ConvOrSubConv
subConv = (MLSConversation -> ConvOrSubConv)
-> Local MLSConversation -> Local ConvOrSubConv
forall a b.
(a -> b)
-> QualifiedWithTag 'QLocal a -> QualifiedWithTag 'QLocal b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((MLSConversation -> SubConversation -> ConvOrSubConv)
-> SubConversation -> MLSConversation -> ConvOrSubConv
forall a b c. (a -> b -> c) -> b -> a -> c
flip MLSConversation -> SubConversation -> ConvOrSubConv
forall c s. c -> s -> ConvOrSubChoice c s
SubConv SubConversation
sub) Local MLSConversation
lMlsConv
sgid :: GroupId
sgid = ConversationMLSData -> GroupId
cnvmlsGroupId (ConversationMLSData -> GroupId)
-> (SubConversation -> ConversationMLSData)
-> SubConversation
-> GroupId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SubConversation -> ConversationMLSData
scMLSData (SubConversation -> GroupId) -> SubConversation -> GroupId
forall a b. (a -> b) -> a -> b
$ SubConversation
sub
clients :: f (ClientIdentity, LeafIndex)
clients = ConvOrSubConv -> f (ClientIdentity, LeafIndex)
getClients (Local ConvOrSubConv -> ConvOrSubConv
forall (t :: QTag) a. QualifiedWithTag t a -> a
tUnqualified Local ConvOrSubConv
subConv)
GroupId -> f ClientIdentity -> Sem r ()
forall (r :: EffectRow) (f :: * -> *).
(Member MemberStore r, Foldable f) =>
GroupId -> f ClientIdentity -> Sem r ()
planClientRemoval GroupId
sgid (((ClientIdentity, LeafIndex) -> ClientIdentity)
-> f (ClientIdentity, LeafIndex) -> f ClientIdentity
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ClientIdentity, LeafIndex) -> ClientIdentity
forall a b. (a, b) -> a
fst f (ClientIdentity, LeafIndex)
clients)
Local ConvOrSubConv
-> f LeafIndex -> Qualified UserId -> ClientMap -> Sem r ()
forall (r :: EffectRow) (t :: * -> *).
(Member (Error FederationError) r, Member (Input UTCTime) r,
Member TinyLog 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 ConvOrSubConv
subConv
(((ClientIdentity, LeafIndex) -> LeafIndex)
-> f (ClientIdentity, LeafIndex) -> f LeafIndex
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ClientIdentity, LeafIndex) -> LeafIndex
forall a b. (a, b) -> b
snd f (ClientIdentity, LeafIndex)
clients)
Qualified UserId
qusr
ClientMap
cm
removeClient ::
( Member BackendNotificationQueueAccess r,
Member (Error FederationError) r,
Member ExternalAccess r,
Member NotificationSubsystem r,
Member (Input Env) r,
Member (Input UTCTime) r,
Member MemberStore r,
Member ProposalStore r,
Member Random r,
Member SubConversationStore r,
Member TinyLog r
) =>
Local Data.Conversation ->
Qualified UserId ->
ClientId ->
Sem r ()
removeClient :: forall (r :: EffectRow).
(Member BackendNotificationQueueAccess r,
Member (Error FederationError) r, Member ExternalAccess r,
Member NotificationSubsystem r, Member (Input Env) r,
Member (Input UTCTime) r, Member MemberStore r,
Member ProposalStore r, Member Random r,
Member SubConversationStore r, Member TinyLog r) =>
Local Conversation -> Qualified UserId -> ClientId -> Sem r ()
removeClient Local Conversation
lc Qualified UserId
qusr ClientId
c = do
Maybe MLSConversation
mMlsConv <- Conversation -> Sem r (Maybe MLSConversation)
forall (r :: EffectRow).
Member MemberStore r =>
Conversation -> Sem r (Maybe MLSConversation)
mkMLSConversation (Local Conversation -> Conversation
forall (t :: QTag) a. QualifiedWithTag t a -> a
tUnqualified Local Conversation
lc)
Maybe MLSConversation -> (MLSConversation -> Sem r ()) -> Sem r ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Maybe MLSConversation
mMlsConv ((MLSConversation -> Sem r ()) -> Sem r ())
-> (MLSConversation -> Sem r ()) -> Sem r ()
forall a b. (a -> b) -> a -> b
$ \MLSConversation
mlsConv -> do
let cid :: ClientIdentity
cid = Qualified UserId -> ClientId -> ClientIdentity
mkClientIdentity Qualified UserId
qusr ClientId
c
let getClients :: ConvOrSubConv -> Maybe (ClientIdentity, LeafIndex)
getClients = (LeafIndex -> (ClientIdentity, LeafIndex))
-> Maybe LeafIndex -> Maybe (ClientIdentity, LeafIndex)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ClientIdentity
cid,) (Maybe LeafIndex -> Maybe (ClientIdentity, LeafIndex))
-> (ConvOrSubConv -> Maybe LeafIndex)
-> ConvOrSubConv
-> Maybe (ClientIdentity, LeafIndex)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ClientIdentity -> ClientMap -> Maybe LeafIndex
cmLookupIndex ClientIdentity
cid (ClientMap -> Maybe LeafIndex)
-> (ConvOrSubConv -> ClientMap) -> ConvOrSubConv -> Maybe LeafIndex
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (.members)
Local MLSConversation
-> (ConvOrSubConv -> Maybe (ClientIdentity, LeafIndex))
-> Qualified UserId
-> Sem r ()
forall (r :: EffectRow) (f :: * -> *).
(Member (Error FederationError) r, Member (Input UTCTime) r,
Member TinyLog r, Member BackendNotificationQueueAccess r,
Member ExternalAccess r, Member NotificationSubsystem r,
Member MemberStore r, Member ProposalStore r,
Member SubConversationStore r, Member (Input Env) r,
Member Random r, Functor f, Foldable f) =>
Local MLSConversation
-> (ConvOrSubConv -> f (ClientIdentity, LeafIndex))
-> Qualified UserId
-> Sem r ()
removeClientsWithClientMapRecursively (Local Conversation -> MLSConversation -> Local MLSConversation
forall (t :: QTag) x a.
QualifiedWithTag t x -> a -> QualifiedWithTag t a
qualifyAs Local Conversation
lc MLSConversation
mlsConv) ConvOrSubConv -> Maybe (ClientIdentity, LeafIndex)
getClients Qualified UserId
qusr
data RemoveUserIncludeMain
=
RemoveUserIncludeMain
|
RemoveUserExcludeMain
removeUser ::
( Member BackendNotificationQueueAccess r,
Member (Error FederationError) r,
Member ExternalAccess r,
Member NotificationSubsystem r,
Member (Input Env) r,
Member (Input UTCTime) r,
Member MemberStore r,
Member ProposalStore r,
Member Random r,
Member SubConversationStore r,
Member TinyLog r
) =>
Local Data.Conversation ->
RemoveUserIncludeMain ->
Qualified UserId ->
Sem r ()
removeUser :: forall (r :: EffectRow).
(Member BackendNotificationQueueAccess r,
Member (Error FederationError) r, Member ExternalAccess r,
Member NotificationSubsystem r, Member (Input Env) r,
Member (Input UTCTime) r, Member MemberStore r,
Member ProposalStore r, Member Random r,
Member SubConversationStore r, Member TinyLog r) =>
Local Conversation
-> RemoveUserIncludeMain -> Qualified UserId -> Sem r ()
removeUser Local Conversation
lc RemoveUserIncludeMain
includeMain Qualified UserId
qusr = do
Maybe MLSConversation
mMlsConv <- Conversation -> Sem r (Maybe MLSConversation)
forall (r :: EffectRow).
Member MemberStore r =>
Conversation -> Sem r (Maybe MLSConversation)
mkMLSConversation (Local Conversation -> Conversation
forall (t :: QTag) a. QualifiedWithTag t a -> a
tUnqualified Local Conversation
lc)
Maybe MLSConversation -> (MLSConversation -> Sem r ()) -> Sem r ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Maybe MLSConversation
mMlsConv ((MLSConversation -> Sem r ()) -> Sem r ())
-> (MLSConversation -> Sem r ()) -> Sem r ()
forall a b. (a -> b) -> a -> b
$ \MLSConversation
mlsConv -> do
let getClients :: ConvOrSubConv -> [(ClientIdentity, LeafIndex)]
getClients :: ConvOrSubConv -> [(ClientIdentity, LeafIndex)]
getClients =
((ClientId, LeafIndex) -> (ClientIdentity, LeafIndex))
-> [(ClientId, LeafIndex)] -> [(ClientIdentity, LeafIndex)]
forall a b. (a -> b) -> [a] -> [b]
map ((ClientId -> ClientIdentity)
-> (ClientId, LeafIndex) -> (ClientIdentity, LeafIndex)
forall a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (Qualified UserId -> ClientId -> ClientIdentity
mkClientIdentity Qualified UserId
qusr))
([(ClientId, LeafIndex)] -> [(ClientIdentity, LeafIndex)])
-> (ConvOrSubConv -> [(ClientId, LeafIndex)])
-> ConvOrSubConv
-> [(ClientIdentity, LeafIndex)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map ClientId LeafIndex -> [(ClientId, LeafIndex)]
forall k a. Map k a -> [(k, a)]
Map.assocs
(Map ClientId LeafIndex -> [(ClientId, LeafIndex)])
-> (ConvOrSubConv -> Map ClientId LeafIndex)
-> ConvOrSubConv
-> [(ClientId, LeafIndex)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map ClientId LeafIndex
-> Qualified UserId -> ClientMap -> Map ClientId LeafIndex
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault Map ClientId LeafIndex
forall a. Monoid a => a
mempty Qualified UserId
qusr
(ClientMap -> Map ClientId LeafIndex)
-> (ConvOrSubConv -> ClientMap)
-> ConvOrSubConv
-> Map ClientId LeafIndex
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (.members)
case RemoveUserIncludeMain
includeMain of
RemoveUserIncludeMain
RemoveUserIncludeMain ->
Local MLSConversation
-> (ConvOrSubConv -> [(ClientIdentity, LeafIndex)])
-> Qualified UserId
-> Sem r ()
forall (r :: EffectRow) (f :: * -> *).
(Member (Error FederationError) r, Member (Input UTCTime) r,
Member TinyLog r, Member BackendNotificationQueueAccess r,
Member ExternalAccess r, Member NotificationSubsystem r,
Member MemberStore r, Member ProposalStore r,
Member SubConversationStore r, Member (Input Env) r,
Member Random r, Functor f, Foldable f) =>
Local MLSConversation
-> (ConvOrSubConv -> f (ClientIdentity, LeafIndex))
-> Qualified UserId
-> Sem r ()
removeClientsWithClientMapRecursively
(Local Conversation -> MLSConversation -> Local MLSConversation
forall (t :: QTag) x a.
QualifiedWithTag t x -> a -> QualifiedWithTag t a
qualifyAs Local Conversation
lc MLSConversation
mlsConv)
ConvOrSubConv -> [(ClientIdentity, LeafIndex)]
getClients
Qualified UserId
qusr
RemoveUserIncludeMain
RemoveUserExcludeMain ->
Local MLSConversation
-> (ConvOrSubConv -> [(ClientIdentity, LeafIndex)])
-> Qualified UserId
-> Sem r ()
forall (r :: EffectRow) (f :: * -> *).
(Member (Error FederationError) r, Member (Input UTCTime) r,
Member TinyLog r, Member BackendNotificationQueueAccess r,
Member ExternalAccess r, Member NotificationSubsystem r,
Member MemberStore r, Member ProposalStore r,
Member SubConversationStore r, Member (Input Env) r,
Member Random r, Functor f, Foldable f) =>
Local MLSConversation
-> (ConvOrSubConv -> f (ClientIdentity, LeafIndex))
-> Qualified UserId
-> Sem r ()
removeClientsFromSubConvs (Local Conversation -> MLSConversation -> Local MLSConversation
forall (t :: QTag) x a.
QualifiedWithTag t x -> a -> QualifiedWithTag t a
qualifyAs Local Conversation
lc MLSConversation
mlsConv) ConvOrSubConv -> [(ClientIdentity, LeafIndex)]
getClients Qualified UserId
qusr
listSubConversations' ::
(Member SubConversationStore r) =>
ConvId ->
Sem r [SubConversation]
listSubConversations' :: forall (r :: EffectRow).
Member SubConversationStore r =>
ConvId -> Sem r [SubConversation]
listSubConversations' ConvId
cid = do
Map SubConvId ConversationMLSData
subs <- ConvId -> Sem r (Map SubConvId ConversationMLSData)
forall (r :: EffectRow).
Member SubConversationStore r =>
ConvId -> Sem r (Map SubConvId ConversationMLSData)
listSubConversations ConvId
cid
[Maybe SubConversation]
msubs <- [(SubConvId, ConversationMLSData)]
-> ((SubConvId, ConversationMLSData)
-> Sem r (Maybe SubConversation))
-> Sem r [Maybe SubConversation]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for (Map SubConvId ConversationMLSData
-> [(SubConvId, ConversationMLSData)]
forall k a. Map k a -> [(k, a)]
Map.assocs Map SubConvId ConversationMLSData
subs) (((SubConvId, ConversationMLSData)
-> Sem r (Maybe SubConversation))
-> Sem r [Maybe SubConversation])
-> ((SubConvId, ConversationMLSData)
-> Sem r (Maybe SubConversation))
-> Sem r [Maybe SubConversation]
forall a b. (a -> b) -> a -> b
$ \(SubConvId
subId, ConversationMLSData
_) -> do
ConvId -> SubConvId -> Sem r (Maybe SubConversation)
forall (r :: EffectRow).
Member SubConversationStore r =>
ConvId -> SubConvId -> Sem r (Maybe SubConversation)
getSubConversation ConvId
cid SubConvId
subId
[SubConversation] -> Sem r [SubConversation]
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Maybe SubConversation] -> [SubConversation]
forall a. [Maybe a] -> [a]
catMaybes [Maybe SubConversation]
msubs)
removeExtraneousClients ::
( Member BackendNotificationQueueAccess r,
Member (Error FederationError) r,
Member ExternalAccess r,
Member NotificationSubsystem r,
Member (Input Env) r,
Member (Input UTCTime) r,
Member MemberStore r,
Member ProposalStore r,
Member Random r,
Member SubConversationStore r,
Member TinyLog r
) =>
Qualified UserId ->
Local Conversation ->
Sem r ()
Qualified UserId
qusr Local Conversation
lconv = do
Maybe MLSConversation
mMlsConv <- Conversation -> Sem r (Maybe MLSConversation)
forall (r :: EffectRow).
Member MemberStore r =>
Conversation -> Sem r (Maybe MLSConversation)
mkMLSConversation (Local Conversation -> Conversation
forall (t :: QTag) a. QualifiedWithTag t a -> a
tUnqualified Local Conversation
lconv)
Maybe MLSConversation -> (MLSConversation -> Sem r ()) -> Sem r ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Maybe MLSConversation
mMlsConv ((MLSConversation -> Sem r ()) -> Sem r ())
-> (MLSConversation -> Sem r ()) -> Sem r ()
forall a b. (a -> b) -> a -> b
$ \MLSConversation
mlsConv -> do
let allMembers :: Set (Qualified UserId)
allMembers =
[Qualified UserId] -> Set (Qualified UserId)
forall a. Ord a => [a] -> Set a
Set.fromList ([Qualified UserId] -> Set (Qualified UserId))
-> [Qualified UserId] -> Set (Qualified UserId)
forall a b. (a -> b) -> a -> b
$
(LocalMember -> Qualified UserId)
-> [LocalMember] -> [Qualified UserId]
forall a b. (a -> b) -> [a] -> [b]
map (QualifiedWithTag 'QLocal UserId -> Qualified UserId
forall (t :: QTag) a. QualifiedWithTag t a -> Qualified a
tUntagged (QualifiedWithTag 'QLocal UserId -> Qualified UserId)
-> (LocalMember -> QualifiedWithTag 'QLocal UserId)
-> LocalMember
-> Qualified UserId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Local Conversation -> UserId -> QualifiedWithTag 'QLocal UserId
forall (t :: QTag) x a.
QualifiedWithTag t x -> a -> QualifiedWithTag t a
qualifyAs Local Conversation
lconv (UserId -> QualifiedWithTag 'QLocal UserId)
-> (LocalMember -> UserId)
-> LocalMember
-> QualifiedWithTag 'QLocal UserId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LocalMember -> UserId
lmId) (MLSConversation -> [LocalMember]
mcLocalMembers MLSConversation
mlsConv)
[Qualified UserId] -> [Qualified UserId] -> [Qualified UserId]
forall a. Semigroup a => a -> a -> a
<> (RemoteMember -> Qualified UserId)
-> [RemoteMember] -> [Qualified UserId]
forall a b. (a -> b) -> [a] -> [b]
map (QualifiedWithTag 'QRemote UserId -> Qualified UserId
forall (t :: QTag) a. QualifiedWithTag t a -> Qualified a
tUntagged (QualifiedWithTag 'QRemote UserId -> Qualified UserId)
-> (RemoteMember -> QualifiedWithTag 'QRemote UserId)
-> RemoteMember
-> Qualified UserId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RemoteMember -> QualifiedWithTag 'QRemote UserId
rmId) (MLSConversation -> [RemoteMember]
mcRemoteMembers MLSConversation
mlsConv)
let getClients :: ConvOrSubConv -> [(ClientIdentity, LeafIndex)]
getClients ConvOrSubConv
c =
((ClientIdentity, LeafIndex) -> Bool)
-> [(ClientIdentity, LeafIndex)] -> [(ClientIdentity, LeafIndex)]
forall a. (a -> Bool) -> [a] -> [a]
filter
(\(ClientIdentity
cid, LeafIndex
_) -> ClientIdentity -> Qualified UserId
cidQualifiedUser ClientIdentity
cid Qualified UserId -> Set (Qualified UserId) -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.notMember` Set (Qualified UserId)
allMembers)
(ClientMap -> [(ClientIdentity, LeafIndex)]
cmAssocs ConvOrSubConv
c.members)
Local MLSConversation
-> (ConvOrSubConv -> [(ClientIdentity, LeafIndex)])
-> Qualified UserId
-> Sem r ()
forall (r :: EffectRow) (f :: * -> *).
(Member (Error FederationError) r, Member (Input UTCTime) r,
Member TinyLog r, Member BackendNotificationQueueAccess r,
Member ExternalAccess r, Member NotificationSubsystem r,
Member MemberStore r, Member ProposalStore r,
Member SubConversationStore r, Member (Input Env) r,
Member Random r, Functor f, Foldable f) =>
Local MLSConversation
-> (ConvOrSubConv -> f (ClientIdentity, LeafIndex))
-> Qualified UserId
-> Sem r ()
removeClientsWithClientMapRecursively (Local Conversation -> MLSConversation -> Local MLSConversation
forall (t :: QTag) x a.
QualifiedWithTag t x -> a -> QualifiedWithTag t a
qualifyAs Local Conversation
lconv MLSConversation
mlsConv) ConvOrSubConv -> [(ClientIdentity, LeafIndex)]
getClients Qualified UserId
qusr