-- This file is part of the Wire Server implementation.
--
-- Copyright (C) 2022 Wire Swiss GmbH <opensource@wire.com>
--
-- This program is free software: you can redistribute it and/or modify it under
-- the terms of the GNU Affero General Public License as published by the Free
-- Software Foundation, either version 3 of the License, or (at your option) any
-- later version.
--
-- This program is distributed in the hope that it will be useful, but WITHOUT
-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more
-- details.
--
-- You should have received a copy of the GNU Affero General Public License along
-- with this program. If not, see <https://www.gnu.org/licenses/>.

module 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

-- | Send remove proposals for a set of clients to clients in the ClientMap.
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 ->
  -- | The client map that has all the recipients of the message. This is an
  -- argument, and not constructed within the function, because of a special
  -- case of subconversations where everyone but the subconversation leaver
  -- client should get the remove proposal message; in this case the recipients
  -- are a strict subset of all the clients represented by the in-memory
  -- conversation/subconversation client maps.
  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 ->
  -- | A function returning the "list" of clients to be removed from either the
  -- main conversation or each of its subconversations.
  (ConvOrSubConv -> f (ClientIdentity, LeafIndex)) ->
  -- | Originating user. The resulting proposals will appear to be sent by this user.
  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 ->
  -- | A function returning the "list" of clients to be removed from either the
  -- main conversation or each of its subconversations.
  (ConvOrSubConv -> f (ClientIdentity, LeafIndex)) ->
  -- | Originating user. The resulting proposals will appear to be sent by this user.
  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)

  -- remove this client from all subconversations
  [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

-- | Send remove proposals for a single client of a user to the local conversation.
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

-- | A flag to determine whether 'removeUser' should operate on the parent
-- conversation as well as all the subconversations.
data RemoveUserIncludeMain
  = -- | Remove user clients from all subconversations, including the parent.
    RemoveUserIncludeMain
  | -- | Remove user clients from all subconversations, but not the parent.
    --
    -- This can be used when the clients are already in the process of being
    -- removed from the main conversation, for example as a result of a commit
    -- containing a remove proposal.
    RemoveUserExcludeMain

-- | Send remove proposals for all clients of the user to the local conversation.
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

-- | Convert cassandra subconv maps into SubConversations
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)

-- | Send remove proposals for clients of users that are not part of a conversation
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 ()
removeExtraneousClients :: 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) =>
Qualified UserId -> Local Conversation -> Sem r ()
removeExtraneousClients 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