-- This file is part of the Wire Server implementation.
--
-- Copyright (C) 2022 Wire Swiss GmbH <opensource@wire.com>
--
-- This program is free software: you can redistribute it and/or modify it under
-- the terms of the GNU Affero General Public License as published by the Free
-- Software Foundation, either version 3 of the License, or (at your option) any
-- later version.
--
-- This program is distributed in the hope that it will be useful, but WITHOUT
-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more
-- details.
--
-- You should have received a copy of the GNU Affero General Public License along
-- with this program. If not, see <https://www.gnu.org/licenses/>.

module Galley.API.Message
  ( UserType (..),
    sendLocalMessages,
    postQualifiedOtrMessage,
    postBroadcast,
    postRemoteOtrMessage,
    legacyClientMismatchStrategy,
    Unqualify (..),
    userToProtectee,
    MessageMetadata (..),

    -- * Only exported for tests
    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))

-- A Venn diagram of words in this function:
--
--                +-----------------------------------+
--                |                                   |
--    +---------->|                 +-----------------+--------------------+
--    |           |                 |                 |                    | <----------+
--    |           |                 |                 |   Deleted Clients  |            |
--    |           |                 |                 |   (clients of users from conv   |
-- Expected       |                 |                 |   that have been deleted)       |   Recipients
-- Clients        |  Missing        | Valid           |       Extra        |                (from the request)
-- (actually in   |  Clients        | Clients         +-------Clients------+----------+
-- conversation)  |                 | (these will     |                    |          |
--                |                 | actually receive|                    |          |
--                |                 | the msg)        |       Redundant Clients     <------- Sender Client
--                |                 |                 |       (clients that are not   |
--                |                 |                 |       part of conv for        |
--                |                 |                 |       whatever reason + sender)
--                |                 +--------------------------------------+----------+
--                |                                   |
--                +-----------------------------------+
checkMessageClients ::
  -- | Sender
  (Domain, UserId, ClientId) ->
  -- | Participants of the conversation
  --
  -- When the set of clients for a given user is empty, that means the user is
  -- present in the conversation, but has no clients at all, and this is a
  -- valid state.
  Map (Domain, UserId) (Set ClientId) ->
  -- | Provided recipients and ciphertexts
  Map (Domain, UserId, ClientId) ByteString ->
  -- | Subset of missing clients to report
  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
      -- Whoever is expected but not in recipients is missing.
      missing :: QualifiedRecipientSet
missing = QualifiedRecipientSet
-> QualifiedRecipientSet -> QualifiedRecipientSet
forall a. Ord a => Set a -> Set a -> Set a
Set.difference QualifiedRecipientSet
expected QualifiedRecipientSet
recipients
      -- Whoever is in recipient but not expected is extra.
      extra :: QualifiedRecipientSet
extra = QualifiedRecipientSet
-> QualifiedRecipientSet -> QualifiedRecipientSet
forall a. Ord a => Set a -> Set a -> Set a
Set.difference QualifiedRecipientSet
recipients QualifiedRecipientSet
expected
      -- The clients which belong to users who are expected are considered deleted.
      deleted :: QualifiedRecipientSet
deleted =
        (Domain, UserId, ClientId)
-> QualifiedRecipientSet -> QualifiedRecipientSet
forall a. Ord a => a -> Set a -> Set a
Set.delete (Domain, UserId, ClientId)
sender -- the sender is never deleted
          (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
      -- The clients which are extra but not deleted, must belong to users which
      -- are not in the conversation and hence considered redundant.
      redundant :: QualifiedRecipientSet
redundant = QualifiedRecipientSet
-> QualifiedRecipientSet -> QualifiedRecipientSet
forall a. Ord a => Set a -> Set a -> Set a
Set.difference QualifiedRecipientSet
extra QualifiedRecipientSet
deleted
      -- The clients which are both recipients and expected are considered valid.
      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
      -- Resolve whether the message is valid using client mismatch strategy
      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 =
  -- concatenating maps is correct here, because their sets of keys are disjoint
  -- Use runFederatedConcurrentlyEither so we can catch federation errors and report to clients
  -- which domains and users aren't contactable at the moment.
  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
  -- If we are going to fan this out to more than limit, we want to fail early
  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
  -- In large teams, we may still use the broadcast endpoint but only if `report_missing`
  -- is used and length `report_missing` < limit since we cannot fetch larger teams than
  -- that.
  [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
      -- Note: remote ids are not in a local team
      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

      -- check if the sender is part of the conversation
      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

      -- get local clients
      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

      -- get remote clients
      [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 -- concatenating maps is correct here, because their sets of keys are disjoint
          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
          -- Try to get the client IDs for the users that we failed to fetch clients for from the recipient list.
          -- Partition the list of users into those that we were able to find clients for and those that we weren't.
          ([((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
      -- check if the sender client exists (as one of the clients in the conversation)
      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

      -- throw error if there is a legalhold policy conflict
      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

      -- throw error if clients are missing
      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 -- List of the clients that are initially flagged as redundant.
          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
          -- List of users that we couldn't fetch clients for. Used to get their "redundant"
          -- clients for reporting as failedToSend.
          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
          -- failedToConfirmRemoteClients doesn't contain client IDs, so those need to be excluded
          -- from the filter search. We have to focus on only the domain and user. These clients
          -- should be listed in the failedToSend field however, as tracking these clients is an
          -- important part of the proteus protocol.
          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'
          -- Failed users/clients aren't redundant
          ([(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
    -- Get the triples for domains, users, and clients so we can easily filter
    -- out the values from redundant clients that should be in failed to send.
    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'

    -- Rebuild the map, concatenating results along the way.
    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)

-- FUTUREWORK: This is just a workaround and would not be needed if we had a proper monoid/semigroup instance for Map where the values have a monoid instance.
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)

-- | Send both local and remote messages, return the set of clients for which
-- sending has failed.
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

-- | Send remote messages to the backend given by the domain argument, and
-- return the set of clients for which sending has failed. In case there was no
-- failure, the empty set is returned.
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 =
  -- FUTUREWORK: a FederationError here just means that queueing did not work.
  -- It should not result in clients ending up in failedToSend.
  (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
          }

-- unqualified

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)