module Galley.API.MLS.Propagate where
import Control.Comonad
import Data.Id
import Data.Json.Util
import Data.List.NonEmpty (NonEmpty, nonEmpty)
import Data.List1
import Data.Map qualified as Map
import Data.Qualified
import Data.Time
import Galley.API.MLS.Types
import Galley.API.Push
import Galley.Data.Services
import Galley.Effects
import Galley.Effects.BackendNotificationQueueAccess
import Galley.Types.Conversations.Members
import Imports
import Network.AMQP qualified as Q
import Polysemy
import Polysemy.Error
import Polysemy.Input
import Polysemy.TinyLog hiding (trace)
import Wire.API.Event.Conversation
import Wire.API.Federation.API
import Wire.API.Federation.API.Galley
import Wire.API.Federation.Error
import Wire.API.MLS.Credential
import Wire.API.MLS.Message
import Wire.API.MLS.Serialisation
import Wire.API.MLS.SubConversation
import Wire.API.Message
import Wire.API.Push.V2 (RecipientClients (..))
import Wire.NotificationSubsystem
propagateMessage ::
( 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 :: forall (r :: EffectRow).
(Member BackendNotificationQueueAccess r,
Member (Error FederationError) r, Member ExternalAccess r,
Member (Input UTCTime) r, Member TinyLog r,
Member NotificationSubsystem r) =>
Qualified UserId
-> Maybe ClientId
-> Local ConvOrSubConv
-> Maybe ConnId
-> RawMLS Message
-> ClientMap
-> Sem r ()
propagateMessage Qualified UserId
qusr Maybe ClientId
mSenderClient Local ConvOrSubConv
lConvOrSub Maybe ConnId
con RawMLS Message
msg ClientMap
cm = do
UTCTime
now <- forall i (r :: EffectRow). Member (Input i) r => Sem r i
input @UTCTime
let mlsConv :: QualifiedWithTag 'QLocal MLSConversation
mlsConv = (.conv) (ConvOrSubConv -> MLSConversation)
-> Local ConvOrSubConv -> QualifiedWithTag 'QLocal MLSConversation
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Local ConvOrSubConv
lConvOrSub
lmems :: [LocalMember]
lmems = MLSConversation -> [LocalMember]
mcLocalMembers (MLSConversation -> [LocalMember])
-> (QualifiedWithTag 'QLocal MLSConversation -> MLSConversation)
-> QualifiedWithTag 'QLocal MLSConversation
-> [LocalMember]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QualifiedWithTag 'QLocal MLSConversation -> MLSConversation
forall (t :: QTag) a. QualifiedWithTag t a -> a
tUnqualified (QualifiedWithTag 'QLocal MLSConversation -> [LocalMember])
-> QualifiedWithTag 'QLocal MLSConversation -> [LocalMember]
forall a b. (a -> b) -> a -> b
$ QualifiedWithTag 'QLocal MLSConversation
mlsConv
rmems :: [RemoteMember]
rmems = MLSConversation -> [RemoteMember]
mcRemoteMembers (MLSConversation -> [RemoteMember])
-> (QualifiedWithTag 'QLocal MLSConversation -> MLSConversation)
-> QualifiedWithTag 'QLocal MLSConversation
-> [RemoteMember]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QualifiedWithTag 'QLocal MLSConversation -> MLSConversation
forall (t :: QTag) a. QualifiedWithTag t a -> a
tUnqualified (QualifiedWithTag 'QLocal MLSConversation -> [RemoteMember])
-> QualifiedWithTag 'QLocal MLSConversation -> [RemoteMember]
forall a b. (a -> b) -> a -> b
$ QualifiedWithTag 'QLocal MLSConversation
mlsConv
botMap :: Map UserId BotMember
botMap = [(UserId, BotMember)] -> Map UserId BotMember
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(UserId, BotMember)] -> Map UserId BotMember)
-> [(UserId, BotMember)] -> Map UserId BotMember
forall a b. (a -> b) -> a -> b
$ do
LocalMember
m <- [LocalMember]
lmems
BotMember
b <- Maybe BotMember -> [BotMember]
forall a. Maybe a -> [a]
maybeToList (Maybe BotMember -> [BotMember]) -> Maybe BotMember -> [BotMember]
forall a b. (a -> b) -> a -> b
$ LocalMember -> Maybe BotMember
newBotMember LocalMember
m
(UserId, BotMember) -> [(UserId, BotMember)]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LocalMember -> UserId
lmId LocalMember
m, BotMember
b)
mm :: MessageMetadata
mm = MessageMetadata
defMessageMetadata
let qt :: Qualified (ConvId, Maybe SubConvId)
qt =
Local ConvOrSubConv -> Qualified ConvOrSubConv
forall (t :: QTag) a. QualifiedWithTag t a -> Qualified a
tUntagged Local ConvOrSubConv
lConvOrSub Qualified ConvOrSubConv
-> (ConvOrSubConv -> (ConvId, Maybe SubConvId))
-> Qualified (ConvId, Maybe SubConvId)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case
Conv MLSConversation
c -> (MLSConversation -> ConvId
mcId MLSConversation
c, Maybe SubConvId
forall a. Maybe a
Nothing)
SubConv MLSConversation
c SubConversation
s -> (MLSConversation -> ConvId
mcId MLSConversation
c, SubConvId -> Maybe SubConvId
forall a. a -> Maybe a
Just (SubConversation -> SubConvId
scSubConvId SubConversation
s))
qcnv :: Qualified ConvId
qcnv = (ConvId, Maybe SubConvId) -> ConvId
forall a b. (a, b) -> a
fst ((ConvId, Maybe SubConvId) -> ConvId)
-> Qualified (ConvId, Maybe SubConvId) -> Qualified ConvId
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Qualified (ConvId, Maybe SubConvId)
qt
sconv :: Maybe SubConvId
sconv = (ConvId, Maybe SubConvId) -> Maybe SubConvId
forall a b. (a, b) -> b
snd (Qualified (ConvId, Maybe SubConvId) -> (ConvId, Maybe SubConvId)
forall a. Qualified a -> a
qUnqualified Qualified (ConvId, Maybe SubConvId)
qt)
e :: Event
e = Qualified ConvId
-> Maybe SubConvId
-> Qualified UserId
-> UTCTime
-> EventData
-> Event
Event Qualified ConvId
qcnv Maybe SubConvId
sconv Qualified UserId
qusr UTCTime
now (EventData -> Event) -> EventData -> Event
forall a b. (a -> b) -> a -> b
$ ByteString -> EventData
EdMLSMessage RawMLS Message
msg.raw
Local ConvOrSubConv
-> Maybe (Qualified ConvId) -> MessagePush -> Sem r ()
forall x (r :: EffectRow).
(Member ExternalAccess r, Member TinyLog r,
Member NotificationSubsystem r) =>
Local x -> Maybe (Qualified ConvId) -> MessagePush -> Sem r ()
runMessagePush Local ConvOrSubConv
lConvOrSub (Qualified ConvId -> Maybe (Qualified ConvId)
forall a. a -> Maybe a
Just Qualified ConvId
qcnv) (MessagePush -> Sem r ()) -> MessagePush -> Sem r ()
forall a b. (a -> b) -> a -> b
$
Map UserId BotMember
-> Maybe ConnId
-> MessageMetadata
-> [Recipient]
-> Event
-> MessagePush
forall r.
ToRecipient r =>
Map UserId BotMember
-> Maybe ConnId -> MessageMetadata -> [r] -> Event -> MessagePush
newMessagePush Map UserId BotMember
botMap Maybe ConnId
con MessageMetadata
mm ([LocalMember]
lmems [LocalMember] -> (LocalMember -> [Recipient]) -> [Recipient]
forall a b. [a] -> (a -> [b]) -> [b]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Maybe Recipient -> [Recipient]
forall a. Maybe a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Maybe Recipient -> [Recipient])
-> (LocalMember -> Maybe Recipient) -> LocalMember -> [Recipient]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QualifiedWithTag 'QLocal MLSConversation
-> LocalMember -> Maybe Recipient
forall x. Local x -> LocalMember -> Maybe Recipient
localMemberRecipient QualifiedWithTag 'QLocal MLSConversation
mlsConv) Event
e
Sem r [Remote ()] -> Sem r ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Sem r [Remote ()] -> Sem r ()) -> Sem r [Remote ()] -> Sem r ()
forall a b. (a -> b) -> a -> b
$
DeliveryMode
-> [Remote RemoteMember]
-> (Remote [RemoteMember] -> FedQueueClient 'Galley ())
-> Sem r [Remote ()]
forall (c :: Component) (f :: * -> *) (r :: EffectRow) x a.
(KnownComponent c, Foldable f, Functor f,
Member (Error FederationError) r,
Member BackendNotificationQueueAccess r) =>
DeliveryMode
-> f (Remote x)
-> (Remote [x] -> FedQueueClient c a)
-> Sem r [Remote a]
enqueueNotificationsConcurrently DeliveryMode
Q.Persistent ((RemoteMember -> Remote RemoteMember)
-> [RemoteMember] -> [Remote RemoteMember]
forall a b. (a -> b) -> [a] -> [b]
map RemoteMember -> Remote RemoteMember
remoteMemberQualify [RemoteMember]
rmems) ((Remote [RemoteMember] -> FedQueueClient 'Galley ())
-> Sem r [Remote ()])
-> (Remote [RemoteMember] -> FedQueueClient 'Galley ())
-> Sem r [Remote ()]
forall a b. (a -> b) -> a -> b
$
\Remote [RemoteMember]
rs ->
forall {k} (tag :: k) (c :: Component).
(HasNotificationEndpoint tag, HasVersionRange tag, HasFedPath tag,
KnownComponent (NotificationComponent k), ToJSON (Payload tag),
c ~ NotificationComponent k) =>
Payload tag -> FedQueueClient c ()
forall (tag :: GalleyNotificationTag) (c :: Component).
(HasNotificationEndpoint tag, HasVersionRange tag, HasFedPath tag,
KnownComponent (NotificationComponent GalleyNotificationTag),
ToJSON (Payload tag),
c ~ NotificationComponent GalleyNotificationTag) =>
Payload tag -> FedQueueClient c ()
fedQueueClient
@'OnMLSMessageSentTag
RemoteMLSMessage
{ $sel:time:RemoteMLSMessage :: UTCTime
time = UTCTime
now,
$sel:sender:RemoteMLSMessage :: Qualified UserId
sender = Qualified UserId
qusr,
$sel:metadata:RemoteMLSMessage :: MessageMetadata
metadata = MessageMetadata
mm,
$sel:conversation:RemoteMLSMessage :: ConvId
conversation = Qualified ConvId -> ConvId
forall a. Qualified a -> a
qUnqualified Qualified ConvId
qcnv,
$sel:subConversation:RemoteMLSMessage :: Maybe SubConvId
subConversation = Maybe SubConvId
sconv,
$sel:recipients:RemoteMLSMessage :: Map UserId (NonEmpty ClientId)
recipients =
[(UserId, NonEmpty ClientId)] -> Map UserId (NonEmpty ClientId)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(UserId, NonEmpty ClientId)] -> Map UserId (NonEmpty ClientId))
-> [(UserId, NonEmpty ClientId)] -> Map UserId (NonEmpty ClientId)
forall a b. (a -> b) -> a -> b
$
Remote [RemoteMember] -> [RemoteMember]
forall (t :: QTag) a. QualifiedWithTag t a -> a
tUnqualified Remote [RemoteMember]
rs
[RemoteMember]
-> (RemoteMember -> [(UserId, NonEmpty ClientId)])
-> [(UserId, NonEmpty ClientId)]
forall a b. [a] -> (a -> [b]) -> [b]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Maybe (UserId, NonEmpty ClientId) -> [(UserId, NonEmpty ClientId)]
forall a. Maybe a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Maybe (UserId, NonEmpty ClientId)
-> [(UserId, NonEmpty ClientId)])
-> (RemoteMember -> Maybe (UserId, NonEmpty ClientId))
-> RemoteMember
-> [(UserId, NonEmpty ClientId)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RemoteMember -> Maybe (UserId, NonEmpty ClientId)
remoteMemberMLSClients,
$sel:message:RemoteMLSMessage :: Base64ByteString
message = ByteString -> Base64ByteString
Base64ByteString RawMLS Message
msg.raw
}
where
cmWithoutSender :: ClientMap
cmWithoutSender = ClientMap -> (ClientId -> ClientMap) -> Maybe ClientId -> ClientMap
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ClientMap
cm ((ClientIdentity -> ClientMap -> ClientMap)
-> ClientMap -> ClientIdentity -> ClientMap
forall a b c. (a -> b -> c) -> b -> a -> c
flip ClientIdentity -> ClientMap -> ClientMap
cmRemoveClient ClientMap
cm (ClientIdentity -> ClientMap)
-> (ClientId -> ClientIdentity) -> ClientId -> ClientMap
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Qualified UserId -> ClientId -> ClientIdentity
mkClientIdentity Qualified UserId
qusr) Maybe ClientId
mSenderClient
localMemberRecipient :: Local x -> LocalMember -> Maybe Recipient
localMemberRecipient :: forall x. Local x -> LocalMember -> Maybe Recipient
localMemberRecipient Local x
loc LocalMember
lm = do
let localUserQId :: Qualified UserId
localUserQId = QualifiedWithTag 'QLocal UserId -> Qualified UserId
forall (t :: QTag) a. QualifiedWithTag t a -> Qualified a
tUntagged (Local x -> UserId -> QualifiedWithTag 'QLocal UserId
forall (t :: QTag) x a.
QualifiedWithTag t x -> a -> QualifiedWithTag t a
qualifyAs Local x
loc UserId
localUserId)
localUserId :: UserId
localUserId = LocalMember -> UserId
lmId LocalMember
lm
NonEmpty ClientId
clients <- [ClientId] -> Maybe (NonEmpty ClientId)
forall a. [a] -> Maybe (NonEmpty a)
nonEmpty ([ClientId] -> Maybe (NonEmpty ClientId))
-> [ClientId] -> Maybe (NonEmpty ClientId)
forall a b. (a -> b) -> a -> b
$ Map ClientId LeafIndex -> [ClientId]
forall k a. Map k a -> [k]
Map.keys (Map ClientId LeafIndex
-> Qualified UserId -> ClientMap -> Map ClientId LeafIndex
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault Map ClientId LeafIndex
forall a. Monoid a => a
mempty Qualified UserId
localUserQId ClientMap
cmWithoutSender)
Recipient -> Maybe Recipient
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Recipient -> Maybe Recipient) -> Recipient -> Maybe Recipient
forall a b. (a -> b) -> a -> b
$ UserId -> RecipientClients -> Recipient
Recipient UserId
localUserId (List1 ClientId -> RecipientClients
RecipientClientsSome (NonEmpty ClientId -> List1 ClientId
forall a. NonEmpty a -> List1 a
List1 NonEmpty ClientId
clients))
remoteMemberMLSClients :: RemoteMember -> Maybe (UserId, NonEmpty ClientId)
remoteMemberMLSClients :: RemoteMember -> Maybe (UserId, NonEmpty ClientId)
remoteMemberMLSClients RemoteMember
rm = do
let remoteUserQId :: Qualified UserId
remoteUserQId = QualifiedWithTag 'QRemote UserId -> Qualified UserId
forall (t :: QTag) a. QualifiedWithTag t a -> Qualified a
tUntagged (RemoteMember -> QualifiedWithTag 'QRemote UserId
rmId RemoteMember
rm)
remoteUserId :: UserId
remoteUserId = Qualified UserId -> UserId
forall a. Qualified a -> a
qUnqualified Qualified UserId
remoteUserQId
NonEmpty ClientId
clients <-
[ClientId] -> Maybe (NonEmpty ClientId)
forall a. [a] -> Maybe (NonEmpty a)
nonEmpty ([ClientId] -> Maybe (NonEmpty ClientId))
-> ([(ClientId, LeafIndex)] -> [ClientId])
-> [(ClientId, LeafIndex)]
-> Maybe (NonEmpty ClientId)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((ClientId, LeafIndex) -> ClientId)
-> [(ClientId, LeafIndex)] -> [ClientId]
forall a b. (a -> b) -> [a] -> [b]
map (ClientId, LeafIndex) -> ClientId
forall a b. (a, b) -> a
fst ([(ClientId, LeafIndex)] -> Maybe (NonEmpty ClientId))
-> [(ClientId, LeafIndex)] -> Maybe (NonEmpty ClientId)
forall a b. (a -> b) -> a -> b
$
Map ClientId LeafIndex -> [(ClientId, LeafIndex)]
forall k a. Map k a -> [(k, a)]
Map.assocs (Map ClientId LeafIndex
-> Qualified UserId -> ClientMap -> Map ClientId LeafIndex
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault Map ClientId LeafIndex
forall a. Monoid a => a
mempty Qualified UserId
remoteUserQId ClientMap
cmWithoutSender)
(UserId, NonEmpty ClientId) -> Maybe (UserId, NonEmpty ClientId)
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (UserId
remoteUserId, NonEmpty ClientId
clients)