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

-- | Propagate a message.
-- The message will not be propagated to the sender client if provided. This is
-- a requirement from Core Crypto and the clients.
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

  -- send to remotes
  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)