"Fossies" - the Fresh Open Source Software Archive  

Source code changes of the file "services/galley/src/Galley/API/Update.hs" between
wire-server-2020-06-10.tar.gz and wire-server-2020-06-19.tar.gz

About: Wire (server) offers end-to-end encrypted messaging, file-sharing, video and voice calls, and guest rooms for external communication (back-end server).

Update.hs  (wire-server-2020-06-10):Update.hs  (wire-server-2020-06-19)
skipping to change at line 63 skipping to change at line 63
postBotMessageH, postBotMessageH,
) )
where where
import qualified Brig.Types.User as User import qualified Brig.Types.User as User
import Control.Lens import Control.Lens
import Control.Monad.Catch import Control.Monad.Catch
import Control.Monad.State import Control.Monad.State
import Data.Code import Data.Code
import Data.Id import Data.Id
import qualified Data.Id as Id
import Data.IdMapping import Data.IdMapping
import Data.List (delete)
import Data.List.Extra (nubOrdOn) import Data.List.Extra (nubOrdOn)
import Data.List.NonEmpty (nonEmpty) import Data.List.NonEmpty (nonEmpty)
import Data.List1 import Data.List1
import qualified Data.Map.Strict as Map import qualified Data.Map.Strict as Map
import Data.Range import Data.Range
import qualified Data.Set as Set import qualified Data.Set as Set
import Data.Time import Data.Time
import Galley.API.Error import Galley.API.Error
import Galley.API.Mapping import Galley.API.Mapping
import qualified Galley.API.Teams as Teams import qualified Galley.API.Teams as Teams
skipping to change at line 112 skipping to change at line 112
import qualified Wire.API.Message.Proto as Proto import qualified Wire.API.Message.Proto as Proto
acceptConvH :: UserId ::: Maybe ConnId ::: ConvId -> Galley Response acceptConvH :: UserId ::: Maybe ConnId ::: ConvId -> Galley Response
acceptConvH (usr ::: conn ::: cnv) = do acceptConvH (usr ::: conn ::: cnv) = do
setStatus status200 . json <$> acceptConv usr conn cnv setStatus status200 . json <$> acceptConv usr conn cnv
acceptConv :: UserId -> Maybe ConnId -> ConvId -> Galley Conversation acceptConv :: UserId -> Maybe ConnId -> ConvId -> Galley Conversation
acceptConv usr conn cnv = do acceptConv usr conn cnv = do
conv <- Data.conversation cnv >>= ifNothing convNotFound conv <- Data.conversation cnv >>= ifNothing convNotFound
conv' <- acceptOne2One usr conv conn conv' <- acceptOne2One usr conv conn
conversationView usr conv' conversationView (Local usr) conv'
blockConvH :: UserId ::: ConvId -> Galley Response blockConvH :: UserId ::: ConvId -> Galley Response
blockConvH (zusr ::: cnv) = do blockConvH (zusr ::: cnv) = do
empty <$ blockConv zusr cnv empty <$ blockConv zusr cnv
blockConv :: UserId -> ConvId -> Galley () blockConv :: UserId -> ConvId -> Galley ()
blockConv zusr cnv = do blockConv zusr cnv = do
conv <- Data.conversation cnv >>= ifNothing convNotFound conv <- Data.conversation cnv >>= ifNothing convNotFound
unless (Data.convType conv `elem` [ConnectConv, One2OneConv]) unless (Data.convType conv `elem` [ConnectConv, One2OneConv])
$ throwM $ throwM
$ invalidOp "block: invalid conversation type" $ invalidOp "block: invalid conversation type"
let mems = Data.convMembers conv let mems = Data.convMembers conv
when (makeIdOpaque zusr `isMember` mems) $ Data.removeMember zusr cnv when (Local zusr `isMember` mems) $ Data.removeMember (Local zusr) cnv
unblockConvH :: UserId ::: Maybe ConnId ::: ConvId -> Galley Response unblockConvH :: UserId ::: Maybe ConnId ::: ConvId -> Galley Response
unblockConvH (usr ::: conn ::: cnv) = do unblockConvH (usr ::: conn ::: cnv) = do
setStatus status200 . json <$> unblockConv usr conn cnv setStatus status200 . json <$> unblockConv usr conn cnv
unblockConv :: UserId -> Maybe ConnId -> ConvId -> Galley Conversation unblockConv :: UserId -> Maybe ConnId -> ConvId -> Galley Conversation
unblockConv usr conn cnv = do unblockConv usr conn cnv = do
conv <- Data.conversation cnv >>= ifNothing convNotFound conv <- Data.conversation cnv >>= ifNothing convNotFound
unless (Data.convType conv `elem` [ConnectConv, One2OneConv]) unless (Data.convType conv `elem` [ConnectConv, One2OneConv])
$ throwM $ throwM
$ invalidOp "unblock: invalid conversation type" $ invalidOp "unblock: invalid conversation type"
conv' <- acceptOne2One usr conv conn conv' <- acceptOne2One usr conv conn
conversationView usr conv' conversationView (Local usr) conv'
-- conversation updates -- conversation updates
data UpdateResult data UpdateResult
= Updated Public.Event = Updated Public.Event
| Unchanged | Unchanged
handleUpdateResult :: UpdateResult -> Response handleUpdateResult :: UpdateResult -> Response
handleUpdateResult = \case handleUpdateResult = \case
Updated ev -> json ev & setStatus status200 Updated ev -> json ev & setStatus status200
skipping to change at line 166 skipping to change at line 166
updateConversationAccess :: UserId -> ConnId -> ConvId -> Public.ConversationAcc essUpdate -> Galley UpdateResult updateConversationAccess :: UserId -> ConnId -> ConvId -> Public.ConversationAcc essUpdate -> Galley UpdateResult
updateConversationAccess usr zcon cnv update = do updateConversationAccess usr zcon cnv update = do
let targetAccess = Set.fromList (toList (cupAccess update)) let targetAccess = Set.fromList (toList (cupAccess update))
targetRole = cupAccessRole update targetRole = cupAccessRole update
-- 'PrivateAccessRole' is for self-conversations, 1:1 conversations and -- 'PrivateAccessRole' is for self-conversations, 1:1 conversations and
-- so on; users are not supposed to be able to make other conversations -- so on; users are not supposed to be able to make other conversations
-- have 'PrivateAccessRole' -- have 'PrivateAccessRole'
when (PrivateAccess `elem` targetAccess || PrivateAccessRole == targetRole) $ when (PrivateAccess `elem` targetAccess || PrivateAccessRole == targetRole) $
throwM invalidTargetAccess throwM invalidTargetAccess
-- The user who initiated access change has to be a conversation member -- The user who initiated access change has to be a conversation member
(bots, users) <- botsAndUsers <$> Data.members cnv (bots, users) <- botsAndUsers =<< Data.members cnv
ensureConvMember users usr ensureConvMember users usr
conv <- Data.conversation cnv >>= ifNothing convNotFound conv <- Data.conversation cnv >>= ifNothing convNotFound
-- The conversation has to be a group conversation -- The conversation has to be a group conversation
ensureGroupConv conv ensureGroupConv conv
self <- getSelfMember usr users self <- getSelfMember usr users
ensureActionAllowed ModifyConversationAccess self ensureActionAllowed ModifyConversationAccess self
-- Team conversations incur another round of checks -- Team conversations incur another round of checks
case Data.convTeam conv of case Data.convTeam conv of
Just tid -> checkTeamConv tid self Just tid -> checkTeamConv tid self
Nothing -> when (targetRole == TeamAccessRole) $ throwM invalidTargetAccess Nothing -> when (targetRole == TeamAccessRole) $ throwM invalidTargetAccess
skipping to change at line 230 skipping to change at line 230
Data.deleteCode key ReusableCode Data.deleteCode key ReusableCode
-- Depending on a variety of things, some bots and users have to be -- Depending on a variety of things, some bots and users have to be
-- removed from the conversation. We keep track of them using 'State'. -- removed from the conversation. We keep track of them using 'State'.
(newUsers, newBots) <- flip execStateT (users, bots) $ do (newUsers, newBots) <- flip execStateT (users, bots) $ do
-- We might have to remove non-activated members -- We might have to remove non-activated members
-- TODO(akshay): Remove Ord instance for AccessRole. It is dangerous -- TODO(akshay): Remove Ord instance for AccessRole. It is dangerous
-- to make assumption about the order of roles and implement policy -- to make assumption about the order of roles and implement policy
-- based on those assumptions. -- based on those assumptions.
when (currentRole > ActivatedAccessRole && targetRole <= ActivatedAccessRole ) $ do when (currentRole > ActivatedAccessRole && targetRole <= ActivatedAccessRole ) $ do
mIds <- map memId <$> use usersL mIds <- map memId <$> use usersL
activated <- fmap User.userId <$> lift (lookupActivatedUsers mIds) let (localMemberIds, _) = partitionMappedOrLocalIds mIds
usersL %= filter (\user -> memId user `elem` activated) activated <- fmap User.userId <$> lift (lookupActivatedUsers localMemberId
s)
let isActivatedOrRemote user = case memId user of
Local l -> l `elem` activated
Mapped _ -> True -- remote users don't need to be activated (we can'
t enforce it anyways)
usersL %= filter isActivatedOrRemote
-- In a team-only conversation we also want to remove bots and guests -- In a team-only conversation we also want to remove bots and guests
case (targetRole, Data.convTeam conv) of case (targetRole, Data.convTeam conv) of
(TeamAccessRole, Just tid) -> do (TeamAccessRole, Just tid) -> do
currentUsers <- use usersL currentUsers <- use usersL
onlyTeamUsers <- filterM (\user -> lift $ isJust <$> Data.teamMember tid onlyTeamUsers <- flip filterM currentUsers $ \user ->
(memId user)) currentUsers case memId user of
Mapped _ -> pure False -- remote users can't be team members
Local localId -> lift $ isJust <$> Data.teamMember tid localId
assign usersL onlyTeamUsers assign usersL onlyTeamUsers
botsL .= [] botsL .= []
_ -> return () _ -> return ()
-- Update Cassandra & send an event -- Update Cassandra & send an event
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
let accessEvent = Event ConvAccessUpdate cnv usr now (Just $ EdConvAccessUpdat e body) let accessEvent = Event ConvAccessUpdate cnv usr now (Just $ EdConvAccessUpdat e body)
Data.updateConversationAccess cnv targetAccess targetRole Data.updateConversationAccess cnv targetAccess targetRole
pushEvent accessEvent users bots zcon pushEvent accessEvent users bots zcon
-- Remove users and bots -- Remove users and bots
let removedUsers = map memId users \\ map memId newUsers let removedUsers = map memId users \\ map memId newUsers
removedBots = map botMemId bots \\ map botMemId newBots removedBots = map botMemId bots \\ map botMemId newBots
mapM_ (deleteBot cnv) removedBots mapM_ (deleteBot cnv) removedBots
case removedUsers of case removedUsers of
[] -> return () [] -> return ()
x : xs -> do x : xs -> do
e <- Data.removeMembers conv usr (Local <$> list1 x xs) e <- Data.removeMembers conv usr (list1 x xs)
-- push event to all clients, including zconn -- push event to all clients, including zconn
-- since updateConversationAccess generates a second (member removal) even t here -- since updateConversationAccess generates a second (member removal) even t here
for_ (newPush ListComplete (evtFrom e) (ConvEvent e) (recipient <$> users) ) $ \p -> push1 p for_ (newPush ListComplete (evtFrom e) (ConvEvent e) (recipient <$> users) ) $ \p -> push1 p
void . forkIO $ void $ External.deliver (newBots `zip` repeat e) void . forkIO $ void $ External.deliver (newBots `zip` repeat e)
-- Return the event -- Return the event
pure accessEvent pure accessEvent
where where
usersL :: Lens' ([Member], [BotMember]) [Member] usersL :: Lens' ([Member], [BotMember]) [Member]
usersL = _1 usersL = _1
botsL :: Lens' ([Member], [BotMember]) [BotMember] botsL :: Lens' ([Member], [BotMember]) [BotMember]
botsL = _2 botsL = _2
updateConversationReceiptModeH :: UserId ::: ConnId ::: ConvId ::: JsonRequest P ublic.ConversationReceiptModeUpdate ::: JSON -> Galley Response updateConversationReceiptModeH :: UserId ::: ConnId ::: ConvId ::: JsonRequest P ublic.ConversationReceiptModeUpdate ::: JSON -> Galley Response
updateConversationReceiptModeH (usr ::: zcon ::: cnv ::: req ::: _) = do updateConversationReceiptModeH (usr ::: zcon ::: cnv ::: req ::: _) = do
update <- fromJsonBody req update <- fromJsonBody req
handleUpdateResult <$> updateConversationReceiptMode usr zcon cnv update handleUpdateResult <$> updateConversationReceiptMode usr zcon cnv update
updateConversationReceiptMode :: UserId -> ConnId -> ConvId -> Public.Conversati onReceiptModeUpdate -> Galley UpdateResult updateConversationReceiptMode :: UserId -> ConnId -> ConvId -> Public.Conversati onReceiptModeUpdate -> Galley UpdateResult
updateConversationReceiptMode usr zcon cnv receiptModeUpdate@(Public.Conversatio nReceiptModeUpdate target) = do updateConversationReceiptMode usr zcon cnv receiptModeUpdate@(Public.Conversatio nReceiptModeUpdate target) = do
(bots, users) <- botsAndUsers <$> Data.members cnv (bots, users) <- botsAndUsers =<< Data.members cnv
ensureActionAllowed ModifyConversationReceiptMode =<< getSelfMember usr users ensureActionAllowed ModifyConversationReceiptMode =<< getSelfMember usr users
current <- Data.lookupReceiptMode cnv current <- Data.lookupReceiptMode cnv
if current == Just target if current == Just target
then pure Unchanged then pure Unchanged
else Updated <$> update users bots else Updated <$> update users bots
where where
update users bots = do update users bots = do
-- Update Cassandra & send an event -- Update Cassandra & send an event
Data.updateConversationReceiptMode cnv target Data.updateConversationReceiptMode cnv target
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
skipping to change at line 295 skipping to change at line 302
pure receiptEvent pure receiptEvent
updateConversationMessageTimerH :: UserId ::: ConnId ::: ConvId ::: JsonRequest Public.ConversationMessageTimerUpdate -> Galley Response updateConversationMessageTimerH :: UserId ::: ConnId ::: ConvId ::: JsonRequest Public.ConversationMessageTimerUpdate -> Galley Response
updateConversationMessageTimerH (usr ::: zcon ::: cnv ::: req) = do updateConversationMessageTimerH (usr ::: zcon ::: cnv ::: req) = do
timerUpdate <- fromJsonBody req timerUpdate <- fromJsonBody req
handleUpdateResult <$> updateConversationMessageTimer usr zcon cnv timerUpdate handleUpdateResult <$> updateConversationMessageTimer usr zcon cnv timerUpdate
updateConversationMessageTimer :: UserId -> ConnId -> ConvId -> Public.Conversat ionMessageTimerUpdate -> Galley UpdateResult updateConversationMessageTimer :: UserId -> ConnId -> ConvId -> Public.Conversat ionMessageTimerUpdate -> Galley UpdateResult
updateConversationMessageTimer usr zcon cnv timerUpdate@(Public.ConversationMess ageTimerUpdate target) = do updateConversationMessageTimer usr zcon cnv timerUpdate@(Public.ConversationMess ageTimerUpdate target) = do
-- checks and balances -- checks and balances
(bots, users) <- botsAndUsers <$> Data.members cnv (bots, users) <- botsAndUsers =<< Data.members cnv
ensureActionAllowed ModifyConversationMessageTimer =<< getSelfMember usr users ensureActionAllowed ModifyConversationMessageTimer =<< getSelfMember usr users
conv <- Data.conversation cnv >>= ifNothing convNotFound conv <- Data.conversation cnv >>= ifNothing convNotFound
ensureGroupConv conv ensureGroupConv conv
let currentTimer = Data.convMessageTimer conv let currentTimer = Data.convMessageTimer conv
if currentTimer == target if currentTimer == target
then pure Unchanged then pure Unchanged
else Updated <$> update users bots else Updated <$> update users bots
where where
update users bots = do update users bots = do
-- update cassandra & send event -- update cassandra & send event
skipping to change at line 333 skipping to change at line 340
data AddCodeResult data AddCodeResult
= CodeAdded Public.Event = CodeAdded Public.Event
| CodeAlreadyExisted Public.ConversationCode | CodeAlreadyExisted Public.ConversationCode
addCode :: UserId -> ConnId -> ConvId -> Galley AddCodeResult addCode :: UserId -> ConnId -> ConvId -> Galley AddCodeResult
addCode usr zcon cnv = do addCode usr zcon cnv = do
conv <- Data.conversation cnv >>= ifNothing convNotFound conv <- Data.conversation cnv >>= ifNothing convNotFound
ensureConvMember (Data.convMembers conv) usr ensureConvMember (Data.convMembers conv) usr
ensureAccess conv CodeAccess ensureAccess conv CodeAccess
let (bots, users) = botsAndUsers $ Data.convMembers conv (bots, users) <- botsAndUsers $ Data.convMembers conv
key <- mkKey cnv key <- mkKey cnv
mCode <- Data.lookupCode key ReusableCode mCode <- Data.lookupCode key ReusableCode
case mCode of case mCode of
Nothing -> do Nothing -> do
code <- generate cnv ReusableCode (Timeout 3600 * 24 * 365) -- one year TO DO: configurable code <- generate cnv ReusableCode (Timeout 3600 * 24 * 365) -- one year TO DO: configurable
Data.insertCode code Data.insertCode code
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
conversationCode <- createCode code conversationCode <- createCode code
let event = Event ConvCodeUpdate cnv usr now (Just $ EdConvCodeUpdate conv ersationCode) let event = Event ConvCodeUpdate cnv usr now (Just $ EdConvCodeUpdate conv ersationCode)
pushEvent event users bots zcon pushEvent event users bots zcon
skipping to change at line 363 skipping to change at line 370
rmCodeH :: UserId ::: ConnId ::: ConvId -> Galley Response rmCodeH :: UserId ::: ConnId ::: ConvId -> Galley Response
rmCodeH (usr ::: zcon ::: cnv) = do rmCodeH (usr ::: zcon ::: cnv) = do
setStatus status200 . json <$> rmCode usr zcon cnv setStatus status200 . json <$> rmCode usr zcon cnv
rmCode :: UserId -> ConnId -> ConvId -> Galley Public.Event rmCode :: UserId -> ConnId -> ConvId -> Galley Public.Event
rmCode usr zcon cnv = do rmCode usr zcon cnv = do
conv <- Data.conversation cnv >>= ifNothing convNotFound conv <- Data.conversation cnv >>= ifNothing convNotFound
ensureConvMember (Data.convMembers conv) usr ensureConvMember (Data.convMembers conv) usr
ensureAccess conv CodeAccess ensureAccess conv CodeAccess
let (bots, users) = botsAndUsers $ Data.convMembers conv (bots, users) <- botsAndUsers $ Data.convMembers conv
key <- mkKey cnv key <- mkKey cnv
Data.deleteCode key ReusableCode Data.deleteCode key ReusableCode
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
let event = Event ConvCodeDelete cnv usr now Nothing let event = Event ConvCodeDelete cnv usr now Nothing
pushEvent event users bots zcon pushEvent event users bots zcon
pure event pure event
getCodeH :: UserId ::: ConvId -> Galley Response getCodeH :: UserId ::: ConvId -> Galley Response
getCodeH (usr ::: cnv) = do getCodeH (usr ::: cnv) = do
setStatus status200 . json <$> getCode usr cnv setStatus status200 . json <$> getCode usr cnv
skipping to change at line 430 skipping to change at line 437
joinConversationById :: UserId -> ConnId -> ConvId -> Galley UpdateResult joinConversationById :: UserId -> ConnId -> ConvId -> Galley UpdateResult
joinConversationById zusr zcon cnv = joinConversationById zusr zcon cnv =
joinConversation zusr zcon cnv LinkAccess joinConversation zusr zcon cnv LinkAccess
joinConversation :: UserId -> ConnId -> ConvId -> Access -> Galley UpdateResult joinConversation :: UserId -> ConnId -> ConvId -> Access -> Galley UpdateResult
joinConversation zusr zcon cnv access = do joinConversation zusr zcon cnv access = do
conv <- Data.conversation cnv >>= ifNothing convNotFound conv <- Data.conversation cnv >>= ifNothing convNotFound
ensureAccess conv access ensureAccess conv access
zusrMembership <- maybe (pure Nothing) (`Data.teamMember` zusr) (Data.convTeam conv) zusrMembership <- maybe (pure Nothing) (`Data.teamMember` zusr) (Data.convTeam conv)
ensureAccessRole (Data.convAccessRole conv) [(zusr, zusrMembership)] ensureAccessRole (Data.convAccessRole conv) [(zusr, zusrMembership)]
let newUsers = filter (notIsMember conv . makeIdOpaque) [zusr] let newUsers = filter (notIsMember conv . Local) [zusr]
ensureMemberLimit (toList $ Data.convMembers conv) (makeIdOpaque <$> newUsers) ensureMemberLimit (toList $ Data.convMembers conv) (Local <$> newUsers)
-- NOTE: When joining conversations, all users become members -- NOTE: When joining conversations, all users become members
-- as this is our desired behavior for these types of conversations -- as this is our desired behavior for these types of conversations
-- where there is no way to control who joins, etc. -- where there is no way to control who joins, etc.
addToConversation (botsAndUsers (Data.convMembers conv)) (zusr, roleNameWireMe mems <- botsAndUsers (Data.convMembers conv)
mber) zcon ((,roleNameWireMember) <$> newUsers) conv addToConversation mems (zusr, roleNameWireMember) zcon ((,roleNameWireMember)
<$> newUsers) conv
addMembersH :: UserId ::: ConnId ::: OpaqueConvId ::: JsonRequest Public.Invite -> Galley Response addMembersH :: UserId ::: ConnId ::: OpaqueConvId ::: JsonRequest Public.Invite -> Galley Response
addMembersH (zusr ::: zcon ::: cid ::: req) = do addMembersH (zusr ::: zcon ::: cid ::: req) = do
invite <- fromJsonBody req invite <- fromJsonBody req
handleUpdateResult <$> addMembers zusr zcon cid invite handleUpdateResult <$> addMembers zusr zcon cid invite
addMembers :: UserId -> ConnId -> OpaqueConvId -> Public.Invite -> Galley Update Result addMembers :: UserId -> ConnId -> OpaqueConvId -> Public.Invite -> Galley Update Result
addMembers zusr zcon cid invite = do addMembers zusr zcon cid invite = do
resolveOpaqueConvId cid >>= \case resolveOpaqueConvId cid >>= \case
Mapped idMapping -> Mapped idMapping ->
-- FUTUREWORK(federation): if the conversation is on another backend, send request there. -- FUTUREWORK(federation): if the conversation is on another backend, send request there.
-- in the case of a non-team conversation, we need to think about `ensureC onnectedOrSameTeam`, -- in the case of a non-team conversation, we need to think about `ensureC onnectedOrSameTeam`,
-- specifically whether teams from another backend than the conversation s hould have any -- specifically whether teams from another backend than the conversation s hould have any
-- relevance here. -- relevance here.
throwM . federationNotImplemented $ pure idMapping throwM . federationNotImplemented $ pure idMapping
Local localConvId -> Local localConvId ->
addMembersToLocalConv localConvId addMembersToLocalConv localConvId
where where
addMembersToLocalConv convId = do addMembersToLocalConv convId = do
conv <- Data.conversation convId >>= ifNothing convNotFound conv <- Data.conversation convId >>= ifNothing convNotFound
let mems = botsAndUsers (Data.convMembers conv) mems <- botsAndUsers (Data.convMembers conv)
self <- getSelfMember zusr (snd mems) self <- getSelfMember zusr (snd mems)
ensureActionAllowed AddConversationMember self ensureActionAllowed AddConversationMember self
toAdd <- fromMemberSize <$> checkedMemberAddSize (toList $ invUsers invite invitedUsers <- traverse resolveOpaqueUserId (toList $ invUsers invite)
) toAdd <- fromMemberSize <$> checkedMemberAddSize invitedUsers
let newOpaqueUsers = filter (notIsMember conv) (toList toAdd) let newUsers = filter (notIsMember conv) (toList toAdd)
ensureMemberLimit (toList $ Data.convMembers conv) newOpaqueUsers ensureMemberLimit (toList $ Data.convMembers conv) newUsers
ensureAccess conv InviteAccess ensureAccess conv InviteAccess
ensureConvRoleNotElevated self (invRoleName invite) ensureConvRoleNotElevated self (invRoleName invite)
(newUsers, newQualifiedUsers) <- partitionMappedOrLocalIds <$> traverse re solveOpaqueUserId newOpaqueUsers let (newLocalUsers, newQualifiedUsers) = partitionMappedOrLocalIds newUser s
-- FUTUREWORK(federation): allow adding remote members -- FUTUREWORK(federation): allow adding remote members
-- this one is a bit tricky because all of the checks that need to be done , -- this one is a bit tricky because all of the checks that need to be done ,
-- some of them on remote backends. -- some of them on remote backends.
for_ (nonEmpty newQualifiedUsers) $ for_ (nonEmpty newQualifiedUsers) $
throwM . federationNotImplemented throwM . federationNotImplemented
case Data.convTeam conv of case Data.convTeam conv of
Nothing -> do Nothing -> do
ensureAccessRole (Data.convAccessRole conv) (zip newUsers $ repeat Not ensureAccessRole (Data.convAccessRole conv) (zip newLocalUsers $ repea
hing) t Nothing)
ensureConnectedOrSameTeam zusr newUsers ensureConnectedOrSameTeam zusr newLocalUsers
Just ti -> teamConvChecks ti newUsers convId conv Just ti -> teamConvChecks ti newLocalUsers convId conv
addToConversation mems (zusr, memConvRoleName self) zcon ((,invRoleName in addToConversation mems (zusr, memConvRoleName self) zcon ((,invRoleName in
vite) <$> newUsers) conv vite) <$> newLocalUsers) conv
userIsMember u = (^. userId . to (== u)) userIsMember u = (^. userId . to (== u))
teamConvChecks tid newUsers convId conv = do teamConvChecks tid newLocalUsers convId conv = do
tms <- Data.teamMembersLimited tid newUsers tms <- Data.teamMembersLimited tid newLocalUsers
let userMembershipMap = map (\u -> (u, find (userIsMember u) tms)) newUser let userMembershipMap = map (\u -> (u, find (userIsMember u) tms)) newLoca
s lUsers
ensureAccessRole (Data.convAccessRole conv) userMembershipMap ensureAccessRole (Data.convAccessRole conv) userMembershipMap
tcv <- Data.teamConversation tid convId tcv <- Data.teamConversation tid convId
when (maybe True (view managedConversation) tcv) $ when (maybe True (view managedConversation) tcv) $
throwM noAddToManaged throwM noAddToManaged
ensureConnectedOrSameTeam zusr newUsers ensureConnectedOrSameTeam zusr newLocalUsers
updateSelfMemberH :: UserId ::: ConnId ::: ConvId ::: JsonRequest Public.MemberU pdate -> Galley Response updateSelfMemberH :: UserId ::: ConnId ::: ConvId ::: JsonRequest Public.MemberU pdate -> Galley Response
updateSelfMemberH (zusr ::: zcon ::: cid ::: req) = do updateSelfMemberH (zusr ::: zcon ::: cid ::: req) = do
update <- fromJsonBody req update <- fromJsonBody req
updateSelfMember zusr zcon cid update updateSelfMember zusr zcon cid update
return empty return empty
updateSelfMember :: UserId -> ConnId -> ConvId -> Public.MemberUpdate -> Galley () updateSelfMember :: UserId -> ConnId -> ConvId -> Public.MemberUpdate -> Galley ()
updateSelfMember zusr zcon cid update = do updateSelfMember zusr zcon cid update = do
conv <- getConversationAndCheckMembership zusr (Local cid) conv <- getConversationAndCheckMembership zusr (Local cid)
m <- getSelfMember zusr (Data.convMembers conv) m <- getSelfMember zusr (Data.convMembers conv)
-- Ensure no self role upgrades -- Ensure no self role upgrades
for_ (mupConvRoleName update) $ ensureConvRoleNotElevated m for_ (mupConvRoleName update) $ ensureConvRoleNotElevated m
void $ processUpdateMemberEvent zusr zcon cid [m] m update void $ processUpdateMemberEvent zusr zcon cid [Local <$> m] m update
updateOtherMemberH :: UserId ::: ConnId ::: ConvId ::: UserId ::: JsonRequest Pu blic.OtherMemberUpdate -> Galley Response updateOtherMemberH :: UserId ::: ConnId ::: ConvId ::: UserId ::: JsonRequest Pu blic.OtherMemberUpdate -> Galley Response
updateOtherMemberH (zusr ::: zcon ::: cid ::: victim ::: req) = do updateOtherMemberH (zusr ::: zcon ::: cid ::: victim ::: req) = do
update <- fromJsonBody req update <- fromJsonBody req
updateOtherMember zusr zcon cid victim update updateOtherMember zusr zcon cid victim update
return empty return empty
updateOtherMember :: UserId -> ConnId -> ConvId -> UserId -> Public.OtherMemberU pdate -> Galley () updateOtherMember :: UserId -> ConnId -> ConvId -> UserId -> Public.OtherMemberU pdate -> Galley ()
updateOtherMember zusr zcon cid victim update = do updateOtherMember zusr zcon cid victim update = do
when (zusr == victim) $ when (zusr == victim) $
throwM invalidTargetUserOp throwM invalidTargetUserOp
conv <- getConversationAndCheckMembership zusr (Local cid) conv <- getConversationAndCheckMembership zusr (Local cid)
let (bots, users) = botsAndUsers (Data.convMembers conv) (bots, users) <- botsAndUsers (Data.convMembers conv)
ensureActionAllowed ModifyOtherConversationMember =<< getSelfMember zusr users ensureActionAllowed ModifyOtherConversationMember =<< getSelfMember zusr users
memTarget <- getOtherMember victim users memTarget <- getOtherMember victim users
e <- processUpdateMemberEvent zusr zcon cid users memTarget (memberUpdate {mup ConvRoleName = omuConvRoleName update}) e <- processUpdateMemberEvent zusr zcon cid users memTarget (memberUpdate {mup ConvRoleName = omuConvRoleName update})
void . forkIO $ void $ External.deliver (bots `zip` repeat e) void . forkIO $ void $ External.deliver (bots `zip` repeat e)
removeMemberH :: UserId ::: ConnId ::: OpaqueConvId ::: OpaqueUserId -> Galley R esponse removeMemberH :: UserId ::: ConnId ::: OpaqueConvId ::: OpaqueUserId -> Galley R esponse
removeMemberH (zusr ::: zcon ::: cid ::: victim) = do removeMemberH (zusr ::: zcon ::: cid ::: victim) = do
handleUpdateResult <$> removeMember zusr zcon cid victim handleUpdateResult <$> removeMember zusr zcon cid victim
removeMember :: UserId -> ConnId -> OpaqueConvId -> OpaqueUserId -> Galley Updat eResult removeMember :: UserId -> ConnId -> OpaqueConvId -> OpaqueUserId -> Galley Updat eResult
removeMember zusr zcon cid victim = do removeMember zusr zcon cid opaqueVictim = do
resolveOpaqueConvId cid >>= \case resolveOpaqueConvId cid >>= \case
Mapped idMapping -> Mapped idMapping ->
-- FUTUREWORK(federation, #1274): forward request to conversation's backen d. -- FUTUREWORK(federation, #1274): forward request to conversation's backen d.
throwM . federationNotImplemented $ pure idMapping throwM . federationNotImplemented $ pure idMapping
Local localConvId -> Local localConvId -> do
removeMemberOfLocalConversation localConvId victim <- resolveOpaqueUserId opaqueVictim
removeMemberOfLocalConversation localConvId victim
where where
removeMemberOfLocalConversation convId = do removeMemberOfLocalConversation convId victim = do
conv <- Data.conversation convId >>= ifNothing convNotFound conv <- Data.conversation convId >>= ifNothing convNotFound
let (bots, users) = botsAndUsers (Data.convMembers conv) (bots, users) <- botsAndUsers (Data.convMembers conv)
genConvChecks conv users genConvChecks conv users victim
case Data.convTeam conv of case Data.convTeam conv of
Nothing -> pure () Nothing -> pure ()
Just ti -> teamConvChecks convId ti Just ti -> teamConvChecks convId ti
if victim `isMember` users if victim `isMember` users
then do then do
resolvedVictim <- resolveOpaqueUserId victim event <- Data.removeMembers conv zusr (singleton victim)
event <- Data.removeMembers conv zusr (singleton resolvedVictim) case victim of
case resolvedVictim of
Local _ -> pure () -- nothing to do Local _ -> pure () -- nothing to do
Mapped _ -> do Mapped _ -> do
-- FUTUREWORK(federation, #1274): users can be on other backend, h ow to notify it? -- FUTUREWORK(federation, #1274): users can be on other backend, h ow to notify it?
pure () pure ()
for_ (newPush ListComplete (evtFrom event) (ConvEvent event) (recipien t <$> users)) $ \p -> for_ (newPush ListComplete (evtFrom event) (ConvEvent event) (recipien t <$> users)) $ \p ->
push1 $ p & pushConn ?~ zcon push1 $ p & pushConn ?~ zcon
void . forkIO $ void $ External.deliver (bots `zip` repeat event) void . forkIO $ void $ External.deliver (bots `zip` repeat event)
pure $ Updated event pure $ Updated event
else pure Unchanged else pure Unchanged
genConvChecks conv usrs = do genConvChecks conv usrs victim = do
ensureGroupConv conv ensureGroupConv conv
if makeIdOpaque zusr == victim if Local zusr == victim
then ensureActionAllowed LeaveConversation =<< getSelfMember zusr usrs then ensureActionAllowed LeaveConversation =<< getSelfMember zusr usrs
else ensureActionAllowed RemoveConversationMember =<< getSelfMember zusr usrs else ensureActionAllowed RemoveConversationMember =<< getSelfMember zusr usrs
teamConvChecks convId tid = do teamConvChecks convId tid = do
tcv <- Data.teamConversation tid convId tcv <- Data.teamConversation tid convId
when (maybe False (view managedConversation) tcv) $ when (maybe False (view managedConversation) tcv) $
throwM (invalidOp "Users can not be removed from managed conversations." ) throwM (invalidOp "Users can not be removed from managed conversations." )
-- OTR -- OTR
data OtrResult data OtrResult
skipping to change at line 661 skipping to change at line 670
gone <- External.deliver toBots gone <- External.deliver toBots
mapM_ (deleteBot localConvId . botMemId) gone mapM_ (deleteBot localConvId . botMemId) gone
newMessage :: newMessage ::
UserId -> UserId ->
Maybe ConnId -> Maybe ConnId ->
-- | Conversation Id (if Nothing, recipient's self conversation is used) -- | Conversation Id (if Nothing, recipient's self conversation is used)
Maybe ConvId -> Maybe ConvId ->
NewOtrMessage -> NewOtrMessage ->
UTCTime -> UTCTime ->
(Member, ClientId, Text) -> (LocalMember, ClientId, Text) ->
([(BotMember, Event)], [Maybe Push]) -> ([(BotMember, Event)], [Maybe Push]) ->
([(BotMember, Event)], [Maybe Push]) ([(BotMember, Event)], [Maybe Push])
newMessage usr con cnv msg now (m, c, t) ~(toBots, toUsers) = newMessage usr con cnv msg now (m, c, t) ~(toBots, toUsers) =
let o = let o =
OtrMessage OtrMessage
{ otrSender = newOtrSender msg, { otrSender = newOtrSender msg,
otrRecipient = c, otrRecipient = c,
otrCiphertext = t, otrCiphertext = t,
otrData = newOtrData msg otrData = newOtrData msg
} }
conv = fromMaybe (selfConv $ memId m) cnv -- use recipient's client's self -- use recipient's client's self conversation on broadcast
conversation on broadcast -- (with federation, this might not work for remote members)
conv = fromMaybe (selfConv $ memId m) cnv
e = Event OtrMessageAdd conv usr now (Just $ EdOtrMessage o) e = Event OtrMessageAdd conv usr now (Just $ EdOtrMessage o)
r = recipient m & recipientClients .~ (RecipientClientsSome $ singleton c) r = recipient (Local <$> m) & recipientClients .~ (RecipientClientsSome $ singleton c)
in case newBotMember m of in case newBotMember m of
Just b -> ((b, e) : toBots, toUsers) Just b -> ((b, e) : toBots, toUsers)
Nothing -> Nothing ->
let p = let p =
newPush ListComplete (evtFrom e) (ConvEvent e) [r] newPush ListComplete (evtFrom e) (ConvEvent e) [r]
<&> set pushConn con <&> set pushConn con
. set pushNativePriority (newOtrNativePriority msg) . set pushNativePriority (newOtrNativePriority msg)
. set pushRoute (bool RouteDirect RouteAny (newOtrNativePush m sg)) . set pushRoute (bool RouteDirect RouteAny (newOtrNativePush m sg))
. set pushTransient (newOtrTransient msg) . set pushTransient (newOtrTransient msg)
in (toBots, p : toUsers) in (toBots, p : toUsers)
skipping to change at line 702 skipping to change at line 713
updateConversationNameH (zusr ::: zcon ::: cnv ::: req) = do updateConversationNameH (zusr ::: zcon ::: cnv ::: req) = do
convRename <- fromJsonBody req convRename <- fromJsonBody req
setStatus status200 . json <$> updateConversationName zusr zcon cnv convRename setStatus status200 . json <$> updateConversationName zusr zcon cnv convRename
updateConversationName :: UserId -> ConnId -> ConvId -> Public.ConversationRenam e -> Galley Public.Event updateConversationName :: UserId -> ConnId -> ConvId -> Public.ConversationRenam e -> Galley Public.Event
updateConversationName zusr zcon cnv convRename = do updateConversationName zusr zcon cnv convRename = do
alive <- Data.isConvAlive cnv alive <- Data.isConvAlive cnv
unless alive $ do unless alive $ do
Data.deleteConversation cnv Data.deleteConversation cnv
throwM convNotFound throwM convNotFound
(bots, users) <- botsAndUsers <$> Data.members cnv (bots, users) <- botsAndUsers =<< Data.members cnv
ensureActionAllowed ModifyConversationName =<< getSelfMember zusr users ensureActionAllowed ModifyConversationName =<< getSelfMember zusr users
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
cn <- rangeChecked (cupName convRename) cn <- rangeChecked (cupName convRename)
Data.updateConversation cnv cn Data.updateConversation cnv cn
let e = Event ConvRename cnv zusr now (Just $ EdConvRename convRename) let e = Event ConvRename cnv zusr now (Just $ EdConvRename convRename)
for_ (newPush ListComplete (evtFrom e) (ConvEvent e) (recipient <$> users)) $ \p -> for_ (newPush ListComplete (evtFrom e) (ConvEvent e) (recipient <$> users)) $ \p ->
push1 $ p & pushConn ?~ zcon push1 $ p & pushConn ?~ zcon
void . forkIO $ void $ External.deliver (bots `zip` repeat e) void . forkIO $ void $ External.deliver (bots `zip` repeat e)
return e return e
isTypingH :: UserId ::: ConnId ::: ConvId ::: JsonRequest Public.TypingData -> G alley Response isTypingH :: UserId ::: ConnId ::: ConvId ::: JsonRequest Public.TypingData -> G alley Response
isTypingH (zusr ::: zcon ::: cnv ::: req) = do isTypingH (zusr ::: zcon ::: cnv ::: req) = do
typingData <- fromJsonBody req typingData <- fromJsonBody req
isTyping zusr zcon cnv typingData isTyping zusr zcon cnv typingData
pure empty pure empty
isTyping :: UserId -> ConnId -> ConvId -> Public.TypingData -> Galley () isTyping :: UserId -> ConnId -> ConvId -> Public.TypingData -> Galley ()
isTyping zusr zcon cnv typingData = do isTyping zusr zcon cnv typingData = do
mm <- Data.members cnv mm <- Data.members cnv
unless (makeIdOpaque zusr `isMember` mm) $ unless (Local zusr `isMember` mm) $
throwM convNotFound throwM convNotFound
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
let e = Event Typing cnv zusr now (Just $ EdTyping typingData) let e = Event Typing cnv zusr now (Just $ EdTyping typingData)
for_ (newPush ListComplete (evtFrom e) (ConvEvent e) (recipient <$> mm)) $ \p -> for_ (newPush ListComplete (evtFrom e) (ConvEvent e) (recipient <$> mm)) $ \p ->
push1 $ push1 $
p p
& pushConn ?~ zcon & pushConn ?~ zcon
& pushRoute .~ RouteDirect & pushRoute .~ RouteDirect
& pushTransient .~ True & pushTransient .~ True
skipping to change at line 763 skipping to change at line 774
(bots, users) <- regularConvChecks c (bots, users) <- regularConvChecks c
t <- liftIO getCurrentTime t <- liftIO getCurrentTime
Data.updateClient True (botUserId (b ^. addBotId)) (b ^. addBotClient) Data.updateClient True (botUserId (b ^. addBotId)) (b ^. addBotClient)
(e, bm) <- Data.addBotMember zusr (b ^. addBotService) (b ^. addBotId) (b ^. a ddBotConv) t (e, bm) <- Data.addBotMember zusr (b ^. addBotService) (b ^. addBotId) (b ^. a ddBotConv) t
for_ (newPush ListComplete (evtFrom e) (ConvEvent e) (recipient <$> users)) $ \p -> for_ (newPush ListComplete (evtFrom e) (ConvEvent e) (recipient <$> users)) $ \p ->
push1 $ p & pushConn ?~ zcon push1 $ p & pushConn ?~ zcon
void . forkIO $ void $ External.deliver ((bm : bots) `zip` repeat e) void . forkIO $ void $ External.deliver ((bm : bots) `zip` repeat e)
pure e pure e
where where
regularConvChecks c = do regularConvChecks c = do
let (bots, users) = botsAndUsers (Data.convMembers c) (bots, users) <- botsAndUsers (Data.convMembers c)
unless (makeIdOpaque zusr `isMember` users) $ unless (Local zusr `isMember` users) $
throwM convNotFound throwM convNotFound
ensureGroupConv c ensureGroupConv c
ensureActionAllowed AddConversationMember =<< getSelfMember zusr users ensureActionAllowed AddConversationMember =<< getSelfMember zusr users
unless (any ((== b ^. addBotId) . botMemId) bots) $ unless (any ((== b ^. addBotId) . botMemId) bots) $
ensureMemberLimit (toList $ Data.convMembers c) [makeIdOpaque (botUserId (b ^. addBotId))] ensureMemberLimit (toList $ Data.convMembers c) [Local (botUserId (b ^. addBotId))]
return (bots, users) return (bots, users)
teamConvChecks cid tid = do teamConvChecks cid tid = do
tcv <- Data.teamConversation tid cid tcv <- Data.teamConversation tid cid
when (maybe True (view managedConversation) tcv) $ when (maybe True (view managedConversation) tcv) $
throwM noAddToManaged throwM noAddToManaged
rmBotH :: UserId ::: Maybe ConnId ::: JsonRequest RemoveBot -> Galley Response rmBotH :: UserId ::: Maybe ConnId ::: JsonRequest RemoveBot -> Galley Response
rmBotH (zusr ::: zcon ::: req) = do rmBotH (zusr ::: zcon ::: req) = do
bot <- fromJsonBody req bot <- fromJsonBody req
handleUpdateResult <$> rmBot zusr zcon bot handleUpdateResult <$> rmBot zusr zcon bot
rmBot :: UserId -> Maybe ConnId -> RemoveBot -> Galley UpdateResult rmBot :: UserId -> Maybe ConnId -> RemoveBot -> Galley UpdateResult
rmBot zusr zcon b = do rmBot zusr zcon b = do
c <- Data.conversation (b ^. rmBotConv) >>= ifNothing convNotFound c <- Data.conversation (b ^. rmBotConv) >>= ifNothing convNotFound
unless (makeIdOpaque zusr `isMember` Data.convMembers c) $ unless (Local zusr `isMember` Data.convMembers c) $
throwM convNotFound throwM convNotFound
let (bots, users) = botsAndUsers (Data.convMembers c) (bots, users) <- botsAndUsers (Data.convMembers c)
if not (any ((== b ^. rmBotId) . botMemId) bots) if not (any ((== b ^. rmBotId) . botMemId) bots)
then pure Unchanged then pure Unchanged
else do else do
t <- liftIO getCurrentTime t <- liftIO getCurrentTime
let evd = Just (EdMembersLeave (UserIdList [botUserId (b ^. rmBotId)])) let evd = Just (EdMembersLeave (UserIdList [botUserId (b ^. rmBotId)]))
let e = Event MemberLeave (Data.convId c) zusr t evd let e = Event MemberLeave (Data.convId c) zusr t evd
for_ (newPush ListComplete (evtFrom e) (ConvEvent e) (recipient <$> users) ) $ \p -> for_ (newPush ListComplete (evtFrom e) (ConvEvent e) (recipient <$> users) ) $ \p ->
push1 $ p & pushConn .~ zcon push1 $ p & pushConn .~ zcon
Data.removeMember (botUserId (b ^. rmBotId)) (Data.convId c) Data.removeMember (Local (botUserId (b ^. rmBotId))) (Data.convId c)
Data.eraseClients (botUserId (b ^. rmBotId)) Data.eraseClients (botUserId (b ^. rmBotId))
void . forkIO $ void $ External.deliver (bots `zip` repeat e) void . forkIO $ void $ External.deliver (bots `zip` repeat e)
pure $ Updated e pure $ Updated e
------------------------------------------------------------------------------- -------------------------------------------------------------------------------
-- Helpers -- Helpers
addToConversation :: ([BotMember], [Member]) -> (UserId, RoleName) -> ConnId -> [(UserId, RoleName)] -> Data.Conversation -> Galley UpdateResult addToConversation :: ([BotMember], [Member]) -> (UserId, RoleName) -> ConnId -> [(UserId, RoleName)] -> Data.Conversation -> Galley UpdateResult
addToConversation _ _ _ [] _ = pure Unchanged addToConversation _ _ _ [] _ = pure Unchanged
addToConversation (bots, others) (usr, usrRole) conn xs c = do addToConversation (bots, others) (usr, usrRole) conn xs c = do
skipping to change at line 823 skipping to change at line 834
void . forkIO $ void $ External.deliver (bots `zip` repeat e) void . forkIO $ void $ External.deliver (bots `zip` repeat e)
pure $ Updated e pure $ Updated e
ensureGroupConv :: MonadThrow m => Data.Conversation -> m () ensureGroupConv :: MonadThrow m => Data.Conversation -> m ()
ensureGroupConv c = case Data.convType c of ensureGroupConv c = case Data.convType c of
SelfConv -> throwM invalidSelfOp SelfConv -> throwM invalidSelfOp
One2OneConv -> throwM invalidOne2OneOp One2OneConv -> throwM invalidOne2OneOp
ConnectConv -> throwM invalidConnectOp ConnectConv -> throwM invalidConnectOp
_ -> return () _ -> return ()
ensureMemberLimit :: [Member] -> [OpaqueUserId] -> Galley () ensureMemberLimit :: [Member] -> [MappedOrLocalId Id.U] -> Galley ()
ensureMemberLimit old new = do ensureMemberLimit old new = do
o <- view options o <- view options
let maxSize = fromIntegral (o ^. optSettings . setMaxConvSize) let maxSize = fromIntegral (o ^. optSettings . setMaxConvSize)
when (length old + length new > maxSize) $ when (length old + length new > maxSize) $
throwM tooManyMembers throwM tooManyMembers
notIsMember :: Data.Conversation -> OpaqueUserId -> Bool notIsMember :: Data.Conversation -> MappedOrLocalId Id.U -> Bool
notIsMember cc u = not $ isMember u (Data.convMembers cc) notIsMember cc u = not $ isMember u (Data.convMembers cc)
ensureConvMember :: [Member] -> UserId -> Galley () ensureConvMember :: [Member] -> UserId -> Galley ()
ensureConvMember users usr = ensureConvMember users usr =
unless (makeIdOpaque usr `isMember` users) $ unless (Local usr `isMember` users) $
throwM convNotFound throwM convNotFound
ensureAccess :: Data.Conversation -> Access -> Galley () ensureAccess :: Data.Conversation -> Access -> Galley ()
ensureAccess conv access = ensureAccess conv access =
unless (access `elem` Data.convAccess conv) $ unless (access `elem` Data.convAccess conv) $
throwM convAccessDenied throwM convAccessDenied
applyMemUpdateChanges :: Member -> MemberUpdateData -> Member
applyMemUpdateChanges m u =
m
{ memOtrMuted = fromMaybe (memOtrMuted m) (misOtrMuted u),
memOtrMutedRef = misOtrMutedRef u <|> memOtrMutedRef m,
memOtrArchived = fromMaybe (memOtrArchived m) (misOtrArchived u),
memOtrArchivedRef = misOtrArchivedRef u <|> memOtrArchivedRef m,
memHidden = fromMaybe (memHidden m) (misHidden u),
memHiddenRef = misHiddenRef u <|> memHiddenRef m,
memConvRoleName = fromMaybe (memConvRoleName m) (misConvRoleName u)
}
processUpdateMemberEvent :: processUpdateMemberEvent ::
UserId -> UserId ->
ConnId -> ConnId ->
ConvId -> ConvId ->
[Member] -> [Member] ->
Member -> LocalMember ->
MemberUpdate -> MemberUpdate ->
Galley Event Galley Event
processUpdateMemberEvent zusr zcon cid users target update = do processUpdateMemberEvent zusr zcon cid users target update = do
up <- Data.updateMember cid (memId target) update up <- Data.updateMember cid (memId target) update
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
let e = Event MemberStateUpdate cid zusr now (Just $ EdMemberUpdate up) let e = Event MemberStateUpdate cid zusr now (Just $ EdMemberUpdate up)
let ms = applyMemUpdateChanges target up let recipients = fmap recipient ((Local <$> target) : filter ((/= Local (memId
for_ (newPush ListComplete (evtFrom e) (ConvEvent e) (recipient ms : fmap reci target)) . memId) users)
pient (delete target users))) $ \p -> for_ (newPush ListComplete (evtFrom e) (ConvEvent e) recipients) $ \p ->
push1 $ push1 $
p p
& pushConn ?~ zcon & pushConn ?~ zcon
& pushRoute .~ RouteDirect & pushRoute .~ RouteDirect
return e return e
------------------------------------------------------------------------------- -------------------------------------------------------------------------------
-- OtrRecipients Validation -- OtrRecipients Validation
data CheckedOtrRecipients data CheckedOtrRecipients
= -- | Valid sender (user and client) and no missing recipients, = -- | Valid sender (user and client) and no missing recipients,
-- or missing recipients have been willfully ignored. -- or missing recipients have been willfully ignored.
ValidOtrRecipients !ClientMismatch [(Member, ClientId, Text)] ValidOtrRecipients !ClientMismatch [(LocalMember, ClientId, Text)]
| -- | Missing recipients. | -- | Missing recipients.
MissingOtrRecipients !ClientMismatch MissingOtrRecipients !ClientMismatch
| -- | Invalid sender (user). | -- | Invalid sender (user).
InvalidOtrSenderUser InvalidOtrSenderUser
| -- | Invalid sender (client). | -- | Invalid sender (client).
InvalidOtrSenderClient InvalidOtrSenderClient
withValidOtrBroadcastRecipients :: withValidOtrBroadcastRecipients ::
UserId -> UserId ->
ClientId -> ClientId ->
OtrRecipients -> OtrRecipients ->
OtrFilterMissing -> OtrFilterMissing ->
UTCTime -> UTCTime ->
([(Member, ClientId, Text)] -> Galley ()) -> ([(LocalMember, ClientId, Text)] -> Galley ()) ->
Galley OtrResult Galley OtrResult
withValidOtrBroadcastRecipients usr clt rcps val now go = Teams.withBindingTeam usr $ \tid -> do withValidOtrBroadcastRecipients usr clt rcps val now go = Teams.withBindingTeam usr $ \tid -> do
limit <- fromIntegral . fromRange <$> fanoutLimit limit <- fromIntegral . fromRange <$> fanoutLimit
-- If we are going to fan this out to more than limit, we want to fail early -- If we are going to fan this out to more than limit, we want to fail early
unless ((Map.size $ userClientMap (otrRecipientsMap rcps)) <= limit) $ unless ((Map.size $ userClientMap (otrRecipientsMap rcps)) <= limit) $
throwM broadcastLimitExceeded throwM broadcastLimitExceeded
-- In large teams, we may still use the broadcast endpoint but only if `report _missing` -- In large teams, we may still use the broadcast endpoint but only if `report _missing`
-- is used and length `report_missing` < limit since we cannot fetch larger te ams than -- is used and length `report_missing` < limit since we cannot fetch larger te ams than
-- that. -- that.
tMembers <- fmap (view userId) <$> case val of tMembers <- fmap (view userId) <$> case val of
skipping to change at line 941 skipping to change at line 940
throwM broadcastLimitExceeded throwM broadcastLimitExceeded
pure (mems ^. teamMembers) pure (mems ^. teamMembers)
withValidOtrRecipients :: withValidOtrRecipients ::
UserId -> UserId ->
ClientId -> ClientId ->
ConvId -> ConvId ->
OtrRecipients -> OtrRecipients ->
OtrFilterMissing -> OtrFilterMissing ->
UTCTime -> UTCTime ->
([(Member, ClientId, Text)] -> Galley ()) -> ([(LocalMember, ClientId, Text)] -> Galley ()) ->
Galley OtrResult Galley OtrResult
withValidOtrRecipients usr clt cnv rcps val now go = do withValidOtrRecipients usr clt cnv rcps val now go = do
alive <- Data.isConvAlive cnv alive <- Data.isConvAlive cnv
unless alive $ do unless alive $ do
Data.deleteConversation cnv Data.deleteConversation cnv
throwM convNotFound throwM convNotFound
-- FUTUREWORK(federation): also handle remote members
membs <- Data.members cnv membs <- Data.members cnv
let memIds = (memId <$> membs) let localMembers = flip mapMaybe membs $ \memb ->
case memId memb of
Local localId -> Just (memb {memId = localId} :: LocalMember)
Mapped _ -> Nothing
let localMemberIds = memId <$> localMembers
isInternal <- view $ options . optSettings . setIntraListing isInternal <- view $ options . optSettings . setIntraListing
clts <- clts <-
if isInternal if isInternal
then Clients.fromUserClients <$> Intra.lookupClients memIds then Clients.fromUserClients <$> Intra.lookupClients localMemberIds
else Data.lookupClients memIds else Data.lookupClients localMemberIds
handleOtrResponse usr clt rcps membs clts val now go handleOtrResponse usr clt rcps localMembers clts val now go
handleOtrResponse :: handleOtrResponse ::
-- | Proposed sender (user) -- | Proposed sender (user)
UserId -> UserId ->
-- | Proposed sender (client) -- | Proposed sender (client)
ClientId -> ClientId ->
-- | Proposed recipients (users & clients). -- | Proposed recipients (users & clients).
OtrRecipients -> OtrRecipients ->
-- | Members to consider as valid recipients. -- | Members to consider as valid recipients.
[Member] -> [LocalMember] ->
-- | Clients to consider as valid recipients. -- | Clients to consider as valid recipients.
Clients -> Clients ->
-- | How to filter missing clients. -- | How to filter missing clients.
OtrFilterMissing -> OtrFilterMissing ->
-- | The current timestamp. -- | The current timestamp.
UTCTime -> UTCTime ->
-- | Callback if OtrRecipients are valid -- | Callback if OtrRecipients are valid
([(Member, ClientId, Text)] -> Galley ()) -> ([(LocalMember, ClientId, Text)] -> Galley ()) ->
Galley OtrResult Galley OtrResult
handleOtrResponse usr clt rcps membs clts val now go = case checkOtrRecipients u sr clt rcps membs clts val now of handleOtrResponse usr clt rcps membs clts val now go = case checkOtrRecipients u sr clt rcps membs clts val now of
ValidOtrRecipients m r -> go r >> pure (OtrSent m) ValidOtrRecipients m r -> go r >> pure (OtrSent m)
MissingOtrRecipients m -> pure (OtrMissingRecipients m) MissingOtrRecipients m -> pure (OtrMissingRecipients m)
InvalidOtrSenderUser -> throwM convNotFound InvalidOtrSenderUser -> throwM convNotFound
InvalidOtrSenderClient -> throwM unknownClient InvalidOtrSenderClient -> throwM unknownClient
-- | Check OTR sender and recipients for validity and completeness -- | Check OTR sender and recipients for validity and completeness
-- against a given list of valid members and clients, optionally -- against a given list of valid members and clients, optionally
-- ignoring missing clients. Returns 'ValidOtrRecipients' on success -- ignoring missing clients. Returns 'ValidOtrRecipients' on success
-- for further processing. -- for further processing.
checkOtrRecipients :: checkOtrRecipients ::
-- | Proposed sender (user) -- | Proposed sender (user)
UserId -> UserId ->
-- | Proposed sender (client) -- | Proposed sender (client)
ClientId -> ClientId ->
-- | Proposed recipients (users & clients). -- | Proposed recipients (users & clients).
OtrRecipients -> OtrRecipients ->
-- | Members to consider as valid recipients. -- | Members to consider as valid recipients.
[Member] -> [LocalMember] ->
-- | Clients to consider as valid recipients. -- | Clients to consider as valid recipients.
Clients -> Clients ->
-- | How to filter missing clients. -- | How to filter missing clients.
OtrFilterMissing -> OtrFilterMissing ->
-- | The current timestamp. -- | The current timestamp.
UTCTime -> UTCTime ->
CheckedOtrRecipients CheckedOtrRecipients
checkOtrRecipients (makeIdOpaque -> usr) sid prs vms vcs val now checkOtrRecipients (makeIdOpaque -> usr) sid prs vms vcs val now
| not (Map.member usr vmembers) = InvalidOtrSenderUser | not (Map.member usr vmembers) = InvalidOtrSenderUser
| not (Clients.contains usr sid vcs) = InvalidOtrSenderClient | not (Clients.contains usr sid vcs) = InvalidOtrSenderClient
| not (Clients.null missing) = MissingOtrRecipients mismatch | not (Clients.null missing) = MissingOtrRecipients mismatch
| otherwise = ValidOtrRecipients mismatch yield | otherwise = ValidOtrRecipients mismatch yield
where where
yield = foldrOtrRecipients next [] prs yield = foldrOtrRecipients next [] prs
next u c t rs next u c t rs
| Just m <- member u c = (m, c, t) : rs | Just m <- member u c = (m, c, t) : rs
| otherwise = rs | otherwise = rs
member :: OpaqueUserId -> ClientId -> Maybe Member member :: OpaqueUserId -> ClientId -> Maybe LocalMember
member u c member u c
| Just m <- Map.lookup u vmembers, | Just m <- Map.lookup u vmembers,
Clients.contains u c vclients = Clients.contains u c vclients =
Just m Just m
| otherwise = Nothing | otherwise = Nothing
-- Valid recipient members & clients -- Valid recipient members & clients
vmembers = Map.fromList $ map (\m -> (makeIdOpaque (memId m), m)) vms vmembers = Map.fromList $ map (\m -> (makeIdOpaque (memId m), m)) vms
vclients = Clients.rmClient usr sid vcs vclients = Clients.rmClient usr sid vcs
-- Proposed (given) recipients -- Proposed (given) recipients
recipients = userClientMap (otrRecipientsMap prs) recipients = userClientMap (otrRecipientsMap prs)
 End of changes. 56 change blocks. 
90 lines changed or deleted 93 lines changed or added

Home  |  About  |  Features  |  All  |  Newest  |  Dox  |  Diffs  |  RSS Feeds  |  Screenshots  |  Comments  |  Imprint  |  Privacy  |  HTTP(S)