{-# LANGUAGE RecordWildCards #-}

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

module Galley.API.Util where

import Control.Lens (set, to, view, (.~), (^.))
import Control.Monad.Extra (allM, anyM)
import Data.Bifunctor
import Data.Code qualified as Code
import Data.Domain (Domain)
import Data.Id as Id
import Data.Json.Util
import Data.LegalHold (UserLegalHoldStatus (..), defUserLegalHoldStatus)
import Data.List.Extra (chunksOf, nubOrd)
import Data.List.NonEmpty (NonEmpty)
import Data.List.NonEmpty qualified as NE
import Data.Map qualified as Map
import Data.Misc (PlainTextPassword6, PlainTextPassword8)
import Data.Qualified
import Data.Set qualified as Set
import Data.Singletons
import Data.Text qualified as T
import Data.Time
import Galley.API.Error
import Galley.API.Mapping
import Galley.Data.Conversation qualified as Data
import Galley.Data.Services (BotMember, newBotMember)
import Galley.Data.Types qualified as DataTypes
import Galley.Effects
import Galley.Effects.BackendNotificationQueueAccess
import Galley.Effects.BrigAccess
import Galley.Effects.ClientStore
import Galley.Effects.CodeStore
import Galley.Effects.ConversationStore
import Galley.Effects.ExternalAccess
import Galley.Effects.FederatorAccess
import Galley.Effects.LegalHoldStore
import Galley.Effects.MemberStore
import Galley.Effects.TeamStore
import Galley.Options
import Galley.Types.Clients (Clients, fromUserClients)
import Galley.Types.Conversations.Members
import Galley.Types.Conversations.Roles
import Galley.Types.Teams
import Galley.Types.UserList
import Imports hiding (forkIO)
import Network.AMQP qualified as Q
import Polysemy
import Polysemy.Error
import Polysemy.Input
import Polysemy.TinyLog qualified as P
import Wire.API.Connection
import Wire.API.Conversation hiding (Member, cnvAccess, cnvAccessRoles, cnvName, cnvType)
import Wire.API.Conversation qualified as Public
import Wire.API.Conversation.Action
import Wire.API.Conversation.Protocol
import Wire.API.Conversation.Role
import Wire.API.Error
import Wire.API.Error.Galley
import Wire.API.Event.Conversation
import Wire.API.Federation.API
import Wire.API.Federation.API.Galley
import Wire.API.Federation.Error
import Wire.API.Password
import Wire.API.Push.V2 qualified as PushV2
import Wire.API.Routes.Public.Galley.Conversation
import Wire.API.Routes.Public.Util
import Wire.API.Team.Feature
import Wire.API.Team.Member
import Wire.API.Team.Member qualified as Mem
import Wire.API.Team.Role
import Wire.API.User hiding (userId)
import Wire.API.User.Auth.ReAuth
import Wire.NotificationSubsystem

ensureAccessRole ::
  ( Member BrigAccess r,
    Member (ErrorS 'NotATeamMember) r,
    Member (ErrorS 'ConvAccessDenied) r
  ) =>
  Set Public.AccessRole ->
  [(UserId, Maybe TeamMember)] ->
  Sem r ()
ensureAccessRole :: forall (r :: EffectRow).
(Member BrigAccess r, Member (ErrorS 'NotATeamMember) r,
 Member (ErrorS 'ConvAccessDenied) r) =>
Set AccessRole -> [(UserId, Maybe TeamMember)] -> Sem r ()
ensureAccessRole Set AccessRole
roles [(UserId, Maybe TeamMember)]
users = do
  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
roles) (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 @'ConvAccessDenied
  Bool -> Sem r () -> Sem r ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (AccessRole
NonTeamMemberAccessRole AccessRole -> Set AccessRole -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set AccessRole
roles) (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 ()
when (((UserId, Maybe TeamMember) -> Bool)
-> [(UserId, Maybe TeamMember)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Maybe TeamMember -> Bool
forall a. Maybe a -> Bool
isNothing (Maybe TeamMember -> Bool)
-> ((UserId, Maybe TeamMember) -> Maybe TeamMember)
-> (UserId, Maybe TeamMember)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UserId, Maybe TeamMember) -> Maybe TeamMember
forall a b. (a, b) -> b
snd) [(UserId, Maybe TeamMember)]
users) (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 @'NotATeamMember
  Bool -> Sem r () -> Sem r ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([AccessRole] -> Set AccessRole
forall a. Ord a => [a] -> Set a
Set.fromList [AccessRole
GuestAccessRole, AccessRole
ServiceAccessRole] Set AccessRole -> Set AccessRole -> Bool
forall a. Ord a => Set a -> Set a -> Bool
`Set.isSubsetOf` Set AccessRole
roles) (Sem r () -> Sem r ()) -> Sem r () -> Sem r ()
forall a b. (a -> b) -> a -> b
$ do
    [User]
activated <- [UserId] -> Sem r [User]
forall (r :: EffectRow).
Member BrigAccess r =>
[UserId] -> Sem r [User]
lookupActivatedUsers ((UserId, Maybe TeamMember) -> UserId
forall a b. (a, b) -> a
fst ((UserId, Maybe TeamMember) -> UserId)
-> [(UserId, Maybe TeamMember)] -> [UserId]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(UserId, Maybe TeamMember)]
users)
    let guestsExist :: Bool
guestsExist = [User] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [User]
activated Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= [(UserId, Maybe TeamMember)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(UserId, Maybe TeamMember)]
users
    Bool -> Sem r () -> Sem r ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Bool -> Bool
not Bool
guestsExist Bool -> Bool -> Bool
|| AccessRole
GuestAccessRole AccessRole -> Set AccessRole -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set AccessRole
roles) (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 @'ConvAccessDenied
    let botsExist :: Bool
botsExist = (User -> Bool) -> [User] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Maybe ServiceRef -> Bool
forall a. Maybe a -> Bool
isJust (Maybe ServiceRef -> Bool)
-> (User -> Maybe ServiceRef) -> User -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. User -> Maybe ServiceRef
userService) [User]
activated
    Bool -> Sem r () -> Sem r ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Bool -> Bool
not Bool
botsExist Bool -> Bool -> Bool
|| AccessRole
ServiceAccessRole AccessRole -> Set AccessRole -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set AccessRole
roles) (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 @'ConvAccessDenied

-- | Check that the given user is either part of the same team as the other
-- users OR that there is a connection.
ensureConnectedOrSameTeam ::
  ( Member BrigAccess r,
    Member (ErrorS 'NotConnected) r,
    Member TeamStore r
  ) =>
  Local UserId ->
  [Qualified UserId] ->
  Sem r ()
ensureConnectedOrSameTeam :: forall (r :: EffectRow).
(Member BrigAccess r, Member (ErrorS 'NotConnected) r,
 Member TeamStore r) =>
Local UserId -> [Qualified UserId] -> Sem r ()
ensureConnectedOrSameTeam Local UserId
lusr [Qualified UserId]
others = do
  let ([UserId]
locals, [Remote UserId]
remotes) = Local UserId -> [Qualified UserId] -> ([UserId], [Remote UserId])
forall (f :: * -> *) x a.
Foldable f =>
Local x -> f (Qualified a) -> ([a], [Remote a])
partitionQualified Local UserId
lusr [Qualified UserId]
others
  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]
locals
  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

-- | Check that the given user is either part of the same team(s) as the other
-- users OR that there is a connection.
--
-- Team members are always considered connected, so we only check 'ensureConnected'
-- for non-team-members of the _given_ user
ensureConnectedToLocalsOrSameTeam ::
  ( Member BrigAccess r,
    Member (ErrorS 'NotConnected) r,
    Member TeamStore r
  ) =>
  Local UserId ->
  [UserId] ->
  Sem r ()
ensureConnectedToLocalsOrSameTeam :: forall (r :: EffectRow).
(Member BrigAccess r, Member (ErrorS 'NotConnected) r,
 Member TeamStore r) =>
Local UserId -> [UserId] -> Sem r ()
ensureConnectedToLocalsOrSameTeam Local UserId
_ [] = () -> Sem r ()
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
ensureConnectedToLocalsOrSameTeam (Local UserId -> UserId
forall (t :: QTag) a. QualifiedWithTag t a -> a
tUnqualified -> UserId
u) [UserId]
uids = do
  [TeamId]
uTeams <- UserId -> Sem r [TeamId]
forall (r :: EffectRow).
Member TeamStore r =>
UserId -> Sem r [TeamId]
getUserTeams UserId
u
  -- We collect all the relevant uids from same teams as the origin user
  [[UserId]]
sameTeamUids <- [TeamId] -> (TeamId -> Sem r [UserId]) -> Sem r [[UserId]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [TeamId]
uTeams ((TeamId -> Sem r [UserId]) -> Sem r [[UserId]])
-> (TeamId -> Sem r [UserId]) -> Sem r [[UserId]]
forall a b. (a -> b) -> a -> b
$ \TeamId
team ->
    (TeamMember -> UserId) -> [TeamMember] -> [UserId]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Getting UserId TeamMember UserId -> TeamMember -> UserId
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting UserId TeamMember UserId
Lens' TeamMember UserId
Mem.userId) ([TeamMember] -> [UserId]) -> Sem r [TeamMember] -> Sem r [UserId]
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]
selectTeamMembers TeamId
team [UserId]
uids
  -- Do not check connections for users that are on the same team
  UserId -> [UserId] -> Sem r ()
forall (r :: EffectRow).
(Member (ErrorS 'NotConnected) r, Member BrigAccess r) =>
UserId -> [UserId] -> Sem r ()
ensureConnectedToLocals UserId
u ([UserId]
uids [UserId] -> [UserId] -> [UserId]
forall a. Eq a => [a] -> [a] -> [a]
\\ [[UserId]] -> [UserId]
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join [[UserId]]
sameTeamUids)

-- | Check that the user is connected to everybody else.
--
-- The connection has to be bidirectional (e.g. if A connects to B and later
-- B blocks A, the status of A-to-B is still 'Accepted' but it doesn't mean
-- that they are connected).
ensureConnected ::
  ( Member BrigAccess r,
    Member (ErrorS 'NotConnected) r
  ) =>
  Local UserId ->
  UserList UserId ->
  Sem r ()
ensureConnected :: forall (r :: EffectRow).
(Member BrigAccess r, Member (ErrorS 'NotConnected) r) =>
Local UserId -> UserList UserId -> Sem r ()
ensureConnected Local UserId
self UserList UserId
others = do
  UserId -> [UserId] -> Sem r ()
forall (r :: EffectRow).
(Member (ErrorS 'NotConnected) r, Member BrigAccess r) =>
UserId -> [UserId] -> Sem r ()
ensureConnectedToLocals (Local UserId -> UserId
forall (t :: QTag) a. QualifiedWithTag t a -> a
tUnqualified Local UserId
self) (UserList UserId -> [UserId]
forall a. UserList a -> [a]
ulLocals UserList UserId
others)
  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
self (UserList UserId -> [Remote UserId]
forall a. UserList a -> [Remote a]
ulRemotes UserList UserId
others)

ensureConnectedToLocals ::
  ( Member (ErrorS 'NotConnected) r,
    Member BrigAccess r
  ) =>
  UserId ->
  [UserId] ->
  Sem r ()
ensureConnectedToLocals :: forall (r :: EffectRow).
(Member (ErrorS 'NotConnected) r, Member BrigAccess r) =>
UserId -> [UserId] -> Sem r ()
ensureConnectedToLocals UserId
_ [] = () -> Sem r ()
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
ensureConnectedToLocals UserId
u [UserId]
uids = do
  ([ConnectionStatus]
connsFrom, [ConnectionStatus]
connsTo) <-
    [UserId]
-> [UserId]
-> Maybe Relation
-> Maybe Relation
-> Sem r ([ConnectionStatus], [ConnectionStatus])
forall (r :: EffectRow).
Member BrigAccess r =>
[UserId]
-> [UserId]
-> Maybe Relation
-> Maybe Relation
-> Sem r ([ConnectionStatus], [ConnectionStatus])
getConnectionsUnqualifiedBidi [UserId
u] [UserId]
uids (Relation -> Maybe Relation
forall a. a -> Maybe a
Just Relation
Accepted) (Relation -> Maybe Relation
forall a. a -> Maybe a
Just Relation
Accepted)
  Bool -> Sem r () -> Sem r ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([ConnectionStatus] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ConnectionStatus]
connsFrom Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== [UserId] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [UserId]
uids Bool -> Bool -> Bool
&& [ConnectionStatus] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ConnectionStatus]
connsTo Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== [UserId] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [UserId]
uids) (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 @'NotConnected

ensureConnectedToRemotes ::
  ( Member BrigAccess r,
    Member (ErrorS 'NotConnected) r
  ) =>
  Local UserId ->
  [Remote UserId] ->
  Sem r ()
ensureConnectedToRemotes :: forall (r :: EffectRow).
(Member BrigAccess r, Member (ErrorS 'NotConnected) r) =>
Local UserId -> [Remote UserId] -> Sem r ()
ensureConnectedToRemotes Local UserId
_ [] = () -> Sem r ()
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
ensureConnectedToRemotes Local UserId
u [Remote UserId]
remotes = do
  [ConnectionStatusV2]
acceptedConns <- [UserId]
-> Maybe [Qualified UserId]
-> Maybe Relation
-> Sem r [ConnectionStatusV2]
forall (r :: EffectRow).
Member BrigAccess r =>
[UserId]
-> Maybe [Qualified UserId]
-> Maybe Relation
-> Sem r [ConnectionStatusV2]
getConnections [Local UserId -> UserId
forall (t :: QTag) a. QualifiedWithTag t a -> a
tUnqualified Local UserId
u] ([Qualified UserId] -> Maybe [Qualified UserId]
forall a. a -> Maybe a
Just ([Qualified UserId] -> Maybe [Qualified UserId])
-> [Qualified UserId] -> Maybe [Qualified UserId]
forall a b. (a -> b) -> a -> b
$ (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]
remotes) (Relation -> Maybe Relation
forall a. a -> Maybe a
Just Relation
Accepted)
  Bool -> Sem r () -> Sem r ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([ConnectionStatusV2] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ConnectionStatusV2]
acceptedConns Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= [Remote UserId] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Remote UserId]
remotes) (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 @'NotConnected

ensureReAuthorised ::
  ( Member BrigAccess r,
    Member (Error AuthenticationError) r
  ) =>
  UserId ->
  Maybe PlainTextPassword6 ->
  Maybe Code.Value ->
  Maybe VerificationAction ->
  Sem r ()
ensureReAuthorised :: forall (r :: EffectRow).
(Member BrigAccess r, Member (Error AuthenticationError) r) =>
UserId
-> Maybe PlainTextPassword6
-> Maybe Value
-> Maybe VerificationAction
-> Sem r ()
ensureReAuthorised UserId
u Maybe PlainTextPassword6
secret Maybe Value
mbAction Maybe VerificationAction
mbCode =
  UserId -> ReAuthUser -> Sem r (Either AuthenticationError ())
forall (r :: EffectRow).
Member BrigAccess r =>
UserId -> ReAuthUser -> Sem r (Either AuthenticationError ())
reauthUser UserId
u (Maybe PlainTextPassword6
-> Maybe Value -> Maybe VerificationAction -> ReAuthUser
ReAuthUser Maybe PlainTextPassword6
secret Maybe Value
mbAction Maybe VerificationAction
mbCode) Sem r (Either AuthenticationError ())
-> (Either AuthenticationError () -> 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
>>= Either AuthenticationError () -> Sem r ()
forall e (r :: EffectRow) a.
Member (Error e) r =>
Either e a -> Sem r a
fromEither

-- | Given a member in a conversation, check if the given action
-- is permitted. If the user does not have the given permission, or if it has a
-- custom role, throw 'ActionDenied'.
ensureActionAllowed ::
  forall (action :: Action) mem r.
  (IsConvMember mem, Member (ErrorS ('ActionDenied action)) r) =>
  Sing action ->
  mem ->
  Sem r ()
ensureActionAllowed :: forall (action :: Action) mem (r :: EffectRow).
(IsConvMember mem, Member (ErrorS ('ActionDenied action)) r) =>
Sing action -> mem -> Sem r ()
ensureActionAllowed Sing action
action mem
self = case Action -> RoleName -> Maybe Bool
isActionAllowed (Sing action -> Demote Action
forall k (a :: k). SingKind k => Sing a -> Demote k
forall (a :: Action). Sing a -> Demote Action
fromSing Sing action
action) (mem -> RoleName
forall mem. IsConvMember mem => mem -> RoleName
convMemberRole mem
self) of
  Just Bool
True -> () -> Sem r ()
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  Just Bool
False -> 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 @('ActionDenied action)
  -- Actually, this will "never" happen due to the
  -- fact that there can be no custom roles at the moment
  Maybe Bool
Nothing -> 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 @('ActionDenied action)

ensureGroupConversation :: (Member (ErrorS 'InvalidOperation) r) => Data.Conversation -> Sem r ()
ensureGroupConversation :: forall (r :: EffectRow).
Member (ErrorS 'InvalidOperation) r =>
Conversation -> Sem r ()
ensureGroupConversation Conversation
conv = do
  let ty :: ConvType
ty = Conversation -> ConvType
Data.convType Conversation
conv
  Bool -> Sem r () -> Sem r ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ConvType
ty ConvType -> ConvType -> Bool
forall a. Eq a => a -> a -> Bool
/= ConvType
RegularConv) (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

-- | Ensure that the set of actions provided are not "greater" than the user's
--   own. This is used to ensure users cannot "elevate" allowed actions
--   This function needs to be review when custom roles are introduced since only
--   custom roles can cause `roleNameToActions` to return a Nothing
ensureConvRoleNotElevated ::
  (IsConvMember mem, Member (ErrorS 'InvalidAction) r) =>
  mem ->
  RoleName ->
  Sem r ()
ensureConvRoleNotElevated :: forall mem (r :: EffectRow).
(IsConvMember mem, Member (ErrorS 'InvalidAction) r) =>
mem -> RoleName -> Sem r ()
ensureConvRoleNotElevated mem
origMember RoleName
targetRole = do
  case (RoleName -> Maybe (Set Action)
roleNameToActions RoleName
targetRole, RoleName -> Maybe (Set Action)
roleNameToActions (mem -> RoleName
forall mem. IsConvMember mem => mem -> RoleName
convMemberRole mem
origMember)) of
    (Just Set Action
targetActions, Just Set Action
memberActions) ->
      Bool -> Sem r () -> Sem r ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Set Action -> Set Action -> Bool
forall a. Ord a => Set a -> Set a -> Bool
Set.isSubsetOf Set Action
targetActions Set Action
memberActions) (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 @'InvalidAction
    (Maybe (Set Action)
_, Maybe (Set Action)
_) ->
      -- custom roles not supported
      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 @'InvalidAction

-- | Same as 'permissionCheck', but for a statically known permission.
permissionCheckS ::
  forall perm (p :: perm) r.
  ( SingKind perm,
    IsPerm (Demote perm),
    ( Member (ErrorS (PermError p)) r,
      Member (ErrorS 'NotATeamMember) r
    )
  ) =>
  Sing p ->
  Maybe TeamMember ->
  Sem r TeamMember
permissionCheckS :: forall perm (p :: perm) (r :: EffectRow).
(SingKind perm, IsPerm (Demote perm),
 (Member (ErrorS (PermError p)) r,
  Member (ErrorS 'NotATeamMember) r)) =>
Sing p -> Maybe TeamMember -> Sem r TeamMember
permissionCheckS Sing p
p =
  \case
    Just TeamMember
m -> do
      if TeamMember
m TeamMember -> Demote perm -> Bool
forall perm. IsPerm perm => TeamMember -> perm -> Bool
`hasPermission` Sing p -> Demote perm
forall (a :: perm). Sing a -> Demote perm
forall k (a :: k). SingKind k => Sing a -> Demote k
fromSing Sing p
p
        then TeamMember -> Sem r TeamMember
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TeamMember
m
        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 @(PermError p)
    -- FUTUREWORK: factor `noteS` out of this function.
    Maybe TeamMember
Nothing -> 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 @'NotATeamMember

-- | If a team member is not given throw 'notATeamMember'; if the given team
-- member does not have the given permission, throw 'operationDenied'.
-- Otherwise, return the team member.
permissionCheck ::
  ( IsPerm perm,
    ( Member (ErrorS OperationDenied) r,
      Member (ErrorS 'NotATeamMember) r
    )
  ) =>
  perm ->
  Maybe TeamMember ->
  Sem r TeamMember
-- FUTUREWORK: factor `noteS` out of this function.
permissionCheck :: forall perm (r :: EffectRow).
(IsPerm perm,
 (Member (ErrorS OperationDenied) r,
  Member (ErrorS 'NotATeamMember) r)) =>
perm -> Maybe TeamMember -> Sem r TeamMember
permissionCheck perm
p = \case
  Just TeamMember
m -> do
    if TeamMember
m TeamMember -> perm -> Bool
forall perm. IsPerm perm => TeamMember -> perm -> Bool
`hasPermission` perm
p
      then TeamMember -> Sem r TeamMember
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TeamMember
m
      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 @OperationDenied
  -- FUTUREWORK: factor `noteS` out of this function.
  Maybe TeamMember
Nothing -> 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 @'NotATeamMember

assertTeamExists ::
  ( Member (ErrorS 'TeamNotFound) r,
    Member TeamStore r
  ) =>
  TeamId ->
  Sem r ()
assertTeamExists :: forall (r :: EffectRow).
(Member (ErrorS 'TeamNotFound) r, Member TeamStore r) =>
TeamId -> Sem r ()
assertTeamExists TeamId
tid = do
  Bool
teamExists <- Maybe TeamData -> Bool
forall a. Maybe a -> Bool
isJust (Maybe TeamData -> Bool) -> Sem r (Maybe TeamData) -> Sem r Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TeamId -> Sem r (Maybe TeamData)
forall (r :: EffectRow).
Member TeamStore r =>
TeamId -> Sem r (Maybe TeamData)
getTeam TeamId
tid
  if Bool
teamExists
    then () -> Sem r ()
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    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 @'TeamNotFound

assertOnTeam ::
  ( Member (ErrorS 'NotATeamMember) r,
    Member TeamStore r
  ) =>
  UserId ->
  TeamId ->
  Sem r ()
assertOnTeam :: forall (r :: EffectRow).
(Member (ErrorS 'NotATeamMember) r, Member TeamStore r) =>
UserId -> TeamId -> Sem r ()
assertOnTeam UserId
uid TeamId
tid =
  TeamId -> UserId -> Sem r (Maybe TeamMember)
forall (r :: EffectRow).
Member TeamStore r =>
TeamId -> UserId -> Sem r (Maybe TeamMember)
getTeamMember TeamId
tid UserId
uid Sem r (Maybe TeamMember)
-> (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
>>= \case
    Maybe TeamMember
Nothing -> 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 @'NotATeamMember
    Just TeamMember
_ -> () -> Sem r ()
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

-- | Try to accept a 1-1 conversation, promoting connect conversations as appropriate.
acceptOne2One ::
  ( Member ConversationStore r,
    Member (ErrorS 'ConvNotFound) r,
    Member (Error InternalError) r,
    Member (ErrorS 'InvalidOperation) r,
    Member (Input UTCTime) r,
    Member MemberStore r,
    Member NotificationSubsystem r
  ) =>
  Local UserId ->
  Data.Conversation ->
  Maybe ConnId ->
  Sem r Data.Conversation
acceptOne2One :: forall (r :: EffectRow).
(Member ConversationStore r, Member (ErrorS 'ConvNotFound) r,
 Member (Error InternalError) r,
 Member (ErrorS 'InvalidOperation) r, Member (Input UTCTime) r,
 Member MemberStore r, Member NotificationSubsystem r) =>
Local UserId -> Conversation -> Maybe ConnId -> Sem r Conversation
acceptOne2One Local UserId
lusr Conversation
conv Maybe ConnId
conn = do
  let lcid :: QualifiedWithTag 'QLocal ConvId
lcid = Local UserId -> ConvId -> QualifiedWithTag 'QLocal ConvId
forall (t :: QTag) x a.
QualifiedWithTag t x -> a -> QualifiedWithTag t a
qualifyAs Local UserId
lusr ConvId
cid
  case Conversation -> ConvType
Data.convType Conversation
conv of
    ConvType
One2OneConv ->
      if Local UserId -> UserId
forall (t :: QTag) a. QualifiedWithTag t a -> a
tUnqualified Local UserId
lusr UserId -> [LocalMember] -> Bool
forall (m :: * -> *). Foldable m => UserId -> m LocalMember -> Bool
`isMember` [LocalMember]
mems
        then Conversation -> Sem r Conversation
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Conversation
conv
        else do
          [LocalMember]
mm <- QualifiedWithTag 'QLocal ConvId
-> Local UserId -> Sem r [LocalMember]
forall (r :: EffectRow).
Member MemberStore r =>
QualifiedWithTag 'QLocal ConvId
-> Local UserId -> Sem r [LocalMember]
createMember QualifiedWithTag 'QLocal ConvId
lcid Local UserId
lusr
          Conversation -> Sem r Conversation
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Conversation
conv {Data.convLocalMembers = mems <> toList mm}
    ConvType
ConnectConv -> case [LocalMember]
mems of
      [LocalMember
_, LocalMember
_] | Local UserId -> UserId
forall (t :: QTag) a. QualifiedWithTag t a -> a
tUnqualified Local UserId
lusr UserId -> [LocalMember] -> Bool
forall (m :: * -> *). Foldable m => UserId -> m LocalMember -> Bool
`isMember` [LocalMember]
mems -> Sem r Conversation
promote
      [LocalMember
_, LocalMember
_] -> forall {k} (e :: k) (r :: EffectRow) a.
Member (ErrorS e) r =>
Sem r a
forall (e :: GalleyError) (r :: EffectRow) a.
Member (ErrorS e) r =>
Sem r a
throwS @'ConvNotFound
      [LocalMember]
_ -> do
        Bool -> Sem r () -> Sem r ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([LocalMember] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [LocalMember]
mems Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
2) (Sem r () -> Sem r ()) -> Sem r () -> Sem r ()
forall a b. (a -> b) -> a -> b
$
          InternalError -> Sem r ()
forall e (r :: EffectRow) a. Member (Error e) r => e -> Sem r a
throw (InternalError -> Sem r ())
-> (ConvId -> InternalError) -> ConvId -> Sem r ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConvId -> InternalError
BadConvState (ConvId -> Sem r ()) -> ConvId -> Sem r ()
forall a b. (a -> b) -> a -> b
$
            ConvId
cid
        UTCTime
now <- Sem r UTCTime
forall i (r :: EffectRow). Member (Input i) r => Sem r i
input
        [LocalMember]
mm <- QualifiedWithTag 'QLocal ConvId
-> Local UserId -> Sem r [LocalMember]
forall (r :: EffectRow).
Member MemberStore r =>
QualifiedWithTag 'QLocal ConvId
-> Local UserId -> Sem r [LocalMember]
createMember QualifiedWithTag 'QLocal ConvId
lcid Local UserId
lusr
        let e :: Event
e = Local UserId
-> Qualified ConvId
-> UTCTime
-> [LocalMember]
-> [RemoteMember]
-> Event
memberJoinEvent Local UserId
lusr (QualifiedWithTag 'QLocal ConvId -> Qualified ConvId
forall (t :: QTag) a. QualifiedWithTag t a -> Qualified a
tUntagged QualifiedWithTag 'QLocal ConvId
lcid) UTCTime
now [LocalMember]
mm []
        Conversation
conv' <- if Maybe LocalMember -> Bool
forall a. Maybe a -> Bool
isJust ((LocalMember -> Bool) -> [LocalMember] -> Maybe LocalMember
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((Local UserId -> UserId
forall (t :: QTag) a. QualifiedWithTag t a -> a
tUnqualified Local UserId
lusr /=) (UserId -> Bool) -> (LocalMember -> UserId) -> LocalMember -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LocalMember -> UserId
lmId) [LocalMember]
mems) then Sem r Conversation
promote else Conversation -> Sem r Conversation
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Conversation
conv
        let mems' :: [LocalMember]
mems' = [LocalMember]
mems [LocalMember] -> [LocalMember] -> [LocalMember]
forall a. Semigroup a => a -> a -> a
<> [LocalMember] -> [LocalMember]
forall a. [a] -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList [LocalMember]
mm
        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 (Local UserId -> UserId
forall (t :: QTag) a. QualifiedWithTag t a -> a
tUnqualified Local UserId
lusr) (Event -> Object
forall a. ToJSONObject a => a -> Object
toJSONObject Event
e) (LocalMember -> Recipient
localMemberToRecipient (LocalMember -> Recipient) -> [LocalMember] -> [Recipient]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [LocalMember]
mems')) ((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
conn 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]
        Conversation -> Sem r Conversation
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Conversation
conv' {Data.convLocalMembers = mems'}
    ConvType
_ -> 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
  where
    cid :: ConvId
cid = Conversation -> ConvId
Data.convId Conversation
conv
    mems :: [LocalMember]
mems = Conversation -> [LocalMember]
Data.convLocalMembers Conversation
conv
    promote :: Sem r Conversation
promote = do
      ConvId -> Sem r ()
forall (r :: EffectRow).
Member ConversationStore r =>
ConvId -> Sem r ()
acceptConnectConversation ConvId
cid
      Conversation -> Sem r Conversation
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Conversation -> Sem r Conversation)
-> Conversation -> Sem r Conversation
forall a b. (a -> b) -> a -> b
$ ConvType -> Conversation -> Conversation
Data.convSetType ConvType
One2OneConv Conversation
conv

localMemberToRecipient :: LocalMember -> Recipient
localMemberToRecipient :: LocalMember -> Recipient
localMemberToRecipient = UserId -> Recipient
userRecipient (UserId -> Recipient)
-> (LocalMember -> UserId) -> LocalMember -> Recipient
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LocalMember -> UserId
lmId

userRecipient :: UserId -> Recipient
userRecipient :: UserId -> Recipient
userRecipient UserId
u = UserId -> RecipientClients -> Recipient
Recipient UserId
u RecipientClients
PushV2.RecipientClientsAll

memberJoinEvent ::
  Local UserId ->
  Qualified ConvId ->
  UTCTime ->
  [LocalMember] ->
  [RemoteMember] ->
  Event
memberJoinEvent :: Local UserId
-> Qualified ConvId
-> UTCTime
-> [LocalMember]
-> [RemoteMember]
-> Event
memberJoinEvent Local UserId
lorig Qualified ConvId
qconv UTCTime
t [LocalMember]
lmems [RemoteMember]
rmems =
  Qualified ConvId
-> Maybe SubConvId
-> Qualified UserId
-> UTCTime
-> EventData
-> Event
Event Qualified ConvId
qconv Maybe SubConvId
forall a. Maybe a
Nothing (Local UserId -> Qualified UserId
forall (t :: QTag) a. QualifiedWithTag t a -> Qualified a
tUntagged Local UserId
lorig) UTCTime
t (EventData -> Event) -> EventData -> Event
forall a b. (a -> b) -> a -> b
$
    SimpleMembers -> EventData
EdMembersJoin ([SimpleMember] -> SimpleMembers
SimpleMembers ((LocalMember -> SimpleMember) -> [LocalMember] -> [SimpleMember]
forall a b. (a -> b) -> [a] -> [b]
map LocalMember -> SimpleMember
localToSimple [LocalMember]
lmems [SimpleMember] -> [SimpleMember] -> [SimpleMember]
forall a. Semigroup a => a -> a -> a
<> (RemoteMember -> SimpleMember) -> [RemoteMember] -> [SimpleMember]
forall a b. (a -> b) -> [a] -> [b]
map RemoteMember -> SimpleMember
remoteToSimple [RemoteMember]
rmems))
  where
    localToSimple :: LocalMember -> SimpleMember
localToSimple LocalMember
u = Qualified UserId -> RoleName -> SimpleMember
SimpleMember (Local UserId -> Qualified UserId
forall (t :: QTag) a. QualifiedWithTag t a -> Qualified a
tUntagged (Local UserId -> UserId -> Local UserId
forall (t :: QTag) x a.
QualifiedWithTag t x -> a -> QualifiedWithTag t a
qualifyAs Local UserId
lorig (LocalMember -> UserId
lmId LocalMember
u))) (LocalMember -> RoleName
lmConvRoleName LocalMember
u)
    remoteToSimple :: RemoteMember -> SimpleMember
remoteToSimple RemoteMember
u = Qualified UserId -> RoleName -> SimpleMember
SimpleMember (Remote UserId -> Qualified UserId
forall (t :: QTag) a. QualifiedWithTag t a -> Qualified a
tUntagged (RemoteMember -> Remote UserId
rmId RemoteMember
u)) (RemoteMember -> RoleName
rmConvRoleName RemoteMember
u)

convDeleteMembers ::
  (Member MemberStore r) =>
  UserList UserId ->
  Data.Conversation ->
  Sem r Data.Conversation
convDeleteMembers :: forall (r :: EffectRow).
Member MemberStore r =>
UserList UserId -> Conversation -> Sem r Conversation
convDeleteMembers UserList UserId
ul Conversation
conv = do
  ConvId -> UserList UserId -> Sem r ()
forall (r :: EffectRow).
Member MemberStore r =>
ConvId -> UserList UserId -> Sem r ()
deleteMembers (Conversation -> ConvId
Data.convId Conversation
conv) UserList UserId
ul
  let locals :: Set UserId
locals = [UserId] -> Set UserId
forall a. Ord a => [a] -> Set a
Set.fromList (UserList UserId -> [UserId]
forall a. UserList a -> [a]
ulLocals UserList UserId
ul)
      remotes :: Set (Remote UserId)
remotes = [Remote UserId] -> Set (Remote UserId)
forall a. Ord a => [a] -> Set a
Set.fromList (UserList UserId -> [Remote UserId]
forall a. UserList a -> [Remote a]
ulRemotes UserList UserId
ul)
  -- update in-memory view of the conversation
  Conversation -> Sem r Conversation
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Conversation -> Sem r Conversation)
-> Conversation -> Sem r Conversation
forall a b. (a -> b) -> a -> b
$
    Conversation
conv
      { Data.convLocalMembers =
          filter (\LocalMember
lm -> UserId -> Set UserId -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.notMember (LocalMember -> UserId
lmId LocalMember
lm) Set UserId
locals) (Data.convLocalMembers conv),
        Data.convRemoteMembers =
          filter (\RemoteMember
rm -> Remote UserId -> Set (Remote UserId) -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.notMember (RemoteMember -> Remote UserId
rmId RemoteMember
rm) Set (Remote UserId)
remotes) (Data.convRemoteMembers conv)
      }

isMember :: (Foldable m) => UserId -> m LocalMember -> Bool
isMember :: forall (m :: * -> *). Foldable m => UserId -> m LocalMember -> Bool
isMember UserId
u = Maybe LocalMember -> Bool
forall a. Maybe a -> Bool
isJust (Maybe LocalMember -> Bool)
-> (m LocalMember -> Maybe LocalMember) -> m LocalMember -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LocalMember -> Bool) -> m LocalMember -> Maybe LocalMember
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((UserId
u ==) (UserId -> Bool) -> (LocalMember -> UserId) -> LocalMember -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LocalMember -> UserId
lmId)

isRemoteMember :: (Foldable m) => Remote UserId -> m RemoteMember -> Bool
isRemoteMember :: forall (m :: * -> *).
Foldable m =>
Remote UserId -> m RemoteMember -> Bool
isRemoteMember Remote UserId
u = Maybe RemoteMember -> Bool
forall a. Maybe a -> Bool
isJust (Maybe RemoteMember -> Bool)
-> (m RemoteMember -> Maybe RemoteMember) -> m RemoteMember -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (RemoteMember -> Bool) -> m RemoteMember -> Maybe RemoteMember
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((Remote UserId
u ==) (Remote UserId -> Bool)
-> (RemoteMember -> Remote UserId) -> RemoteMember -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RemoteMember -> Remote UserId
rmId)

class (IsConvMember mem) => IsConvMemberId uid mem | uid -> mem where
  getConvMember :: Local x -> Data.Conversation -> uid -> Maybe mem

  isConvMember :: Local x -> Data.Conversation -> uid -> Bool
  isConvMember Local x
loc Conversation
conv = Maybe mem -> Bool
forall a. Maybe a -> Bool
isJust (Maybe mem -> Bool) -> (uid -> Maybe mem) -> uid -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Local x -> Conversation -> uid -> Maybe mem
forall x. Local x -> Conversation -> uid -> Maybe mem
forall uid mem x.
IsConvMemberId uid mem =>
Local x -> Conversation -> uid -> Maybe mem
getConvMember Local x
loc Conversation
conv

  notIsConvMember :: Local x -> Data.Conversation -> uid -> Bool
  notIsConvMember Local x
loc Conversation
conv = Bool -> Bool
not (Bool -> Bool) -> (uid -> Bool) -> uid -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Local x -> Conversation -> uid -> Bool
forall x. Local x -> Conversation -> uid -> Bool
forall uid mem x.
IsConvMemberId uid mem =>
Local x -> Conversation -> uid -> Bool
isConvMember Local x
loc Conversation
conv

isConvMemberL :: (IsConvMemberId uid mem) => Local Data.Conversation -> uid -> Bool
isConvMemberL :: forall uid mem.
IsConvMemberId uid mem =>
Local Conversation -> uid -> Bool
isConvMemberL Local Conversation
lconv = Local Conversation -> Conversation -> uid -> Bool
forall x. Local x -> Conversation -> uid -> Bool
forall uid mem x.
IsConvMemberId uid mem =>
Local x -> Conversation -> uid -> Bool
isConvMember Local Conversation
lconv (Local Conversation -> Conversation
forall (t :: QTag) a. QualifiedWithTag t a -> a
tUnqualified Local Conversation
lconv)

instance IsConvMemberId UserId LocalMember where
  getConvMember :: forall x. Local x -> Conversation -> UserId -> Maybe LocalMember
getConvMember Local x
_ Conversation
conv UserId
u = (LocalMember -> Bool) -> [LocalMember] -> Maybe LocalMember
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((UserId
u ==) (UserId -> Bool) -> (LocalMember -> UserId) -> LocalMember -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LocalMember -> UserId
lmId) (Conversation -> [LocalMember]
Data.convLocalMembers Conversation
conv)

instance IsConvMemberId (Local UserId) LocalMember where
  getConvMember :: forall x.
Local x -> Conversation -> Local UserId -> Maybe LocalMember
getConvMember Local x
loc Conversation
conv = Local x -> Conversation -> UserId -> Maybe LocalMember
forall x. Local x -> Conversation -> UserId -> Maybe LocalMember
forall uid mem x.
IsConvMemberId uid mem =>
Local x -> Conversation -> uid -> Maybe mem
getConvMember Local x
loc Conversation
conv (UserId -> Maybe LocalMember)
-> (Local UserId -> UserId) -> Local UserId -> Maybe LocalMember
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Local UserId -> UserId
forall (t :: QTag) a. QualifiedWithTag t a -> a
tUnqualified

instance IsConvMemberId (Remote UserId) RemoteMember where
  getConvMember :: forall x.
Local x -> Conversation -> Remote UserId -> Maybe RemoteMember
getConvMember Local x
_ Conversation
conv Remote UserId
u = (RemoteMember -> Bool) -> [RemoteMember] -> Maybe RemoteMember
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((Remote UserId
u ==) (Remote UserId -> Bool)
-> (RemoteMember -> Remote UserId) -> RemoteMember -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RemoteMember -> Remote UserId
rmId) (Conversation -> [RemoteMember]
Data.convRemoteMembers Conversation
conv)

instance IsConvMemberId (Qualified UserId) (Either LocalMember RemoteMember) where
  getConvMember :: forall x.
Local x
-> Conversation
-> Qualified UserId
-> Maybe (Either LocalMember RemoteMember)
getConvMember Local x
loc Conversation
conv =
    Local x
-> (Local UserId -> Maybe (Either LocalMember RemoteMember))
-> (Remote UserId -> Maybe (Either LocalMember RemoteMember))
-> Qualified UserId
-> Maybe (Either LocalMember RemoteMember)
forall x a b.
Local x -> (Local a -> b) -> (Remote a -> b) -> Qualified a -> b
foldQualified
      Local x
loc
      ((LocalMember -> Either LocalMember RemoteMember)
-> Maybe LocalMember -> Maybe (Either LocalMember RemoteMember)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap LocalMember -> Either LocalMember RemoteMember
forall a b. a -> Either a b
Left (Maybe LocalMember -> Maybe (Either LocalMember RemoteMember))
-> (Local UserId -> Maybe LocalMember)
-> Local UserId
-> Maybe (Either LocalMember RemoteMember)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Local x -> Conversation -> Local UserId -> Maybe LocalMember
forall x.
Local x -> Conversation -> Local UserId -> Maybe LocalMember
forall uid mem x.
IsConvMemberId uid mem =>
Local x -> Conversation -> uid -> Maybe mem
getConvMember Local x
loc Conversation
conv)
      ((RemoteMember -> Either LocalMember RemoteMember)
-> Maybe RemoteMember -> Maybe (Either LocalMember RemoteMember)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap RemoteMember -> Either LocalMember RemoteMember
forall a b. b -> Either a b
Right (Maybe RemoteMember -> Maybe (Either LocalMember RemoteMember))
-> (Remote UserId -> Maybe RemoteMember)
-> Remote UserId
-> Maybe (Either LocalMember RemoteMember)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Local x -> Conversation -> Remote UserId -> Maybe RemoteMember
forall x.
Local x -> Conversation -> Remote UserId -> Maybe RemoteMember
forall uid mem x.
IsConvMemberId uid mem =>
Local x -> Conversation -> uid -> Maybe mem
getConvMember Local x
loc Conversation
conv)

class IsConvMember mem where
  convMemberRole :: mem -> RoleName
  convMemberId :: Local x -> mem -> Qualified UserId

instance IsConvMember LocalMember where
  convMemberRole :: LocalMember -> RoleName
convMemberRole = LocalMember -> RoleName
lmConvRoleName
  convMemberId :: forall x. Local x -> LocalMember -> Qualified UserId
convMemberId Local x
loc LocalMember
mem = Local UserId -> Qualified UserId
forall (t :: QTag) a. QualifiedWithTag t a -> Qualified a
tUntagged (Local x -> UserId -> Local UserId
forall (t :: QTag) x a.
QualifiedWithTag t x -> a -> QualifiedWithTag t a
qualifyAs Local x
loc (LocalMember -> UserId
lmId LocalMember
mem))

instance IsConvMember RemoteMember where
  convMemberRole :: RemoteMember -> RoleName
convMemberRole = RemoteMember -> RoleName
rmConvRoleName
  convMemberId :: forall x. Local x -> RemoteMember -> Qualified UserId
convMemberId Local x
_ = Remote UserId -> Qualified UserId
forall (t :: QTag) a. QualifiedWithTag t a -> Qualified a
tUntagged (Remote UserId -> Qualified UserId)
-> (RemoteMember -> Remote UserId)
-> RemoteMember
-> Qualified UserId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RemoteMember -> Remote UserId
rmId

instance IsConvMember (Either LocalMember RemoteMember) where
  convMemberRole :: Either LocalMember RemoteMember -> RoleName
convMemberRole = (LocalMember -> RoleName)
-> (RemoteMember -> RoleName)
-> Either LocalMember RemoteMember
-> RoleName
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either LocalMember -> RoleName
forall mem. IsConvMember mem => mem -> RoleName
convMemberRole RemoteMember -> RoleName
forall mem. IsConvMember mem => mem -> RoleName
convMemberRole
  convMemberId :: forall x.
Local x -> Either LocalMember RemoteMember -> Qualified UserId
convMemberId Local x
loc = (LocalMember -> Qualified UserId)
-> (RemoteMember -> Qualified UserId)
-> Either LocalMember RemoteMember
-> Qualified UserId
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Local x -> LocalMember -> Qualified UserId
forall x. Local x -> LocalMember -> Qualified UserId
forall mem x.
IsConvMember mem =>
Local x -> mem -> Qualified UserId
convMemberId Local x
loc) (Local x -> RemoteMember -> Qualified UserId
forall x. Local x -> RemoteMember -> Qualified UserId
forall mem x.
IsConvMember mem =>
Local x -> mem -> Qualified UserId
convMemberId Local x
loc)

-- | Remove users that are already present in the conversation.
ulNewMembers :: Local x -> Data.Conversation -> UserList UserId -> UserList UserId
ulNewMembers :: forall x.
Local x -> Conversation -> UserList UserId -> UserList UserId
ulNewMembers Local x
loc Conversation
conv (UserList [UserId]
locals [Remote UserId]
remotes) =
  [UserId] -> [Remote UserId] -> UserList UserId
forall a. [a] -> [Remote a] -> UserList a
UserList
    ((UserId -> Bool) -> [UserId] -> [UserId]
forall a. (a -> Bool) -> [a] -> [a]
filter (Local x -> Conversation -> UserId -> Bool
forall x. Local x -> Conversation -> UserId -> Bool
forall uid mem x.
IsConvMemberId uid mem =>
Local x -> Conversation -> uid -> Bool
notIsConvMember Local x
loc Conversation
conv) [UserId]
locals)
    ((Remote UserId -> Bool) -> [Remote UserId] -> [Remote UserId]
forall a. (a -> Bool) -> [a] -> [a]
filter (Local x -> Conversation -> Remote UserId -> Bool
forall x. Local x -> Conversation -> Remote UserId -> Bool
forall uid mem x.
IsConvMemberId uid mem =>
Local x -> Conversation -> uid -> Bool
notIsConvMember Local x
loc Conversation
conv) [Remote UserId]
remotes)

-- | This is an ad-hoc class to update notification targets based on the type
-- of the user id. Local user IDs get added to the local targets, remote user IDs
-- to remote targets, and qualified user IDs get added to the appropriate list
-- according to whether they are local or remote, by making a runtime check.
class IsBotOrMember uid where
  bmAdd :: Local x -> uid -> BotsAndMembers -> BotsAndMembers

data BotsAndMembers = BotsAndMembers
  { BotsAndMembers -> Set UserId
bmLocals :: Set UserId,
    BotsAndMembers -> Set (Remote UserId)
bmRemotes :: Set (Remote UserId),
    BotsAndMembers -> Set BotMember
bmBots :: Set BotMember
  }
  deriving (Int -> BotsAndMembers -> ShowS
[BotsAndMembers] -> ShowS
BotsAndMembers -> String
(Int -> BotsAndMembers -> ShowS)
-> (BotsAndMembers -> String)
-> ([BotsAndMembers] -> ShowS)
-> Show BotsAndMembers
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> BotsAndMembers -> ShowS
showsPrec :: Int -> BotsAndMembers -> ShowS
$cshow :: BotsAndMembers -> String
show :: BotsAndMembers -> String
$cshowList :: [BotsAndMembers] -> ShowS
showList :: [BotsAndMembers] -> ShowS
Show)

bmQualifiedMembers :: Local x -> BotsAndMembers -> [Qualified UserId]
bmQualifiedMembers :: forall x. Local x -> BotsAndMembers -> [Qualified UserId]
bmQualifiedMembers Local x
loc BotsAndMembers
bm =
  (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 x -> UserId -> Local UserId
forall (t :: QTag) x a.
QualifiedWithTag t x -> a -> QualifiedWithTag t a
qualifyAs Local x
loc) (Set UserId -> [UserId]
forall a. Set a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (BotsAndMembers -> Set UserId
bmLocals BotsAndMembers
bm))
    [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 (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
bm))

instance Semigroup BotsAndMembers where
  BotsAndMembers Set UserId
locals1 Set (Remote UserId)
remotes1 Set BotMember
bots1
    <> :: BotsAndMembers -> BotsAndMembers -> BotsAndMembers
<> BotsAndMembers Set UserId
locals2 Set (Remote UserId)
remotes2 Set BotMember
bots2 =
      Set UserId
-> Set (Remote UserId) -> Set BotMember -> BotsAndMembers
BotsAndMembers
        (Set UserId
locals1 Set UserId -> Set UserId -> Set UserId
forall a. Semigroup a => a -> a -> a
<> Set UserId
locals2)
        (Set (Remote UserId)
remotes1 Set (Remote UserId) -> Set (Remote UserId) -> Set (Remote UserId)
forall a. Semigroup a => a -> a -> a
<> Set (Remote UserId)
remotes2)
        (Set BotMember
bots1 Set BotMember -> Set BotMember -> Set BotMember
forall a. Semigroup a => a -> a -> a
<> Set BotMember
bots2)

instance Monoid BotsAndMembers where
  mempty :: BotsAndMembers
mempty = Set UserId
-> Set (Remote UserId) -> Set BotMember -> BotsAndMembers
BotsAndMembers Set UserId
forall a. Monoid a => a
mempty Set (Remote UserId)
forall a. Monoid a => a
mempty Set BotMember
forall a. Monoid a => a
mempty

instance IsBotOrMember (Local UserId) where
  bmAdd :: forall x.
Local x -> Local UserId -> BotsAndMembers -> BotsAndMembers
bmAdd Local x
_ Local UserId
luid BotsAndMembers
bm =
    BotsAndMembers
bm {bmLocals = Set.insert (tUnqualified luid) (bmLocals bm)}

instance IsBotOrMember (Remote UserId) where
  bmAdd :: forall x.
Local x -> Remote UserId -> BotsAndMembers -> BotsAndMembers
bmAdd Local x
_ Remote UserId
ruid BotsAndMembers
bm = BotsAndMembers
bm {bmRemotes = Set.insert ruid (bmRemotes bm)}

instance IsBotOrMember (Qualified UserId) where
  bmAdd :: forall x.
Local x -> Qualified UserId -> BotsAndMembers -> BotsAndMembers
bmAdd Local x
loc = Local x
-> (Local UserId -> BotsAndMembers -> BotsAndMembers)
-> (Remote UserId -> BotsAndMembers -> BotsAndMembers)
-> Qualified UserId
-> BotsAndMembers
-> BotsAndMembers
forall x a b.
Local x -> (Local a -> b) -> (Remote a -> b) -> Qualified a -> b
foldQualified Local x
loc (Local x -> Local UserId -> BotsAndMembers -> BotsAndMembers
forall x.
Local x -> Local UserId -> BotsAndMembers -> BotsAndMembers
forall uid x.
IsBotOrMember uid =>
Local x -> uid -> BotsAndMembers -> BotsAndMembers
bmAdd Local x
loc) (Local x -> Remote UserId -> BotsAndMembers -> BotsAndMembers
forall x.
Local x -> Remote UserId -> BotsAndMembers -> BotsAndMembers
forall uid x.
IsBotOrMember uid =>
Local x -> uid -> BotsAndMembers -> BotsAndMembers
bmAdd Local x
loc)

bmDiff :: BotsAndMembers -> BotsAndMembers -> BotsAndMembers
bmDiff :: BotsAndMembers -> BotsAndMembers -> BotsAndMembers
bmDiff BotsAndMembers
bm1 BotsAndMembers
bm2 =
  BotsAndMembers
    { $sel:bmLocals:BotsAndMembers :: Set UserId
bmLocals = Set UserId -> Set UserId -> Set UserId
forall a. Ord a => Set a -> Set a -> Set a
Set.difference (BotsAndMembers -> Set UserId
bmLocals BotsAndMembers
bm1) (BotsAndMembers -> Set UserId
bmLocals BotsAndMembers
bm2),
      $sel:bmRemotes:BotsAndMembers :: Set (Remote UserId)
bmRemotes = Set (Remote UserId) -> Set (Remote UserId) -> Set (Remote UserId)
forall a. Ord a => Set a -> Set a -> Set a
Set.difference (BotsAndMembers -> Set (Remote UserId)
bmRemotes BotsAndMembers
bm1) (BotsAndMembers -> Set (Remote UserId)
bmRemotes BotsAndMembers
bm2),
      $sel:bmBots:BotsAndMembers :: Set BotMember
bmBots = Set BotMember -> Set BotMember -> Set BotMember
forall a. Ord a => Set a -> Set a -> Set a
Set.difference (BotsAndMembers -> Set BotMember
bmBots BotsAndMembers
bm1) (BotsAndMembers -> Set BotMember
bmBots BotsAndMembers
bm2)
    }

bmFromMembers :: [LocalMember] -> [RemoteMember] -> BotsAndMembers
bmFromMembers :: [LocalMember] -> [RemoteMember] -> BotsAndMembers
bmFromMembers [LocalMember]
lmems [RemoteMember]
rusers = case [LocalMember] -> ([BotMember], [LocalMember])
forall (f :: * -> *).
Foldable f =>
f LocalMember -> ([BotMember], [LocalMember])
localBotsAndUsers [LocalMember]
lmems of
  ([BotMember]
bots, [LocalMember]
lusers) ->
    BotsAndMembers
      { $sel:bmLocals:BotsAndMembers :: Set UserId
bmLocals = [UserId] -> Set UserId
forall a. Ord a => [a] -> Set a
Set.fromList ((LocalMember -> UserId) -> [LocalMember] -> [UserId]
forall a b. (a -> b) -> [a] -> [b]
map LocalMember -> UserId
lmId [LocalMember]
lusers),
        $sel:bmRemotes:BotsAndMembers :: Set (Remote UserId)
bmRemotes = [Remote UserId] -> Set (Remote UserId)
forall a. Ord a => [a] -> Set a
Set.fromList ((RemoteMember -> Remote UserId)
-> [RemoteMember] -> [Remote UserId]
forall a b. (a -> b) -> [a] -> [b]
map RemoteMember -> Remote UserId
rmId [RemoteMember]
rusers),
        $sel:bmBots:BotsAndMembers :: Set BotMember
bmBots = [BotMember] -> Set BotMember
forall a. Ord a => [a] -> Set a
Set.fromList [BotMember]
bots
      }

convBotsAndMembers :: Data.Conversation -> BotsAndMembers
convBotsAndMembers :: Conversation -> BotsAndMembers
convBotsAndMembers Conversation
conv = [LocalMember] -> [RemoteMember] -> BotsAndMembers
bmFromMembers (Conversation -> [LocalMember]
Data.convLocalMembers Conversation
conv) (Conversation -> [RemoteMember]
Data.convRemoteMembers Conversation
conv)

localBotsAndUsers :: (Foldable f) => f LocalMember -> ([BotMember], [LocalMember])
localBotsAndUsers :: forall (f :: * -> *).
Foldable f =>
f LocalMember -> ([BotMember], [LocalMember])
localBotsAndUsers = (LocalMember -> ([BotMember], [LocalMember]))
-> f LocalMember -> ([BotMember], [LocalMember])
forall m a. Monoid m => (a -> m) -> f a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap LocalMember -> ([BotMember], [LocalMember])
botOrUser
  where
    botOrUser :: LocalMember -> ([BotMember], [LocalMember])
botOrUser LocalMember
m = case LocalMember -> Maybe ServiceRef
lmService LocalMember
m of
      -- we drop invalid bots here, which shouldn't happen
      Just ServiceRef
_ -> (Maybe BotMember -> [BotMember]
forall a. Maybe a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (LocalMember -> Maybe BotMember
newBotMember LocalMember
m), [])
      Maybe ServiceRef
Nothing -> ([], [LocalMember
m])

nonTeamMembers :: [LocalMember] -> [TeamMember] -> [LocalMember]
nonTeamMembers :: [LocalMember] -> [TeamMember] -> [LocalMember]
nonTeamMembers [LocalMember]
cm [TeamMember]
tm = (LocalMember -> Bool) -> [LocalMember] -> [LocalMember]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (LocalMember -> Bool) -> LocalMember -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UserId -> Bool
isMemberOfTeam (UserId -> Bool) -> (LocalMember -> UserId) -> LocalMember -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LocalMember -> UserId
lmId) [LocalMember]
cm
  where
    -- FUTUREWORK: remote members: teams and their members are always on the same backend
    isMemberOfTeam :: UserId -> Bool
isMemberOfTeam = \case
      UserId
uid -> UserId -> [TeamMember] -> Bool
forall (m :: * -> *). Foldable m => UserId -> m TeamMember -> Bool
isTeamMember UserId
uid [TeamMember]
tm

membersToRecipients :: Maybe UserId -> [TeamMember] -> [Recipient]
membersToRecipients :: Maybe UserId -> [TeamMember] -> [Recipient]
membersToRecipients Maybe UserId
Nothing = (TeamMember -> Recipient) -> [TeamMember] -> [Recipient]
forall a b. (a -> b) -> [a] -> [b]
map (UserId -> Recipient
userRecipient (UserId -> Recipient)
-> (TeamMember -> UserId) -> TeamMember -> Recipient
forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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
Mem.userId)
membersToRecipients (Just UserId
u) = (UserId -> Recipient) -> [UserId] -> [Recipient]
forall a b. (a -> b) -> [a] -> [b]
map UserId -> Recipient
userRecipient ([UserId] -> [Recipient])
-> ([TeamMember] -> [UserId]) -> [TeamMember] -> [Recipient]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UserId -> Bool) -> [UserId] -> [UserId]
forall a. (a -> Bool) -> [a] -> [a]
filter (UserId -> UserId -> Bool
forall a. Eq a => a -> a -> Bool
/= UserId
u) ([UserId] -> [UserId])
-> ([TeamMember] -> [UserId]) -> [TeamMember] -> [UserId]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TeamMember -> UserId) -> [TeamMember] -> [UserId]
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
Mem.userId)

getSelfMemberFromLocals ::
  (Foldable t, Member (ErrorS 'ConvNotFound) r) =>
  UserId ->
  t LocalMember ->
  Sem r LocalMember
getSelfMemberFromLocals :: forall (t :: * -> *) (r :: EffectRow).
(Foldable t, Member (ErrorS 'ConvNotFound) r) =>
UserId -> t LocalMember -> Sem r LocalMember
getSelfMemberFromLocals = forall {k1} (e :: k1) mem (t :: * -> *) userId (r :: EffectRow).
(Foldable t, Eq userId, Member (ErrorS e) r) =>
(mem -> userId) -> userId -> t mem -> Sem r mem
forall (e :: GalleyError) mem (t :: * -> *) userId
       (r :: EffectRow).
(Foldable t, Eq userId, Member (ErrorS e) r) =>
(mem -> userId) -> userId -> t mem -> Sem r mem
getMember @'ConvNotFound LocalMember -> UserId
lmId

-- | Throw 'ConvMemberNotFound' if the given user is not part of a
-- conversation (either locally or remotely).
ensureOtherMember ::
  (Member (ErrorS 'ConvMemberNotFound) r) =>
  Local a ->
  Qualified UserId ->
  Data.Conversation ->
  Sem r (Either LocalMember RemoteMember)
ensureOtherMember :: forall (r :: EffectRow) a.
Member (ErrorS 'ConvMemberNotFound) r =>
Local a
-> Qualified UserId
-> Conversation
-> Sem r (Either LocalMember RemoteMember)
ensureOtherMember Local a
loc Qualified UserId
quid Conversation
conv =
  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 @'ConvMemberNotFound (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
$
    LocalMember -> Either LocalMember RemoteMember
forall a b. a -> Either a b
Left
      (LocalMember -> Either LocalMember RemoteMember)
-> Maybe LocalMember -> Maybe (Either LocalMember RemoteMember)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (LocalMember -> Bool) -> [LocalMember] -> Maybe LocalMember
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((Qualified UserId -> Qualified UserId -> Bool
forall a. Eq a => a -> a -> Bool
== Qualified UserId
quid) (Qualified UserId -> Bool)
-> (LocalMember -> Qualified UserId) -> LocalMember -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Local UserId -> Qualified UserId
forall (t :: QTag) a. QualifiedWithTag t a -> Qualified a
tUntagged (Local UserId -> Qualified UserId)
-> (LocalMember -> Local UserId) -> LocalMember -> Qualified UserId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Local a -> UserId -> Local UserId
forall (t :: QTag) x a.
QualifiedWithTag t x -> a -> QualifiedWithTag t a
qualifyAs Local a
loc (UserId -> Local UserId)
-> (LocalMember -> UserId) -> LocalMember -> Local UserId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LocalMember -> UserId
lmId) (Conversation -> [LocalMember]
Data.convLocalMembers Conversation
conv)
        Maybe (Either LocalMember RemoteMember)
-> Maybe (Either LocalMember RemoteMember)
-> Maybe (Either LocalMember RemoteMember)
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> RemoteMember -> Either LocalMember RemoteMember
forall a b. b -> Either a b
Right
      (RemoteMember -> Either LocalMember RemoteMember)
-> Maybe RemoteMember -> Maybe (Either LocalMember RemoteMember)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (RemoteMember -> Bool) -> [RemoteMember] -> Maybe RemoteMember
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((Qualified UserId -> Qualified UserId -> Bool
forall a. Eq a => a -> a -> Bool
== Qualified UserId
quid) (Qualified UserId -> Bool)
-> (RemoteMember -> Qualified UserId) -> RemoteMember -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Remote UserId -> Qualified UserId
forall (t :: QTag) a. QualifiedWithTag t a -> Qualified a
tUntagged (Remote UserId -> Qualified UserId)
-> (RemoteMember -> Remote UserId)
-> RemoteMember
-> Qualified UserId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RemoteMember -> Remote UserId
rmId) (Conversation -> [RemoteMember]
Data.convRemoteMembers Conversation
conv)

getMember ::
  forall e mem t userId r.
  (Foldable t, Eq userId, Member (ErrorS e) r) =>
  -- | A projection from a member type to its user ID
  (mem -> userId) ->
  -- | The member to be found by its user ID
  userId ->
  -- | A list of members to search
  t mem ->
  Sem r mem
getMember :: forall {k1} (e :: k1) mem (t :: * -> *) userId (r :: EffectRow).
(Foldable t, Eq userId, Member (ErrorS e) r) =>
(mem -> userId) -> userId -> t mem -> Sem r mem
getMember mem -> userId
p userId
u = forall (e :: k1) (r :: EffectRow) a.
Member (ErrorS e) r =>
Maybe a -> Sem r a
forall {k} (e :: k) (r :: EffectRow) a.
Member (ErrorS e) r =>
Maybe a -> Sem r a
noteS @e (Maybe mem -> Sem r mem)
-> (t mem -> Maybe mem) -> t mem -> Sem r mem
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (mem -> Bool) -> t mem -> Maybe mem
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((userId
u ==) (userId -> Bool) -> (mem -> userId) -> mem -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. mem -> userId
p)

getConversationAndCheckMembership ::
  ( Member ConversationStore r,
    Member (ErrorS 'ConvNotFound) r,
    Member (ErrorS 'ConvAccessDenied) r
  ) =>
  Qualified UserId ->
  Local ConvId ->
  Sem r Data.Conversation
getConversationAndCheckMembership :: forall (r :: EffectRow).
(Member ConversationStore r, Member (ErrorS 'ConvNotFound) r,
 Member (ErrorS 'ConvAccessDenied) r) =>
Qualified UserId
-> QualifiedWithTag 'QLocal ConvId -> Sem r Conversation
getConversationAndCheckMembership Qualified UserId
quid QualifiedWithTag 'QLocal ConvId
lcnv = do
  QualifiedWithTag 'QLocal ConvId
-> (Local UserId -> Sem r Conversation)
-> (Remote UserId -> Sem r Conversation)
-> Qualified UserId
-> Sem r Conversation
forall x a b.
Local x -> (Local a -> b) -> (Remote a -> b) -> Qualified a -> b
foldQualified
    QualifiedWithTag 'QLocal ConvId
lcnv
    ( \Local UserId
lusr -> do
        (Conversation
conv, LocalMember
_) <-
          forall {k1} (e :: k1) uid mem (r :: EffectRow).
(Member ConversationStore r, Member (ErrorS 'ConvNotFound) r,
 Member (ErrorS e) r, IsConvMemberId uid mem) =>
uid -> QualifiedWithTag 'QLocal ConvId -> Sem r (Conversation, mem)
forall (e :: GalleyError) uid mem (r :: EffectRow).
(Member ConversationStore r, Member (ErrorS 'ConvNotFound) r,
 Member (ErrorS e) r, IsConvMemberId uid mem) =>
uid -> QualifiedWithTag 'QLocal ConvId -> Sem r (Conversation, mem)
getConversationAndMemberWithError
            @'ConvAccessDenied
            (Local UserId -> UserId
forall (t :: QTag) a. QualifiedWithTag t a -> a
tUnqualified Local UserId
lusr)
            QualifiedWithTag 'QLocal ConvId
lcnv
        Conversation -> Sem r Conversation
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Conversation
conv
    )
    ( \Remote UserId
rusr -> do
        (Conversation
conv, RemoteMember
_) <-
          forall {k1} (e :: k1) uid mem (r :: EffectRow).
(Member ConversationStore r, Member (ErrorS 'ConvNotFound) r,
 Member (ErrorS e) r, IsConvMemberId uid mem) =>
uid -> QualifiedWithTag 'QLocal ConvId -> Sem r (Conversation, mem)
forall (e :: GalleyError) uid mem (r :: EffectRow).
(Member ConversationStore r, Member (ErrorS 'ConvNotFound) r,
 Member (ErrorS e) r, IsConvMemberId uid mem) =>
uid -> QualifiedWithTag 'QLocal ConvId -> Sem r (Conversation, mem)
getConversationAndMemberWithError
            @'ConvNotFound
            Remote UserId
rusr
            QualifiedWithTag 'QLocal ConvId
lcnv
        Conversation -> Sem r Conversation
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Conversation
conv
    )
    Qualified UserId
quid

getConversationWithError ::
  ( Member ConversationStore r,
    Member (ErrorS 'ConvNotFound) r
  ) =>
  Local ConvId ->
  Sem r Data.Conversation
getConversationWithError :: forall (r :: EffectRow).
(Member ConversationStore r, Member (ErrorS 'ConvNotFound) r) =>
QualifiedWithTag 'QLocal ConvId -> Sem r Conversation
getConversationWithError QualifiedWithTag 'QLocal ConvId
lcnv =
  ConvId -> Sem r (Maybe Conversation)
forall (r :: EffectRow).
Member ConversationStore r =>
ConvId -> Sem r (Maybe Conversation)
getConversation (QualifiedWithTag 'QLocal ConvId -> ConvId
forall (t :: QTag) a. QualifiedWithTag t a -> a
tUnqualified QualifiedWithTag 'QLocal ConvId
lcnv) Sem r (Maybe Conversation)
-> (Maybe Conversation -> Sem r Conversation) -> Sem r Conversation
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 @'ConvNotFound

getConversationAndMemberWithError ::
  forall e uid mem r.
  ( Member ConversationStore r,
    Member (ErrorS 'ConvNotFound) r,
    Member (ErrorS e) r,
    IsConvMemberId uid mem
  ) =>
  uid ->
  Local ConvId ->
  Sem r (Data.Conversation, mem)
getConversationAndMemberWithError :: forall {k1} (e :: k1) uid mem (r :: EffectRow).
(Member ConversationStore r, Member (ErrorS 'ConvNotFound) r,
 Member (ErrorS e) r, IsConvMemberId uid mem) =>
uid -> QualifiedWithTag 'QLocal ConvId -> Sem r (Conversation, mem)
getConversationAndMemberWithError uid
usr QualifiedWithTag 'QLocal ConvId
lcnv = do
  Conversation
c <- 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
  mem
member <- forall (e :: k1) (r :: EffectRow) a.
Member (ErrorS e) r =>
Maybe a -> Sem r a
forall {k} (e :: k) (r :: EffectRow) a.
Member (ErrorS e) r =>
Maybe a -> Sem r a
noteS @e (Maybe mem -> Sem r mem) -> Maybe mem -> Sem r mem
forall a b. (a -> b) -> a -> b
$ QualifiedWithTag 'QLocal ConvId -> Conversation -> uid -> Maybe mem
forall x. Local x -> Conversation -> uid -> Maybe mem
forall uid mem x.
IsConvMemberId uid mem =>
Local x -> Conversation -> uid -> Maybe mem
getConvMember QualifiedWithTag 'QLocal ConvId
lcnv Conversation
c uid
usr
  (Conversation, mem) -> Sem r (Conversation, mem)
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Conversation
c, mem
member)

-- | Deletion requires a permission check, but also a 'Role' comparison:
-- Owners can only be deleted by another owner (and not themselves).
--
-- FUTUREWORK: do not do this with 'Role', but introduce permissions "can delete owner", "can
-- delete admin", etc.
canDeleteMember :: TeamMember -> TeamMember -> Bool
canDeleteMember :: TeamMember -> TeamMember -> Bool
canDeleteMember TeamMember
deleter TeamMember
deletee
  | TeamMember -> Role
getRole TeamMember
deletee Role -> Role -> Bool
forall a. Eq a => a -> a -> Bool
== Role
RoleOwner =
      TeamMember -> Role
getRole TeamMember
deleter Role -> Role -> Bool
forall a. Eq a => a -> a -> Bool
== Role
RoleOwner -- owners can only be deleted by another owner
        Bool -> Bool -> Bool
&& (TeamMember
deleter TeamMember -> Getting UserId TeamMember UserId -> UserId
forall s a. s -> Getting a s a -> a
^. Getting UserId TeamMember UserId
Lens' TeamMember UserId
Mem.userId UserId -> UserId -> Bool
forall a. Eq a => a -> a -> Bool
/= TeamMember
deletee TeamMember -> Getting UserId TeamMember UserId -> UserId
forall s a. s -> Getting a s a -> a
^. Getting UserId TeamMember UserId
Lens' TeamMember UserId
Mem.userId) -- owner cannot delete itself
  | Bool
otherwise =
      Bool
True
  where
    -- (team members having no role is an internal error, but we don't want to deal with that
    -- here, so we pick a reasonable default.)
    getRole :: TeamMember -> Role
getRole TeamMember
mem = Role -> Maybe Role -> Role
forall a. a -> Maybe a -> a
fromMaybe Role
RoleMember (Maybe Role -> Role) -> Maybe Role -> Role
forall a b. (a -> b) -> a -> b
$ Permissions -> Maybe Role
permissionsRole (Permissions -> Maybe Role) -> Permissions -> Maybe Role
forall a b. (a -> b) -> a -> b
$ TeamMember
mem TeamMember
-> Getting Permissions TeamMember Permissions -> Permissions
forall s a. s -> Getting a s a -> a
^. Getting Permissions TeamMember Permissions
(PermissionType 'Required
 -> Const Permissions (PermissionType 'Required))
-> TeamMember -> Const Permissions TeamMember
forall (tag1 :: PermissionTag) (tag2 :: PermissionTag)
       (f :: * -> *).
Functor f =>
(PermissionType tag1 -> f (PermissionType tag2))
-> TeamMember' tag1 -> f (TeamMember' tag2)
permissions

-- | Send an event to local users and bots
pushConversationEvent ::
  ( Member ExternalAccess r,
    Member NotificationSubsystem r,
    Foldable f
  ) =>
  Maybe ConnId ->
  Event ->
  Local (f UserId) ->
  f BotMember ->
  Sem r ()
pushConversationEvent :: 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
conn Event
e Local (f UserId)
lusers f BotMember
bots = do
  Maybe Push -> (Push -> Sem r ()) -> Sem r ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ (Event -> Local [UserId] -> Maybe Push
newConversationEventPush Event
e ((f UserId -> [UserId]) -> Local (f UserId) -> Local [UserId]
forall a b.
(a -> b)
-> QualifiedWithTag 'QLocal a -> QualifiedWithTag 'QLocal b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap f UserId -> [UserId]
forall a. f a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Local (f UserId)
lusers)) ((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)
-> Maybe ConnId -> Push -> Push
forall s t a b. ASetter s t a b -> b -> s -> t
set (Maybe ConnId -> Identity (Maybe ConnId)) -> Push -> Identity Push
Lens' Push (Maybe ConnId)
pushConn Maybe ConnId
conn]
  [(BotMember, Event)] -> Sem r ()
forall (r :: EffectRow) (f :: * -> *).
(Member ExternalAccess r, Foldable f) =>
f (BotMember, Event) -> Sem r ()
deliverAsync ((BotMember -> (BotMember, Event))
-> [BotMember] -> [(BotMember, Event)]
forall a b. (a -> b) -> [a] -> [b]
map (,Event
e) (f BotMember -> [BotMember]
forall a. f a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList f BotMember
bots))

newConversationEventPush :: Event -> Local [UserId] -> Maybe Push
newConversationEventPush :: Event -> Local [UserId] -> Maybe Push
newConversationEventPush Event
e Local [UserId]
users =
  let musr :: Maybe UserId
musr = Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Local [UserId] -> Domain
forall (t :: QTag) a. QualifiedWithTag t a -> Domain
tDomain Local [UserId]
users Domain -> Domain -> Bool
forall a. Eq a => a -> a -> Bool
== Qualified UserId -> Domain
forall a. Qualified a -> Domain
qDomain (Event -> Qualified UserId
evtFrom Event
e)) Maybe () -> UserId -> Maybe UserId
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Qualified UserId -> UserId
forall a. Qualified a -> a
qUnqualified (Event -> Qualified UserId
evtFrom Event
e)
   in Maybe UserId -> Object -> [Recipient] -> Maybe Push
newPush Maybe UserId
musr (Event -> Object
forall a. ToJSONObject a => a -> Object
toJSONObject Event
e) ((UserId -> Recipient) -> [UserId] -> [Recipient]
forall a b. (a -> b) -> [a] -> [b]
map UserId -> Recipient
userRecipient (Local [UserId] -> [UserId]
forall (t :: QTag) a. QualifiedWithTag t a -> a
tUnqualified Local [UserId]
users))

verifyReusableCode ::
  ( Member CodeStore r,
    Member (ErrorS 'CodeNotFound) r,
    Member (ErrorS 'InvalidConversationPassword) r
  ) =>
  Bool ->
  Maybe PlainTextPassword8 ->
  ConversationCode ->
  Sem r DataTypes.Code
verifyReusableCode :: forall (r :: EffectRow).
(Member CodeStore r, Member (ErrorS 'CodeNotFound) r,
 Member (ErrorS 'InvalidConversationPassword) r) =>
Bool -> Maybe PlainTextPassword8 -> ConversationCode -> Sem r Code
verifyReusableCode Bool
checkPw Maybe PlainTextPassword8
mPtpw ConversationCode
convCode = do
  (Code
c, Maybe Password
mPw) <-
    Key -> Scope -> Sem r (Maybe (Code, Maybe Password))
forall (r :: EffectRow).
Member CodeStore r =>
Key -> Scope -> Sem r (Maybe (Code, Maybe Password))
getCode (ConversationCode -> Key
conversationKey ConversationCode
convCode) Scope
DataTypes.ReusableCode
      Sem r (Maybe (Code, Maybe Password))
-> (Maybe (Code, Maybe Password) -> Sem r (Code, Maybe Password))
-> Sem r (Code, Maybe Password)
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 @'CodeNotFound
  Bool -> Sem r () -> Sem r ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Code -> Value
DataTypes.codeValue Code
c Value -> Value -> Bool
forall a. Eq a => a -> a -> Bool
== ConversationCode -> Value
conversationCode ConversationCode
convCode) (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 @'CodeNotFound
  case (Bool
checkPw, Maybe PlainTextPassword8
mPtpw, Maybe Password
mPw) of
    (Bool
True, Just PlainTextPassword8
ptpw, Just Password
pw) ->
      Bool -> Sem r () -> Sem r ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (PlainTextPassword8 -> Password -> Bool
forall (t :: Nat). PlainTextPassword' t -> Password -> Bool
verifyPassword PlainTextPassword8
ptpw Password
pw) (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 @'InvalidConversationPassword
    (Bool
True, Maybe PlainTextPassword8
Nothing, Just Password
_) ->
      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 @'InvalidConversationPassword
    (Bool
_, Maybe PlainTextPassword8
_, Maybe Password
_) -> () -> Sem r ()
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  Code -> Sem r Code
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Code
c

ensureConversationAccess ::
  ( Member BrigAccess r,
    Member (ErrorS 'ConvAccessDenied) r,
    Member (ErrorS 'NotATeamMember) r,
    Member TeamStore r
  ) =>
  UserId ->
  Data.Conversation ->
  Access ->
  Sem r ()
ensureConversationAccess :: forall (r :: EffectRow).
(Member BrigAccess r, Member (ErrorS 'ConvAccessDenied) r,
 Member (ErrorS 'NotATeamMember) r, Member TeamStore r) =>
UserId -> Conversation -> Access -> Sem r ()
ensureConversationAccess UserId
zusr Conversation
conv Access
access = do
  Conversation -> Access -> Sem r ()
forall (r :: EffectRow).
Member (ErrorS 'ConvAccessDenied) r =>
Conversation -> Access -> Sem r ()
ensureAccess Conversation
conv Access
access
  Maybe TeamMember
zusrMembership <- Sem r (Maybe TeamMember)
-> (TeamId -> Sem r (Maybe TeamMember))
-> Maybe TeamId
-> Sem r (Maybe TeamMember)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Maybe TeamMember -> Sem r (Maybe TeamMember)
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe TeamMember
forall a. Maybe a
Nothing) (TeamId -> UserId -> Sem r (Maybe TeamMember)
forall (r :: EffectRow).
Member TeamStore r =>
TeamId -> UserId -> Sem r (Maybe TeamMember)
`getTeamMember` UserId
zusr) (Conversation -> Maybe TeamId
Data.convTeam Conversation
conv)
  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
Data.convAccessRoles Conversation
conv) [(UserId
zusr, Maybe TeamMember
zusrMembership)]

ensureAccess ::
  (Member (ErrorS 'ConvAccessDenied) r) =>
  Data.Conversation ->
  Access ->
  Sem r ()
ensureAccess :: forall (r :: EffectRow).
Member (ErrorS 'ConvAccessDenied) r =>
Conversation -> Access -> Sem r ()
ensureAccess Conversation
conv Access
access =
  Bool -> Sem r () -> Sem r ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Access
access Access -> [Access] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` Conversation -> [Access]
Data.convAccess Conversation
conv) (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 @'ConvAccessDenied

ensureLocal :: (Member (Error FederationError) r) => Local x -> Qualified a -> Sem r (Local a)
ensureLocal :: forall (r :: EffectRow) x a.
Member (Error FederationError) r =>
Local x -> Qualified a -> Sem r (Local a)
ensureLocal Local x
loc = Local x
-> (Local a -> Sem r (Local a))
-> (Remote a -> Sem r (Local a))
-> Qualified a
-> Sem r (Local a)
forall x a b.
Local x -> (Local a -> b) -> (Remote a -> b) -> Qualified a -> b
foldQualified Local x
loc Local a -> Sem r (Local a)
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (\Remote a
_ -> FederationError -> Sem r (Local a)
forall e (r :: EffectRow) a. Member (Error e) r => e -> Sem r a
throw FederationError
FederationNotImplemented)

--------------------------------------------------------------------------------
-- Federation

qualifyLocal :: (Member (Input (Local ())) r) => a -> Sem r (Local a)
qualifyLocal :: forall (r :: EffectRow) a.
Member (Input (Local ())) r =>
a -> Sem r (Local a)
qualifyLocal a
a = Domain -> a -> Local a
forall a. Domain -> a -> Local a
toLocalUnsafe (Domain -> a -> Local a) -> Sem r Domain -> Sem r (a -> Local a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Local () -> Domain) -> Sem r (Local ()) -> Sem r Domain
forall a b. (a -> b) -> Sem r a -> Sem r b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Local () -> Domain
getDomain Sem r (Local ())
forall i (r :: EffectRow). Member (Input i) r => Sem r i
input Sem r (a -> Local a) -> Sem r a -> Sem r (Local a)
forall a b. Sem r (a -> b) -> Sem r a -> Sem r b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> a -> Sem r a
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a
  where
    getDomain :: Local () -> Domain
    getDomain :: Local () -> Domain
getDomain = Local () -> Domain
forall (t :: QTag) a. QualifiedWithTag t a -> Domain
tDomain

runLocalInput :: Local x -> Sem (Input (Local ()) ': r) a -> Sem r a
runLocalInput :: forall x (r :: EffectRow) a.
Local x -> Sem (Input (Local ()) : r) a -> Sem r a
runLocalInput = Local () -> Sem (Input (Local ()) : r) a -> Sem r a
forall i (r :: EffectRow) a. i -> Sem (Input i : r) a -> Sem r a
runInputConst (Local () -> Sem (Input (Local ()) : r) a -> Sem r a)
-> (Local x -> Local ())
-> Local x
-> Sem (Input (Local ()) : r) a
-> Sem r a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Local x -> Local ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void

-- | Convert an internal conversation representation 'Data.Conversation' to
-- 'ConversationCreated' to be sent over the wire to a remote backend that will
-- reconstruct this into multiple public-facing
-- 'Wire.API.Conversation.Conversation' values, one per user from that remote
-- backend.
--
-- FUTUREWORK: Include the team ID as well once it becomes qualified.
toConversationCreated ::
  -- | The time stamp the conversation was created at
  UTCTime ->
  -- | The user that created the conversation
  Local UserId ->
  -- | The conversation to convert for sending to a remote Galley
  Data.Conversation ->
  -- | The resulting information to be sent to a remote Galley
  ConversationCreated ConvId
toConversationCreated :: UTCTime
-> Local UserId -> Conversation -> ConversationCreated ConvId
toConversationCreated UTCTime
now Local UserId
lusr Data.Conversation {$sel:convMetadata:Conversation :: Conversation -> ConversationMetadata
convMetadata = ConversationMetadata {[Access]
Maybe Text
Maybe TeamId
Maybe UserId
Maybe Milliseconds
Maybe ReceiptMode
Set AccessRole
ConvType
cnvmType :: ConvType
cnvmCreator :: Maybe UserId
cnvmAccess :: [Access]
cnvmAccessRoles :: Set AccessRole
cnvmName :: Maybe Text
cnvmTeam :: Maybe TeamId
cnvmMessageTimer :: Maybe Milliseconds
cnvmReceiptMode :: Maybe ReceiptMode
$sel:cnvmType:ConversationMetadata :: ConversationMetadata -> ConvType
$sel:cnvmCreator:ConversationMetadata :: ConversationMetadata -> Maybe UserId
$sel:cnvmAccess:ConversationMetadata :: ConversationMetadata -> [Access]
$sel:cnvmAccessRoles:ConversationMetadata :: ConversationMetadata -> Set AccessRole
$sel:cnvmName:ConversationMetadata :: ConversationMetadata -> Maybe Text
$sel:cnvmTeam:ConversationMetadata :: ConversationMetadata -> Maybe TeamId
$sel:cnvmMessageTimer:ConversationMetadata :: ConversationMetadata -> Maybe Milliseconds
$sel:cnvmReceiptMode:ConversationMetadata :: ConversationMetadata -> Maybe ReceiptMode
..}, Bool
[LocalMember]
[RemoteMember]
ConvId
Protocol
$sel:convLocalMembers:Conversation :: Conversation -> [LocalMember]
$sel:convId:Conversation :: Conversation -> ConvId
$sel:convRemoteMembers:Conversation :: Conversation -> [RemoteMember]
convId :: ConvId
convLocalMembers :: [LocalMember]
convRemoteMembers :: [RemoteMember]
convDeleted :: Bool
convProtocol :: Protocol
$sel:convDeleted:Conversation :: Conversation -> Bool
$sel:convProtocol:Conversation :: Conversation -> Protocol
..} =
  ConversationCreated
    { $sel:time:ConversationCreated :: UTCTime
time = UTCTime
now,
      $sel:origUserId:ConversationCreated :: UserId
origUserId = Local UserId -> UserId
forall (t :: QTag) a. QualifiedWithTag t a -> a
tUnqualified Local UserId
lusr,
      $sel:cnvId:ConversationCreated :: ConvId
cnvId = ConvId
convId,
      $sel:cnvType:ConversationCreated :: ConvType
cnvType = ConvType
cnvmType,
      $sel:cnvAccess:ConversationCreated :: [Access]
cnvAccess = [Access]
cnvmAccess,
      $sel:cnvAccessRoles:ConversationCreated :: Set AccessRole
cnvAccessRoles = Set AccessRole
cnvmAccessRoles,
      $sel:cnvName:ConversationCreated :: Maybe Text
cnvName = Maybe Text
cnvmName,
      -- non-creator members are a function of the remote backend and will be
      -- overridden when fanning out the notification to remote backends.
      $sel:nonCreatorMembers:ConversationCreated :: Set OtherMember
nonCreatorMembers = Set OtherMember
forall a. Set a
Set.empty,
      $sel:messageTimer:ConversationCreated :: Maybe Milliseconds
messageTimer = Maybe Milliseconds
cnvmMessageTimer,
      $sel:receiptMode:ConversationCreated :: Maybe ReceiptMode
receiptMode = Maybe ReceiptMode
cnvmReceiptMode,
      $sel:protocol:ConversationCreated :: Protocol
protocol = Protocol
convProtocol
    }

-- | The function converts a 'ConversationCreated' value to a
-- 'Wire.API.Conversation.Conversation' value for each user that is on the given
-- domain/backend. The obtained value can be used in e.g. creating an 'Event' to
-- be sent out to users informing them that they were added to a new
-- conversation.
fromConversationCreated ::
  Local x ->
  ConversationCreated (Remote ConvId) ->
  [(Public.Member, Public.Conversation)]
fromConversationCreated :: forall x.
Local x
-> ConversationCreated (Remote ConvId) -> [(Member, Conversation)]
fromConversationCreated Local x
loc rc :: ConversationCreated (Remote ConvId)
rc@ConversationCreated {[Access]
Maybe Text
Maybe Milliseconds
Maybe ReceiptMode
UTCTime
Set OtherMember
Set AccessRole
UserId
Remote ConvId
Protocol
ConvType
$sel:time:ConversationCreated :: forall conv. ConversationCreated conv -> UTCTime
$sel:origUserId:ConversationCreated :: forall conv. ConversationCreated conv -> UserId
$sel:cnvId:ConversationCreated :: forall conv. ConversationCreated conv -> conv
$sel:cnvType:ConversationCreated :: forall conv. ConversationCreated conv -> ConvType
$sel:cnvAccess:ConversationCreated :: forall conv. ConversationCreated conv -> [Access]
$sel:cnvAccessRoles:ConversationCreated :: forall conv. ConversationCreated conv -> Set AccessRole
$sel:cnvName:ConversationCreated :: forall conv. ConversationCreated conv -> Maybe Text
$sel:nonCreatorMembers:ConversationCreated :: forall conv. ConversationCreated conv -> Set OtherMember
$sel:messageTimer:ConversationCreated :: forall conv. ConversationCreated conv -> Maybe Milliseconds
$sel:receiptMode:ConversationCreated :: forall conv. ConversationCreated conv -> Maybe ReceiptMode
$sel:protocol:ConversationCreated :: forall conv. ConversationCreated conv -> Protocol
time :: UTCTime
origUserId :: UserId
cnvId :: Remote ConvId
cnvType :: ConvType
cnvAccess :: [Access]
cnvAccessRoles :: Set AccessRole
cnvName :: Maybe Text
nonCreatorMembers :: Set OtherMember
messageTimer :: Maybe Milliseconds
receiptMode :: Maybe ReceiptMode
protocol :: Protocol
..} =
  let membersView :: [(OtherMember, [OtherMember])]
membersView = ((OtherMember, Set OtherMember) -> (OtherMember, [OtherMember]))
-> [(OtherMember, Set OtherMember)]
-> [(OtherMember, [OtherMember])]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Set OtherMember -> [OtherMember])
-> (OtherMember, Set OtherMember) -> (OtherMember, [OtherMember])
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second Set OtherMember -> [OtherMember]
forall a. Set a -> [a]
Set.toList) ([(OtherMember, Set OtherMember)]
 -> [(OtherMember, [OtherMember])])
-> (Set OtherMember -> [(OtherMember, Set OtherMember)])
-> Set OtherMember
-> [(OtherMember, [OtherMember])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set OtherMember -> [(OtherMember, Set OtherMember)]
forall a. Ord a => Set a -> [(a, Set a)]
setHoles (Set OtherMember -> [(OtherMember, [OtherMember])])
-> Set OtherMember -> [(OtherMember, [OtherMember])]
forall a b. (a -> b) -> a -> b
$ Set OtherMember
nonCreatorMembers
      creatorOther :: OtherMember
creatorOther =
        Qualified UserId -> Maybe ServiceRef -> RoleName -> OtherMember
OtherMember
          (Remote UserId -> Qualified UserId
forall (t :: QTag) a. QualifiedWithTag t a -> Qualified a
tUntagged (ConversationCreated (Remote ConvId) -> Remote UserId
ccRemoteOrigUserId ConversationCreated (Remote ConvId)
rc))
          Maybe ServiceRef
forall a. Maybe a
Nothing
          RoleName
roleNameWireAdmin
   in ((OtherMember, [OtherMember]) -> [(Member, Conversation)])
-> [(OtherMember, [OtherMember])] -> [(Member, Conversation)]
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap
        ( \(OtherMember
me, [OtherMember]
others) ->
            Bool -> [()]
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (OtherMember -> Bool
inDomain OtherMember
me) [()] -> (Member, Conversation) -> [(Member, Conversation)]
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> let mem :: Member
mem = OtherMember -> Member
toMember OtherMember
me in (Member
mem, Member -> [OtherMember] -> Conversation
conv Member
mem (OtherMember
creatorOther OtherMember -> [OtherMember] -> [OtherMember]
forall a. a -> [a] -> [a]
: [OtherMember]
others))
        )
        [(OtherMember, [OtherMember])]
membersView
  where
    inDomain :: OtherMember -> Bool
    inDomain :: OtherMember -> Bool
inDomain = (Domain -> Domain -> Bool
forall a. Eq a => a -> a -> Bool
== Local x -> Domain
forall (t :: QTag) a. QualifiedWithTag t a -> Domain
tDomain Local x
loc) (Domain -> Bool) -> (OtherMember -> Domain) -> OtherMember -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Qualified UserId -> Domain
forall a. Qualified a -> Domain
qDomain (Qualified UserId -> Domain)
-> (OtherMember -> Qualified UserId) -> OtherMember -> Domain
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OtherMember -> Qualified UserId
Public.omQualifiedId
    setHoles :: (Ord a) => Set a -> [(a, Set a)]
    setHoles :: forall a. Ord a => Set a -> [(a, Set a)]
setHoles Set a
s = (a -> [(a, Set a)]) -> Set a -> [(a, Set a)]
forall m a. Monoid m => (a -> m) -> Set a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (\a
x -> [(a
x, a -> Set a -> Set a
forall a. Ord a => a -> Set a -> Set a
Set.delete a
x Set a
s)]) Set a
s
    -- Currently this function creates a Member with default conversation attributes
    -- FUTUREWORK(federation): retrieve member's conversation attributes (muted, archived, etc) here once supported by the database schema.
    toMember :: OtherMember -> Public.Member
    toMember :: OtherMember -> Member
toMember OtherMember
m =
      Public.Member
        { $sel:memId:Member :: Qualified UserId
memId = OtherMember -> Qualified UserId
Public.omQualifiedId OtherMember
m,
          $sel:memService:Member :: Maybe ServiceRef
memService = OtherMember -> Maybe ServiceRef
Public.omService OtherMember
m,
          $sel:memOtrMutedStatus:Member :: Maybe MutedStatus
memOtrMutedStatus = Maybe MutedStatus
forall a. Maybe a
Nothing,
          $sel:memOtrMutedRef:Member :: Maybe Text
memOtrMutedRef = Maybe Text
forall a. Maybe a
Nothing,
          $sel:memOtrArchived:Member :: Bool
memOtrArchived = Bool
False,
          $sel:memOtrArchivedRef:Member :: Maybe Text
memOtrArchivedRef = Maybe Text
forall a. Maybe a
Nothing,
          $sel:memHidden:Member :: Bool
memHidden = Bool
False,
          $sel:memHiddenRef:Member :: Maybe Text
memHiddenRef = Maybe Text
forall a. Maybe a
Nothing,
          $sel:memConvRoleName:Member :: RoleName
memConvRoleName = OtherMember -> RoleName
Public.omConvRoleName OtherMember
m
        }
    conv :: Public.Member -> [OtherMember] -> Public.Conversation
    conv :: Member -> [OtherMember] -> Conversation
conv Member
this [OtherMember]
others =
      Qualified ConvId
-> ConversationMetadata -> ConvMembers -> Protocol -> Conversation
Public.Conversation
        (Remote ConvId -> Qualified ConvId
forall (t :: QTag) a. QualifiedWithTag t a -> Qualified a
tUntagged Remote ConvId
cnvId)
        ConversationMetadata
          { $sel:cnvmType:ConversationMetadata :: ConvType
cnvmType = ConvType
cnvType,
            -- FUTUREWORK: Document this is the same domain as the conversation
            -- domain
            $sel:cnvmCreator:ConversationMetadata :: Maybe UserId
cnvmCreator = UserId -> Maybe UserId
forall a. a -> Maybe a
Just UserId
origUserId,
            $sel:cnvmAccess:ConversationMetadata :: [Access]
cnvmAccess = [Access]
cnvAccess,
            $sel:cnvmAccessRoles:ConversationMetadata :: Set AccessRole
cnvmAccessRoles = Set AccessRole
cnvAccessRoles,
            $sel:cnvmName:ConversationMetadata :: Maybe Text
cnvmName = Maybe Text
cnvName,
            -- FUTUREWORK: Document this is the same domain as the conversation
            -- domain.
            $sel:cnvmTeam:ConversationMetadata :: Maybe TeamId
cnvmTeam = Maybe TeamId
forall a. Maybe a
Nothing,
            $sel:cnvmMessageTimer:ConversationMetadata :: Maybe Milliseconds
cnvmMessageTimer = Maybe Milliseconds
messageTimer,
            $sel:cnvmReceiptMode:ConversationMetadata :: Maybe ReceiptMode
cnvmReceiptMode = Maybe ReceiptMode
receiptMode
          }
        (Member -> [OtherMember] -> ConvMembers
ConvMembers Member
this [OtherMember]
others)
        Protocol
ProtocolProteus

ensureNoUnreachableBackends ::
  (Member (Error UnreachableBackends) r) =>
  [Either (Remote e, b) a] ->
  Sem r [a]
ensureNoUnreachableBackends :: forall (r :: EffectRow) e b a.
Member (Error UnreachableBackends) r =>
[Either (Remote e, b) a] -> Sem r [a]
ensureNoUnreachableBackends [Either (Remote e, b) a]
results = do
  let ([(Remote e, b)]
errors, [a]
values) = [Either (Remote e, b) a] -> ([(Remote e, b)], [a])
forall a b. [Either a b] -> ([a], [b])
partitionEithers [Either (Remote e, b) a]
results
  Bool -> Sem r () -> Sem r ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([(Remote e, b)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Remote e, b)]
errors) (Sem r () -> Sem r ()) -> Sem r () -> Sem r ()
forall a b. (a -> b) -> a -> b
$
    UnreachableBackends -> Sem r ()
forall e (r :: EffectRow) a. Member (Error e) r => e -> Sem r a
throw ([Domain] -> UnreachableBackends
UnreachableBackends (((Remote e, b) -> Domain) -> [(Remote e, b)] -> [Domain]
forall a b. (a -> b) -> [a] -> [b]
map (Remote e -> Domain
forall (t :: QTag) a. QualifiedWithTag t a -> Domain
tDomain (Remote e -> Domain)
-> ((Remote e, b) -> Remote e) -> (Remote e, b) -> Domain
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Remote e, b) -> Remote e
forall a b. (a, b) -> a
fst) [(Remote e, b)]
errors))
  [a] -> Sem r [a]
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [a]
values

-- | Notify remote users of being added to a new conversation.
registerRemoteConversationMemberships ::
  ( Member ConversationStore r,
    Member (Error UnreachableBackends) r,
    Member (Error FederationError) r,
    Member BackendNotificationQueueAccess r,
    Member FederatorAccess r
  ) =>
  -- | The time stamp when the conversation was created
  UTCTime ->
  Local UserId ->
  Local Data.Conversation ->
  Sem r ()
registerRemoteConversationMemberships :: forall (r :: EffectRow).
(Member ConversationStore r, Member (Error UnreachableBackends) r,
 Member (Error FederationError) r,
 Member BackendNotificationQueueAccess r,
 Member FederatorAccess r) =>
UTCTime -> Local UserId -> Local Conversation -> Sem r ()
registerRemoteConversationMemberships UTCTime
now Local UserId
lusr Local Conversation
lc = Sem r () -> Sem r ()
forall (r :: EffectRow) a.
(Member ConversationStore r,
 Member (Error UnreachableBackends) r) =>
Sem r a -> Sem r a
deleteOnUnreachable (Sem r () -> Sem r ()) -> Sem r () -> Sem r ()
forall a b. (a -> b) -> a -> b
$ do
  let c :: Conversation
c = Local Conversation -> Conversation
forall (t :: QTag) a. QualifiedWithTag t a -> a
tUnqualified Local Conversation
lc
      rc :: ConversationCreated ConvId
rc = UTCTime
-> Local UserId -> Conversation -> ConversationCreated ConvId
toConversationCreated UTCTime
now Local UserId
lusr Conversation
c
      allRemoteMembers :: [RemoteMember]
allRemoteMembers = [RemoteMember] -> [RemoteMember]
forall a. Ord a => [a] -> [a]
nubOrd {- (but why would there be duplicates?) -} (Conversation -> [RemoteMember]
Data.convRemoteMembers Conversation
c)
      allRemoteMembersQualified :: [Remote RemoteMember]
allRemoteMembersQualified = RemoteMember -> Remote RemoteMember
remoteMemberQualify (RemoteMember -> Remote RemoteMember)
-> [RemoteMember] -> [Remote RemoteMember]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [RemoteMember]
allRemoteMembers
      [Remote [RemoteMember]]
allRemoteBuckets :: [Remote [RemoteMember]] = [Remote RemoteMember] -> [Remote [RemoteMember]]
forall (f :: * -> *) a.
(Functor f, Foldable f) =>
f (Remote a) -> [Remote [a]]
bucketRemote [Remote RemoteMember]
allRemoteMembersQualified

  -- ping involved remote backends
  Sem r [Remote ()] -> Sem r ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Sem r [Remote ()] -> Sem r ())
-> (Sem
      r [Either (Remote [RemoteMember], FederationError) (Remote ())]
    -> Sem r [Remote ()])
-> Sem
     r [Either (Remote [RemoteMember], FederationError) (Remote ())]
-> Sem r ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Either (Remote [RemoteMember], 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 [RemoteMember], FederationError) (Remote ())]
 -> Sem r ())
-> Sem
     r [Either (Remote [RemoteMember], FederationError) (Remote ())]
-> Sem r ()
forall a b. (a -> b) -> a -> b
$
    [Remote RemoteMember]
-> (Remote [RemoteMember] -> FederatorClient 'Brig ())
-> Sem
     r [Either (Remote [RemoteMember], FederationError) (Remote ())]
forall (r :: EffectRow) (c :: Component) (f :: * -> *) x a.
(Member FederatorAccess r, KnownComponent c, Foldable f,
 Functor f) =>
f (Remote x)
-> (Remote [x] -> FederatorClient c a)
-> Sem r [Either (Remote [x], FederationError) (Remote a)]
runFederatedConcurrentlyEither [Remote RemoteMember]
allRemoteMembersQualified ((Remote [RemoteMember] -> FederatorClient 'Brig ())
 -> Sem
      r [Either (Remote [RemoteMember], FederationError) (Remote ())])
-> (Remote [RemoteMember] -> FederatorClient 'Brig ())
-> Sem
     r [Either (Remote [RemoteMember], FederationError) (Remote ())]
forall a b. (a -> b) -> a -> b
$ \Remote [RemoteMember]
_ ->
      FederatorClient 'Brig VersionInfo -> FederatorClient 'Brig ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (FederatorClient 'Brig VersionInfo -> FederatorClient 'Brig ())
-> FederatorClient 'Brig VersionInfo -> FederatorClient 'Brig ()
forall a b. (a -> b) -> a -> b
$ forall {k} (comp :: Component) (name :: k)
       (fedM :: Component -> * -> *) (showcomp :: Symbol) api.
(showcomp ~ ShowComponent comp, HasFedEndpoint comp api name,
 HasClient (fedM comp) api, KnownComponent comp, IsNamed name,
 FederationMonad fedM, Typeable (Client (fedM comp) api)) =>
Client (fedM comp) api
forall (comp :: Component) (name :: Symbol)
       (fedM :: Component -> * -> *) (showcomp :: Symbol) api.
(showcomp ~ ShowComponent comp, HasFedEndpoint comp api name,
 HasClient (fedM comp) api, KnownComponent comp, IsNamed name,
 FederationMonad fedM, Typeable (Client (fedM comp) api)) =>
Client (fedM comp) api
fedClient @'Brig @"api-version" ()

  Sem r [Remote EmptyResponse] -> Sem r ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Sem r [Remote EmptyResponse] -> Sem r ())
-> (Sem
      r
      [Either
         (Remote [RemoteMember], FederationError) (Remote EmptyResponse)]
    -> Sem r [Remote EmptyResponse])
-> Sem
     r
     [Either
        (Remote [RemoteMember], FederationError) (Remote EmptyResponse)]
-> Sem r ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Either
   (Remote [RemoteMember], FederationError) (Remote EmptyResponse)]
-> Sem r [Remote EmptyResponse]
forall (r :: EffectRow) e b a.
Member (Error UnreachableBackends) r =>
[Either (Remote e, b) a] -> Sem r [a]
ensureNoUnreachableBackends =<<) (Sem
   r
   [Either
      (Remote [RemoteMember], FederationError) (Remote EmptyResponse)]
 -> Sem r ())
-> Sem
     r
     [Either
        (Remote [RemoteMember], FederationError) (Remote EmptyResponse)]
-> Sem r ()
forall a b. (a -> b) -> a -> b
$
    -- let remote backends know about a subset of new joiners
    [Remote RemoteMember]
-> (Remote [RemoteMember] -> FederatorClient 'Galley EmptyResponse)
-> Sem
     r
     [Either
        (Remote [RemoteMember], 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)]
runFederatedConcurrentlyEither [Remote RemoteMember]
allRemoteMembersQualified ((Remote [RemoteMember] -> FederatorClient 'Galley EmptyResponse)
 -> Sem
      r
      [Either
         (Remote [RemoteMember], FederationError) (Remote EmptyResponse)])
-> (Remote [RemoteMember] -> FederatorClient 'Galley EmptyResponse)
-> Sem
     r
     [Either
        (Remote [RemoteMember], FederationError) (Remote EmptyResponse)]
forall a b. (a -> b) -> a -> b
$
      \Remote [RemoteMember]
rrms ->
        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-conversation-created"
          ( ConversationCreated ConvId
rc
              { nonCreatorMembers =
                  toMembers (tUnqualified rrms)
              }
          )

  -- reachable members in buckets per remote domain
  let [Remote [RemoteMember]]
joined :: [Remote [RemoteMember]] = [Remote [RemoteMember]]
allRemoteBuckets
      joinedCoupled :: [Remote ([RemoteMember], NonEmpty (Remote UserId))]
      joinedCoupled :: [Remote ([RemoteMember], NonEmpty (Remote UserId))]
joinedCoupled =
        (Remote [RemoteMember]
 -> [Remote ([RemoteMember], NonEmpty (Remote UserId))])
-> [Remote [RemoteMember]]
-> [Remote ([RemoteMember], NonEmpty (Remote UserId))]
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap
          ( \Remote [RemoteMember]
ruids ->
              let nj :: [Remote UserId]
nj =
                    (Remote [RemoteMember] -> [Remote UserId])
-> [Remote [RemoteMember]] -> [Remote UserId]
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ((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] -> [Remote UserId])
-> (Remote [RemoteMember] -> [RemoteMember])
-> Remote [RemoteMember]
-> [Remote UserId]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Remote [RemoteMember] -> [RemoteMember]
forall (t :: QTag) a. QualifiedWithTag t a -> a
tUnqualified) ([Remote [RemoteMember]] -> [Remote UserId])
-> [Remote [RemoteMember]] -> [Remote UserId]
forall a b. (a -> b) -> a -> b
$
                      (Remote [RemoteMember] -> Bool)
-> [Remote [RemoteMember]] -> [Remote [RemoteMember]]
forall a. (a -> Bool) -> [a] -> [a]
filter (\Remote [RemoteMember]
r -> Remote [RemoteMember] -> Domain
forall (t :: QTag) a. QualifiedWithTag t a -> Domain
tDomain Remote [RemoteMember]
r Domain -> Domain -> Bool
forall a. Eq a => a -> a -> Bool
/= Remote [RemoteMember] -> Domain
forall (t :: QTag) a. QualifiedWithTag t a -> Domain
tDomain Remote [RemoteMember]
ruids) [Remote [RemoteMember]]
joined
               in case [Remote UserId] -> Maybe (NonEmpty (Remote UserId))
forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty [Remote UserId]
nj of
                    Maybe (NonEmpty (Remote UserId))
Nothing -> []
                    Just NonEmpty (Remote UserId)
v -> [([RemoteMember] -> ([RemoteMember], NonEmpty (Remote UserId)))
-> Remote [RemoteMember]
-> Remote ([RemoteMember], NonEmpty (Remote UserId))
forall a b.
(a -> b)
-> QualifiedWithTag 'QRemote a -> QualifiedWithTag 'QRemote b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (,NonEmpty (Remote UserId)
v) Remote [RemoteMember]
ruids]
          )
          [Remote [RemoteMember]]
joined

  Sem r [Remote ()] -> Sem r ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Sem r [Remote ()] -> Sem r ()) -> Sem r [Remote ()] -> Sem r ()
forall a b. (a -> b) -> a -> b
$ DeliveryMode
-> [Remote ([RemoteMember], NonEmpty (Remote UserId))]
-> (Remote ([RemoteMember], NonEmpty (Remote UserId))
    -> FedQueueClient 'Galley ())
-> Sem r [Remote ()]
forall (c :: Component) (f :: * -> *) (r :: EffectRow) x a.
(KnownComponent c, Foldable f, Functor f,
 Member (Error FederationError) r,
 Member BackendNotificationQueueAccess r) =>
DeliveryMode
-> f (Remote x)
-> (Remote x -> FedQueueClient c a)
-> Sem r [Remote a]
enqueueNotificationsConcurrentlyBuckets DeliveryMode
Q.Persistent [Remote ([RemoteMember], NonEmpty (Remote UserId))]
joinedCoupled ((Remote ([RemoteMember], NonEmpty (Remote UserId))
  -> FedQueueClient 'Galley ())
 -> Sem r [Remote ()])
-> (Remote ([RemoteMember], NonEmpty (Remote UserId))
    -> FedQueueClient 'Galley ())
-> Sem r [Remote ()]
forall a b. (a -> b) -> a -> b
$ \Remote ([RemoteMember], NonEmpty (Remote UserId))
z ->
    ConversationUpdate
-> FedQueueClient 'Galley (PayloadBundle 'Galley)
makeConversationUpdateBundle (Remote ([RemoteMember], NonEmpty (Remote UserId))
-> ConversationUpdate
convUpdateJoin Remote ([RemoteMember], NonEmpty (Remote UserId))
z) 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
  where
    creator :: Maybe UserId
    creator :: Maybe UserId
creator = ConversationMetadata -> Maybe UserId
cnvmCreator (ConversationMetadata -> Maybe UserId)
-> (Local Conversation -> ConversationMetadata)
-> Local Conversation
-> Maybe UserId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Conversation -> ConversationMetadata
DataTypes.convMetadata (Conversation -> ConversationMetadata)
-> (Local Conversation -> Conversation)
-> Local Conversation
-> ConversationMetadata
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Local Conversation -> Conversation
forall (t :: QTag) a. QualifiedWithTag t a -> a
tUnqualified (Local Conversation -> Maybe UserId)
-> Local Conversation -> Maybe UserId
forall a b. (a -> b) -> a -> b
$ Local Conversation
lc

    localNonCreators :: [OtherMember]
    localNonCreators :: [OtherMember]
localNonCreators =
      (LocalMember -> OtherMember) -> [LocalMember] -> [OtherMember]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Domain -> LocalMember -> OtherMember
localMemberToOther (Domain -> LocalMember -> OtherMember)
-> (Local Conversation -> Domain)
-> Local Conversation
-> LocalMember
-> OtherMember
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Local Conversation -> Domain
forall (t :: QTag) a. QualifiedWithTag t a -> Domain
tDomain (Local Conversation -> LocalMember -> OtherMember)
-> Local Conversation -> LocalMember -> OtherMember
forall a b. (a -> b) -> a -> b
$ Local Conversation
lc)
        ([LocalMember] -> [OtherMember])
-> (Local Conversation -> [LocalMember])
-> Local Conversation
-> [OtherMember]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LocalMember -> Bool) -> [LocalMember] -> [LocalMember]
forall a. (a -> Bool) -> [a] -> [a]
filter (\LocalMember
lm -> LocalMember -> UserId
lmId LocalMember
lm UserId -> Maybe UserId -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` Maybe UserId
creator)
        ([LocalMember] -> [LocalMember])
-> (Local Conversation -> [LocalMember])
-> Local Conversation
-> [LocalMember]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Conversation -> [LocalMember]
Data.convLocalMembers
        (Conversation -> [LocalMember])
-> (Local Conversation -> Conversation)
-> Local Conversation
-> [LocalMember]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Local Conversation -> Conversation
forall (t :: QTag) a. QualifiedWithTag t a -> a
tUnqualified
        (Local Conversation -> [OtherMember])
-> Local Conversation -> [OtherMember]
forall a b. (a -> b) -> a -> b
$ Local Conversation
lc

    -- Total set of members living on one remote backend (rs) or the hosting backend.
    toMembers :: [RemoteMember] -> Set OtherMember
    toMembers :: [RemoteMember] -> Set OtherMember
toMembers [RemoteMember]
rs = [OtherMember] -> Set OtherMember
forall a. Ord a => [a] -> Set a
Set.fromList ([OtherMember] -> Set OtherMember)
-> [OtherMember] -> Set OtherMember
forall a b. (a -> b) -> a -> b
$ [OtherMember]
localNonCreators [OtherMember] -> [OtherMember] -> [OtherMember]
forall a. Semigroup a => a -> a -> a
<> (RemoteMember -> OtherMember) -> [RemoteMember] -> [OtherMember]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap RemoteMember -> OtherMember
remoteMemberToOther [RemoteMember]
rs

    convUpdateJoin :: Remote ([RemoteMember], NonEmpty (Remote UserId)) -> ConversationUpdate
    convUpdateJoin :: Remote ([RemoteMember], NonEmpty (Remote UserId))
-> ConversationUpdate
convUpdateJoin (Remote ([RemoteMember], NonEmpty (Remote UserId))
-> ([RemoteMember], NonEmpty (Remote UserId))
forall (t :: QTag) a. QualifiedWithTag t a -> a
tUnqualified -> ([RemoteMember]
toNotify, NonEmpty (Remote UserId)
newMembers)) =
      ConversationUpdate
        { $sel:time:ConversationUpdate :: UTCTime
time = UTCTime
now,
          $sel:origUserId:ConversationUpdate :: Qualified UserId
origUserId = Local UserId -> Qualified UserId
forall (t :: QTag) a. QualifiedWithTag t a -> Qualified a
tUntagged Local UserId
lusr,
          $sel:convId:ConversationUpdate :: ConvId
convId = Conversation -> ConvId
DataTypes.convId (Local Conversation -> Conversation
forall (t :: QTag) a. QualifiedWithTag t a -> a
tUnqualified Local Conversation
lc),
          $sel:alreadyPresentUsers:ConversationUpdate :: [UserId]
alreadyPresentUsers = (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]
toNotify,
          $sel:action:ConversationUpdate :: SomeConversationAction
action =
            Sing 'ConversationJoinTag
-> ConversationAction 'ConversationJoinTag
-> SomeConversationAction
forall (tag :: ConversationActionTag).
Sing tag -> ConversationAction tag -> SomeConversationAction
SomeConversationAction
              (forall {k} (a :: k). SingI a => Sing a
forall (a :: ConversationActionTag). SingI a => Sing a
sing @'ConversationJoinTag)
              -- FUTUREWORK(md): replace the member role with whatever is provided in
              -- the NewConv input
              (NonEmpty (Qualified UserId) -> RoleName -> ConversationJoin
ConversationJoin (Remote UserId -> Qualified UserId
forall (t :: QTag) a. QualifiedWithTag t a -> Qualified a
tUntagged (Remote UserId -> Qualified UserId)
-> NonEmpty (Remote UserId) -> NonEmpty (Qualified UserId)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty (Remote UserId)
newMembers) RoleName
roleNameWireMember)
        }

    deleteOnUnreachable ::
      ( Member ConversationStore r,
        Member (Error UnreachableBackends) r
      ) =>
      Sem r a ->
      Sem r a
    deleteOnUnreachable :: forall (r :: EffectRow) a.
(Member ConversationStore r,
 Member (Error UnreachableBackends) r) =>
Sem r a -> Sem r a
deleteOnUnreachable Sem r a
m = forall e (r :: EffectRow) a.
Member (Error e) r =>
Sem r a -> (e -> Sem r a) -> Sem r a
catch @UnreachableBackends Sem r a
m ((UnreachableBackends -> Sem r a) -> Sem r a)
-> (UnreachableBackends -> Sem r a) -> Sem r a
forall a b. (a -> b) -> a -> b
$ \UnreachableBackends
e -> do
      ConvId -> Sem r ()
forall (r :: EffectRow).
Member ConversationStore r =>
ConvId -> Sem r ()
deleteConversation (Conversation -> ConvId
DataTypes.convId (Local Conversation -> Conversation
forall (t :: QTag) a. QualifiedWithTag t a -> a
tUnqualified Local Conversation
lc))
      UnreachableBackends -> Sem r a
forall e (r :: EffectRow) a. Member (Error e) r => e -> Sem r a
throw UnreachableBackends
e

--------------------------------------------------------------------------------
-- Legalhold

userLHEnabled :: UserLegalHoldStatus -> Bool
userLHEnabled :: UserLegalHoldStatus -> Bool
userLHEnabled = \case
  UserLegalHoldStatus
UserLegalHoldEnabled -> Bool
True
  UserLegalHoldStatus
UserLegalHoldPending -> Bool
False
  UserLegalHoldStatus
UserLegalHoldDisabled -> Bool
False
  UserLegalHoldStatus
UserLegalHoldNoConsent -> Bool
False

data ConsentGiven = ConsentGiven | ConsentNotGiven
  deriving (ConsentGiven -> ConsentGiven -> Bool
(ConsentGiven -> ConsentGiven -> Bool)
-> (ConsentGiven -> ConsentGiven -> Bool) -> Eq ConsentGiven
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ConsentGiven -> ConsentGiven -> Bool
== :: ConsentGiven -> ConsentGiven -> Bool
$c/= :: ConsentGiven -> ConsentGiven -> Bool
/= :: ConsentGiven -> ConsentGiven -> Bool
Eq, Eq ConsentGiven
Eq ConsentGiven =>
(ConsentGiven -> ConsentGiven -> Ordering)
-> (ConsentGiven -> ConsentGiven -> Bool)
-> (ConsentGiven -> ConsentGiven -> Bool)
-> (ConsentGiven -> ConsentGiven -> Bool)
-> (ConsentGiven -> ConsentGiven -> Bool)
-> (ConsentGiven -> ConsentGiven -> ConsentGiven)
-> (ConsentGiven -> ConsentGiven -> ConsentGiven)
-> Ord ConsentGiven
ConsentGiven -> ConsentGiven -> Bool
ConsentGiven -> ConsentGiven -> Ordering
ConsentGiven -> ConsentGiven -> ConsentGiven
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: ConsentGiven -> ConsentGiven -> Ordering
compare :: ConsentGiven -> ConsentGiven -> Ordering
$c< :: ConsentGiven -> ConsentGiven -> Bool
< :: ConsentGiven -> ConsentGiven -> Bool
$c<= :: ConsentGiven -> ConsentGiven -> Bool
<= :: ConsentGiven -> ConsentGiven -> Bool
$c> :: ConsentGiven -> ConsentGiven -> Bool
> :: ConsentGiven -> ConsentGiven -> Bool
$c>= :: ConsentGiven -> ConsentGiven -> Bool
>= :: ConsentGiven -> ConsentGiven -> Bool
$cmax :: ConsentGiven -> ConsentGiven -> ConsentGiven
max :: ConsentGiven -> ConsentGiven -> ConsentGiven
$cmin :: ConsentGiven -> ConsentGiven -> ConsentGiven
min :: ConsentGiven -> ConsentGiven -> ConsentGiven
Ord, Int -> ConsentGiven -> ShowS
[ConsentGiven] -> ShowS
ConsentGiven -> String
(Int -> ConsentGiven -> ShowS)
-> (ConsentGiven -> String)
-> ([ConsentGiven] -> ShowS)
-> Show ConsentGiven
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ConsentGiven -> ShowS
showsPrec :: Int -> ConsentGiven -> ShowS
$cshow :: ConsentGiven -> String
show :: ConsentGiven -> String
$cshowList :: [ConsentGiven] -> ShowS
showList :: [ConsentGiven] -> ShowS
Show)

consentGiven :: UserLegalHoldStatus -> ConsentGiven
consentGiven :: UserLegalHoldStatus -> ConsentGiven
consentGiven = \case
  UserLegalHoldStatus
UserLegalHoldDisabled -> ConsentGiven
ConsentGiven
  UserLegalHoldStatus
UserLegalHoldPending -> ConsentGiven
ConsentGiven
  UserLegalHoldStatus
UserLegalHoldEnabled -> ConsentGiven
ConsentGiven
  UserLegalHoldStatus
UserLegalHoldNoConsent -> ConsentGiven
ConsentNotGiven

checkConsent ::
  (Member TeamStore r) =>
  Map UserId TeamId ->
  UserId ->
  Sem r ConsentGiven
checkConsent :: forall (r :: EffectRow).
Member TeamStore r =>
Map UserId TeamId -> UserId -> Sem r ConsentGiven
checkConsent Map UserId TeamId
teamsOfUsers UserId
other = do
  UserLegalHoldStatus -> ConsentGiven
consentGiven (UserLegalHoldStatus -> ConsentGiven)
-> Sem r UserLegalHoldStatus -> Sem r ConsentGiven
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe TeamId -> UserId -> Sem r UserLegalHoldStatus
forall (r :: EffectRow).
Member TeamStore r =>
Maybe TeamId -> UserId -> Sem r UserLegalHoldStatus
getLHStatus (UserId -> Map UserId TeamId -> Maybe TeamId
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup UserId
other Map UserId TeamId
teamsOfUsers) UserId
other

-- Get legalhold status of user. Defaults to 'defUserLegalHoldStatus' if user
-- doesn't belong to a team.
getLHStatus ::
  (Member TeamStore r) =>
  Maybe TeamId ->
  UserId ->
  Sem r UserLegalHoldStatus
getLHStatus :: forall (r :: EffectRow).
Member TeamStore r =>
Maybe TeamId -> UserId -> Sem r UserLegalHoldStatus
getLHStatus Maybe TeamId
teamOfUser UserId
other = do
  case Maybe TeamId
teamOfUser of
    Maybe TeamId
Nothing -> UserLegalHoldStatus -> Sem r UserLegalHoldStatus
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure UserLegalHoldStatus
defUserLegalHoldStatus
    Just TeamId
team -> do
      Maybe TeamMember
mMember <- TeamId -> UserId -> Sem r (Maybe TeamMember)
forall (r :: EffectRow).
Member TeamStore r =>
TeamId -> UserId -> Sem r (Maybe TeamMember)
getTeamMember TeamId
team UserId
other
      UserLegalHoldStatus -> Sem r UserLegalHoldStatus
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (UserLegalHoldStatus -> Sem r UserLegalHoldStatus)
-> UserLegalHoldStatus -> Sem r UserLegalHoldStatus
forall a b. (a -> b) -> a -> b
$ UserLegalHoldStatus
-> (TeamMember -> UserLegalHoldStatus)
-> Maybe TeamMember
-> UserLegalHoldStatus
forall b a. b -> (a -> b) -> Maybe a -> b
maybe UserLegalHoldStatus
defUserLegalHoldStatus (Getting UserLegalHoldStatus TeamMember UserLegalHoldStatus
-> TeamMember -> UserLegalHoldStatus
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting UserLegalHoldStatus TeamMember UserLegalHoldStatus
forall (tag :: PermissionTag) (f :: * -> *).
Functor f =>
(UserLegalHoldStatus -> f UserLegalHoldStatus)
-> TeamMember' tag -> f (TeamMember' tag)
legalHoldStatus) Maybe TeamMember
mMember

anyLegalholdActivated ::
  ( Member (Input Opts) r,
    Member TeamStore r
  ) =>
  [UserId] ->
  Sem r Bool
anyLegalholdActivated :: forall (r :: EffectRow).
(Member (Input Opts) r, Member TeamStore r) =>
[UserId] -> Sem r Bool
anyLegalholdActivated [UserId]
uids = do
  Opts
opts <- Sem r Opts
forall i (r :: EffectRow). Member (Input i) r => Sem r i
input
  case Getting
  (FeatureDefaults LegalholdConfig)
  Opts
  (FeatureDefaults LegalholdConfig)
-> Opts -> FeatureDefaults LegalholdConfig
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view ((Settings -> Const (FeatureDefaults LegalholdConfig) Settings)
-> Opts -> Const (FeatureDefaults LegalholdConfig) Opts
Lens' Opts Settings
settings ((Settings -> Const (FeatureDefaults LegalholdConfig) Settings)
 -> Opts -> Const (FeatureDefaults LegalholdConfig) Opts)
-> ((FeatureDefaults LegalholdConfig
     -> Const
          (FeatureDefaults LegalholdConfig)
          (FeatureDefaults LegalholdConfig))
    -> Settings -> Const (FeatureDefaults LegalholdConfig) Settings)
-> Getting
     (FeatureDefaults LegalholdConfig)
     Opts
     (FeatureDefaults LegalholdConfig)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FeatureFlags
 -> Const (FeatureDefaults LegalholdConfig) FeatureFlags)
-> Settings -> Const (FeatureDefaults LegalholdConfig) Settings
Lens' Settings FeatureFlags
featureFlags ((FeatureFlags
  -> Const (FeatureDefaults LegalholdConfig) FeatureFlags)
 -> Settings -> Const (FeatureDefaults LegalholdConfig) Settings)
-> ((FeatureDefaults LegalholdConfig
     -> Const
          (FeatureDefaults LegalholdConfig)
          (FeatureDefaults LegalholdConfig))
    -> FeatureFlags
    -> Const (FeatureDefaults LegalholdConfig) FeatureFlags)
-> (FeatureDefaults LegalholdConfig
    -> Const
         (FeatureDefaults LegalholdConfig)
         (FeatureDefaults LegalholdConfig))
-> Settings
-> Const (FeatureDefaults LegalholdConfig) Settings
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FeatureFlags -> FeatureDefaults LegalholdConfig)
-> (FeatureDefaults LegalholdConfig
    -> Const
         (FeatureDefaults LegalholdConfig)
         (FeatureDefaults LegalholdConfig))
-> FeatureFlags
-> Const (FeatureDefaults LegalholdConfig) FeatureFlags
forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to FeatureFlags -> FeatureDefaults LegalholdConfig
forall {k} (x :: k) (f :: k -> *) (xs :: [k]).
NpProject x xs =>
NP f xs -> f x
npProject) Opts
opts of
    FeatureDefaults LegalholdConfig
R:FeatureDefaultsLegalholdConfig
FeatureLegalHoldDisabledPermanently -> Bool -> Sem r Bool
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
    FeatureDefaults LegalholdConfig
R:FeatureDefaultsLegalholdConfig
FeatureLegalHoldDisabledByDefault -> Sem r Bool
check
    FeatureDefaults LegalholdConfig
R:FeatureDefaultsLegalholdConfig
FeatureLegalHoldWhitelistTeamsAndImplicitConsent -> Sem r Bool
check
  where
    check :: Sem r Bool
check = do
      (([UserId] -> Sem r Bool) -> [[UserId]] -> Sem r Bool)
-> [[UserId]] -> ([UserId] -> Sem r Bool) -> Sem r Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip ([UserId] -> Sem r Bool) -> [[UserId]] -> Sem r Bool
forall (m :: * -> *) a. Monad m => (a -> m Bool) -> [a] -> m Bool
anyM (Int -> [UserId] -> [[UserId]]
forall a. Partial => Int -> [a] -> [[a]]
chunksOf Int
32 [UserId]
uids) (([UserId] -> Sem r Bool) -> Sem r Bool)
-> ([UserId] -> Sem r Bool) -> Sem r Bool
forall a b. (a -> b) -> a -> b
$ \[UserId]
uidsPage -> do
        Map UserId TeamId
teamsOfUsers <- [UserId] -> Sem r (Map UserId TeamId)
forall (r :: EffectRow).
Member TeamStore r =>
[UserId] -> Sem r (Map UserId TeamId)
getUsersTeams [UserId]
uidsPage
        (UserId -> Sem r Bool) -> [UserId] -> Sem r Bool
forall (m :: * -> *) a. Monad m => (a -> m Bool) -> [a] -> m Bool
anyM (\UserId
uid -> UserLegalHoldStatus -> Bool
userLHEnabled (UserLegalHoldStatus -> Bool)
-> Sem r UserLegalHoldStatus -> Sem r Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe TeamId -> UserId -> Sem r UserLegalHoldStatus
forall (r :: EffectRow).
Member TeamStore r =>
Maybe TeamId -> UserId -> Sem r UserLegalHoldStatus
getLHStatus (UserId -> Map UserId TeamId -> Maybe TeamId
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup UserId
uid Map UserId TeamId
teamsOfUsers) UserId
uid) [UserId]
uidsPage

allLegalholdConsentGiven ::
  ( Member (Input Opts) r,
    Member LegalHoldStore r,
    Member TeamStore r
  ) =>
  [UserId] ->
  Sem r Bool
allLegalholdConsentGiven :: forall (r :: EffectRow).
(Member (Input Opts) r, Member LegalHoldStore r,
 Member TeamStore r) =>
[UserId] -> Sem r Bool
allLegalholdConsentGiven [UserId]
uids = do
  Opts
opts <- Sem r Opts
forall i (r :: EffectRow). Member (Input i) r => Sem r i
input
  case Getting
  (FeatureDefaults LegalholdConfig)
  Opts
  (FeatureDefaults LegalholdConfig)
-> Opts -> FeatureDefaults LegalholdConfig
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view ((Settings -> Const (FeatureDefaults LegalholdConfig) Settings)
-> Opts -> Const (FeatureDefaults LegalholdConfig) Opts
Lens' Opts Settings
settings ((Settings -> Const (FeatureDefaults LegalholdConfig) Settings)
 -> Opts -> Const (FeatureDefaults LegalholdConfig) Opts)
-> ((FeatureDefaults LegalholdConfig
     -> Const
          (FeatureDefaults LegalholdConfig)
          (FeatureDefaults LegalholdConfig))
    -> Settings -> Const (FeatureDefaults LegalholdConfig) Settings)
-> Getting
     (FeatureDefaults LegalholdConfig)
     Opts
     (FeatureDefaults LegalholdConfig)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FeatureFlags
 -> Const (FeatureDefaults LegalholdConfig) FeatureFlags)
-> Settings -> Const (FeatureDefaults LegalholdConfig) Settings
Lens' Settings FeatureFlags
featureFlags ((FeatureFlags
  -> Const (FeatureDefaults LegalholdConfig) FeatureFlags)
 -> Settings -> Const (FeatureDefaults LegalholdConfig) Settings)
-> ((FeatureDefaults LegalholdConfig
     -> Const
          (FeatureDefaults LegalholdConfig)
          (FeatureDefaults LegalholdConfig))
    -> FeatureFlags
    -> Const (FeatureDefaults LegalholdConfig) FeatureFlags)
-> (FeatureDefaults LegalholdConfig
    -> Const
         (FeatureDefaults LegalholdConfig)
         (FeatureDefaults LegalholdConfig))
-> Settings
-> Const (FeatureDefaults LegalholdConfig) Settings
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FeatureFlags -> FeatureDefaults LegalholdConfig)
-> (FeatureDefaults LegalholdConfig
    -> Const
         (FeatureDefaults LegalholdConfig)
         (FeatureDefaults LegalholdConfig))
-> FeatureFlags
-> Const (FeatureDefaults LegalholdConfig) FeatureFlags
forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to FeatureFlags -> FeatureDefaults LegalholdConfig
forall {k} (x :: k) (f :: k -> *) (xs :: [k]).
NpProject x xs =>
NP f xs -> f x
npProject) Opts
opts of
    FeatureDefaults LegalholdConfig
R:FeatureDefaultsLegalholdConfig
FeatureLegalHoldDisabledPermanently -> Bool -> Sem r Bool
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
    FeatureDefaults LegalholdConfig
R:FeatureDefaultsLegalholdConfig
FeatureLegalHoldDisabledByDefault -> do
      (([UserId] -> Sem r Bool) -> [[UserId]] -> Sem r Bool)
-> [[UserId]] -> ([UserId] -> Sem r Bool) -> Sem r Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip ([UserId] -> Sem r Bool) -> [[UserId]] -> Sem r Bool
forall (m :: * -> *) a. Monad m => (a -> m Bool) -> [a] -> m Bool
allM (Int -> [UserId] -> [[UserId]]
forall a. Partial => Int -> [a] -> [[a]]
chunksOf Int
32 [UserId]
uids) (([UserId] -> Sem r Bool) -> Sem r Bool)
-> ([UserId] -> Sem r Bool) -> Sem r Bool
forall a b. (a -> b) -> a -> b
$ \[UserId]
uidsPage -> do
        Map UserId TeamId
teamsOfUsers <- [UserId] -> Sem r (Map UserId TeamId)
forall (r :: EffectRow).
Member TeamStore r =>
[UserId] -> Sem r (Map UserId TeamId)
getUsersTeams [UserId]
uidsPage
        (UserId -> Sem r Bool) -> [UserId] -> Sem r Bool
forall (m :: * -> *) a. Monad m => (a -> m Bool) -> [a] -> m Bool
allM (\UserId
uid -> (ConsentGiven -> ConsentGiven -> Bool
forall a. Eq a => a -> a -> Bool
== ConsentGiven
ConsentGiven) (ConsentGiven -> Bool)
-> (UserLegalHoldStatus -> ConsentGiven)
-> UserLegalHoldStatus
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UserLegalHoldStatus -> ConsentGiven
consentGiven (UserLegalHoldStatus -> Bool)
-> Sem r UserLegalHoldStatus -> Sem r Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe TeamId -> UserId -> Sem r UserLegalHoldStatus
forall (r :: EffectRow).
Member TeamStore r =>
Maybe TeamId -> UserId -> Sem r UserLegalHoldStatus
getLHStatus (UserId -> Map UserId TeamId -> Maybe TeamId
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup UserId
uid Map UserId TeamId
teamsOfUsers) UserId
uid) [UserId]
uidsPage
    FeatureDefaults LegalholdConfig
R:FeatureDefaultsLegalholdConfig
FeatureLegalHoldWhitelistTeamsAndImplicitConsent -> do
      -- For this feature the implementation is more efficient. Being part of
      -- a whitelisted team is equivalent to have given consent to be in a
      -- conversation with user under legalhold.
      (([UserId] -> Sem r Bool) -> [[UserId]] -> Sem r Bool)
-> [[UserId]] -> ([UserId] -> Sem r Bool) -> Sem r Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip ([UserId] -> Sem r Bool) -> [[UserId]] -> Sem r Bool
forall (m :: * -> *) a. Monad m => (a -> m Bool) -> [a] -> m Bool
allM (Int -> [UserId] -> [[UserId]]
forall a. Partial => Int -> [a] -> [[a]]
chunksOf Int
32 [UserId]
uids) (([UserId] -> Sem r Bool) -> Sem r Bool)
-> ([UserId] -> Sem r Bool) -> Sem r Bool
forall a b. (a -> b) -> a -> b
$ \[UserId]
uidsPage -> do
        Map UserId TeamId
teamsPage <- [UserId] -> Sem r (Map UserId TeamId)
forall (r :: EffectRow).
Member TeamStore r =>
[UserId] -> Sem r (Map UserId TeamId)
getUsersTeams [UserId]
uidsPage
        (UserId -> Sem r Bool) -> [UserId] -> Sem r Bool
forall (m :: * -> *) a. Monad m => (a -> m Bool) -> [a] -> m Bool
allM (Map UserId TeamId -> UserId -> Sem r Bool
forall {k} {r :: EffectRow}.
(Ord k, Member LegalHoldStore r) =>
Map k TeamId -> k -> Sem r Bool
eitherTeamMemberAndLHAllowedOrDefLHStatus Map UserId TeamId
teamsPage) [UserId]
uidsPage
      where
        eitherTeamMemberAndLHAllowedOrDefLHStatus :: Map k TeamId -> k -> Sem r Bool
eitherTeamMemberAndLHAllowedOrDefLHStatus Map k TeamId
teamsPage k
uid = do
          Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe (UserLegalHoldStatus -> ConsentGiven
consentGiven UserLegalHoldStatus
defUserLegalHoldStatus ConsentGiven -> ConsentGiven -> Bool
forall a. Eq a => a -> a -> Bool
== ConsentGiven
ConsentGiven) (Maybe Bool -> Bool) -> Sem r (Maybe Bool) -> Sem r Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Maybe TeamId -> (TeamId -> Sem r Bool) -> Sem r (Maybe Bool)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for (k -> Map k TeamId -> Maybe TeamId
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup k
uid Map k TeamId
teamsPage) TeamId -> Sem r Bool
forall (r :: EffectRow).
Member LegalHoldStore r =>
TeamId -> Sem r Bool
isTeamLegalholdWhitelisted)

-- | Add to every uid the legalhold status
getLHStatusForUsers ::
  (Member TeamStore r) =>
  [UserId] ->
  Sem r [(UserId, UserLegalHoldStatus)]
getLHStatusForUsers :: forall (r :: EffectRow).
Member TeamStore r =>
[UserId] -> Sem r [(UserId, UserLegalHoldStatus)]
getLHStatusForUsers [UserId]
uids =
  [[(UserId, UserLegalHoldStatus)]]
-> [(UserId, UserLegalHoldStatus)]
forall a. Monoid a => [a] -> a
mconcat
    ([[(UserId, UserLegalHoldStatus)]]
 -> [(UserId, UserLegalHoldStatus)])
-> Sem r [[(UserId, UserLegalHoldStatus)]]
-> Sem r [(UserId, UserLegalHoldStatus)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [[UserId]]
-> ([UserId] -> Sem r [(UserId, UserLegalHoldStatus)])
-> Sem r [[(UserId, UserLegalHoldStatus)]]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for
      (Int -> [UserId] -> [[UserId]]
forall a. Partial => Int -> [a] -> [[a]]
chunksOf Int
32 [UserId]
uids)
      ( \[UserId]
uidsChunk -> do
          Map UserId TeamId
teamsOfUsers <- [UserId] -> Sem r (Map UserId TeamId)
forall (r :: EffectRow).
Member TeamStore r =>
[UserId] -> Sem r (Map UserId TeamId)
getUsersTeams [UserId]
uidsChunk
          [UserId]
-> (UserId -> Sem r (UserId, UserLegalHoldStatus))
-> Sem r [(UserId, UserLegalHoldStatus)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [UserId]
uidsChunk ((UserId -> Sem r (UserId, UserLegalHoldStatus))
 -> Sem r [(UserId, UserLegalHoldStatus)])
-> (UserId -> Sem r (UserId, UserLegalHoldStatus))
-> Sem r [(UserId, UserLegalHoldStatus)]
forall a b. (a -> b) -> a -> b
$ \UserId
uid -> do
            (UserId
uid,) (UserLegalHoldStatus -> (UserId, UserLegalHoldStatus))
-> Sem r UserLegalHoldStatus -> Sem r (UserId, UserLegalHoldStatus)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe TeamId -> UserId -> Sem r UserLegalHoldStatus
forall (r :: EffectRow).
Member TeamStore r =>
Maybe TeamId -> UserId -> Sem r UserLegalHoldStatus
getLHStatus (UserId -> Map UserId TeamId -> Maybe TeamId
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup UserId
uid Map UserId TeamId
teamsOfUsers) UserId
uid
      )

getTeamMembersForFanout :: (Member TeamStore r) => TeamId -> Sem r TeamMemberList
getTeamMembersForFanout :: forall (r :: EffectRow).
Member TeamStore r =>
TeamId -> Sem r TeamMemberList
getTeamMembersForFanout TeamId
tid = do
  Range 1 HardTruncationLimit Int32
lim <- Sem r (Range 1 HardTruncationLimit Int32)
forall (r :: EffectRow).
Member TeamStore r =>
Sem r (Range 1 HardTruncationLimit Int32)
fanoutLimit
  TeamId -> Range 1 HardTruncationLimit Int32 -> Sem r TeamMemberList
forall (r :: EffectRow).
Member TeamStore r =>
TeamId -> Range 1 HardTruncationLimit Int32 -> Sem r TeamMemberList
getTeamMembersWithLimit TeamId
tid Range 1 HardTruncationLimit Int32
lim

ensureMemberLimit ::
  ( Foldable f,
    ( Member (ErrorS 'TooManyMembers) r,
      Member (Input Opts) r
    )
  ) =>
  ProtocolTag ->
  [LocalMember] ->
  f a ->
  Sem r ()
ensureMemberLimit :: forall (f :: * -> *) (r :: EffectRow) a.
(Foldable f,
 (Member (ErrorS 'TooManyMembers) r, Member (Input Opts) r)) =>
ProtocolTag -> [LocalMember] -> f a -> Sem r ()
ensureMemberLimit ProtocolTag
ProtocolMLSTag [LocalMember]
_ f a
_ = () -> Sem r ()
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
ensureMemberLimit ProtocolTag
_ [LocalMember]
old f a
new = do
  Opts
o <- Sem r Opts
forall i (r :: EffectRow). Member (Input i) r => Sem r i
input
  let maxSize :: Int
maxSize = Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Opts
o Opts -> Getting Word16 Opts Word16 -> Word16
forall s a. s -> Getting a s a -> a
^. (Settings -> Const Word16 Settings) -> Opts -> Const Word16 Opts
Lens' Opts Settings
settings ((Settings -> Const Word16 Settings) -> Opts -> Const Word16 Opts)
-> ((Word16 -> Const Word16 Word16)
    -> Settings -> Const Word16 Settings)
-> Getting Word16 Opts Word16
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Word16 -> Const Word16 Word16)
-> Settings -> Const Word16 Settings
Lens' Settings Word16
maxConvSize)
  Bool -> Sem r () -> Sem r ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([LocalMember] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [LocalMember]
old Int -> Int -> Int
forall a. Num a => a -> a -> a
+ f a -> Int
forall a. f a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length f a
new Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
maxSize) (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 @'TooManyMembers

conversationExisted ::
  ( Member (Error InternalError) r,
    Member P.TinyLog r
  ) =>
  Local UserId ->
  Data.Conversation ->
  Sem r (ConversationResponse Conversation)
conversationExisted :: forall (r :: EffectRow).
(Member (Error InternalError) r, Member TinyLog r) =>
Local UserId
-> Conversation -> Sem r (ConversationResponse Conversation)
conversationExisted Local UserId
lusr Conversation
cnv = Conversation -> ResponseForExistedCreated Conversation
forall a. a -> ResponseForExistedCreated a
Existed (Conversation -> ResponseForExistedCreated Conversation)
-> Sem r Conversation
-> Sem r (ResponseForExistedCreated Conversation)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Local UserId -> Conversation -> Sem r Conversation
forall (r :: EffectRow).
(Member (Error InternalError) r, Member TinyLog r) =>
Local UserId -> Conversation -> Sem r Conversation
conversationView Local UserId
lusr Conversation
cnv

getLocalUsers :: Domain -> NonEmpty (Qualified UserId) -> [UserId]
getLocalUsers :: Domain -> NonEmpty (Qualified UserId) -> [UserId]
getLocalUsers Domain
localDomain = (Qualified UserId -> UserId) -> [Qualified UserId] -> [UserId]
forall a b. (a -> b) -> [a] -> [b]
map Qualified UserId -> UserId
forall a. Qualified a -> a
qUnqualified ([Qualified UserId] -> [UserId])
-> (NonEmpty (Qualified UserId) -> [Qualified UserId])
-> NonEmpty (Qualified UserId)
-> [UserId]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Qualified UserId -> Bool)
-> [Qualified UserId] -> [Qualified UserId]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Domain -> Domain -> Bool
forall a. Eq a => a -> a -> Bool
== Domain
localDomain) (Domain -> Bool)
-> (Qualified UserId -> Domain) -> Qualified UserId -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Qualified UserId -> Domain
forall a. Qualified a -> Domain
qDomain) ([Qualified UserId] -> [Qualified UserId])
-> (NonEmpty (Qualified UserId) -> [Qualified UserId])
-> NonEmpty (Qualified UserId)
-> [Qualified UserId]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty (Qualified UserId) -> [Qualified UserId]
forall a. NonEmpty a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList

getBrigClients ::
  ( Member BrigAccess r,
    Member ClientStore r
  ) =>
  [UserId] ->
  Sem r Clients
getBrigClients :: forall (r :: EffectRow).
(Member BrigAccess r, Member ClientStore r) =>
[UserId] -> Sem r Clients
getBrigClients [UserId]
users = do
  Bool
isInternal <- Sem r Bool
forall (r :: EffectRow). Member ClientStore r => Sem r Bool
useIntraClientListing
  if Bool
isInternal
    then UserClients -> Clients
fromUserClients (UserClients -> Clients) -> Sem r UserClients -> Sem r Clients
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [UserId] -> Sem r UserClients
forall (r :: EffectRow).
Member BrigAccess r =>
[UserId] -> Sem r UserClients
lookupClients [UserId]
users
    else [UserId] -> Sem r Clients
forall (r :: EffectRow).
Member ClientStore r =>
[UserId] -> Sem r Clients
getClients [UserId]
users

--------------------------------------------------------------------------------
-- Handling remote errors

class RethrowErrors (effs :: EffectRow) r where
  rethrowErrors :: GalleyError -> Sem r a

instance (Member (Error FederationError) r) => RethrowErrors '[] r where
  rethrowErrors :: GalleyError -> Sem r a
  rethrowErrors :: forall a. GalleyError -> Sem r a
rethrowErrors GalleyError
err' = FederationError -> Sem r a
forall e (r :: EffectRow) a. Member (Error e) r => e -> Sem r a
throw (Text -> FederationError
FederationUnexpectedError (String -> Text
T.pack (String -> Text) -> (GalleyError -> String) -> GalleyError -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GalleyError -> String
forall a. Show a => a -> String
show (GalleyError -> Text) -> GalleyError -> Text
forall a b. (a -> b) -> a -> b
$ GalleyError
err'))

instance
  ( SingI (e :: GalleyError),
    Member (ErrorS e) r,
    RethrowErrors effs r
  ) =>
  RethrowErrors (ErrorS e ': effs) r
  where
  rethrowErrors :: GalleyError -> Sem r a
  rethrowErrors :: forall a. GalleyError -> Sem r a
rethrowErrors GalleyError
err' =
    if GalleyError
err' GalleyError -> GalleyError -> Bool
forall a. Eq a => a -> a -> Bool
== forall {k} (a :: k). (SingKind k, SingI a) => Demote k
forall (a :: GalleyError).
(SingKind GalleyError, SingI a) =>
Demote GalleyError
demote @e
      then 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 @e
      else forall (effs :: EffectRow) (r :: EffectRow) a.
RethrowErrors effs r =>
GalleyError -> Sem r a
rethrowErrors @effs @r GalleyError
err'