-- 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.Commit.ExternalCommit
  ( getExternalCommitData,
    processExternalCommit,
  )
where

import Control.Comonad
import Control.Lens (forOf_)
import Data.Map qualified as Map
import Data.Qualified
import Data.Set qualified as Set
import Galley.API.MLS.Commit.Core
import Galley.API.MLS.Proposal
import Galley.API.MLS.Removal
import Galley.API.MLS.Types
import Galley.API.MLS.Util
import Galley.Effects
import Galley.Effects.ConversationStore
import Galley.Effects.MemberStore
import Galley.Effects.SubConversationStore
import Imports
import Polysemy
import Polysemy.Error
import Polysemy.Resource (Resource)
import Polysemy.State
import Wire.API.Conversation.Protocol
import Wire.API.Error
import Wire.API.Error.Galley
import Wire.API.Federation.Error
import Wire.API.MLS.CipherSuite
import Wire.API.MLS.Commit
import Wire.API.MLS.Credential
import Wire.API.MLS.LeafNode
import Wire.API.MLS.Proposal
import Wire.API.MLS.ProposalTag
import Wire.API.MLS.Serialisation
import Wire.API.MLS.SubConversation
import Wire.API.MLS.Validation

data ExternalCommitAction = ExternalCommitAction
  { ExternalCommitAction -> LeafIndex
add :: LeafIndex,
    ExternalCommitAction -> Maybe LeafIndex
remove :: Maybe LeafIndex
  }

getExternalCommitData ::
  forall r.
  ( Member (Error MLSProtocolError) r,
    Member (ErrorS 'MLSStaleMessage) r,
    Member (ErrorS 'MLSUnsupportedProposal) r,
    Member (ErrorS 'MLSInvalidLeafNodeIndex) r
  ) =>
  ClientIdentity ->
  Local ConvOrSubConv ->
  Epoch ->
  Commit ->
  Sem r ExternalCommitAction
getExternalCommitData :: forall (r :: EffectRow).
(Member (Error MLSProtocolError) r,
 Member (ErrorS 'MLSStaleMessage) r,
 Member (ErrorS 'MLSUnsupportedProposal) r,
 Member (ErrorS 'MLSInvalidLeafNodeIndex) r) =>
ClientIdentity
-> Local ConvOrSubConv
-> Epoch
-> Commit
-> Sem r ExternalCommitAction
getExternalCommitData ClientIdentity
senderIdentity Local ConvOrSubConv
lConvOrSub Epoch
epoch Commit
commit = do
  let convOrSub :: ConvOrSubConv
convOrSub = Local ConvOrSubConv -> ConvOrSubConv
forall (t :: QTag) a. QualifiedWithTag t a -> a
tUnqualified Local ConvOrSubConv
lConvOrSub
      groupId :: GroupId
groupId = ConversationMLSData -> GroupId
cnvmlsGroupId ConvOrSubConv
convOrSub.mlsMeta
  ActiveMLSConversationData
activeData <-
    MLSProtocolError
-> Maybe ActiveMLSConversationData
-> Sem r ActiveMLSConversationData
forall e (r :: EffectRow) a.
Member (Error e) r =>
e -> Maybe a -> Sem r a
note (Text -> MLSProtocolError
mlsProtocolError Text
"The first commit in a group cannot be external") (Maybe ActiveMLSConversationData
 -> Sem r ActiveMLSConversationData)
-> Maybe ActiveMLSConversationData
-> Sem r ActiveMLSConversationData
forall a b. (a -> b) -> a -> b
$
      ConversationMLSData -> Maybe ActiveMLSConversationData
cnvmlsActiveData ConvOrSubConv
convOrSub.mlsMeta
  let curEpoch :: Epoch
curEpoch = ActiveMLSConversationData
activeData.epoch
  Bool -> Sem r () -> Sem r ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Epoch
epoch Epoch -> Epoch -> Bool
forall a. Eq a => a -> a -> Bool
/= Epoch
curEpoch) (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
  Bool -> Sem r () -> Sem r ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Epoch
epoch Epoch -> Epoch -> Bool
forall a. Eq a => a -> a -> Bool
== Word64 -> Epoch
Epoch Word64
0) (Sem r () -> Sem r ()) -> Sem r () -> Sem r ()
forall a b. (a -> b) -> a -> b
$
    MLSProtocolError -> Sem r ()
forall e (r :: EffectRow) a. Member (Error e) r => e -> Sem r a
throw (MLSProtocolError -> Sem r ()) -> MLSProtocolError -> Sem r ()
forall a b. (a -> b) -> a -> b
$
      Text -> MLSProtocolError
mlsProtocolError Text
"The first commit in a group cannot be external"
  [Proposal]
proposals <- (ProposalOrRef -> Sem r Proposal)
-> [ProposalOrRef] -> Sem r [Proposal]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse ProposalOrRef -> Sem r Proposal
getInlineProposal Commit
commit.proposals

  -- According to the spec, an external commit must contain:
  -- (https://messaginglayersecurity.rocks/mls-protocol/draft-ietf-mls-protocol.html#section-12.2)
  --
  -- > Exactly one ExternalInit
  -- > At most one Remove proposal, with which the joiner removes an old
  -- > version of themselves.
  -- > Zero or more PreSharedKey proposals.
  -- > No other proposals.
  let counts :: Map ProposalTag Int
counts = (Proposal -> Map ProposalTag Int -> Map ProposalTag Int)
-> Map ProposalTag Int -> [Proposal] -> Map ProposalTag Int
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\Proposal
x -> (Int -> Int -> Int)
-> ProposalTag -> Int -> Map ProposalTag Int -> Map ProposalTag Int
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith Int -> Int -> Int
forall a. Num a => a -> a -> a
(+) Proposal
x.tag (Int
1 :: Int)) Map ProposalTag Int
forall a. Monoid a => a
mempty [Proposal]
proposals

  Bool -> Sem r () -> Sem r ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ProposalTag -> Map ProposalTag Int -> Maybe Int
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ProposalTag
ExternalInitProposalTag Map ProposalTag Int
counts Maybe Int -> Maybe Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int -> Maybe Int
forall a. a -> Maybe a
Just Int
1) (Sem r () -> Sem r ()) -> Sem r () -> Sem r ()
forall a b. (a -> b) -> a -> b
$
    MLSProtocolError -> Sem r ()
forall e (r :: EffectRow) a. Member (Error e) r => e -> Sem r a
throw (Text -> MLSProtocolError
mlsProtocolError Text
"External commits must contain exactly one ExternalInit proposal")
  Bool -> Sem r () -> Sem r ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([ProposalTag] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Map ProposalTag Int -> [ProposalTag]
forall k a. Map k a -> [k]
Map.keys Map ProposalTag Int
counts [ProposalTag] -> [ProposalTag] -> [ProposalTag]
forall a. Eq a => [a] -> [a] -> [a]
\\ [ProposalTag]
allowedProposals)) (Sem r () -> Sem r ()) -> Sem r () -> Sem r ()
forall a b. (a -> b) -> a -> b
$
    MLSProtocolError -> Sem r ()
forall e (r :: EffectRow) a. Member (Error e) r => e -> Sem r a
throw (Text -> MLSProtocolError
mlsProtocolError Text
"Invalid proposal type in an external commit")

  IndexMap
-> Sem (State IndexMap : r) ExternalCommitAction
-> Sem r ExternalCommitAction
forall s (r :: EffectRow) a. s -> Sem (State s : r) a -> Sem r a
evalState ConvOrSubConv
convOrSub.indexMap (Sem (State IndexMap : r) ExternalCommitAction
 -> Sem r ExternalCommitAction)
-> Sem (State IndexMap : r) ExternalCommitAction
-> Sem r ExternalCommitAction
forall a b. (a -> b) -> a -> b
$ do
    -- process optional removal
    ProposalAction
propAction <- CipherSuiteTag
-> GroupId -> [Proposal] -> Sem (State IndexMap : r) ProposalAction
forall (r :: EffectRow).
(Member (State IndexMap) r, Member (Error MLSProtocolError) r,
 Member (ErrorS 'MLSUnsupportedProposal) r,
 Member (ErrorS 'MLSInvalidLeafNodeIndex) r) =>
CipherSuiteTag -> GroupId -> [Proposal] -> Sem r ProposalAction
applyProposals ActiveMLSConversationData
activeData.ciphersuite GroupId
groupId [Proposal]
proposals
    Maybe LeafIndex
removedIndex <- case ClientMap -> [(ClientIdentity, LeafIndex)]
cmAssocs (ProposalAction -> ClientMap
paRemove ProposalAction
propAction) of
      [(ClientIdentity
cid, LeafIndex
idx)]
        | ClientIdentity
cid ClientIdentity -> ClientIdentity -> Bool
forall a. Eq a => a -> a -> Bool
/= ClientIdentity
senderIdentity ->
            MLSProtocolError -> Sem (State IndexMap : r) (Maybe LeafIndex)
forall e (r :: EffectRow) a. Member (Error e) r => e -> Sem r a
throw (MLSProtocolError -> Sem (State IndexMap : r) (Maybe LeafIndex))
-> MLSProtocolError -> Sem (State IndexMap : r) (Maybe LeafIndex)
forall a b. (a -> b) -> a -> b
$ Text -> MLSProtocolError
mlsProtocolError Text
"Only the self client can be removed by an external commit"
        | Bool
otherwise -> Maybe LeafIndex -> Sem (State IndexMap : r) (Maybe LeafIndex)
forall a. a -> Sem (State IndexMap : r) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LeafIndex -> Maybe LeafIndex
forall a. a -> Maybe a
Just LeafIndex
idx)
      [] -> Maybe LeafIndex -> Sem (State IndexMap : r) (Maybe LeafIndex)
forall a. a -> Sem (State IndexMap : r) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe LeafIndex
forall a. Maybe a
Nothing
      [(ClientIdentity, LeafIndex)]
_ -> MLSProtocolError -> Sem (State IndexMap : r) (Maybe LeafIndex)
forall e (r :: EffectRow) a. Member (Error e) r => e -> Sem r a
throw (Text -> MLSProtocolError
mlsProtocolError Text
"External commits must contain at most one Remove proposal")

    -- add sender client
    LeafIndex
addedIndex <- (IndexMap -> LeafIndex) -> Sem (State IndexMap : r) LeafIndex
forall s a (r :: EffectRow).
Member (State s) r =>
(s -> a) -> Sem r a
gets IndexMap -> LeafIndex
imNextIndex

    ExternalCommitAction
-> Sem (State IndexMap : r) ExternalCommitAction
forall a. a -> Sem (State IndexMap : r) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
      ExternalCommitAction
        { $sel:add:ExternalCommitAction :: LeafIndex
add = LeafIndex
addedIndex,
          $sel:remove:ExternalCommitAction :: Maybe LeafIndex
remove = Maybe LeafIndex
removedIndex
        }
  where
    allowedProposals :: [ProposalTag]
allowedProposals = [ProposalTag
ExternalInitProposalTag, ProposalTag
RemoveProposalTag, ProposalTag
PreSharedKeyProposalTag]

    getInlineProposal :: ProposalOrRef -> Sem r Proposal
    getInlineProposal :: ProposalOrRef -> Sem r Proposal
getInlineProposal (Ref ProposalRef
_) =
      MLSProtocolError -> Sem r Proposal
forall e (r :: EffectRow) a. Member (Error e) r => e -> Sem r a
throw (Text -> MLSProtocolError
mlsProtocolError Text
"External commits cannot reference proposals")
    getInlineProposal (Inline Proposal
p) = Proposal -> Sem r Proposal
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Proposal
p

processExternalCommit ::
  forall r.
  ( Member (Error FederationError) r,
    Member (ErrorS 'MLSStaleMessage) r,
    Member (ErrorS 'MLSSubConvClientNotInParent) r,
    Member Resource r,
    HasProposalActionEffects r
  ) =>
  ClientIdentity ->
  Local ConvOrSubConv ->
  CipherSuiteTag ->
  Bool ->
  Epoch ->
  ExternalCommitAction ->
  Maybe UpdatePath ->
  Sem r ()
processExternalCommit :: forall (r :: EffectRow).
(Member (Error FederationError) r,
 Member (ErrorS 'MLSStaleMessage) r,
 Member (ErrorS 'MLSSubConvClientNotInParent) r, Member Resource r,
 HasProposalActionEffects r) =>
ClientIdentity
-> Local ConvOrSubConv
-> CipherSuiteTag
-> Bool
-> Epoch
-> ExternalCommitAction
-> Maybe UpdatePath
-> Sem r ()
processExternalCommit ClientIdentity
senderIdentity Local ConvOrSubConv
lConvOrSub CipherSuiteTag
ciphersuite Bool
ciphersuiteUpdate Epoch
epoch ExternalCommitAction
action Maybe UpdatePath
updatePath = do
  let convOrSub :: ConvOrSubConv
convOrSub = Local ConvOrSubConv -> ConvOrSubConv
forall (t :: QTag) a. QualifiedWithTag t a -> a
tUnqualified Local ConvOrSubConv
lConvOrSub

  -- only members can join a subconversation
  Getting
  (Traversed () (Sem r))
  ConvOrSubConv
  (MLSConversation, SubConversation)
-> ConvOrSubConv
-> ((MLSConversation, SubConversation) -> Sem r ())
-> Sem r ()
forall (f :: * -> *) r s a.
Functor f =>
Getting (Traversed r f) s a -> s -> (a -> f r) -> f ()
forOf_ Getting
  (Traversed () (Sem r))
  ConvOrSubConv
  (MLSConversation, SubConversation)
forall c s1 s2 (p :: * -> * -> *) (f :: * -> *).
(Choice p, Applicative f) =>
p (c, s1) (f (c, s2))
-> p (ConvOrSubChoice c s1) (f (ConvOrSubChoice c s2))
_SubConv ConvOrSubConv
convOrSub (((MLSConversation, SubConversation) -> Sem r ()) -> Sem r ())
-> ((MLSConversation, SubConversation) -> Sem r ()) -> Sem r ()
forall a b. (a -> b) -> a -> b
$ \(MLSConversation
mlsConv, SubConversation
_) ->
    Bool -> Sem r () -> Sem r ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ClientIdentity -> ClientMap -> Bool
isClientMember ClientIdentity
senderIdentity (MLSConversation -> ClientMap
mcMembers MLSConversation
mlsConv)) (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 @'MLSSubConvClientNotInParent

  -- extract leaf node from update path and validate it
  RawMLS LeafNode
leafNode <-
    (.leaf)
      (UpdatePath -> RawMLS LeafNode)
-> Sem r UpdatePath -> Sem r (RawMLS LeafNode)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MLSProtocolError -> Maybe UpdatePath -> Sem r UpdatePath
forall e (r :: EffectRow) a.
Member (Error e) r =>
e -> Maybe a -> Sem r a
note
        (Text -> MLSProtocolError
mlsProtocolError Text
"External commits need an update path")
        Maybe UpdatePath
updatePath
  let groupId :: GroupId
groupId = ConversationMLSData -> GroupId
cnvmlsGroupId ConvOrSubConv
convOrSub.mlsMeta
  let extra :: LeafNodeTBSExtra
extra = GroupId -> LeafIndex -> LeafNodeTBSExtra
LeafNodeTBSExtraCommit GroupId
groupId ExternalCommitAction
action.add
  case CipherSuiteTag
-> Maybe ClientIdentity
-> LeafNodeTBSExtra
-> LeafNode
-> Either Text ()
validateLeafNode CipherSuiteTag
ciphersuite (ClientIdentity -> Maybe ClientIdentity
forall a. a -> Maybe a
Just ClientIdentity
senderIdentity) LeafNodeTBSExtra
extra RawMLS LeafNode
leafNode.value of
    Left Text
errMsg ->
      MLSProtocolError -> Sem r ()
forall e (r :: EffectRow) a. Member (Error e) r => e -> Sem r a
throw (MLSProtocolError -> Sem r ()) -> MLSProtocolError -> Sem r ()
forall a b. (a -> b) -> a -> b
$
        Text -> MLSProtocolError
mlsProtocolError (Text
"Tried to add invalid LeafNode: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
errMsg)
    Right ()
_ -> () -> Sem r ()
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

  Local ConvOrSubConvId -> GroupId -> Epoch -> Sem r () -> Sem r ()
forall (r :: EffectRow) a.
Members
  '[Resource, ConversationStore, ErrorS 'MLSStaleMessage,
    SubConversationStore]
  r =>
Local ConvOrSubConvId -> GroupId -> Epoch -> Sem r a -> Sem r a
withCommitLock ((ConvOrSubConv -> ConvOrSubConvId)
-> Local ConvOrSubConv -> Local ConvOrSubConvId
forall a b.
(a -> b)
-> QualifiedWithTag 'QLocal a -> QualifiedWithTag 'QLocal b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (.id) Local ConvOrSubConv
lConvOrSub) GroupId
groupId Epoch
epoch (Sem r () -> Sem r ()) -> Sem r () -> Sem r ()
forall a b. (a -> b) -> a -> b
$ do
    Local ConvOrSubConv
-> ClientIdentity -> ExternalCommitAction -> Sem r ()
forall (r :: EffectRow).
HasProposalActionEffects r =>
Local ConvOrSubConv
-> ClientIdentity -> ExternalCommitAction -> Sem r ()
executeExternalCommitAction Local ConvOrSubConv
lConvOrSub ClientIdentity
senderIdentity ExternalCommitAction
action

    -- increment epoch number
    Local ConvOrSubConv
lConvOrSub' <- Local ConvOrSubConv
-> (ConvOrSubConv -> Sem r ConvOrSubConv)
-> Sem r (Local ConvOrSubConv)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for Local ConvOrSubConv
lConvOrSub ConvOrSubConv -> Sem r ConvOrSubConv
forall (r :: EffectRow).
(Member ConversationStore r, Member (ErrorS 'ConvNotFound) r,
 Member MemberStore r, Member SubConversationStore r) =>
ConvOrSubConv -> Sem r ConvOrSubConv
incrementEpoch

    -- fetch backend remove proposals of the previous epoch
    Set LeafIndex
indices0 <- GroupId -> Epoch -> Sem r (Set LeafIndex)
forall (r :: EffectRow).
(Member ProposalStore r, Member TinyLog r) =>
GroupId -> Epoch -> Sem r (Set LeafIndex)
getPendingBackendRemoveProposals GroupId
groupId Epoch
epoch

    -- skip proposals for clients already removed by the external commit
    let indices :: Set LeafIndex
indices = (Set LeafIndex -> Set LeafIndex)
-> (LeafIndex -> Set LeafIndex -> Set LeafIndex)
-> Maybe LeafIndex
-> Set LeafIndex
-> Set LeafIndex
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Set LeafIndex -> Set LeafIndex
forall a. a -> a
id LeafIndex -> Set LeafIndex -> Set LeafIndex
forall a. Ord a => a -> Set a -> Set a
Set.delete ExternalCommitAction
action.remove Set LeafIndex
indices0

    -- set cipher suite
    Bool -> Sem r () -> Sem r ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
ciphersuiteUpdate (Sem r () -> Sem r ()) -> Sem r () -> Sem r ()
forall a b. (a -> b) -> a -> b
$ case ConvOrSubConv
convOrSub.id of
      Conv ConvId
cid -> ConvId -> CipherSuiteTag -> Sem r ()
forall (r :: EffectRow).
Member ConversationStore r =>
ConvId -> CipherSuiteTag -> Sem r ()
setConversationCipherSuite ConvId
cid CipherSuiteTag
ciphersuite
      SubConv ConvId
cid SubConvId
sub -> ConvId -> SubConvId -> CipherSuiteTag -> Sem r ()
forall (r :: EffectRow).
Member SubConversationStore r =>
ConvId -> SubConvId -> CipherSuiteTag -> Sem r ()
setSubConversationCipherSuite ConvId
cid SubConvId
sub CipherSuiteTag
ciphersuite

    -- requeue backend remove proposals for the current epoch
    Local ConvOrSubConv
-> Set 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
lConvOrSub'
      Set LeafIndex
indices
      (ClientIdentity -> Qualified UserId
cidQualifiedUser ClientIdentity
senderIdentity)
      (Local ConvOrSubConv -> ConvOrSubConv
forall (t :: QTag) a. QualifiedWithTag t a -> a
tUnqualified Local ConvOrSubConv
lConvOrSub').members

executeExternalCommitAction ::
  forall r.
  (HasProposalActionEffects r) =>
  Local ConvOrSubConv ->
  ClientIdentity ->
  ExternalCommitAction ->
  Sem r ()
executeExternalCommitAction :: forall (r :: EffectRow).
HasProposalActionEffects r =>
Local ConvOrSubConv
-> ClientIdentity -> ExternalCommitAction -> Sem r ()
executeExternalCommitAction Local ConvOrSubConv
lconvOrSub ClientIdentity
senderIdentity ExternalCommitAction
action = do
  let mlsMeta :: ConversationMLSData
mlsMeta = (Local ConvOrSubConv -> ConvOrSubConv
forall (t :: QTag) a. QualifiedWithTag t a -> a
tUnqualified Local ConvOrSubConv
lconvOrSub).mlsMeta

  -- Remove deprecated sender client from conversation state.
  Maybe LeafIndex -> (LeafIndex -> Sem r ()) -> Sem r ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ ExternalCommitAction
action.remove ((LeafIndex -> Sem r ()) -> Sem r ())
-> (LeafIndex -> Sem r ()) -> Sem r ()
forall a b. (a -> b) -> a -> b
$ \LeafIndex
_ ->
    GroupId -> Qualified UserId -> Set ClientId -> Sem r ()
forall (r :: EffectRow).
Member MemberStore r =>
GroupId -> Qualified UserId -> Set ClientId -> Sem r ()
removeMLSClients
      (ConversationMLSData -> GroupId
cnvmlsGroupId ConversationMLSData
mlsMeta)
      (ClientIdentity -> Qualified UserId
cidQualifiedUser ClientIdentity
senderIdentity)
      (ClientId -> Set ClientId
forall a. a -> Set a
Set.singleton (ClientIdentity -> ClientId
ciClient ClientIdentity
senderIdentity))

  -- Add new sender client to the conversation state.
  GroupId
-> Qualified UserId -> Set (ClientId, LeafIndex) -> Sem r ()
forall (r :: EffectRow).
Member MemberStore r =>
GroupId
-> Qualified UserId -> Set (ClientId, LeafIndex) -> Sem r ()
addMLSClients
    (ConversationMLSData -> GroupId
cnvmlsGroupId ConversationMLSData
mlsMeta)
    (ClientIdentity -> Qualified UserId
cidQualifiedUser ClientIdentity
senderIdentity)
    ((ClientId, LeafIndex) -> Set (ClientId, LeafIndex)
forall a. a -> Set a
Set.singleton (ClientIdentity -> ClientId
ciClient ClientIdentity
senderIdentity, ExternalCommitAction
action.add))