module Galley.API.Action
(
ConversationActionTag (..),
ConversationJoin (..),
ConversationMemberUpdate (..),
HasConversationActionEffects,
HasConversationActionGalleyErrors,
updateLocalConversation,
updateLocalConversationUnchecked,
NoChanges (..),
LocalConversationUpdate (..),
notifyTypingIndicator,
pushTypingIndicatorEvents,
ensureConversationActionAllowed,
addMembersToLocalConversation,
notifyConversationAction,
updateLocalStateOfRemoteConv,
addLocalUsersToRemoteConv,
ConversationUpdate,
getFederationStatus,
checkFederationStatus,
firstConflictOrFullyConnected,
)
where
import Control.Arrow ((&&&))
import Control.Error (headMay)
import Control.Lens
import Data.ByteString.Conversion (toByteString')
import Data.Domain (Domain (..))
import Data.Id
import Data.Json.Util
import Data.Kind
import Data.List qualified as List
import Data.List.Extra (nubOrd)
import Data.List.NonEmpty (nonEmpty)
import Data.List.NonEmpty qualified as NE
import Data.Map qualified as Map
import Data.Misc
import Data.Qualified
import Data.Set ((\\))
import Data.Set qualified as Set
import Data.Singletons
import Data.Time.Clock
import Galley.API.Error
import Galley.API.MLS.Conversation
import Galley.API.MLS.Migration
import Galley.API.MLS.Removal
import Galley.API.Teams.Features.Get
import Galley.API.Util
import Galley.Data.Conversation
import Galley.Data.Conversation qualified as Data
import Galley.Data.Conversation.Types
import Galley.Data.Scope (Scope (ReusableCode))
import Galley.Data.Services
import Galley.Effects
import Galley.Effects.BackendNotificationQueueAccess
import Galley.Effects.BotAccess qualified as E
import Galley.Effects.BrigAccess qualified as E
import Galley.Effects.CodeStore qualified as E
import Galley.Effects.ConversationStore qualified as E
import Galley.Effects.FederatorAccess qualified as E
import Galley.Effects.FireAndForget qualified as E
import Galley.Effects.MemberStore qualified as E
import Galley.Effects.ProposalStore qualified as E
import Galley.Effects.SubConversationStore qualified as E
import Galley.Effects.TeamStore qualified as E
import Galley.Env (Env)
import Galley.Options
import Galley.Types.Conversations.Members
import Galley.Types.UserList
import Galley.Validation
import Imports hiding ((\\))
import Network.AMQP qualified as Q
import Polysemy
import Polysemy.Error
import Polysemy.Input
import Polysemy.TinyLog
import Polysemy.TinyLog qualified as P
import System.Logger qualified as Log
import Wire.API.Connection (Relation (Accepted))
import Wire.API.Conversation hiding (Conversation, Member)
import Wire.API.Conversation.Action
import Wire.API.Conversation.Protocol
import Wire.API.Conversation.Role
import Wire.API.Conversation.Typing
import Wire.API.Error
import Wire.API.Error.Galley
import Wire.API.Event.Conversation
import Wire.API.Event.LeaveReason
import Wire.API.Federation.API
import Wire.API.Federation.API.Brig
import Wire.API.Federation.API.Galley
import Wire.API.Federation.API.Galley qualified as F
import Wire.API.Federation.Error
import Wire.API.FederationStatus
import Wire.API.Push.V2 qualified as PushV2
import Wire.API.Routes.Internal.Brig.Connection
import Wire.API.Team.Feature
import Wire.API.Team.LegalHold
import Wire.API.Team.Member
import Wire.API.Team.Permission (Perm (AddRemoveConvMember, ModifyConvName))
import Wire.API.User qualified as User
import Wire.NotificationSubsystem
data NoChanges = NoChanges
type family HasConversationActionEffects (tag :: ConversationActionTag) r :: Constraint where
HasConversationActionEffects 'ConversationJoinTag r =
( Member BrigAccess r,
Member (Error FederationError) r,
Member (Error InternalError) r,
Member (ErrorS 'NotATeamMember) r,
Member (ErrorS 'NotConnected) r,
Member (ErrorS ('ActionDenied 'LeaveConversation)) r,
Member (ErrorS ('ActionDenied 'AddConversationMember)) r,
Member (ErrorS 'InvalidOperation) r,
Member (ErrorS 'ConvAccessDenied) r,
Member (ErrorS 'ConvNotFound) r,
Member (ErrorS 'TooManyMembers) r,
Member (ErrorS 'MissingLegalholdConsent) r,
Member (Error NonFederatingBackends) r,
Member (Error UnreachableBackends) r,
Member ExternalAccess r,
Member FederatorAccess r,
Member NotificationSubsystem r,
Member (Input Env) r,
Member (Input Opts) r,
Member (Input UTCTime) r,
Member LegalHoldStore r,
Member MemberStore r,
Member ProposalStore r,
Member Random r,
Member SubConversationStore r,
Member TeamStore r,
Member TinyLog r,
Member ConversationStore r,
Member (Error NoChanges) r
)
HasConversationActionEffects 'ConversationLeaveTag r =
( Member MemberStore r,
Member (Error InternalError) r,
Member (Error NoChanges) r,
Member ExternalAccess r,
Member FederatorAccess r,
Member NotificationSubsystem r,
Member (Input UTCTime) r,
Member (Input Env) r,
Member ProposalStore r,
Member SubConversationStore r,
Member Random r,
Member TinyLog r
)
HasConversationActionEffects 'ConversationRemoveMembersTag r =
( Member MemberStore r,
Member (Error NoChanges) r,
Member SubConversationStore r,
Member ProposalStore r,
Member (Input Env) r,
Member (Input UTCTime) r,
Member ExternalAccess r,
Member FederatorAccess r,
Member NotificationSubsystem r,
Member (Error InternalError) r,
Member Random r,
Member TinyLog r,
Member (Error NoChanges) r
)
HasConversationActionEffects 'ConversationMemberUpdateTag r =
( Member MemberStore r,
Member (ErrorS 'ConvMemberNotFound) r
)
HasConversationActionEffects 'ConversationDeleteTag r =
( Member BrigAccess r,
Member CodeStore r,
Member ConversationStore r,
Member (Error FederationError) r,
Member (ErrorS 'NotATeamMember) r,
Member FederatorAccess r,
Member MemberStore r,
Member ProposalStore r,
Member SubConversationStore r,
Member TeamStore r
)
HasConversationActionEffects 'ConversationRenameTag r =
( Member (Error InvalidInput) r,
Member ConversationStore r,
Member TeamStore r,
Member (ErrorS InvalidOperation) r
)
HasConversationActionEffects 'ConversationAccessDataTag r =
( Member BotAccess r,
Member BrigAccess r,
Member CodeStore r,
Member (Error InternalError) r,
Member (Error InvalidInput) r,
Member (Error NoChanges) r,
Member (ErrorS 'InvalidTargetAccess) r,
Member (ErrorS ('ActionDenied 'RemoveConversationMember)) r,
Member ExternalAccess r,
Member FederatorAccess r,
Member FireAndForget r,
Member NotificationSubsystem r,
Member (Input Env) r,
Member MemberStore r,
Member ProposalStore r,
Member TeamStore r,
Member TinyLog r,
Member (Input UTCTime) r,
Member ConversationStore r,
Member SubConversationStore r,
Member Random r
)
HasConversationActionEffects 'ConversationMessageTimerUpdateTag r =
( Member ConversationStore r,
Member (Error NoChanges) r
)
HasConversationActionEffects 'ConversationReceiptModeUpdateTag r =
( Member ConversationStore r,
Member (Error NoChanges) r
)
HasConversationActionEffects 'ConversationUpdateProtocolTag r =
( Member ConversationStore r,
Member (ErrorS 'ConvInvalidProtocolTransition) r,
Member (ErrorS 'MLSMigrationCriteriaNotSatisfied) r,
Member (Error NoChanges) r,
Member BrigAccess r,
Member ExternalAccess r,
Member FederatorAccess r,
Member NotificationSubsystem r,
Member (Input Env) r,
Member (Input Opts) r,
Member (Input UTCTime) r,
Member MemberStore r,
Member ProposalStore r,
Member Random r,
Member SubConversationStore r,
Member TeamFeatureStore r,
Member TinyLog r
)
type family HasConversationActionGalleyErrors (tag :: ConversationActionTag) :: EffectRow where
HasConversationActionGalleyErrors 'ConversationJoinTag =
'[ ErrorS ('ActionDenied 'LeaveConversation),
ErrorS ('ActionDenied 'AddConversationMember),
ErrorS 'NotATeamMember,
ErrorS 'InvalidOperation,
ErrorS 'ConvNotFound,
ErrorS 'NotConnected,
ErrorS 'ConvAccessDenied,
ErrorS 'TooManyMembers,
ErrorS 'MissingLegalholdConsent
]
HasConversationActionGalleyErrors 'ConversationLeaveTag =
'[ ErrorS ('ActionDenied 'LeaveConversation),
ErrorS 'InvalidOperation,
ErrorS 'ConvNotFound
]
HasConversationActionGalleyErrors 'ConversationRemoveMembersTag =
'[ ErrorS ('ActionDenied 'RemoveConversationMember),
ErrorS 'InvalidOperation,
ErrorS 'ConvNotFound
]
HasConversationActionGalleyErrors 'ConversationMemberUpdateTag =
'[ ErrorS ('ActionDenied 'ModifyOtherConversationMember),
ErrorS 'InvalidOperation,
ErrorS 'ConvNotFound,
ErrorS 'ConvMemberNotFound
]
HasConversationActionGalleyErrors 'ConversationDeleteTag =
'[ ErrorS ('ActionDenied 'DeleteConversation),
ErrorS 'NotATeamMember,
ErrorS 'InvalidOperation,
ErrorS 'ConvNotFound
]
HasConversationActionGalleyErrors 'ConversationRenameTag =
'[ ErrorS ('ActionDenied 'ModifyConversationName),
ErrorS 'InvalidOperation,
ErrorS 'ConvNotFound
]
HasConversationActionGalleyErrors 'ConversationMessageTimerUpdateTag =
'[ ErrorS ('ActionDenied 'ModifyConversationMessageTimer),
ErrorS 'InvalidOperation,
ErrorS 'ConvNotFound
]
HasConversationActionGalleyErrors 'ConversationReceiptModeUpdateTag =
'[ ErrorS ('ActionDenied 'ModifyConversationReceiptMode),
ErrorS 'InvalidOperation,
ErrorS 'ConvNotFound
]
HasConversationActionGalleyErrors 'ConversationAccessDataTag =
'[ ErrorS ('ActionDenied 'RemoveConversationMember),
ErrorS ('ActionDenied 'ModifyConversationAccess),
ErrorS 'InvalidOperation,
ErrorS 'InvalidTargetAccess,
ErrorS 'ConvNotFound
]
HasConversationActionGalleyErrors 'ConversationUpdateProtocolTag =
'[ ErrorS ('ActionDenied 'LeaveConversation),
ErrorS 'InvalidOperation,
ErrorS 'ConvNotFound,
ErrorS 'ConvInvalidProtocolTransition,
ErrorS 'MLSMigrationCriteriaNotSatisfied,
ErrorS 'NotATeamMember,
ErrorS OperationDenied,
ErrorS 'TeamNotFound
]
checkFederationStatus ::
( Member (Error UnreachableBackends) r,
Member (Error NonFederatingBackends) r,
Member FederatorAccess r
) =>
RemoteDomains ->
Sem r ()
checkFederationStatus :: forall (r :: EffectRow).
(Member (Error UnreachableBackends) r,
Member (Error NonFederatingBackends) r,
Member FederatorAccess r) =>
RemoteDomains -> Sem r ()
checkFederationStatus RemoteDomains
req = do
FederationStatus
status <- RemoteDomains -> Sem r FederationStatus
forall (r :: EffectRow).
(Member (Error UnreachableBackends) r, Member FederatorAccess r) =>
RemoteDomains -> Sem r FederationStatus
getFederationStatus RemoteDomains
req
case FederationStatus
status of
FederationStatus
FullyConnected -> () -> Sem r ()
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
NotConnectedDomains Domain
dom1 Domain
dom2 -> NonFederatingBackends -> Sem r ()
forall e (r :: EffectRow) a. Member (Error e) r => e -> Sem r a
throw (Domain -> Domain -> NonFederatingBackends
NonFederatingBackends Domain
dom1 Domain
dom2)
getFederationStatus ::
( Member (Error UnreachableBackends) r,
Member FederatorAccess r
) =>
RemoteDomains ->
Sem r FederationStatus
getFederationStatus :: forall (r :: EffectRow).
(Member (Error UnreachableBackends) r, Member FederatorAccess r) =>
RemoteDomains -> Sem r FederationStatus
getFederationStatus RemoteDomains
req = do
([Remote NonConnectedBackends] -> FederationStatus)
-> Sem r [Remote NonConnectedBackends] -> Sem r FederationStatus
forall a b. (a -> b) -> Sem r a -> Sem r b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Remote NonConnectedBackends] -> FederationStatus
firstConflictOrFullyConnected
(Sem r [Remote NonConnectedBackends] -> Sem r FederationStatus)
-> (Sem
r
[Either
(Remote [()], FederationError) (Remote NonConnectedBackends)]
-> Sem r [Remote NonConnectedBackends])
-> Sem
r
[Either
(Remote [()], FederationError) (Remote NonConnectedBackends)]
-> Sem r FederationStatus
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Either
(Remote [()], FederationError) (Remote NonConnectedBackends)]
-> Sem r [Remote NonConnectedBackends]
forall (r :: EffectRow) e b a.
Member (Error UnreachableBackends) r =>
[Either (Remote e, b) a] -> Sem r [a]
ensureNoUnreachableBackends =<<)
(Sem
r
[Either
(Remote [()], FederationError) (Remote NonConnectedBackends)]
-> Sem r FederationStatus)
-> Sem
r
[Either
(Remote [()], FederationError) (Remote NonConnectedBackends)]
-> Sem r FederationStatus
forall a b. (a -> b) -> a -> b
$ [Remote ()]
-> (Remote [()] -> FederatorClient 'Brig NonConnectedBackends)
-> Sem
r
[Either
(Remote [()], FederationError) (Remote NonConnectedBackends)]
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)]
E.runFederatedConcurrentlyEither
(Set (Remote ()) -> [Remote ()]
forall a. Set a -> [a]
Set.toList RemoteDomains
req.rdDomains)
( \Remote [()]
qds ->
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-not-fully-connected-backends"
(Set Domain -> DomainSet
DomainSet (Set Domain -> DomainSet)
-> (Set (Remote ()) -> Set Domain) -> Set (Remote ()) -> DomainSet
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Remote () -> Domain) -> Set (Remote ()) -> Set Domain
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map Remote () -> Domain
forall (t :: QTag) a. QualifiedWithTag t a -> Domain
tDomain (Set (Remote ()) -> DomainSet) -> Set (Remote ()) -> DomainSet
forall a b. (a -> b) -> a -> b
$ Remote [()] -> Remote ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void Remote [()]
qds Remote () -> Set (Remote ()) -> Set (Remote ())
forall a. Ord a => a -> Set a -> Set a
`Set.delete` RemoteDomains
req.rdDomains)
)
firstConflictOrFullyConnected :: [Remote NonConnectedBackends] -> FederationStatus
firstConflictOrFullyConnected :: [Remote NonConnectedBackends] -> FederationStatus
firstConflictOrFullyConnected =
FederationStatus
-> ((Domain, Domain) -> FederationStatus)
-> Maybe (Domain, Domain)
-> FederationStatus
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
FederationStatus
FullyConnected
((Domain -> Domain -> FederationStatus)
-> (Domain, Domain) -> FederationStatus
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Domain -> Domain -> FederationStatus
NotConnectedDomains)
(Maybe (Domain, Domain) -> FederationStatus)
-> ([Remote NonConnectedBackends] -> Maybe (Domain, Domain))
-> [Remote NonConnectedBackends]
-> FederationStatus
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Domain, Domain)] -> Maybe (Domain, Domain)
forall a. [a] -> Maybe a
headMay
([(Domain, Domain)] -> Maybe (Domain, Domain))
-> ([Remote NonConnectedBackends] -> [(Domain, Domain)])
-> [Remote NonConnectedBackends]
-> Maybe (Domain, Domain)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Remote NonConnectedBackends -> Maybe (Domain, Domain))
-> [Remote NonConnectedBackends] -> [(Domain, Domain)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Remote NonConnectedBackends -> Maybe (Domain, Domain)
toMaybeConflict
where
toMaybeConflict :: Remote NonConnectedBackends -> Maybe (Domain, Domain)
toMaybeConflict :: Remote NonConnectedBackends -> Maybe (Domain, Domain)
toMaybeConflict Remote NonConnectedBackends
r =
[Domain] -> Maybe Domain
forall a. [a] -> Maybe a
headMay (Set Domain -> [Domain]
forall a. Set a -> [a]
Set.toList (NonConnectedBackends -> Set Domain
nonConnectedBackends (Remote NonConnectedBackends -> NonConnectedBackends
forall (t :: QTag) a. QualifiedWithTag t a -> a
tUnqualified Remote NonConnectedBackends
r))) Maybe Domain
-> (Domain -> (Domain, Domain)) -> Maybe (Domain, Domain)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (Remote NonConnectedBackends -> Domain
forall (t :: QTag) a. QualifiedWithTag t a -> Domain
tDomain Remote NonConnectedBackends
r,)
noChanges :: (Member (Error NoChanges) r) => Sem r a
noChanges :: forall (r :: EffectRow) a. Member (Error NoChanges) r => Sem r a
noChanges = NoChanges -> Sem r a
forall e (r :: EffectRow) a. Member (Error e) r => e -> Sem r a
throw NoChanges
NoChanges
ensureAllowed ::
forall tag mem r x.
(IsConvMember mem, HasConversationActionEffects tag r) =>
Sing tag ->
Local x ->
ConversationAction tag ->
Conversation ->
mem ->
Sem r ()
ensureAllowed :: forall (tag :: ConversationActionTag) mem (r :: EffectRow) x.
(IsConvMember mem, HasConversationActionEffects tag r) =>
Sing tag
-> Local x
-> ConversationAction tag
-> Conversation
-> mem
-> Sem r ()
ensureAllowed Sing tag
tag Local x
loc ConversationAction tag
action Conversation
conv mem
origUser = do
case Sing tag
tag of
Sing tag
SConversationActionTag tag
SConversationJoinTag ->
forall {k1} {k2} (e :: k1) (e' :: k2) (r :: EffectRow) a.
Member (ErrorS e') r =>
Sem (ErrorS e : r) a -> Sem r a
forall (e :: GalleyError) (e' :: GalleyError) (r :: EffectRow) a.
Member (ErrorS e') r =>
Sem (ErrorS e : r) a -> Sem r a
mapErrorS @'InvalidAction @('ActionDenied 'AddConversationMember) (Sem (ErrorS 'InvalidAction : r) () -> Sem r ())
-> Sem (ErrorS 'InvalidAction : r) () -> Sem r ()
forall a b. (a -> b) -> a -> b
$
mem -> RoleName -> Sem (ErrorS 'InvalidAction : r) ()
forall mem (r :: EffectRow).
(IsConvMember mem, Member (ErrorS 'InvalidAction) r) =>
mem -> RoleName -> Sem r ()
ensureConvRoleNotElevated mem
origUser (ConversationJoin -> RoleName
cjRole ConversationJoin
ConversationAction tag
action)
Sing tag
SConversationActionTag tag
SConversationDeleteTag ->
Maybe TeamId -> (TeamId -> Sem r ()) -> Sem r ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ (Conversation -> Maybe TeamId
convTeam Conversation
conv) ((TeamId -> Sem r ()) -> Sem r ())
-> (TeamId -> Sem r ()) -> Sem r ()
forall a b. (a -> b) -> a -> b
$ \TeamId
tid -> do
Local UserId
lusr <- Local x -> Qualified UserId -> Sem r (Local UserId)
forall (r :: EffectRow) x a.
Member (Error FederationError) r =>
Local x -> Qualified a -> Sem r (Local a)
ensureLocal Local x
loc (Local x -> mem -> Qualified UserId
forall x. Local x -> mem -> Qualified UserId
forall mem x.
IsConvMember mem =>
Local x -> mem -> Qualified UserId
convMemberId Local x
loc mem
origUser)
Sem r TeamMember -> Sem r ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Sem r TeamMember -> Sem r ()) -> Sem r TeamMember -> Sem r ()
forall a b. (a -> b) -> a -> b
$ TeamId -> UserId -> Sem r (Maybe TeamMember)
forall (r :: EffectRow).
Member TeamStore r =>
TeamId -> UserId -> Sem r (Maybe TeamMember)
E.getTeamMember TeamId
tid (Local UserId -> UserId
forall (t :: QTag) a. QualifiedWithTag t a -> a
tUnqualified Local UserId
lusr) Sem r (Maybe TeamMember)
-> (Maybe TeamMember -> Sem r TeamMember) -> Sem r TeamMember
forall a b. Sem r a -> (a -> Sem r b) -> Sem r b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall {k} (e :: k) (r :: EffectRow) a.
Member (ErrorS e) r =>
Maybe a -> Sem r a
forall (e :: GalleyError) (r :: EffectRow) a.
Member (ErrorS e) r =>
Maybe a -> Sem r a
noteS @'NotATeamMember
Sing tag
SConversationActionTag tag
SConversationAccessDataTag -> do
Bool -> Sem r () -> Sem r ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Access
PrivateAccess Access -> Set Access -> Bool
forall a. Eq a => a -> Set a -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` ConversationAccessData -> Set Access
cupAccess ConversationAccessData
ConversationAction tag
action Bool -> Bool -> Bool
|| Set AccessRole -> Bool
forall a. Set a -> Bool
Set.null (ConversationAccessData -> Set AccessRole
cupAccessRoles ConversationAccessData
ConversationAction tag
action)) (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 @'InvalidTargetAccess
case Conversation -> Maybe TeamId
convTeam Conversation
conv of
Just TeamId
_ -> do
Sing 'RemoveConversationMember -> mem -> Sem r ()
forall (action :: Action) mem (r :: EffectRow).
(IsConvMember mem, Member (ErrorS ('ActionDenied action)) r) =>
Sing action -> mem -> Sem r ()
ensureActionAllowed Sing 'RemoveConversationMember
SAction 'RemoveConversationMember
SRemoveConversationMember mem
origUser
Maybe TeamId
Nothing ->
Bool -> Sem r () -> Sem r ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Set AccessRole -> Bool
forall a. Set a -> Bool
Set.null (Set AccessRole -> Bool) -> Set AccessRole -> Bool
forall a b. (a -> b) -> a -> b
$ ConversationAccessData -> Set AccessRole
cupAccessRoles ConversationAccessData
ConversationAction tag
action Set AccessRole -> Set AccessRole -> Set AccessRole
forall a. Ord a => Set a -> Set a -> Set a
Set.\\ [AccessRole] -> Set AccessRole
forall a. Ord a => [a] -> Set a
Set.fromList [AccessRole
TeamMemberAccessRole]) (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 @'InvalidTargetAccess
Sing tag
_ -> () -> Sem r ()
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
performAction ::
forall tag r.
( HasConversationActionEffects tag r,
Member BackendNotificationQueueAccess r,
Member (Error FederationError) r
) =>
Sing tag ->
Qualified UserId ->
Local Conversation ->
ConversationAction tag ->
Sem r (BotsAndMembers, ConversationAction tag)
performAction :: forall (tag :: ConversationActionTag) (r :: EffectRow).
(HasConversationActionEffects tag r,
Member BackendNotificationQueueAccess r,
Member (Error FederationError) r) =>
Sing tag
-> Qualified UserId
-> Local Conversation
-> ConversationAction tag
-> Sem r (BotsAndMembers, ConversationAction tag)
performAction Sing tag
tag Qualified UserId
origUser Local Conversation
lconv ConversationAction tag
action = do
let lcnv :: QualifiedWithTag 'QLocal ConvId
lcnv = (Conversation -> ConvId)
-> Local Conversation -> QualifiedWithTag 'QLocal 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 (.convId) Local Conversation
lconv
conv :: Conversation
conv = Local Conversation -> Conversation
forall (t :: QTag) a. QualifiedWithTag t a -> a
tUnqualified Local Conversation
lconv
case Sing tag
tag of
Sing tag
SConversationActionTag tag
SConversationJoinTag -> do
Qualified UserId
-> Local Conversation
-> ConversationJoin
-> Sem r (BotsAndMembers, ConversationJoin)
forall (r :: EffectRow).
(HasConversationActionEffects 'ConversationJoinTag r,
Member BackendNotificationQueueAccess r) =>
Qualified UserId
-> Local Conversation
-> ConversationJoin
-> Sem r (BotsAndMembers, ConversationJoin)
performConversationJoin Qualified UserId
origUser Local Conversation
lconv ConversationJoin
ConversationAction tag
action
Sing tag
SConversationActionTag tag
SConversationLeaveTag -> do
let victims :: [Qualified UserId]
victims = [Qualified UserId
origUser]
Local Conversation
lconv' <- (Conversation -> Sem r Conversation)
-> Local Conversation -> Sem r (Local Conversation)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b)
-> QualifiedWithTag 'QLocal a -> f (QualifiedWithTag 'QLocal b)
traverse (UserList UserId -> Conversation -> Sem r Conversation
forall (r :: EffectRow).
Member MemberStore r =>
UserList UserId -> Conversation -> Sem r Conversation
convDeleteMembers (Local Conversation -> [Qualified UserId] -> UserList UserId
forall (f :: * -> *) x a.
Foldable f =>
Local x -> f (Qualified a) -> UserList a
toUserList Local Conversation
lconv [Qualified UserId]
victims)) Local Conversation
lconv
(Qualified UserId -> Sem r ()) -> [Qualified UserId] -> Sem r ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (Local Conversation
-> RemoveUserIncludeMain -> Qualified UserId -> Sem r ()
forall (r :: EffectRow).
(Member BackendNotificationQueueAccess r,
Member (Error FederationError) r, Member ExternalAccess r,
Member NotificationSubsystem r, Member (Input Env) r,
Member (Input UTCTime) r, Member MemberStore r,
Member ProposalStore r, Member Random r,
Member SubConversationStore r, Member TinyLog r) =>
Local Conversation
-> RemoveUserIncludeMain -> Qualified UserId -> Sem r ()
removeUser Local Conversation
lconv' RemoveUserIncludeMain
RemoveUserIncludeMain) [Qualified UserId]
victims
(BotsAndMembers, ()) -> Sem r (BotsAndMembers, ())
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (BotsAndMembers
forall a. Monoid a => a
mempty, ()
ConversationAction tag
action)
Sing tag
SConversationActionTag tag
SConversationRemoveMembersTag -> do
let presentVictims :: [Qualified UserId]
presentVictims = (Qualified UserId -> Bool)
-> [Qualified UserId] -> [Qualified UserId]
forall a. (a -> Bool) -> [a] -> [a]
filter (Local Conversation -> Qualified UserId -> Bool
forall uid mem.
IsConvMemberId uid mem =>
Local Conversation -> uid -> Bool
isConvMemberL Local Conversation
lconv) (NonEmpty (Qualified UserId) -> [Qualified UserId]
forall a. NonEmpty a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (NonEmpty (Qualified UserId) -> [Qualified UserId])
-> (ConversationAction tag -> NonEmpty (Qualified UserId))
-> ConversationAction tag
-> [Qualified UserId]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConversationRemoveMembers -> NonEmpty (Qualified UserId)
ConversationAction tag -> NonEmpty (Qualified UserId)
crmTargets (ConversationAction tag -> [Qualified UserId])
-> ConversationAction tag -> [Qualified UserId]
forall a b. (a -> b) -> a -> b
$ ConversationAction tag
action)
Bool -> Sem r () -> Sem r ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([Qualified UserId] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Qualified UserId]
presentVictims) Sem r ()
forall (r :: EffectRow) a. Member (Error NoChanges) r => Sem r a
noChanges
(Conversation -> Sem r Conversation)
-> Local Conversation -> Sem r ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (UserList UserId -> Conversation -> Sem r Conversation
forall (r :: EffectRow).
Member MemberStore r =>
UserList UserId -> Conversation -> Sem r Conversation
convDeleteMembers (Local Conversation -> [Qualified UserId] -> UserList UserId
forall (f :: * -> *) x a.
Foldable f =>
Local x -> f (Qualified a) -> UserList a
toUserList Local Conversation
lconv [Qualified UserId]
presentVictims)) Local Conversation
lconv
(Qualified UserId -> Sem r ()) -> [Qualified UserId] -> Sem r ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (Local Conversation
-> RemoveUserIncludeMain -> Qualified UserId -> Sem r ()
forall (r :: EffectRow).
(Member BackendNotificationQueueAccess r,
Member (Error FederationError) r, Member ExternalAccess r,
Member NotificationSubsystem r, Member (Input Env) r,
Member (Input UTCTime) r, Member MemberStore r,
Member ProposalStore r, Member Random r,
Member SubConversationStore r, Member TinyLog r) =>
Local Conversation
-> RemoveUserIncludeMain -> Qualified UserId -> Sem r ()
removeUser Local Conversation
lconv RemoveUserIncludeMain
RemoveUserExcludeMain) [Qualified UserId]
presentVictims
(BotsAndMembers, ConversationRemoveMembers)
-> Sem r (BotsAndMembers, ConversationRemoveMembers)
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (BotsAndMembers
forall a. Monoid a => a
mempty, ConversationRemoveMembers
ConversationAction tag
action)
Sing tag
SConversationActionTag tag
SConversationMemberUpdateTag -> do
Sem r (Either LocalMember RemoteMember) -> Sem r ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Sem r (Either LocalMember RemoteMember) -> Sem r ())
-> Sem r (Either LocalMember RemoteMember) -> Sem r ()
forall a b. (a -> b) -> a -> b
$ Local Conversation
-> Qualified UserId
-> Conversation
-> Sem r (Either LocalMember RemoteMember)
forall (r :: EffectRow) a.
Member (ErrorS 'ConvMemberNotFound) r =>
Local a
-> Qualified UserId
-> Conversation
-> Sem r (Either LocalMember RemoteMember)
ensureOtherMember Local Conversation
lconv (ConversationMemberUpdate -> Qualified UserId
cmuTarget ConversationMemberUpdate
ConversationAction tag
action) Conversation
conv
QualifiedWithTag 'QLocal ConvId
-> Qualified UserId -> OtherMemberUpdate -> Sem r ()
forall (r :: EffectRow).
Member MemberStore r =>
QualifiedWithTag 'QLocal ConvId
-> Qualified UserId -> OtherMemberUpdate -> Sem r ()
E.setOtherMember QualifiedWithTag 'QLocal ConvId
lcnv (ConversationMemberUpdate -> Qualified UserId
cmuTarget ConversationMemberUpdate
ConversationAction tag
action) (ConversationMemberUpdate -> OtherMemberUpdate
cmuUpdate ConversationMemberUpdate
ConversationAction tag
action)
(BotsAndMembers, ConversationMemberUpdate)
-> Sem r (BotsAndMembers, ConversationMemberUpdate)
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (BotsAndMembers
forall a. Monoid a => a
mempty, ConversationMemberUpdate
ConversationAction tag
action)
Sing tag
SConversationActionTag tag
SConversationDeleteTag -> do
let deleteGroup :: GroupId -> Sem r ()
deleteGroup GroupId
groupId = do
GroupId -> Sem r ()
forall (r :: EffectRow).
Member MemberStore r =>
GroupId -> Sem r ()
E.removeAllMLSClients GroupId
groupId
GroupId -> Sem r ()
forall (r :: EffectRow).
Member ProposalStore r =>
GroupId -> Sem r ()
E.deleteAllProposals GroupId
groupId
let cid :: ConvId
cid = Conversation
conv.convId
Maybe GroupId -> (GroupId -> Sem r ()) -> Sem r ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ (Conversation
conv Conversation
-> (Conversation -> Maybe (ConversationMLSData, MLSMigrationState))
-> Maybe (ConversationMLSData, MLSMigrationState)
forall a b. a -> (a -> b) -> b
& Conversation -> Maybe (ConversationMLSData, MLSMigrationState)
mlsMetadata Maybe (ConversationMLSData, MLSMigrationState)
-> ((ConversationMLSData, MLSMigrationState) -> GroupId)
-> Maybe GroupId
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> ConversationMLSData -> GroupId
cnvmlsGroupId (ConversationMLSData -> GroupId)
-> ((ConversationMLSData, MLSMigrationState)
-> ConversationMLSData)
-> (ConversationMLSData, MLSMigrationState)
-> GroupId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ConversationMLSData, MLSMigrationState) -> ConversationMLSData
forall a b. (a, b) -> a
fst) ((GroupId -> Sem r ()) -> Sem r ())
-> (GroupId -> Sem r ()) -> Sem r ()
forall a b. (a -> b) -> a -> b
$ \GroupId
gidParent -> do
Map SubConvId ConversationMLSData
sconvs <- ConvId -> Sem r (Map SubConvId ConversationMLSData)
forall (r :: EffectRow).
Member SubConversationStore r =>
ConvId -> Sem r (Map SubConvId ConversationMLSData)
E.listSubConversations ConvId
cid
[(SubConvId, ConversationMLSData)]
-> ((SubConvId, ConversationMLSData) -> Sem r ()) -> Sem r ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ (Map SubConvId ConversationMLSData
-> [(SubConvId, ConversationMLSData)]
forall k a. Map k a -> [(k, a)]
Map.assocs Map SubConvId ConversationMLSData
sconvs) (((SubConvId, ConversationMLSData) -> Sem r ()) -> Sem r ())
-> ((SubConvId, ConversationMLSData) -> Sem r ()) -> Sem r ()
forall a b. (a -> b) -> a -> b
$ \(SubConvId
subid, ConversationMLSData
mlsData) -> do
let gidSub :: GroupId
gidSub = ConversationMLSData -> GroupId
cnvmlsGroupId ConversationMLSData
mlsData
ConvId -> SubConvId -> Sem r ()
forall (r :: EffectRow).
Member SubConversationStore r =>
ConvId -> SubConvId -> Sem r ()
E.deleteSubConversation ConvId
cid SubConvId
subid
GroupId -> Sem r ()
forall {r :: EffectRow}.
(Member MemberStore r, Member ProposalStore r) =>
GroupId -> Sem r ()
deleteGroup GroupId
gidSub
GroupId -> Sem r ()
forall {r :: EffectRow}.
(Member MemberStore r, Member ProposalStore r) =>
GroupId -> Sem r ()
deleteGroup GroupId
gidParent
Key
key <- ConvId -> Sem r Key
forall (r :: EffectRow). Member CodeStore r => ConvId -> Sem r Key
E.makeKey (QualifiedWithTag 'QLocal ConvId -> ConvId
forall (t :: QTag) a. QualifiedWithTag t a -> a
tUnqualified QualifiedWithTag 'QLocal ConvId
lcnv)
Key -> Scope -> Sem r ()
forall (r :: EffectRow).
Member CodeStore r =>
Key -> Scope -> Sem r ()
E.deleteCode Key
key Scope
ReusableCode
case Conversation -> Maybe TeamId
convTeam Conversation
conv of
Maybe TeamId
Nothing -> ConvId -> Sem r ()
forall (r :: EffectRow).
Member ConversationStore r =>
ConvId -> Sem r ()
E.deleteConversation (QualifiedWithTag 'QLocal ConvId -> ConvId
forall (t :: QTag) a. QualifiedWithTag t a -> a
tUnqualified QualifiedWithTag 'QLocal ConvId
lcnv)
Just TeamId
tid -> TeamId -> ConvId -> Sem r ()
forall (r :: EffectRow).
Member TeamStore r =>
TeamId -> ConvId -> Sem r ()
E.deleteTeamConversation TeamId
tid (QualifiedWithTag 'QLocal ConvId -> ConvId
forall (t :: QTag) a. QualifiedWithTag t a -> a
tUnqualified QualifiedWithTag 'QLocal ConvId
lcnv)
(BotsAndMembers, ()) -> Sem r (BotsAndMembers, ())
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (BotsAndMembers
forall a. Monoid a => a
mempty, ()
ConversationAction tag
action)
Sing tag
SConversationActionTag tag
SConversationRenameTag -> do
Maybe TeamMember
zusrMembership <- Maybe (Maybe TeamMember) -> Maybe TeamMember
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (Maybe (Maybe TeamMember) -> Maybe TeamMember)
-> Sem r (Maybe (Maybe TeamMember)) -> Sem r (Maybe TeamMember)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe TeamId
-> (TeamId -> Sem r (Maybe TeamMember))
-> Sem r (Maybe (Maybe TeamMember))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (ConversationMetadata -> Maybe TeamId
cnvmTeam (Conversation -> ConversationMetadata
convMetadata Conversation
conv)) ((TeamId -> UserId -> Sem r (Maybe TeamMember))
-> UserId -> TeamId -> Sem r (Maybe TeamMember)
forall a b c. (a -> b -> c) -> b -> a -> c
flip TeamId -> UserId -> Sem r (Maybe TeamMember)
forall (r :: EffectRow).
Member TeamStore r =>
TeamId -> UserId -> Sem r (Maybe TeamMember)
E.getTeamMember (Qualified UserId -> UserId
forall a. Qualified a -> a
qUnqualified Qualified UserId
origUser))
Maybe TeamMember -> (TeamMember -> Sem r ()) -> Sem r ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Maybe TeamMember
zusrMembership ((TeamMember -> Sem r ()) -> Sem r ())
-> (TeamMember -> Sem r ()) -> Sem r ()
forall a b. (a -> b) -> a -> b
$ \TeamMember
tm -> Bool -> Sem r () -> Sem r ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (TeamMember
tm TeamMember -> Perm -> Bool
forall perm. IsPerm perm => TeamMember -> perm -> Bool
`hasPermission` Perm
ModifyConvName) (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 @'InvalidOperation
Range 1 256 Text
cn <- Text -> Sem r (Range 1 256 Text)
forall (n :: Nat) (m :: Nat) (r :: EffectRow) a.
(KnownNat n, KnownNat m, Member (Error InvalidInput) r,
Within a n m) =>
a -> Sem r (Range n m a)
rangeChecked (ConversationRename -> Text
cupName ConversationRename
ConversationAction tag
action)
ConvId -> Range 1 256 Text -> Sem r ()
forall (r :: EffectRow).
Member ConversationStore r =>
ConvId -> Range 1 256 Text -> Sem r ()
E.setConversationName (QualifiedWithTag 'QLocal ConvId -> ConvId
forall (t :: QTag) a. QualifiedWithTag t a -> a
tUnqualified QualifiedWithTag 'QLocal ConvId
lcnv) Range 1 256 Text
cn
(BotsAndMembers, ConversationRename)
-> Sem r (BotsAndMembers, ConversationRename)
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (BotsAndMembers
forall a. Monoid a => a
mempty, ConversationRename
ConversationAction tag
action)
Sing tag
SConversationActionTag tag
SConversationMessageTimerUpdateTag -> do
Bool -> Sem r () -> Sem r ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Conversation -> Maybe Milliseconds
Data.convMessageTimer Conversation
conv Maybe Milliseconds -> Maybe Milliseconds -> Bool
forall a. Eq a => a -> a -> Bool
== ConversationMessageTimerUpdate -> Maybe Milliseconds
cupMessageTimer ConversationMessageTimerUpdate
ConversationAction tag
action) Sem r ()
forall (r :: EffectRow) a. Member (Error NoChanges) r => Sem r a
noChanges
ConvId -> Maybe Milliseconds -> Sem r ()
forall (r :: EffectRow).
Member ConversationStore r =>
ConvId -> Maybe Milliseconds -> Sem r ()
E.setConversationMessageTimer (QualifiedWithTag 'QLocal ConvId -> ConvId
forall (t :: QTag) a. QualifiedWithTag t a -> a
tUnqualified QualifiedWithTag 'QLocal ConvId
lcnv) (ConversationMessageTimerUpdate -> Maybe Milliseconds
cupMessageTimer ConversationMessageTimerUpdate
ConversationAction tag
action)
(BotsAndMembers, ConversationMessageTimerUpdate)
-> Sem r (BotsAndMembers, ConversationMessageTimerUpdate)
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (BotsAndMembers
forall a. Monoid a => a
mempty, ConversationMessageTimerUpdate
ConversationAction tag
action)
Sing tag
SConversationActionTag tag
SConversationReceiptModeUpdateTag -> do
Bool -> Sem r () -> Sem r ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Conversation -> Maybe ReceiptMode
Data.convReceiptMode Conversation
conv Maybe ReceiptMode -> Maybe ReceiptMode -> Bool
forall a. Eq a => a -> a -> Bool
== ReceiptMode -> Maybe ReceiptMode
forall a. a -> Maybe a
Just (ConversationReceiptModeUpdate -> ReceiptMode
cruReceiptMode ConversationReceiptModeUpdate
ConversationAction tag
action)) Sem r ()
forall (r :: EffectRow) a. Member (Error NoChanges) r => Sem r a
noChanges
ConvId -> ReceiptMode -> Sem r ()
forall (r :: EffectRow).
Member ConversationStore r =>
ConvId -> ReceiptMode -> Sem r ()
E.setConversationReceiptMode (QualifiedWithTag 'QLocal ConvId -> ConvId
forall (t :: QTag) a. QualifiedWithTag t a -> a
tUnqualified QualifiedWithTag 'QLocal ConvId
lcnv) (ConversationReceiptModeUpdate -> ReceiptMode
cruReceiptMode ConversationReceiptModeUpdate
ConversationAction tag
action)
(BotsAndMembers, ConversationReceiptModeUpdate)
-> Sem r (BotsAndMembers, ConversationReceiptModeUpdate)
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (BotsAndMembers
forall a. Monoid a => a
mempty, ConversationReceiptModeUpdate
ConversationAction tag
action)
Sing tag
SConversationActionTag tag
SConversationAccessDataTag -> do
(BotsAndMembers
bm, ConversationAccessData
act) <- Qualified UserId
-> Local Conversation
-> ConversationAccessData
-> Sem r (BotsAndMembers, ConversationAccessData)
forall (r :: EffectRow).
(HasConversationActionEffects 'ConversationAccessDataTag r,
Member (Error FederationError) r,
Member BackendNotificationQueueAccess r) =>
Qualified UserId
-> Local Conversation
-> ConversationAccessData
-> Sem r (BotsAndMembers, ConversationAccessData)
performConversationAccessData Qualified UserId
origUser Local Conversation
lconv ConversationAccessData
ConversationAction tag
action
(BotsAndMembers, ConversationAccessData)
-> Sem r (BotsAndMembers, ConversationAccessData)
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (BotsAndMembers
bm, ConversationAccessData
act)
Sing tag
SConversationActionTag tag
SConversationUpdateProtocolTag -> do
case (Protocol -> ProtocolTag
protocolTag (Conversation -> Protocol
convProtocol (Local Conversation -> Conversation
forall (t :: QTag) a. QualifiedWithTag t a -> a
tUnqualified Local Conversation
lconv)), ProtocolTag
ConversationAction tag
action, Conversation -> Maybe TeamId
convTeam (Local Conversation -> Conversation
forall (t :: QTag) a. QualifiedWithTag t a -> a
tUnqualified Local Conversation
lconv)) of
(ProtocolTag
ProtocolProteusTag, ProtocolTag
ProtocolMixedTag, Just TeamId
_) -> do
QualifiedWithTag 'QLocal ConvId -> ConvType -> Sem r ()
forall (r :: EffectRow).
Member ConversationStore r =>
QualifiedWithTag 'QLocal ConvId -> ConvType -> Sem r ()
E.updateToMixedProtocol QualifiedWithTag 'QLocal ConvId
lcnv (Conversation -> ConvType
convType (Local Conversation -> Conversation
forall (t :: QTag) a. QualifiedWithTag t a -> a
tUnqualified Local Conversation
lconv))
(BotsAndMembers, ProtocolTag)
-> Sem r (BotsAndMembers, ProtocolTag)
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (BotsAndMembers
forall a. Monoid a => a
mempty, ProtocolTag
ConversationAction tag
action)
(ProtocolTag
ProtocolMixedTag, ProtocolTag
ProtocolMLSTag, Just TeamId
tid) -> do
LockableFeature MlsMigrationConfig
mig <- forall cfg (r :: EffectRow).
(GetFeatureConfig cfg, ComputeFeatureConstraints cfg r,
Member (Input Opts) r, Member TeamFeatureStore r) =>
TeamId -> Sem r (LockableFeature cfg)
getFeatureForTeam @MlsMigrationConfig TeamId
tid
UTCTime
now <- Sem r UTCTime
forall i (r :: EffectRow). Member (Input i) r => Sem r i
input
MLSConversation
mlsConv <- Conversation -> Sem r (Maybe MLSConversation)
forall (r :: EffectRow).
Member MemberStore r =>
Conversation -> Sem r (Maybe MLSConversation)
mkMLSConversation Conversation
conv Sem r (Maybe MLSConversation)
-> (Maybe MLSConversation -> Sem r MLSConversation)
-> Sem r MLSConversation
forall a b. Sem r a -> (a -> Sem r b) -> Sem r b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall {k} (e :: k) (r :: EffectRow) a.
Member (ErrorS e) r =>
Maybe a -> Sem r a
forall (e :: GalleyError) (r :: EffectRow) a.
Member (ErrorS e) r =>
Maybe a -> Sem r a
noteS @'ConvInvalidProtocolTransition
Bool
ok <- UTCTime
-> MLSConversation
-> LockableFeature MlsMigrationConfig
-> Sem r Bool
forall (r :: EffectRow).
(Member BrigAccess r, Member FederatorAccess r) =>
UTCTime
-> MLSConversation
-> LockableFeature MlsMigrationConfig
-> Sem r Bool
checkMigrationCriteria UTCTime
now MLSConversation
mlsConv LockableFeature MlsMigrationConfig
mig
Bool -> Sem r () -> Sem r ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
ok (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 @'MLSMigrationCriteriaNotSatisfied
Qualified UserId -> Local Conversation -> Sem r ()
forall (r :: EffectRow).
(Member BackendNotificationQueueAccess r,
Member (Error FederationError) r, Member ExternalAccess r,
Member NotificationSubsystem r, Member (Input Env) r,
Member (Input UTCTime) r, Member MemberStore r,
Member ProposalStore r, Member Random r,
Member SubConversationStore r, Member TinyLog r) =>
Qualified UserId -> Local Conversation -> Sem r ()
removeExtraneousClients Qualified UserId
origUser Local Conversation
lconv
QualifiedWithTag 'QLocal ConvId -> Sem r ()
forall (r :: EffectRow).
Member ConversationStore r =>
QualifiedWithTag 'QLocal ConvId -> Sem r ()
E.updateToMLSProtocol QualifiedWithTag 'QLocal ConvId
lcnv
(BotsAndMembers, ProtocolTag)
-> Sem r (BotsAndMembers, ProtocolTag)
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (BotsAndMembers
forall a. Monoid a => a
mempty, ProtocolTag
ConversationAction tag
action)
(ProtocolTag
ProtocolProteusTag, ProtocolTag
ProtocolProteusTag, Maybe TeamId
_) ->
Sem r (BotsAndMembers, ProtocolTag)
Sem r (BotsAndMembers, ConversationAction tag)
forall (r :: EffectRow) a. Member (Error NoChanges) r => Sem r a
noChanges
(ProtocolTag
ProtocolMixedTag, ProtocolTag
ProtocolMixedTag, Maybe TeamId
_) ->
Sem r (BotsAndMembers, ProtocolTag)
Sem r (BotsAndMembers, ConversationAction tag)
forall (r :: EffectRow) a. Member (Error NoChanges) r => Sem r a
noChanges
(ProtocolTag
ProtocolMLSTag, ProtocolTag
ProtocolMLSTag, Maybe TeamId
_) ->
Sem r (BotsAndMembers, ProtocolTag)
Sem r (BotsAndMembers, ConversationAction tag)
forall (r :: EffectRow) a. Member (Error NoChanges) r => Sem r a
noChanges
(ProtocolTag
_, ProtocolTag
_, Maybe TeamId
_) -> 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 @'ConvInvalidProtocolTransition
performConversationJoin ::
forall r.
( HasConversationActionEffects 'ConversationJoinTag r,
Member BackendNotificationQueueAccess r
) =>
Qualified UserId ->
Local Conversation ->
ConversationJoin ->
Sem r (BotsAndMembers, ConversationJoin)
performConversationJoin :: forall (r :: EffectRow).
(HasConversationActionEffects 'ConversationJoinTag r,
Member BackendNotificationQueueAccess r) =>
Qualified UserId
-> Local Conversation
-> ConversationJoin
-> Sem r (BotsAndMembers, ConversationJoin)
performConversationJoin Qualified UserId
qusr Local Conversation
lconv (ConversationJoin NonEmpty (Qualified UserId)
invited RoleName
role) = do
let newMembers :: UserList UserId
newMembers = Local Conversation
-> Conversation -> UserList UserId -> UserList UserId
forall x.
Local x -> Conversation -> UserList UserId -> UserList UserId
ulNewMembers Local Conversation
lconv Conversation
conv (UserList UserId -> UserList UserId)
-> (NonEmpty (Qualified UserId) -> UserList UserId)
-> NonEmpty (Qualified UserId)
-> UserList UserId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Local Conversation
-> NonEmpty (Qualified UserId) -> UserList UserId
forall (f :: * -> *) x a.
Foldable f =>
Local x -> f (Qualified a) -> UserList a
toUserList Local Conversation
lconv (NonEmpty (Qualified UserId) -> UserList UserId)
-> NonEmpty (Qualified UserId) -> UserList UserId
forall a b. (a -> b) -> a -> b
$ NonEmpty (Qualified UserId)
invited
Local UserId
lusr <- Local Conversation -> Qualified UserId -> Sem r (Local UserId)
forall (r :: EffectRow) x a.
Member (Error FederationError) r =>
Local x -> Qualified a -> Sem r (Local a)
ensureLocal Local Conversation
lconv Qualified UserId
qusr
ProtocolTag -> [LocalMember] -> UserList UserId -> Sem r ()
forall (f :: * -> *) (r :: EffectRow) a.
(Foldable f,
(Member (ErrorS 'TooManyMembers) r, Member (Input Opts) r)) =>
ProtocolTag -> [LocalMember] -> f a -> Sem r ()
ensureMemberLimit (Conversation -> ProtocolTag
convProtocolTag Conversation
conv) ([LocalMember] -> [LocalMember]
forall a. [a] -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Conversation -> [LocalMember]
convLocalMembers Conversation
conv)) UserList UserId
newMembers
Conversation -> Access -> Sem r ()
forall (r :: EffectRow).
Member (ErrorS 'ConvAccessDenied) r =>
Conversation -> Access -> Sem r ()
ensureAccess Conversation
conv Access
InviteAccess
Local UserId -> Maybe TeamId -> [UserId] -> Sem r ()
checkLocals Local UserId
lusr (Conversation -> Maybe TeamId
convTeam Conversation
conv) (UserList UserId -> [UserId]
forall a. UserList a -> [a]
ulLocals UserList UserId
newMembers)
Local UserId -> [Remote UserId] -> Sem r ()
checkRemotes Local UserId
lusr (UserList UserId -> [Remote UserId]
forall a. UserList a -> [Remote a]
ulRemotes UserList UserId
newMembers)
[UserId] -> Sem r ()
checkLHPolicyConflictsLocal (UserList UserId -> [UserId]
forall a. UserList a -> [a]
ulLocals UserList UserId
newMembers)
FutureWork 'LegalholdPlusFederationNotImplemented [Remote UserId]
-> Sem r ()
checkLHPolicyConflictsRemote ([Remote UserId]
-> FutureWork
'LegalholdPlusFederationNotImplemented [Remote UserId]
forall {k} (label :: k) payload.
payload -> FutureWork label payload
FutureWork (UserList UserId -> [Remote UserId]
forall a. UserList a -> [Remote a]
ulRemotes UserList UserId
newMembers))
Local UserId -> Sem r ()
forall x. Local x -> Sem r ()
checkRemoteBackendsConnected Local UserId
lusr
Local UserId -> Sem r ()
checkTeamMemberAddPermissions Local UserId
lusr
QualifiedWithTag 'QLocal ConvId
-> UserList UserId
-> RoleName
-> Sem r (BotsAndMembers, ConversationJoin)
forall (r :: EffectRow).
(Member MemberStore r, Member (Error NoChanges) r) =>
QualifiedWithTag 'QLocal ConvId
-> UserList UserId
-> RoleName
-> Sem r (BotsAndMembers, ConversationJoin)
addMembersToLocalConversation ((Conversation -> ConvId)
-> Local Conversation -> QualifiedWithTag 'QLocal 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 (.convId) Local Conversation
lconv) UserList UserId
newMembers RoleName
role
where
checkRemoteBackendsConnected :: Local x -> Sem r ()
checkRemoteBackendsConnected :: forall x. Local x -> Sem r ()
checkRemoteBackendsConnected Local x
loc = do
let invitedRemoteUsers :: [Remote UserId]
invitedRemoteUsers = ([UserId], [Remote UserId]) -> [Remote UserId]
forall a b. (a, b) -> b
snd (([UserId], [Remote UserId]) -> [Remote UserId])
-> (NonEmpty (Qualified UserId) -> ([UserId], [Remote UserId]))
-> NonEmpty (Qualified UserId)
-> [Remote UserId]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Local x -> [Qualified UserId] -> ([UserId], [Remote UserId])
forall (f :: * -> *) x a.
Foldable f =>
Local x -> f (Qualified a) -> ([a], [Remote a])
partitionQualified Local x
loc ([Qualified UserId] -> ([UserId], [Remote UserId]))
-> (NonEmpty (Qualified UserId) -> [Qualified UserId])
-> NonEmpty (Qualified UserId)
-> ([UserId], [Remote UserId])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty (Qualified UserId) -> [Qualified UserId]
forall a. NonEmpty a -> [a]
NE.toList (NonEmpty (Qualified UserId) -> [Remote UserId])
-> NonEmpty (Qualified UserId) -> [Remote UserId]
forall a b. (a -> b) -> a -> b
$ NonEmpty (Qualified UserId)
invited
invitedRemoteDomains :: Set (Remote ())
invitedRemoteDomains = [Remote ()] -> Set (Remote ())
forall a. Ord a => [a] -> Set a
Set.fromList ([Remote ()] -> Set (Remote ())) -> [Remote ()] -> Set (Remote ())
forall a b. (a -> b) -> a -> b
$ Remote UserId -> Remote ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Remote UserId -> Remote ()) -> [Remote UserId] -> [Remote ()]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Remote UserId]
invitedRemoteUsers
existingRemoteDomains :: Set (Remote ())
existingRemoteDomains = [Remote ()] -> Set (Remote ())
forall a. Ord a => [a] -> Set a
Set.fromList ([Remote ()] -> Set (Remote ())) -> [Remote ()] -> Set (Remote ())
forall a b. (a -> b) -> a -> b
$ Remote UserId -> Remote ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Remote UserId -> Remote ())
-> (RemoteMember -> Remote UserId) -> RemoteMember -> Remote ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RemoteMember -> Remote UserId
rmId (RemoteMember -> Remote ()) -> [RemoteMember] -> [Remote ()]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Conversation -> [RemoteMember]
convRemoteMembers (Local Conversation -> Conversation
forall (t :: QTag) a. QualifiedWithTag t a -> a
tUnqualified Local Conversation
lconv)
allInvitedAlreadyInConversation :: Bool
allInvitedAlreadyInConversation = Set (Remote ()) -> Bool
forall a. Set a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Set (Remote ()) -> Bool) -> Set (Remote ()) -> Bool
forall a b. (a -> b) -> a -> b
$ Set (Remote ())
invitedRemoteDomains Set (Remote ()) -> Set (Remote ()) -> Set (Remote ())
forall a. Ord a => Set a -> Set a -> Set a
\\ Set (Remote ())
existingRemoteDomains
if Bool -> Bool
not Bool
allInvitedAlreadyInConversation
then RemoteDomains -> Sem r ()
forall (r :: EffectRow).
(Member (Error UnreachableBackends) r,
Member (Error NonFederatingBackends) r,
Member FederatorAccess r) =>
RemoteDomains -> Sem r ()
checkFederationStatus (Set (Remote ()) -> RemoteDomains
RemoteDomains (Set (Remote ())
invitedRemoteDomains Set (Remote ()) -> Set (Remote ()) -> Set (Remote ())
forall a. Semigroup a => a -> a -> a
<> Set (Remote ())
existingRemoteDomains))
else
Sem r [Remote ()] -> Sem r ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Sem r [Remote ()] -> Sem r ())
-> (Sem r [Either (Remote [UserId], FederationError) (Remote ())]
-> Sem r [Remote ()])
-> Sem r [Either (Remote [UserId], FederationError) (Remote ())]
-> Sem r ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Either (Remote [UserId], FederationError) (Remote ())]
-> Sem r [Remote ()]
forall (r :: EffectRow) e b a.
Member (Error UnreachableBackends) r =>
[Either (Remote e, b) a] -> Sem r [a]
ensureNoUnreachableBackends =<<) (Sem r [Either (Remote [UserId], FederationError) (Remote ())]
-> Sem r ())
-> Sem r [Either (Remote [UserId], FederationError) (Remote ())]
-> Sem r ()
forall a b. (a -> b) -> a -> b
$
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)]
E.runFederatedConcurrentlyEither @_ @'Brig [Remote UserId]
invitedRemoteUsers ((Remote [UserId] -> FederatorClient 'Brig ())
-> Sem r [Either (Remote [UserId], FederationError) (Remote ())])
-> (Remote [UserId] -> FederatorClient 'Brig ())
-> Sem r [Either (Remote [UserId], FederationError) (Remote ())]
forall a b. (a -> b) -> a -> b
$ \Remote [UserId]
_ ->
() -> FederatorClient 'Brig ()
forall a. a -> FederatorClient 'Brig a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
conv :: Data.Conversation
conv :: Conversation
conv = Local Conversation -> Conversation
forall (t :: QTag) a. QualifiedWithTag t a -> a
tUnqualified Local Conversation
lconv
checkLocals ::
Local UserId ->
Maybe TeamId ->
[UserId] ->
Sem r ()
checkLocals :: Local UserId -> Maybe TeamId -> [UserId] -> Sem r ()
checkLocals Local UserId
lusr (Just TeamId
tid) [UserId]
newUsers = do
Map UserId TeamMember
tms <-
[(UserId, TeamMember)] -> Map UserId TeamMember
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(UserId, TeamMember)] -> Map UserId TeamMember)
-> ([TeamMember] -> [(UserId, TeamMember)])
-> [TeamMember]
-> Map UserId TeamMember
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TeamMember -> (UserId, TeamMember))
-> [TeamMember] -> [(UserId, TeamMember)]
forall a b. (a -> b) -> [a] -> [b]
map (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)
-> (TeamMember -> TeamMember) -> TeamMember -> (UserId, TeamMember)
forall b c c'. (b -> c) -> (b -> c') -> b -> (c, c')
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& TeamMember -> TeamMember
forall a. a -> a
Imports.id)
([TeamMember] -> Map UserId TeamMember)
-> Sem r [TeamMember] -> Sem r (Map UserId TeamMember)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TeamId -> [UserId] -> Sem r [TeamMember]
forall (r :: EffectRow).
Member TeamStore r =>
TeamId -> [UserId] -> Sem r [TeamMember]
E.selectTeamMembers TeamId
tid [UserId]
newUsers
let userMembershipMap :: [(UserId, Maybe TeamMember)]
userMembershipMap = (UserId -> (UserId, Maybe TeamMember))
-> [UserId] -> [(UserId, Maybe TeamMember)]
forall a b. (a -> b) -> [a] -> [b]
map (UserId -> UserId
forall a. a -> a
Imports.id (UserId -> UserId)
-> (UserId -> Maybe TeamMember)
-> UserId
-> (UserId, Maybe TeamMember)
forall b c c'. (b -> c) -> (b -> c') -> b -> (c, c')
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& (UserId -> Map UserId TeamMember -> Maybe TeamMember)
-> Map UserId TeamMember -> UserId -> Maybe TeamMember
forall a b c. (a -> b -> c) -> b -> a -> c
flip UserId -> Map UserId TeamMember -> Maybe TeamMember
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Map UserId TeamMember
tms) [UserId]
newUsers
Set AccessRole -> [(UserId, Maybe TeamMember)] -> Sem r ()
forall (r :: EffectRow).
(Member BrigAccess r, Member (ErrorS 'NotATeamMember) r,
Member (ErrorS 'ConvAccessDenied) r) =>
Set AccessRole -> [(UserId, Maybe TeamMember)] -> Sem r ()
ensureAccessRole (Conversation -> Set AccessRole
convAccessRoles Conversation
conv) [(UserId, Maybe TeamMember)]
userMembershipMap
Local UserId -> [UserId] -> Sem r ()
forall (r :: EffectRow).
(Member BrigAccess r, Member (ErrorS 'NotConnected) r,
Member TeamStore r) =>
Local UserId -> [UserId] -> Sem r ()
ensureConnectedToLocalsOrSameTeam Local UserId
lusr [UserId]
newUsers
checkLocals Local UserId
lusr Maybe TeamId
Nothing [UserId]
newUsers = do
Set AccessRole -> [(UserId, Maybe TeamMember)] -> Sem r ()
forall (r :: EffectRow).
(Member BrigAccess r, Member (ErrorS 'NotATeamMember) r,
Member (ErrorS 'ConvAccessDenied) r) =>
Set AccessRole -> [(UserId, Maybe TeamMember)] -> Sem r ()
ensureAccessRole (Conversation -> Set AccessRole
convAccessRoles Conversation
conv) ((UserId -> (UserId, Maybe TeamMember))
-> [UserId] -> [(UserId, Maybe TeamMember)]
forall a b. (a -> b) -> [a] -> [b]
map (,Maybe TeamMember
forall a. Maybe a
Nothing) [UserId]
newUsers)
Local UserId -> [UserId] -> Sem r ()
forall (r :: EffectRow).
(Member BrigAccess r, Member (ErrorS 'NotConnected) r,
Member TeamStore r) =>
Local UserId -> [UserId] -> Sem r ()
ensureConnectedToLocalsOrSameTeam Local UserId
lusr [UserId]
newUsers
checkRemotes ::
Local UserId ->
[Remote UserId] ->
Sem r ()
checkRemotes :: Local UserId -> [Remote UserId] -> Sem r ()
checkRemotes Local UserId
lusr [Remote UserId]
remotes = do
Bool -> Sem r () -> Sem r ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([Remote UserId] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Remote UserId]
remotes) (Sem r () -> Sem r ()) -> Sem r () -> Sem r ()
forall a b. (a -> b) -> a -> b
$
Sem r Bool -> Sem r () -> Sem r ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
unlessM Sem r Bool
forall (r :: EffectRow). Member FederatorAccess r => Sem r Bool
E.isFederationConfigured (Sem r () -> Sem r ()) -> Sem r () -> Sem r ()
forall a b. (a -> b) -> a -> b
$
FederationError -> Sem r ()
forall e (r :: EffectRow) a. Member (Error e) r => e -> Sem r a
throw FederationError
FederationNotConfigured
Local UserId -> [Remote UserId] -> Sem r ()
forall (r :: EffectRow).
(Member BrigAccess r, Member (ErrorS 'NotConnected) r) =>
Local UserId -> [Remote UserId] -> Sem r ()
ensureConnectedToRemotes Local UserId
lusr [Remote UserId]
remotes
checkLHPolicyConflictsLocal ::
[UserId] ->
Sem r ()
checkLHPolicyConflictsLocal :: [UserId] -> Sem r ()
checkLHPolicyConflictsLocal [UserId]
newUsers = do
let convUsers :: [LocalMember]
convUsers = Conversation -> [LocalMember]
convLocalMembers Conversation
conv
Bool
allNewUsersGaveConsent <- [UserId] -> Sem r Bool
forall (r :: EffectRow).
(Member (Input Opts) r, Member LegalHoldStore r,
Member TeamStore r) =>
[UserId] -> Sem r Bool
allLegalholdConsentGiven [UserId]
newUsers
Sem r Bool -> Sem r () -> Sem r ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM ([UserId] -> Sem r Bool
forall (r :: EffectRow).
(Member (Input Opts) r, Member TeamStore r) =>
[UserId] -> Sem r Bool
anyLegalholdActivated (LocalMember -> UserId
lmId (LocalMember -> UserId) -> [LocalMember] -> [UserId]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [LocalMember]
convUsers)) (Sem r () -> Sem r ()) -> Sem r () -> Sem r ()
forall a b. (a -> b) -> a -> b
$
Bool -> Sem r () -> Sem r ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
allNewUsersGaveConsent (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 @'MissingLegalholdConsent
Sem r Bool -> Sem r () -> Sem r ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM ([UserId] -> Sem r Bool
forall (r :: EffectRow).
(Member (Input Opts) r, Member TeamStore r) =>
[UserId] -> Sem r Bool
anyLegalholdActivated [UserId]
newUsers) (Sem r () -> Sem r ()) -> Sem r () -> Sem r ()
forall a b. (a -> b) -> a -> b
$ do
Bool -> Sem r () -> Sem r ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
allNewUsersGaveConsent (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 @'MissingLegalholdConsent
[(LocalMember, UserLegalHoldStatus)]
convUsersLHStatus <- do
[(UserId, UserLegalHoldStatus)]
uidsStatus <- [UserId] -> Sem r [(UserId, UserLegalHoldStatus)]
forall (r :: EffectRow).
Member TeamStore r =>
[UserId] -> Sem r [(UserId, UserLegalHoldStatus)]
getLHStatusForUsers (LocalMember -> UserId
lmId (LocalMember -> UserId) -> [LocalMember] -> [UserId]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [LocalMember]
convUsers)
[(LocalMember, UserLegalHoldStatus)]
-> Sem r [(LocalMember, UserLegalHoldStatus)]
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([(LocalMember, UserLegalHoldStatus)]
-> Sem r [(LocalMember, UserLegalHoldStatus)])
-> [(LocalMember, UserLegalHoldStatus)]
-> Sem r [(LocalMember, UserLegalHoldStatus)]
forall a b. (a -> b) -> a -> b
$ (LocalMember
-> (UserId, UserLegalHoldStatus)
-> (LocalMember, UserLegalHoldStatus))
-> [LocalMember]
-> [(UserId, UserLegalHoldStatus)]
-> [(LocalMember, UserLegalHoldStatus)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\LocalMember
mem (UserId
_, UserLegalHoldStatus
status) -> (LocalMember
mem, UserLegalHoldStatus
status)) [LocalMember]
convUsers [(UserId, UserLegalHoldStatus)]
uidsStatus
if ((LocalMember, UserLegalHoldStatus) -> Bool)
-> [(LocalMember, UserLegalHoldStatus)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any
( \(LocalMember
mem, UserLegalHoldStatus
status) ->
LocalMember -> RoleName
lmConvRoleName LocalMember
mem RoleName -> RoleName -> Bool
forall a. Eq a => a -> a -> Bool
== RoleName
roleNameWireAdmin
Bool -> Bool -> Bool
&& UserLegalHoldStatus -> ConsentGiven
consentGiven UserLegalHoldStatus
status ConsentGiven -> ConsentGiven -> Bool
forall a. Eq a => a -> a -> Bool
== ConsentGiven
ConsentGiven
)
[(LocalMember, UserLegalHoldStatus)]
convUsersLHStatus
then do
[(LocalMember, UserLegalHoldStatus)]
-> ((LocalMember, UserLegalHoldStatus) -> Sem r ()) -> Sem r ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [(LocalMember, UserLegalHoldStatus)]
convUsersLHStatus (((LocalMember, UserLegalHoldStatus) -> Sem r ()) -> Sem r ())
-> ((LocalMember, UserLegalHoldStatus) -> Sem r ()) -> Sem r ()
forall a b. (a -> b) -> a -> b
$ \(LocalMember
mem, UserLegalHoldStatus
status) ->
Bool -> Sem r () -> Sem r ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (UserLegalHoldStatus -> ConsentGiven
consentGiven UserLegalHoldStatus
status ConsentGiven -> ConsentGiven -> Bool
forall a. Eq a => a -> a -> Bool
== ConsentGiven
ConsentNotGiven) (Sem r () -> Sem r ()) -> Sem r () -> Sem r ()
forall a b. (a -> b) -> a -> b
$ do
Qualified UserId
-> Local Conversation
-> BotsAndMembers
-> Qualified UserId
-> Sem r ()
forall (r :: EffectRow).
(Member BackendNotificationQueueAccess r,
Member (Error FederationError) r, Member (Error InternalError) r,
Member ExternalAccess r, Member FederatorAccess r,
Member NotificationSubsystem r, Member ProposalStore r,
Member (Input UTCTime) r, Member (Input Env) r,
Member MemberStore r, Member SubConversationStore r,
Member TinyLog r, Member Random r) =>
Qualified UserId
-> Local Conversation
-> BotsAndMembers
-> Qualified UserId
-> Sem r ()
kickMember
Qualified UserId
qusr
Local Conversation
lconv
(Conversation -> BotsAndMembers
convBotsAndMembers (Local Conversation -> Conversation
forall (t :: QTag) a. QualifiedWithTag t a -> a
tUnqualified Local Conversation
lconv))
(Local UserId -> Qualified UserId
forall (t :: QTag) a. QualifiedWithTag t a -> Qualified a
tUntagged (Local Conversation -> UserId -> Local UserId
forall (t :: QTag) x a.
QualifiedWithTag t x -> a -> QualifiedWithTag t a
qualifyAs Local Conversation
lconv (LocalMember -> UserId
lmId LocalMember
mem)))
else 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 @'MissingLegalholdConsent
checkLHPolicyConflictsRemote ::
FutureWork 'LegalholdPlusFederationNotImplemented [Remote UserId] ->
Sem r ()
checkLHPolicyConflictsRemote :: FutureWork 'LegalholdPlusFederationNotImplemented [Remote UserId]
-> Sem r ()
checkLHPolicyConflictsRemote FutureWork 'LegalholdPlusFederationNotImplemented [Remote UserId]
_remotes = () -> Sem r ()
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
checkTeamMemberAddPermissions :: Local UserId -> Sem r ()
checkTeamMemberAddPermissions :: Local UserId -> Sem r ()
checkTeamMemberAddPermissions Local UserId
lusr =
Maybe TeamId
-> (TeamId -> Sem r (Maybe TeamMember))
-> Sem r (Maybe (Maybe TeamMember))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (ConversationMetadata -> Maybe TeamId
cnvmTeam (Conversation -> ConversationMetadata
convMetadata Conversation
conv)) ((TeamId -> UserId -> Sem r (Maybe TeamMember))
-> UserId -> TeamId -> Sem r (Maybe TeamMember)
forall a b c. (a -> b -> c) -> b -> a -> c
flip TeamId -> UserId -> Sem r (Maybe TeamMember)
forall (r :: EffectRow).
Member TeamStore r =>
TeamId -> UserId -> Sem r (Maybe TeamMember)
E.getTeamMember (Local UserId -> UserId
forall (t :: QTag) a. QualifiedWithTag t a -> a
tUnqualified Local UserId
lusr))
Sem r (Maybe (Maybe TeamMember))
-> (Maybe (Maybe TeamMember) -> Sem r ()) -> Sem r ()
forall a b. Sem r a -> (a -> Sem r b) -> Sem r b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Sem r ()
-> (TeamMember -> Sem r ()) -> Maybe TeamMember -> Sem r ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> Sem r ()
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) (\TeamMember
tm -> Bool -> Sem r () -> Sem r ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (TeamMember
tm TeamMember -> Perm -> Bool
forall perm. IsPerm perm => TeamMember -> perm -> Bool
`hasPermission` Perm
AddRemoveConvMember) (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 @'InvalidOperation))
(Maybe TeamMember -> Sem r ())
-> (Maybe (Maybe TeamMember) -> Maybe TeamMember)
-> Maybe (Maybe TeamMember)
-> Sem r ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe (Maybe TeamMember) -> Maybe TeamMember
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join
performConversationAccessData ::
( HasConversationActionEffects 'ConversationAccessDataTag r,
Member (Error FederationError) r,
Member BackendNotificationQueueAccess r
) =>
Qualified UserId ->
Local Conversation ->
ConversationAccessData ->
Sem r (BotsAndMembers, ConversationAccessData)
performConversationAccessData :: forall (r :: EffectRow).
(HasConversationActionEffects 'ConversationAccessDataTag r,
Member (Error FederationError) r,
Member BackendNotificationQueueAccess r) =>
Qualified UserId
-> Local Conversation
-> ConversationAccessData
-> Sem r (BotsAndMembers, ConversationAccessData)
performConversationAccessData Qualified UserId
qusr Local Conversation
lconv ConversationAccessData
action = do
Bool -> Sem r () -> Sem r ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Conversation -> ConversationAccessData
convAccessData Conversation
conv ConversationAccessData -> ConversationAccessData -> Bool
forall a. Eq a => a -> a -> Bool
== ConversationAccessData
action) Sem r ()
forall (r :: EffectRow) a. Member (Error NoChanges) r => Sem r a
noChanges
Bool -> Sem r () -> Sem r ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when
( Access
CodeAccess Access -> [Access] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` Conversation -> [Access]
convAccess Conversation
conv
Bool -> Bool -> Bool
&& Access
CodeAccess Access -> Set Access -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` ConversationAccessData -> Set Access
cupAccess ConversationAccessData
action
)
(Sem r () -> Sem r ()) -> Sem r () -> Sem r ()
forall a b. (a -> b) -> a -> b
$ do
Key
key <- ConvId -> Sem r Key
forall (r :: EffectRow). Member CodeStore r => ConvId -> Sem r Key
E.makeKey (QualifiedWithTag 'QLocal ConvId -> ConvId
forall (t :: QTag) a. QualifiedWithTag t a -> a
tUnqualified QualifiedWithTag 'QLocal ConvId
lcnv)
Key -> Scope -> Sem r ()
forall (r :: EffectRow).
Member CodeStore r =>
Key -> Scope -> Sem r ()
E.deleteCode Key
key Scope
ReusableCode
let filterBotsAndMembers :: BotsAndMembers -> Sem r BotsAndMembers
filterBotsAndMembers =
BotsAndMembers -> Sem r BotsAndMembers
forall (r :: EffectRow). BotsAndMembers -> Sem r BotsAndMembers
maybeRemoveBots (BotsAndMembers -> Sem r BotsAndMembers)
-> (BotsAndMembers -> Sem r BotsAndMembers)
-> BotsAndMembers
-> Sem r BotsAndMembers
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> BotsAndMembers -> Sem r BotsAndMembers
forall (r :: EffectRow).
Member BrigAccess r =>
BotsAndMembers -> Sem r BotsAndMembers
maybeRemoveGuests (BotsAndMembers -> Sem r BotsAndMembers)
-> (BotsAndMembers -> Sem r BotsAndMembers)
-> BotsAndMembers
-> Sem r BotsAndMembers
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> BotsAndMembers -> Sem r BotsAndMembers
forall (r :: EffectRow).
Member TeamStore r =>
BotsAndMembers -> Sem r BotsAndMembers
maybeRemoveNonTeamMembers (BotsAndMembers -> Sem r BotsAndMembers)
-> (BotsAndMembers -> Sem r BotsAndMembers)
-> BotsAndMembers
-> Sem r BotsAndMembers
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> BotsAndMembers -> Sem r BotsAndMembers
forall (r :: EffectRow).
Member TeamStore r =>
BotsAndMembers -> Sem r BotsAndMembers
maybeRemoveTeamMembers
let current :: BotsAndMembers
current = Conversation -> BotsAndMembers
convBotsAndMembers Conversation
conv
BotsAndMembers
desired <- BotsAndMembers -> Sem r BotsAndMembers
filterBotsAndMembers BotsAndMembers
current
let toRemove :: BotsAndMembers
toRemove = BotsAndMembers -> BotsAndMembers -> BotsAndMembers
bmDiff BotsAndMembers
current BotsAndMembers
desired
ConvId -> ConversationAccessData -> Sem r ()
forall (r :: EffectRow).
Member ConversationStore r =>
ConvId -> ConversationAccessData -> Sem r ()
E.setConversationAccess (QualifiedWithTag 'QLocal ConvId -> ConvId
forall (t :: QTag) a. QualifiedWithTag t a -> a
tUnqualified QualifiedWithTag 'QLocal ConvId
lcnv) ConversationAccessData
action
Sem r () -> Sem r ()
forall (r :: EffectRow).
Member FireAndForget r =>
Sem r () -> Sem r ()
E.fireAndForget (Sem r () -> Sem r ()) -> Sem r () -> Sem r ()
forall a b. (a -> b) -> a -> b
$ do
(BotMember -> Sem r ()) -> Set BotMember -> Sem r ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (ConvId -> BotId -> Sem r ()
forall (r :: EffectRow).
Member BotAccess r =>
ConvId -> BotId -> Sem r ()
E.deleteBot (QualifiedWithTag 'QLocal ConvId -> ConvId
forall (t :: QTag) a. QualifiedWithTag t a -> a
tUnqualified QualifiedWithTag 'QLocal ConvId
lcnv) (BotId -> Sem r ())
-> (BotMember -> BotId) -> BotMember -> Sem r ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BotMember -> BotId
botMemId) (BotsAndMembers -> Set BotMember
bmBots BotsAndMembers
toRemove)
let bmToNotify :: BotsAndMembers
bmToNotify = BotsAndMembers
current {bmBots = bmBots desired}
[Qualified UserId] -> (Qualified UserId -> Sem r ()) -> Sem r ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ (QualifiedWithTag 'QLocal ConvId
-> BotsAndMembers -> [Qualified UserId]
forall x. Local x -> BotsAndMembers -> [Qualified UserId]
bmQualifiedMembers QualifiedWithTag 'QLocal ConvId
lcnv BotsAndMembers
toRemove) ((Qualified UserId -> Sem r ()) -> Sem r ())
-> (Qualified UserId -> Sem r ()) -> Sem r ()
forall a b. (a -> b) -> a -> b
$
Qualified UserId
-> Local Conversation
-> BotsAndMembers
-> Qualified UserId
-> Sem r ()
forall (r :: EffectRow).
(Member BackendNotificationQueueAccess r,
Member (Error FederationError) r, Member (Error InternalError) r,
Member ExternalAccess r, Member FederatorAccess r,
Member NotificationSubsystem r, Member ProposalStore r,
Member (Input UTCTime) r, Member (Input Env) r,
Member MemberStore r, Member SubConversationStore r,
Member TinyLog r, Member Random r) =>
Qualified UserId
-> Local Conversation
-> BotsAndMembers
-> Qualified UserId
-> Sem r ()
kickMember Qualified UserId
qusr Local Conversation
lconv BotsAndMembers
bmToNotify
(BotsAndMembers, ConversationAccessData)
-> Sem r (BotsAndMembers, ConversationAccessData)
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (BotsAndMembers
forall a. Monoid a => a
mempty, ConversationAccessData
action)
where
lcnv :: QualifiedWithTag 'QLocal ConvId
lcnv = (Conversation -> ConvId)
-> Local Conversation -> QualifiedWithTag 'QLocal 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 (.convId) Local Conversation
lconv
conv :: Conversation
conv = Local Conversation -> Conversation
forall (t :: QTag) a. QualifiedWithTag t a -> a
tUnqualified Local Conversation
lconv
maybeRemoveBots :: BotsAndMembers -> Sem r BotsAndMembers
maybeRemoveBots :: forall (r :: EffectRow). BotsAndMembers -> Sem r BotsAndMembers
maybeRemoveBots BotsAndMembers
bm =
if AccessRole -> Set AccessRole -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member AccessRole
ServiceAccessRole (ConversationAccessData -> Set AccessRole
cupAccessRoles ConversationAccessData
action)
then BotsAndMembers -> Sem r BotsAndMembers
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure BotsAndMembers
bm
else BotsAndMembers -> Sem r BotsAndMembers
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (BotsAndMembers -> Sem r BotsAndMembers)
-> BotsAndMembers -> Sem r BotsAndMembers
forall a b. (a -> b) -> a -> b
$ BotsAndMembers
bm {bmBots = mempty}
maybeRemoveGuests :: (Member BrigAccess r) => BotsAndMembers -> Sem r BotsAndMembers
maybeRemoveGuests :: forall (r :: EffectRow).
Member BrigAccess r =>
BotsAndMembers -> Sem r BotsAndMembers
maybeRemoveGuests BotsAndMembers
bm =
if AccessRole -> Set AccessRole -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member AccessRole
GuestAccessRole (ConversationAccessData -> Set AccessRole
cupAccessRoles ConversationAccessData
action)
then BotsAndMembers -> Sem r BotsAndMembers
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure BotsAndMembers
bm
else do
[UserId]
activated <- (User -> UserId) -> [User] -> [UserId]
forall a b. (a -> b) -> [a] -> [b]
map User -> UserId
User.userId ([User] -> [UserId]) -> Sem r [User] -> Sem r [UserId]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [UserId] -> Sem r [User]
forall (r :: EffectRow).
Member BrigAccess r =>
[UserId] -> Sem r [User]
E.lookupActivatedUsers (Set UserId -> [UserId]
forall a. Set a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (BotsAndMembers -> Set UserId
bmLocals BotsAndMembers
bm))
BotsAndMembers -> Sem r BotsAndMembers
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (BotsAndMembers -> Sem r BotsAndMembers)
-> BotsAndMembers -> Sem r BotsAndMembers
forall a b. (a -> b) -> a -> b
$ BotsAndMembers
bm {bmLocals = Set.fromList activated}
maybeRemoveNonTeamMembers :: (Member TeamStore r) => BotsAndMembers -> Sem r BotsAndMembers
maybeRemoveNonTeamMembers :: forall (r :: EffectRow).
Member TeamStore r =>
BotsAndMembers -> Sem r BotsAndMembers
maybeRemoveNonTeamMembers BotsAndMembers
bm =
if AccessRole -> Set AccessRole -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member AccessRole
NonTeamMemberAccessRole (ConversationAccessData -> Set AccessRole
cupAccessRoles ConversationAccessData
action)
then BotsAndMembers -> Sem r BotsAndMembers
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure BotsAndMembers
bm
else case Conversation -> Maybe TeamId
convTeam Conversation
conv of
Just TeamId
tid -> do
[UserId]
onlyTeamUsers <- (UserId -> Sem r Bool) -> [UserId] -> Sem r [UserId]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM ((Maybe TeamMember -> Bool)
-> Sem r (Maybe TeamMember) -> Sem r Bool
forall a b. (a -> b) -> Sem r a -> Sem r b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Maybe TeamMember -> Bool
forall a. Maybe a -> Bool
isJust (Sem r (Maybe TeamMember) -> Sem r Bool)
-> (UserId -> Sem r (Maybe TeamMember)) -> UserId -> Sem r Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TeamId -> UserId -> Sem r (Maybe TeamMember)
forall (r :: EffectRow).
Member TeamStore r =>
TeamId -> UserId -> Sem r (Maybe TeamMember)
E.getTeamMember TeamId
tid) (Set UserId -> [UserId]
forall a. Set a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (BotsAndMembers -> Set UserId
bmLocals BotsAndMembers
bm))
BotsAndMembers -> Sem r BotsAndMembers
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (BotsAndMembers -> Sem r BotsAndMembers)
-> BotsAndMembers -> Sem r BotsAndMembers
forall a b. (a -> b) -> a -> b
$ BotsAndMembers
bm {bmLocals = Set.fromList onlyTeamUsers, bmRemotes = mempty}
Maybe TeamId
Nothing -> BotsAndMembers -> Sem r BotsAndMembers
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure BotsAndMembers
bm
maybeRemoveTeamMembers :: (Member TeamStore r) => BotsAndMembers -> Sem r BotsAndMembers
maybeRemoveTeamMembers :: forall (r :: EffectRow).
Member TeamStore r =>
BotsAndMembers -> Sem r BotsAndMembers
maybeRemoveTeamMembers BotsAndMembers
bm =
if AccessRole -> Set AccessRole -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member AccessRole
TeamMemberAccessRole (ConversationAccessData -> Set AccessRole
cupAccessRoles ConversationAccessData
action)
then BotsAndMembers -> Sem r BotsAndMembers
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure BotsAndMembers
bm
else case Conversation -> Maybe TeamId
convTeam Conversation
conv of
Just TeamId
tid -> do
[UserId]
noTeamMembers <- (UserId -> Sem r Bool) -> [UserId] -> Sem r [UserId]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM ((Maybe TeamMember -> Bool)
-> Sem r (Maybe TeamMember) -> Sem r Bool
forall a b. (a -> b) -> Sem r a -> Sem r b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Maybe TeamMember -> Bool
forall a. Maybe a -> Bool
isNothing (Sem r (Maybe TeamMember) -> Sem r Bool)
-> (UserId -> Sem r (Maybe TeamMember)) -> UserId -> Sem r Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TeamId -> UserId -> Sem r (Maybe TeamMember)
forall (r :: EffectRow).
Member TeamStore r =>
TeamId -> UserId -> Sem r (Maybe TeamMember)
E.getTeamMember TeamId
tid) (Set UserId -> [UserId]
forall a. Set a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (BotsAndMembers -> Set UserId
bmLocals BotsAndMembers
bm))
BotsAndMembers -> Sem r BotsAndMembers
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (BotsAndMembers -> Sem r BotsAndMembers)
-> BotsAndMembers -> Sem r BotsAndMembers
forall a b. (a -> b) -> a -> b
$ BotsAndMembers
bm {bmLocals = Set.fromList noTeamMembers}
Maybe TeamId
Nothing -> BotsAndMembers -> Sem r BotsAndMembers
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure BotsAndMembers
bm
data LocalConversationUpdate = LocalConversationUpdate
{ LocalConversationUpdate -> Event
lcuEvent :: Event,
LocalConversationUpdate -> ConversationUpdate
lcuUpdate :: ConversationUpdate
}
deriving (Int -> LocalConversationUpdate -> ShowS
[LocalConversationUpdate] -> ShowS
LocalConversationUpdate -> String
(Int -> LocalConversationUpdate -> ShowS)
-> (LocalConversationUpdate -> String)
-> ([LocalConversationUpdate] -> ShowS)
-> Show LocalConversationUpdate
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> LocalConversationUpdate -> ShowS
showsPrec :: Int -> LocalConversationUpdate -> ShowS
$cshow :: LocalConversationUpdate -> String
show :: LocalConversationUpdate -> String
$cshowList :: [LocalConversationUpdate] -> ShowS
showList :: [LocalConversationUpdate] -> ShowS
Show)
updateLocalConversation ::
forall tag r.
( Member BackendNotificationQueueAccess r,
Member ConversationStore r,
Member (Error FederationError) r,
Member (ErrorS ('ActionDenied (ConversationActionPermission tag))) r,
Member (ErrorS 'InvalidOperation) r,
Member (ErrorS 'ConvNotFound) r,
Member ExternalAccess r,
Member NotificationSubsystem r,
Member (Input UTCTime) r,
HasConversationActionEffects tag r,
SingI tag
) =>
Local ConvId ->
Qualified UserId ->
Maybe ConnId ->
ConversationAction tag ->
Sem r LocalConversationUpdate
updateLocalConversation :: forall (tag :: ConversationActionTag) (r :: EffectRow).
(Member BackendNotificationQueueAccess r,
Member ConversationStore r, Member (Error FederationError) r,
Member
(ErrorS ('ActionDenied (ConversationActionPermission tag))) r,
Member (ErrorS 'InvalidOperation) r,
Member (ErrorS 'ConvNotFound) r, Member ExternalAccess r,
Member NotificationSubsystem r, Member (Input UTCTime) r,
HasConversationActionEffects tag r, SingI tag) =>
QualifiedWithTag 'QLocal ConvId
-> Qualified UserId
-> Maybe ConnId
-> ConversationAction tag
-> Sem r LocalConversationUpdate
updateLocalConversation QualifiedWithTag 'QLocal ConvId
lcnv Qualified UserId
qusr Maybe ConnId
con ConversationAction tag
action = do
let tag :: Sing tag
tag = forall {k} (a :: k). SingI a => Sing a
forall (a :: ConversationActionTag). SingI a => Sing a
sing @tag
Conversation
conv <- QualifiedWithTag 'QLocal ConvId -> Sem r Conversation
forall (r :: EffectRow).
(Member ConversationStore r, Member (ErrorS 'ConvNotFound) r) =>
QualifiedWithTag 'QLocal ConvId -> Sem r Conversation
getConversationWithError QualifiedWithTag 'QLocal ConvId
lcnv
Bool -> Sem r () -> Sem r ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Protocol -> ConversationActionTag -> Bool
protocolValidAction (Conversation -> Protocol
convProtocol Conversation
conv) (Sing tag -> Demote ConversationActionTag
forall k (a :: k). SingKind k => Sing a -> Demote k
forall (a :: ConversationActionTag).
Sing a -> Demote ConversationActionTag
fromSing Sing tag
tag)) (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 @'InvalidOperation
forall (tag :: ConversationActionTag) (r :: EffectRow).
(SingI tag, Member BackendNotificationQueueAccess r,
Member (Error FederationError) r,
Member
(ErrorS ('ActionDenied (ConversationActionPermission tag))) r,
Member (ErrorS 'ConvNotFound) r,
Member (ErrorS 'InvalidOperation) r, Member ExternalAccess r,
Member NotificationSubsystem r, Member (Input UTCTime) r,
HasConversationActionEffects tag r) =>
Local Conversation
-> Qualified UserId
-> Maybe ConnId
-> ConversationAction tag
-> Sem r LocalConversationUpdate
updateLocalConversationUnchecked @tag (QualifiedWithTag 'QLocal ConvId
-> Conversation -> Local Conversation
forall (t :: QTag) x a.
QualifiedWithTag t x -> a -> QualifiedWithTag t a
qualifyAs QualifiedWithTag 'QLocal ConvId
lcnv Conversation
conv) Qualified UserId
qusr Maybe ConnId
con ConversationAction tag
action
updateLocalConversationUnchecked ::
forall tag r.
( SingI tag,
Member BackendNotificationQueueAccess r,
Member (Error FederationError) r,
Member (ErrorS ('ActionDenied (ConversationActionPermission tag))) r,
Member (ErrorS 'ConvNotFound) r,
Member (ErrorS 'InvalidOperation) r,
Member ExternalAccess r,
Member NotificationSubsystem r,
Member (Input UTCTime) r,
HasConversationActionEffects tag r
) =>
Local Conversation ->
Qualified UserId ->
Maybe ConnId ->
ConversationAction tag ->
Sem r LocalConversationUpdate
updateLocalConversationUnchecked :: forall (tag :: ConversationActionTag) (r :: EffectRow).
(SingI tag, Member BackendNotificationQueueAccess r,
Member (Error FederationError) r,
Member
(ErrorS ('ActionDenied (ConversationActionPermission tag))) r,
Member (ErrorS 'ConvNotFound) r,
Member (ErrorS 'InvalidOperation) r, Member ExternalAccess r,
Member NotificationSubsystem r, Member (Input UTCTime) r,
HasConversationActionEffects tag r) =>
Local Conversation
-> Qualified UserId
-> Maybe ConnId
-> ConversationAction tag
-> Sem r LocalConversationUpdate
updateLocalConversationUnchecked Local Conversation
lconv Qualified UserId
qusr Maybe ConnId
con ConversationAction tag
action = do
let tag :: Sing tag
tag = forall {k} (a :: k). SingI a => Sing a
forall (a :: ConversationActionTag). SingI a => Sing a
sing @tag
lcnv :: QualifiedWithTag 'QLocal ConvId
lcnv = (Conversation -> ConvId)
-> Local Conversation -> QualifiedWithTag 'QLocal 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 (.convId) Local Conversation
lconv
conv :: Conversation
conv = Local Conversation -> Conversation
forall (t :: QTag) a. QualifiedWithTag t a -> a
tUnqualified Local Conversation
lconv
Either LocalMember RemoteMember
self <- forall {k} (e :: k) (r :: EffectRow) a.
Member (ErrorS e) r =>
Maybe a -> Sem r a
forall (e :: GalleyError) (r :: EffectRow) a.
Member (ErrorS e) r =>
Maybe a -> Sem r a
noteS @'ConvNotFound (Maybe (Either LocalMember RemoteMember)
-> Sem r (Either LocalMember RemoteMember))
-> Maybe (Either LocalMember RemoteMember)
-> Sem r (Either LocalMember RemoteMember)
forall a b. (a -> b) -> a -> b
$ Local Conversation
-> Conversation
-> Qualified UserId
-> Maybe (Either LocalMember RemoteMember)
forall x.
Local x
-> Conversation
-> Qualified UserId
-> Maybe (Either LocalMember RemoteMember)
forall uid mem x.
IsConvMemberId uid mem =>
Local x -> Conversation -> uid -> Maybe mem
getConvMember Local Conversation
lconv Conversation
conv Qualified UserId
qusr
Sing tag
-> QualifiedWithTag 'QLocal ConvId
-> ConversationAction tag
-> Conversation
-> Either LocalMember RemoteMember
-> Sem r ()
forall (tag :: ConversationActionTag) mem x (r :: EffectRow).
(IsConvMember mem, HasConversationActionEffects tag r,
(Member
(ErrorS ('ActionDenied (ConversationActionPermission tag))) r,
Member (ErrorS 'InvalidOperation) r)) =>
Sing tag
-> Local x
-> ConversationAction tag
-> Conversation
-> mem
-> Sem r ()
ensureConversationActionAllowed (forall {k} (a :: k). SingI a => Sing a
forall (a :: ConversationActionTag). SingI a => Sing a
sing @tag) QualifiedWithTag 'QLocal ConvId
lcnv ConversationAction tag
action Conversation
conv Either LocalMember RemoteMember
self
(BotsAndMembers
extraTargets, ConversationAction tag
action') <- Sing tag
-> Qualified UserId
-> Local Conversation
-> ConversationAction tag
-> Sem r (BotsAndMembers, ConversationAction tag)
forall (tag :: ConversationActionTag) (r :: EffectRow).
(HasConversationActionEffects tag r,
Member BackendNotificationQueueAccess r,
Member (Error FederationError) r) =>
Sing tag
-> Qualified UserId
-> Local Conversation
-> ConversationAction tag
-> Sem r (BotsAndMembers, ConversationAction tag)
performAction Sing tag
tag Qualified UserId
qusr Local Conversation
lconv ConversationAction tag
action
Sing tag
-> Qualified UserId
-> Bool
-> Maybe ConnId
-> Local Conversation
-> BotsAndMembers
-> ConversationAction tag
-> Sem r LocalConversationUpdate
forall (tag :: ConversationActionTag) (r :: EffectRow).
(Member BackendNotificationQueueAccess r, Member ExternalAccess r,
Member (Error FederationError) r, Member NotificationSubsystem r,
Member (Input UTCTime) r) =>
Sing tag
-> Qualified UserId
-> Bool
-> Maybe ConnId
-> Local Conversation
-> BotsAndMembers
-> ConversationAction tag
-> Sem r LocalConversationUpdate
notifyConversationAction
(forall {k} (a :: k). SingI a => Sing a
forall (a :: ConversationActionTag). SingI a => Sing a
sing @tag)
Qualified UserId
qusr
Bool
False
Maybe ConnId
con
Local Conversation
lconv
(Conversation -> BotsAndMembers
convBotsAndMembers Conversation
conv BotsAndMembers -> BotsAndMembers -> BotsAndMembers
forall a. Semigroup a => a -> a -> a
<> BotsAndMembers
extraTargets)
ConversationAction tag
action'
ensureConversationActionAllowed ::
forall tag mem x r.
( IsConvMember mem,
HasConversationActionEffects tag r,
( Member (ErrorS ('ActionDenied (ConversationActionPermission tag))) r,
Member (ErrorS 'InvalidOperation) r
)
) =>
Sing tag ->
Local x ->
ConversationAction (tag :: ConversationActionTag) ->
Conversation ->
mem ->
Sem r ()
ensureConversationActionAllowed :: forall (tag :: ConversationActionTag) mem x (r :: EffectRow).
(IsConvMember mem, HasConversationActionEffects tag r,
(Member
(ErrorS ('ActionDenied (ConversationActionPermission tag))) r,
Member (ErrorS 'InvalidOperation) r)) =>
Sing tag
-> Local x
-> ConversationAction tag
-> Conversation
-> mem
-> Sem r ()
ensureConversationActionAllowed Sing tag
tag Local x
loc ConversationAction tag
action Conversation
conv mem
self = do
Sing (ConversationActionPermission tag) -> mem -> Sem r ()
forall (action :: Action) mem (r :: EffectRow).
(IsConvMember mem, Member (ErrorS ('ActionDenied action)) r) =>
Sing action -> mem -> Sem r ()
ensureActionAllowed (Sing tag -> Sing (Apply ConversationActionPermissionSym0 tag)
forall (t :: ConversationActionTag).
Sing t -> Sing (Apply ConversationActionPermissionSym0 t)
sConversationActionPermission Sing tag
tag) mem
self
Bool -> Sem r () -> Sem r ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Sing tag -> Demote ConversationActionTag
forall k (a :: k). SingKind k => Sing a -> Demote k
forall (a :: ConversationActionTag).
Sing a -> Demote ConversationActionTag
fromSing Sing tag
tag ConversationActionTag -> ConversationActionTag -> Bool
forall a. Eq a => a -> a -> Bool
/= ConversationActionTag
ConversationRenameTag) (Sem r () -> Sem r ()) -> Sem r () -> Sem r ()
forall a b. (a -> b) -> a -> b
$
Conversation -> Sem r ()
forall (r :: EffectRow).
Member (ErrorS 'InvalidOperation) r =>
Conversation -> Sem r ()
ensureGroupConversation Conversation
conv
Sing tag
-> Local x
-> ConversationAction tag
-> Conversation
-> mem
-> Sem r ()
forall (tag :: ConversationActionTag) mem (r :: EffectRow) x.
(IsConvMember mem, HasConversationActionEffects tag r) =>
Sing tag
-> Local x
-> ConversationAction tag
-> Conversation
-> mem
-> Sem r ()
ensureAllowed Sing tag
tag Local x
loc ConversationAction tag
action Conversation
conv mem
self
addMembersToLocalConversation ::
( Member MemberStore r,
Member (Error NoChanges) r
) =>
Local ConvId ->
UserList UserId ->
RoleName ->
Sem r (BotsAndMembers, ConversationJoin)
addMembersToLocalConversation :: forall (r :: EffectRow).
(Member MemberStore r, Member (Error NoChanges) r) =>
QualifiedWithTag 'QLocal ConvId
-> UserList UserId
-> RoleName
-> Sem r (BotsAndMembers, ConversationJoin)
addMembersToLocalConversation QualifiedWithTag 'QLocal ConvId
lcnv UserList UserId
users RoleName
role = do
([LocalMember]
lmems, [RemoteMember]
rmems) <- ConvId
-> UserList (UserId, RoleName)
-> Sem r ([LocalMember], [RemoteMember])
forall (r :: EffectRow) u.
(Member MemberStore r, ToUserRole u) =>
ConvId -> UserList u -> Sem r ([LocalMember], [RemoteMember])
E.createMembers (QualifiedWithTag 'QLocal ConvId -> ConvId
forall (t :: QTag) a. QualifiedWithTag t a -> a
tUnqualified QualifiedWithTag 'QLocal ConvId
lcnv) ((UserId -> (UserId, RoleName))
-> UserList UserId -> UserList (UserId, RoleName)
forall a b. (a -> b) -> UserList a -> UserList b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (,RoleName
role) UserList UserId
users)
NonEmpty (Qualified UserId)
neUsers <- NoChanges
-> Maybe (NonEmpty (Qualified UserId))
-> Sem r (NonEmpty (Qualified UserId))
forall e (r :: EffectRow) a.
Member (Error e) r =>
e -> Maybe a -> Sem r a
note NoChanges
NoChanges (Maybe (NonEmpty (Qualified UserId))
-> Sem r (NonEmpty (Qualified UserId)))
-> Maybe (NonEmpty (Qualified UserId))
-> Sem r (NonEmpty (Qualified UserId))
forall a b. (a -> b) -> a -> b
$ [Qualified UserId] -> Maybe (NonEmpty (Qualified UserId))
forall a. [a] -> Maybe (NonEmpty a)
nonEmpty (QualifiedWithTag 'QLocal ConvId
-> UserList UserId -> [Qualified UserId]
forall x a. Local x -> UserList a -> [Qualified a]
ulAll QualifiedWithTag 'QLocal ConvId
lcnv UserList UserId
users)
let action :: ConversationJoin
action = NonEmpty (Qualified UserId) -> RoleName -> ConversationJoin
ConversationJoin NonEmpty (Qualified UserId)
neUsers RoleName
role
(BotsAndMembers, ConversationJoin)
-> Sem r (BotsAndMembers, ConversationJoin)
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([LocalMember] -> [RemoteMember] -> BotsAndMembers
bmFromMembers [LocalMember]
lmems [RemoteMember]
rmems, ConversationJoin
action)
notifyConversationAction ::
forall tag r.
( Member BackendNotificationQueueAccess r,
Member ExternalAccess r,
Member (Error FederationError) r,
Member NotificationSubsystem r,
Member (Input UTCTime) r
) =>
Sing tag ->
Qualified UserId ->
Bool ->
Maybe ConnId ->
Local Conversation ->
BotsAndMembers ->
ConversationAction (tag :: ConversationActionTag) ->
Sem r LocalConversationUpdate
notifyConversationAction :: forall (tag :: ConversationActionTag) (r :: EffectRow).
(Member BackendNotificationQueueAccess r, Member ExternalAccess r,
Member (Error FederationError) r, Member NotificationSubsystem r,
Member (Input UTCTime) r) =>
Sing tag
-> Qualified UserId
-> Bool
-> Maybe ConnId
-> Local Conversation
-> BotsAndMembers
-> ConversationAction tag
-> Sem r LocalConversationUpdate
notifyConversationAction Sing tag
tag Qualified UserId
quid Bool
notifyOrigDomain Maybe ConnId
con Local Conversation
lconv BotsAndMembers
targets ConversationAction tag
action = do
UTCTime
now <- Sem r UTCTime
forall i (r :: EffectRow). Member (Input i) r => Sem r i
input
let lcnv :: QualifiedWithTag 'QLocal ConvId
lcnv = (Conversation -> ConvId)
-> Local Conversation -> QualifiedWithTag 'QLocal 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 (.convId) Local Conversation
lconv
e :: Event
e = Sing tag
-> UTCTime
-> Qualified UserId
-> Qualified ConvId
-> Maybe SubConvId
-> ConversationAction tag
-> Event
forall (tag :: ConversationActionTag).
Sing tag
-> UTCTime
-> Qualified UserId
-> Qualified ConvId
-> Maybe SubConvId
-> ConversationAction tag
-> Event
conversationActionToEvent Sing tag
tag UTCTime
now Qualified UserId
quid (QualifiedWithTag 'QLocal ConvId -> Qualified ConvId
forall (t :: QTag) a. QualifiedWithTag t a -> Qualified a
tUntagged QualifiedWithTag 'QLocal ConvId
lcnv) Maybe SubConvId
forall a. Maybe a
Nothing ConversationAction tag
action
mkUpdate :: [UserId] -> ConversationUpdate
mkUpdate [UserId]
uids =
UTCTime
-> Qualified UserId
-> ConvId
-> [UserId]
-> SomeConversationAction
-> ConversationUpdate
ConversationUpdate
UTCTime
now
Qualified UserId
quid
(QualifiedWithTag 'QLocal ConvId -> ConvId
forall (t :: QTag) a. QualifiedWithTag t a -> a
tUnqualified QualifiedWithTag 'QLocal ConvId
lcnv)
[UserId]
uids
(Sing tag -> ConversationAction tag -> SomeConversationAction
forall (tag :: ConversationActionTag).
Sing tag -> ConversationAction tag -> SomeConversationAction
SomeConversationAction Sing tag
tag ConversationAction tag
action)
ConversationUpdate
update <-
([QualifiedWithTag 'QRemote (Maybe ConversationUpdate)]
-> ConversationUpdate)
-> Sem r [QualifiedWithTag 'QRemote (Maybe ConversationUpdate)]
-> Sem r ConversationUpdate
forall a b. (a -> b) -> Sem r a -> Sem r b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ConversationUpdate
-> Maybe ConversationUpdate -> ConversationUpdate
forall a. a -> Maybe a -> a
fromMaybe ([UserId] -> ConversationUpdate
mkUpdate []) (Maybe ConversationUpdate -> ConversationUpdate)
-> ([QualifiedWithTag 'QRemote (Maybe ConversationUpdate)]
-> Maybe ConversationUpdate)
-> [QualifiedWithTag 'QRemote (Maybe ConversationUpdate)]
-> ConversationUpdate
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Maybe ConversationUpdate] -> Maybe ConversationUpdate
forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum ([Maybe ConversationUpdate] -> Maybe ConversationUpdate)
-> ([QualifiedWithTag 'QRemote (Maybe ConversationUpdate)]
-> [Maybe ConversationUpdate])
-> [QualifiedWithTag 'QRemote (Maybe ConversationUpdate)]
-> Maybe ConversationUpdate
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (QualifiedWithTag 'QRemote (Maybe ConversationUpdate)
-> Maybe ConversationUpdate)
-> [QualifiedWithTag 'QRemote (Maybe ConversationUpdate)]
-> [Maybe ConversationUpdate]
forall a b. (a -> b) -> [a] -> [b]
map QualifiedWithTag 'QRemote (Maybe ConversationUpdate)
-> Maybe ConversationUpdate
forall (t :: QTag) a. QualifiedWithTag t a -> a
tUnqualified) (Sem r [QualifiedWithTag 'QRemote (Maybe ConversationUpdate)]
-> Sem r ConversationUpdate)
-> Sem r [QualifiedWithTag 'QRemote (Maybe ConversationUpdate)]
-> Sem r ConversationUpdate
forall a b. (a -> b) -> a -> b
$
DeliveryMode
-> [Remote UserId]
-> (Remote [UserId]
-> FedQueueClient 'Galley (Maybe ConversationUpdate))
-> Sem r [QualifiedWithTag 'QRemote (Maybe ConversationUpdate)]
forall (c :: Component) (f :: * -> *) (r :: EffectRow) x a.
(KnownComponent c, Foldable f, Functor f,
Member (Error FederationError) r,
Member BackendNotificationQueueAccess r) =>
DeliveryMode
-> f (Remote x)
-> (Remote [x] -> FedQueueClient c a)
-> Sem r [Remote a]
enqueueNotificationsConcurrently DeliveryMode
Q.Persistent (Set (Remote UserId) -> [Remote UserId]
forall a. Set a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (BotsAndMembers -> Set (Remote UserId)
bmRemotes BotsAndMembers
targets)) ((Remote [UserId]
-> FedQueueClient 'Galley (Maybe ConversationUpdate))
-> Sem r [QualifiedWithTag 'QRemote (Maybe ConversationUpdate)])
-> (Remote [UserId]
-> FedQueueClient 'Galley (Maybe ConversationUpdate))
-> Sem r [QualifiedWithTag 'QRemote (Maybe ConversationUpdate)]
forall a b. (a -> b) -> a -> b
$
\Remote [UserId]
ruids -> do
let update :: ConversationUpdate
update = [UserId] -> ConversationUpdate
mkUpdate (Remote [UserId] -> [UserId]
forall (t :: QTag) a. QualifiedWithTag t a -> a
tUnqualified Remote [UserId]
ruids)
if Bool
notifyOrigDomain Bool -> Bool -> Bool
|| Remote [UserId] -> Domain
forall (t :: QTag) a. QualifiedWithTag t a -> Domain
tDomain Remote [UserId]
ruids Domain -> Domain -> Bool
forall a. Eq a => a -> a -> Bool
/= Qualified UserId -> Domain
forall a. Qualified a -> Domain
qDomain Qualified UserId
quid
then do
ConversationUpdate
-> FedQueueClient 'Galley (PayloadBundle 'Galley)
makeConversationUpdateBundle ConversationUpdate
update FedQueueClient 'Galley (PayloadBundle 'Galley)
-> (PayloadBundle 'Galley -> FedQueueClient 'Galley ())
-> FedQueueClient 'Galley ()
forall a b.
FedQueueClient 'Galley a
-> (a -> FedQueueClient 'Galley b) -> FedQueueClient 'Galley b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= PayloadBundle 'Galley -> FedQueueClient 'Galley ()
forall (c :: Component).
KnownComponent c =>
PayloadBundle c -> FedQueueClient c ()
sendBundle
Maybe ConversationUpdate
-> FedQueueClient 'Galley (Maybe ConversationUpdate)
forall a. a -> FedQueueClient 'Galley a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe ConversationUpdate
forall a. Maybe a
Nothing
else Maybe ConversationUpdate
-> FedQueueClient 'Galley (Maybe ConversationUpdate)
forall a. a -> FedQueueClient 'Galley a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ConversationUpdate -> Maybe ConversationUpdate
forall a. a -> Maybe a
Just ConversationUpdate
update)
Maybe ConnId
-> Event -> Local (Set UserId) -> Set BotMember -> Sem r ()
forall (r :: EffectRow) (f :: * -> *).
(Member ExternalAccess r, Member NotificationSubsystem r,
Foldable f) =>
Maybe ConnId
-> Event -> Local (f UserId) -> f BotMember -> Sem r ()
pushConversationEvent Maybe ConnId
con Event
e (QualifiedWithTag 'QLocal ConvId -> Set UserId -> Local (Set UserId)
forall (t :: QTag) x a.
QualifiedWithTag t x -> a -> QualifiedWithTag t a
qualifyAs QualifiedWithTag 'QLocal ConvId
lcnv (BotsAndMembers -> Set UserId
bmLocals BotsAndMembers
targets)) (BotsAndMembers -> Set BotMember
bmBots BotsAndMembers
targets)
LocalConversationUpdate -> Sem r LocalConversationUpdate
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LocalConversationUpdate -> Sem r LocalConversationUpdate)
-> LocalConversationUpdate -> Sem r LocalConversationUpdate
forall a b. (a -> b) -> a -> b
$ Event -> ConversationUpdate -> LocalConversationUpdate
LocalConversationUpdate Event
e ConversationUpdate
update
updateLocalStateOfRemoteConv ::
( Member BrigAccess r,
Member NotificationSubsystem r,
Member ExternalAccess r,
Member (Input (Local ())) r,
Member MemberStore r,
Member P.TinyLog r
) =>
Remote F.ConversationUpdate ->
Maybe ConnId ->
Sem r (Maybe Event)
updateLocalStateOfRemoteConv :: forall (r :: EffectRow).
(Member BrigAccess r, Member NotificationSubsystem r,
Member ExternalAccess r, Member (Input (Local ())) r,
Member MemberStore r, Member TinyLog r) =>
Remote ConversationUpdate -> Maybe ConnId -> Sem r (Maybe Event)
updateLocalStateOfRemoteConv Remote ConversationUpdate
rcu Maybe ConnId
con = do
Local ()
loc <- () -> Sem r (Local ())
forall (r :: EffectRow) a.
Member (Input (Local ())) r =>
a -> Sem r (Local a)
qualifyLocal ()
let cu :: ConversationUpdate
cu = Remote ConversationUpdate -> ConversationUpdate
forall (t :: QTag) a. QualifiedWithTag t a -> a
tUnqualified Remote ConversationUpdate
rcu
rconvId :: QualifiedWithTag 'QRemote ConvId
rconvId = (ConversationUpdate -> ConvId)
-> Remote ConversationUpdate -> QualifiedWithTag 'QRemote ConvId
forall a b.
(a -> b)
-> QualifiedWithTag 'QRemote a -> QualifiedWithTag 'QRemote b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (.convId) Remote ConversationUpdate
rcu
qconvId :: Qualified ConvId
qconvId = QualifiedWithTag 'QRemote ConvId -> Qualified ConvId
forall (t :: QTag) a. QualifiedWithTag t a -> Qualified a
tUntagged QualifiedWithTag 'QRemote ConvId
rconvId
([UserId]
presentUsers, Bool
allUsersArePresent) <-
[UserId]
-> QualifiedWithTag 'QRemote ConvId -> Sem r ([UserId], Bool)
forall (r :: EffectRow).
Member MemberStore r =>
[UserId]
-> QualifiedWithTag 'QRemote ConvId -> Sem r ([UserId], Bool)
E.selectRemoteMembers ConversationUpdate
cu.alreadyPresentUsers QualifiedWithTag 'QRemote ConvId
rconvId
(Maybe SomeConversationAction
mActualAction, [UserId]
extraTargets) <- case ConversationUpdate
cu.action of
sca :: SomeConversationAction
sca@(SomeConversationAction Sing tag
singTag ConversationAction tag
action) -> case Sing tag
singTag of
Sing tag
SConversationActionTag tag
SConversationJoinTag -> do
let ConversationJoin NonEmpty (Qualified UserId)
toAdd RoleName
role = ConversationAction tag
action
let ([UserId]
localUsers, [Remote UserId]
remoteUsers) = Local ()
-> NonEmpty (Qualified UserId) -> ([UserId], [Remote UserId])
forall (f :: * -> *) x a.
Foldable f =>
Local x -> f (Qualified a) -> ([a], [Remote a])
partitionQualified Local ()
loc NonEmpty (Qualified UserId)
toAdd
[UserId]
addedLocalUsers <- Set UserId -> [UserId]
forall a. Set a -> [a]
Set.toList (Set UserId -> [UserId]) -> Sem r (Set UserId) -> Sem r [UserId]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> QualifiedWithTag 'QRemote ConvId
-> Qualified UserId -> [UserId] -> Sem r (Set UserId)
forall (r :: EffectRow).
(Member BrigAccess r, Member MemberStore r, Member TinyLog r) =>
QualifiedWithTag 'QRemote ConvId
-> Qualified UserId -> [UserId] -> Sem r (Set UserId)
addLocalUsersToRemoteConv QualifiedWithTag 'QRemote ConvId
rconvId ConversationUpdate
cu.origUserId [UserId]
localUsers
let allAddedUsers :: [Qualified UserId]
allAddedUsers = (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 () -> UserId -> Local UserId
forall (t :: QTag) x a.
QualifiedWithTag t x -> a -> QualifiedWithTag t a
qualifyAs Local ()
loc) [UserId]
addedLocalUsers [Qualified UserId] -> [Qualified UserId] -> [Qualified UserId]
forall a. Semigroup a => a -> a -> a
<> (Remote UserId -> Qualified UserId)
-> [Remote UserId] -> [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]
remoteUsers
(Maybe SomeConversationAction, [UserId])
-> Sem r (Maybe SomeConversationAction, [UserId])
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Maybe SomeConversationAction, [UserId])
-> Sem r (Maybe SomeConversationAction, [UserId]))
-> (Maybe SomeConversationAction, [UserId])
-> Sem r (Maybe SomeConversationAction, [UserId])
forall a b. (a -> b) -> a -> b
$
( (NonEmpty (Qualified UserId) -> SomeConversationAction)
-> Maybe (NonEmpty (Qualified UserId))
-> Maybe SomeConversationAction
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
(\NonEmpty (Qualified UserId)
users -> Sing 'ConversationJoinTag
-> ConversationAction 'ConversationJoinTag
-> SomeConversationAction
forall (tag :: ConversationActionTag).
Sing tag -> ConversationAction tag -> SomeConversationAction
SomeConversationAction Sing 'ConversationJoinTag
SConversationActionTag 'ConversationJoinTag
SConversationJoinTag (NonEmpty (Qualified UserId) -> RoleName -> ConversationJoin
ConversationJoin NonEmpty (Qualified UserId)
users RoleName
role))
([Qualified UserId] -> Maybe (NonEmpty (Qualified UserId))
forall a. [a] -> Maybe (NonEmpty a)
nonEmpty [Qualified UserId]
allAddedUsers),
[UserId]
addedLocalUsers
)
Sing tag
SConversationActionTag tag
SConversationLeaveTag -> do
let users :: [UserId]
users = Local ()
-> (Local UserId -> [UserId])
-> (Remote UserId -> [UserId])
-> Qualified UserId
-> [UserId]
forall x a b.
Local x -> (Local a -> b) -> (Remote a -> b) -> Qualified a -> b
foldQualified Local ()
loc (UserId -> [UserId]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (UserId -> [UserId])
-> (Local UserId -> UserId) -> Local UserId -> [UserId]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Local UserId -> UserId
forall (t :: QTag) a. QualifiedWithTag t a -> a
tUnqualified) ([UserId] -> Remote UserId -> [UserId]
forall a b. a -> b -> a
const []) ConversationUpdate
cu.origUserId
QualifiedWithTag 'QRemote ConvId -> [UserId] -> Sem r ()
forall (r :: EffectRow).
Member MemberStore r =>
QualifiedWithTag 'QRemote ConvId -> [UserId] -> Sem r ()
E.deleteMembersInRemoteConversation QualifiedWithTag 'QRemote ConvId
rconvId [UserId]
users
(Maybe SomeConversationAction, [UserId])
-> Sem r (Maybe SomeConversationAction, [UserId])
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SomeConversationAction -> Maybe SomeConversationAction
forall a. a -> Maybe a
Just SomeConversationAction
sca, [])
Sing tag
SConversationActionTag tag
SConversationRemoveMembersTag -> do
let localUsers :: [UserId]
localUsers = Domain -> NonEmpty (Qualified UserId) -> [UserId]
getLocalUsers (Local () -> Domain
forall (t :: QTag) a. QualifiedWithTag t a -> Domain
tDomain Local ()
loc) (NonEmpty (Qualified UserId) -> [UserId])
-> (ConversationAction tag -> NonEmpty (Qualified UserId))
-> ConversationAction tag
-> [UserId]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConversationRemoveMembers -> NonEmpty (Qualified UserId)
ConversationAction tag -> NonEmpty (Qualified UserId)
crmTargets (ConversationAction tag -> [UserId])
-> ConversationAction tag -> [UserId]
forall a b. (a -> b) -> a -> b
$ ConversationAction tag
action
QualifiedWithTag 'QRemote ConvId -> [UserId] -> Sem r ()
forall (r :: EffectRow).
Member MemberStore r =>
QualifiedWithTag 'QRemote ConvId -> [UserId] -> Sem r ()
E.deleteMembersInRemoteConversation QualifiedWithTag 'QRemote ConvId
rconvId [UserId]
localUsers
(Maybe SomeConversationAction, [UserId])
-> Sem r (Maybe SomeConversationAction, [UserId])
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SomeConversationAction -> Maybe SomeConversationAction
forall a. a -> Maybe a
Just SomeConversationAction
sca, [])
Sing tag
SConversationActionTag tag
SConversationMemberUpdateTag ->
(Maybe SomeConversationAction, [UserId])
-> Sem r (Maybe SomeConversationAction, [UserId])
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SomeConversationAction -> Maybe SomeConversationAction
forall a. a -> Maybe a
Just SomeConversationAction
sca, [])
Sing tag
SConversationActionTag tag
SConversationDeleteTag -> do
QualifiedWithTag 'QRemote ConvId -> [UserId] -> Sem r ()
forall (r :: EffectRow).
Member MemberStore r =>
QualifiedWithTag 'QRemote ConvId -> [UserId] -> Sem r ()
E.deleteMembersInRemoteConversation QualifiedWithTag 'QRemote ConvId
rconvId [UserId]
presentUsers
(Maybe SomeConversationAction, [UserId])
-> Sem r (Maybe SomeConversationAction, [UserId])
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SomeConversationAction -> Maybe SomeConversationAction
forall a. a -> Maybe a
Just SomeConversationAction
sca, [])
Sing tag
SConversationActionTag tag
SConversationRenameTag -> (Maybe SomeConversationAction, [UserId])
-> Sem r (Maybe SomeConversationAction, [UserId])
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SomeConversationAction -> Maybe SomeConversationAction
forall a. a -> Maybe a
Just SomeConversationAction
sca, [])
Sing tag
SConversationActionTag tag
SConversationMessageTimerUpdateTag -> (Maybe SomeConversationAction, [UserId])
-> Sem r (Maybe SomeConversationAction, [UserId])
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SomeConversationAction -> Maybe SomeConversationAction
forall a. a -> Maybe a
Just SomeConversationAction
sca, [])
Sing tag
SConversationActionTag tag
SConversationReceiptModeUpdateTag -> (Maybe SomeConversationAction, [UserId])
-> Sem r (Maybe SomeConversationAction, [UserId])
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SomeConversationAction -> Maybe SomeConversationAction
forall a. a -> Maybe a
Just SomeConversationAction
sca, [])
Sing tag
SConversationActionTag tag
SConversationAccessDataTag -> (Maybe SomeConversationAction, [UserId])
-> Sem r (Maybe SomeConversationAction, [UserId])
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SomeConversationAction -> Maybe SomeConversationAction
forall a. a -> Maybe a
Just SomeConversationAction
sca, [])
Sing tag
SConversationActionTag tag
SConversationUpdateProtocolTag -> (Maybe SomeConversationAction, [UserId])
-> Sem r (Maybe SomeConversationAction, [UserId])
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SomeConversationAction -> Maybe SomeConversationAction
forall a. a -> Maybe a
Just SomeConversationAction
sca, [])
Bool -> Sem r () -> Sem r ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
allUsersArePresent (Sem r () -> Sem r ()) -> Sem r () -> Sem r ()
forall a b. (a -> b) -> a -> b
$
(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' ConversationUpdate
cu.convId)
(Msg -> Msg) -> (Msg -> Msg) -> Msg -> Msg
forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 ConversationUpdate -> Domain
forall (t :: QTag) a. QualifiedWithTag t a -> Domain
tDomain Remote ConversationUpdate
rcu))
(Msg -> Msg) -> (Msg -> Msg) -> Msg -> Msg
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Msg -> Msg
forall a. ToBytes a => a -> Msg -> Msg
Log.msg
( ByteString
"Attempt to send notification about conversation update \
\to users not in the conversation" ::
ByteString
)
Maybe SomeConversationAction
-> (SomeConversationAction -> Sem r Event) -> Sem r (Maybe Event)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for Maybe SomeConversationAction
mActualAction ((SomeConversationAction -> Sem r Event) -> Sem r (Maybe Event))
-> (SomeConversationAction -> Sem r Event) -> Sem r (Maybe Event)
forall a b. (a -> b) -> a -> b
$ \(SomeConversationAction Sing tag
tag ConversationAction tag
action) -> do
let event :: Event
event = Sing tag
-> UTCTime
-> Qualified UserId
-> Qualified ConvId
-> Maybe SubConvId
-> ConversationAction tag
-> Event
forall (tag :: ConversationActionTag).
Sing tag
-> UTCTime
-> Qualified UserId
-> Qualified ConvId
-> Maybe SubConvId
-> ConversationAction tag
-> Event
conversationActionToEvent Sing tag
tag ConversationUpdate
cu.time ConversationUpdate
cu.origUserId Qualified ConvId
qconvId Maybe SubConvId
forall a. Maybe a
Nothing ConversationAction tag
action
targets :: [UserId]
targets = [UserId] -> [UserId]
forall a. Ord a => [a] -> [a]
nubOrd ([UserId] -> [UserId]) -> [UserId] -> [UserId]
forall a b. (a -> b) -> a -> b
$ [UserId]
presentUsers [UserId] -> [UserId] -> [UserId]
forall a. Semigroup a => a -> a -> a
<> [UserId]
extraTargets
Maybe ConnId -> Event -> Local [UserId] -> [BotMember] -> Sem r ()
forall (r :: EffectRow) (f :: * -> *).
(Member ExternalAccess r, Member NotificationSubsystem r,
Foldable f) =>
Maybe ConnId
-> Event -> Local (f UserId) -> f BotMember -> Sem r ()
pushConversationEvent Maybe ConnId
con Event
event (Local () -> [UserId] -> Local [UserId]
forall (t :: QTag) x a.
QualifiedWithTag t x -> a -> QualifiedWithTag t a
qualifyAs Local ()
loc [UserId]
targets) [] Sem r () -> Event -> Sem r Event
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Event
event
addLocalUsersToRemoteConv ::
( Member BrigAccess r,
Member MemberStore r,
Member P.TinyLog r
) =>
Remote ConvId ->
Qualified UserId ->
[UserId] ->
Sem r (Set UserId)
addLocalUsersToRemoteConv :: forall (r :: EffectRow).
(Member BrigAccess r, Member MemberStore r, Member TinyLog r) =>
QualifiedWithTag 'QRemote ConvId
-> Qualified UserId -> [UserId] -> Sem r (Set UserId)
addLocalUsersToRemoteConv QualifiedWithTag 'QRemote ConvId
remoteConvId Qualified UserId
qAdder [UserId]
localUsers = do
[ConnectionStatusV2]
connStatus <- [UserId]
-> Maybe [Qualified UserId]
-> Maybe Relation
-> Sem r [ConnectionStatusV2]
forall (r :: EffectRow).
Member BrigAccess r =>
[UserId]
-> Maybe [Qualified UserId]
-> Maybe Relation
-> Sem r [ConnectionStatusV2]
E.getConnections [UserId]
localUsers ([Qualified UserId] -> Maybe [Qualified UserId]
forall a. a -> Maybe a
Just [Qualified UserId
qAdder]) (Relation -> Maybe Relation
forall a. a -> Maybe a
Just Relation
Accepted)
let localUserIdsSet :: Set UserId
localUserIdsSet = [UserId] -> Set UserId
forall a. Ord a => [a] -> Set a
Set.fromList [UserId]
localUsers
adder :: UserId
adder = Qualified UserId -> UserId
forall a. Qualified a -> a
qUnqualified Qualified UserId
qAdder
connected :: Set UserId
connected =
[UserId] -> Set UserId
forall a. Ord a => [a] -> Set a
Set.fromList ((ConnectionStatusV2 -> UserId) -> [ConnectionStatusV2] -> [UserId]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ConnectionStatusV2 -> UserId
csv2From [ConnectionStatusV2]
connStatus)
Set UserId -> Set UserId -> Set UserId
forall a. Semigroup a => a -> a -> a
<> if UserId -> Set UserId -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member UserId
adder Set UserId
localUserIdsSet
then UserId -> Set UserId
forall a. a -> Set a
Set.singleton UserId
adder
else Set UserId
forall a. Monoid a => a
mempty
unconnected :: Set UserId
unconnected = Set UserId -> Set UserId -> Set UserId
forall a. Ord a => Set a -> Set a -> Set a
Set.difference Set UserId
localUserIdsSet Set UserId
connected
connectedList :: [UserId]
connectedList = Set UserId -> [UserId]
forall a. Set a -> [a]
Set.toList Set UserId
connected
Bool -> Sem r () -> Sem r ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Set UserId -> Bool
forall a. Set a -> Bool
Set.null Set UserId
unconnected) (Sem r () -> Sem r ()) -> Sem r () -> Sem r ()
forall a b. (a -> b) -> a -> b
$
(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
$
Text -> Msg -> Msg
forall a. ToBytes a => a -> Msg -> Msg
Log.msg (Text
"A remote user is trying to add unconnected local users to a remote conversation" :: Text)
(Msg -> Msg) -> (Msg -> Msg) -> Msg -> Msg
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> String -> Msg -> Msg
forall a. ToBytes a => ByteString -> a -> Msg -> Msg
Log.field ByteString
"remote_user" (Qualified UserId -> String
forall a. Show a => a -> String
show Qualified UserId
qAdder)
(Msg -> Msg) -> (Msg -> Msg) -> Msg -> Msg
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> String -> Msg -> Msg
forall a. ToBytes a => ByteString -> a -> Msg -> Msg
Log.field ByteString
"local_unconnected_users" (Set UserId -> String
forall a. Show a => a -> String
show Set UserId
unconnected)
QualifiedWithTag 'QRemote ConvId -> [UserId] -> Sem r ()
forall (r :: EffectRow).
Member MemberStore r =>
QualifiedWithTag 'QRemote ConvId -> [UserId] -> Sem r ()
E.createMembersInRemoteConversation QualifiedWithTag 'QRemote ConvId
remoteConvId [UserId]
connectedList
Set UserId -> Sem r (Set UserId)
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Set UserId
connected
kickMember ::
( Member BackendNotificationQueueAccess r,
Member (Error FederationError) r,
Member (Error InternalError) r,
Member ExternalAccess r,
Member FederatorAccess r,
Member NotificationSubsystem r,
Member ProposalStore r,
Member (Input UTCTime) r,
Member (Input Env) r,
Member MemberStore r,
Member SubConversationStore r,
Member TinyLog r,
Member Random r
) =>
Qualified UserId ->
Local Conversation ->
BotsAndMembers ->
Qualified UserId ->
Sem r ()
kickMember :: forall (r :: EffectRow).
(Member BackendNotificationQueueAccess r,
Member (Error FederationError) r, Member (Error InternalError) r,
Member ExternalAccess r, Member FederatorAccess r,
Member NotificationSubsystem r, Member ProposalStore r,
Member (Input UTCTime) r, Member (Input Env) r,
Member MemberStore r, Member SubConversationStore r,
Member TinyLog r, Member Random r) =>
Qualified UserId
-> Local Conversation
-> BotsAndMembers
-> Qualified UserId
-> Sem r ()
kickMember Qualified UserId
qusr Local Conversation
lconv BotsAndMembers
targets Qualified UserId
victim = Sem r (Either NoChanges LocalConversationUpdate) -> Sem r ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Sem r (Either NoChanges LocalConversationUpdate) -> Sem r ())
-> (Sem (Error NoChanges : r) LocalConversationUpdate
-> Sem r (Either NoChanges LocalConversationUpdate))
-> Sem (Error NoChanges : r) LocalConversationUpdate
-> Sem r ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e (r :: EffectRow) a.
Sem (Error e : r) a -> Sem r (Either e a)
runError @NoChanges (Sem (Error NoChanges : r) LocalConversationUpdate -> Sem r ())
-> Sem (Error NoChanges : r) LocalConversationUpdate -> Sem r ()
forall a b. (a -> b) -> a -> b
$ do
(BotsAndMembers
extraTargets, ConversationAction 'ConversationLeaveTag
_) <-
Sing 'ConversationLeaveTag
-> Qualified UserId
-> Local Conversation
-> ConversationAction 'ConversationLeaveTag
-> Sem
(Error NoChanges : r)
(BotsAndMembers, ConversationAction 'ConversationLeaveTag)
forall (tag :: ConversationActionTag) (r :: EffectRow).
(HasConversationActionEffects tag r,
Member BackendNotificationQueueAccess r,
Member (Error FederationError) r) =>
Sing tag
-> Qualified UserId
-> Local Conversation
-> ConversationAction tag
-> Sem r (BotsAndMembers, ConversationAction tag)
performAction
Sing 'ConversationLeaveTag
SConversationActionTag 'ConversationLeaveTag
SConversationLeaveTag
Qualified UserId
victim
Local Conversation
lconv
()
Sing 'ConversationRemoveMembersTag
-> Qualified UserId
-> Bool
-> Maybe ConnId
-> Local Conversation
-> BotsAndMembers
-> ConversationAction 'ConversationRemoveMembersTag
-> Sem (Error NoChanges : r) LocalConversationUpdate
forall (tag :: ConversationActionTag) (r :: EffectRow).
(Member BackendNotificationQueueAccess r, Member ExternalAccess r,
Member (Error FederationError) r, Member NotificationSubsystem r,
Member (Input UTCTime) r) =>
Sing tag
-> Qualified UserId
-> Bool
-> Maybe ConnId
-> Local Conversation
-> BotsAndMembers
-> ConversationAction tag
-> Sem r LocalConversationUpdate
notifyConversationAction
(forall {k} (a :: k). SingI a => Sing a
forall (a :: ConversationActionTag). SingI a => Sing a
sing @'ConversationRemoveMembersTag)
Qualified UserId
qusr
Bool
True
Maybe ConnId
forall a. Maybe a
Nothing
Local Conversation
lconv
(BotsAndMembers
targets BotsAndMembers -> BotsAndMembers -> BotsAndMembers
forall a. Semigroup a => a -> a -> a
<> BotsAndMembers
extraTargets)
(NonEmpty (Qualified UserId)
-> EdMemberLeftReason -> ConversationRemoveMembers
ConversationRemoveMembers (Qualified UserId -> NonEmpty (Qualified UserId)
forall a. a -> NonEmpty a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Qualified UserId
victim) EdMemberLeftReason
EdReasonRemoved)
notifyTypingIndicator ::
( Member (Input UTCTime) r,
Member (Input (Local ())) r,
Member NotificationSubsystem r,
Member FederatorAccess r
) =>
Conversation ->
Qualified UserId ->
Maybe ConnId ->
TypingStatus ->
Sem r TypingDataUpdated
notifyTypingIndicator :: forall (r :: EffectRow).
(Member (Input UTCTime) r, Member (Input (Local ())) r,
Member NotificationSubsystem r, Member FederatorAccess r) =>
Conversation
-> Qualified UserId
-> Maybe ConnId
-> TypingStatus
-> Sem r TypingDataUpdated
notifyTypingIndicator Conversation
conv Qualified UserId
qusr Maybe ConnId
mcon TypingStatus
ts = do
let origDomain :: Domain
origDomain = Qualified UserId -> Domain
forall a. Qualified a -> Domain
qDomain Qualified UserId
qusr
UTCTime
now <- Sem r UTCTime
forall i (r :: EffectRow). Member (Input i) r => Sem r i
input
QualifiedWithTag 'QLocal ConvId
lconv <- ConvId -> Sem r (QualifiedWithTag 'QLocal ConvId)
forall (r :: EffectRow) a.
Member (Input (Local ())) r =>
a -> Sem r (Local a)
qualifyLocal (Conversation -> ConvId
Data.convId Conversation
conv)
Qualified UserId
-> UTCTime
-> [UserId]
-> Maybe ConnId
-> Qualified ConvId
-> TypingStatus
-> Sem r ()
forall (r :: EffectRow).
Member NotificationSubsystem r =>
Qualified UserId
-> UTCTime
-> [UserId]
-> Maybe ConnId
-> Qualified ConvId
-> TypingStatus
-> Sem r ()
pushTypingIndicatorEvents Qualified UserId
qusr UTCTime
now ((LocalMember -> UserId) -> [LocalMember] -> [UserId]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap LocalMember -> UserId
lmId (Conversation -> [LocalMember]
Data.convLocalMembers Conversation
conv)) Maybe ConnId
mcon (QualifiedWithTag 'QLocal ConvId -> Qualified ConvId
forall (t :: QTag) a. QualifiedWithTag t a -> Qualified a
tUntagged QualifiedWithTag 'QLocal ConvId
lconv) TypingStatus
ts
let ([RemoteMember]
remoteMemsOrig, [RemoteMember]
remoteMemsOther) = (RemoteMember -> Bool)
-> [RemoteMember] -> ([RemoteMember], [RemoteMember])
forall a. (a -> Bool) -> [a] -> ([a], [a])
List.partition ((Domain
origDomain ==) (Domain -> Bool)
-> (RemoteMember -> Domain) -> RemoteMember -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Remote UserId -> Domain
forall (t :: QTag) a. QualifiedWithTag t a -> Domain
tDomain (Remote UserId -> Domain)
-> (RemoteMember -> Remote UserId) -> RemoteMember -> Domain
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RemoteMember -> Remote UserId
rmId) (Conversation -> [RemoteMember]
Data.convRemoteMembers Conversation
conv)
tdu :: [UserId] -> TypingDataUpdated
tdu [UserId]
users =
TypingDataUpdated
{ $sel:time:TypingDataUpdated :: UTCTime
time = UTCTime
now,
$sel:origUserId:TypingDataUpdated :: Qualified UserId
origUserId = Qualified UserId
qusr,
$sel:convId:TypingDataUpdated :: ConvId
convId = Conversation -> ConvId
Data.convId Conversation
conv,
$sel:usersInConv:TypingDataUpdated :: [UserId]
usersInConv = [UserId]
users,
$sel:typingStatus:TypingDataUpdated :: TypingStatus
typingStatus = TypingStatus
ts
}
Sem
r
[Either (Remote [UserId], FederationError) (Remote EmptyResponse)]
-> Sem r ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Sem
r
[Either (Remote [UserId], FederationError) (Remote EmptyResponse)]
-> Sem r ())
-> Sem
r
[Either (Remote [UserId], FederationError) (Remote EmptyResponse)]
-> Sem r ()
forall a b. (a -> b) -> a -> b
$ [Remote UserId]
-> (Remote [UserId] -> FederatorClient 'Galley EmptyResponse)
-> Sem
r
[Either (Remote [UserId], FederationError) (Remote EmptyResponse)]
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)]
E.runFederatedConcurrentlyEither ((RemoteMember -> Remote UserId)
-> [RemoteMember] -> [Remote UserId]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap RemoteMember -> Remote UserId
rmId [RemoteMember]
remoteMemsOther) ((Remote [UserId] -> FederatorClient 'Galley EmptyResponse)
-> Sem
r
[Either (Remote [UserId], FederationError) (Remote EmptyResponse)])
-> (Remote [UserId] -> FederatorClient 'Galley EmptyResponse)
-> Sem
r
[Either (Remote [UserId], FederationError) (Remote EmptyResponse)]
forall a b. (a -> b) -> a -> b
$ \Remote [UserId]
rmems -> do
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 @"on-typing-indicator-updated" ([UserId] -> TypingDataUpdated
tdu (Remote [UserId] -> [UserId]
forall (t :: QTag) a. QualifiedWithTag t a -> a
tUnqualified Remote [UserId]
rmems))
TypingDataUpdated -> Sem r TypingDataUpdated
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([UserId] -> TypingDataUpdated
tdu ((RemoteMember -> UserId) -> [RemoteMember] -> [UserId]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Remote UserId -> UserId
forall (t :: QTag) a. QualifiedWithTag t a -> a
tUnqualified (Remote UserId -> UserId)
-> (RemoteMember -> Remote UserId) -> RemoteMember -> UserId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RemoteMember -> Remote UserId
rmId) [RemoteMember]
remoteMemsOrig))
pushTypingIndicatorEvents ::
(Member NotificationSubsystem r) =>
Qualified UserId ->
UTCTime ->
[UserId] ->
Maybe ConnId ->
Qualified ConvId ->
TypingStatus ->
Sem r ()
pushTypingIndicatorEvents :: forall (r :: EffectRow).
Member NotificationSubsystem r =>
Qualified UserId
-> UTCTime
-> [UserId]
-> Maybe ConnId
-> Qualified ConvId
-> TypingStatus
-> Sem r ()
pushTypingIndicatorEvents Qualified UserId
qusr UTCTime
tEvent [UserId]
users Maybe ConnId
mcon Qualified ConvId
qcnv TypingStatus
ts = do
let e :: Event
e = Qualified ConvId
-> Maybe SubConvId
-> Qualified UserId
-> UTCTime
-> EventData
-> Event
Event Qualified ConvId
qcnv Maybe SubConvId
forall a. Maybe a
Nothing Qualified UserId
qusr UTCTime
tEvent (TypingStatus -> EventData
EdTyping TypingStatus
ts)
Maybe Push -> (Push -> Sem r ()) -> Sem r ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ (UserId -> Object -> [Recipient] -> Maybe Push
newPushLocal (Qualified UserId -> UserId
forall a. Qualified a -> a
qUnqualified Qualified UserId
qusr) (Event -> Object
forall a. ToJSONObject a => a -> Object
toJSONObject Event
e) (UserId -> Recipient
userRecipient (UserId -> Recipient) -> [UserId] -> [Recipient]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [UserId]
users)) ((Push -> Sem r ()) -> Sem r ()) -> (Push -> Sem r ()) -> Sem r ()
forall a b. (a -> b) -> a -> b
$ \Push
p ->
[Push] -> Sem r ()
forall (r :: EffectRow).
Member NotificationSubsystem r =>
[Push] -> Sem r ()
pushNotifications
[ Push
p
Push -> (Push -> Push) -> Push
forall a b. a -> (a -> b) -> b
& (Maybe ConnId -> Identity (Maybe ConnId)) -> Push -> Identity Push
Lens' Push (Maybe ConnId)
pushConn ((Maybe ConnId -> Identity (Maybe ConnId))
-> Push -> Identity Push)
-> Maybe ConnId -> Push -> Push
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Maybe ConnId
mcon
Push -> (Push -> Push) -> Push
forall a b. a -> (a -> b) -> b
& (Route -> Identity Route) -> Push -> Identity Push
Lens' Push Route
pushRoute ((Route -> Identity Route) -> Push -> Identity Push)
-> Route -> Push -> Push
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Route
PushV2.RouteDirect
Push -> (Push -> Push) -> Push
forall a b. a -> (a -> b) -> b
& (Bool -> Identity Bool) -> Push -> Identity Push
Lens' Push Bool
pushTransient ((Bool -> Identity Bool) -> Push -> Identity Push)
-> Bool -> Push -> Push
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Bool
True
]