dandri/simplex-chat
1
0 Fork 0
mirror of https://github.com/simplex-chat/simplex-chat.git synced 2026-10-23 15:03:16 +00:00
Code Issues Packages Projects Releases Wiki Activity

Merge branch 'stable'

Browse Source
This commit is contained in:
Evgeny Poberezkin committed 2026-06-06 21:18:42 +01:00
2 parents 79ac515f6c 5b93cb0e3f
commit adbffe2d1b
20 files changed
+988 -972
Download Patch File Download Diff File Expand all files Collapse all files

No files matched your search

src/Simplex/Chat/Library/Commands.hs
+320 -320
View File
File diff suppressed because it is too large. Load diff
src/Simplex/Chat/Library/Internal.hs
+103 -95
View File
@@ -473,12 +473,12 @@ deleteGroupCIs user gInfo chatScopeInfo items byGroupMember_ deletedTs = do
deleteCIFiles user ciFilesInfo
(errs, deletions) <- lift $ partitionEithers <$> withStoreBatch' (\db -> map (deleteItem db) items)
unless (null errs) $ toView $ CEvtChatErrors errs
vr <- chatVersionRange
cxt <- chatStoreCxt
deletions' <- case chatScopeInfo of
Nothing -> pure deletions
Just scopeInfo@GCSIMemberSupport {groupMember_} -> do
let decStats = countDeletedUnreadItems groupMember_ deletions
gInfo' <- withFastStore' $ \db -> updateGroupScopeUnreadStats db vr user gInfo scopeInfo decStats
gInfo' <- withFastStore' $ \db -> updateGroupScopeUnreadStats db cxt user gInfo scopeInfo decStats
pure $ map (updateDeletionGroupInfo gInfo') deletions
pure deletions'
where
@@ -687,7 +687,7 @@ acceptFileReceive user@User {userId} RcvFileTransfer {fileId, xftpRcvFile, fileI
unless (fileStatus == RFSNew) $ case fileStatus of
RFSCancelled _ -> throwChatError $ CEFileCancelled fName
_ -> throwChatError $ CEFileAlreadyReceiving fName
vr <- chatVersionRange
cxt <- chatStoreCxt
case (xftpRcvFile, fileConnReq) of
-- XFTP
(Just XFTPRcvFile {userApprovedRelays = approvedBeforeReady}, _) -> do
@@ -696,7 +696,7 @@ acceptFileReceive user@User {userId} RcvFileTransfer {fileId, xftpRcvFile, fileI
(ci, rfd) <- withStore $ \db -> do
-- marking file as accepted and reading description in the same transaction
-- to prevent race condition with appending description
ci <- xftpAcceptRcvFT db vr user fileId filePath userApproved
ci <- xftpAcceptRcvFT db cxt user fileId filePath userApproved
rfd <- getRcvFileDescrByRcvFileId db fileId
pure (ci, rfd)
receiveViaCompleteFD user fileId rfd userApproved cryptoArgs
@@ -707,10 +707,10 @@ acceptFileReceive user@User {userId} RcvFileTransfer {fileId, xftpRcvFile, fileI
chatRef <- withStore $ \db -> getChatRefByFileId db user fileId
case (chatRef, grpMemberId) of
(ChatRef CTDirect contactId _, Nothing) -> do
ct <- withStore $ \db -> getContact db vr user contactId
ct <- withStore $ \db -> getContact db cxt user contactId
acceptFile $ \msg -> void $ sendDirectContactMessage user ct msg
(ChatRef CTGroup groupId _, Just memId) -> do
GroupMember {activeConn} <- withStore $ \db -> getGroupMember db vr user groupId memId
GroupMember {activeConn} <- withStore $ \db -> getGroupMember db cxt user groupId memId
case activeConn of
Just conn -> do
acceptFile $ \msg -> void $ sendDirectMemberMessage conn msg groupId
@@ -721,12 +721,12 @@ acceptFileReceive user@User {userId} RcvFileTransfer {fileId, xftpRcvFile, fileI
acceptFile send = do
filePath <- getRcvFilePath fileId filePath_ fName True
inline <- receiveInline
vr <- chatVersionRange
cxt <- chatStoreCxt
if
| inline -> do
-- accepting inline
(ci, sharedMsgId) <- withStore $ \db ->
liftM2 (,) (acceptRcvInlineFT db vr user fileId filePath) (getSharedMsgIdByFileId db userId fileId)
liftM2 (,) (acceptRcvInlineFT db cxt user fileId filePath) (getSharedMsgIdByFileId db userId fileId)
send $ XFileAcptInv sharedMsgId Nothing fName
pure ci
| fileInline == Just IFMSent -> throwChatError $ CEFileAlreadyReceiving fName
@@ -802,13 +802,13 @@ getNetworkConfig = withAgent' $ liftIO . getFastNetworkConfig
resetRcvCIFileStatus :: User -> FileTransferId -> CIFileStatus 'MDRcv -> CM (Maybe AChatItem)
resetRcvCIFileStatus user fileId ciFileStatus = do
vr <- chatVersionRange
cxt <- chatStoreCxt
withStore $ \db -> do
liftIO $ do
updateCIFileStatus db user fileId ciFileStatus
updateRcvFileStatus db fileId FSNew
updateRcvFileAgentId db fileId Nothing
lookupChatItemByFileId db vr user fileId
lookupChatItemByFileId db cxt user fileId
receiveViaURI :: User -> FileDescriptionURI -> CryptoFile -> CM RcvFileTransfer
receiveViaURI user@User {userId} FileDescriptionURI {description} cf@CryptoFile {cryptoArgs} = do
@@ -826,11 +826,11 @@ receiveViaURI user@User {userId} FileDescriptionURI {description} cf@CryptoFile
startReceivingFile :: User -> FileTransferId -> CM ()
startReceivingFile user fileId = do
vr <- chatVersionRange
cxt <- chatStoreCxt
ci <- withStore $ \db -> do
liftIO $ updateRcvFileStatus db fileId FSConnected
liftIO $ updateCIFileStatus db user fileId $ CIFSRcvTransfer 0 1
getChatItemByFileId db vr user fileId
getChatItemByFileId db cxt user fileId
toView $ CEvtRcvFileStart user ci
getRcvFilePath :: FileTransferId -> Maybe FilePath -> String -> Bool -> CM FilePath
@@ -881,8 +881,8 @@ acceptContactRequest nm user@User {userId} UserContactRequest {agentInvitationId
subMode <- chatReadVar subscriptionMode
let pqSup = PQSupportOn
pqSup' = pqSup `CR.pqSupportAnd` pqSupport
vr <- chatVersionRange
let chatV = vr `peerConnChatVersion` cReqChatVRange
cxt <- chatStoreCxt
let chatV = vr cxt `peerConnChatVersion` cReqChatVRange
(ct, conn, incognitoProfile) <- case contactId_ of
Nothing -> do
incognitoProfile <- if incognito then Just . NewIncognito <$> liftIO generateRandomProfile else pure Nothing
@@ -891,7 +891,7 @@ acceptContactRequest nm user@User {userId} UserContactRequest {agentInvitationId
createContactFromRequest db user userContactLinkId_ connId chatV cReqChatVRange cName profileId cp xContactId incognitoProfile subMode pqSup' False
pure (ct, conn, incognitoProfile)
Just contactId -> do
ct <- withFastStore $ \db -> getContact db vr user contactId
ct <- withFastStore $ \db -> getContact db cxt user contactId
case contactConn ct of
Nothing -> do
incognitoProfile <- if incognito then Just . NewIncognito <$> liftIO generateRandomProfile else pure Nothing
@@ -917,15 +917,15 @@ acceptContactRequestAsync
incognitoProfile = do
subMode <- chatReadVar subscriptionMode
let profileToSend = userProfileDirect user (fromIncognitoProfile <$> incognitoProfile) (Just ct) True
vr <- chatVersionRange
let chatV = vr `peerConnChatVersion` cReqChatVRange
cxt <- chatStoreCxt
let chatV = vr cxt `peerConnChatVersion` cReqChatVRange
(cmdId, acId) <- agentAcceptContactAsync user True cReqInvId (XInfo profileToSend) subMode cReqPQSup chatV
currentTs <- liftIO getCurrentTime
withStore $ \db -> do
forM_ xContactId $ \xcId -> liftIO $ setContactAcceptedXContactId db ct xcId
Connection {connId} <- liftIO $ createAcceptedContactConn db user (Just uclId) contactId acId chatV cReqChatVRange cReqPQSup incognitoProfile subMode currentTs
liftIO $ setCommandConnId db user cmdId connId
getContact db vr user contactId
getContact db cxt user contactId
acceptGroupJoinRequestAsync :: User -> Int64 -> GroupInfo -> InvitationId -> VersionRangeChat -> Profile -> Maybe XContactId -> Maybe MemberId -> Maybe SharedMsgId -> GroupAcceptance -> GroupMemberRole -> Maybe IncognitoProfile -> Maybe MemberKey -> CM GroupMember
acceptGroupJoinRequestAsync
@@ -961,12 +961,12 @@ acceptGroupJoinRequestAsync
groupSize = Just currentMemCount
}
subMode <- chatReadVar subscriptionMode
vr <- chatVersionRange
let chatV = vr `peerConnChatVersion` cReqChatVRange
cxt <- chatStoreCxt
let chatV = vr cxt `peerConnChatVersion` cReqChatVRange
connIds <- agentAcceptContactAsync user True cReqInvId msg subMode PQSupportOff chatV
withStore $ \db -> do
liftIO $ createJoiningMemberConnection db user uclId connIds chatV cReqChatVRange groupMemberId subMode
getGroupMemberById db vr user groupMemberId
getGroupMemberById db cxt user groupMemberId
acceptGroupJoinSendRejectAsync :: User -> Int64 -> GroupInfo -> InvitationId -> VersionRangeChat -> Profile -> Maybe XContactId -> GroupRejectionReason -> CM GroupMember
acceptGroupJoinSendRejectAsync
@@ -991,12 +991,12 @@ acceptGroupJoinSendRejectAsync
rejectionReason
}
subMode <- chatReadVar subscriptionMode
vr <- chatVersionRange
let chatV = vr `peerConnChatVersion` cReqChatVRange
cxt <- chatStoreCxt
let chatV = vr cxt `peerConnChatVersion` cReqChatVRange
connIds <- agentAcceptContactAsync user False cReqInvId msg subMode PQSupportOff chatV
withStore $ \db -> do
liftIO $ createJoiningMemberConnection db user uclId connIds chatV cReqChatVRange groupMemberId subMode
getGroupMemberById db vr user groupMemberId
getGroupMemberById db cxt user groupMemberId
acceptBusinessJoinRequestAsync :: User -> Int64 -> GroupInfo -> GroupMember -> UserContactRequest -> CM (GroupInfo, GroupMember)
acceptBusinessJoinRequestAsync
@@ -1005,7 +1005,7 @@ acceptBusinessJoinRequestAsync
gInfo@GroupInfo {membership = GroupMember {memberRole = userRole, memberId = userMemberId}}
clientMember@GroupMember {groupMemberId, memberId}
UserContactRequest {agentInvitationId = AgentInvId cReqInvId, cReqChatVRange, xContactId} = do
vr <- chatVersionRange
cxt <- chatStoreCxt
let userProfile@Profile {displayName, preferences} = fromLocalProfile $ profile' user
-- TODO [short links] take groupPreferences from group info
groupPreferences = maybe defaultBusinessGroupPrefs businessGroupPrefs preferences
@@ -1024,7 +1024,7 @@ acceptBusinessJoinRequestAsync
groupSize = Just 1
}
subMode <- chatReadVar subscriptionMode
let chatV = vr `peerConnChatVersion` cReqChatVRange
let chatV = vr cxt `peerConnChatVersion` cReqChatVRange
connIds <- agentAcceptContactAsync user True cReqInvId msg subMode PQSupportOff chatV
withStore' $ \db -> do
forM_ xContactId $ \xcId -> setBusinessChatAcceptedXContactId db gInfo xcId
@@ -1048,28 +1048,28 @@ acceptRelayJoinRequestAsync
-- TODO [channel web] derive RelayCapabilities from relay config (RelayWebOptions)
let msg = XGrpRelayAcpt relayLink defaultRelayCapabilities
subMode <- chatReadVar subscriptionMode
vr <- chatVersionRange
let chatV = vr `peerConnChatVersion` cReqChatVRange
cxt <- chatStoreCxt
let chatV = vr cxt `peerConnChatVersion` cReqChatVRange
connIds <- agentAcceptContactAsync user True cReqInvId msg subMode PQSupportOff chatV
withStore $ \db -> do
liftIO $ createJoiningMemberConnection db user uclId connIds chatV cReqChatVRange groupMemberId subMode
gInfo' <- liftIO $ updateRelayOwnStatusFromTo db gInfo RSInvited RSAccepted
ownerMember' <- getGroupMemberById db vr user groupMemberId
ownerMember' <- getGroupMemberById db cxt user groupMemberId
pure (gInfo', ownerMember')
rejectRelayInvitationAsync
:: User
-> Int64
-> VersionRangeChat
-> StoreCxt
-> GroupRelayInvitation
-> InvitationId
-> VersionRangeChat
-> Int64
-> RelayRejectionReason
-> CM ()
rejectRelayInvitationAsync user uclId vr groupRelayInv invId reqChatVRange initialDelay reason = do
rejectRelayInvitationAsync user uclId cxt groupRelayInv invId reqChatVRange initialDelay reason = do
(_gInfo, ownerMember) <- withStore $ \db ->
createRelayRequestGroup db vr user groupRelayInv invId reqChatVRange initialDelay GSMemInvited RSRejected
createRelayRequestGroup db cxt user groupRelayInv invId reqChatVRange initialDelay GSMemInvited RSRejected
let GroupMember {groupMemberId} = ownerMember
msg = XGrpRelayReject reason
subMode <- chatReadVar subscriptionMode
@@ -1083,15 +1083,15 @@ businessGroupProfile :: Profile -> GroupPreferences -> GroupProfile
businessGroupProfile Profile {displayName, fullName, shortDescr, image} groupPreferences =
GroupProfile {displayName, fullName, description = Nothing, shortDescr, image, publicGroup = Nothing, groupPreferences = Just groupPreferences, memberAdmission = Nothing}
introduceToModerators :: VersionRangeChat -> User -> GroupInfo -> GroupMember -> CM ()
introduceToModerators vr user gInfo@GroupInfo {groupId} m@GroupMember {memberRole, memberId} = do
introduceToModerators :: StoreCxt -> User -> GroupInfo -> GroupMember -> CM ()
introduceToModerators cxt user gInfo@GroupInfo {groupId} m@GroupMember {memberRole, memberId} = do
forM_ (memberConn m) $ \mConn -> do
let msg =
if maxVersion (memberChatVRange m) >= groupKnockingVersion
then XGrpLinkAcpt GAPendingReview memberRole memberId
else XMsgNew $ mcSimple (MCText pendingReviewMessage)
void $ sendDirectMemberMessage mConn msg groupId
modMs <- withStore' $ \db -> getGroupModerators db vr user gInfo
modMs <- withStore' $ \db -> getGroupModerators db cxt user gInfo
let rcpModMs = filter shouldIntroduceToMod modMs
introduceMember user gInfo m rcpModMs (Just $ MSMember $ memberId' m)
where
@@ -1101,15 +1101,15 @@ introduceToModerators vr user gInfo@GroupInfo {groupId} m@GroupMember {memberRol
&& groupMemberId' mem /= groupMemberId' m
&& maxVersion (memberChatVRange mem) >= groupKnockingVersion
introduceToAll :: VersionRangeChat -> User -> GroupInfo -> GroupMember -> CM ()
introduceToAll vr user gInfo m = do
(members, vector) <- withStore $ \db -> liftM2 (,) (liftIO $ getGroupMembers db vr user gInfo) (getMemberRelationsVector db m)
introduceToAll :: StoreCxt -> User -> GroupInfo -> GroupMember -> CM ()
introduceToAll cxt user gInfo m = do
(members, vector) <- withStore $ \db -> liftM2 (,) (liftIO $ getGroupMembers db cxt user gInfo) (getMemberRelationsVector db m)
let recipients = filter (shouldIntroduce m vector) members
introduceMember user gInfo m recipients Nothing
introduceToRemaining :: VersionRangeChat -> User -> GroupInfo -> GroupMember -> CM ()
introduceToRemaining vr user gInfo m = do
(members, vector) <- withStore $ \db -> liftM2 (,) (liftIO $ getGroupMembers db vr user gInfo) (getMemberRelationsVector db m)
introduceToRemaining :: StoreCxt -> User -> GroupInfo -> GroupMember -> CM ()
introduceToRemaining cxt user gInfo m = do
(members, vector) <- withStore $ \db -> liftM2 (,) (liftIO $ getGroupMembers db cxt user gInfo) (getMemberRelationsVector db m)
let recipients = filter (shouldIntroduce m vector) members
introduceMember user gInfo m recipients Nothing
@@ -1163,10 +1163,10 @@ memberIntroEvt gInfo reMember =
-- Used in groups with relays to introduce moderators and above to a new member,
-- and to announce the new member to moderators and above.
-- This doesn't create introduction records in db, compared to above methods.
introduceInChannel :: VersionRangeChat -> User -> GroupInfo -> GroupMember -> CM ()
introduceInChannel :: StoreCxt -> User -> GroupInfo -> GroupMember -> CM ()
introduceInChannel _ _ _ GroupMember {activeConn = Nothing} = throwChatError $ CEInternalError "member connection not active"
introduceInChannel vr user gInfo subscriber@GroupMember {activeConn = Just conn, indexInGroup = subscriberIdx} = do
modMs <- withStore' $ \db -> getGroupModerators db vr user gInfo
introduceInChannel cxt user gInfo subscriber@GroupMember {activeConn = Just conn, indexInGroup = subscriberIdx} = do
modMs <- withStore' $ \db -> getGroupModerators db cxt user gInfo
void $ sendGroupMessage' user gInfo modMs $ XGrpMemNew (memberInfo gInfo subscriber) Nothing
withStore' $ \db ->
setMemberVectorNewRelations db subscriber [(indexInGroup m, (IDSubjectIntroduced, MRIntroduced)) | m <- modMs]
@@ -1329,9 +1329,9 @@ setGroupLinkData' nm user gInfo =
setGroupLinkData :: NetworkRequestMode -> User -> GroupInfo -> GroupLink -> CM GroupLink
setGroupLinkData nm user gInfo gLink = do
vr <- chatVersionRange
cxt <- chatStoreCxt
(conn, groupRelays) <- withFastStore $ \db ->
(,) <$> getGroupLinkConnection db vr user gInfo <*> liftIO (getConnectedGroupRelays db gInfo)
(,) <$> getGroupLinkConnection db cxt user gInfo <*> liftIO (getConnectedGroupRelays db gInfo)
let (userLinkData, crClientData) = groupLinkData gInfo gLink groupRelays
linkType = if useRelays' gInfo then CCTChannel else CCTGroup
sLnk <- shortenShortLink' . setShortLinkType_ linkType =<< withAgent (\a -> setConnShortLink a nm (aConnId conn) SCMContact userLinkData (Just crClientData))
@@ -1339,17 +1339,17 @@ setGroupLinkData nm user gInfo gLink = do
setGroupLinkDataAsync :: User -> GroupInfo -> GroupLink -> CM ()
setGroupLinkDataAsync user gInfo gLink = do
vr <- chatVersionRange
cxt <- chatStoreCxt
(conn, groupRelays) <- withStore $ \db ->
(,) <$> getGroupLinkConnection db vr user gInfo <*> liftIO (getConnectedGroupRelays db gInfo)
(,) <$> getGroupLinkConnection db cxt user gInfo <*> liftIO (getConnectedGroupRelays db gInfo)
let (userLinkData, crClientData) = groupLinkData gInfo gLink groupRelays
setAgentConnShortLinkAsync user conn userLinkData (Just crClientData)
connectToRelayAsync :: User -> GroupInfo -> ShortLinkContact -> CM ()
connectToRelayAsync user gInfo relayLink = do
vr <- chatVersionRange
cxt <- chatStoreCxt
gVar <- asks random
relayMember@GroupMember {activeConn} <- withFastStore $ \db -> getCreateRelayForMember db vr gVar user gInfo relayLink
relayMember@GroupMember {activeConn} <- withFastStore $ \db -> getCreateRelayForMember db cxt gVar user gInfo relayLink
case activeConn of
Just _ -> pure ()
Nothing -> do
@@ -1360,9 +1360,9 @@ connectToRelayAsync user gInfo relayLink = do
updatePublicGroupData :: User -> GroupInfo -> CM GroupInfo
updatePublicGroupData user gInfo
| useRelays' gInfo && memberRole' (membership gInfo) == GROwner = do
vr <- chatVersionRange
cxt <- chatStoreCxt
(gInfo', gLink) <- withStore $ \db -> do
gInfo' <- updatePublicMemberCount db vr user gInfo
gInfo' <- updatePublicMemberCount db cxt user gInfo
gLink <- getGroupLink db user gInfo'
pure (gInfo', gLink)
setGroupLinkDataAsync user gInfo' gLink
@@ -1372,12 +1372,12 @@ updatePublicGroupData user gInfo
updateGroupFromLinkData :: User -> GroupInfo -> GroupShortLinkData -> CM (GroupInfo, Bool)
updateGroupFromLinkData user gInfo@GroupInfo {groupProfile = p, groupSummary = GroupSummary {publicMemberCount = localCount}} GroupShortLinkData {groupProfile, publicGroupData}
| profileChanged || countChanged = do
vr <- chatVersionRange
cxt <- chatStoreCxt
withStore $ \db -> do
g <- if profileChanged then updateGroupProfile db user gInfo groupProfile else pure gInfo
g' <- case publicGroupData of
Just PublicGroupData {publicMemberCount} | countChanged ->
setPublicMemberCount db vr user g publicMemberCount
setPublicMemberCount db cxt user g publicMemberCount
_ -> pure g
pure (g', profileChanged)
| otherwise = pure (gInfo, False)
@@ -1456,14 +1456,14 @@ shortenCreatedLink (CCLink cReq sLnk) = CCLink cReq <$> mapM shortenShortLink' s
deleteGroupLink' :: User -> GroupInfo -> CM ()
deleteGroupLink' user gInfo = do
vr <- chatVersionRange
conn <- withStore $ \db -> getGroupLinkConnection db vr user gInfo
cxt <- chatStoreCxt
conn <- withStore $ \db -> getGroupLinkConnection db cxt user gInfo
deleteGroupLink_ user gInfo conn
deleteGroupLinkIfExists :: User -> GroupInfo -> CM ()
deleteGroupLinkIfExists user gInfo = do
vr <- chatVersionRange
conn_ <- eitherToMaybe <$> withStore' (\db -> runExceptT $ getGroupLinkConnection db vr user gInfo)
cxt <- chatStoreCxt
conn_ <- eitherToMaybe <$> withStore' (\db -> runExceptT $ getGroupLinkConnection db cxt user gInfo)
mapM_ (deleteGroupLink_ user gInfo) conn_
deleteGroupLink_ :: User -> GroupInfo -> Connection -> CM ()
@@ -1498,16 +1498,16 @@ deleteTimedItem user (ChatRef cType chatId scope, itemId) deleteAt = do
ts <- liftIO getCurrentTime
liftIO $ threadDelay' $ diffToMicroseconds $ diffUTCTime deleteAt ts
lift waitChatStartedAndActivated
vr <- chatVersionRange
cxt <- chatStoreCxt
case cType of
CTDirect -> do
(ct, ci) <- withStore $ \db -> (,) <$> getContact db vr user chatId <*> getDirectChatItem db user chatId itemId
(ct, ci) <- withStore $ \db -> (,) <$> getContact db cxt user chatId <*> getDirectChatItem db user chatId itemId
deletions <- deleteDirectCIs user ct [ci]
toView $ CEvtChatItemsDeleted user deletions True True
CTGroup -> do
(gInfo, ci) <- withStore $ \db -> (,) <$> getGroupInfo db vr user chatId <*> getGroupChatItem db user chatId itemId
(gInfo, ci) <- withStore $ \db -> (,) <$> getGroupInfo db cxt user chatId <*> getGroupChatItem db user chatId itemId
deletedTs <- liftIO getCurrentTime
chatScopeInfo <- mapM (getChatScopeInfo vr user) scope
chatScopeInfo <- mapM (getChatScopeInfo cxt user) scope
deletions <- deleteGroupCIs user gInfo chatScopeInfo [ci] Nothing deletedTs
toView $ CEvtChatItemsDeleted user deletions True True
_ -> eToView $ ChatError $ CEInternalError "bad deleteTimedItem cType"
@@ -1624,25 +1624,25 @@ parseChatMessage conn s = do
errType = CEInvalidChatMessage conn Nothing (safeDecodeUtf8 s)
{-# INLINE parseChatMessage #-}
getChatScopeInfo :: VersionRangeChat -> User -> GroupChatScope -> CM GroupChatScopeInfo
getChatScopeInfo vr user = \case
getChatScopeInfo :: StoreCxt -> User -> GroupChatScope -> CM GroupChatScopeInfo
getChatScopeInfo cxt user = \case
GCSMemberSupport Nothing -> pure $ GCSIMemberSupport Nothing
GCSMemberSupport (Just gmId) -> do
supportMem <- withFastStore $ \db -> getGroupMemberById db vr user gmId
supportMem <- withFastStore $ \db -> getGroupMemberById db cxt user gmId
pure $ GCSIMemberSupport (Just supportMem)
getGroupRecipients :: VersionRangeChat -> User -> GroupInfo -> Maybe GroupChatScopeInfo -> VersionChat -> CM [GroupMember]
getGroupRecipients vr user gInfo@GroupInfo {membership} scopeInfo modsCompatVersion
getGroupRecipients :: StoreCxt -> User -> GroupInfo -> Maybe GroupChatScopeInfo -> VersionChat -> CM [GroupMember]
getGroupRecipients cxt user gInfo@GroupInfo {membership} scopeInfo modsCompatVersion
| useRelays' gInfo && not (isRelay membership) = do
unless (memberCurrent membership && memberActive membership) $ throwChatError $ CECommandError "not current member"
withFastStore' $ \db -> getGroupRelayMembers db vr user gInfo
withFastStore' $ \db -> getGroupRelayMembers db cxt user gInfo
| otherwise = case scopeInfo of
Nothing -> do
unless (memberCurrent membership && memberActive membership) $ throwChatError $ CECommandError "not current member"
ms <- withFastStore' $ \db -> getGroupMembers db vr user gInfo
ms <- withFastStore' $ \db -> getGroupMembers db cxt user gInfo
pure $ filter memberCurrent ms
Just (GCSIMemberSupport Nothing) -> do
modMs <- withFastStore' $ \db -> getGroupModerators db vr user gInfo
modMs <- withFastStore' $ \db -> getGroupModerators db cxt user gInfo
let rcpModMs' = filter (\m -> compatible m && memberCurrent m) modMs
when (null rcpModMs') $ throwChatError $ CECommandError "no admins support this message"
pure rcpModMs'
@@ -1652,7 +1652,7 @@ getGroupRecipients vr user gInfo@GroupInfo {membership} scopeInfo modsCompatVers
if memberStatus supportMem == GSMemPendingApproval
then pure [supportMem]
else do
modMs <- withFastStore' $ \db -> getGroupModerators db vr user gInfo
modMs <- withFastStore' $ \db -> getGroupModerators db cxt user gInfo
let rcpModMs' = filter (\m -> compatible m && memberCurrent m) modMs
pure $ [supportMem] <> rcpModMs'
where
@@ -1678,8 +1678,8 @@ mkGroupChatScope gInfo@GroupInfo {membership} m
| otherwise =
pure (gInfo, m, Nothing)
mkGetMessageChatScope :: VersionRangeChat -> User -> GroupInfo -> GroupMember -> MsgContent -> Maybe MsgScope -> CM (GroupInfo, GroupMember, Maybe GroupChatScopeInfo)
mkGetMessageChatScope vr user gInfo@GroupInfo {membership} m mc msgScope_ =
mkGetMessageChatScope :: StoreCxt -> User -> GroupInfo -> GroupMember -> MsgContent -> Maybe MsgScope -> CM (GroupInfo, GroupMember, Maybe GroupChatScopeInfo)
mkGetMessageChatScope cxt user gInfo@GroupInfo {membership} m mc msgScope_ =
mkGroupChatScope gInfo m >>= \case
groupScope@(_gInfo', _m', Just _scopeInfo) -> pure groupScope
(_, _, Nothing)
@@ -1694,7 +1694,7 @@ mkGetMessageChatScope vr user gInfo@GroupInfo {membership} m mc msgScope_ =
(gInfo', scopeInfo) <- mkGroupSupportChatInfo gInfo
pure (gInfo', m, Just scopeInfo)
| otherwise -> do
referredMember <- withStore $ \db -> getGroupMemberByMemberId db vr user gInfo mId
referredMember <- withStore $ \db -> getGroupMemberByMemberId db cxt user gInfo mId
-- TODO [knocking] return patched _referredMember'?
(_referredMember', scopeInfo) <- mkMemberSupportChatInfo referredMember
pure (gInfo, m, Just scopeInfo)
@@ -1808,8 +1808,8 @@ cancelSndFileTransfer user@User {userId} ft@SndFileTransfer {fileId, connId, fil
withStore' $ \db -> updateSndFileStatus db ft FSCancelled
when sendCancel $ case fileInline of
Just _ -> do
vr <- chatVersionRange
(sharedMsgId, conn) <- withStore $ \db -> (,) <$> getSharedMsgIdByFileId db userId fileId <*> getConnectionById db vr user connId
cxt <- chatStoreCxt
(sharedMsgId, conn) <- withStore $ \db -> (,) <$> getSharedMsgIdByFileId db userId fileId <*> getConnectionById db cxt user connId
void $ sendDirectMessage_ conn (BFileChunk sharedMsgId FileChunkCancel) (ConnectionId connId)
_ -> throwChatError $ CEException "cancelSndFileTransfer: cancelling file via a separate connection is deprecated"
@@ -2008,13 +2008,13 @@ batchSndMessagesJSON mode = batchMessages mode maxEncodedMsgLength . L.toList
encodeConnInfo :: MsgEncodingI e => ChatMsgEvent e -> CM ByteString
encodeConnInfo chatMsgEvent = do
vr <- chatVersionRange
encodeConnInfoPQ PQSupportOff (maxVersion vr) chatMsgEvent
cxt <- chatStoreCxt
encodeConnInfoPQ PQSupportOff (maxVersion (vr cxt)) chatMsgEvent
encodeConnInfoPQ :: MsgEncodingI e => PQSupport -> VersionChat -> ChatMsgEvent e -> CM ByteString
encodeConnInfoPQ pqSup v chatMsgEvent = do
vr <- chatVersionRange
let info = ChatMessage {chatVRange = vr, msgId = Nothing, chatMsgEvent}
cxt <- chatStoreCxt
let info = ChatMessage {chatVRange = vr cxt, msgId = Nothing, chatMsgEvent}
case encodeChatMessage maxEncodedInfoLength info of
ECMEncoded connInfo -> case pqSup of
PQSupportOn | v >= pqEncryptionCompressionVersion && B.length connInfo > maxCompressedInfoLength -> do
@@ -2328,8 +2328,8 @@ saveGroupRcvMsg user groupId authorMember conn@Connection {connId} agentMsgMeta
withStore (\db -> createNewMessageAndRcvMsgDelivery db (GroupId groupId) newMsg sharedMsgId_ rcvMsgDelivery $ Just amGroupMemId)
`catchAllErrors` \e -> case e of
ChatErrorStore (SEDuplicateGroupMessage _ _ _ (Just forwardedByGroupMemberId)) -> do
vr <- chatVersionRange
fm <- withStore $ \db -> getGroupMember db vr user groupId forwardedByGroupMemberId
cxt <- chatStoreCxt
fm <- withStore $ \db -> getGroupMember db cxt user groupId forwardedByGroupMemberId
forM_ (memberConn fm) $ \fmConn ->
void $ sendDirectMemberMessage fmConn (XGrpMemCon amMemId) groupId
throwError e
@@ -2349,8 +2349,8 @@ saveGroupFwdRcvMsg user gInfo@GroupInfo {groupId} forwardingMember refAuthorMemb
| useRelays' gInfo -> pure Nothing -- with chat relays, duplicates are expected
| otherwise -> case (authorGroupMemberId, forwardedByGroupMemberId) of
(Just authorGMId, Nothing) -> do
vr <- chatVersionRange
am@GroupMember {memberId = amMemberId} <- withStore $ \db -> getGroupMember db vr user groupId authorGMId
cxt <- chatStoreCxt
am@GroupMember {memberId = amMemberId} <- withStore $ \db -> getGroupMember db cxt user groupId authorGMId
if maybe False (\ref -> sameMemberId (memberId' ref) am) refAuthorMember_
then forM_ (memberConn forwardingMember) $ \fmConn ->
void $ sendDirectMemberMessage fmConn (XGrpMemCon amMemberId) groupId
@@ -2392,9 +2392,9 @@ saveSndChatItems ::
CM [Either ChatError (ChatItem c 'MDSnd)]
saveSndChatItems user cd showGroupAsSender itemsData itemTimed live = do
createdAt <- liftIO getCurrentTime
vr <- chatVersionRange
cxt <- chatStoreCxt
when (contactChatDeleted cd || any (\NewSndChatItemData {content} -> ciRequiresAttention content) (rights itemsData)) $
void (withStore' $ \db -> updateChatTsStats db vr user cd createdAt Nothing)
void (withStore' $ \db -> updateChatTsStats db cxt user cd createdAt Nothing)
lift $ withStoreBatch (\db -> map (bindRight $ createItem db createdAt) itemsData)
where
createItem :: DB.Connection -> UTCTime -> NewSndChatItemData c -> IO (Either ChatError (ChatItem c 'MDSnd))
@@ -2420,14 +2420,14 @@ ciContentNoParse content = (content, (ciContentToText content, Nothing))
saveRcvChatItem' :: (ChatTypeI c, ChatTypeQuotable c) => User -> ChatDirection c 'MDRcv -> RcvMessage -> Maybe SharedMsgId -> UTCTime -> (CIContent 'MDRcv, (Text, Maybe MarkdownList)) -> Maybe (CIFile 'MDRcv) -> Maybe CITimed -> Bool -> Map MemberName MsgMention -> CM (ChatItem c 'MDRcv, ChatInfo c)
saveRcvChatItem' user cd msg@RcvMessage {chatMsgEvent, msgSigned, forwardedByMember} sharedMsgId_ brokerTs (content, (t, ft_)) ciFile itemTimed live mentions = do
createdAt <- liftIO getCurrentTime
vr <- chatVersionRange
cxt <- chatStoreCxt
withStore' $ \db -> do
(mentions' :: Map MemberName CIMention, userMention) <- case toChatInfo cd of
GroupChat g@GroupInfo {membership} _ -> groupMentions db g membership
_ -> pure (M.empty, False)
cInfo' <-
if (ciRequiresAttention content || contactChatDeleted cd)
then updateChatTsStats db vr user cd createdAt (memberChatStats userMention)
then updateChatTsStats db cxt user cd createdAt (memberChatStats userMention)
else pure $ toChatInfo cd
let showAsGroup = case cd of CDChannelRcv {} -> True; _ -> False
hasLink_ = ciContentHasLink content ft_
@@ -2720,13 +2720,13 @@ createChatItems ::
createChatItems user itemTs_ dirsCIContents = do
createdAt <- liftIO getCurrentTime
let itemTs = fromMaybe createdAt itemTs_
vr <- chatVersionRange'
void . withStoreBatch' $ \db -> map (updateChat db vr createdAt) dirsCIContents
cxt <- chatStoreCxt'
void . withStoreBatch' $ \db -> map (updateChat db cxt createdAt) dirsCIContents
withStoreBatch' $ \db -> concatMap (createACIs db itemTs createdAt) dirsCIContents
where
updateChat :: DB.Connection -> VersionRangeChat -> UTCTime -> (ChatDirection c d, ShowGroupAsSender, [(CIContent d, Maybe SharedMsgId)]) -> IO ()
updateChat db vr createdAt (cd, _, contents)
| any (ciRequiresAttention . fst) contents || contactChatDeleted cd = void $ updateChatTsStats db vr user cd createdAt memberChatStats
updateChat :: DB.Connection -> StoreCxt -> UTCTime -> (ChatDirection c d, ShowGroupAsSender, [(CIContent d, Maybe SharedMsgId)]) -> IO ()
updateChat db cxt createdAt (cd, _, contents)
| any (ciRequiresAttention . fst) contents || contactChatDeleted cd = void $ updateChatTsStats db cxt user cd createdAt memberChatStats
| otherwise = pure ()
where
memberChatStats :: Maybe (Int, MemberAttention, Int)
@@ -2765,8 +2765,8 @@ createLocalChatItems ::
UTCTime ->
CM [ChatItem 'CTLocal 'MDSnd]
createLocalChatItems user cd itemsData createdAt = do
vr <- chatVersionRange
void $ withStore' $ \db -> updateChatTsStats db vr user cd createdAt Nothing
cxt <- chatStoreCxt
void $ withStore' $ \db -> updateChatTsStats db cxt user cd createdAt Nothing
(errs, items) <- lift $ partitionEithers <$> withStoreBatch' (\db -> map (createItem db) $ L.toList itemsData)
unless (null errs) $ toView $ CEvtChatErrors errs
pure items
@@ -2816,6 +2816,14 @@ waitChatStartedAndActivated = do
activated <- readTVar chatActivated
unless (isJust started && activated) retry
chatStoreCxt :: CM StoreCxt
chatStoreCxt = lift chatStoreCxt'
{-# INLINE chatStoreCxt #-}
chatStoreCxt' :: CM' StoreCxt
chatStoreCxt' = mkStoreCxt <$> asks config
{-# INLINE chatStoreCxt' #-}
chatVersionRange :: CM VersionRangeChat
chatVersionRange = lift chatVersionRange'
{-# INLINE chatVersionRange #-}
src/Simplex/Chat/Library/Subscriber.hs
+127 -127
View File
@@ -117,10 +117,10 @@ processAgentMessage _ "" (ERR e) =
processAgentMessage corrId connId msg = do
lockEntity <- critical connId (withStore (`getChatLockEntity` AgentConnId connId))
withEntityLock "processAgentMessage" lockEntity $ do
vr <- chatVersionRange
cxt <- chatStoreCxt
-- getUserByAConnId never throws logical errors, only SEDBBusyError can be thrown here
critical connId (withStore' (`getUserByAConnId` AgentConnId connId)) >>= \case
Just user -> processAgentMessageConn vr user corrId connId msg `catchAllErrors` eToView
Just user -> processAgentMessageConn cxt user corrId connId msg `catchAllErrors` eToView
_ -> throwChatError $ CENoConnectionUser (AgentConnId connId)
-- CRITICAL error will be shown to the user as alert with restart button in Android/desktop apps.
@@ -182,27 +182,27 @@ processAgentMsgSndFile _corrId aFileId msg = do
process :: User -> FileTransferId -> CM ()
process user fileId = do
(ft@FileTransferMeta {xftpRedirectFor, cancelled}, sfts) <- withStore $ \db -> getSndFileTransfer db user fileId
vr <- chatVersionRange
cxt <- chatStoreCxt
unless cancelled $ case msg of
SFPROG sndProgress sndTotal -> do
let status = CIFSSndTransfer {sndProgress, sndTotal}
ci <- withStore $ \db -> do
liftIO $ updateCIFileStatus db user fileId status
lookupChatItemByFileId db vr user fileId
lookupChatItemByFileId db cxt user fileId
toView $ CEvtSndFileProgressXFTP user ci ft sndProgress sndTotal
SFDONE sndDescr rfds -> do
withStore' $ \db -> setSndFTPrivateSndDescr db user fileId (fileDescrText sndDescr)
ci <- withStore $ \db -> lookupChatItemByFileId db vr user fileId
ci <- withStore $ \db -> lookupChatItemByFileId db cxt user fileId
case ci of
Nothing -> do
lift $ withAgent' (`xftpDeleteSndFileInternal` aFileId)
withStore' $ \db -> createExtraSndFTDescrs db user fileId (map fileDescrText rfds)
case rfds of
[] -> sendFileError (FileErrOther "no receiver descriptions") "no receiver descriptions" vr ft
[] -> sendFileError (FileErrOther "no receiver descriptions") "no receiver descriptions" cxt ft
rfd : _ -> case [fd | fd@(FD.ValidFileDescription FD.FileDescription {chunks = [_]}) <- rfds] of
[] -> case xftpRedirectFor of
Nothing -> xftpSndFileRedirect user fileId rfd >>= toView . CEvtSndFileRedirectStartXFTP user ft
Just _ -> sendFileError (FileErrOther "chaining redirects") "Prohibit chaining redirects" vr ft
Just _ -> sendFileError (FileErrOther "chaining redirects") "Prohibit chaining redirects" cxt ft
rfds' -> do
-- we have 1 chunk - use it as URI whether it is redirect or not
ft' <- maybe (pure ft) (\fId -> withStore $ \db -> getFileTransferMeta db user fId) xftpRedirectFor
@@ -235,13 +235,13 @@ processAgentMsgSndFile _corrId aFileId msg = do
sendFileDescriptions (GroupId groupId) rfdsMemberFTs' sharedMsgId
ci' <- withStore $ \db -> do
liftIO $ updateCIFileStatus db user fileId CIFSSndComplete
getChatItemByFileId db vr user fileId
getChatItemByFileId db cxt user fileId
lift $ withAgent' (`xftpDeleteSndFileInternal` aFileId)
toView $ CEvtSndFileCompleteXFTP user ci' ft
where
getRecipients
| useRelays' g = withStore' $ \db -> getGroupRelayMembers db vr user g
| otherwise = withStore' $ \db -> getGroupMembers db vr user g
| useRelays' g = withStore' $ \db -> getGroupRelayMembers db cxt user g
| otherwise = withStore' $ \db -> getGroupMembers db cxt user g
memberFTs :: [GroupMember] -> [(Connection, SndFileTransfer)]
memberFTs ms = M.elems $ M.intersectionWith (,) (M.fromList mConns') (M.fromList sfts')
where
@@ -254,10 +254,10 @@ processAgentMsgSndFile _corrId aFileId msg = do
logWarn $ "Sent file warning: " <> err
ci <- withStore $ \db -> do
liftIO $ updateCIFileStatus db user fileId (CIFSSndWarning $ agentFileError e)
lookupChatItemByFileId db vr user fileId
lookupChatItemByFileId db cxt user fileId
toView $ CEvtSndFileWarning user ci ft err
SFERR e ->
sendFileError (agentFileError e) (tshow e) vr ft
sendFileError (agentFileError e) (tshow e) cxt ft
where
fileDescrText :: FilePartyI p => ValidFileDescription p -> T.Text
fileDescrText = safeDecodeUtf8 . strEncode
@@ -282,12 +282,12 @@ processAgentMsgSndFile _corrId aFileId msg = do
toMsgReq :: (Connection, (ConnOrGroupId, Maybe MsgSigning, ChatMsgEvent 'Json)) -> SndMessage -> ChatMsgReq
toMsgReq (conn, _) SndMessage {msgId, msgBody} =
(conn, MsgFlags {notification = hasNotification XMsgFileDescr_}, (vrValue msgBody, [msgId]))
sendFileError :: FileError -> Text -> VersionRangeChat -> FileTransferMeta -> CM ()
sendFileError ferr err vr ft = do
sendFileError :: FileError -> Text -> StoreCxt -> FileTransferMeta -> CM ()
sendFileError ferr err cxt ft = do
logError $ "Sent file error: " <> err
ci <- withStore $ \db -> do
liftIO $ updateFileCancelled db user fileId (CIFSSndError ferr)
lookupChatItemByFileId db vr user fileId
lookupChatItemByFileId db cxt user fileId
lift $ withAgent' (`xftpDeleteSndFileInternal` aFileId)
toView $ CEvtSndFileError user ci ft err
@@ -322,13 +322,13 @@ processAgentMsgRcvFile _corrId aFileId msg = do
process :: User -> FileTransferId -> CM ()
process user fileId = do
ft <- withStore $ \db -> getRcvFileTransfer db user fileId
vr <- chatVersionRange
cxt <- chatStoreCxt
unless (rcvFileCompleteOrCancelled ft) $ case msg of
RFPROG rcvProgress rcvTotal -> do
let status = CIFSRcvTransfer {rcvProgress, rcvTotal}
ci <- withStore $ \db -> do
liftIO $ updateCIFileStatus db user fileId status
lookupChatItemByFileId db vr user fileId
lookupChatItemByFileId db cxt user fileId
toView $ CEvtRcvFileProgressXFTP user ci rcvProgress rcvTotal ft
RFDONE xftpPath ->
case liveRcvFileTransferPath ft of
@@ -340,13 +340,13 @@ processAgentMsgRcvFile _corrId aFileId msg = do
liftIO $ do
updateRcvFileStatus db fileId FSComplete
updateCIFileStatus db user fileId CIFSRcvComplete
lookupChatItemByFileId db vr user fileId
lookupChatItemByFileId db cxt user fileId
agentXFTPDeleteRcvFile aFileId fileId
toView $ maybe (CEvtRcvStandaloneFileComplete user fsTargetPath ft) (CEvtRcvFileComplete user) ci_
RFWARN e -> do
ci <- withStore $ \db -> do
liftIO $ updateCIFileStatus db user fileId (CIFSRcvWarning $ agentFileError e)
lookupChatItemByFileId db vr user fileId
lookupChatItemByFileId db cxt user fileId
toView $ CEvtRcvFileWarning user ci e ft
RFERR e
| e == FILE NOT_APPROVED -> do
@@ -357,20 +357,20 @@ processAgentMsgRcvFile _corrId aFileId msg = do
| otherwise -> do
aci_ <- withStore $ \db -> do
liftIO $ updateFileCancelled db user fileId (CIFSRcvError $ agentFileError e)
lookupChatItemByFileId db vr user fileId
lookupChatItemByFileId db cxt user fileId
forM_ aci_ cleanupACIFile
agentXFTPDeleteRcvFile aFileId fileId
toView $ CEvtRcvFileError user aci_ e ft
type ShouldDeleteGroupConns = Bool
processAgentMessageConn :: VersionRangeChat -> User -> ACorrId -> ConnId -> AEvent 'AEConn -> CM ()
processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = do
processAgentMessageConn :: StoreCxt -> User -> ACorrId -> ConnId -> AEvent 'AEConn -> CM ()
processAgentMessageConn cxt user@User {userId} corrId agentConnId agentMessage = do
-- Missing connection/entity errors here will be sent to the view but not shown as CRITICAL alert,
-- as in this case no need to ACK message - we can't process messages for this connection anyway.
-- SEDBException will be re-trown as CRITICAL as it is likely to indicate a temporary database condition
-- that will be resolved with app restart.
entity <- critical agentConnId $ withStore (\db -> getConnectionEntity db vr user $ AgentConnId agentConnId) >>= updateConnStatus
entity <- critical agentConnId $ withStore (\db -> getConnectionEntity db cxt user $ AgentConnId agentConnId) >>= updateConnStatus
case agentMessage of
END -> case entity of
RcvDirectMsgConnection _ (Just ct) -> toView $ CEvtContactAnotherClient user ct
@@ -573,7 +573,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
-- XGrpLinkInv here means we are connecting via business contact card, so we replace contact with group
(gInfo, host) <- withStore $ \db -> do
liftIO $ deleteContactCardKeepConn db connId ct
createGroupInvitedViaLink db vr user conn'' glInv
createGroupInvitedViaLink db cxt user conn'' glInv
void $ createChatItem user (CDGroupSnd gInfo Nothing) False CIChatBanner Nothing (Just epochStart)
-- [incognito] send saved profile
incognitoProfile <- forM customUserProfileId $ \pId -> withStore (\db -> getProfileById db userId pId)
@@ -625,7 +625,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
when (connChatVersion < batchSend2Version) $ forM_ (autoReply $ addressSettings ucl) $ \mc -> sendAutoReply ct' mc Nothing -- old versions only
-- TODO REMOVE LEGACY vvv
forM_ gli_ $ \GroupLinkInfo {groupId, memberRole = gLinkMemRole} -> do
groupInfo <- withStore $ \db -> getGroupInfo db vr user groupId
groupInfo <- withStore $ \db -> getGroupInfo db cxt user groupId
subMode <- chatReadVar subscriptionMode
groupConnIds <- createAgentConnectionAsync user CFCreateConnGrpInv True SCMInvitation subMode
gVar <- asks random
@@ -736,7 +736,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
-- [async agent commands] group link auto-accept continuation on receiving INV
CFCreateConnGrpInv -> do
(ct, groupLinkId) <- withStore $ \db -> do
ct <- getContactViaMember db vr user m
ct <- getContactViaMember db cxt user m
liftIO $ setNewContactMemberConnRequest db user m cReq
liftIO $ (ct,) <$> getGroupLinkId db user gInfo
sendGrpInvitation ct m groupLinkId
@@ -804,7 +804,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
pgId = fmap (\PublicGroupProfile {publicGroupId} -> publicGroupId),
useRelays' gInfo == isJust rcvPG && pgId rcvPG == pgId curPG -> do
-- XGrpLinkInv here means we are connecting via prepared group, and we have to update user and host member records
(gInfo', m') <- withStore $ \db -> updatePreparedUserAndHostMembersInvited db vr user gInfo m glInv
(gInfo', m') <- withStore $ \db -> updatePreparedUserAndHostMembersInvited db cxt user gInfo m glInv
-- [incognito] send saved profile
incognitoProfile <- forM customUserProfileId $ \pId -> withStore (\db -> getProfileById db userId pId)
let profileToSend = userProfileInGroup user gInfo (fromLocalProfile <$> incognitoProfile)
@@ -812,7 +812,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
toView $ CEvtGroupLinkConnecting user gInfo' m'
| otherwise -> messageError "x.grp.link.inv: publicGroupId mismatch"
XGrpLinkReject glRjct@GroupLinkRejection {rejectionReason} -> do
(gInfo', m') <- withStore $ \db -> updatePreparedUserAndHostMembersRejected db vr user gInfo m glRjct
(gInfo', m') <- withStore $ \db -> updatePreparedUserAndHostMembersRejected db cxt user gInfo m glRjct
toView $ CEvtGroupLinkConnecting user gInfo' m'
toViewTE $ TEGroupLinkRejected user gInfo' rejectionReason
_ -> messageError "CONF from host member in prepared group must have x.grp.link.inv or x.grp.link.reject"
@@ -886,7 +886,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
where
firstConnectedHost
| useRelays' gInfo = do
relayMems <- withStore' $ \db -> getGroupRelayMembers db vr user gInfo
relayMems <- withStore' $ \db -> getGroupRelayMembers db cxt user gInfo
let numConnected = length $ filter (\GroupMember {memberStatus = ms} -> ms == GSMemConnected) relayMems
pure $ numConnected == 1
| otherwise = pure True
@@ -916,13 +916,13 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
when (connChatVersion < batchSend2Version) $ getAutoReplyMsg >>= mapM_ (\mc -> sendGroupAutoReply mc Nothing)
if useRelays' gInfo''
then do
introduceInChannel vr user gInfo'' m'
introduceInChannel cxt user gInfo'' m'
when (groupFeatureAllowed SGFHistory gInfo'') $ sendHistory user gInfo'' m'
else case mStatus of
GSMemPendingApproval -> pure ()
GSMemPendingReview -> introduceToModerators vr user gInfo'' m'
GSMemPendingReview -> introduceToModerators cxt user gInfo'' m'
_ -> do
introduceToAll vr user gInfo'' m'
introduceToAll cxt user gInfo'' m'
let memberIsCustomer = case businessChat gInfo'' of
Just BusinessChatInfo {chatType = BCCustomer, customerId} -> memberId' m' == customerId
_ -> False
@@ -945,12 +945,12 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
sendXGrpMemCon = \case
GCPreMember ->
forM_ (invitedByGroupMemberId membership) $ \hostId -> do
host <- withStore $ \db -> getGroupMember db vr user groupId hostId
host <- withStore $ \db -> getGroupMember db cxt user groupId hostId
forM_ (memberConn host) $ \hostConn ->
void $ sendDirectMemberMessage hostConn (XGrpMemCon memberId) groupId
GCPostMember ->
forM_ (invitedByGroupMemberId m) $ \invitingMemberId -> do
im <- withStore $ \db -> getGroupMember db vr user groupId invitingMemberId
im <- withStore $ \db -> getGroupMember db cxt user groupId invitingMemberId
forM_ (memberConn im) $ \imConn ->
void $ sendDirectMemberMessage imConn (XGrpMemCon memberId) groupId
_ -> messageWarning "sendXGrpMemCon: member category GCPreMember or GCPostMember is expected"
@@ -1210,7 +1210,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
(confId, m', relay) <- withStore $ \db -> do
confId <- getRelayConfId db m
liftIO $ updateGroupMemberStatus db userId m GSMemAccepted
(m', relay) <- setRelayLinkAccepted db vr user m (MemberKey relayKey) relayProfile
(m', relay) <- setRelayLinkAccepted db cxt user m (MemberKey relayKey) relayProfile
pure (confId, m', relay)
allowAgentConnectionAsync user conn confId XOk
toView $ CEvtGroupRelayUpdated user gInfo m' relay
@@ -1298,7 +1298,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
FileChunkCancel ->
unless (rcvFileCompleteOrCancelled ft) $ do
cancelRcvFileTransfer user ft
ci <- withStore $ \db -> getChatItemByFileId db vr user fileId
ci <- withStore $ \db -> getChatItemByFileId db cxt user fileId
toView $ CEvtRcvFileSndCancelled user ci ft
FileChunk {chunkNo, chunkBytes = chunk} -> do
case integrity of
@@ -1321,7 +1321,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
updateRcvFileStatus db fileId FSComplete
updateCIFileStatus db user fileId CIFSRcvComplete
deleteRcvFileChunks db ft
getChatItemByFileId db vr user fileId
getChatItemByFileId db cxt user fileId
toView $ CEvtRcvFileComplete user ci
mapM_ (deleteAgentConnectionAsync . aConnId) conn_
RcvChunkDuplicate -> withAckMessage' "file msg" agentConnId meta $ pure ()
@@ -1346,7 +1346,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
case (ucGroupId_, auData) of
(Just groupId, UserContactLinkData UserContactData {relays = relayLinks}) -> do
(gInfo, gLink, relays, relaysChanged, newlyActiveLinks) <- withStore $ \db -> do
gInfo <- getGroupInfo db vr user groupId
gInfo <- getGroupInfo db cxt user groupId
gLink <- getGroupLink db user gInfo
relays <- liftIO $ getGroupRelays db gInfo
(relays', changed, newlyActive) <- liftIO $ foldrM (updateRelay db) ([], False, []) relays
@@ -1359,7 +1359,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
-- dedicated subscriber count).
when (fromMaybe 0 publicMemberCount > 1) $
forM_ (L.nonEmpty newlyActiveLinks) $ \newlyActive -> do
allRelayMembers <- withFastStore' $ \db -> getGroupRelayMembers db vr user gInfo
allRelayMembers <- withFastStore' $ \db -> getGroupRelayMembers db cxt user gInfo
let recipients =
filter
(\GroupMember {memberStatus, relayLink} ->
@@ -1409,7 +1409,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
AddressSettings {autoAccept} = addressSettings
isSimplexTeam = sameConnReqContact connReq adminContactReq
gVar <- asks random
withStore (\db -> createOrUpdateContactRequest db gVar vr user uclId ucl isSimplexTeam invId chatVRange p xContactId_ welcomeMsgId_ requestMsg_ reqPQSup) >>= \case
withStore (\db -> createOrUpdateContactRequest db gVar cxt user uclId ucl isSimplexTeam invId chatVRange p xContactId_ welcomeMsgId_ requestMsg_ reqPQSup) >>= \case
RSAcceptedRequest _ucr re -> case re of
REContact ct ->
-- TODO [short links] update request msg
@@ -1541,7 +1541,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
-- ##### Group link join requests (don't create contact requests) #####
Just gli@GroupLinkInfo {groupId, memberRole = gLinkMemRole} -> do
-- TODO [short links] deduplicate request by xContactId?
gInfo <- withStore $ \db -> getGroupInfo db vr user groupId
gInfo <- withStore $ \db -> getGroupInfo db cxt user groupId
if useRelays' gInfo
then messageWarning $ "processContactConnMessage (group " <> groupName' gInfo <> "): ignored direct join request from " <> displayName <> " (group uses relays)"
else do
@@ -1567,10 +1567,10 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
rejected <- withStore' $ \db -> isRelayGroupRejected db user groupLink
initialDelay <- asks $ initialInterval . relayRequestRetryInterval . config
if rejected
then rejectRelayInvitationAsync user uclId vr groupRelayInv invId chatVRange initialDelay RRRRejoinRejected
then rejectRelayInvitationAsync user uclId cxt groupRelayInv invId chatVRange initialDelay RRRRejoinRejected
else do
(_gInfo, _ownerMember) <- withStore $ \db ->
createRelayRequestGroup db vr user groupRelayInv invId chatVRange initialDelay GSMemAccepted RSInvited
createRelayRequestGroup db cxt user groupRelayInv invId chatVRange initialDelay GSMemAccepted RSInvited
lift $ void $ getRelayRequestWorker True
xGrpRelayTest :: InvitationId -> VersionRangeChat -> ByteString -> CM ()
xGrpRelayTest invId chatVRange challenge = do
@@ -1585,7 +1585,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
let chatV = chatVR `peerConnChatVersion` chatVRange
(cmdId, acId) <- agentAcceptContactAsync user True invId msg subMode PQSupportOff chatV
withStore $ \db -> do
Connection {connId = testCId} <- createRelayTestConnection db vr user acId ConnAccepted chatV subMode
Connection {connId = testCId} <- createRelayTestConnection db cxt user acId ConnAccepted chatV subMode
liftIO $ setCommandConnId db user cmdId testCId
-- TODO [relays] owner, relays: TBC how to communicate member rejection rules from owner to relays
-- TODO [relays] relay: TBC communicate rejection when memberId already exists (currently checked in createJoiningMember)
@@ -1594,7 +1594,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
(_ucl, gLinkInfo_) <- withStore $ \db -> getUserContactLinkById db userId uclId
case gLinkInfo_ of
Just GroupLinkInfo {groupId, memberRole = gLinkMemRole} -> do
gInfo <- withStore $ \db -> getGroupInfo db vr user groupId
gInfo <- withStore $ \db -> getGroupInfo db cxt user groupId
mem <- acceptGroupJoinRequestAsync user uclId gInfo invId chatVRange p Nothing (Just joiningMemberId) Nothing GAAccepted gLinkMemRole Nothing (Just joiningMemberKey)
(gInfo', mem', scopeInfo) <- mkGroupChatScope gInfo mem
createInternalChatItem user (CDGroupRcv gInfo' scopeInfo mem') (CIRcvGroupEvent RGEInvitedViaGroupLink) Nothing
@@ -1764,7 +1764,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
-- sendProbe -> sendProbeHashes (currently)
-- sendProbeHashes -> sendProbe (reversed - change order in code, may add delay)
sendProbe probe
ms <- map COMGroupMember <$> withStore' (\db -> getMatchingMembers db vr user ct)
ms <- map COMGroupMember <$> withStore' (\db -> getMatchingMembers db cxt user ct)
sendProbeHashes ms probe probeId
else sendProbe . Probe =<< liftIO (encodedRandomBytes gVar 32)
where
@@ -1780,7 +1780,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
then do
(probe, probeId) <- withStore $ \db -> createSentProbe db gVar userId $ COMGroupMember m
sendProbe probe
cs <- map COMContact <$> withStore' (\db -> getMatchingMemberContacts db vr user m)
cs <- map COMContact <$> withStore' (\db -> getMatchingMemberContacts db cxt user m)
sendProbeHashes cs probe probeId
else sendProbe . Probe =<< liftIO (encodedRandomBytes gVar 32)
where
@@ -1853,7 +1853,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
messageFileDescription Contact {contactId} sharedMsgId fileDescr = do
(fileId, aci) <- withStore $ \db -> do
fileId <- getFileIdBySharedMsgId db userId contactId sharedMsgId
aci <- getChatItemByFileId db vr user fileId
aci <- getChatItemByFileId db cxt user fileId
pure (fileId, aci)
processFDMessage fileId aci fileDescr
@@ -1861,7 +1861,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
groupMessageFileDescription g@GroupInfo {groupId} m_ sharedMsgId fileDescr = do
(fileId, aci) <- withStore $ \db -> do
fileId <- getGroupFileIdBySharedMsgId db userId groupId sharedMsgId
aci <- getChatItemByFileId db vr user fileId
aci <- getChatItemByFileId db cxt user fileId
pure (fileId, aci)
case aci of
AChatItem SCTGroup SMDRcv (GroupChat _g scopeInfo) ChatItem {chatDir}
@@ -2022,7 +2022,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
cci <- case itemMemberId of
Just itemMemberId' -> getGroupMemberCIBySharedMsgId db user g itemMemberId' sharedMsgId
Nothing -> getGroupChatItemBySharedMsgId db user g Nothing sharedMsgId
scopeInfo <- getGroupChatScopeInfoForItem db vr user g (cChatItemId cci)
scopeInfo <- getGroupChatScopeInfoForItem db cxt user g (cChatItemId cci)
pure (cci, scopeInfo)
if ciReactionAllowed ci
then do
@@ -2060,13 +2060,13 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
-- no delivery task - message already forwarded by relay
pure Nothing
Just m@GroupMember {memberId} -> do
(gInfo', m', scopeInfo) <- mkGetMessageChatScope vr user gInfo m content msgScope_
(gInfo', m', scopeInfo) <- mkGetMessageChatScope cxt user gInfo m content msgScope_
if blockedByAdmin m'
then createBlockedByAdmin gInfo' (Just m') scopeInfo $> Nothing
else case prohibitedGroupContent gInfo' m' scopeInfo content ft_ fInv_ False of
Just f -> rejected gInfo' (Just m') scopeInfo f $> Nothing
Nothing ->
withStore' (\db -> getCIModeration db vr user gInfo' memberId sharedMsgId_) >>= \case
withStore' (\db -> getCIModeration db cxt user gInfo' memberId sharedMsgId_) >>= \case
Just ciModeration -> do
applyModeration gInfo' m' scopeInfo ciModeration
withStore' $ \db -> deleteCIModeration db gInfo' memberId sharedMsgId_
@@ -2156,7 +2156,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
else case m_ of
Just m -> do
let mentions' = if memberBlocked m then [] else mentions
(gInfo', m', scopeInfo) <- mkGetMessageChatScope vr user gInfo m mc msgScope_
(gInfo', m', scopeInfo) <- mkGetMessageChatScope cxt user gInfo m mc msgScope_
pure (gInfo', CDGroupRcv gInfo' scopeInfo m', mentions', scopeInfo)
Nothing -> pure (gInfo, CDChannelRcv gInfo Nothing, mentions, Nothing)
case m_ >>= \m -> prohibitedGroupContent gInfo' m scopeInfo mc ft_ (Nothing :: Maybe String) False of
@@ -2187,7 +2187,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
else case m_ of
Just m -> getGroupMemberCIBySharedMsgId db user gInfo (memberId' m) sharedMsgId
Nothing -> getGroupChatItemBySharedMsgId db user gInfo Nothing sharedMsgId
(cci,) <$> getGroupChatScopeInfoForItem db vr user gInfo (cChatItemId cci)
(cci,) <$> getGroupChatScopeInfoForItem db cxt user gInfo (cChatItemId cci)
case cci of
CChatItem SMDRcv ci@ChatItem {chatDir = CIGroupRcv m', meta = CIMeta {itemLive}, content = CIRcvMsgContent oldMC}
| isSender m' -> updateCI False ci scopeInfo oldMC itemLive (Just $ memberId' m')
@@ -2299,7 +2299,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
| otherwise = a
delete :: CChatItem 'CTGroup -> Bool -> Maybe GroupMember -> CM (Maybe DeliveryTaskContext)
delete cci asGroup byGroupMember = do
scopeInfo <- withStore $ \db -> getGroupChatScopeInfoForItem db vr user gInfo (cChatItemId cci)
scopeInfo <- withStore $ \db -> getGroupChatScopeInfoForItem db cxt user gInfo (cChatItemId cci)
let fullDelete
| asGroup = groupFeatureAllowed SGFFullDelete gInfo
| otherwise = maybe False (\m -> groupFeatureMemberAllowed SGFFullDelete m gInfo) m_
@@ -2367,14 +2367,14 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
(fileId,) <$> getRcvFileTransfer db user fileId
unless (rcvFileCompleteOrCancelled ft) $ do
cancelRcvFileTransfer user ft
ci <- withStore $ \db -> getChatItemByFileId db vr user fileId
ci <- withStore $ \db -> getChatItemByFileId db cxt user fileId
toView $ CEvtRcvFileSndCancelled user ci ft
xFileAcptInv :: Contact -> SharedMsgId -> Maybe ConnReqInvitation -> String -> CM ()
xFileAcptInv ct sharedMsgId fileConnReq_ fName = do
(fileId, AChatItem _ _ _ ci) <- withStore $ \db -> do
fileId <- getDirectFileIdBySharedMsgId db user ct sharedMsgId
(fileId,) <$> getChatItemByFileId db vr user fileId
(fileId,) <$> getChatItemByFileId db cxt user fileId
assertSMPAcceptNotProhibited ci
ft@FileTransferMeta {fileName, fileSize, fileInline, cancelled} <- withStore (\db -> getFileTransferMeta db user fileId)
-- [async agent commands] no continuation needed, but command should be asynchronous for stability
@@ -2383,7 +2383,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
-- receiving inline
Nothing -> do
event <- withStore $ \db -> do
ci' <- updateDirectCIFileStatus db vr user fileId $ CIFSSndTransfer 0 1
ci' <- updateDirectCIFileStatus db cxt user fileId $ CIFSSndTransfer 0 1
sft <- createSndDirectInlineFT db ct ft
pure $ CEvtSndFileStart user ci' sft
toView event
@@ -2411,7 +2411,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
forM_ sft_ $ \sft@SndFileTransfer {fileId} -> do
ci@(AChatItem _ _ _ ChatItem {file}) <- withStore $ \db -> do
liftIO $ updateSndFileStatus db sft FSComplete
updateDirectCIFileStatus db vr user fileId CIFSSndComplete
updateDirectCIFileStatus db cxt user fileId CIFSSndComplete
case file of
Just CIFile {fileProtocol = FPXFTP} -> do
ft <- withStore $ \db -> getFileTransferMeta db user fileId
@@ -2449,7 +2449,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
xFileCancelGroup g@GroupInfo {groupId} m_ sharedMsgId = do
(fileId, aci) <- withStore $ \db -> do
fileId <- getGroupFileIdBySharedMsgId db userId groupId sharedMsgId
(fileId,) <$> getChatItemByFileId db vr user fileId
(fileId,) <$> getChatItemByFileId db cxt user fileId
case aci of
AChatItem SCTGroup SMDRcv (GroupChat _g scopeInfo) ChatItem {chatDir}
| validSender m_ chatDir -> do
@@ -2465,7 +2465,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
xFileAcptInvGroup GroupInfo {groupId} m@GroupMember {activeConn} sharedMsgId fileConnReq_ fName = do
(fileId, AChatItem _ _ _ ci) <- withStore $ \db -> do
fileId <- getGroupFileIdBySharedMsgId db userId groupId sharedMsgId
(fileId,) <$> getChatItemByFileId db vr user fileId
(fileId,) <$> getChatItemByFileId db cxt user fileId
assertSMPAcceptNotProhibited ci
-- TODO check that it's not already accepted
ft@FileTransferMeta {fileName, fileSize, fileInline, cancelled} <- withStore (\db -> getFileTransferMeta db user fileId)
@@ -2474,7 +2474,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
(Nothing, Just conn) -> do
-- receiving inline
event <- withStore $ \db -> do
ci' <- updateDirectCIFileStatus db vr user fileId $ CIFSSndTransfer 0 1
ci' <- updateDirectCIFileStatus db cxt user fileId $ CIFSSndTransfer 0 1
sft <- liftIO $ createSndGroupInlineFT db m conn ft
pure $ CEvtSndFileStart user ci' sft
toView event
@@ -2500,7 +2500,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
when (fromRole < GRAdmin || fromRole < memRole) $ throwChatError (CEGroupContactRole c)
when (fromMemId == memId) $ throwChatError CEGroupDuplicateMemberId
-- [incognito] if direct connection with host is incognito, create membership using the same incognito profile
(gInfo@GroupInfo {groupId, localDisplayName, groupProfile, membership}, hostId) <- withStore $ \db -> createGroupInvitation db vr user ct inv customUserProfileId
(gInfo@GroupInfo {groupId, localDisplayName, groupProfile, membership}, hostId) <- withStore $ \db -> createGroupInvitation db cxt user ct inv customUserProfileId
void $ createChatItem user (CDGroupSnd gInfo Nothing) False CIChatBanner Nothing (Just epochStart)
let GroupMember {groupMemberId, memberId = membershipMemId} = membership
if sameGroupLinkId groupLinkId groupLinkId'
@@ -2541,7 +2541,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
then do
(ct', contactConns) <- withStore' $ \db -> do
ct' <- updateContactStatus db user c CSDeleted
(ct',) <$> getContactConnections db vr userId ct'
(ct',) <$> getContactConnections db cxt userId ct'
deleteAgentConnectionsAsync $ map aConnId contactConns
forM_ contactConns $ \conn -> withStore' $ \db -> updateConnectionStatus db conn ConnDeleted
activeConn' <- forM (contactConn ct') $ \conn -> pure conn {connStatus = ConnDeleted}
@@ -2550,7 +2550,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
toView $ CEvtNewChatItems user [AChatItem SCTDirect SMDRcv cInfo ci]
toView $ CEvtContactDeletedByContact user ct''
else do
contactConns <- withStore' $ \db -> getContactConnections db vr userId c
contactConns <- withStore' $ \db -> getContactConnections db cxt userId c
deleteAgentConnectionsAsync $ map aConnId contactConns
withStore $ \db -> deleteContact db user c
where
@@ -2619,7 +2619,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
messageError "x.grp.link.acpt with insufficient member permissions"
| sameMemberId memberId membership = processUserAccepted
| otherwise =
withStore' (\db -> runExceptT $ getGroupMemberByMemberId db vr user gInfo memberId) >>= \case
withStore' (\db -> runExceptT $ getGroupMemberByMemberId db cxt user gInfo memberId) >>= \case
Left _ -> messageError "x.grp.link.acpt error: referenced member does not exist"
Right referencedMember -> do
(referencedMember', gInfo') <- withStore' $ \db -> do
@@ -2663,7 +2663,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
GAPendingApproval ->
messageWarning "x.grp.link.acpt: unexpected group acceptance - pending approval"
introduceToRemainingMembers acceptedMember = do
introduceToRemaining vr user gInfo acceptedMember
introduceToRemaining cxt user gInfo acceptedMember
when (groupFeatureAllowed SGFHistory gInfo) $ sendHistory user gInfo acceptedMember
maybeCreateGroupDescrLocal :: GroupInfo -> GroupMember -> CM ()
@@ -2685,7 +2685,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
toView $ CEvtGroupMemberUpdated user gInfo m m'
pure m'
Just mContactId -> do
mCt <- withStore $ \db -> getContact db vr user mContactId
mCt <- withStore $ \db -> getContact db cxt user mContactId
if canUpdateProfile mCt
then do
(m', ct') <- withStore $ \db -> updateContactMemberProfile db user m mCt p'
@@ -2733,7 +2733,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
contactMerge <- readTVarIO =<< asks contactMergeEnabled
-- [incognito] unless connected incognito
when (contactMerge && not (contactOrMemberIncognito cgm2)) $ do
cgm1s <- withStore' $ \db -> matchReceivedProbe db vr user cgm2 probe
cgm1s <- withStore' $ \db -> matchReceivedProbe db cxt user cgm2 probe
let cgm1s' = filter (not . contactOrMemberIncognito) cgm1s
probeMatches cgm1s' cgm2
where
@@ -2749,7 +2749,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
contactMerge <- readTVarIO =<< asks contactMergeEnabled
-- [incognito] unless connected incognito
when (contactMerge && not (contactOrMemberIncognito cgm1)) $ do
cgm2Probe_ <- withStore' $ \db -> matchReceivedProbeHash db vr user cgm1 probeHash
cgm2Probe_ <- withStore' $ \db -> matchReceivedProbeHash db cxt user cgm1 probeHash
forM_ cgm2Probe_ $ \(cgm2, probe) ->
unless (contactOrMemberIncognito cgm2) . void $
probeMatch cgm1 cgm2 probe
@@ -2779,7 +2779,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
xInfoProbeOk :: ContactOrMember -> Probe -> CM ()
xInfoProbeOk cgm1 probe = do
cgm2 <- withStore' $ \db -> matchSentProbe db vr user cgm1 probe
cgm2 <- withStore' $ \db -> matchSentProbe db cxt user cgm1 probe
case cgm1 of
COMContact c1 ->
case cgm2 of
@@ -2928,14 +2928,14 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
associateMemberWithContact c1 m2@GroupMember {groupId} = do
g <- withStore $ \db -> do
liftIO $ associateMemberWithContactRecord db user c1 m2
getGroupInfo db vr user groupId
getGroupInfo db cxt user groupId
toView $ CEvtContactAndMemberAssociated user c1 g m2 c1
pure c1
associateContactWithMember :: GroupMember -> Contact -> CM Contact
associateContactWithMember m1@GroupMember {groupId} c2 = do
(c2', g) <- withStore $ \db ->
liftM2 (,) (associateContactWithMemberRecord db vr user m1 c2) (getGroupInfo db vr user groupId)
liftM2 (,) (associateContactWithMemberRecord db cxt user m1 c2) (getGroupInfo db cxt user groupId)
toView $ CEvtContactAndMemberAssociated user c2 g m1 c2'
pure c2'
@@ -2945,15 +2945,15 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
conn' <- updatePeerChatVRange activeConn chatVRange
case chatMsgEvent of
XInfo p -> do
ct <- withStore $ \db -> createDirectContact db vr user conn' p
ct <- withStore $ \db -> createDirectContact db cxt user conn' p
toView $ CEvtContactConnecting user ct
pure (conn', Nothing)
XGrpLinkInv glInv -> do
(gInfo, host) <- withStore $ \db -> createGroupInvitedViaLink db vr user conn' glInv
(gInfo, host) <- withStore $ \db -> createGroupInvitedViaLink db cxt user conn' glInv
toView $ CEvtGroupLinkConnecting user gInfo host
pure (conn', Just gInfo)
XGrpLinkReject glRjct@GroupLinkRejection {rejectionReason} -> do
(gInfo, host) <- withStore $ \db -> createGroupRejectedViaLink db vr user conn' glRjct
(gInfo, host) <- withStore $ \db -> createGroupRejectedViaLink db cxt user conn' glRjct
toView $ CEvtGroupLinkConnecting user gInfo host
toViewTE $ TEGroupLinkRejected user gInfo rejectionReason
pure (conn', Just gInfo)
@@ -2968,10 +2968,10 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
if sameMemberId memId (membership gInfo)
then pure Nothing
else do
withStore' (\db -> runExceptT $ getGroupMemberByMemberId db vr user gInfo memId) >>= \case
withStore' (\db -> runExceptT $ getGroupMemberByMemberId db cxt user gInfo memId) >>= \case
Right unknownMember@GroupMember {memberStatus = GSMemUnknown} -> do
(updatedMember, gInfo') <- withStore $ \db -> do
updatedMember <- updateUnknownMemberAnnounced db vr user m unknownMember memInfo initialStatus
updatedMember <- updateUnknownMemberAnnounced db cxt user m unknownMember memInfo initialStatus
gInfo' <-
if memberPending updatedMember
then liftIO $ increaseGroupMembersRequireAttention db user gInfo
@@ -3024,10 +3024,10 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
xGrpMemIntro gInfo@GroupInfo {chatSettings} m@GroupMember {memberRole, localDisplayName = c} memInfo@(MemberInfo memId _ memChatVRange _ _) memRestrictions = do
case memberCategory m of
GCHostMember ->
withStore' (\db -> runExceptT $ getGroupMemberByMemberId db vr user gInfo memId) >>= \case
withStore' (\db -> runExceptT $ getGroupMemberByMemberId db cxt user gInfo memId) >>= \case
Right existingMember
| useRelays' gInfo -> do
updatedMember <- withStore $ \db -> updatePreparedChannelMember db vr user existingMember memInfo
updatedMember <- withStore $ \db -> updatePreparedChannelMember db cxt user existingMember memInfo
toView $ CEvtGroupMemberUpdated user gInfo existingMember updatedMember
| otherwise ->
messageError "x.grp.mem.intro ignored: member already exists"
@@ -3048,7 +3048,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
subMode <- chatReadVar subscriptionMode
-- [async agent commands] commands should be asynchronous, continuation is to send XGrpMemInv - have to remember one has completed and process on second
groupConnIds <- createConn subMode
let chatV = maybe (minVersion vr) (\peerVR -> vr `peerConnChatVersion` fromChatVRange peerVR) memChatVRange
let chatV = maybe (minVersion (vr cxt)) (\peerVR -> vr cxt `peerConnChatVersion` fromChatVRange peerVR) memChatVRange
void $ withStore $ \db -> do
reMember <- createIntroReMember db user gInfo memInfo memRestrictions
createIntroReMemberConn db user m reMember chatV memInfo groupConnIds subMode
@@ -3059,7 +3059,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
sendXGrpMemInv :: Int64 -> Maybe ConnReqInvitation -> XGrpMemIntroCont -> CM ()
sendXGrpMemInv hostConnId directConnReq XGrpMemIntroCont {groupId, groupMemberId, memberId, groupConnReq} = do
hostConn <- withStore $ \db -> getConnectionById db vr user hostConnId
hostConn <- withStore $ \db -> getConnectionById db cxt user hostConnId
let msg = XGrpMemInv memberId IntroInvitation {groupConnReq, directConnReq}
void $ sendDirectMemberMessage hostConn msg groupId
withStore' $ \db -> updateGroupMemberStatusById db userId groupMemberId GSMemIntroInvited
@@ -3068,7 +3068,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
xGrpMemInv gInfo m memId introInv = do
case memberCategory m of
GCInviteeMember ->
withStore' (\db -> runExceptT $ getGroupMemberByMemberId db vr user gInfo memId) >>= \case
withStore' (\db -> runExceptT $ getGroupMemberByMemberId db cxt user gInfo memId) >>= \case
Left _ -> messageError "x.grp.mem.inv error: referenced member does not exist"
Right reMember -> sendGroupMemberMessage gInfo reMember $ XGrpMemFwd (memberInfo gInfo m) introInv
_ -> messageError "x.grp.mem.inv can be only sent by invitee member"
@@ -3079,7 +3079,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
checkHostRole m memRole
toMember <- withStore $ \db -> do
toMember <-
getGroupMemberByMemberId db vr user gInfo memId
getGroupMemberByMemberId db cxt user gInfo memId
-- TODO if the missed messages are correctly sent as soon as there is connection before anything else is sent
-- the situation when member does not exist is an error
-- member receiving x.grp.mem.fwd should have also received x.grp.mem.new prior to that.
@@ -3103,7 +3103,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
directConnIds <- forM directConnReq $ \dcr -> joinAgentConnectionAsync user Nothing True dcr dm subMode
let customUserProfileId = localProfileId <$> incognitoMembershipProfile gInfo
mcvr = maybe chatInitialVRange fromChatVRange memChatVRange
chatV = vr `peerConnChatVersion` mcvr
chatV = vr cxt `peerConnChatVersion` mcvr
withStore' $ \db -> createIntroToMemberContact db user m toMember chatV mcvr groupConnIds directConnIds customUserProfileId subMode
xGrpMemRole :: GroupInfo -> GroupMember -> MemberId -> GroupMemberRole -> RcvMessage -> UTCTime -> CM (Maybe DeliveryJobScope)
@@ -3112,7 +3112,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
let gInfo' = gInfo {membership = membership {memberRole = memRole}}
in changeMemberRole gInfo' membership $ RGEUserRole memRole
| otherwise =
withStore' (\db -> runExceptT $ getGroupMemberByMemberId db vr user gInfo memId) >>= \case
withStore' (\db -> runExceptT $ getGroupMemberByMemberId db cxt user gInfo memId) >>= \case
Right member -> changeMemberRole gInfo member $ RGEMemberRole (groupMemberId' member) (fromLocalProfile $ memberProfile member) memRole
Left _ -> messageError "x.grp.mem.role with unknown member ID" $> Nothing
where
@@ -3143,7 +3143,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
| membershipMemId == memId = pure Nothing -- ignore - XGrpMemRestrict can be sent to restricted member for efficiency
| otherwise = do
unknownRole <- unknownMemberRole gInfo
withStore (\db -> getCreateUnknownGMByMemberId db vr user gInfo memId "" unknownRole True) >>= \case
withStore (\db -> getCreateUnknownGMByMemberId db cxt user gInfo memId "" unknownRole True) >>= \case
Nothing -> messageError "x.grp.mem.restrict: no member" $> Nothing -- shouldn't happen
Just (bm, unknown) -> do
let GroupMember {groupMemberId = bmId, memberRole, blockedByAdmin, memberProfile = bmp} = bm
@@ -3167,7 +3167,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
xGrpMemCon :: GroupInfo -> GroupMember -> MemberId -> CM ()
xGrpMemCon gInfo sendingMem memId = do
refMem <- withStore $ \db -> getGroupMemberByMemberId db vr user gInfo memId
refMem <- withStore $ \db -> getGroupMemberByMemberId db cxt user gInfo memId
-- Updating vectors in separate transactions to avoid deadlocks.
withStore $ \db -> setMemberVectorRelationConnected db sendingMem refMem MRSubjectConnected
withStore $ \db -> setMemberVectorRelationConnected db refMem sendingMem MRReferencedConnected
@@ -3189,7 +3189,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
toView $ CEvtDeletedMemberUser user gInfo {membership = membership'} m withMessages msgSigned
pure $ Just DJSGroup {jobSpec = DJRelayRemoved}
else
withStore' (\db -> runExceptT $ getGroupMemberByMemberId db vr user gInfo memId) >>= \case
withStore' (\db -> runExceptT $ getGroupMemberByMemberId db cxt user gInfo memId) >>= \case
Left _ -> do
messageError "x.grp.mem.del with unknown member ID"
pure $ Just DJSGroup {jobSpec = DJDeliveryJob {includePending = True}}
@@ -3336,7 +3336,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
case memberContactId of
Nothing -> createNewContact subMode
Just mContactId -> do
mCt <- withStore $ \db -> getContact db vr user mContactId
mCt <- withStore $ \db -> getContact db cxt user mContactId
let Contact {activeConn, contactGrpInvSent} = mCt
forM_ activeConn $ \Connection {connId} ->
if contactGrpInvSent
@@ -3363,7 +3363,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
mCt' <- withStore $ \db -> do
updateMemberContactInvited db user mCt groupDirectInv
void $ liftIO $ createMemberContactConn db user acId (Just cmdId) g mConn ConnJoined mContactId subMode
getContact db vr user mContactId
getContact db cxt user mContactId
securityCodeChanged mCt'
createItems mCt' m
| otherwise = do
@@ -3371,7 +3371,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
mCt' <- withStore $ \db -> do
updateMemberContactInvited db user mCt groupDirectInv
void $ liftIO $ createMemberContactConn db user acId Nothing g mConn ConnPrepared mContactId subMode
getContact db vr user mContactId
getContact db cxt user mContactId
securityCodeChanged mCt'
createInternalChatItem user (CDDirectRcv mCt') (CIRcvDirectEvent $ RDEGroupInvLinkReceived gp) Nothing
createItems mCt' m
@@ -3382,7 +3382,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
(mCt, m') <- withStore $ \db -> do
(mContactId, m') <- liftIO $ createMemberContactInvited db user g m groupDirectInv
void $ liftIO $ createMemberContactConn db user acId (Just cmdId) g mConn ConnJoined mContactId subMode
mCt <- getContact db vr user mContactId
mCt <- getContact db cxt user mContactId
pure (mCt, m')
createInternalChatItem user (CDDirectSnd mCt) CIChatBanner (Just epochStart)
createItems mCt m'
@@ -3391,7 +3391,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
(mCt, m') <- withStore $ \db -> do
(mContactId, m') <- liftIO $ createMemberContactInvited db user g m groupDirectInv
void $ liftIO $ createMemberContactConn db user acId Nothing g mConn ConnPrepared mContactId subMode
mCt <- getContact db vr user mContactId
mCt <- getContact db cxt user mContactId
pure (mCt, m')
createInternalChatItem user (CDDirectSnd mCt) CIChatBanner (Just epochStart)
createInternalChatItem user (CDDirectRcv mCt) (CIRcvDirectEvent $ RDEGroupInvLinkReceived gp) Nothing
@@ -3422,7 +3422,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
FwdMember memberId memberName -> do
unknownRole <- unknownMemberRole gInfo
let allowCreate = toCMEventTag chatMsgEvent /= XGrpLeave_
withStore (\db -> getCreateUnknownGMByMemberId db vr user gInfo memberId memberName unknownRole allowCreate) >>= \case
withStore (\db -> getCreateUnknownGMByMemberId db cxt user gInfo memberId memberName unknownRole allowCreate) >>= \case
Just (author, unknown)
| memberRemoved author ->
logInfo $ "x.grp.msg.forward: ignoring content from removed member, group " <> tshow (groupId' gInfo) <> ", member " <> safeDecodeUtf8 (strEncode memberId) <> ", event " <> tshow (toCMEventTag chatMsgEvent)
@@ -3552,7 +3552,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
-- SENT and RCVD events are received for messages that may be batched in single scope,
-- so we can look up scope of first item
scopeInfo <- case cis of
(ci : _) -> getGroupChatScopeInfoForItem db vr user gInfo (chatItemId' ci)
(ci : _) -> getGroupChatScopeInfoForItem db cxt user gInfo (chatItemId' ci)
_ -> pure Nothing
pure $ map (gItem scopeInfo) cis
unless (null acis) $ toView $ CEvtChatItemsStatusesUpdated user acis
@@ -3576,14 +3576,14 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
deleteGroupConnections :: User -> GroupInfo -> Bool -> CM ()
deleteGroupConnections user gInfo@GroupInfo {membership} waitDelivery = do
vr <- chatVersionRange
cxt <- chatStoreCxt
-- member records are not deleted to keep history
members <- getMembers vr
members <- getMembers cxt
deleteMembersConnections' user members waitDelivery
where
getMembers vr
| useRelays' gInfo, not (isRelay membership) = withStore' $ \db -> getGroupRelayMembers db vr user gInfo
| otherwise = withStore' $ \db -> getGroupMembers db vr user gInfo
getMembers cxt
| useRelays' gInfo, not (isRelay membership) = withStore' $ \db -> getGroupRelayMembers db cxt user gInfo
| otherwise = withStore' $ \db -> getGroupMembers db cxt user gInfo
startDeliveryTaskWorkers :: CM ()
startDeliveryTaskWorkers = do
@@ -3603,20 +3603,20 @@ getDeliveryTaskWorker hasWork deliveryKey = do
runDeliveryTaskWorker :: AgentClient -> DeliveryWorkerKey -> Worker -> CM ()
runDeliveryTaskWorker a deliveryKey Worker {doWork} = do
delay <- asks $ deliveryWorkerDelay . config
vr <- chatVersionRange
cxt <- chatStoreCxt
-- TODO [relays] in future may be required to read groupInfo and user on each iteration for up to date state
-- TODO - same for delivery jobs (runDeliveryJobWorker)
gInfo <- withStore $ \db -> do
user <- getUserByGroupId db groupId
getGroupInfo db vr user groupId
getGroupInfo db cxt user groupId
forever $ do
unless (delay == 0) $ liftIO $ threadDelay' delay
lift $ waitForWork doWork
runDeliveryTaskOperation vr gInfo
runDeliveryTaskOperation cxt gInfo
where
(groupId, workerScope) = deliveryKey
runDeliveryTaskOperation :: VersionRangeChat -> GroupInfo -> CM ()
runDeliveryTaskOperation vr gInfo = do
runDeliveryTaskOperation :: StoreCxt -> GroupInfo -> CM ()
runDeliveryTaskOperation cxt gInfo = do
withWork_ a doWork (withStore' $ \db -> getNextDeliveryTask db deliveryKey) $ \task ->
processDeliveryTask task
`catchAllErrors` \e -> do
@@ -3632,7 +3632,7 @@ runDeliveryTaskWorker a deliveryKey Worker {doWork} = do
withStore' $ \db -> setDeliveryTaskErrStatus db (deliveryTaskId task) "relay inactive"
| otherwise ->
withWorkItems a doWork (withStore' $ \db -> getNextDeliveryTasks db gInfo task) $ \nextTasks -> do
let (body, acceptedTasks, largeTasks) = batchDeliveryTasks1 vr maxEncodedMsgLength nextTasks
let (body, acceptedTasks, largeTasks) = batchDeliveryTasks1 (vr cxt) maxEncodedMsgLength nextTasks
senderGMIds = S.toList . S.fromList $ map (\MessageDeliveryTask {senderGMId} -> senderGMId) acceptedTasks
withStore' $ \db -> do
createMsgDeliveryJob db gInfo jobScope senderGMIds body
@@ -3691,19 +3691,19 @@ encodeMemberNew vr gInfo member = case encodeChatMessage maxBatchElementSize cha
runDeliveryJobWorker :: AgentClient -> DeliveryWorkerKey -> Worker -> CM ()
runDeliveryJobWorker a deliveryKey Worker {doWork} = do
delay <- asks $ deliveryWorkerDelay . config
vr <- chatVersionRange
cxt <- chatStoreCxt
(user, gInfo) <- withStore $ \db -> do
user <- getUserByGroupId db groupId
gInfo <- getGroupInfo db vr user groupId
gInfo <- getGroupInfo db cxt user groupId
pure (user, gInfo)
forever $ do
unless (delay == 0) $ liftIO $ threadDelay' delay
lift $ waitForWork doWork
runDeliveryJobOperation vr user gInfo
runDeliveryJobOperation cxt user gInfo
where
(groupId, workerScope) = deliveryKey
runDeliveryJobOperation :: VersionRangeChat -> User -> GroupInfo -> CM ()
runDeliveryJobOperation vr user gInfo = do
runDeliveryJobOperation :: StoreCxt -> User -> GroupInfo -> CM ()
runDeliveryJobOperation cxt user gInfo = do
withWork_ a doWork (withStore' $ \db -> getNextDeliveryJob db deliveryKey) $ \job ->
processDeliveryJob job
`catchAllErrors` \e -> do
@@ -3743,7 +3743,7 @@ runDeliveryJobWorker a deliveryKey Worker {doWork} = do
senders <- withStore' $ \db ->
fmap catMaybes . forM senderGMIds $ \sId ->
fmap eitherToMaybe . runExceptT $ do
sender <- getNonRemovedMemberById db vr user sId
sender <- getNonRemovedMemberById db cxt user sId
vec <- getMemberRelationsVector db sender
pure (sender, vec)
let missingSenders = length senderGMIds - length senders
@@ -3759,7 +3759,7 @@ runDeliveryJobWorker a deliveryKey Worker {doWork} = do
-- TODO [relays] public groups: revisit if mods/admins are introduced via this sidecar.
let (encoderErrs, validLabeled) =
partitionEithers
[ (\bs -> (s, bs)) <$> encodeMemberNew vr gInfo s
[ (\bs -> (s, bs)) <$> encodeMemberNew (vr cxt) gInfo s
| (s, _) <- senders, memberRole' s <= GRMember
]
(extBody', inBody, overflowLabeled, large1) = batchProfilesWithBody maxEncodedMsgLength body validLabeled
@@ -3779,7 +3779,7 @@ runDeliveryJobWorker a deliveryKey Worker {doWork} = do
where
sendLoop :: Int -> Maybe GroupMemberId -> Map GroupMemberId ByteString -> [(Int, (ByteString, [GroupMember]))] -> [GroupMember] -> ByteString -> [GroupMember] -> CM ()
sendLoop bucketSize cursorGMId_ senderVec overflowWithIds inBodySenders extBody activeSenders = do
mems <- withStore' $ \db -> getGroupMembersByCursor db vr user gInfo cursorGMId_ singleSenderGMId_ bucketSize
mems <- withStore' $ \db -> getGroupMembersByCursor db cxt user gInfo cursorGMId_ singleSenderGMId_ bucketSize
unless (null mems) $ do
let msgReqs = buildMsgReqs mems
unless (null msgReqs) $ void $ withAgent (`sendMessages` msgReqs)
@@ -3824,7 +3824,7 @@ runDeliveryJobWorker a deliveryKey Worker {doWork} = do
Nothing -> True
DJSMemberSupport scopeGMId -> do
-- for member support scope we just load all recipients in one go, without cursor
modMs <- withStore' $ \db -> getGroupModerators db vr user gInfo
modMs <- withStore' $ \db -> getGroupModerators db cxt user gInfo
let moderatorFilter m =
memberCurrent m
&& maxVersion (memberChatVRange m) >= groupKnockingVersion
@@ -3834,14 +3834,14 @@ runDeliveryJobWorker a deliveryKey Worker {doWork} = do
if Just scopeGMId == singleSenderGMId_
then pure modMs'
else do
scopeMem <- withStore $ \db -> getGroupMemberById db vr user scopeGMId
scopeMem <- withStore $ \db -> getGroupMemberById db cxt user scopeGMId
pure $ scopeMem : modMs'
unless (null mems) $ deliver body mems
-- fully connected group
| otherwise = case singleSenderGMId_ of
Nothing -> throwChatError $ CEInternalError "delivery job worker: singleSenderGMId is required when not using relays"
Just sId -> do
sender <- withStore $ \db -> getGroupMemberById db vr user sId
sender <- withStore $ \db -> getGroupMemberById db cxt user sId
ms <- buildMemberList sender
unless (null ms) $ deliver body ms
where
@@ -3851,14 +3851,14 @@ runDeliveryJobWorker a deliveryKey Worker {doWork} = do
let introducedMemsIdxs = getRelationsIndexes MRIntroduced vec
case jobScope of
DJSGroup {jobSpec} -> do
ms <- withStore' $ \db -> getGroupMembersByIndexes db vr user gInfo introducedMemsIdxs
ms <- withStore' $ \db -> getGroupMembersByIndexes db cxt user gInfo introducedMemsIdxs
pure $ filter shouldForwardTo ms
where
shouldForwardTo m
| jobSpecImpliedPending jobSpec = memberCurrentOrPending m
| otherwise = memberCurrent m
DJSMemberSupport scopeGMId -> do
ms <- withStore' $ \db -> getSupportScopeMembersByIndexes db vr user gInfo scopeGMId introducedMemsIdxs
ms <- withStore' $ \db -> getSupportScopeMembersByIndexes db cxt user gInfo scopeGMId introducedMemsIdxs
pure $ filter shouldForwardTo ms
where
shouldForwardTo m = groupMemberId' m == scopeGMId || currentModerator m
@@ -3909,7 +3909,7 @@ getRelayRequestWorker hasWork = do
runRelayRequestWorker :: AgentClient -> Worker -> CM ()
runRelayRequestWorker a Worker {doWork} = do
vr <- chatVersionRange
cxt <- chatStoreCxt
(user, uclId) <- withStore $ \db -> do
user <- getRelayUser db
UserContactLink {userContactLinkId} <- getUserAddress db user
@@ -3917,10 +3917,10 @@ runRelayRequestWorker a Worker {doWork} = do
delayThreads <- liftIO TM.emptyIO
forever $ do
lift $ waitForWork doWork
runRelayRequestOperation delayThreads vr user uclId
runRelayRequestOperation delayThreads cxt user uclId
where
runRelayRequestOperation :: TM.TMap GroupId (TMVar (Weak ThreadId)) -> VersionRangeChat -> User -> Int64 -> CM ()
runRelayRequestOperation delayThreads vr user uclId =
runRelayRequestOperation :: TM.TMap GroupId (TMVar (Weak ThreadId)) -> StoreCxt -> User -> Int64 -> CM ()
runRelayRequestOperation delayThreads cxt user uclId =
withWork_ a doWork getReadyRelayRequest $
\(groupId, rrd) -> do
ChatConfig {relayRequestExpiry} <- asks config
@@ -3969,7 +3969,7 @@ runRelayRequestWorker a Worker {doWork} = do
processRelayRequest :: GroupId -> RelayRequestData -> CM ()
processRelayRequest groupId rrd = do
(gInfo, groupLink_) <- withStore $ \db -> do
gInfo <- getGroupInfo db vr user groupId
gInfo <- getGroupInfo db cxt user groupId
groupLink_ <- liftIO $ runExceptT $ getGroupLink db user gInfo
pure (gInfo, groupLink_)
-- Check if relay link already exists (recovery case)
@@ -3997,7 +3997,7 @@ runRelayRequestWorker a Worker {doWork} = do
gInfo' <- withStore $ \db -> do
void $ updateGroupProfile db user gInfo gp
updateRelayGroupKeys db user gInfo pg rootKey memberPrivKey owners
getGroupInfo db vr user groupId
getGroupInfo db cxt user groupId
pure (gInfo', sLnk)
where
validateGroupProfile :: GroupProfile -> CM ()
@@ -4029,5 +4029,5 @@ runRelayRequestWorker a Worker {doWork} = do
pure (sigKeys, sLnk)
acceptOwnerConnection :: RelayRequestData -> GroupInfo -> ShortLinkContact -> CM ()
acceptOwnerConnection RelayRequestData {relayInvId, reqChatVRange} gi relayLink = do
ownerMember <- withStore $ \db -> getHostMember db vr user groupId
ownerMember <- withStore $ \db -> getHostMember db cxt user groupId
void $ acceptRelayJoinRequestAsync user uclId gi ownerMember relayInvId reqChatVRange relayLink