module Galley.API.MLS.Message
( IncomingBundle (..),
mkIncomingBundle,
IncomingMessage (..),
mkIncomingMessage,
postMLSCommitBundle,
postMLSCommitBundleFromLocalUser,
postMLSMessageFromLocalUser,
postMLSMessage,
MLSMessageStaticErrors,
MLSBundleStaticErrors,
)
where
import Data.Domain
import Data.Id
import Data.Json.Util
import Data.LegalHold
import Data.Qualified
import Data.Set qualified as Set
import Data.Tagged
import Data.Text.Lazy qualified as LT
import Data.Tuple.Extra
import Galley.API.Action
import Galley.API.Error
import Galley.API.LegalHold.Get (getUserStatus)
import Galley.API.MLS.Commit.Core (getCommitData)
import Galley.API.MLS.Commit.ExternalCommit
import Galley.API.MLS.Commit.InternalCommit
import Galley.API.MLS.Conversation
import Galley.API.MLS.Enabled
import Galley.API.MLS.IncomingMessage
import Galley.API.MLS.One2One
import Galley.API.MLS.Propagate
import Galley.API.MLS.Proposal
import Galley.API.MLS.Types
import Galley.API.MLS.Util
import Galley.API.MLS.Welcome (sendWelcomes)
import Galley.API.Util
import Galley.Data.Conversation.Types
import Galley.Effects
import Galley.Effects.ConversationStore
import Galley.Effects.FederatorAccess
import Galley.Effects.MemberStore
import Galley.Effects.SubConversationStore
import Galley.Effects.TeamStore qualified as TeamStore
import Imports
import Polysemy
import Polysemy.Error
import Polysemy.Input
import Polysemy.Internal
import Polysemy.Output
import Polysemy.Resource (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.CipherSuite
import Wire.API.MLS.Commit hiding (output)
import Wire.API.MLS.CommitBundle
import Wire.API.MLS.Credential
import Wire.API.MLS.GroupInfo
import Wire.API.MLS.Message
import Wire.API.MLS.Serialisation
import Wire.API.MLS.SubConversation
import Wire.API.Team.LegalHold
import Wire.NotificationSubsystem
type MLSMessageStaticErrors =
'[ ErrorS 'ConvAccessDenied,
ErrorS 'ConvMemberNotFound,
ErrorS 'ConvNotFound,
ErrorS 'MLSNotEnabled,
ErrorS 'MLSUnsupportedMessage,
ErrorS 'MLSStaleMessage,
ErrorS 'MLSProposalNotFound,
ErrorS 'MissingLegalholdConsent,
ErrorS 'MLSInvalidLeafNodeIndex,
ErrorS 'MLSClientMismatch,
ErrorS 'MLSUnsupportedProposal,
ErrorS 'MLSCommitMissingReferences,
ErrorS 'MLSSelfRemovalNotAllowed,
ErrorS 'MLSClientSenderUserMismatch,
ErrorS 'MLSGroupConversationMismatch,
ErrorS 'MLSSubConvClientNotInParent
]
type MLSBundleStaticErrors =
Append
MLSMessageStaticErrors
'[ErrorS 'MLSWelcomeMismatch]
postMLSMessageFromLocalUser ::
( HasProposalEffects r,
Member (ErrorS 'ConvAccessDenied) r,
Member (ErrorS 'ConvMemberNotFound) r,
Member (ErrorS 'ConvNotFound) r,
Member (ErrorS 'MissingLegalholdConsent) r,
Member (ErrorS 'MLSClientSenderUserMismatch) r,
Member (ErrorS 'MLSCommitMissingReferences) r,
Member (ErrorS 'MLSGroupConversationMismatch) r,
Member (ErrorS 'MLSNotEnabled) r,
Member (ErrorS 'MLSProposalNotFound) r,
Member (ErrorS 'MLSSelfRemovalNotAllowed) r,
Member (ErrorS 'MLSStaleMessage) r,
Member (ErrorS 'MLSUnsupportedMessage) r,
Member (ErrorS 'MLSSubConvClientNotInParent) r,
Member SubConversationStore r
) =>
Local UserId ->
ClientId ->
ConnId ->
RawMLS Message ->
Sem r MLSMessageSendingStatus
postMLSMessageFromLocalUser :: forall (r :: EffectRow).
(HasProposalEffects r, Member (ErrorS 'ConvAccessDenied) r,
Member (ErrorS 'ConvMemberNotFound) r,
Member (ErrorS 'ConvNotFound) r,
Member (ErrorS 'MissingLegalholdConsent) r,
Member (ErrorS 'MLSClientSenderUserMismatch) r,
Member (ErrorS 'MLSCommitMissingReferences) r,
Member (ErrorS 'MLSGroupConversationMismatch) r,
Member (ErrorS 'MLSNotEnabled) r,
Member (ErrorS 'MLSProposalNotFound) r,
Member (ErrorS 'MLSSelfRemovalNotAllowed) r,
Member (ErrorS 'MLSStaleMessage) r,
Member (ErrorS 'MLSUnsupportedMessage) r,
Member (ErrorS 'MLSSubConvClientNotInParent) r,
Member SubConversationStore r) =>
Local UserId
-> ClientId
-> ConnId
-> RawMLS Message
-> Sem r MLSMessageSendingStatus
postMLSMessageFromLocalUser Local UserId
lusr ClientId
c ConnId
conn RawMLS Message
smsg = do
Sem r ()
forall (r :: EffectRow).
(Member (Input Env) r, Member (ErrorS 'MLSNotEnabled) r) =>
Sem r ()
assertMLSEnabled
IncomingMessage
imsg <- 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 @'MLSUnsupportedMessage (Maybe IncomingMessage -> Sem r IncomingMessage)
-> Maybe IncomingMessage -> Sem r IncomingMessage
forall a b. (a -> b) -> a -> b
$ RawMLS Message -> Maybe IncomingMessage
mkIncomingMessage RawMLS Message
smsg
(ConvType
ctype, Qualified ConvOrSubConvId
cnvOrSub) <- GroupId -> Sem r (ConvType, Qualified ConvOrSubConvId)
forall (r :: EffectRow).
Member (Error MLSProtocolError) r =>
GroupId -> Sem r (ConvType, Qualified ConvOrSubConvId)
getConvFromGroupId IncomingMessage
imsg.groupId
[Event]
events <-
(LocalConversationUpdate -> Event)
-> [LocalConversationUpdate] -> [Event]
forall a b. (a -> b) -> [a] -> [b]
map LocalConversationUpdate -> Event
lcuEvent
([LocalConversationUpdate] -> [Event])
-> Sem r [LocalConversationUpdate] -> Sem r [Event]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Local UserId
-> Qualified UserId
-> ClientId
-> ConvType
-> Qualified ConvOrSubConvId
-> Maybe ConnId
-> IncomingMessage
-> Sem r [LocalConversationUpdate]
forall (r :: EffectRow) x.
(HasProposalEffects r, Member (ErrorS 'ConvAccessDenied) r,
Member (ErrorS 'ConvMemberNotFound) r,
Member (ErrorS 'ConvNotFound) r, Member (ErrorS 'MLSNotEnabled) r,
Member (ErrorS 'MissingLegalholdConsent) r,
Member (ErrorS 'MLSClientSenderUserMismatch) r,
Member (ErrorS 'MLSCommitMissingReferences) r,
Member (ErrorS 'MLSGroupConversationMismatch) r,
Member (ErrorS 'MLSProposalNotFound) r,
Member (ErrorS 'MLSSelfRemovalNotAllowed) r,
Member (ErrorS 'MLSStaleMessage) r,
Member (ErrorS 'MLSUnsupportedMessage) r,
Member (ErrorS 'MLSSubConvClientNotInParent) r,
Member SubConversationStore r) =>
Local x
-> Qualified UserId
-> ClientId
-> ConvType
-> Qualified ConvOrSubConvId
-> Maybe ConnId
-> IncomingMessage
-> Sem r [LocalConversationUpdate]
postMLSMessage Local UserId
lusr (Local UserId -> Qualified UserId
forall (t :: QTag) a. QualifiedWithTag t a -> Qualified a
tUntagged Local UserId
lusr) ClientId
c ConvType
ctype Qualified ConvOrSubConvId
cnvOrSub (ConnId -> Maybe ConnId
forall a. a -> Maybe a
Just ConnId
conn) IncomingMessage
imsg
UTCTimeMillis
t <- UTCTime -> UTCTimeMillis
toUTCTimeMillis (UTCTime -> UTCTimeMillis) -> Sem r UTCTime -> Sem r UTCTimeMillis
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Sem r UTCTime
forall i (r :: EffectRow). Member (Input i) r => Sem r i
input
MLSMessageSendingStatus -> Sem r MLSMessageSendingStatus
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (MLSMessageSendingStatus -> Sem r MLSMessageSendingStatus)
-> MLSMessageSendingStatus -> Sem r MLSMessageSendingStatus
forall a b. (a -> b) -> a -> b
$ [Event] -> UTCTimeMillis -> MLSMessageSendingStatus
MLSMessageSendingStatus [Event]
events UTCTimeMillis
t
postMLSCommitBundle ::
( Member (ErrorS MLSLegalholdIncompatible) r,
Member Random r,
Member Resource r,
Member SubConversationStore r,
Members MLSBundleStaticErrors r,
HasProposalEffects r
) =>
Local x ->
Qualified UserId ->
ClientId ->
ConvType ->
Qualified ConvOrSubConvId ->
Maybe ConnId ->
IncomingBundle ->
Sem r [LocalConversationUpdate]
postMLSCommitBundle :: forall (r :: EffectRow) x.
(Member (ErrorS 'MLSLegalholdIncompatible) r, Member Random r,
Member Resource r, Member SubConversationStore r,
Members MLSBundleStaticErrors r, HasProposalEffects r) =>
Local x
-> Qualified UserId
-> ClientId
-> ConvType
-> Qualified ConvOrSubConvId
-> Maybe ConnId
-> IncomingBundle
-> Sem r [LocalConversationUpdate]
postMLSCommitBundle Local x
loc Qualified UserId
qusr ClientId
c ConvType
ctype Qualified ConvOrSubConvId
qConvOrSub Maybe ConnId
conn IncomingBundle
bundle =
Local x
-> (Local ConvOrSubConvId -> Sem r [LocalConversationUpdate])
-> (Remote ConvOrSubConvId -> Sem r [LocalConversationUpdate])
-> Qualified ConvOrSubConvId
-> Sem r [LocalConversationUpdate]
forall x a b.
Local x -> (Local a -> b) -> (Remote a -> b) -> Qualified a -> b
foldQualified
Local x
loc
(Qualified UserId
-> ClientId
-> Maybe ConnId
-> IncomingBundle
-> ConvType
-> Local ConvOrSubConvId
-> Sem r [LocalConversationUpdate]
forall (r :: EffectRow).
(Member (ErrorS 'MLSLegalholdIncompatible) r, Member Random r,
Member Resource r, Member SubConversationStore r,
Members MLSBundleStaticErrors r, HasProposalEffects r) =>
Qualified UserId
-> ClientId
-> Maybe ConnId
-> IncomingBundle
-> ConvType
-> Local ConvOrSubConvId
-> Sem r [LocalConversationUpdate]
postMLSCommitBundleToLocalConv Qualified UserId
qusr ClientId
c Maybe ConnId
conn IncomingBundle
bundle ConvType
ctype)
(Local x
-> Qualified UserId
-> ClientId
-> Maybe ConnId
-> IncomingBundle
-> ConvType
-> Remote ConvOrSubConvId
-> Sem r [LocalConversationUpdate]
forall (r :: EffectRow) x.
(Member BrigAccess r, Members MLSBundleStaticErrors r,
Member (Error FederationError) r,
Member (Error MLSProtocolError) r,
Member (Error MLSProposalFailure) r,
Member (Error NonFederatingBackends) r,
Member (Error UnreachableBackends) r, Member ExternalAccess r,
Member FederatorAccess r, Member NotificationSubsystem r,
Member MemberStore r, Member TinyLog r) =>
Local x
-> Qualified UserId
-> ClientId
-> Maybe ConnId
-> IncomingBundle
-> ConvType
-> Remote ConvOrSubConvId
-> Sem r [LocalConversationUpdate]
postMLSCommitBundleToRemoteConv Local x
loc Qualified UserId
qusr ClientId
c Maybe ConnId
conn IncomingBundle
bundle ConvType
ctype)
Qualified ConvOrSubConvId
qConvOrSub
postMLSCommitBundleFromLocalUser ::
( Member (ErrorS MLSLegalholdIncompatible) r,
Member Random r,
Member Resource r,
Member SubConversationStore r,
Members MLSBundleStaticErrors r,
HasProposalEffects r
) =>
Local UserId ->
ClientId ->
ConnId ->
RawMLS CommitBundle ->
Sem r MLSMessageSendingStatus
postMLSCommitBundleFromLocalUser :: forall (r :: EffectRow).
(Member (ErrorS 'MLSLegalholdIncompatible) r, Member Random r,
Member Resource r, Member SubConversationStore r,
Members MLSBundleStaticErrors r, HasProposalEffects r) =>
Local UserId
-> ClientId
-> ConnId
-> RawMLS CommitBundle
-> Sem r MLSMessageSendingStatus
postMLSCommitBundleFromLocalUser Local UserId
lusr ClientId
c ConnId
conn RawMLS CommitBundle
bundle = do
Sem r ()
forall (r :: EffectRow).
(Member (Input Env) r, Member (ErrorS 'MLSNotEnabled) r) =>
Sem r ()
assertMLSEnabled
IncomingBundle
ibundle <- 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 @'MLSUnsupportedMessage (Maybe IncomingBundle -> Sem r IncomingBundle)
-> Maybe IncomingBundle -> Sem r IncomingBundle
forall a b. (a -> b) -> a -> b
$ RawMLS CommitBundle -> Maybe IncomingBundle
mkIncomingBundle RawMLS CommitBundle
bundle
(ConvType
ctype, Qualified ConvOrSubConvId
qConvOrSub) <- GroupId -> Sem r (ConvType, Qualified ConvOrSubConvId)
forall (r :: EffectRow).
Member (Error MLSProtocolError) r =>
GroupId -> Sem r (ConvType, Qualified ConvOrSubConvId)
getConvFromGroupId IncomingBundle
ibundle.groupId
[Event]
events <-
(LocalConversationUpdate -> Event)
-> [LocalConversationUpdate] -> [Event]
forall a b. (a -> b) -> [a] -> [b]
map LocalConversationUpdate -> Event
lcuEvent
([LocalConversationUpdate] -> [Event])
-> Sem r [LocalConversationUpdate] -> Sem r [Event]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Local UserId
-> Qualified UserId
-> ClientId
-> ConvType
-> Qualified ConvOrSubConvId
-> Maybe ConnId
-> IncomingBundle
-> Sem r [LocalConversationUpdate]
forall (r :: EffectRow) x.
(Member (ErrorS 'MLSLegalholdIncompatible) r, Member Random r,
Member Resource r, Member SubConversationStore r,
Members MLSBundleStaticErrors r, HasProposalEffects r) =>
Local x
-> Qualified UserId
-> ClientId
-> ConvType
-> Qualified ConvOrSubConvId
-> Maybe ConnId
-> IncomingBundle
-> Sem r [LocalConversationUpdate]
postMLSCommitBundle Local UserId
lusr (Local UserId -> Qualified UserId
forall (t :: QTag) a. QualifiedWithTag t a -> Qualified a
tUntagged Local UserId
lusr) ClientId
c ConvType
ctype Qualified ConvOrSubConvId
qConvOrSub (ConnId -> Maybe ConnId
forall a. a -> Maybe a
Just ConnId
conn) IncomingBundle
ibundle
UTCTimeMillis
t <- UTCTime -> UTCTimeMillis
toUTCTimeMillis (UTCTime -> UTCTimeMillis) -> Sem r UTCTime -> Sem r UTCTimeMillis
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Sem r UTCTime
forall i (r :: EffectRow). Member (Input i) r => Sem r i
input
MLSMessageSendingStatus -> Sem r MLSMessageSendingStatus
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (MLSMessageSendingStatus -> Sem r MLSMessageSendingStatus)
-> MLSMessageSendingStatus -> Sem r MLSMessageSendingStatus
forall a b. (a -> b) -> a -> b
$ [Event] -> UTCTimeMillis -> MLSMessageSendingStatus
MLSMessageSendingStatus [Event]
events UTCTimeMillis
t
postMLSCommitBundleToLocalConv ::
( Member (ErrorS MLSLegalholdIncompatible) r,
Member Random r,
Member Resource r,
Member SubConversationStore r,
Members MLSBundleStaticErrors r,
HasProposalEffects r
) =>
Qualified UserId ->
ClientId ->
Maybe ConnId ->
IncomingBundle ->
ConvType ->
Local ConvOrSubConvId ->
Sem r [LocalConversationUpdate]
postMLSCommitBundleToLocalConv :: forall (r :: EffectRow).
(Member (ErrorS 'MLSLegalholdIncompatible) r, Member Random r,
Member Resource r, Member SubConversationStore r,
Members MLSBundleStaticErrors r, HasProposalEffects r) =>
Qualified UserId
-> ClientId
-> Maybe ConnId
-> IncomingBundle
-> ConvType
-> Local ConvOrSubConvId
-> Sem r [LocalConversationUpdate]
postMLSCommitBundleToLocalConv Qualified UserId
qusr ClientId
c Maybe ConnId
conn IncomingBundle
bundle ConvType
ctype Local ConvOrSubConvId
lConvOrSubId = do
Local ConvOrSubConv
lConvOrSub <- Qualified UserId
-> GroupId
-> ConvType
-> Local ConvOrSubConvId
-> Sem r (Local ConvOrSubConv)
forall (r :: EffectRow).
(Member ConversationStore r, Member (ErrorS 'ConvNotFound) r,
Member (Error MLSProtocolError) r, Member MemberStore r,
Member SubConversationStore r) =>
Qualified UserId
-> GroupId
-> ConvType
-> Local ConvOrSubConvId
-> Sem r (Local ConvOrSubConv)
fetchConvOrSub Qualified UserId
qusr IncomingBundle
bundle.groupId ConvType
ctype Local ConvOrSubConvId
lConvOrSubId
let convOrSub :: ConvOrSubConv
convOrSub = Local ConvOrSubConv -> ConvOrSubConv
forall (t :: QTag) a. QualifiedWithTag t a -> a
tUnqualified Local ConvOrSubConv
lConvOrSub
CipherSuiteTag
ciphersuite <-
MLSProtocolError -> Maybe CipherSuiteTag -> Sem r CipherSuiteTag
forall e (r :: EffectRow) a.
Member (Error e) r =>
e -> Maybe a -> Sem r a
note (Text -> MLSProtocolError
mlsProtocolError Text
"Unsupported ciphersuite") (Maybe CipherSuiteTag -> Sem r CipherSuiteTag)
-> Maybe CipherSuiteTag -> Sem r CipherSuiteTag
forall a b. (a -> b) -> a -> b
$
CipherSuite -> Maybe CipherSuiteTag
cipherSuiteTag IncomingBundle
bundle.groupInfo.value.groupContext.cipherSuite
case Qualified UserId
qusr Qualified UserId -> Local ConvOrSubConvId -> RelativeTo UserId
forall a loc. Qualified a -> Local loc -> RelativeTo a
`relativeTo` Local ConvOrSubConvId
lConvOrSubId of
Local Local UserId
luid ->
Bool -> Sem r () -> Sem r ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe ActiveMLSConversationData -> Bool
forall a. Maybe a -> Bool
isNothing ConvOrSubConv
convOrSub.mlsMeta.cnvmlsActiveData) do
[TeamId]
usrTeams <- UserId -> Sem r [TeamId]
forall (r :: EffectRow).
Member TeamStore r =>
UserId -> Sem r [TeamId]
TeamStore.getUserTeams (Local UserId -> UserId
forall (t :: QTag) a. QualifiedWithTag t a -> a
tUnqualified Local UserId
luid)
[TeamId] -> (TeamId -> Sem r ()) -> Sem r ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [TeamId]
usrTeams \TeamId
tid -> do
Either (Tagged 'TeamMemberNotFound ()) UserLegalHoldStatusResponse
resp <- forall e (r :: EffectRow) a.
Sem (Error e : r) a -> Sem r (Either e a)
runError @(Tagged TeamMemberNotFound ()) (Sem
(Error (Tagged 'TeamMemberNotFound ()) : r)
UserLegalHoldStatusResponse
-> Sem
r
(Either
(Tagged 'TeamMemberNotFound ()) UserLegalHoldStatusResponse))
-> Sem
(Error (Tagged 'TeamMemberNotFound ()) : r)
UserLegalHoldStatusResponse
-> Sem
r
(Either
(Tagged 'TeamMemberNotFound ()) UserLegalHoldStatusResponse)
forall a b. (a -> b) -> a -> b
$ Local UserId
-> TeamId
-> UserId
-> Sem
(Error (Tagged 'TeamMemberNotFound ()) : r)
UserLegalHoldStatusResponse
forall (r :: EffectRow).
(Member (Error InternalError) r,
Member (Error (Tagged 'TeamMemberNotFound ())) r,
Member LegalHoldStore r, Member TeamStore r, Member TinyLog r) =>
Local UserId
-> TeamId -> UserId -> Sem r UserLegalHoldStatusResponse
getUserStatus Local UserId
luid TeamId
tid (Local UserId -> UserId
forall (t :: QTag) a. QualifiedWithTag t a -> a
tUnqualified Local UserId
luid)
case Either (Tagged 'TeamMemberNotFound ()) UserLegalHoldStatusResponse
resp of
Left Tagged 'TeamMemberNotFound ()
_ -> InternalError -> Sem r ()
forall e (r :: EffectRow) a. Member (Error e) r => e -> Sem r a
throw (InternalError -> Sem r ()) -> InternalError -> Sem r ()
forall a b. (a -> b) -> a -> b
$ LText -> InternalError
InternalErrorWithDescription LText
"Server error. Team member must have vanished with the legal hold check"
Right UserLegalHoldStatusResponse
r -> case UserLegalHoldStatusResponse
r.ulhsrStatus of
UserLegalHoldStatus
UserLegalHoldPending -> 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 @MLSLegalholdIncompatible
UserLegalHoldStatus
UserLegalHoldEnabled -> 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 @MLSLegalholdIncompatible
UserLegalHoldStatus
UserLegalHoldDisabled -> () -> Sem r ()
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
UserLegalHoldStatus
UserLegalHoldNoConsent -> () -> Sem r ()
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
Remote Remote UserId
_ -> () -> Sem r ()
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
Bool
ciphersuiteUpdate <- case ConvOrSubConv
convOrSub.mlsMeta.cnvmlsActiveData of
Maybe ActiveMLSConversationData
Nothing -> Bool -> Sem r Bool
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
Just ActiveMLSConversationData
activeData -> do
Bool -> Sem r () -> Sem r ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (CipherSuiteTag
ciphersuite CipherSuiteTag -> CipherSuiteTag -> Bool
forall a. Eq a => a -> a -> Bool
== ActiveMLSConversationData
activeData.ciphersuite) (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
"GroupInfo ciphersuite does not match conversation"
Bool -> Sem r () -> Sem r ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (IncomingBundle
bundle.epoch Epoch -> Epoch -> Bool
forall a. Eq a => a -> a -> Bool
== ActiveMLSConversationData
activeData.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
Bool -> Sem r Bool
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
ClientIdentity
senderIdentity <- Qualified UserId
-> ClientId
-> Sender
-> Local ConvOrSubConv
-> Sem r ClientIdentity
forall (r :: EffectRow).
(Member (ErrorS 'MLSClientSenderUserMismatch) r,
Member (Error MLSProtocolError) r) =>
Qualified UserId
-> ClientId
-> Sender
-> Local ConvOrSubConv
-> Sem r ClientIdentity
getSenderIdentity Qualified UserId
qusr ClientId
c IncomingBundle
bundle.sender Local ConvOrSubConv
lConvOrSub
([LocalConversationUpdate]
events, [ClientIdentity]
newClients) <- case IncomingBundle
bundle.sender of
SenderMember LeafIndex
_index -> do
ProposalAction
action <- ClientIdentity
-> Local ConvOrSubConv
-> Epoch
-> CipherSuiteTag
-> IncomingBundle
-> Sem r ProposalAction
forall (r :: EffectRow).
(HasProposalEffects r, Member (ErrorS 'MLSProposalNotFound) r) =>
ClientIdentity
-> Local ConvOrSubConv
-> Epoch
-> CipherSuiteTag
-> IncomingBundle
-> Sem r ProposalAction
getCommitData ClientIdentity
senderIdentity Local ConvOrSubConv
lConvOrSub IncomingBundle
bundle.epoch CipherSuiteTag
ciphersuite IncomingBundle
bundle
[LocalConversationUpdate]
events <-
ClientIdentity
-> Maybe ConnId
-> Local ConvOrSubConv
-> CipherSuiteTag
-> Bool
-> Epoch
-> ProposalAction
-> Commit
-> Sem r [LocalConversationUpdate]
forall (r :: EffectRow).
(HasProposalEffects r, Member (ErrorS 'ConvNotFound) r,
Member (ErrorS 'MLSCommitMissingReferences) r,
Member (ErrorS 'MLSSelfRemovalNotAllowed) r,
Member (ErrorS 'MLSStaleMessage) r,
Member (ErrorS 'MissingLegalholdConsent) r,
Member SubConversationStore r, Member Resource r,
Member Random r) =>
ClientIdentity
-> Maybe ConnId
-> Local ConvOrSubConv
-> CipherSuiteTag
-> Bool
-> Epoch
-> ProposalAction
-> Commit
-> Sem r [LocalConversationUpdate]
processInternalCommit
ClientIdentity
senderIdentity
Maybe ConnId
conn
Local ConvOrSubConv
lConvOrSub
CipherSuiteTag
ciphersuite
Bool
ciphersuiteUpdate
IncomingBundle
bundle.epoch
ProposalAction
action
IncomingBundle
bundle.commit.value
let newClients :: [ClientIdentity]
newClients = (ClientIdentity -> Bool) -> [ClientIdentity] -> [ClientIdentity]
forall a. (a -> Bool) -> [a] -> [a]
filter (ClientIdentity -> ClientIdentity -> Bool
forall a. Eq a => a -> a -> Bool
(/=) ClientIdentity
senderIdentity) (ClientMap -> [ClientIdentity]
cmIdentities (ProposalAction -> ClientMap
paAdd ProposalAction
action))
([LocalConversationUpdate], [ClientIdentity])
-> Sem r ([LocalConversationUpdate], [ClientIdentity])
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([LocalConversationUpdate]
events, [ClientIdentity]
newClients)
SenderExternal LeafIndex
_ -> MLSProtocolError
-> Sem r ([LocalConversationUpdate], [ClientIdentity])
forall e (r :: EffectRow) a. Member (Error e) r => e -> Sem r a
throw (Text -> MLSProtocolError
mlsProtocolError Text
"Unexpected sender")
Sender
SenderNewMemberProposal -> MLSProtocolError
-> Sem r ([LocalConversationUpdate], [ClientIdentity])
forall e (r :: EffectRow) a. Member (Error e) r => e -> Sem r a
throw (Text -> MLSProtocolError
mlsProtocolError Text
"Unexpected sender")
Sender
SenderNewMemberCommit -> do
ExternalCommitAction
action <- ClientIdentity
-> Local ConvOrSubConv
-> Epoch
-> Commit
-> Sem r ExternalCommitAction
forall (r :: EffectRow).
(Member (Error MLSProtocolError) r,
Member (ErrorS 'MLSStaleMessage) r,
Member (Error (Tagged 'MLSUnsupportedProposal ())) r,
Member (Error (Tagged 'MLSInvalidLeafNodeIndex ())) r) =>
ClientIdentity
-> Local ConvOrSubConv
-> Epoch
-> Commit
-> Sem r ExternalCommitAction
getExternalCommitData ClientIdentity
senderIdentity Local ConvOrSubConv
lConvOrSub IncomingBundle
bundle.epoch IncomingBundle
bundle.commit.value
ClientIdentity
-> Local ConvOrSubConv
-> CipherSuiteTag
-> Bool
-> Epoch
-> ExternalCommitAction
-> Maybe UpdatePath
-> Sem r ()
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
IncomingBundle
bundle.epoch
ExternalCommitAction
action
IncomingBundle
bundle.commit.value.path
([LocalConversationUpdate], [ClientIdentity])
-> Sem r ([LocalConversationUpdate], [ClientIdentity])
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([], [])
ConvOrSubConvId -> GroupInfoData -> Sem r ()
forall (r :: EffectRow).
(Member ConversationStore r, Member SubConversationStore r) =>
ConvOrSubConvId -> GroupInfoData -> Sem r ()
storeGroupInfo (Local ConvOrSubConv -> ConvOrSubConv
forall (t :: QTag) a. QualifiedWithTag t a -> a
tUnqualified Local ConvOrSubConv
lConvOrSub).id (ByteString -> GroupInfoData
GroupInfoData IncomingBundle
bundle.groupInfo.raw)
Qualified UserId
-> Maybe ClientId
-> Local ConvOrSubConv
-> Maybe ConnId
-> RawMLS Message
-> ClientMap
-> Sem 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 (ClientId -> Maybe ClientId
forall a. a -> Maybe a
Just ClientId
c) Local ConvOrSubConv
lConvOrSub Maybe ConnId
conn IncomingBundle
bundle.rawMessage (Local ConvOrSubConv -> ConvOrSubConv
forall (t :: QTag) a. QualifiedWithTag t a -> a
tUnqualified Local ConvOrSubConv
lConvOrSub).members
Maybe (RawMLS Welcome) -> (RawMLS Welcome -> Sem r ()) -> Sem r ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ IncomingBundle
bundle.welcome ((RawMLS Welcome -> Sem r ()) -> Sem r ())
-> (RawMLS Welcome -> Sem r ()) -> Sem r ()
forall a b. (a -> b) -> a -> b
$ \RawMLS Welcome
welcome ->
Local ConvOrSubConvId
-> Qualified UserId
-> Maybe ConnId
-> [ClientIdentity]
-> RawMLS Welcome
-> Sem r ()
forall (r :: EffectRow).
(Member FederatorAccess r, Member ExternalAccess r,
Member TinyLog r, Member (Input UTCTime) r,
Member NotificationSubsystem r) =>
Local ConvOrSubConvId
-> Qualified UserId
-> Maybe ConnId
-> [ClientIdentity]
-> RawMLS Welcome
-> Sem r ()
sendWelcomes Local ConvOrSubConvId
lConvOrSubId Qualified UserId
qusr Maybe ConnId
conn [ClientIdentity]
newClients RawMLS Welcome
welcome
[LocalConversationUpdate] -> Sem r [LocalConversationUpdate]
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [LocalConversationUpdate]
events
postMLSCommitBundleToRemoteConv ::
( Member BrigAccess r,
Members MLSBundleStaticErrors r,
Member (Error FederationError) r,
Member (Error MLSProtocolError) r,
Member (Error MLSProposalFailure) r,
Member (Error NonFederatingBackends) r,
Member (Error UnreachableBackends) r,
Member ExternalAccess r,
Member FederatorAccess r,
Member NotificationSubsystem r,
Member MemberStore r,
Member TinyLog r
) =>
Local x ->
Qualified UserId ->
ClientId ->
Maybe ConnId ->
IncomingBundle ->
ConvType ->
Remote ConvOrSubConvId ->
Sem r [LocalConversationUpdate]
postMLSCommitBundleToRemoteConv :: forall (r :: EffectRow) x.
(Member BrigAccess r, Members MLSBundleStaticErrors r,
Member (Error FederationError) r,
Member (Error MLSProtocolError) r,
Member (Error MLSProposalFailure) r,
Member (Error NonFederatingBackends) r,
Member (Error UnreachableBackends) r, Member ExternalAccess r,
Member FederatorAccess r, Member NotificationSubsystem r,
Member MemberStore r, Member TinyLog r) =>
Local x
-> Qualified UserId
-> ClientId
-> Maybe ConnId
-> IncomingBundle
-> ConvType
-> Remote ConvOrSubConvId
-> Sem r [LocalConversationUpdate]
postMLSCommitBundleToRemoteConv Local x
loc Qualified UserId
qusr ClientId
c Maybe ConnId
con IncomingBundle
bundle ConvType
ctype Remote ConvOrSubConvId
rConvOrSubId = do
Local UserId
lusr <- Local x
-> (Local UserId -> Sem r (Local UserId))
-> (Remote UserId -> Sem r (Local UserId))
-> Qualified UserId
-> Sem r (Local UserId)
forall x a b.
Local x -> (Local a -> b) -> (Remote a -> b) -> Qualified a -> b
foldQualified Local x
loc Local UserId -> Sem r (Local UserId)
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (\Remote UserId
_ -> 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 @'ConvAccessDenied) Qualified UserId
qusr
Bool -> Sem r () -> Sem r ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (IncomingBundle
bundle.epoch Epoch -> Epoch -> Bool
forall a. Eq a => a -> a -> Bool
== Word64 -> Epoch
Epoch Word64
0 Bool -> Bool -> Bool
&& ConvType
ctype 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
$
(Bool -> Sem r () -> Sem r ()) -> Sem r () -> Bool -> Sem r ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip Bool -> Sem r () -> Sem r ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (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 @'ConvMemberNotFound) (Bool -> Sem r ()) -> Sem r Bool -> Sem r ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< UserId -> Remote ConvId -> Sem r Bool
forall (r :: EffectRow).
Member MemberStore r =>
UserId -> Remote ConvId -> Sem r Bool
checkLocalMemberRemoteConv (Local UserId -> UserId
forall (t :: QTag) a. QualifiedWithTag t a -> a
tUnqualified Local UserId
lusr) ((.conv) (ConvOrSubConvId -> ConvId)
-> Remote ConvOrSubConvId -> Remote ConvId
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Remote ConvOrSubConvId
rConvOrSubId)
MLSMessageResponse
resp <-
Remote ConvOrSubConvId
-> FederatorClient 'Galley MLSMessageResponse
-> Sem r MLSMessageResponse
forall (r :: EffectRow) (c :: Component) x a.
(Member FederatorAccess r, KnownComponent c) =>
Remote x -> FederatorClient c a -> Sem r a
runFederated Remote ConvOrSubConvId
rConvOrSubId (FederatorClient 'Galley MLSMessageResponse
-> Sem r MLSMessageResponse)
-> FederatorClient 'Galley MLSMessageResponse
-> Sem r MLSMessageResponse
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 @"send-mls-commit-bundle" (MLSMessageSendRequest
-> FederatorClient 'Galley MLSMessageResponse)
-> MLSMessageSendRequest
-> FederatorClient 'Galley MLSMessageResponse
forall a b. (a -> b) -> a -> b
$
MLSMessageSendRequest
{ $sel:convOrSubId:MLSMessageSendRequest :: ConvOrSubConvId
convOrSubId = Remote ConvOrSubConvId -> ConvOrSubConvId
forall (t :: QTag) a. QualifiedWithTag t a -> a
tUnqualified Remote ConvOrSubConvId
rConvOrSubId,
$sel:sender:MLSMessageSendRequest :: UserId
sender = Local UserId -> UserId
forall (t :: QTag) a. QualifiedWithTag t a -> a
tUnqualified Local UserId
lusr,
$sel:senderClient:MLSMessageSendRequest :: ClientId
senderClient = ClientId
c,
$sel:rawMessage:MLSMessageSendRequest :: Base64ByteString
rawMessage = ByteString -> Base64ByteString
Base64ByteString IncomingBundle
bundle.serialized
}
case MLSMessageResponse
resp of
MLSMessageResponseError GalleyError
e -> forall (effs :: EffectRow) (r :: EffectRow) a.
RethrowErrors effs r =>
GalleyError -> Sem r a
rethrowErrors @MLSBundleStaticErrors GalleyError
e
MLSMessageResponseProtocolError Text
e -> MLSProtocolError -> Sem r [LocalConversationUpdate]
forall e (r :: EffectRow) a. Member (Error e) r => e -> Sem r a
throw (Text -> MLSProtocolError
mlsProtocolError Text
e)
MLSMessageResponseProposalFailure JSONResponse
e -> MLSProposalFailure -> Sem r [LocalConversationUpdate]
forall e (r :: EffectRow) a. Member (Error e) r => e -> Sem r a
throw (JSONResponse -> MLSProposalFailure
MLSProposalFailure JSONResponse
e)
MLSMessageResponseUnreachableBackends Set Domain
ds -> UnreachableBackends -> Sem r [LocalConversationUpdate]
forall e (r :: EffectRow) a. Member (Error e) r => e -> Sem r a
throw ([Domain] -> UnreachableBackends
UnreachableBackends (Set Domain -> [Domain]
forall a. Set a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Set Domain
ds))
MLSMessageResponseUpdates [ConversationUpdate]
updates -> do
(([LocalConversationUpdate], ()) -> [LocalConversationUpdate])
-> Sem r ([LocalConversationUpdate], ())
-> Sem r [LocalConversationUpdate]
forall a b. (a -> b) -> Sem r a -> Sem r b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([LocalConversationUpdate], ()) -> [LocalConversationUpdate]
forall a b. (a, b) -> a
fst (Sem r ([LocalConversationUpdate], ())
-> Sem r [LocalConversationUpdate])
-> (Sem
(Input (QualifiedWithTag 'QLocal ())
: Output LocalConversationUpdate : r)
()
-> Sem r ([LocalConversationUpdate], ()))
-> Sem
(Input (QualifiedWithTag 'QLocal ())
: Output LocalConversationUpdate : r)
()
-> Sem r [LocalConversationUpdate]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Sem (Output LocalConversationUpdate : r) ()
-> Sem r ([LocalConversationUpdate], ())
forall o (r :: EffectRow) a. Sem (Output o : r) a -> Sem r ([o], a)
runOutputList (Sem (Output LocalConversationUpdate : r) ()
-> Sem r ([LocalConversationUpdate], ()))
-> (Sem
(Input (QualifiedWithTag 'QLocal ())
: Output LocalConversationUpdate : r)
()
-> Sem (Output LocalConversationUpdate : r) ())
-> Sem
(Input (QualifiedWithTag 'QLocal ())
: Output LocalConversationUpdate : r)
()
-> Sem r ([LocalConversationUpdate], ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QualifiedWithTag 'QLocal ()
-> Sem
(Input (QualifiedWithTag 'QLocal ())
: Output LocalConversationUpdate : r)
()
-> Sem (Output LocalConversationUpdate : r) ()
forall i (r :: EffectRow) a. i -> Sem (Input i : r) a -> Sem r a
runInputConst (Local x -> QualifiedWithTag 'QLocal ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void Local x
loc) (Sem
(Input (QualifiedWithTag 'QLocal ())
: Output LocalConversationUpdate : r)
()
-> Sem r [LocalConversationUpdate])
-> Sem
(Input (QualifiedWithTag 'QLocal ())
: Output LocalConversationUpdate : r)
()
-> Sem r [LocalConversationUpdate]
forall a b. (a -> b) -> a -> b
$
[ConversationUpdate]
-> (ConversationUpdate
-> Sem
(Input (QualifiedWithTag 'QLocal ())
: Output LocalConversationUpdate : r)
())
-> Sem
(Input (QualifiedWithTag 'QLocal ())
: Output LocalConversationUpdate : r)
()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [ConversationUpdate]
updates ((ConversationUpdate
-> Sem
(Input (QualifiedWithTag 'QLocal ())
: Output LocalConversationUpdate : r)
())
-> Sem
(Input (QualifiedWithTag 'QLocal ())
: Output LocalConversationUpdate : r)
())
-> (ConversationUpdate
-> Sem
(Input (QualifiedWithTag 'QLocal ())
: Output LocalConversationUpdate : r)
())
-> Sem
(Input (QualifiedWithTag 'QLocal ())
: Output LocalConversationUpdate : r)
()
forall a b. (a -> b) -> a -> b
$ \ConversationUpdate
update -> do
Maybe Event
me <- Remote ConversationUpdate
-> Maybe ConnId
-> Sem
(Input (QualifiedWithTag 'QLocal ())
: Output LocalConversationUpdate : r)
(Maybe Event)
forall (r :: EffectRow).
(Member BrigAccess r, Member NotificationSubsystem r,
Member ExternalAccess r,
Member (Input (QualifiedWithTag 'QLocal ())) r,
Member MemberStore r, Member TinyLog r) =>
Remote ConversationUpdate -> Maybe ConnId -> Sem r (Maybe Event)
updateLocalStateOfRemoteConv (Remote ConvOrSubConvId
-> ConversationUpdate -> Remote ConversationUpdate
forall (t :: QTag) x a.
QualifiedWithTag t x -> a -> QualifiedWithTag t a
qualifyAs Remote ConvOrSubConvId
rConvOrSubId ConversationUpdate
update) Maybe ConnId
con
Maybe Event
-> (Event
-> Sem
(Input (QualifiedWithTag 'QLocal ())
: Output LocalConversationUpdate : r)
())
-> Sem
(Input (QualifiedWithTag 'QLocal ())
: Output LocalConversationUpdate : r)
()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Maybe Event
me ((Event
-> Sem
(Input (QualifiedWithTag 'QLocal ())
: Output LocalConversationUpdate : r)
())
-> Sem
(Input (QualifiedWithTag 'QLocal ())
: Output LocalConversationUpdate : r)
())
-> (Event
-> Sem
(Input (QualifiedWithTag 'QLocal ())
: Output LocalConversationUpdate : r)
())
-> Sem
(Input (QualifiedWithTag 'QLocal ())
: Output LocalConversationUpdate : r)
()
forall a b. (a -> b) -> a -> b
$ \Event
e -> LocalConversationUpdate
-> Sem
(Input (QualifiedWithTag 'QLocal ())
: Output LocalConversationUpdate : r)
()
forall o (r :: EffectRow). Member (Output o) r => o -> Sem r ()
output (Event -> ConversationUpdate -> LocalConversationUpdate
LocalConversationUpdate Event
e ConversationUpdate
update)
MLSMessageResponseNonFederatingBackends NonFederatingBackends
e -> NonFederatingBackends -> Sem r [LocalConversationUpdate]
forall e (r :: EffectRow) a. Member (Error e) r => e -> Sem r a
throw NonFederatingBackends
e
postMLSMessage ::
( HasProposalEffects r,
Member (ErrorS 'ConvAccessDenied) r,
Member (ErrorS 'ConvMemberNotFound) r,
Member (ErrorS 'ConvNotFound) r,
Member (ErrorS 'MLSNotEnabled) r,
Member (ErrorS 'MissingLegalholdConsent) r,
Member (ErrorS 'MLSClientSenderUserMismatch) r,
Member (ErrorS 'MLSCommitMissingReferences) r,
Member (ErrorS 'MLSGroupConversationMismatch) r,
Member (ErrorS 'MLSProposalNotFound) r,
Member (ErrorS 'MLSSelfRemovalNotAllowed) r,
Member (ErrorS 'MLSStaleMessage) r,
Member (ErrorS 'MLSUnsupportedMessage) r,
Member (ErrorS 'MLSSubConvClientNotInParent) r,
Member SubConversationStore r
) =>
Local x ->
Qualified UserId ->
ClientId ->
ConvType ->
Qualified ConvOrSubConvId ->
Maybe ConnId ->
IncomingMessage ->
Sem r [LocalConversationUpdate]
postMLSMessage :: forall (r :: EffectRow) x.
(HasProposalEffects r, Member (ErrorS 'ConvAccessDenied) r,
Member (ErrorS 'ConvMemberNotFound) r,
Member (ErrorS 'ConvNotFound) r, Member (ErrorS 'MLSNotEnabled) r,
Member (ErrorS 'MissingLegalholdConsent) r,
Member (ErrorS 'MLSClientSenderUserMismatch) r,
Member (ErrorS 'MLSCommitMissingReferences) r,
Member (ErrorS 'MLSGroupConversationMismatch) r,
Member (ErrorS 'MLSProposalNotFound) r,
Member (ErrorS 'MLSSelfRemovalNotAllowed) r,
Member (ErrorS 'MLSStaleMessage) r,
Member (ErrorS 'MLSUnsupportedMessage) r,
Member (ErrorS 'MLSSubConvClientNotInParent) r,
Member SubConversationStore r) =>
Local x
-> Qualified UserId
-> ClientId
-> ConvType
-> Qualified ConvOrSubConvId
-> Maybe ConnId
-> IncomingMessage
-> Sem r [LocalConversationUpdate]
postMLSMessage Local x
loc Qualified UserId
qusr ClientId
c ConvType
ctype Qualified ConvOrSubConvId
qconvOrSub Maybe ConnId
con IncomingMessage
msg = do
Local x
-> (Local ConvOrSubConvId -> Sem r [LocalConversationUpdate])
-> (Remote ConvOrSubConvId -> Sem r [LocalConversationUpdate])
-> Qualified ConvOrSubConvId
-> Sem r [LocalConversationUpdate]
forall x a b.
Local x -> (Local a -> b) -> (Remote a -> b) -> Qualified a -> b
foldQualified
Local x
loc
(Qualified UserId
-> ClientId
-> Maybe ConnId
-> IncomingMessage
-> ConvType
-> Local ConvOrSubConvId
-> Sem r [LocalConversationUpdate]
forall (r :: EffectRow).
(HasProposalEffects r, Member (ErrorS 'ConvNotFound) r,
Member (ErrorS 'MLSClientSenderUserMismatch) r,
Member (ErrorS 'MLSStaleMessage) r,
Member (ErrorS 'MLSUnsupportedMessage) r,
Member SubConversationStore r) =>
Qualified UserId
-> ClientId
-> Maybe ConnId
-> IncomingMessage
-> ConvType
-> Local ConvOrSubConvId
-> Sem r [LocalConversationUpdate]
postMLSMessageToLocalConv Qualified UserId
qusr ClientId
c Maybe ConnId
con IncomingMessage
msg ConvType
ctype)
(Local x
-> Qualified UserId
-> ClientId
-> Maybe ConnId
-> IncomingMessage
-> Remote ConvOrSubConvId
-> Sem r [LocalConversationUpdate]
forall (r :: EffectRow) x.
(Members MLSMessageStaticErrors r, HasProposalEffects r) =>
Local x
-> Qualified UserId
-> ClientId
-> Maybe ConnId
-> IncomingMessage
-> Remote ConvOrSubConvId
-> Sem r [LocalConversationUpdate]
postMLSMessageToRemoteConv Local x
loc Qualified UserId
qusr ClientId
c Maybe ConnId
con IncomingMessage
msg)
Qualified ConvOrSubConvId
qconvOrSub
getSenderIdentity ::
( Member (ErrorS 'MLSClientSenderUserMismatch) r,
Member (Error MLSProtocolError) r
) =>
Qualified UserId ->
ClientId ->
Sender ->
Local ConvOrSubConv ->
Sem r ClientIdentity
getSenderIdentity :: forall (r :: EffectRow).
(Member (ErrorS 'MLSClientSenderUserMismatch) r,
Member (Error MLSProtocolError) r) =>
Qualified UserId
-> ClientId
-> Sender
-> Local ConvOrSubConv
-> Sem r ClientIdentity
getSenderIdentity Qualified UserId
qusr ClientId
c Sender
mSender Local ConvOrSubConv
lConvOrSubConv = do
let cid :: ClientIdentity
cid = Qualified UserId -> ClientId -> ClientIdentity
mkClientIdentity Qualified UserId
qusr ClientId
c
let epoch :: Word64
epoch = Epoch -> Word64
epochNumber (Epoch -> Word64)
-> (Local ConvOrSubConv -> Epoch) -> Local ConvOrSubConv -> Word64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConversationMLSData -> Epoch
cnvmlsEpoch (ConversationMLSData -> Epoch)
-> (Local ConvOrSubConv -> ConversationMLSData)
-> Local ConvOrSubConv
-> Epoch
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (.mlsMeta) (ConvOrSubConv -> ConversationMLSData)
-> (Local ConvOrSubConv -> ConvOrSubConv)
-> Local ConvOrSubConv
-> ConversationMLSData
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Local ConvOrSubConv -> ConvOrSubConv
forall (t :: QTag) a. QualifiedWithTag t a -> a
tUnqualified (Local ConvOrSubConv -> Word64) -> Local ConvOrSubConv -> Word64
forall a b. (a -> b) -> a -> b
$ Local ConvOrSubConv
lConvOrSubConv
case Sender
mSender of
SenderMember LeafIndex
idx | Word64
epoch Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
> Word64
0 -> do
ClientIdentity
cid' <- MLSProtocolError -> Maybe ClientIdentity -> Sem r ClientIdentity
forall e (r :: EffectRow) a.
Member (Error e) r =>
e -> Maybe a -> Sem r a
note (Text -> MLSProtocolError
mlsProtocolError Text
"unknown sender leaf index") (Maybe ClientIdentity -> Sem r ClientIdentity)
-> Maybe ClientIdentity -> Sem r ClientIdentity
forall a b. (a -> b) -> a -> b
$ IndexMap -> LeafIndex -> Maybe ClientIdentity
imLookup (Local ConvOrSubConv -> ConvOrSubConv
forall (t :: QTag) a. QualifiedWithTag t a -> a
tUnqualified Local ConvOrSubConv
lConvOrSubConv).indexMap LeafIndex
idx
Bool -> Sem r () -> Sem r ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ClientIdentity
cid' ClientIdentity -> ClientIdentity -> Bool
forall a. Eq a => a -> a -> Bool
== ClientIdentity
cid) (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 @'MLSClientSenderUserMismatch
Sender
_ -> () -> Sem r ()
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
ClientIdentity -> Sem r ClientIdentity
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ClientIdentity
cid
postMLSMessageToLocalConv ::
( HasProposalEffects r,
Member (ErrorS 'ConvNotFound) r,
Member (ErrorS 'MLSClientSenderUserMismatch) r,
Member (ErrorS 'MLSStaleMessage) r,
Member (ErrorS 'MLSUnsupportedMessage) r,
Member SubConversationStore r
) =>
Qualified UserId ->
ClientId ->
Maybe ConnId ->
IncomingMessage ->
ConvType ->
Local ConvOrSubConvId ->
Sem r [LocalConversationUpdate]
postMLSMessageToLocalConv :: forall (r :: EffectRow).
(HasProposalEffects r, Member (ErrorS 'ConvNotFound) r,
Member (ErrorS 'MLSClientSenderUserMismatch) r,
Member (ErrorS 'MLSStaleMessage) r,
Member (ErrorS 'MLSUnsupportedMessage) r,
Member SubConversationStore r) =>
Qualified UserId
-> ClientId
-> Maybe ConnId
-> IncomingMessage
-> ConvType
-> Local ConvOrSubConvId
-> Sem r [LocalConversationUpdate]
postMLSMessageToLocalConv Qualified UserId
qusr ClientId
c Maybe ConnId
con IncomingMessage
msg ConvType
ctype Local ConvOrSubConvId
convOrSubId = do
Local ConvOrSubConv
lConvOrSub <- Qualified UserId
-> GroupId
-> ConvType
-> Local ConvOrSubConvId
-> Sem r (Local ConvOrSubConv)
forall (r :: EffectRow).
(Member ConversationStore r, Member (ErrorS 'ConvNotFound) r,
Member (Error MLSProtocolError) r, Member MemberStore r,
Member SubConversationStore r) =>
Qualified UserId
-> GroupId
-> ConvType
-> Local ConvOrSubConvId
-> Sem r (Local ConvOrSubConv)
fetchConvOrSub Qualified UserId
qusr IncomingMessage
msg.groupId ConvType
ctype Local ConvOrSubConvId
convOrSubId
let convOrSub :: ConvOrSubConv
convOrSub = Local ConvOrSubConv -> ConvOrSubConv
forall (t :: QTag) a. QualifiedWithTag t a -> a
tUnqualified Local ConvOrSubConv
lConvOrSub
Maybe Sender -> (Sender -> Sem r ()) -> Sem r ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ IncomingMessage
msg.sender ((Sender -> Sem r ()) -> Sem r ())
-> (Sender -> Sem r ()) -> Sem r ()
forall a b. (a -> b) -> a -> b
$ \Sender
sender ->
Sem r ClientIdentity -> Sem r ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Sem r ClientIdentity -> Sem r ())
-> Sem r ClientIdentity -> Sem r ()
forall a b. (a -> b) -> a -> b
$ Qualified UserId
-> ClientId
-> Sender
-> Local ConvOrSubConv
-> Sem r ClientIdentity
forall (r :: EffectRow).
(Member (ErrorS 'MLSClientSenderUserMismatch) r,
Member (Error MLSProtocolError) r) =>
Qualified UserId
-> ClientId
-> Sender
-> Local ConvOrSubConv
-> Sem r ClientIdentity
getSenderIdentity Qualified UserId
qusr ClientId
c Sender
sender Local ConvOrSubConv
lConvOrSub
case IncomingMessage
msg.content of
IncomingMessageContentPublic IncomingPublicMessageContent
pub -> case IncomingPublicMessageContent
pub.content of
FramedContentCommit RawMLS Commit
_commit -> 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 @'MLSUnsupportedMessage
FramedContentApplicationData ByteString
_ -> 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 @'MLSUnsupportedMessage
FramedContentProposal RawMLS Proposal
prop ->
Qualified UserId
-> Local ConvOrSubConv
-> GroupId
-> Epoch
-> IncomingPublicMessageContent
-> RawMLS Proposal
-> Sem r ()
forall (r :: EffectRow).
(HasProposalEffects r, Member (ErrorS 'ConvNotFound) r,
Member (ErrorS 'MLSStaleMessage) r) =>
Qualified UserId
-> Local ConvOrSubConv
-> GroupId
-> Epoch
-> IncomingPublicMessageContent
-> RawMLS Proposal
-> Sem r ()
processProposal Qualified UserId
qusr Local ConvOrSubConv
lConvOrSub IncomingMessage
msg.groupId IncomingMessage
msg.epoch IncomingPublicMessageContent
pub RawMLS Proposal
prop
IncomingMessageContent
IncomingMessageContentPrivate -> do
Bool -> Sem r () -> Sem r ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ConvOrSubConv
convOrSub.migrationState MLSMigrationState -> MLSMigrationState -> Bool
forall a. Eq a => a -> a -> Bool
== MLSMigrationState
MLSMigrationMixed) (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 @'MLSUnsupportedMessage
let epochInt :: Epoch -> Integer
epochInt :: Epoch -> Integer
epochInt = Word64 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> Integer) -> (Epoch -> Word64) -> Epoch -> Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Epoch -> Word64
epochNumber
case ConvOrSubConv
convOrSub.mlsMeta.cnvmlsActiveData of
Maybe ActiveMLSConversationData
Nothing -> 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
"Application messages at epoch 0 are not supported"
Just ActiveMLSConversationData
activeData ->
Bool -> Sem r () -> Sem r ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when
( Epoch -> Integer
epochInt IncomingMessage
msg.epoch Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Epoch -> Integer
epochInt ActiveMLSConversationData
activeData.epoch Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
2
Bool -> Bool -> Bool
|| Epoch -> Integer
epochInt IncomingMessage
msg.epoch Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Epoch -> Integer
epochInt ActiveMLSConversationData
activeData.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
Qualified UserId
-> Maybe ClientId
-> Local ConvOrSubConv
-> Maybe ConnId
-> RawMLS Message
-> ClientMap
-> Sem 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 (ClientId -> Maybe ClientId
forall a. a -> Maybe a
Just ClientId
c) Local ConvOrSubConv
lConvOrSub Maybe ConnId
con IncomingMessage
msg.rawMessage (Local ConvOrSubConv -> ConvOrSubConv
forall (t :: QTag) a. QualifiedWithTag t a -> a
tUnqualified Local ConvOrSubConv
lConvOrSub).members
[LocalConversationUpdate] -> Sem r [LocalConversationUpdate]
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
postMLSMessageToRemoteConv ::
( Members MLSMessageStaticErrors r,
HasProposalEffects r
) =>
Local x ->
Qualified UserId ->
ClientId ->
Maybe ConnId ->
IncomingMessage ->
Remote ConvOrSubConvId ->
Sem r [LocalConversationUpdate]
postMLSMessageToRemoteConv :: forall (r :: EffectRow) x.
(Members MLSMessageStaticErrors r, HasProposalEffects r) =>
Local x
-> Qualified UserId
-> ClientId
-> Maybe ConnId
-> IncomingMessage
-> Remote ConvOrSubConvId
-> Sem r [LocalConversationUpdate]
postMLSMessageToRemoteConv Local x
loc Qualified UserId
qusr ClientId
senderClient Maybe ConnId
con IncomingMessage
msg Remote ConvOrSubConvId
rConvOrSubId = do
Local UserId
lusr <- Local x
-> (Local UserId -> Sem r (Local UserId))
-> (Remote UserId -> Sem r (Local UserId))
-> Qualified UserId
-> Sem r (Local UserId)
forall x a b.
Local x -> (Local a -> b) -> (Remote a -> b) -> Qualified a -> b
foldQualified Local x
loc Local UserId -> Sem r (Local UserId)
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (\Remote UserId
_ -> 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 @'ConvAccessDenied) Qualified UserId
qusr
(Bool -> Sem r () -> Sem r ()) -> Sem r () -> Bool -> Sem r ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip Bool -> Sem r () -> Sem r ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (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 @'ConvMemberNotFound) (Bool -> Sem r ()) -> Sem r Bool -> Sem r ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< UserId -> Remote ConvId -> Sem r Bool
forall (r :: EffectRow).
Member MemberStore r =>
UserId -> Remote ConvId -> Sem r Bool
checkLocalMemberRemoteConv (Local UserId -> UserId
forall (t :: QTag) a. QualifiedWithTag t a -> a
tUnqualified Local UserId
lusr) ((.conv) (ConvOrSubConvId -> ConvId)
-> Remote ConvOrSubConvId -> Remote ConvId
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Remote ConvOrSubConvId
rConvOrSubId)
MLSMessageResponse
resp <-
Remote ConvOrSubConvId
-> FederatorClient 'Galley MLSMessageResponse
-> Sem r MLSMessageResponse
forall (r :: EffectRow) (c :: Component) x a.
(Member FederatorAccess r, KnownComponent c) =>
Remote x -> FederatorClient c a -> Sem r a
runFederated Remote ConvOrSubConvId
rConvOrSubId (FederatorClient 'Galley MLSMessageResponse
-> Sem r MLSMessageResponse)
-> FederatorClient 'Galley MLSMessageResponse
-> Sem r MLSMessageResponse
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 @"send-mls-message" (MLSMessageSendRequest
-> FederatorClient 'Galley MLSMessageResponse)
-> MLSMessageSendRequest
-> FederatorClient 'Galley MLSMessageResponse
forall a b. (a -> b) -> a -> b
$
MLSMessageSendRequest
{ $sel:convOrSubId:MLSMessageSendRequest :: ConvOrSubConvId
convOrSubId = Remote ConvOrSubConvId -> ConvOrSubConvId
forall (t :: QTag) a. QualifiedWithTag t a -> a
tUnqualified Remote ConvOrSubConvId
rConvOrSubId,
$sel:sender:MLSMessageSendRequest :: UserId
sender = Local UserId -> UserId
forall (t :: QTag) a. QualifiedWithTag t a -> a
tUnqualified Local UserId
lusr,
$sel:senderClient:MLSMessageSendRequest :: ClientId
senderClient = ClientId
senderClient,
$sel:rawMessage:MLSMessageSendRequest :: Base64ByteString
rawMessage = ByteString -> Base64ByteString
Base64ByteString IncomingMessage
msg.rawMessage.raw
}
case MLSMessageResponse
resp of
MLSMessageResponseError GalleyError
e -> forall (effs :: EffectRow) (r :: EffectRow) a.
RethrowErrors effs r =>
GalleyError -> Sem r a
rethrowErrors @MLSMessageStaticErrors GalleyError
e
MLSMessageResponseProtocolError Text
e ->
MLSProtocolError -> Sem r [LocalConversationUpdate]
forall e (r :: EffectRow) a. Member (Error e) r => e -> Sem r a
throw (Text -> MLSProtocolError
mlsProtocolError Text
e)
MLSMessageResponseProposalFailure JSONResponse
e -> MLSProposalFailure -> Sem r [LocalConversationUpdate]
forall e (r :: EffectRow) a. Member (Error e) r => e -> Sem r a
throw (JSONResponse -> MLSProposalFailure
MLSProposalFailure JSONResponse
e)
MLSMessageResponseUnreachableBackends Set Domain
ds ->
InternalError -> Sem r [LocalConversationUpdate]
forall e (r :: EffectRow) a. Member (Error e) r => e -> Sem r a
throw (InternalError -> Sem r [LocalConversationUpdate])
-> (LText -> InternalError)
-> LText
-> Sem r [LocalConversationUpdate]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LText -> InternalError
InternalErrorWithDescription (LText -> Sem r [LocalConversationUpdate])
-> LText -> Sem r [LocalConversationUpdate]
forall a b. (a -> b) -> a -> b
$
LText
"An application or proposal message to a remote conversation should \
\not ever return a non-empty list of domains a commit could not be \
\sent to. The remote end returned: "
LText -> LText -> LText
forall a. Semigroup a => a -> a -> a
<> [Char] -> LText
LT.pack ([Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
intercalate [Char]
", " (Text -> [Char]
forall a. Show a => a -> [Char]
show (Text -> [Char]) -> [Text] -> [[Char]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Set Text -> [Text]
forall a. Set a -> [a]
Set.toList ((Domain -> Text) -> Set Domain -> Set Text
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map Domain -> Text
domainText Set Domain
ds)))
MLSMessageResponseUpdates [ConversationUpdate]
updates -> do
(([LocalConversationUpdate], ()) -> [LocalConversationUpdate])
-> Sem r ([LocalConversationUpdate], ())
-> Sem r [LocalConversationUpdate]
forall a b. (a -> b) -> Sem r a -> Sem r b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([LocalConversationUpdate], ()) -> [LocalConversationUpdate]
forall a b. (a, b) -> a
fst (Sem r ([LocalConversationUpdate], ())
-> Sem r [LocalConversationUpdate])
-> (Sem (Output LocalConversationUpdate : r) ()
-> Sem r ([LocalConversationUpdate], ()))
-> Sem (Output LocalConversationUpdate : r) ()
-> Sem r [LocalConversationUpdate]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Sem (Output LocalConversationUpdate : r) ()
-> Sem r ([LocalConversationUpdate], ())
forall o (r :: EffectRow) a. Sem (Output o : r) a -> Sem r ([o], a)
runOutputList (Sem (Output LocalConversationUpdate : r) ()
-> Sem r [LocalConversationUpdate])
-> Sem (Output LocalConversationUpdate : r) ()
-> Sem r [LocalConversationUpdate]
forall a b. (a -> b) -> a -> b
$
[ConversationUpdate]
-> (ConversationUpdate
-> Sem (Output LocalConversationUpdate : r) ())
-> Sem (Output LocalConversationUpdate : r) ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [ConversationUpdate]
updates ((ConversationUpdate
-> Sem (Output LocalConversationUpdate : r) ())
-> Sem (Output LocalConversationUpdate : r) ())
-> (ConversationUpdate
-> Sem (Output LocalConversationUpdate : r) ())
-> Sem (Output LocalConversationUpdate : r) ()
forall a b. (a -> b) -> a -> b
$ \ConversationUpdate
update -> do
Maybe Event
me <- Remote ConversationUpdate
-> Maybe ConnId
-> Sem (Output LocalConversationUpdate : r) (Maybe Event)
forall (r :: EffectRow).
(Member BrigAccess r, Member NotificationSubsystem r,
Member ExternalAccess r,
Member (Input (QualifiedWithTag 'QLocal ())) r,
Member MemberStore r, Member TinyLog r) =>
Remote ConversationUpdate -> Maybe ConnId -> Sem r (Maybe Event)
updateLocalStateOfRemoteConv (Remote ConvOrSubConvId
-> ConversationUpdate -> Remote ConversationUpdate
forall (t :: QTag) x a.
QualifiedWithTag t x -> a -> QualifiedWithTag t a
qualifyAs Remote ConvOrSubConvId
rConvOrSubId ConversationUpdate
update) Maybe ConnId
con
Maybe Event
-> (Event -> Sem (Output LocalConversationUpdate : r) ())
-> Sem (Output LocalConversationUpdate : r) ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Maybe Event
me ((Event -> Sem (Output LocalConversationUpdate : r) ())
-> Sem (Output LocalConversationUpdate : r) ())
-> (Event -> Sem (Output LocalConversationUpdate : r) ())
-> Sem (Output LocalConversationUpdate : r) ()
forall a b. (a -> b) -> a -> b
$ \Event
e -> LocalConversationUpdate
-> Sem (Output LocalConversationUpdate : r) ()
forall o (r :: EffectRow). Member (Output o) r => o -> Sem r ()
output (Event -> ConversationUpdate -> LocalConversationUpdate
LocalConversationUpdate Event
e ConversationUpdate
update)
MLSMessageResponseNonFederatingBackends NonFederatingBackends
e -> NonFederatingBackends -> Sem r [LocalConversationUpdate]
forall e (r :: EffectRow) a. Member (Error e) r => e -> Sem r a
throw NonFederatingBackends
e
storeGroupInfo ::
( Member ConversationStore r,
Member SubConversationStore r
) =>
ConvOrSubConvId ->
GroupInfoData ->
Sem r ()
storeGroupInfo :: forall (r :: EffectRow).
(Member ConversationStore r, Member SubConversationStore r) =>
ConvOrSubConvId -> GroupInfoData -> Sem r ()
storeGroupInfo ConvOrSubConvId
convOrSub GroupInfoData
ginfo = case ConvOrSubConvId
convOrSub of
Conv ConvId
cid -> ConvId -> GroupInfoData -> Sem r ()
forall (r :: EffectRow).
Member ConversationStore r =>
ConvId -> GroupInfoData -> Sem r ()
setGroupInfo ConvId
cid GroupInfoData
ginfo
SubConv ConvId
cid SubConvId
subconvid -> ConvId -> SubConvId -> Maybe GroupInfoData -> Sem r ()
forall (r :: EffectRow).
Member SubConversationStore r =>
ConvId -> SubConvId -> Maybe GroupInfoData -> Sem r ()
setSubConversationGroupInfo ConvId
cid SubConvId
subconvid (GroupInfoData -> Maybe GroupInfoData
forall a. a -> Maybe a
Just GroupInfoData
ginfo)
fetchConvOrSub ::
forall r.
( Member ConversationStore r,
Member (ErrorS 'ConvNotFound) r,
Member (Error MLSProtocolError) r,
Member MemberStore r,
Member SubConversationStore r
) =>
Qualified UserId ->
GroupId ->
ConvType ->
Local ConvOrSubConvId ->
Sem r (Local ConvOrSubConv)
fetchConvOrSub :: forall (r :: EffectRow).
(Member ConversationStore r, Member (ErrorS 'ConvNotFound) r,
Member (Error MLSProtocolError) r, Member MemberStore r,
Member SubConversationStore r) =>
Qualified UserId
-> GroupId
-> ConvType
-> Local ConvOrSubConvId
-> Sem r (Local ConvOrSubConv)
fetchConvOrSub Qualified UserId
qusr GroupId
groupId ConvType
ctype Local ConvOrSubConvId
convOrSubId = Local ConvOrSubConvId
-> (ConvOrSubConvId -> 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 ConvOrSubConvId
convOrSubId ((ConvOrSubConvId -> Sem r ConvOrSubConv)
-> Sem r (Local ConvOrSubConv))
-> (ConvOrSubConvId -> Sem r ConvOrSubConv)
-> Sem r (Local ConvOrSubConv)
forall a b. (a -> b) -> a -> b
$ \case
Conv ConvId
convId -> MLSConversation -> ConvOrSubConv
forall c s. c -> ConvOrSubChoice c s
Conv (MLSConversation -> ConvOrSubConv)
-> Sem r MLSConversation -> Sem r ConvOrSubConv
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Qualified UserId
-> Maybe GroupId
-> ConvType
-> Local ConvId
-> Sem r MLSConversation
forall (r :: EffectRow).
(Member (ErrorS 'ConvNotFound) r,
Member (Error MLSProtocolError) r, Member ConversationStore r,
Member MemberStore r) =>
Qualified UserId
-> Maybe GroupId
-> ConvType
-> Local ConvId
-> Sem r MLSConversation
getMLSConv Qualified UserId
qusr (GroupId -> Maybe GroupId
forall a. a -> Maybe a
Just GroupId
groupId) ConvType
ctype (Local ConvOrSubConvId -> ConvId -> Local ConvId
forall (t :: QTag) x a.
QualifiedWithTag t x -> a -> QualifiedWithTag t a
qualifyAs Local ConvOrSubConvId
convOrSubId ConvId
convId)
SubConv ConvId
convId SubConvId
sconvId -> do
let lconv :: Local ConvId
lconv = Local ConvOrSubConvId -> ConvId -> Local ConvId
forall (t :: QTag) x a.
QualifiedWithTag t x -> a -> QualifiedWithTag t a
qualifyAs Local ConvOrSubConvId
convOrSubId ConvId
convId
MLSConversation
c <- Qualified UserId
-> Maybe GroupId
-> ConvType
-> Local ConvId
-> Sem r MLSConversation
forall (r :: EffectRow).
(Member (ErrorS 'ConvNotFound) r,
Member (Error MLSProtocolError) r, Member ConversationStore r,
Member MemberStore r) =>
Qualified UserId
-> Maybe GroupId
-> ConvType
-> Local ConvId
-> Sem r MLSConversation
getMLSConv Qualified UserId
qusr Maybe GroupId
forall a. Maybe a
Nothing ConvType
ctype Local ConvId
lconv
Maybe SubConversation
msubconv <- ConvId -> SubConvId -> Sem r (Maybe SubConversation)
forall (r :: EffectRow).
Member SubConversationStore r =>
ConvId -> SubConvId -> Sem r (Maybe SubConversation)
getSubConversation ConvId
convId SubConvId
sconvId
SubConversation
subconv <- case Maybe SubConversation
msubconv of
Maybe SubConversation
Nothing -> SubConversation -> Sem r SubConversation
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SubConversation -> Sem r SubConversation)
-> SubConversation -> Sem r SubConversation
forall a b. (a -> b) -> a -> b
$ Local ConvId -> SubConvId -> SubConversation
newSubConversationFromParent Local ConvId
lconv SubConvId
sconvId
Just SubConversation
subconv -> do
Bool -> Sem r () -> Sem r ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (GroupId
groupId GroupId -> GroupId -> Bool
forall a. Eq a => a -> a -> Bool
/= SubConversation
subconv.scMLSData.cnvmlsGroupId) (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
"The message group ID does not match the subconversation")
SubConversation -> Sem r SubConversation
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SubConversation
subconv
ConvOrSubConv -> Sem r ConvOrSubConv
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (MLSConversation -> SubConversation -> ConvOrSubConv
forall c s. c -> s -> ConvOrSubChoice c s
SubConv MLSConversation
c SubConversation
subconv)
getMLSConv ::
( Member (ErrorS 'ConvNotFound) r,
Member (Error MLSProtocolError) r,
Member ConversationStore r,
Member MemberStore r
) =>
Qualified UserId ->
Maybe GroupId ->
ConvType ->
Local ConvId ->
Sem r MLSConversation
getMLSConv :: forall (r :: EffectRow).
(Member (ErrorS 'ConvNotFound) r,
Member (Error MLSProtocolError) r, Member ConversationStore r,
Member MemberStore r) =>
Qualified UserId
-> Maybe GroupId
-> ConvType
-> Local ConvId
-> Sem r MLSConversation
getMLSConv Qualified UserId
u Maybe GroupId
mGroupId ConvType
ctype Local ConvId
lcnv = do
MLSConversation
mlsConv <- case ConvType
ctype of
ConvType
One2OneConv -> do
Maybe Conversation
mconv <- ConvId -> Sem r (Maybe Conversation)
forall (r :: EffectRow).
Member ConversationStore r =>
ConvId -> Sem r (Maybe Conversation)
getConversation (Local ConvId -> ConvId
forall (t :: QTag) a. QualifiedWithTag t a -> a
tUnqualified Local ConvId
lcnv)
case Maybe Conversation
mconv of
Just Conversation
conv -> Conversation -> Sem r (Maybe MLSConversation)
forall (r :: EffectRow).
Member MemberStore r =>
Conversation -> Sem r (Maybe MLSConversation)
mkMLSConversation Conversation
conv Sem r (Maybe MLSConversation)
-> (Maybe MLSConversation -> Sem r MLSConversation)
-> Sem r MLSConversation
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
Maybe Conversation
Nothing ->
let (ConversationMetadata
meta, ConversationMLSData
mlsData) = Qualified ConvId -> (ConversationMetadata, ConversationMLSData)
localMLSOne2OneConversationMetadata (Local ConvId -> Qualified ConvId
forall (t :: QTag) a. QualifiedWithTag t a -> Qualified a
tUntagged Local ConvId
lcnv)
in MLSConversation -> Sem r MLSConversation
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Local ConvId
-> ConversationMetadata -> ConversationMLSData -> MLSConversation
newMLSConversation Local ConvId
lcnv ConversationMetadata
meta ConversationMLSData
mlsData)
ConvType
_ ->
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
u Local ConvId
lcnv
Sem r Conversation
-> (Conversation -> Sem r (Maybe MLSConversation))
-> Sem r (Maybe MLSConversation)
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
>>= Conversation -> Sem r (Maybe MLSConversation)
forall (r :: EffectRow).
Member MemberStore r =>
Conversation -> Sem r (Maybe MLSConversation)
mkMLSConversation
Sem r (Maybe MLSConversation)
-> (Maybe MLSConversation -> Sem r MLSConversation)
-> Sem r MLSConversation
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
Maybe GroupId -> (GroupId -> Sem r ()) -> Sem r ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Maybe GroupId
mGroupId ((GroupId -> Sem r ()) -> Sem r ())
-> (GroupId -> Sem r ()) -> Sem r ()
forall a b. (a -> b) -> a -> b
$ \GroupId
groupId ->
Bool -> Sem r () -> Sem r ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (GroupId
groupId GroupId -> GroupId -> Bool
forall a. Eq a => a -> a -> Bool
/= MLSConversation
mlsConv.mcMLSData.cnvmlsGroupId) (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
"The message group ID does not match the conversation")
MLSConversation -> Sem r MLSConversation
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure MLSConversation
mlsConv