-- 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.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

-- FUTUREWORK
-- - Check that the capabilities of a leaf node in an add proposal contains all
--   the required_capabilities of the group context. This would require fetching
--   the group info from the DB in order to read the group context.
-- - Verify message signature, this also requires the group context. (see above)

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

  -- when a user tries to join any mls conversation while being under legalhold
  -- they receive a 409 stating that mls and legalhold are incompatible
  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
          -- this would only return 'Left' if the team member did vanish directly in the process of this
          -- request or if the legalhold state was somehow inconsistent. We can safely assume that this
          -- should be a server error
          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 ()

    -- we can skip the remote case because we currently to not support creating conversations on the remote backend
    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
    -- if this is the first commit of the conversation, update ciphersuite
    Maybe ActiveMLSConversationData
Nothing -> Bool -> Sem r Bool
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
    -- otherwise, make sure the ciphersuite matches
    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
      -- extract added/removed clients from bundle
      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

      -- process additions and removals
      [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
      -- the sender client is included in the Add action on the first commit,
      -- but it doesn't need to get a welcome message, so we filter it out here
      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
  -- only local users can send messages to remote conversations
  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
$
    -- only members may send commit bundles to a remote conversation
    (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 x.
(AddAnnotation 'Remote showcomp (FedPath name) x,
 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 x.
(AddAnnotation 'Remote showcomp (FedPath name) x,
 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

  -- validate message
  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
      -- proposal message
      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
      -- application message:

      -- reject all application messages if the conv is in mixed state
      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

      -- reject application messages older than 2 epochs
      -- FUTUREWORK: consider rejecting this message if the conversation epoch is 0
      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
  -- only local users can send messages to remote conversations
  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
  -- only members may send messages to the remote conversation
  (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 x.
(AddAnnotation 'Remote showcomp (FedPath name) x,
 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 x.
(AddAnnotation 'Remote showcomp (FedPath name) x,
 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
  -- check that the group ID in the message matches that of the conversation
  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