module Galley.API.Message
( UserType (..),
sendLocalMessages,
postQualifiedOtrMessage,
postBroadcast,
postRemoteOtrMessage,
legacyClientMismatchStrategy,
Unqualify (..),
userToProtectee,
MessageMetadata (..),
checkMessageClients,
QualifiedMismatch (..),
mkQualifiedUserClients,
clientMismatchStrategyApply,
collectFailedToSend,
)
where
import Control.Lens
import Data.Aeson (encode)
import Data.Bifunctor
import Data.ByteString.Conversion (toByteString')
import Data.Domain (Domain)
import Data.Id
import Data.Json.Util
import Data.Map qualified as Map
import Data.Map.Lens (toMapOf)
import Data.Qualified
import Data.Range
import Data.Set qualified as Set
import Data.Set.Lens
import Data.Time.Clock (UTCTime)
import Galley.API.LegalHold.Conflicts
import Galley.API.Push
import Galley.API.Util
import Galley.Data.Conversation
import Galley.Data.Services
import Galley.Effects
import Galley.Effects.BackendNotificationQueueAccess
import Galley.Effects.BrigAccess
import Galley.Effects.ClientStore
import Galley.Effects.ConversationStore
import Galley.Effects.FederatorAccess
import Galley.Effects.TeamStore
import Galley.Options
import Galley.Types.Clients qualified as Clients
import Galley.Types.Conversations.Members
import Imports hiding (forkIO)
import Network.AMQP qualified as Q
import Polysemy hiding (send)
import Polysemy.Error
import Polysemy.Input
import Polysemy.TinyLog qualified as P
import System.Logger.Class qualified as Log
import Wire.API.Conversation.Protocol
import Wire.API.Error
import Wire.API.Error.Galley
import Wire.API.Event.Conversation
import Wire.API.Federation.API
import Wire.API.Federation.API.Brig
import Wire.API.Federation.API.Galley
import Wire.API.Federation.Client (FederatorClient)
import Wire.API.Federation.Error
import Wire.API.Message
import Wire.API.Routes.Public.Galley.Messaging
import Wire.API.Team.LegalHold
import Wire.API.Team.Member
import Wire.API.User.Client
import Wire.API.UserMap (UserMap (..))
import Wire.NotificationSubsystem (NotificationSubsystem)
data UserType = User | Bot
userToProtectee :: UserType -> UserId -> LegalholdProtectee
userToProtectee :: UserType -> UserId -> LegalholdProtectee
userToProtectee UserType
User UserId
user = UserId -> LegalholdProtectee
ProtectedUser UserId
user
userToProtectee UserType
Bot UserId
_ = LegalholdProtectee
UnprotectedBot
qualifiedUserToProtectee ::
Domain ->
UserType ->
Qualified UserId ->
LegalholdProtectee
qualifiedUserToProtectee :: Domain -> UserType -> Qualified UserId -> LegalholdProtectee
qualifiedUserToProtectee Domain
localDomain UserType
ty Qualified UserId
user
| Qualified UserId -> Domain
forall a. Qualified a -> Domain
qDomain Qualified UserId
user Domain -> Domain -> Bool
forall a. Eq a => a -> a -> Bool
== Domain
localDomain = UserType -> UserId -> LegalholdProtectee
userToProtectee UserType
ty (Qualified UserId -> UserId
forall a. Qualified a -> a
qUnqualified Qualified UserId
user)
| Bool
otherwise = LegalholdProtectee
LegalholdPlusFederationNotImplemented
data QualifiedMismatch = QualifiedMismatch
{ QualifiedMismatch -> QualifiedUserClients
qmMissing :: QualifiedUserClients,
QualifiedMismatch -> QualifiedUserClients
qmRedundant :: QualifiedUserClients,
QualifiedMismatch -> QualifiedUserClients
qmDeleted :: QualifiedUserClients
}
deriving (Int -> QualifiedMismatch -> ShowS
[QualifiedMismatch] -> ShowS
QualifiedMismatch -> String
(Int -> QualifiedMismatch -> ShowS)
-> (QualifiedMismatch -> String)
-> ([QualifiedMismatch] -> ShowS)
-> Show QualifiedMismatch
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> QualifiedMismatch -> ShowS
showsPrec :: Int -> QualifiedMismatch -> ShowS
$cshow :: QualifiedMismatch -> String
show :: QualifiedMismatch -> String
$cshowList :: [QualifiedMismatch] -> ShowS
showList :: [QualifiedMismatch] -> ShowS
Show, QualifiedMismatch -> QualifiedMismatch -> Bool
(QualifiedMismatch -> QualifiedMismatch -> Bool)
-> (QualifiedMismatch -> QualifiedMismatch -> Bool)
-> Eq QualifiedMismatch
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: QualifiedMismatch -> QualifiedMismatch -> Bool
== :: QualifiedMismatch -> QualifiedMismatch -> Bool
$c/= :: QualifiedMismatch -> QualifiedMismatch -> Bool
/= :: QualifiedMismatch -> QualifiedMismatch -> Bool
Eq)
type QualifiedRecipientSet = Set (Domain, UserId, ClientId)
type RecipientSet = Set (UserId, ClientId)
mkQualifiedMismatch ::
QualifiedRecipientSet -> QualifiedRecipientSet -> QualifiedRecipientSet -> QualifiedMismatch
mkQualifiedMismatch :: QualifiedRecipientSet
-> QualifiedRecipientSet
-> QualifiedRecipientSet
-> QualifiedMismatch
mkQualifiedMismatch QualifiedRecipientSet
missing QualifiedRecipientSet
redundant QualifiedRecipientSet
deleted =
QualifiedUserClients
-> QualifiedUserClients
-> QualifiedUserClients
-> QualifiedMismatch
QualifiedMismatch
(QualifiedRecipientSet -> QualifiedUserClients
mkQualifiedUserClients QualifiedRecipientSet
missing)
(QualifiedRecipientSet -> QualifiedUserClients
mkQualifiedUserClients QualifiedRecipientSet
redundant)
(QualifiedRecipientSet -> QualifiedUserClients
mkQualifiedUserClients QualifiedRecipientSet
deleted)
mkQualifiedUserClients :: QualifiedRecipientSet -> QualifiedUserClients
mkQualifiedUserClients :: QualifiedRecipientSet -> QualifiedUserClients
mkQualifiedUserClients =
Map Domain (Map UserId (Set ClientId)) -> QualifiedUserClients
QualifiedUserClients
(Map Domain (Map UserId (Set ClientId)) -> QualifiedUserClients)
-> (QualifiedRecipientSet
-> Map Domain (Map UserId (Set ClientId)))
-> QualifiedRecipientSet
-> QualifiedUserClients
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Domain, UserId, ClientId)
-> Map Domain (Map UserId (Set ClientId))
-> Map Domain (Map UserId (Set ClientId)))
-> Map Domain (Map UserId (Set ClientId))
-> QualifiedRecipientSet
-> Map Domain (Map UserId (Set ClientId))
forall a b. (a -> b -> b) -> b -> Set a -> b
Set.foldr (\(Domain
d, UserId
u, ClientId
c) -> (Map UserId (Set ClientId)
-> Map UserId (Set ClientId) -> Map UserId (Set ClientId))
-> Domain
-> Map UserId (Set ClientId)
-> Map Domain (Map UserId (Set ClientId))
-> Map Domain (Map UserId (Set ClientId))
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith ((Set ClientId -> Set ClientId -> Set ClientId)
-> Map UserId (Set ClientId)
-> Map UserId (Set ClientId)
-> Map UserId (Set ClientId)
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith Set ClientId -> Set ClientId -> Set ClientId
forall a. Ord a => Set a -> Set a -> Set a
Set.union) Domain
d (UserId -> Set ClientId -> Map UserId (Set ClientId)
forall k a. k -> a -> Map k a
Map.singleton UserId
u (ClientId -> Set ClientId
forall a. a -> Set a
Set.singleton ClientId
c))) Map Domain (Map UserId (Set ClientId))
forall k a. Map k a
Map.empty
mkQualifiedUserClientsByDomain :: Map Domain RecipientSet -> QualifiedUserClients
mkQualifiedUserClientsByDomain :: Map Domain RecipientSet -> QualifiedUserClients
mkQualifiedUserClientsByDomain =
Map Domain (Map UserId (Set ClientId)) -> QualifiedUserClients
QualifiedUserClients
(Map Domain (Map UserId (Set ClientId)) -> QualifiedUserClients)
-> (Map Domain RecipientSet
-> Map Domain (Map UserId (Set ClientId)))
-> Map Domain RecipientSet
-> QualifiedUserClients
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map UserId (Set ClientId) -> Bool)
-> Map Domain (Map UserId (Set ClientId))
-> Map Domain (Map UserId (Set ClientId))
forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter (Bool -> Bool
not (Bool -> Bool)
-> (Map UserId (Set ClientId) -> Bool)
-> Map UserId (Set ClientId)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map UserId (Set ClientId) -> Bool
forall k a. Map k a -> Bool
Map.null)
(Map Domain (Map UserId (Set ClientId))
-> Map Domain (Map UserId (Set ClientId)))
-> (Map Domain RecipientSet
-> Map Domain (Map UserId (Set ClientId)))
-> Map Domain RecipientSet
-> Map Domain (Map UserId (Set ClientId))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (RecipientSet -> Map UserId (Set ClientId))
-> Map Domain RecipientSet
-> Map Domain (Map UserId (Set ClientId))
forall a b. (a -> b) -> Map Domain a -> Map Domain b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap RecipientSet -> Map UserId (Set ClientId)
byUser
where
byUser :: RecipientSet -> Map UserId (Set ClientId)
byUser :: RecipientSet -> Map UserId (Set ClientId)
byUser = ((UserId, ClientId)
-> Map UserId (Set ClientId) -> Map UserId (Set ClientId))
-> Map UserId (Set ClientId)
-> RecipientSet
-> Map UserId (Set ClientId)
forall a b. (a -> b -> b) -> b -> Set a -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\(UserId
u, ClientId
c) -> (Set ClientId -> Set ClientId -> Set ClientId)
-> UserId
-> Set ClientId
-> Map UserId (Set ClientId)
-> Map UserId (Set ClientId)
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith Set ClientId -> Set ClientId -> Set ClientId
forall a. Semigroup a => a -> a -> a
(<>) UserId
u (ClientId -> Set ClientId
forall a. a -> Set a
Set.singleton ClientId
c)) Map UserId (Set ClientId)
forall a. Monoid a => a
mempty
mkMessageSendingStatus :: UTCTimeMillis -> QualifiedMismatch -> MessageSendingStatus
mkMessageSendingStatus :: UTCTimeMillis -> QualifiedMismatch -> MessageSendingStatus
mkMessageSendingStatus UTCTimeMillis
time QualifiedMismatch
mismatch =
MessageSendingStatus
{ $sel:mssTime:MessageSendingStatus :: UTCTimeMillis
mssTime = UTCTimeMillis
time,
$sel:mssMissingClients:MessageSendingStatus :: QualifiedUserClients
mssMissingClients = QualifiedMismatch -> QualifiedUserClients
qmMissing QualifiedMismatch
mismatch,
$sel:mssRedundantClients:MessageSendingStatus :: QualifiedUserClients
mssRedundantClients = QualifiedMismatch -> QualifiedUserClients
qmRedundant QualifiedMismatch
mismatch,
$sel:mssDeletedClients:MessageSendingStatus :: QualifiedUserClients
mssDeletedClients = QualifiedMismatch -> QualifiedUserClients
qmDeleted QualifiedMismatch
mismatch,
$sel:mssFailedToSend:MessageSendingStatus :: QualifiedUserClients
mssFailedToSend = QualifiedUserClients
forall a. Monoid a => a
mempty,
$sel:mssFailedToConfirmClients:MessageSendingStatus :: QualifiedUserClients
mssFailedToConfirmClients = QualifiedUserClients
forall a. Monoid a => a
mempty
}
clientMismatchStrategyApply :: ClientMismatchStrategy -> QualifiedRecipientSet -> QualifiedRecipientSet
clientMismatchStrategyApply :: ClientMismatchStrategy
-> QualifiedRecipientSet -> QualifiedRecipientSet
clientMismatchStrategyApply ClientMismatchStrategy
MismatchReportAll = QualifiedRecipientSet -> QualifiedRecipientSet
forall a. a -> a
Imports.id
clientMismatchStrategyApply ClientMismatchStrategy
MismatchIgnoreAll = QualifiedRecipientSet
-> QualifiedRecipientSet -> QualifiedRecipientSet
forall a b. a -> b -> a
const QualifiedRecipientSet
forall a. Monoid a => a
mempty
clientMismatchStrategyApply (MismatchReportOnly Set (Qualified UserId)
users) =
((Domain, UserId, ClientId) -> Bool)
-> QualifiedRecipientSet -> QualifiedRecipientSet
forall a. (a -> Bool) -> Set a -> Set a
Set.filter (\(Domain
d, UserId
u, ClientId
_) -> Qualified UserId -> Set (Qualified UserId) -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member (UserId -> Domain -> Qualified UserId
forall a. a -> Domain -> Qualified a
Qualified UserId
u Domain
d) Set (Qualified UserId)
users)
clientMismatchStrategyApply (MismatchIgnoreOnly Set (Qualified UserId)
users) =
((Domain, UserId, ClientId) -> Bool)
-> QualifiedRecipientSet -> QualifiedRecipientSet
forall a. (a -> Bool) -> Set a -> Set a
Set.filter (\(Domain
d, UserId
u, ClientId
_) -> Bool -> Bool
not (Qualified UserId -> Set (Qualified UserId) -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member (UserId -> Domain -> Qualified UserId
forall a. a -> Domain -> Qualified a
Qualified UserId
u Domain
d) Set (Qualified UserId)
users))
checkMessageClients ::
(Domain, UserId, ClientId) ->
Map (Domain, UserId) (Set ClientId) ->
Map (Domain, UserId, ClientId) ByteString ->
ClientMismatchStrategy ->
(Bool, Map (Domain, UserId, ClientId) ByteString, QualifiedMismatch)
checkMessageClients :: (Domain, UserId, ClientId)
-> Map (Domain, UserId) (Set ClientId)
-> Map (Domain, UserId, ClientId) ByteString
-> ClientMismatchStrategy
-> (Bool, Map (Domain, UserId, ClientId) ByteString,
QualifiedMismatch)
checkMessageClients (Domain, UserId, ClientId)
sender Map (Domain, UserId) (Set ClientId)
participantMap Map (Domain, UserId, ClientId) ByteString
recipientMap ClientMismatchStrategy
mismatchStrat =
let participants :: QualifiedRecipientSet
participants = Getting
QualifiedRecipientSet
(Map (Domain, UserId) (Set ClientId))
(Domain, UserId, ClientId)
-> Map (Domain, UserId) (Set ClientId) -> QualifiedRecipientSet
forall a s. Getting (Set a) s a -> s -> Set a
setOf ((Indexed
(Domain, UserId)
(Set ClientId)
(Const QualifiedRecipientSet (Set ClientId))
-> Map (Domain, UserId) (Set ClientId)
-> Const
QualifiedRecipientSet (Map (Domain, UserId) (Set ClientId))
forall i (t :: * -> *) a b.
TraversableWithIndex i t =>
IndexedTraversal i (t a) (t b) a b
IndexedTraversal
(Domain, UserId)
(Map (Domain, UserId) (Set ClientId))
(Map (Domain, UserId) (Set ClientId))
(Set ClientId)
(Set ClientId)
itraversed (Indexed
(Domain, UserId)
(Set ClientId)
(Const QualifiedRecipientSet (Set ClientId))
-> Map (Domain, UserId) (Set ClientId)
-> Const
QualifiedRecipientSet (Map (Domain, UserId) (Set ClientId)))
-> ((ClientId -> Const QualifiedRecipientSet ClientId)
-> Set ClientId -> Const QualifiedRecipientSet (Set ClientId))
-> Indexed
(Domain, UserId) ClientId (Const QualifiedRecipientSet ClientId)
-> Map (Domain, UserId) (Set ClientId)
-> Const
QualifiedRecipientSet (Map (Domain, UserId) (Set ClientId))
forall i (p :: * -> * -> *) s t r a b.
Indexable i p =>
(Indexed i s t -> r) -> ((a -> b) -> s -> t) -> p a b -> r
<. (ClientId -> Const QualifiedRecipientSet ClientId)
-> Set ClientId -> Const QualifiedRecipientSet (Set ClientId)
forall (f :: * -> *) a. Foldable f => IndexedFold Int (f a) a
IndexedFold Int (Set ClientId) ClientId
folded) (Indexed
(Domain, UserId) ClientId (Const QualifiedRecipientSet ClientId)
-> Map (Domain, UserId) (Set ClientId)
-> Const
QualifiedRecipientSet (Map (Domain, UserId) (Set ClientId)))
-> (((Domain, UserId, ClientId)
-> Const QualifiedRecipientSet (Domain, UserId, ClientId))
-> Indexed
(Domain, UserId) ClientId (Const QualifiedRecipientSet ClientId))
-> Getting
QualifiedRecipientSet
(Map (Domain, UserId) (Set ClientId))
(Domain, UserId, ClientId)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (((Domain, UserId), ClientId)
-> Const QualifiedRecipientSet ((Domain, UserId), ClientId))
-> Indexed
(Domain, UserId) ClientId (Const QualifiedRecipientSet ClientId)
forall i (p :: * -> * -> *) (f :: * -> *) s j t.
(Indexable i p, Functor f) =>
p (i, s) (f (j, t)) -> Indexed i s (f t)
withIndex ((((Domain, UserId), ClientId)
-> Const QualifiedRecipientSet ((Domain, UserId), ClientId))
-> Indexed
(Domain, UserId) ClientId (Const QualifiedRecipientSet ClientId))
-> (((Domain, UserId, ClientId)
-> Const QualifiedRecipientSet (Domain, UserId, ClientId))
-> ((Domain, UserId), ClientId)
-> Const QualifiedRecipientSet ((Domain, UserId), ClientId))
-> ((Domain, UserId, ClientId)
-> Const QualifiedRecipientSet (Domain, UserId, ClientId))
-> Indexed
(Domain, UserId) ClientId (Const QualifiedRecipientSet ClientId)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (((Domain, UserId), ClientId) -> (Domain, UserId, ClientId))
-> ((Domain, UserId, ClientId)
-> Const QualifiedRecipientSet (Domain, UserId, ClientId))
-> ((Domain, UserId), ClientId)
-> Const QualifiedRecipientSet ((Domain, UserId), ClientId)
forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
Control.Lens.to (\((Domain
d, UserId
u), ClientId
c) -> (Domain
d, UserId
u, ClientId
c))) Map (Domain, UserId) (Set ClientId)
participantMap
expected :: QualifiedRecipientSet
expected = (Domain, UserId, ClientId)
-> QualifiedRecipientSet -> QualifiedRecipientSet
forall a. Ord a => a -> Set a -> Set a
Set.delete (Domain, UserId, ClientId)
sender QualifiedRecipientSet
participants
Set (Domain, UserId)
expectedUsers :: Set (Domain, UserId) = Map (Domain, UserId) (Set ClientId) -> Set (Domain, UserId)
forall k a. Map k a -> Set k
Map.keysSet Map (Domain, UserId) (Set ClientId)
participantMap
recipients :: QualifiedRecipientSet
recipients = Map (Domain, UserId, ClientId) ByteString -> QualifiedRecipientSet
forall k a. Map k a -> Set k
Map.keysSet Map (Domain, UserId, ClientId) ByteString
recipientMap
missing :: QualifiedRecipientSet
missing = QualifiedRecipientSet
-> QualifiedRecipientSet -> QualifiedRecipientSet
forall a. Ord a => Set a -> Set a -> Set a
Set.difference QualifiedRecipientSet
expected QualifiedRecipientSet
recipients
extra :: QualifiedRecipientSet
extra = QualifiedRecipientSet
-> QualifiedRecipientSet -> QualifiedRecipientSet
forall a. Ord a => Set a -> Set a -> Set a
Set.difference QualifiedRecipientSet
recipients QualifiedRecipientSet
expected
deleted :: QualifiedRecipientSet
deleted =
(Domain, UserId, ClientId)
-> QualifiedRecipientSet -> QualifiedRecipientSet
forall a. Ord a => a -> Set a -> Set a
Set.delete (Domain, UserId, ClientId)
sender
(QualifiedRecipientSet -> QualifiedRecipientSet)
-> (QualifiedRecipientSet -> QualifiedRecipientSet)
-> QualifiedRecipientSet
-> QualifiedRecipientSet
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Domain, UserId, ClientId) -> Bool)
-> QualifiedRecipientSet -> QualifiedRecipientSet
forall a. (a -> Bool) -> Set a -> Set a
Set.filter (\(Domain
d, UserId
u, ClientId
_) -> (Domain, UserId) -> Set (Domain, UserId) -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member (Domain
d, UserId
u) Set (Domain, UserId)
expectedUsers)
(QualifiedRecipientSet -> QualifiedRecipientSet)
-> QualifiedRecipientSet -> QualifiedRecipientSet
forall a b. (a -> b) -> a -> b
$ QualifiedRecipientSet
extra
redundant :: QualifiedRecipientSet
redundant = QualifiedRecipientSet
-> QualifiedRecipientSet -> QualifiedRecipientSet
forall a. Ord a => Set a -> Set a -> Set a
Set.difference QualifiedRecipientSet
extra QualifiedRecipientSet
deleted
valid :: QualifiedRecipientSet
valid = QualifiedRecipientSet
-> QualifiedRecipientSet -> QualifiedRecipientSet
forall a. Ord a => Set a -> Set a -> Set a
Set.intersection QualifiedRecipientSet
recipients QualifiedRecipientSet
expected
validMap :: Map (Domain, UserId, ClientId) ByteString
validMap = Map (Domain, UserId, ClientId) ByteString
-> QualifiedRecipientSet
-> Map (Domain, UserId, ClientId) ByteString
forall k a. Ord k => Map k a -> Set k -> Map k a
Map.restrictKeys Map (Domain, UserId, ClientId) ByteString
recipientMap QualifiedRecipientSet
valid
reportedMissing :: QualifiedRecipientSet
reportedMissing = ClientMismatchStrategy
-> QualifiedRecipientSet -> QualifiedRecipientSet
clientMismatchStrategyApply ClientMismatchStrategy
mismatchStrat QualifiedRecipientSet
missing
in ( QualifiedRecipientSet -> Bool
forall a. Set a -> Bool
Set.null QualifiedRecipientSet
reportedMissing,
Map (Domain, UserId, ClientId) ByteString
validMap,
QualifiedRecipientSet
-> QualifiedRecipientSet
-> QualifiedRecipientSet
-> QualifiedMismatch
mkQualifiedMismatch QualifiedRecipientSet
reportedMissing QualifiedRecipientSet
redundant QualifiedRecipientSet
deleted
)
getRemoteClients ::
(Member FederatorAccess r) =>
[RemoteMember] ->
Sem r [Either (Remote [UserId], FederationError) (Map (Domain, UserId) (Set ClientId))]
getRemoteClients :: forall (r :: EffectRow).
Member FederatorAccess r =>
[RemoteMember]
-> Sem
r
[Either
(Remote [UserId], FederationError)
(Map (Domain, UserId) (Set ClientId))]
getRemoteClients [RemoteMember]
remoteMembers =
QualifiedWithTag 'QRemote (Map (Domain, UserId) (Set ClientId))
-> Map (Domain, UserId) (Set ClientId)
forall (t :: QTag) a. QualifiedWithTag t a -> a
tUnqualified (QualifiedWithTag 'QRemote (Map (Domain, UserId) (Set ClientId))
-> Map (Domain, UserId) (Set ClientId))
-> Sem
r
[Either
(Remote [UserId], FederationError)
(QualifiedWithTag 'QRemote (Map (Domain, UserId) (Set ClientId)))]
-> Sem
r
[Either
(Remote [UserId], FederationError)
(Map (Domain, UserId) (Set ClientId))]
forall (f :: * -> *) (g :: * -> *) (h :: * -> *) a b.
(Functor f, Functor g, Functor h) =>
(a -> b) -> f (g (h a)) -> f (g (h b))
<$$$> [Remote UserId]
-> (Remote [UserId]
-> FederatorClient 'Brig (Map (Domain, UserId) (Set ClientId)))
-> Sem
r
[Either
(Remote [UserId], FederationError)
(QualifiedWithTag 'QRemote (Map (Domain, UserId) (Set ClientId)))]
forall (r :: EffectRow) (c :: Component) (f :: * -> *) x a.
(Member FederatorAccess r, KnownComponent c, Foldable f,
Functor f) =>
f (Remote x)
-> (Remote [x] -> FederatorClient c a)
-> Sem r [Either (Remote [x], FederationError) (Remote a)]
runFederatedConcurrentlyEither ((RemoteMember -> Remote UserId)
-> [RemoteMember] -> [Remote UserId]
forall a b. (a -> b) -> [a] -> [b]
map RemoteMember -> Remote UserId
rmId [RemoteMember]
remoteMembers) Remote [UserId]
-> FederatorClient 'Brig (Map (Domain, UserId) (Set ClientId))
getRemoteClientsFromDomain
where
getRemoteClientsFromDomain :: Remote [UserId] -> FederatorClient 'Brig (Map (Domain, UserId) (Set ClientId))
getRemoteClientsFromDomain :: Remote [UserId]
-> FederatorClient 'Brig (Map (Domain, UserId) (Set ClientId))
getRemoteClientsFromDomain (Remote [UserId] -> Qualified [UserId]
forall (t :: QTag) a. QualifiedWithTag t a -> Qualified a
tUntagged -> Qualified [UserId]
uids Domain
domain) =
(UserId -> (Domain, UserId))
-> Map UserId (Set ClientId) -> Map (Domain, UserId) (Set ClientId)
forall k2 k1 a. Ord k2 => (k1 -> k2) -> Map k1 a -> Map k2 a
Map.mapKeys (Domain
domain,) (Map UserId (Set ClientId) -> Map (Domain, UserId) (Set ClientId))
-> (UserMap (Set PubClient) -> Map UserId (Set ClientId))
-> UserMap (Set PubClient)
-> Map (Domain, UserId) (Set ClientId)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Set PubClient -> Set ClientId)
-> Map UserId (Set PubClient) -> Map UserId (Set ClientId)
forall a b. (a -> b) -> Map UserId a -> Map UserId b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((PubClient -> ClientId) -> Set PubClient -> Set ClientId
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map PubClient -> ClientId
pubClientId) (Map UserId (Set PubClient) -> Map UserId (Set ClientId))
-> (UserMap (Set PubClient) -> Map UserId (Set PubClient))
-> UserMap (Set PubClient)
-> Map UserId (Set ClientId)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UserMap (Set PubClient) -> Map UserId (Set PubClient)
forall a. UserMap a -> Map UserId a
userMap
(UserMap (Set PubClient) -> Map (Domain, UserId) (Set ClientId))
-> FederatorClient 'Brig (UserMap (Set PubClient))
-> FederatorClient 'Brig (Map (Domain, UserId) (Set ClientId))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall {k} (comp :: Component) (name :: k)
(fedM :: Component -> * -> *) (showcomp :: Symbol) api.
(showcomp ~ ShowComponent comp, HasFedEndpoint comp api name,
HasClient (fedM comp) api, KnownComponent comp, IsNamed name,
FederationMonad fedM, Typeable (Client (fedM comp) api)) =>
Client (fedM comp) api
forall (comp :: Component) (name :: Symbol)
(fedM :: Component -> * -> *) (showcomp :: Symbol) api.
(showcomp ~ ShowComponent comp, HasFedEndpoint comp api name,
HasClient (fedM comp) api, KnownComponent comp, IsNamed name,
FederationMonad fedM, Typeable (Client (fedM comp) api)) =>
Client (fedM comp) api
fedClient @'Brig @"get-user-clients" ([UserId] -> GetUserClients
GetUserClients [UserId]
uids)
postRemoteOtrMessage ::
(Member FederatorAccess r) =>
Local UserId ->
Remote ConvId ->
ByteString ->
Sem r (PostOtrResponse MessageSendingStatus)
postRemoteOtrMessage :: forall (r :: EffectRow).
Member FederatorAccess r =>
Local UserId
-> Remote ConvId
-> ByteString
-> Sem r (PostOtrResponse MessageSendingStatus)
postRemoteOtrMessage Local UserId
sender Remote ConvId
conv ByteString
rawMsg = do
let msr :: ProteusMessageSendRequest
msr =
ProteusMessageSendRequest
{ $sel:convId:ProteusMessageSendRequest :: ConvId
convId = Remote ConvId -> ConvId
forall (t :: QTag) a. QualifiedWithTag t a -> a
tUnqualified Remote ConvId
conv,
$sel:sender:ProteusMessageSendRequest :: UserId
sender = Qualified UserId -> UserId
forall a. Qualified a -> a
qUnqualified (Local UserId -> Qualified UserId
forall (t :: QTag) a. QualifiedWithTag t a -> Qualified a
tUntagged Local UserId
sender),
$sel:rawMessage:ProteusMessageSendRequest :: Base64ByteString
rawMessage = ByteString -> Base64ByteString
Base64ByteString ByteString
rawMsg
}
rpc :: FederatorClient 'Galley MessageSendResponse
rpc = forall {k} (comp :: Component) (name :: k)
(fedM :: Component -> * -> *) (showcomp :: Symbol) api.
(showcomp ~ ShowComponent comp, HasFedEndpoint comp api name,
HasClient (fedM comp) api, KnownComponent comp, IsNamed name,
FederationMonad fedM, Typeable (Client (fedM comp) api)) =>
Client (fedM comp) api
forall (comp :: Component) (name :: Symbol)
(fedM :: Component -> * -> *) (showcomp :: Symbol) api.
(showcomp ~ ShowComponent comp, HasFedEndpoint comp api name,
HasClient (fedM comp) api, KnownComponent comp, IsNamed name,
FederationMonad fedM, Typeable (Client (fedM comp) api)) =>
Client (fedM comp) api
fedClient @'Galley @"send-message" ProteusMessageSendRequest
msr
(.response) (MessageSendResponse -> PostOtrResponse MessageSendingStatus)
-> Sem r MessageSendResponse
-> Sem r (PostOtrResponse MessageSendingStatus)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Remote ConvId
-> FederatorClient 'Galley MessageSendResponse
-> Sem r MessageSendResponse
forall (r :: EffectRow) (c :: Component) x a.
(Member FederatorAccess r, KnownComponent c) =>
Remote x -> FederatorClient c a -> Sem r a
runFederated Remote ConvId
conv FederatorClient 'Galley MessageSendResponse
rpc
postBroadcast ::
( Member BrigAccess r,
Member ClientStore r,
Member (ErrorS 'TeamNotFound) r,
Member (ErrorS 'NonBindingTeam) r,
Member (ErrorS 'BroadcastLimitExceeded) r,
Member ExternalAccess r,
Member (Input Opts) r,
Member (Input UTCTime) r,
Member TeamStore r,
Member P.TinyLog r,
Member NotificationSubsystem r
) =>
Local UserId ->
Maybe ConnId ->
QualifiedNewOtrMessage ->
Sem r (PostOtrResponse MessageSendingStatus)
postBroadcast :: forall (r :: EffectRow).
(Member BrigAccess r, Member ClientStore r,
Member (ErrorS 'TeamNotFound) r, Member (ErrorS 'NonBindingTeam) r,
Member (ErrorS 'BroadcastLimitExceeded) r, Member ExternalAccess r,
Member (Input Opts) r, Member (Input UTCTime) r,
Member TeamStore r, Member TinyLog r,
Member NotificationSubsystem r) =>
Local UserId
-> Maybe ConnId
-> QualifiedNewOtrMessage
-> Sem r (PostOtrResponse MessageSendingStatus)
postBroadcast Local UserId
lusr Maybe ConnId
con QualifiedNewOtrMessage
msg = Sem
(Error (MessageNotSent MessageSendingStatus) : r)
MessageSendingStatus
-> Sem r (PostOtrResponse MessageSendingStatus)
forall e (r :: EffectRow) a.
Sem (Error e : r) a -> Sem r (Either e a)
runError (Sem
(Error (MessageNotSent MessageSendingStatus) : r)
MessageSendingStatus
-> Sem r (PostOtrResponse MessageSendingStatus))
-> Sem
(Error (MessageNotSent MessageSendingStatus) : r)
MessageSendingStatus
-> Sem r (PostOtrResponse MessageSendingStatus)
forall a b. (a -> b) -> a -> b
$ do
let senderClient :: ClientId
senderClient = QualifiedNewOtrMessage -> ClientId
qualifiedNewOtrSender QualifiedNewOtrMessage
msg
senderDomain :: Domain
senderDomain = Local UserId -> Domain
forall (t :: QTag) a. QualifiedWithTag t a -> Domain
tDomain Local UserId
lusr
senderUser :: UserId
senderUser = Local UserId -> UserId
forall (t :: QTag) a. QualifiedWithTag t a -> a
tUnqualified Local UserId
lusr
rcps :: Map UserId (Map ClientId ByteString)
rcps =
Map UserId (Map ClientId ByteString)
-> Domain
-> Map Domain (Map UserId (Map ClientId ByteString))
-> Map UserId (Map ClientId ByteString)
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault Map UserId (Map ClientId ByteString)
forall a. Monoid a => a
mempty Domain
senderDomain
(Map Domain (Map UserId (Map ClientId ByteString))
-> Map UserId (Map ClientId ByteString))
-> (QualifiedNewOtrMessage
-> Map Domain (Map UserId (Map ClientId ByteString)))
-> QualifiedNewOtrMessage
-> Map UserId (Map ClientId ByteString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QualifiedUserClientMap ByteString
-> Map Domain (Map UserId (Map ClientId ByteString))
forall a.
QualifiedUserClientMap a
-> Map Domain (Map UserId (Map ClientId a))
qualifiedUserClientMap
(QualifiedUserClientMap ByteString
-> Map Domain (Map UserId (Map ClientId ByteString)))
-> (QualifiedNewOtrMessage -> QualifiedUserClientMap ByteString)
-> QualifiedNewOtrMessage
-> Map Domain (Map UserId (Map ClientId ByteString))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QualifiedOtrRecipients -> QualifiedUserClientMap ByteString
qualifiedOtrRecipientsMap
(QualifiedOtrRecipients -> QualifiedUserClientMap ByteString)
-> (QualifiedNewOtrMessage -> QualifiedOtrRecipients)
-> QualifiedNewOtrMessage
-> QualifiedUserClientMap ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QualifiedNewOtrMessage -> QualifiedOtrRecipients
qualifiedNewOtrRecipients
(QualifiedNewOtrMessage -> Map UserId (Map ClientId ByteString))
-> QualifiedNewOtrMessage -> Map UserId (Map ClientId ByteString)
forall a b. (a -> b) -> a -> b
$ QualifiedNewOtrMessage
msg
UTCTime
now <- Sem (Error (MessageNotSent MessageSendingStatus) : r) UTCTime
forall i (r :: EffectRow). Member (Input i) r => Sem r i
input
TeamId
tid <- UserId
-> Sem (Error (MessageNotSent MessageSendingStatus) : r) TeamId
forall (r :: EffectRow).
(Member (ErrorS 'TeamNotFound) r,
Member (ErrorS 'NonBindingTeam) r, Member TeamStore r) =>
UserId -> Sem r TeamId
lookupBindingTeam UserId
senderUser
Int
limit <- Int32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int32 -> Int)
-> (Range 1 HardTruncationLimit Int32 -> Int32)
-> Range 1 HardTruncationLimit Int32
-> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Range 1 HardTruncationLimit Int32 -> Int32
forall (n :: Nat) (m :: Nat) a. Range n m a -> a
fromRange (Range 1 HardTruncationLimit Int32 -> Int)
-> Sem
(Error (MessageNotSent MessageSendingStatus) : r)
(Range 1 HardTruncationLimit Int32)
-> Sem (Error (MessageNotSent MessageSendingStatus) : r) Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Sem
(Error (MessageNotSent MessageSendingStatus) : r)
(Range 1 HardTruncationLimit Int32)
forall (r :: EffectRow).
Member TeamStore r =>
Sem r (Range 1 HardTruncationLimit Int32)
fanoutLimit
Bool
-> Sem (Error (MessageNotSent MessageSendingStatus) : r) ()
-> Sem (Error (MessageNotSent MessageSendingStatus) : r) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Map UserId (Map ClientId ByteString) -> Int
forall k a. Map k a -> Int
Map.size Map UserId (Map ClientId ByteString)
rcps Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
limit) (Sem (Error (MessageNotSent MessageSendingStatus) : r) ()
-> Sem (Error (MessageNotSent MessageSendingStatus) : r) ())
-> Sem (Error (MessageNotSent MessageSendingStatus) : r) ()
-> Sem (Error (MessageNotSent MessageSendingStatus) : 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 @'BroadcastLimitExceeded
[UserId]
tMembers <-
(TeamMember -> UserId) -> [TeamMember] -> [UserId]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Getting UserId TeamMember UserId -> TeamMember -> UserId
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting UserId TeamMember UserId
Lens' TeamMember UserId
Wire.API.Team.Member.userId) ([TeamMember] -> [UserId])
-> Sem
(Error (MessageNotSent MessageSendingStatus) : r) [TeamMember]
-> Sem (Error (MessageNotSent MessageSendingStatus) : r) [UserId]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> case QualifiedNewOtrMessage -> ClientMismatchStrategy
qualifiedNewOtrClientMismatchStrategy QualifiedNewOtrMessage
msg of
MismatchReportOnly Set (Qualified UserId)
qus ->
Int
-> TeamId
-> [UserId]
-> Map UserId (Map ClientId ByteString)
-> Sem
(Error (MessageNotSent MessageSendingStatus) : r) [TeamMember]
forall (r :: EffectRow).
(Member (ErrorS 'BroadcastLimitExceeded) r, Member TeamStore r) =>
Int
-> TeamId
-> [UserId]
-> Map UserId (Map ClientId ByteString)
-> Sem r [TeamMember]
maybeFetchLimitedTeamMemberList
Int
limit
TeamId
tid
(([UserId], [Remote UserId]) -> [UserId]
forall a b. (a, b) -> a
fst (Local UserId
-> Set (Qualified UserId) -> ([UserId], [Remote UserId])
forall (f :: * -> *) x a.
Foldable f =>
Local x -> f (Qualified a) -> ([a], [Remote a])
partitionQualified Local UserId
lusr Set (Qualified UserId)
qus))
Map UserId (Map ClientId ByteString)
rcps
ClientMismatchStrategy
_ -> TeamId
-> Sem
(Error (MessageNotSent MessageSendingStatus) : r) [TeamMember]
forall (r :: EffectRow).
(Member (ErrorS 'BroadcastLimitExceeded) r, Member TeamStore r) =>
TeamId -> Sem r [TeamMember]
maybeFetchAllMembersInTeam TeamId
tid
[UserId]
contacts <- UserId
-> Sem (Error (MessageNotSent MessageSendingStatus) : r) [UserId]
forall (r :: EffectRow).
Member BrigAccess r =>
UserId -> Sem r [UserId]
getContactList UserId
senderUser
let users :: [UserId]
users = Set UserId -> [UserId]
forall a. Set a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Set UserId -> [UserId]) -> Set UserId -> [UserId]
forall a b. (a -> b) -> a -> b
$ Set UserId -> Set UserId -> Set UserId
forall a. Ord a => Set a -> Set a -> Set a
Set.union ([UserId] -> Set UserId
forall a. Ord a => [a] -> Set a
Set.fromList [UserId]
tMembers) ([UserId] -> Set UserId
forall a. Ord a => [a] -> Set a
Set.fromList [UserId]
contacts)
Clients
localClients <- [UserId]
-> Sem (Error (MessageNotSent MessageSendingStatus) : r) Clients
forall (r :: EffectRow).
(Member BrigAccess r, Member ClientStore r) =>
[UserId] -> Sem r Clients
getBrigClients [UserId]
users
let qualifiedLocalClients :: Map (Domain, UserId) (Set ClientId)
qualifiedLocalClients =
(UserId -> (Domain, UserId))
-> Map UserId (Set ClientId) -> Map (Domain, UserId) (Set ClientId)
forall k2 k1 a. Ord k2 => (k1 -> k2) -> Map k1 a -> Map k2 a
Map.mapKeys (Local UserId -> Domain
forall (t :: QTag) a. QualifiedWithTag t a -> Domain
tDomain Local UserId
lusr,)
(Map UserId (Set ClientId) -> Map (Domain, UserId) (Set ClientId))
-> (Clients -> Map UserId (Set ClientId))
-> Clients
-> Map (Domain, UserId) (Set ClientId)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set UserId
-> Map UserId (Set ClientId) -> Map UserId (Set ClientId)
makeUserMap ([UserId] -> Set UserId
forall a. Ord a => [a] -> Set a
Set.fromList [UserId]
users)
(Map UserId (Set ClientId) -> Map UserId (Set ClientId))
-> (Clients -> Map UserId (Set ClientId))
-> Clients
-> Map UserId (Set ClientId)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Clients -> Map UserId (Set ClientId)
Clients.toMap
(Clients -> Map (Domain, UserId) (Set ClientId))
-> Clients -> Map (Domain, UserId) (Set ClientId)
forall a b. (a -> b) -> a -> b
$ Clients
localClients
let (Bool
sendMessage, Map (Domain, UserId, ClientId) ByteString
validMessages, QualifiedMismatch
mismatch) =
(Domain, UserId, ClientId)
-> Map (Domain, UserId) (Set ClientId)
-> Map (Domain, UserId, ClientId) ByteString
-> ClientMismatchStrategy
-> (Bool, Map (Domain, UserId, ClientId) ByteString,
QualifiedMismatch)
checkMessageClients
(Domain
senderDomain, UserId
senderUser, ClientId
senderClient)
Map (Domain, UserId) (Set ClientId)
qualifiedLocalClients
(QualifiedOtrRecipients -> Map (Domain, UserId, ClientId) ByteString
flattenMap (QualifiedOtrRecipients
-> Map (Domain, UserId, ClientId) ByteString)
-> QualifiedOtrRecipients
-> Map (Domain, UserId, ClientId) ByteString
forall a b. (a -> b) -> a -> b
$ QualifiedNewOtrMessage -> QualifiedOtrRecipients
qualifiedNewOtrRecipients QualifiedNewOtrMessage
msg)
(QualifiedNewOtrMessage -> ClientMismatchStrategy
qualifiedNewOtrClientMismatchStrategy QualifiedNewOtrMessage
msg)
otrResult :: MessageSendingStatus
otrResult = UTCTimeMillis -> QualifiedMismatch -> MessageSendingStatus
mkMessageSendingStatus (UTCTime -> UTCTimeMillis
toUTCTimeMillis UTCTime
now) QualifiedMismatch
mismatch
UserType
-> Qualified UserId
-> Clients
-> [Either
(Remote [UserId], FederationError)
(Map (Domain, UserId) (Set ClientId))]
-> Local UserId
-> Sem (Error (MessageNotSent MessageSendingStatus) : r) ()
forall (r :: EffectRow) any.
(Member BrigAccess r,
Member (Error (MessageNotSent MessageSendingStatus)) r,
Member (Input Opts) r, Member TeamStore r, Member TinyLog r) =>
UserType
-> Qualified UserId
-> Clients
-> [Either
(Remote [UserId], FederationError)
(Map (Domain, UserId) (Set ClientId))]
-> Local any
-> Sem r ()
guardQualifiedLegalholdPolicyConflictsWrapper UserType
User (Local UserId -> Qualified UserId
forall (t :: QTag) a. QualifiedWithTag t a -> Qualified a
tUntagged Local UserId
lusr) Clients
localClients [] Local UserId
lusr
Bool
-> Sem (Error (MessageNotSent MessageSendingStatus) : r) ()
-> Sem (Error (MessageNotSent MessageSendingStatus) : r) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
sendMessage (Sem (Error (MessageNotSent MessageSendingStatus) : r) ()
-> Sem (Error (MessageNotSent MessageSendingStatus) : r) ())
-> Sem (Error (MessageNotSent MessageSendingStatus) : r) ()
-> Sem (Error (MessageNotSent MessageSendingStatus) : r) ()
forall a b. (a -> b) -> a -> b
$ do
MessageNotSent MessageSendingStatus
-> Sem (Error (MessageNotSent MessageSendingStatus) : r) ()
forall e (r :: EffectRow) a. Member (Error e) r => e -> Sem r a
throw (MessageNotSent MessageSendingStatus
-> Sem (Error (MessageNotSent MessageSendingStatus) : r) ())
-> MessageNotSent MessageSendingStatus
-> Sem (Error (MessageNotSent MessageSendingStatus) : r) ()
forall a b. (a -> b) -> a -> b
$ MessageSendingStatus -> MessageNotSent MessageSendingStatus
forall a. a -> MessageNotSent a
MessageNotSentClientMissing MessageSendingStatus
otrResult
QualifiedUserClients
failedToSend <-
Local UserId
-> UTCTime
-> Qualified UserId
-> ClientId
-> Maybe ConnId
-> MessageMetadata
-> Map (Domain, UserId, ClientId) ByteString
-> Sem
(Error (MessageNotSent MessageSendingStatus) : r)
QualifiedUserClients
forall (r :: EffectRow) x.
(Member ExternalAccess r, Member TinyLog r,
Member NotificationSubsystem r) =>
Local x
-> UTCTime
-> Qualified UserId
-> ClientId
-> Maybe ConnId
-> MessageMetadata
-> Map (Domain, UserId, ClientId) ByteString
-> Sem r QualifiedUserClients
sendBroadcastMessages
Local UserId
lusr
UTCTime
now
(Local UserId -> Qualified UserId
forall (t :: QTag) a. QualifiedWithTag t a -> Qualified a
tUntagged Local UserId
lusr)
ClientId
senderClient
Maybe ConnId
con
(QualifiedNewOtrMessage -> MessageMetadata
qualifiedNewOtrMetadata QualifiedNewOtrMessage
msg)
Map (Domain, UserId, ClientId) ByteString
validMessages
MessageSendingStatus
-> Sem
(Error (MessageNotSent MessageSendingStatus) : r)
MessageSendingStatus
forall a.
a -> Sem (Error (MessageNotSent MessageSendingStatus) : r) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure MessageSendingStatus
otrResult {mssFailedToSend = failedToSend}
where
maybeFetchLimitedTeamMemberList ::
( Member (ErrorS 'BroadcastLimitExceeded) r,
Member TeamStore r
) =>
Int ->
TeamId ->
[UserId] ->
Map UserId (Map ClientId ByteString) ->
Sem r [TeamMember]
maybeFetchLimitedTeamMemberList :: forall (r :: EffectRow).
(Member (ErrorS 'BroadcastLimitExceeded) r, Member TeamStore r) =>
Int
-> TeamId
-> [UserId]
-> Map UserId (Map ClientId ByteString)
-> Sem r [TeamMember]
maybeFetchLimitedTeamMemberList Int
limit TeamId
tid [UserId]
localUserIdsInFilter Map UserId (Map ClientId ByteString)
rcps = do
let localUserIdsInRcps :: [UserId]
localUserIdsInRcps = Map UserId (Map ClientId ByteString) -> [UserId]
forall k a. Map k a -> [k]
Map.keys Map UserId (Map ClientId ByteString)
rcps
let localUserIdsToLookup :: [UserId]
localUserIdsToLookup = Set UserId -> [UserId]
forall a. Set a -> [a]
Set.toList (Set UserId -> [UserId]) -> Set UserId -> [UserId]
forall a b. (a -> b) -> a -> b
$ Set UserId -> Set UserId -> Set UserId
forall a. Ord a => Set a -> Set a -> Set a
Set.union ([UserId] -> Set UserId
forall a. Ord a => [a] -> Set a
Set.fromList [UserId]
localUserIdsInFilter) ([UserId] -> Set UserId
forall a. Ord a => [a] -> Set a
Set.fromList [UserId]
localUserIdsInRcps)
Bool -> Sem r () -> Sem r ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([UserId] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [UserId]
localUserIdsToLookup Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
limit) (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 @'BroadcastLimitExceeded
TeamId -> [UserId] -> Sem r [TeamMember]
forall (r :: EffectRow).
Member TeamStore r =>
TeamId -> [UserId] -> Sem r [TeamMember]
selectTeamMembers TeamId
tid [UserId]
localUserIdsToLookup
maybeFetchAllMembersInTeam ::
( Member (ErrorS 'BroadcastLimitExceeded) r,
Member TeamStore r
) =>
TeamId ->
Sem r [TeamMember]
maybeFetchAllMembersInTeam :: forall (r :: EffectRow).
(Member (ErrorS 'BroadcastLimitExceeded) r, Member TeamStore r) =>
TeamId -> Sem r [TeamMember]
maybeFetchAllMembersInTeam TeamId
tid = do
TeamMemberList
mems <- TeamId -> Sem r TeamMemberList
forall (r :: EffectRow).
Member TeamStore r =>
TeamId -> Sem r TeamMemberList
getTeamMembersForFanout TeamId
tid
Bool -> Sem r () -> Sem r ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (TeamMemberList
mems TeamMemberList
-> Getting ListType TeamMemberList ListType -> ListType
forall s a. s -> Getting a s a -> a
^. Getting ListType TeamMemberList ListType
forall (tag :: PermissionTag) (f :: * -> *).
Functor f =>
(ListType -> f ListType)
-> TeamMemberList' tag -> f (TeamMemberList' tag)
teamMemberListType ListType -> ListType -> Bool
forall a. Eq a => a -> a -> Bool
== ListType
ListTruncated) (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 @'BroadcastLimitExceeded
[TeamMember] -> Sem r [TeamMember]
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TeamMemberList
mems TeamMemberList
-> Getting [TeamMember] TeamMemberList [TeamMember] -> [TeamMember]
forall s a. s -> Getting a s a -> a
^. Getting [TeamMember] TeamMemberList [TeamMember]
forall (tag1 :: PermissionTag) (tag2 :: PermissionTag)
(f :: * -> *).
Functor f =>
([TeamMember' tag1] -> f [TeamMember' tag2])
-> TeamMemberList' tag1 -> f (TeamMemberList' tag2)
teamMembers)
postQualifiedOtrMessage ::
( Member BrigAccess r,
Member ClientStore r,
Member ConversationStore r,
Member FederatorAccess r,
Member BackendNotificationQueueAccess r,
Member ExternalAccess r,
Member (Input Opts) r,
Member (Input UTCTime) r,
Member TeamStore r,
Member P.TinyLog r,
Member NotificationSubsystem r
) =>
UserType ->
Qualified UserId ->
Maybe ConnId ->
Local ConvId ->
QualifiedNewOtrMessage ->
Sem r (PostOtrResponse MessageSendingStatus)
postQualifiedOtrMessage :: forall (r :: EffectRow).
(Member BrigAccess r, Member ClientStore r,
Member ConversationStore r, Member FederatorAccess r,
Member BackendNotificationQueueAccess r, Member ExternalAccess r,
Member (Input Opts) r, Member (Input UTCTime) r,
Member TeamStore r, Member TinyLog r,
Member NotificationSubsystem r) =>
UserType
-> Qualified UserId
-> Maybe ConnId
-> Local ConvId
-> QualifiedNewOtrMessage
-> Sem r (PostOtrResponse MessageSendingStatus)
postQualifiedOtrMessage UserType
senderType Qualified UserId
sender Maybe ConnId
mconn Local ConvId
lcnv QualifiedNewOtrMessage
msg =
forall e (r :: EffectRow) a.
Sem (Error e : r) a -> Sem r (Either e a)
runError @(MessageNotSent MessageSendingStatus)
(Sem
(Error (MessageNotSent MessageSendingStatus) : r)
MessageSendingStatus
-> Sem r (PostOtrResponse MessageSendingStatus))
-> (Sem
(ErrorS 'InvalidOperation
: ErrorS 'ConvNotFound
: Error (MessageNotSent MessageSendingStatus) : r)
MessageSendingStatus
-> Sem
(Error (MessageNotSent MessageSendingStatus) : r)
MessageSendingStatus)
-> Sem
(ErrorS 'InvalidOperation
: ErrorS 'ConvNotFound
: Error (MessageNotSent MessageSendingStatus) : r)
MessageSendingStatus
-> Sem r (PostOtrResponse MessageSendingStatus)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} (e :: k) e' (r :: EffectRow) a.
Member (Error e') r =>
e' -> Sem (ErrorS e : r) a -> Sem r a
forall (e :: GalleyError) e' (r :: EffectRow) a.
Member (Error e') r =>
e' -> Sem (ErrorS e : r) a -> Sem r a
mapToRuntimeError @'ConvNotFound @(MessageNotSent MessageSendingStatus) MessageNotSent MessageSendingStatus
forall a. MessageNotSent a
MessageNotSentConversationNotFound
(Sem
(ErrorS 'ConvNotFound
: Error (MessageNotSent MessageSendingStatus) : r)
MessageSendingStatus
-> Sem
(Error (MessageNotSent MessageSendingStatus) : r)
MessageSendingStatus)
-> (Sem
(ErrorS 'InvalidOperation
: ErrorS 'ConvNotFound
: Error (MessageNotSent MessageSendingStatus) : r)
MessageSendingStatus
-> Sem
(ErrorS 'ConvNotFound
: Error (MessageNotSent MessageSendingStatus) : r)
MessageSendingStatus)
-> Sem
(ErrorS 'InvalidOperation
: ErrorS 'ConvNotFound
: Error (MessageNotSent MessageSendingStatus) : r)
MessageSendingStatus
-> Sem
(Error (MessageNotSent MessageSendingStatus) : r)
MessageSendingStatus
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} (e :: k) e' (r :: EffectRow) a.
Member (Error e') r =>
e' -> Sem (ErrorS e : r) a -> Sem r a
forall (e :: GalleyError) e' (r :: EffectRow) a.
Member (Error e') r =>
e' -> Sem (ErrorS e : r) a -> Sem r a
mapToRuntimeError @'InvalidOperation @(MessageNotSent MessageSendingStatus) MessageNotSent MessageSendingStatus
forall a. MessageNotSent a
MessageNotSentConversationNotFound
(Sem
(ErrorS 'InvalidOperation
: ErrorS 'ConvNotFound
: Error (MessageNotSent MessageSendingStatus) : r)
MessageSendingStatus
-> Sem r (PostOtrResponse MessageSendingStatus))
-> Sem
(ErrorS 'InvalidOperation
: ErrorS 'ConvNotFound
: Error (MessageNotSent MessageSendingStatus) : r)
MessageSendingStatus
-> Sem r (PostOtrResponse MessageSendingStatus)
forall a b. (a -> b) -> a -> b
$ do
let localDomain :: Domain
localDomain = Local ConvId -> Domain
forall (t :: QTag) a. QualifiedWithTag t a -> Domain
tDomain Local ConvId
lcnv
UTCTime
now <- Sem
(ErrorS 'InvalidOperation
: ErrorS 'ConvNotFound
: Error (MessageNotSent MessageSendingStatus) : r)
UTCTime
forall i (r :: EffectRow). Member (Input i) r => Sem r i
input
let nowMillis :: UTCTimeMillis
nowMillis = UTCTime -> UTCTimeMillis
toUTCTimeMillis UTCTime
now
let senderDomain :: Domain
senderDomain = Qualified UserId -> Domain
forall a. Qualified a -> Domain
qDomain Qualified UserId
sender
senderUser :: UserId
senderUser = Qualified UserId -> UserId
forall a. Qualified a -> a
qUnqualified Qualified UserId
sender
let senderClient :: ClientId
senderClient = QualifiedNewOtrMessage -> ClientId
qualifiedNewOtrSender QualifiedNewOtrMessage
msg
Conversation
conv <- ConvId
-> Sem
(ErrorS 'InvalidOperation
: ErrorS 'ConvNotFound
: Error (MessageNotSent MessageSendingStatus) : 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) Sem
(ErrorS 'InvalidOperation
: ErrorS 'ConvNotFound
: Error (MessageNotSent MessageSendingStatus) : r)
(Maybe Conversation)
-> (Maybe Conversation
-> Sem
(ErrorS 'InvalidOperation
: ErrorS 'ConvNotFound
: Error (MessageNotSent MessageSendingStatus) : r)
Conversation)
-> Sem
(ErrorS 'InvalidOperation
: ErrorS 'ConvNotFound
: Error (MessageNotSent MessageSendingStatus) : r)
Conversation
forall a b.
Sem
(ErrorS 'InvalidOperation
: ErrorS 'ConvNotFound
: Error (MessageNotSent MessageSendingStatus) : r)
a
-> (a
-> Sem
(ErrorS 'InvalidOperation
: ErrorS 'ConvNotFound
: Error (MessageNotSent MessageSendingStatus) : r)
b)
-> Sem
(ErrorS 'InvalidOperation
: ErrorS 'ConvNotFound
: Error (MessageNotSent MessageSendingStatus) : 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
Bool
-> Sem
(ErrorS 'InvalidOperation
: ErrorS 'ConvNotFound
: Error (MessageNotSent MessageSendingStatus) : r)
()
-> Sem
(ErrorS 'InvalidOperation
: ErrorS 'ConvNotFound
: Error (MessageNotSent MessageSendingStatus) : r)
()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Protocol -> ProtocolTag
protocolTag (Conversation -> Protocol
convProtocol Conversation
conv) ProtocolTag -> [ProtocolTag] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ProtocolTag
ProtocolProteusTag, ProtocolTag
ProtocolMixedTag]) (Sem
(ErrorS 'InvalidOperation
: ErrorS 'ConvNotFound
: Error (MessageNotSent MessageSendingStatus) : r)
()
-> Sem
(ErrorS 'InvalidOperation
: ErrorS 'ConvNotFound
: Error (MessageNotSent MessageSendingStatus) : r)
())
-> Sem
(ErrorS 'InvalidOperation
: ErrorS 'ConvNotFound
: Error (MessageNotSent MessageSendingStatus) : r)
()
-> Sem
(ErrorS 'InvalidOperation
: ErrorS 'ConvNotFound
: Error (MessageNotSent MessageSendingStatus) : 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 @'InvalidOperation
let localMemberIds :: [UserId]
localMemberIds = LocalMember -> UserId
lmId (LocalMember -> UserId) -> [LocalMember] -> [UserId]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Conversation -> [LocalMember]
convLocalMembers Conversation
conv
botMap :: BotMap
botMap :: BotMap
botMap = [(UserId, BotMember)] -> BotMap
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(UserId, BotMember)] -> BotMap)
-> [(UserId, BotMember)] -> BotMap
forall a b. (a -> b) -> a -> b
$ do
LocalMember
mem <- Conversation -> [LocalMember]
convLocalMembers Conversation
conv
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
mem
(UserId, BotMember) -> [(UserId, BotMember)]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LocalMember -> UserId
lmId LocalMember
mem, BotMember
b)
members :: Set (Qualified UserId)
members :: Set (Qualified UserId)
members =
[Qualified UserId] -> Set (Qualified UserId)
forall a. Ord a => [a] -> Set a
Set.fromList ([Qualified UserId] -> Set (Qualified UserId))
-> [Qualified UserId] -> Set (Qualified UserId)
forall a b. (a -> b) -> a -> b
$
(UserId -> Qualified UserId) -> [UserId] -> [Qualified UserId]
forall a b. (a -> b) -> [a] -> [b]
map (Local UserId -> Qualified UserId
forall (t :: QTag) a. QualifiedWithTag t a -> Qualified a
tUntagged (Local UserId -> Qualified UserId)
-> (UserId -> Local UserId) -> UserId -> Qualified UserId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Local ConvId -> UserId -> Local UserId
forall (t :: QTag) x a.
QualifiedWithTag t x -> a -> QualifiedWithTag t a
qualifyAs Local ConvId
lcnv) [UserId]
localMemberIds
[Qualified UserId] -> [Qualified UserId] -> [Qualified UserId]
forall a. Semigroup a => a -> a -> a
<> (RemoteMember -> Qualified UserId)
-> [RemoteMember] -> [Qualified UserId]
forall a b. (a -> b) -> [a] -> [b]
map (Remote UserId -> Qualified UserId
forall (t :: QTag) a. QualifiedWithTag t a -> Qualified a
tUntagged (Remote UserId -> Qualified UserId)
-> (RemoteMember -> Remote UserId)
-> RemoteMember
-> Qualified UserId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RemoteMember -> Remote UserId
rmId) (Conversation -> [RemoteMember]
convRemoteMembers Conversation
conv)
Bool
isInternal <- Getting Bool Opts Bool -> Opts -> Bool
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view ((Settings -> Const Bool Settings) -> Opts -> Const Bool Opts
Lens' Opts Settings
settings ((Settings -> Const Bool Settings) -> Opts -> Const Bool Opts)
-> ((Bool -> Const Bool Bool) -> Settings -> Const Bool Settings)
-> Getting Bool Opts Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Bool -> Const Bool Bool) -> Settings -> Const Bool Settings
Lens' Settings Bool
intraListing) (Opts -> Bool)
-> Sem
(ErrorS 'InvalidOperation
: ErrorS 'ConvNotFound
: Error (MessageNotSent MessageSendingStatus) : r)
Opts
-> Sem
(ErrorS 'InvalidOperation
: ErrorS 'ConvNotFound
: Error (MessageNotSent MessageSendingStatus) : r)
Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Sem
(ErrorS 'InvalidOperation
: ErrorS 'ConvNotFound
: Error (MessageNotSent MessageSendingStatus) : r)
Opts
forall i (r :: EffectRow). Member (Input i) r => Sem r i
input
Bool
-> Sem
(ErrorS 'InvalidOperation
: ErrorS 'ConvNotFound
: Error (MessageNotSent MessageSendingStatus) : r)
()
-> Sem
(ErrorS 'InvalidOperation
: ErrorS 'ConvNotFound
: Error (MessageNotSent MessageSendingStatus) : r)
()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Qualified UserId -> Set (Qualified UserId) -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member Qualified UserId
sender Set (Qualified UserId)
members) (Sem
(ErrorS 'InvalidOperation
: ErrorS 'ConvNotFound
: Error (MessageNotSent MessageSendingStatus) : r)
()
-> Sem
(ErrorS 'InvalidOperation
: ErrorS 'ConvNotFound
: Error (MessageNotSent MessageSendingStatus) : r)
())
-> Sem
(ErrorS 'InvalidOperation
: ErrorS 'ConvNotFound
: Error (MessageNotSent MessageSendingStatus) : r)
()
-> Sem
(ErrorS 'InvalidOperation
: ErrorS 'ConvNotFound
: Error (MessageNotSent MessageSendingStatus) : 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 @'ConvNotFound
Clients
localClients <-
if Bool
isInternal
then UserClients -> Clients
Clients.fromUserClients (UserClients -> Clients)
-> Sem
(ErrorS 'InvalidOperation
: ErrorS 'ConvNotFound
: Error (MessageNotSent MessageSendingStatus) : r)
UserClients
-> Sem
(ErrorS 'InvalidOperation
: ErrorS 'ConvNotFound
: Error (MessageNotSent MessageSendingStatus) : r)
Clients
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [UserId]
-> Sem
(ErrorS 'InvalidOperation
: ErrorS 'ConvNotFound
: Error (MessageNotSent MessageSendingStatus) : r)
UserClients
forall (r :: EffectRow).
Member BrigAccess r =>
[UserId] -> Sem r UserClients
lookupClients [UserId]
localMemberIds
else [UserId]
-> Sem
(ErrorS 'InvalidOperation
: ErrorS 'ConvNotFound
: Error (MessageNotSent MessageSendingStatus) : r)
Clients
forall (r :: EffectRow).
Member ClientStore r =>
[UserId] -> Sem r Clients
getClients [UserId]
localMemberIds
let qualifiedLocalClients :: Map (Domain, UserId) (Set ClientId)
qualifiedLocalClients =
(UserId -> (Domain, UserId))
-> Map UserId (Set ClientId) -> Map (Domain, UserId) (Set ClientId)
forall k2 k1 a. Ord k2 => (k1 -> k2) -> Map k1 a -> Map k2 a
Map.mapKeys (Domain
localDomain,)
(Map UserId (Set ClientId) -> Map (Domain, UserId) (Set ClientId))
-> (Clients -> Map UserId (Set ClientId))
-> Clients
-> Map (Domain, UserId) (Set ClientId)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set UserId
-> Map UserId (Set ClientId) -> Map UserId (Set ClientId)
makeUserMap ([UserId] -> Set UserId
forall a. Ord a => [a] -> Set a
Set.fromList ((LocalMember -> UserId) -> [LocalMember] -> [UserId]
forall a b. (a -> b) -> [a] -> [b]
map LocalMember -> UserId
lmId (Conversation -> [LocalMember]
convLocalMembers Conversation
conv)))
(Map UserId (Set ClientId) -> Map UserId (Set ClientId))
-> (Clients -> Map UserId (Set ClientId))
-> Clients
-> Map UserId (Set ClientId)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Clients -> Map UserId (Set ClientId)
Clients.toMap
(Clients -> Map (Domain, UserId) (Set ClientId))
-> Clients -> Map (Domain, UserId) (Set ClientId)
forall a b. (a -> b) -> a -> b
$ Clients
localClients
[Either
(Remote [UserId], FederationError)
(Map (Domain, UserId) (Set ClientId))]
qualifiedRemoteClients :: [Either (Remote [UserId], FederationError) (Map (Domain, UserId) (Set ClientId))] <-
[RemoteMember]
-> Sem
(ErrorS 'InvalidOperation
: ErrorS 'ConvNotFound
: Error (MessageNotSent MessageSendingStatus) : r)
[Either
(Remote [UserId], FederationError)
(Map (Domain, UserId) (Set ClientId))]
forall (r :: EffectRow).
Member FederatorAccess r =>
[RemoteMember]
-> Sem
r
[Either
(Remote [UserId], FederationError)
(Map (Domain, UserId) (Set ClientId))]
getRemoteClients (Conversation -> [RemoteMember]
convRemoteMembers Conversation
conv)
let
qualifiedRemoteClients' :: Map (Domain, UserId) (Set ClientId)
qualifiedRemoteClients' = [Map (Domain, UserId) (Set ClientId)]
-> Map (Domain, UserId) (Set ClientId)
forall a. Monoid a => [a] -> a
mconcat ([Map (Domain, UserId) (Set ClientId)]
-> Map (Domain, UserId) (Set ClientId))
-> [Map (Domain, UserId) (Set ClientId)]
-> Map (Domain, UserId) (Set ClientId)
forall a b. (a -> b) -> a -> b
$ [Either
(Remote [UserId], FederationError)
(Map (Domain, UserId) (Set ClientId))]
-> [Map (Domain, UserId) (Set ClientId)]
forall a b. [Either a b] -> [b]
rights [Either
(Remote [UserId], FederationError)
(Map (Domain, UserId) (Set ClientId))]
qualifiedRemoteClients
([((Domain, UserId), Set ClientId)]
unconfirmedKnownClients, [((Domain, UserId), Set ClientId)]
unconfirmedUnknownClients) =
(((Domain, UserId), Set ClientId) -> Bool)
-> [((Domain, UserId), Set ClientId)]
-> ([((Domain, UserId), Set ClientId)],
[((Domain, UserId), Set ClientId)])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition
(Bool -> Bool
not (Bool -> Bool)
-> (((Domain, UserId), Set ClientId) -> Bool)
-> ((Domain, UserId), Set ClientId)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Set ClientId -> Bool) -> ((Domain, UserId), Set ClientId) -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Set ClientId -> Bool
forall a. Set a -> Bool
Set.null)
([Remote [UserId]] -> [((Domain, UserId), Set ClientId)]
matchUnconfirmedClientsWithRecipients ((Remote [UserId], FederationError) -> Remote [UserId]
forall a b. (a, b) -> a
fst ((Remote [UserId], FederationError) -> Remote [UserId])
-> [(Remote [UserId], FederationError)] -> [Remote [UserId]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Either
(Remote [UserId], FederationError)
(Map (Domain, UserId) (Set ClientId))]
-> [(Remote [UserId], FederationError)]
forall a b. [Either a b] -> [a]
lefts [Either
(Remote [UserId], FederationError)
(Map (Domain, UserId) (Set ClientId))]
qualifiedRemoteClients))
qualifiedClients :: Map (Domain, UserId) (Set ClientId)
qualifiedClients =
Map (Domain, UserId) (Set ClientId)
qualifiedLocalClients
Map (Domain, UserId) (Set ClientId)
-> Map (Domain, UserId) (Set ClientId)
-> Map (Domain, UserId) (Set ClientId)
forall a. Semigroup a => a -> a -> a
<> Map (Domain, UserId) (Set ClientId)
qualifiedRemoteClients'
Map (Domain, UserId) (Set ClientId)
-> Map (Domain, UserId) (Set ClientId)
-> Map (Domain, UserId) (Set ClientId)
forall a. Semigroup a => a -> a -> a
<> [((Domain, UserId), Set ClientId)]
-> Map (Domain, UserId) (Set ClientId)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [((Domain, UserId), Set ClientId)]
unconfirmedKnownClients
Bool
-> Sem
(ErrorS 'InvalidOperation
: ErrorS 'ConvNotFound
: Error (MessageNotSent MessageSendingStatus) : r)
()
-> Sem
(ErrorS 'InvalidOperation
: ErrorS 'ConvNotFound
: Error (MessageNotSent MessageSendingStatus) : r)
()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless
( ClientId -> Set ClientId -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member
ClientId
senderClient
(Set ClientId
-> (Domain, UserId)
-> Map (Domain, UserId) (Set ClientId)
-> Set ClientId
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault Set ClientId
forall a. Monoid a => a
mempty (Domain
senderDomain, UserId
senderUser) Map (Domain, UserId) (Set ClientId)
qualifiedClients)
)
(Sem
(ErrorS 'InvalidOperation
: ErrorS 'ConvNotFound
: Error (MessageNotSent MessageSendingStatus) : r)
()
-> Sem
(ErrorS 'InvalidOperation
: ErrorS 'ConvNotFound
: Error (MessageNotSent MessageSendingStatus) : r)
())
-> Sem
(ErrorS 'InvalidOperation
: ErrorS 'ConvNotFound
: Error (MessageNotSent MessageSendingStatus) : r)
()
-> Sem
(ErrorS 'InvalidOperation
: ErrorS 'ConvNotFound
: Error (MessageNotSent MessageSendingStatus) : r)
()
forall a b. (a -> b) -> a -> b
$ MessageNotSent MessageSendingStatus
-> Sem
(ErrorS 'InvalidOperation
: ErrorS 'ConvNotFound
: Error (MessageNotSent MessageSendingStatus) : r)
()
forall e (r :: EffectRow) a. Member (Error e) r => e -> Sem r a
throw (MessageNotSent MessageSendingStatus
forall a. MessageNotSent a
MessageNotSentUnknownClient :: MessageNotSent MessageSendingStatus)
let (Bool
sendMessage, Map (Domain, UserId, ClientId) ByteString
validMessages, QualifiedMismatch
mismatch) =
(Domain, UserId, ClientId)
-> Map (Domain, UserId) (Set ClientId)
-> Map (Domain, UserId, ClientId) ByteString
-> ClientMismatchStrategy
-> (Bool, Map (Domain, UserId, ClientId) ByteString,
QualifiedMismatch)
checkMessageClients
(Domain
senderDomain, UserId
senderUser, ClientId
senderClient)
Map (Domain, UserId) (Set ClientId)
qualifiedClients
(QualifiedOtrRecipients -> Map (Domain, UserId, ClientId) ByteString
flattenMap (QualifiedOtrRecipients
-> Map (Domain, UserId, ClientId) ByteString)
-> QualifiedOtrRecipients
-> Map (Domain, UserId, ClientId) ByteString
forall a b. (a -> b) -> a -> b
$ QualifiedNewOtrMessage -> QualifiedOtrRecipients
qualifiedNewOtrRecipients QualifiedNewOtrMessage
msg)
(QualifiedNewOtrMessage -> ClientMismatchStrategy
qualifiedNewOtrClientMismatchStrategy QualifiedNewOtrMessage
msg)
otrResult :: MessageSendingStatus
otrResult = UTCTimeMillis -> QualifiedMismatch -> MessageSendingStatus
mkMessageSendingStatus UTCTimeMillis
nowMillis QualifiedMismatch
mismatch
UserType
-> Qualified UserId
-> Clients
-> [Either
(Remote [UserId], FederationError)
(Map (Domain, UserId) (Set ClientId))]
-> Local ConvId
-> Sem
(ErrorS 'InvalidOperation
: ErrorS 'ConvNotFound
: Error (MessageNotSent MessageSendingStatus) : r)
()
forall (r :: EffectRow) any.
(Member BrigAccess r,
Member (Error (MessageNotSent MessageSendingStatus)) r,
Member (Input Opts) r, Member TeamStore r, Member TinyLog r) =>
UserType
-> Qualified UserId
-> Clients
-> [Either
(Remote [UserId], FederationError)
(Map (Domain, UserId) (Set ClientId))]
-> Local any
-> Sem r ()
guardQualifiedLegalholdPolicyConflictsWrapper UserType
senderType Qualified UserId
sender Clients
localClients [Either
(Remote [UserId], FederationError)
(Map (Domain, UserId) (Set ClientId))]
qualifiedRemoteClients Local ConvId
lcnv
Bool
-> Sem
(ErrorS 'InvalidOperation
: ErrorS 'ConvNotFound
: Error (MessageNotSent MessageSendingStatus) : r)
()
-> Sem
(ErrorS 'InvalidOperation
: ErrorS 'ConvNotFound
: Error (MessageNotSent MessageSendingStatus) : r)
()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
sendMessage (Sem
(ErrorS 'InvalidOperation
: ErrorS 'ConvNotFound
: Error (MessageNotSent MessageSendingStatus) : r)
()
-> Sem
(ErrorS 'InvalidOperation
: ErrorS 'ConvNotFound
: Error (MessageNotSent MessageSendingStatus) : r)
())
-> Sem
(ErrorS 'InvalidOperation
: ErrorS 'ConvNotFound
: Error (MessageNotSent MessageSendingStatus) : r)
()
-> Sem
(ErrorS 'InvalidOperation
: ErrorS 'ConvNotFound
: Error (MessageNotSent MessageSendingStatus) : r)
()
forall a b. (a -> b) -> a -> b
$ do
MessageNotSent MessageSendingStatus
-> Sem
(ErrorS 'InvalidOperation
: ErrorS 'ConvNotFound
: Error (MessageNotSent MessageSendingStatus) : r)
()
forall e (r :: EffectRow) a. Member (Error e) r => e -> Sem r a
throw (MessageNotSent MessageSendingStatus
-> Sem
(ErrorS 'InvalidOperation
: ErrorS 'ConvNotFound
: Error (MessageNotSent MessageSendingStatus) : r)
())
-> MessageNotSent MessageSendingStatus
-> Sem
(ErrorS 'InvalidOperation
: ErrorS 'ConvNotFound
: Error (MessageNotSent MessageSendingStatus) : r)
()
forall a b. (a -> b) -> a -> b
$ MessageSendingStatus -> MessageNotSent MessageSendingStatus
forall a. a -> MessageNotSent a
MessageNotSentClientMissing MessageSendingStatus
otrResult
QualifiedUserClients
failedToSend <-
UTCTime
-> Qualified UserId
-> ClientId
-> Maybe ConnId
-> Local ConvId
-> BotMap
-> MessageMetadata
-> Map (Domain, UserId, ClientId) ByteString
-> Sem
(ErrorS 'InvalidOperation
: ErrorS 'ConvNotFound
: Error (MessageNotSent MessageSendingStatus) : r)
QualifiedUserClients
forall (r :: EffectRow).
(Member ExternalAccess r, Member BackendNotificationQueueAccess r,
Member TinyLog r, Member NotificationSubsystem r) =>
UTCTime
-> Qualified UserId
-> ClientId
-> Maybe ConnId
-> Local ConvId
-> BotMap
-> MessageMetadata
-> Map (Domain, UserId, ClientId) ByteString
-> Sem r QualifiedUserClients
sendMessages
UTCTime
now
Qualified UserId
sender
ClientId
senderClient
Maybe ConnId
mconn
Local ConvId
lcnv
BotMap
botMap
(QualifiedNewOtrMessage -> MessageMetadata
qualifiedNewOtrMetadata QualifiedNewOtrMessage
msg)
Map (Domain, UserId, ClientId) ByteString
validMessages
let
redundant' :: [(Domain, (UserId, Set ClientId))]
redundant' = Map Domain (Map UserId (Set ClientId))
-> [(Domain, (UserId, Set ClientId))]
toDomUserClient (Map Domain (Map UserId (Set ClientId))
-> [(Domain, (UserId, Set ClientId))])
-> Map Domain (Map UserId (Set ClientId))
-> [(Domain, (UserId, Set ClientId))]
forall a b. (a -> b) -> a -> b
$ QualifiedUserClients -> Map Domain (Map UserId (Set ClientId))
qualifiedUserClients (QualifiedUserClients -> Map Domain (Map UserId (Set ClientId)))
-> QualifiedUserClients -> Map Domain (Map UserId (Set ClientId))
forall a b. (a -> b) -> a -> b
$ MessageSendingStatus -> QualifiedUserClients
mssRedundantClients MessageSendingStatus
otrResult
failed' :: [(Domain, (UserId, Set ClientId))]
failed' = Map Domain (Map UserId (Set ClientId))
-> [(Domain, (UserId, Set ClientId))]
toDomUserClient (Map Domain (Map UserId (Set ClientId))
-> [(Domain, (UserId, Set ClientId))])
-> Map Domain (Map UserId (Set ClientId))
-> [(Domain, (UserId, Set ClientId))]
forall a b. (a -> b) -> a -> b
$ [((Domain, UserId), Set ClientId)]
-> Map Domain (Map UserId (Set ClientId))
toDomMap [((Domain, UserId), Set ClientId)]
unconfirmedUnknownClients
predicate :: (Domain, (UserId, Set ClientId)) -> Bool
predicate (Domain
d, (UserId
u, Set ClientId
_)) = ((Domain, (UserId, Set ClientId)) -> Bool)
-> [(Domain, (UserId, Set ClientId))] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\(Domain
d', (UserId
u', Set ClientId
_)) -> Domain
d Domain -> Domain -> Bool
forall a. Eq a => a -> a -> Bool
== Domain
d' Bool -> Bool -> Bool
&& UserId
u UserId -> UserId -> Bool
forall a. Eq a => a -> a -> Bool
== UserId
u') [(Domain, (UserId, Set ClientId))]
failed'
([(Domain, (UserId, Set ClientId))]
failed, [(Domain, (UserId, Set ClientId))]
redundant) = ((Domain, (UserId, Set ClientId)) -> Bool)
-> [(Domain, (UserId, Set ClientId))]
-> ([(Domain, (UserId, Set ClientId))],
[(Domain, (UserId, Set ClientId))])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (Domain, (UserId, Set ClientId)) -> Bool
predicate [(Domain, (UserId, Set ClientId))]
redundant'
collectedFailedToSend :: Map Domain (Map UserId (Set ClientId))
collectedFailedToSend = [Map Domain (Map UserId (Set ClientId))]
-> Map Domain (Map UserId (Set ClientId))
forall (f :: * -> *).
Foldable f =>
f (Map Domain (Map UserId (Set ClientId)))
-> Map Domain (Map UserId (Set ClientId))
collectFailedToSend [QualifiedUserClients -> Map Domain (Map UserId (Set ClientId))
qualifiedUserClients QualifiedUserClients
failedToSend, [((Domain, UserId), Set ClientId)]
-> Map Domain (Map UserId (Set ClientId))
toDomMap [((Domain, UserId), Set ClientId)]
unconfirmedUnknownClients, [(Domain, (UserId, Set ClientId))]
-> Map Domain (Map UserId (Set ClientId))
fromDomUserClient [(Domain, (UserId, Set ClientId))]
failed]
MessageSendingStatus
-> Sem
(ErrorS 'InvalidOperation
: ErrorS 'ConvNotFound
: Error (MessageNotSent MessageSendingStatus) : r)
MessageSendingStatus
forall a.
a
-> Sem
(ErrorS 'InvalidOperation
: ErrorS 'ConvNotFound
: Error (MessageNotSent MessageSendingStatus) : r)
a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
MessageSendingStatus
otrResult
{ mssFailedToSend = QualifiedUserClients collectedFailedToSend,
mssRedundantClients = QualifiedUserClients $ fromDomUserClient redundant,
mssFailedToConfirmClients = QualifiedUserClients $ collectFailedToSend $ [toDomMap unconfirmedKnownClients, collectedFailedToSend]
}
where
toDomUserClient :: Map Domain (Map UserId (Set ClientId)) -> [(Domain, (UserId, Set ClientId))]
toDomUserClient :: Map Domain (Map UserId (Set ClientId))
-> [(Domain, (UserId, Set ClientId))]
toDomUserClient Map Domain (Map UserId (Set ClientId))
m = do
(Domain
d, Map UserId (Set ClientId)
m') <- Map Domain (Map UserId (Set ClientId))
-> [(Domain, Map UserId (Set ClientId))]
forall k a. Map k a -> [(k, a)]
Map.assocs Map Domain (Map UserId (Set ClientId))
m
(Domain
d,) ((UserId, Set ClientId) -> (Domain, (UserId, Set ClientId)))
-> [(UserId, Set ClientId)] -> [(Domain, (UserId, Set ClientId))]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map UserId (Set ClientId) -> [(UserId, Set ClientId)]
forall k a. Map k a -> [(k, a)]
Map.assocs Map UserId (Set ClientId)
m'
fromDomUserClient :: [(Domain, (UserId, Set ClientId))] -> Map Domain (Map UserId (Set ClientId))
fromDomUserClient :: [(Domain, (UserId, Set ClientId))]
-> Map Domain (Map UserId (Set ClientId))
fromDomUserClient = ((Domain, (UserId, Set ClientId))
-> Map Domain (Map UserId (Set ClientId))
-> Map Domain (Map UserId (Set ClientId)))
-> Map Domain (Map UserId (Set ClientId))
-> [(Domain, (UserId, Set ClientId))]
-> Map Domain (Map UserId (Set ClientId))
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Domain, (UserId, Set ClientId))
-> Map Domain (Map UserId (Set ClientId))
-> Map Domain (Map UserId (Set ClientId))
buildUserClientMap Map Domain (Map UserId (Set ClientId))
forall a. Monoid a => a
mempty
where
buildUserClientMap :: (Domain, (UserId, Set ClientId)) -> Map Domain (Map UserId (Set ClientId)) -> Map Domain (Map UserId (Set ClientId))
buildUserClientMap :: (Domain, (UserId, Set ClientId))
-> Map Domain (Map UserId (Set ClientId))
-> Map Domain (Map UserId (Set ClientId))
buildUserClientMap (Domain
d, (UserId
u, Set ClientId
c)) Map Domain (Map UserId (Set ClientId))
m = (Maybe (Map UserId (Set ClientId))
-> Maybe (Map UserId (Set ClientId)))
-> Domain
-> Map Domain (Map UserId (Set ClientId))
-> Map Domain (Map UserId (Set ClientId))
forall k a.
Ord k =>
(Maybe a -> Maybe a) -> k -> Map k a -> Map k a
Map.alter (Map UserId (Set ClientId) -> Maybe (Map UserId (Set ClientId))
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map UserId (Set ClientId) -> Maybe (Map UserId (Set ClientId)))
-> (Maybe (Map UserId (Set ClientId)) -> Map UserId (Set ClientId))
-> Maybe (Map UserId (Set ClientId))
-> Maybe (Map UserId (Set ClientId))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe (Set ClientId) -> Maybe (Set ClientId))
-> UserId -> Map UserId (Set ClientId) -> Map UserId (Set ClientId)
forall k a.
Ord k =>
(Maybe a -> Maybe a) -> k -> Map k a -> Map k a
Map.alter (Set ClientId -> Maybe (Set ClientId)
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Set ClientId -> Maybe (Set ClientId))
-> (Maybe (Set ClientId) -> Set ClientId)
-> Maybe (Set ClientId)
-> Maybe (Set ClientId)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set ClientId -> Set ClientId -> Set ClientId
forall a. Ord a => Set a -> Set a -> Set a
Set.union Set ClientId
c (Set ClientId -> Set ClientId)
-> (Maybe (Set ClientId) -> Set ClientId)
-> Maybe (Set ClientId)
-> Set ClientId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set ClientId -> Maybe (Set ClientId) -> Set ClientId
forall a. a -> Maybe a -> a
fromMaybe Set ClientId
forall a. Monoid a => a
mempty) UserId
u (Map UserId (Set ClientId) -> Map UserId (Set ClientId))
-> (Maybe (Map UserId (Set ClientId)) -> Map UserId (Set ClientId))
-> Maybe (Map UserId (Set ClientId))
-> Map UserId (Set ClientId)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map UserId (Set ClientId)
-> Maybe (Map UserId (Set ClientId)) -> Map UserId (Set ClientId)
forall a. a -> Maybe a -> a
fromMaybe Map UserId (Set ClientId)
forall a. Monoid a => a
mempty) Domain
d Map Domain (Map UserId (Set ClientId))
m
toDomMap :: [((Domain, UserId), Set ClientId)] -> Map Domain (Map UserId (Set ClientId))
toDomMap :: [((Domain, UserId), Set ClientId)]
-> Map Domain (Map UserId (Set ClientId))
toDomMap = [(Domain, (UserId, Set ClientId))]
-> Map Domain (Map UserId (Set ClientId))
fromDomUserClient ([(Domain, (UserId, Set ClientId))]
-> Map Domain (Map UserId (Set ClientId)))
-> ([((Domain, UserId), Set ClientId)]
-> [(Domain, (UserId, Set ClientId))])
-> [((Domain, UserId), Set ClientId)]
-> Map Domain (Map UserId (Set ClientId))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (((Domain, UserId), Set ClientId)
-> (Domain, (UserId, Set ClientId)))
-> [((Domain, UserId), Set ClientId)]
-> [(Domain, (UserId, Set ClientId))]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\((Domain
d, UserId
u), Set ClientId
s) -> (Domain
d, (UserId
u, Set ClientId
s)))
matchUnconfirmedClientsWithRecipients :: [Remote [UserId]] -> [((Domain, UserId), Set ClientId)]
matchUnconfirmedClientsWithRecipients :: [Remote [UserId]] -> [((Domain, UserId), Set ClientId)]
matchUnconfirmedClientsWithRecipients [Remote [UserId]]
remotes = do
remoteUsers :: Remote [UserId]
remoteUsers@(Qualified [UserId] -> Domain
forall a. Qualified a -> Domain
qDomain (Qualified [UserId] -> Domain)
-> (Remote [UserId] -> Qualified [UserId])
-> Remote [UserId]
-> Domain
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Remote [UserId] -> Qualified [UserId]
forall (t :: QTag) a. QualifiedWithTag t a -> Qualified a
tUntagged -> Domain
domain) <- [Remote [UserId]]
remotes
UserId
user <- Remote [UserId] -> [UserId]
forall (t :: QTag) a. QualifiedWithTag t a -> a
tUnqualified Remote [UserId]
remoteUsers
((Domain, UserId), Set ClientId)
-> [((Domain, UserId), Set ClientId)]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Domain
domain, UserId
user), Domain -> UserId -> Set ClientId
tryFindClientIds Domain
domain UserId
user)
tryFindClientIds :: Domain -> UserId -> Set ClientId
tryFindClientIds :: Domain -> UserId -> Set ClientId
tryFindClientIds Domain
domain UserId
uid = do
[ClientId] -> Set ClientId
forall a. Ord a => [a] -> Set a
Set.fromList ([ClientId] -> Set ClientId) -> [ClientId] -> Set ClientId
forall a b. (a -> b) -> a -> b
$
Map ClientId ByteString -> [ClientId]
forall k a. Map k a -> [k]
Map.keys (Map ClientId ByteString -> [ClientId])
-> Map ClientId ByteString -> [ClientId]
forall a b. (a -> b) -> a -> b
$
Map ClientId ByteString
-> UserId
-> Map UserId (Map ClientId ByteString)
-> Map ClientId ByteString
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault Map ClientId ByteString
forall a. Monoid a => a
mempty UserId
uid (Map UserId (Map ClientId ByteString) -> Map ClientId ByteString)
-> Map UserId (Map ClientId ByteString) -> Map ClientId ByteString
forall a b. (a -> b) -> a -> b
$
Map UserId (Map ClientId ByteString)
-> Domain
-> Map Domain (Map UserId (Map ClientId ByteString))
-> Map UserId (Map ClientId ByteString)
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault Map UserId (Map ClientId ByteString)
forall a. Monoid a => a
mempty Domain
domain (Map Domain (Map UserId (Map ClientId ByteString))
-> Map UserId (Map ClientId ByteString))
-> Map Domain (Map UserId (Map ClientId ByteString))
-> Map UserId (Map ClientId ByteString)
forall a b. (a -> b) -> a -> b
$
QualifiedUserClientMap ByteString
-> Map Domain (Map UserId (Map ClientId ByteString))
forall a.
QualifiedUserClientMap a
-> Map Domain (Map UserId (Map ClientId a))
qualifiedUserClientMap (QualifiedUserClientMap ByteString
-> Map Domain (Map UserId (Map ClientId ByteString)))
-> QualifiedUserClientMap ByteString
-> Map Domain (Map UserId (Map ClientId ByteString))
forall a b. (a -> b) -> a -> b
$
QualifiedOtrRecipients -> QualifiedUserClientMap ByteString
qualifiedOtrRecipientsMap (QualifiedOtrRecipients -> QualifiedUserClientMap ByteString)
-> QualifiedOtrRecipients -> QualifiedUserClientMap ByteString
forall a b. (a -> b) -> a -> b
$
QualifiedNewOtrMessage -> QualifiedOtrRecipients
qualifiedNewOtrRecipients QualifiedNewOtrMessage
msg
guardQualifiedLegalholdPolicyConflictsWrapper ::
( Member BrigAccess r,
Member (Error (MessageNotSent MessageSendingStatus)) r,
Member (Input Opts) r,
Member TeamStore r,
Member P.TinyLog r
) =>
UserType ->
Qualified UserId ->
Clients.Clients ->
[Either (Remote [UserId], FederationError) (Map (Domain, UserId) (Set ClientId))] ->
Local any ->
Sem r ()
guardQualifiedLegalholdPolicyConflictsWrapper :: forall (r :: EffectRow) any.
(Member BrigAccess r,
Member (Error (MessageNotSent MessageSendingStatus)) r,
Member (Input Opts) r, Member TeamStore r, Member TinyLog r) =>
UserType
-> Qualified UserId
-> Clients
-> [Either
(Remote [UserId], FederationError)
(Map (Domain, UserId) (Set ClientId))]
-> Local any
-> Sem r ()
guardQualifiedLegalholdPolicyConflictsWrapper UserType
senderType Qualified UserId
sender Clients
localClients [Either
(Remote [UserId], FederationError)
(Map (Domain, UserId) (Set ClientId))]
qualifiedRemoteClients Local any
lany = do
Sem
(Error LegalholdConflictsOldClients
: Error LegalholdConflicts : Input (Local ()) : r)
()
-> Sem r ()
wrapper (Sem
(Error LegalholdConflictsOldClients
: Error LegalholdConflicts : Input (Local ()) : r)
()
-> Sem r ())
-> Sem
(Error LegalholdConflictsOldClients
: Error LegalholdConflicts : Input (Local ()) : r)
()
-> Sem r ()
forall a b. (a -> b) -> a -> b
$ LegalholdProtectee
-> QualifiedUserClients
-> Sem
(Error LegalholdConflictsOldClients
: Error LegalholdConflicts : Input (Local ()) : r)
()
forall (r :: EffectRow).
(Member BrigAccess r, Member (Error LegalholdConflicts) r,
Member (Input (Local ())) r, Member (Input Opts) r,
Member TeamStore r, Member TinyLog r) =>
LegalholdProtectee -> QualifiedUserClients -> Sem r ()
guardQualifiedLegalholdPolicyConflicts LegalholdProtectee
lhProtectee QualifiedUserClients
allReceivingClients
where
localDomain :: Domain
localDomain = Local any -> Domain
forall (t :: QTag) a. QualifiedWithTag t a -> Domain
tDomain Local any
lany
lhProtectee :: LegalholdProtectee
lhProtectee = Domain -> UserType -> Qualified UserId -> LegalholdProtectee
qualifiedUserToProtectee Domain
localDomain UserType
senderType Qualified UserId
sender
allReceivingClients :: QualifiedUserClients
allReceivingClients = QualifiedRecipientSet -> QualifiedUserClients
mkQualifiedUserClients (QualifiedRecipientSet -> QualifiedUserClients)
-> QualifiedRecipientSet -> QualifiedUserClients
forall a b. (a -> b) -> a -> b
$ Clients -> QualifiedRecipientSet
parseLocal Clients
localClients QualifiedRecipientSet
-> QualifiedRecipientSet -> QualifiedRecipientSet
forall a. Semigroup a => a -> a -> a
<> [Either
(Remote [UserId], FederationError)
(Map (Domain, UserId) (Set ClientId))]
-> QualifiedRecipientSet
parseRemote [Either
(Remote [UserId], FederationError)
(Map (Domain, UserId) (Set ClientId))]
qualifiedRemoteClients
where
parseLocal :: Clients.Clients -> QualifiedRecipientSet
parseLocal :: Clients -> QualifiedRecipientSet
parseLocal =
[(Domain, UserId, ClientId)] -> QualifiedRecipientSet
forall a. Ord a => [a] -> Set a
Set.fromList
([(Domain, UserId, ClientId)] -> QualifiedRecipientSet)
-> (Clients -> [(Domain, UserId, ClientId)])
-> Clients
-> QualifiedRecipientSet
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[(Domain, UserId, ClientId)]] -> [(Domain, UserId, ClientId)]
forall a. Monoid a => [a] -> a
mconcat
([[(Domain, UserId, ClientId)]] -> [(Domain, UserId, ClientId)])
-> (Clients -> [[(Domain, UserId, ClientId)]])
-> Clients
-> [(Domain, UserId, ClientId)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((UserId, [ClientId]) -> [(Domain, UserId, ClientId)])
-> [(UserId, [ClientId])] -> [[(Domain, UserId, ClientId)]]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(UserId
uid, [ClientId]
cids) -> (Domain
localDomain,UserId
uid,) (ClientId -> (Domain, UserId, ClientId))
-> [ClientId] -> [(Domain, UserId, ClientId)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ClientId]
cids)
([(UserId, [ClientId])] -> [[(Domain, UserId, ClientId)]])
-> (Clients -> [(UserId, [ClientId])])
-> Clients
-> [[(Domain, UserId, ClientId)]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Clients -> [(UserId, [ClientId])]
Clients.toList
parseRemote :: [Either (Remote [UserId], FederationError) (Map (Domain, UserId) (Set ClientId))] -> QualifiedRecipientSet
parseRemote :: [Either
(Remote [UserId], FederationError)
(Map (Domain, UserId) (Set ClientId))]
-> QualifiedRecipientSet
parseRemote =
[(Domain, UserId, ClientId)] -> QualifiedRecipientSet
forall a. Ord a => [a] -> Set a
Set.fromList
([(Domain, UserId, ClientId)] -> QualifiedRecipientSet)
-> ([Either
(Remote [UserId], FederationError)
(Map (Domain, UserId) (Set ClientId))]
-> [(Domain, UserId, ClientId)])
-> [Either
(Remote [UserId], FederationError)
(Map (Domain, UserId) (Set ClientId))]
-> QualifiedRecipientSet
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[(Domain, UserId, ClientId)]] -> [(Domain, UserId, ClientId)]
forall a. Monoid a => [a] -> a
mconcat
([[(Domain, UserId, ClientId)]] -> [(Domain, UserId, ClientId)])
-> ([Either
(Remote [UserId], FederationError)
(Map (Domain, UserId) (Set ClientId))]
-> [[(Domain, UserId, ClientId)]])
-> [Either
(Remote [UserId], FederationError)
(Map (Domain, UserId) (Set ClientId))]
-> [(Domain, UserId, ClientId)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (((Domain, UserId), Set ClientId) -> [(Domain, UserId, ClientId)])
-> [((Domain, UserId), Set ClientId)]
-> [[(Domain, UserId, ClientId)]]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\((Domain
dom, UserId
uid), Set ClientId -> [ClientId]
forall a. Set a -> [a]
Set.toList -> [ClientId]
cids) -> (Domain
dom,UserId
uid,) (ClientId -> (Domain, UserId, ClientId))
-> [ClientId] -> [(Domain, UserId, ClientId)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ClientId]
cids)
([((Domain, UserId), Set ClientId)]
-> [[(Domain, UserId, ClientId)]])
-> ([Either
(Remote [UserId], FederationError)
(Map (Domain, UserId) (Set ClientId))]
-> [((Domain, UserId), Set ClientId)])
-> [Either
(Remote [UserId], FederationError)
(Map (Domain, UserId) (Set ClientId))]
-> [[(Domain, UserId, ClientId)]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[((Domain, UserId), Set ClientId)]]
-> [((Domain, UserId), Set ClientId)]
forall a. Monoid a => [a] -> a
mconcat
([[((Domain, UserId), Set ClientId)]]
-> [((Domain, UserId), Set ClientId)])
-> ([Either
(Remote [UserId], FederationError)
(Map (Domain, UserId) (Set ClientId))]
-> [[((Domain, UserId), Set ClientId)]])
-> [Either
(Remote [UserId], FederationError)
(Map (Domain, UserId) (Set ClientId))]
-> [((Domain, UserId), Set ClientId)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map (Domain, UserId) (Set ClientId)
-> [((Domain, UserId), Set ClientId)])
-> [Map (Domain, UserId) (Set ClientId)]
-> [[((Domain, UserId), Set ClientId)]]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Map (Domain, UserId) (Set ClientId)
-> [((Domain, UserId), Set ClientId)]
forall k a. Map k a -> [(k, a)]
Map.toList
([Map (Domain, UserId) (Set ClientId)]
-> [[((Domain, UserId), Set ClientId)]])
-> ([Either
(Remote [UserId], FederationError)
(Map (Domain, UserId) (Set ClientId))]
-> [Map (Domain, UserId) (Set ClientId)])
-> [Either
(Remote [UserId], FederationError)
(Map (Domain, UserId) (Set ClientId))]
-> [[((Domain, UserId), Set ClientId)]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Either
(Remote [UserId], FederationError)
(Map (Domain, UserId) (Set ClientId))]
-> [Map (Domain, UserId) (Set ClientId)]
forall a b. [Either a b] -> [b]
rights
wrapper :: Sem
(Error LegalholdConflictsOldClients
: Error LegalholdConflicts : Input (Local ()) : r)
()
-> Sem r ()
wrapper =
Local any -> Sem (Input (Local ()) : r) () -> Sem r ()
forall x (r :: EffectRow) a.
Local x -> Sem (Input (Local ()) : r) a -> Sem r a
runLocalInput Local any
lany
(Sem (Input (Local ()) : r) () -> Sem r ())
-> (Sem
(Error LegalholdConflictsOldClients
: Error LegalholdConflicts : Input (Local ()) : r)
()
-> Sem (Input (Local ()) : r) ())
-> Sem
(Error LegalholdConflictsOldClients
: Error LegalholdConflicts : Input (Local ()) : r)
()
-> Sem r ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e1 e2 (r :: EffectRow) a.
Member (Error e2) r =>
(e1 -> e2) -> Sem (Error e1 : r) a -> Sem r a
mapError @LegalholdConflicts @(MessageNotSent MessageSendingStatus) (MessageNotSent MessageSendingStatus
-> LegalholdConflicts -> MessageNotSent MessageSendingStatus
forall a b. a -> b -> a
const MessageNotSent MessageSendingStatus
forall a. MessageNotSent a
MessageNotSentLegalhold)
(Sem (Error LegalholdConflicts : Input (Local ()) : r) ()
-> Sem (Input (Local ()) : r) ())
-> (Sem
(Error LegalholdConflictsOldClients
: Error LegalholdConflicts : Input (Local ()) : r)
()
-> Sem (Error LegalholdConflicts : Input (Local ()) : r) ())
-> Sem
(Error LegalholdConflictsOldClients
: Error LegalholdConflicts : Input (Local ()) : r)
()
-> Sem (Input (Local ()) : r) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e1 e2 (r :: EffectRow) a.
Member (Error e2) r =>
(e1 -> e2) -> Sem (Error e1 : r) a -> Sem r a
mapError @LegalholdConflictsOldClients @(MessageNotSent MessageSendingStatus) (MessageNotSent MessageSendingStatus
-> LegalholdConflictsOldClients
-> MessageNotSent MessageSendingStatus
forall a b. a -> b -> a
const MessageNotSent MessageSendingStatus
forall a. MessageNotSent a
MessageNotSentLegalholdOldClients)
collectFailedToSend ::
(Foldable f) =>
f (Map Domain (Map UserId (Set ClientId))) ->
Map Domain (Map UserId (Set ClientId))
collectFailedToSend :: forall (f :: * -> *).
Foldable f =>
f (Map Domain (Map UserId (Set ClientId)))
-> Map Domain (Map UserId (Set ClientId))
collectFailedToSend = (Map Domain (Map UserId (Set ClientId))
-> Map Domain (Map UserId (Set ClientId))
-> Map Domain (Map UserId (Set ClientId)))
-> Map Domain (Map UserId (Set ClientId))
-> f (Map Domain (Map UserId (Set ClientId)))
-> Map Domain (Map UserId (Set ClientId))
forall a b. (a -> b -> b) -> b -> f a -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ((Map UserId (Set ClientId)
-> Map UserId (Set ClientId) -> Map UserId (Set ClientId))
-> Map Domain (Map UserId (Set ClientId))
-> Map Domain (Map UserId (Set ClientId))
-> Map Domain (Map UserId (Set ClientId))
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith ((Set ClientId -> Set ClientId -> Set ClientId)
-> Map UserId (Set ClientId)
-> Map UserId (Set ClientId)
-> Map UserId (Set ClientId)
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith Set ClientId -> Set ClientId -> Set ClientId
forall a. Ord a => Set a -> Set a -> Set a
Set.union)) Map Domain (Map UserId (Set ClientId))
forall a. Monoid a => a
mempty
makeUserMap :: Set UserId -> Map UserId (Set ClientId) -> Map UserId (Set ClientId)
makeUserMap :: Set UserId
-> Map UserId (Set ClientId) -> Map UserId (Set ClientId)
makeUserMap Set UserId
keys = (Map UserId (Set ClientId)
-> Map UserId (Set ClientId) -> Map UserId (Set ClientId)
forall a. Semigroup a => a -> a -> a
<> (UserId -> Set ClientId) -> Set UserId -> Map UserId (Set ClientId)
forall k a. (k -> a) -> Set k -> Map k a
Map.fromSet (Set ClientId -> UserId -> Set ClientId
forall a b. a -> b -> a
const Set ClientId
forall a. Monoid a => a
mempty) Set UserId
keys)
sendMessages ::
forall r.
( Member ExternalAccess r,
Member BackendNotificationQueueAccess r,
Member P.TinyLog r,
Member NotificationSubsystem r
) =>
UTCTime ->
Qualified UserId ->
ClientId ->
Maybe ConnId ->
Local ConvId ->
BotMap ->
MessageMetadata ->
Map (Domain, UserId, ClientId) ByteString ->
Sem r QualifiedUserClients
sendMessages :: forall (r :: EffectRow).
(Member ExternalAccess r, Member BackendNotificationQueueAccess r,
Member TinyLog r, Member NotificationSubsystem r) =>
UTCTime
-> Qualified UserId
-> ClientId
-> Maybe ConnId
-> Local ConvId
-> BotMap
-> MessageMetadata
-> Map (Domain, UserId, ClientId) ByteString
-> Sem r QualifiedUserClients
sendMessages UTCTime
now Qualified UserId
sender ClientId
senderClient Maybe ConnId
mconn Local ConvId
lcnv BotMap
botMap MessageMetadata
metadata Map (Domain, UserId, ClientId) ByteString
messages = do
let messageMap :: Map Domain (Map (UserId, ClientId) Text)
messageMap = Map (Domain, UserId, ClientId) Text
-> Map Domain (Map (UserId, ClientId) Text)
forall a.
Map (Domain, UserId, ClientId) a
-> Map Domain (Map (UserId, ClientId) a)
byDomain (Map (Domain, UserId, ClientId) Text
-> Map Domain (Map (UserId, ClientId) Text))
-> Map (Domain, UserId, ClientId) Text
-> Map Domain (Map (UserId, ClientId) Text)
forall a b. (a -> b) -> a -> b
$ (ByteString -> Text)
-> Map (Domain, UserId, ClientId) ByteString
-> Map (Domain, UserId, ClientId) Text
forall a b.
(a -> b)
-> Map (Domain, UserId, ClientId) a
-> Map (Domain, UserId, ClientId) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> Text
toBase64Text Map (Domain, UserId, ClientId) ByteString
messages
let send :: Domain -> Map (UserId, ClientId) Text -> Sem r RecipientSet
send Domain
dom =
Local ConvId
-> (Local () -> Map (UserId, ClientId) Text -> Sem r RecipientSet)
-> (Remote () -> Map (UserId, ClientId) Text -> Sem r RecipientSet)
-> Qualified ()
-> Map (UserId, ClientId) Text
-> Sem r RecipientSet
forall x a b.
Local x -> (Local a -> b) -> (Remote a -> b) -> Qualified a -> b
foldQualified
Local ConvId
lcnv
(\Local ()
l -> Local ()
-> UTCTime
-> Qualified UserId
-> ClientId
-> Maybe ConnId
-> Maybe (Qualified ConvId)
-> BotMap
-> MessageMetadata
-> Map (UserId, ClientId) Text
-> Sem r RecipientSet
forall (r :: EffectRow) x.
(Member ExternalAccess r, Member TinyLog r,
Member NotificationSubsystem r) =>
Local x
-> UTCTime
-> Qualified UserId
-> ClientId
-> Maybe ConnId
-> Maybe (Qualified ConvId)
-> BotMap
-> MessageMetadata
-> Map (UserId, ClientId) Text
-> Sem r RecipientSet
sendLocalMessages Local ()
l UTCTime
now Qualified UserId
sender ClientId
senderClient Maybe ConnId
mconn (Qualified ConvId -> Maybe (Qualified ConvId)
forall a. a -> Maybe a
Just (Local ConvId -> Qualified ConvId
forall (t :: QTag) a. QualifiedWithTag t a -> Qualified a
tUntagged Local ConvId
lcnv)) BotMap
botMap MessageMetadata
metadata)
(\Remote ()
r -> Remote ()
-> UTCTime
-> Qualified UserId
-> ClientId
-> Local ConvId
-> MessageMetadata
-> Map (UserId, ClientId) Text
-> Sem r RecipientSet
forall (r :: EffectRow) x.
(Member BackendNotificationQueueAccess r, Member TinyLog r) =>
Remote x
-> UTCTime
-> Qualified UserId
-> ClientId
-> Local ConvId
-> MessageMetadata
-> Map (UserId, ClientId) Text
-> Sem r RecipientSet
sendRemoteMessages Remote ()
r UTCTime
now Qualified UserId
sender ClientId
senderClient Local ConvId
lcnv MessageMetadata
metadata)
(() -> Domain -> Qualified ()
forall a. a -> Domain -> Qualified a
Qualified () Domain
dom)
Map Domain RecipientSet -> QualifiedUserClients
mkQualifiedUserClientsByDomain (Map Domain RecipientSet -> QualifiedUserClients)
-> Sem r (Map Domain RecipientSet) -> Sem r QualifiedUserClients
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Domain -> Map (UserId, ClientId) Text -> Sem r RecipientSet)
-> Map Domain (Map (UserId, ClientId) Text)
-> Sem r (Map Domain RecipientSet)
forall (t :: * -> *) k a b.
Applicative t =>
(k -> a -> t b) -> Map k a -> t (Map k b)
Map.traverseWithKey Domain -> Map (UserId, ClientId) Text -> Sem r RecipientSet
send Map Domain (Map (UserId, ClientId) Text)
messageMap
sendBroadcastMessages ::
( Member ExternalAccess r,
Member P.TinyLog r,
Member NotificationSubsystem r
) =>
Local x ->
UTCTime ->
Qualified UserId ->
ClientId ->
Maybe ConnId ->
MessageMetadata ->
Map (Domain, UserId, ClientId) ByteString ->
Sem r QualifiedUserClients
sendBroadcastMessages :: forall (r :: EffectRow) x.
(Member ExternalAccess r, Member TinyLog r,
Member NotificationSubsystem r) =>
Local x
-> UTCTime
-> Qualified UserId
-> ClientId
-> Maybe ConnId
-> MessageMetadata
-> Map (Domain, UserId, ClientId) ByteString
-> Sem r QualifiedUserClients
sendBroadcastMessages Local x
loc UTCTime
now Qualified UserId
sender ClientId
senderClient Maybe ConnId
mconn MessageMetadata
metadata Map (Domain, UserId, ClientId) ByteString
messages = do
let messageMap :: Map Domain (Map (UserId, ClientId) Text)
messageMap = Map (Domain, UserId, ClientId) Text
-> Map Domain (Map (UserId, ClientId) Text)
forall a.
Map (Domain, UserId, ClientId) a
-> Map Domain (Map (UserId, ClientId) a)
byDomain (Map (Domain, UserId, ClientId) Text
-> Map Domain (Map (UserId, ClientId) Text))
-> Map (Domain, UserId, ClientId) Text
-> Map Domain (Map (UserId, ClientId) Text)
forall a b. (a -> b) -> a -> b
$ (ByteString -> Text)
-> Map (Domain, UserId, ClientId) ByteString
-> Map (Domain, UserId, ClientId) Text
forall a b.
(a -> b)
-> Map (Domain, UserId, ClientId) a
-> Map (Domain, UserId, ClientId) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> Text
toBase64Text Map (Domain, UserId, ClientId) ByteString
messages
localMessages :: Map (UserId, ClientId) Text
localMessages = Map (UserId, ClientId) Text
-> Domain
-> Map Domain (Map (UserId, ClientId) Text)
-> Map (UserId, ClientId) Text
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault Map (UserId, ClientId) Text
forall a. Monoid a => a
mempty (Local x -> Domain
forall (t :: QTag) a. QualifiedWithTag t a -> Domain
tDomain Local x
loc) Map Domain (Map (UserId, ClientId) Text)
messageMap
RecipientSet
failed <- Local x
-> UTCTime
-> Qualified UserId
-> ClientId
-> Maybe ConnId
-> Maybe (Qualified ConvId)
-> BotMap
-> MessageMetadata
-> Map (UserId, ClientId) Text
-> Sem r RecipientSet
forall (r :: EffectRow) x.
(Member ExternalAccess r, Member TinyLog r,
Member NotificationSubsystem r) =>
Local x
-> UTCTime
-> Qualified UserId
-> ClientId
-> Maybe ConnId
-> Maybe (Qualified ConvId)
-> BotMap
-> MessageMetadata
-> Map (UserId, ClientId) Text
-> Sem r RecipientSet
sendLocalMessages Local x
loc UTCTime
now Qualified UserId
sender ClientId
senderClient Maybe ConnId
mconn Maybe (Qualified ConvId)
forall a. Maybe a
Nothing BotMap
forall a. Monoid a => a
mempty MessageMetadata
metadata Map (UserId, ClientId) Text
localMessages
QualifiedUserClients -> Sem r QualifiedUserClients
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (QualifiedUserClients -> Sem r QualifiedUserClients)
-> (Map Domain RecipientSet -> QualifiedUserClients)
-> Map Domain RecipientSet
-> Sem r QualifiedUserClients
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map Domain RecipientSet -> QualifiedUserClients
mkQualifiedUserClientsByDomain (Map Domain RecipientSet -> Sem r QualifiedUserClients)
-> Map Domain RecipientSet -> Sem r QualifiedUserClients
forall a b. (a -> b) -> a -> b
$ Domain -> RecipientSet -> Map Domain RecipientSet
forall k a. k -> a -> Map k a
Map.singleton (Local x -> Domain
forall (t :: QTag) a. QualifiedWithTag t a -> Domain
tDomain Local x
loc) RecipientSet
failed
byDomain :: Map (Domain, UserId, ClientId) a -> Map Domain (Map (UserId, ClientId) a)
byDomain :: forall a.
Map (Domain, UserId, ClientId) a
-> Map Domain (Map (UserId, ClientId) a)
byDomain =
((Domain, UserId, ClientId)
-> a
-> Map Domain (Map (UserId, ClientId) a)
-> Map Domain (Map (UserId, ClientId) a))
-> Map Domain (Map (UserId, ClientId) a)
-> Map (Domain, UserId, ClientId) a
-> Map Domain (Map (UserId, ClientId) a)
forall k a b. (k -> a -> b -> b) -> b -> Map k a -> b
Map.foldrWithKey
(\(Domain
d, UserId
u, ClientId
c) a
t -> (Map (UserId, ClientId) a
-> Map (UserId, ClientId) a -> Map (UserId, ClientId) a)
-> Domain
-> Map (UserId, ClientId) a
-> Map Domain (Map (UserId, ClientId) a)
-> Map Domain (Map (UserId, ClientId) a)
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith Map (UserId, ClientId) a
-> Map (UserId, ClientId) a -> Map (UserId, ClientId) a
forall a. Semigroup a => a -> a -> a
(<>) Domain
d ((UserId, ClientId) -> a -> Map (UserId, ClientId) a
forall k a. k -> a -> Map k a
Map.singleton (UserId
u, ClientId
c) a
t))
Map Domain (Map (UserId, ClientId) a)
forall a. Monoid a => a
mempty
sendLocalMessages ::
forall r x.
( Member ExternalAccess r,
Member P.TinyLog r,
Member NotificationSubsystem r
) =>
Local x ->
UTCTime ->
Qualified UserId ->
ClientId ->
Maybe ConnId ->
Maybe (Qualified ConvId) ->
BotMap ->
MessageMetadata ->
Map (UserId, ClientId) Text ->
Sem r (Set (UserId, ClientId))
sendLocalMessages :: forall (r :: EffectRow) x.
(Member ExternalAccess r, Member TinyLog r,
Member NotificationSubsystem r) =>
Local x
-> UTCTime
-> Qualified UserId
-> ClientId
-> Maybe ConnId
-> Maybe (Qualified ConvId)
-> BotMap
-> MessageMetadata
-> Map (UserId, ClientId) Text
-> Sem r RecipientSet
sendLocalMessages Local x
loc UTCTime
now Qualified UserId
sender ClientId
senderClient Maybe ConnId
mconn Maybe (Qualified ConvId)
qcnv BotMap
botMap MessageMetadata
metadata Map (UserId, ClientId) Text
localMessages = do
let events :: Map (UserId, ClientId) Event
events =
Map (UserId, ClientId) Text
localMessages
Map (UserId, ClientId) Text
-> (Map (UserId, ClientId) Text -> Map (UserId, ClientId) Event)
-> Map (UserId, ClientId) Event
forall a b. a -> (a -> b) -> b
& ((UserId, ClientId) -> (Local UserId, ClientId))
-> (Indexed (UserId, ClientId) Text (Identity Event)
-> Map (UserId, ClientId) Text
-> Identity (Map (UserId, ClientId) Event))
-> Indexed (Local UserId, ClientId) Text (Identity Event)
-> Map (UserId, ClientId) Text
-> Identity (Map (UserId, ClientId) Event)
forall j (p :: * -> * -> *) i a b r.
Indexable j p =>
(i -> j) -> (Indexed i a b -> r) -> p a b -> r
reindexed ((UserId -> Local UserId)
-> (UserId, ClientId) -> (Local UserId, ClientId)
forall a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (Local x -> UserId -> Local UserId
forall (t :: QTag) x a.
QualifiedWithTag t x -> a -> QualifiedWithTag t a
qualifyAs Local x
loc)) Indexed (UserId, ClientId) Text (Identity Event)
-> Map (UserId, ClientId) Text
-> Identity (Map (UserId, ClientId) Event)
forall i (t :: * -> *) a b.
TraversableWithIndex i t =>
IndexedTraversal i (t a) (t b) a b
IndexedTraversal
(UserId, ClientId)
(Map (UserId, ClientId) Text)
(Map (UserId, ClientId) Event)
Text
Event
itraversed
(Indexed (Local UserId, ClientId) Text (Identity Event)
-> Map (UserId, ClientId) Text
-> Identity (Map (UserId, ClientId) Event))
-> ((Local UserId, ClientId) -> Text -> Event)
-> Map (UserId, ClientId) Text
-> Map (UserId, ClientId) Event
forall i s t a b.
AnIndexedSetter i s t a b -> (i -> a -> b) -> s -> t
%@~ Maybe (Qualified ConvId)
-> Qualified UserId
-> ClientId
-> Maybe Text
-> UTCTime
-> (Local UserId, ClientId)
-> Text
-> Event
newMessageEvent
Maybe (Qualified ConvId)
qcnv
Qualified UserId
sender
ClientId
senderClient
(MessageMetadata -> Maybe Text
mmData MessageMetadata
metadata)
UTCTime
now
pushes :: Map (UserId, ClientId) MessagePush
pushes =
Map (UserId, ClientId) Event
events
Map (UserId, ClientId) Event
-> (Map (UserId, ClientId) Event
-> Map (UserId, ClientId) MessagePush)
-> Map (UserId, ClientId) MessagePush
forall a b. a -> (a -> b) -> b
& Indexed (UserId, ClientId) Event (Identity MessagePush)
-> Map (UserId, ClientId) Event
-> Identity (Map (UserId, ClientId) MessagePush)
forall i (t :: * -> *) a b.
TraversableWithIndex i t =>
IndexedTraversal i (t a) (t b) a b
IndexedTraversal
(UserId, ClientId)
(Map (UserId, ClientId) Event)
(Map (UserId, ClientId) MessagePush)
Event
MessagePush
itraversed
(Indexed (UserId, ClientId) Event (Identity MessagePush)
-> Map (UserId, ClientId) Event
-> Identity (Map (UserId, ClientId) MessagePush))
-> ((UserId, ClientId) -> Event -> MessagePush)
-> Map (UserId, ClientId) Event
-> Map (UserId, ClientId) MessagePush
forall i s t a b.
AnIndexedSetter i s t a b -> (i -> a -> b) -> s -> t
%@~ (\(UserId
u, ClientId
c) -> BotMap
-> Maybe ConnId
-> MessageMetadata
-> [(UserId, ClientId)]
-> Event
-> MessagePush
forall r.
ToRecipient r =>
BotMap
-> Maybe ConnId -> MessageMetadata -> [r] -> Event -> MessagePush
newMessagePush BotMap
botMap Maybe ConnId
mconn MessageMetadata
metadata [(UserId
u, ClientId
c)])
Map (UserId, ClientId) MessagePush
-> (MessagePush -> Sem r ()) -> Sem r ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Map (UserId, ClientId) MessagePush
pushes ((MessagePush -> Sem r ()) -> Sem r ())
-> (MessagePush -> Sem r ()) -> Sem r ()
forall a b. (a -> b) -> a -> b
$ Local x -> 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 x
loc Maybe (Qualified ConvId)
qcnv
RecipientSet -> Sem r RecipientSet
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure RecipientSet
forall a. Monoid a => a
mempty
sendRemoteMessages ::
forall r x.
( Member BackendNotificationQueueAccess r,
Member P.TinyLog r
) =>
Remote x ->
UTCTime ->
Qualified UserId ->
ClientId ->
Local ConvId ->
MessageMetadata ->
Map (UserId, ClientId) Text ->
Sem r (Set (UserId, ClientId))
sendRemoteMessages :: forall (r :: EffectRow) x.
(Member BackendNotificationQueueAccess r, Member TinyLog r) =>
Remote x
-> UTCTime
-> Qualified UserId
-> ClientId
-> Local ConvId
-> MessageMetadata
-> Map (UserId, ClientId) Text
-> Sem r RecipientSet
sendRemoteMessages Remote x
domain UTCTime
now Qualified UserId
sender ClientId
senderClient Local ConvId
lcnv MessageMetadata
metadata Map (UserId, ClientId) Text
messages =
(Either FederationError () -> Sem r RecipientSet
forall a. Either FederationError a -> Sem r RecipientSet
handle (Either FederationError () -> Sem r RecipientSet)
-> (Sem (Error FederationError : r) ()
-> Sem r (Either FederationError ()))
-> Sem (Error FederationError : r) ()
-> Sem r RecipientSet
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Sem (Error FederationError : r) ()
-> Sem r (Either FederationError ())
forall e (r :: EffectRow) a.
Sem (Error e : r) a -> Sem r (Either e a)
runError) (Sem (Error FederationError : r) () -> Sem r RecipientSet)
-> Sem (Error FederationError : r) () -> Sem r RecipientSet
forall a b. (a -> b) -> a -> b
$ do
let rcpts :: Map UserId (Map ClientId Text)
rcpts =
(((UserId, ClientId), Text)
-> Map UserId (Map ClientId Text)
-> Map UserId (Map ClientId Text))
-> Map UserId (Map ClientId Text)
-> [((UserId, ClientId), Text)]
-> Map UserId (Map ClientId Text)
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr
(\((UserId
u, ClientId
c), Text
t) -> (Map ClientId Text -> Map ClientId Text -> Map ClientId Text)
-> UserId
-> Map ClientId Text
-> Map UserId (Map ClientId Text)
-> Map UserId (Map ClientId Text)
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith Map ClientId Text -> Map ClientId Text -> Map ClientId Text
forall a. Semigroup a => a -> a -> a
(<>) UserId
u (ClientId -> Text -> Map ClientId Text
forall k a. k -> a -> Map k a
Map.singleton ClientId
c Text
t))
Map UserId (Map ClientId Text)
forall a. Monoid a => a
mempty
(Map (UserId, ClientId) Text -> [((UserId, ClientId), Text)]
forall k a. Map k a -> [(k, a)]
Map.assocs Map (UserId, ClientId) Text
messages)
rm :: RemoteMessage ConvId
rm =
RemoteMessage
{ $sel:time:RemoteMessage :: UTCTime
time = UTCTime
now,
$sel:_data:RemoteMessage :: Maybe Text
_data = MessageMetadata -> Maybe Text
mmData MessageMetadata
metadata,
$sel:sender:RemoteMessage :: Qualified UserId
sender = Qualified UserId
sender,
$sel:senderClient:RemoteMessage :: ClientId
senderClient = ClientId
senderClient,
$sel:conversation:RemoteMessage :: ConvId
conversation = Local ConvId -> ConvId
forall (t :: QTag) a. QualifiedWithTag t a -> a
tUnqualified Local ConvId
lcnv,
$sel:priority:RemoteMessage :: Maybe Priority
priority = MessageMetadata -> Maybe Priority
mmNativePriority MessageMetadata
metadata,
$sel:push:RemoteMessage :: Bool
push = MessageMetadata -> Bool
mmNativePush MessageMetadata
metadata,
$sel:transient:RemoteMessage :: Bool
transient = MessageMetadata -> Bool
mmTransient MessageMetadata
metadata,
$sel:recipients:RemoteMessage :: UserClientMap Text
recipients = Map UserId (Map ClientId Text) -> UserClientMap Text
forall a. Map UserId (Map ClientId a) -> UserClientMap a
UserClientMap Map UserId (Map ClientId Text)
rcpts
}
DeliveryMode
-> Remote x
-> FedQueueClient 'Galley ()
-> Sem (Error FederationError : r) ()
forall (c :: Component) (r :: EffectRow) x a.
(KnownComponent c, Member (Error FederationError) r,
Member BackendNotificationQueueAccess r) =>
DeliveryMode -> Remote x -> FedQueueClient c a -> Sem r a
enqueueNotification DeliveryMode
Q.Persistent Remote x
domain (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 @'OnMessageSentTag Payload 'OnMessageSentTag
RemoteMessage ConvId
rm)
where
handle :: Either FederationError a -> Sem r (Set (UserId, ClientId))
handle :: forall a. Either FederationError a -> Sem r RecipientSet
handle (Right a
_) = RecipientSet -> Sem r RecipientSet
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure RecipientSet
forall a. Monoid a => a
mempty
handle (Left FederationError
e) = do
(Msg -> Msg) -> Sem r ()
forall msg (r :: EffectRow).
Member (Logger msg) r =>
msg -> Sem r ()
P.warn ((Msg -> Msg) -> Sem r ()) -> (Msg -> Msg) -> Sem r ()
forall a b. (a -> b) -> a -> b
$
ByteString -> ByteString -> Msg -> Msg
forall a. ToBytes a => ByteString -> a -> Msg -> Msg
Log.field ByteString
"conversation" (ConvId -> ByteString
forall a. ToByteString a => a -> ByteString
toByteString' (Local ConvId -> ConvId
forall (t :: QTag) a. QualifiedWithTag t a -> a
tUnqualified Local ConvId
lcnv))
(Msg -> Msg) -> (Msg -> Msg) -> Msg -> Msg
forall b c a. (b -> c) -> (a -> b) -> a -> c
Log.~~ ByteString -> ByteString -> Msg -> Msg
forall a. ToBytes a => ByteString -> a -> Msg -> Msg
Log.field ByteString
"domain" (Domain -> ByteString
forall a. ToByteString a => a -> ByteString
toByteString' (Remote x -> Domain
forall (t :: QTag) a. QualifiedWithTag t a -> Domain
tDomain Remote x
domain))
(Msg -> Msg) -> (Msg -> Msg) -> Msg -> Msg
forall b c a. (b -> c) -> (a -> b) -> a -> c
Log.~~ ByteString -> ByteString -> Msg -> Msg
forall a. ToBytes a => ByteString -> a -> Msg -> Msg
Log.field ByteString
"exception" (Error -> ByteString
forall a. ToJSON a => a -> ByteString
encode (FederationError -> Error
federationErrorToWai FederationError
e))
(Msg -> Msg) -> (Msg -> Msg) -> Msg -> Msg
forall b c a. (b -> c) -> (a -> b) -> a -> c
Log.~~ Text -> Msg -> Msg
forall a. ToBytes a => a -> Msg -> Msg
Log.msg (Text
"Remote message sending failed" :: Text)
RecipientSet -> Sem r RecipientSet
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map (UserId, ClientId) Text -> RecipientSet
forall k a. Map k a -> Set k
Map.keysSet Map (UserId, ClientId) Text
messages)
flattenMap :: QualifiedOtrRecipients -> Map (Domain, UserId, ClientId) ByteString
flattenMap :: QualifiedOtrRecipients -> Map (Domain, UserId, ClientId) ByteString
flattenMap (QualifiedOtrRecipients (QualifiedUserClientMap Map Domain (Map UserId (Map ClientId ByteString))
m)) =
IndexedGetting
(Domain, UserId, ClientId)
(Map (Domain, UserId, ClientId) ByteString)
(Map Domain (Map UserId (Map ClientId ByteString)))
ByteString
-> Map Domain (Map UserId (Map ClientId ByteString))
-> Map (Domain, UserId, ClientId) ByteString
forall i a s. IndexedGetting i (Map i a) s a -> s -> Map i a
toMapOf (((Domain, (UserId, ClientId)) -> (Domain, UserId, ClientId))
-> (Indexed
(Domain, (UserId, ClientId))
ByteString
(Const (Map (Domain, UserId, ClientId) ByteString) ByteString)
-> Map Domain (Map UserId (Map ClientId ByteString))
-> Const
(Map (Domain, UserId, ClientId) ByteString)
(Map Domain (Map UserId (Map ClientId ByteString))))
-> IndexedGetting
(Domain, UserId, ClientId)
(Map (Domain, UserId, ClientId) ByteString)
(Map Domain (Map UserId (Map ClientId ByteString)))
ByteString
forall j (p :: * -> * -> *) i a b r.
Indexable j p =>
(i -> j) -> (Indexed i a b -> r) -> p a b -> r
reindexed (\(Domain
d, (UserId
u, ClientId
c)) -> (Domain
d, UserId
u, ClientId
c)) (Indexed
Domain
(Map UserId (Map ClientId ByteString))
(Const
(Map (Domain, UserId, ClientId) ByteString)
(Map UserId (Map ClientId ByteString)))
-> Map Domain (Map UserId (Map ClientId ByteString))
-> Const
(Map (Domain, UserId, ClientId) ByteString)
(Map Domain (Map UserId (Map ClientId ByteString)))
forall i (t :: * -> *) a b.
TraversableWithIndex i t =>
IndexedTraversal i (t a) (t b) a b
IndexedTraversal
Domain
(Map Domain (Map UserId (Map ClientId ByteString)))
(Map Domain (Map UserId (Map ClientId ByteString)))
(Map UserId (Map ClientId ByteString))
(Map UserId (Map ClientId ByteString))
itraversed (Indexed
Domain
(Map UserId (Map ClientId ByteString))
(Const
(Map (Domain, UserId, ClientId) ByteString)
(Map UserId (Map ClientId ByteString)))
-> Map Domain (Map UserId (Map ClientId ByteString))
-> Const
(Map (Domain, UserId, ClientId) ByteString)
(Map Domain (Map UserId (Map ClientId ByteString))))
-> (Indexed
(UserId, ClientId)
ByteString
(Const (Map (Domain, UserId, ClientId) ByteString) ByteString)
-> Map UserId (Map ClientId ByteString)
-> Const
(Map (Domain, UserId, ClientId) ByteString)
(Map UserId (Map ClientId ByteString)))
-> Indexed
(Domain, (UserId, ClientId))
ByteString
(Const (Map (Domain, UserId, ClientId) ByteString) ByteString)
-> Map Domain (Map UserId (Map ClientId ByteString))
-> Const
(Map (Domain, UserId, ClientId) ByteString)
(Map Domain (Map UserId (Map ClientId ByteString)))
forall i j (p :: * -> * -> *) s t r a b.
Indexable (i, j) p =>
(Indexed i s t -> r) -> (Indexed j a b -> s -> t) -> p a b -> r
<.> Indexed
UserId
(Map ClientId ByteString)
(Const
(Map (Domain, UserId, ClientId) ByteString)
(Map ClientId ByteString))
-> Map UserId (Map ClientId ByteString)
-> Const
(Map (Domain, UserId, ClientId) ByteString)
(Map UserId (Map ClientId ByteString))
forall i (t :: * -> *) a b.
TraversableWithIndex i t =>
IndexedTraversal i (t a) (t b) a b
IndexedTraversal
UserId
(Map UserId (Map ClientId ByteString))
(Map UserId (Map ClientId ByteString))
(Map ClientId ByteString)
(Map ClientId ByteString)
itraversed (Indexed
UserId
(Map ClientId ByteString)
(Const
(Map (Domain, UserId, ClientId) ByteString)
(Map ClientId ByteString))
-> Map UserId (Map ClientId ByteString)
-> Const
(Map (Domain, UserId, ClientId) ByteString)
(Map UserId (Map ClientId ByteString)))
-> (Indexed
ClientId
ByteString
(Const (Map (Domain, UserId, ClientId) ByteString) ByteString)
-> Map ClientId ByteString
-> Const
(Map (Domain, UserId, ClientId) ByteString)
(Map ClientId ByteString))
-> Indexed
(UserId, ClientId)
ByteString
(Const (Map (Domain, UserId, ClientId) ByteString) ByteString)
-> Map UserId (Map ClientId ByteString)
-> Const
(Map (Domain, UserId, ClientId) ByteString)
(Map UserId (Map ClientId ByteString))
forall i j (p :: * -> * -> *) s t r a b.
Indexable (i, j) p =>
(Indexed i s t -> r) -> (Indexed j a b -> s -> t) -> p a b -> r
<.> Indexed
ClientId
ByteString
(Const (Map (Domain, UserId, ClientId) ByteString) ByteString)
-> Map ClientId ByteString
-> Const
(Map (Domain, UserId, ClientId) ByteString)
(Map ClientId ByteString)
forall i (t :: * -> *) a b.
TraversableWithIndex i t =>
IndexedTraversal i (t a) (t b) a b
IndexedTraversal
ClientId
(Map ClientId ByteString)
(Map ClientId ByteString)
ByteString
ByteString
itraversed)) Map Domain (Map UserId (Map ClientId ByteString))
m
newMessageEvent ::
Maybe (Qualified ConvId) ->
Qualified UserId ->
ClientId ->
Maybe Text ->
UTCTime ->
(Local UserId, ClientId) ->
Text ->
Event
newMessageEvent :: Maybe (Qualified ConvId)
-> Qualified UserId
-> ClientId
-> Maybe Text
-> UTCTime
-> (Local UserId, ClientId)
-> Text
-> Event
newMessageEvent Maybe (Qualified ConvId)
mconvId Qualified UserId
sender ClientId
senderClient Maybe Text
dat UTCTime
time (Local UserId
receiver, ClientId
receiverClient) Text
cipherText =
let convId :: Qualified ConvId
convId = Qualified ConvId -> Maybe (Qualified ConvId) -> Qualified ConvId
forall a. a -> Maybe a -> a
fromMaybe (Local ConvId -> Qualified ConvId
forall (t :: QTag) a. QualifiedWithTag t a -> Qualified a
tUntagged ((UserId -> ConvId) -> Local UserId -> Local ConvId
forall a b.
(a -> b)
-> QualifiedWithTag 'QLocal a -> QualifiedWithTag 'QLocal b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap UserId -> ConvId
selfConv Local UserId
receiver)) Maybe (Qualified ConvId)
mconvId
in Qualified ConvId
-> Maybe SubConvId
-> Qualified UserId
-> UTCTime
-> EventData
-> Event
Event Qualified ConvId
convId Maybe SubConvId
forall a. Maybe a
Nothing Qualified UserId
sender UTCTime
time (EventData -> Event)
-> (OtrMessage -> EventData) -> OtrMessage -> Event
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OtrMessage -> EventData
EdOtrMessage (OtrMessage -> Event) -> OtrMessage -> Event
forall a b. (a -> b) -> a -> b
$
OtrMessage
{ $sel:otrSender:OtrMessage :: ClientId
otrSender = ClientId
senderClient,
$sel:otrRecipient:OtrMessage :: ClientId
otrRecipient = ClientId
receiverClient,
$sel:otrCiphertext:OtrMessage :: Text
otrCiphertext = Text
cipherText,
$sel:otrData:OtrMessage :: Maybe Text
otrData = Maybe Text
dat
}
legacyClientMismatchStrategy :: Domain -> Maybe [UserId] -> Maybe IgnoreMissing -> Maybe ReportMissing -> ClientMismatchStrategy
legacyClientMismatchStrategy :: Domain
-> Maybe [UserId]
-> Maybe IgnoreMissing
-> Maybe ReportMissing
-> ClientMismatchStrategy
legacyClientMismatchStrategy Domain
localDomain (Just [UserId]
uids) Maybe IgnoreMissing
_ Maybe ReportMissing
_ =
Set (Qualified UserId) -> ClientMismatchStrategy
MismatchReportOnly ([Qualified UserId] -> Set (Qualified UserId)
forall a. Ord a => [a] -> Set a
Set.fromList ((UserId -> Qualified UserId) -> [UserId] -> [Qualified UserId]
forall a b. (a -> b) -> [a] -> [b]
map (UserId -> Domain -> Qualified UserId
forall a. a -> Domain -> Qualified a
`Qualified` Domain
localDomain) [UserId]
uids))
legacyClientMismatchStrategy Domain
_ Maybe [UserId]
Nothing (Just IgnoreMissing
IgnoreMissingAll) Maybe ReportMissing
_ = ClientMismatchStrategy
MismatchIgnoreAll
legacyClientMismatchStrategy Domain
localDomain Maybe [UserId]
Nothing (Just (IgnoreMissingList Set UserId
uids)) Maybe ReportMissing
_ =
Set (Qualified UserId) -> ClientMismatchStrategy
MismatchIgnoreOnly ((UserId -> Qualified UserId)
-> Set UserId -> Set (Qualified UserId)
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map (UserId -> Domain -> Qualified UserId
forall a. a -> Domain -> Qualified a
`Qualified` Domain
localDomain) Set UserId
uids)
legacyClientMismatchStrategy Domain
_ Maybe [UserId]
Nothing Maybe IgnoreMissing
Nothing (Just ReportMissing
ReportMissingAll) = ClientMismatchStrategy
MismatchReportAll
legacyClientMismatchStrategy Domain
localDomain Maybe [UserId]
Nothing Maybe IgnoreMissing
Nothing (Just (ReportMissingList Set UserId
uids)) =
Set (Qualified UserId) -> ClientMismatchStrategy
MismatchReportOnly ((UserId -> Qualified UserId)
-> Set UserId -> Set (Qualified UserId)
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map (UserId -> Domain -> Qualified UserId
forall a. a -> Domain -> Qualified a
`Qualified` Domain
localDomain) Set UserId
uids)
legacyClientMismatchStrategy Domain
_ Maybe [UserId]
Nothing Maybe IgnoreMissing
Nothing Maybe ReportMissing
Nothing = ClientMismatchStrategy
MismatchReportAll
class Unqualify a b where
unqualify :: Domain -> a -> b
instance Unqualify a a where
unqualify :: Domain -> a -> a
unqualify Domain
_ = a -> a
forall a. a -> a
Imports.id
instance Unqualify MessageSendingStatus ClientMismatch where
unqualify :: Domain -> MessageSendingStatus -> ClientMismatch
unqualify Domain
domain MessageSendingStatus
status =
ClientMismatch
{ $sel:cmismatchTime:ClientMismatch :: UTCTimeMillis
cmismatchTime = MessageSendingStatus -> UTCTimeMillis
mssTime MessageSendingStatus
status,
$sel:missingClients:ClientMismatch :: UserClients
missingClients = Domain -> QualifiedUserClients -> UserClients
forall a b. Unqualify a b => Domain -> a -> b
unqualify Domain
domain (MessageSendingStatus -> QualifiedUserClients
mssMissingClients MessageSendingStatus
status),
$sel:redundantClients:ClientMismatch :: UserClients
redundantClients = Domain -> QualifiedUserClients -> UserClients
forall a b. Unqualify a b => Domain -> a -> b
unqualify Domain
domain (MessageSendingStatus -> QualifiedUserClients
mssRedundantClients MessageSendingStatus
status),
$sel:deletedClients:ClientMismatch :: UserClients
deletedClients = Domain -> QualifiedUserClients -> UserClients
forall a b. Unqualify a b => Domain -> a -> b
unqualify Domain
domain (MessageSendingStatus -> QualifiedUserClients
mssDeletedClients MessageSendingStatus
status)
}
instance Unqualify QualifiedUserClients UserClients where
unqualify :: Domain -> QualifiedUserClients -> UserClients
unqualify Domain
domain =
Map UserId (Set ClientId) -> UserClients
UserClients
(Map UserId (Set ClientId) -> UserClients)
-> (QualifiedUserClients -> Map UserId (Set ClientId))
-> QualifiedUserClients
-> UserClients
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map UserId (Set ClientId)
-> Domain
-> Map Domain (Map UserId (Set ClientId))
-> Map UserId (Set ClientId)
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault Map UserId (Set ClientId)
forall a. Monoid a => a
mempty Domain
domain
(Map Domain (Map UserId (Set ClientId))
-> Map UserId (Set ClientId))
-> (QualifiedUserClients -> Map Domain (Map UserId (Set ClientId)))
-> QualifiedUserClients
-> Map UserId (Set ClientId)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QualifiedUserClients -> Map Domain (Map UserId (Set ClientId))
qualifiedUserClients
instance (Unqualify a b) => Unqualify (PostOtrResponse a) (PostOtrResponse b) where
unqualify :: Domain -> PostOtrResponse a -> PostOtrResponse b
unqualify Domain
domain (Left MessageNotSent a
a) = MessageNotSent b -> PostOtrResponse b
forall a b. a -> Either a b
Left (Domain -> a -> b
forall a b. Unqualify a b => Domain -> a -> b
unqualify Domain
domain (a -> b) -> MessageNotSent a -> MessageNotSent b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MessageNotSent a
a)
unqualify Domain
domain (Right a
a) = b -> PostOtrResponse b
forall a b. b -> Either a b
Right (Domain -> a -> b
forall a b. Unqualify a b => Domain -> a -> b
unqualify Domain
domain a
a)