dandri/simplex-chat
1
0 Fork 0
mirror of https://github.com/simplex-chat/simplex-chat.git synced 2026-10-22 21:52:28 +00:00
Code Issues Packages Projects Releases Wiki Activity

Merge branch 'master' into f/public-groups

Browse Source
This commit is contained in:
spaced4ndy committed 2026-06-08 14:25:39 +04:00
2 parents 49a9e547ab 589d834f83
commit 752330e925
107 files changed
+2050 -1701
Download Patch File Download Diff File Expand all files Collapse all files

No files matched your search

src/Simplex/Chat/Controller.hs
+6
View File
@@ -169,6 +169,12 @@ data ChatConfig = ChatConfig
chatHooks :: ChatHooks
}
-- | Builds the read-only context threaded through store functions from chat config.
-- The single construction point, so new store-wide config (e.g. server keys) is added in one place.
mkStoreCxt :: ChatConfig -> StoreCxt
mkStoreCxt ChatConfig {chatVRange} = StoreCxt chatVRange
{-# INLINE mkStoreCxt #-}
data RandomAgentServers = RandomAgentServers
{ smpServers :: NonEmpty (ServerCfg 'PSMP),
xftpServers :: NonEmpty (ServerCfg 'PXFTP)
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
+110 -102
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 -> Maybe GroupMember -> CM GroupMember
acceptGroupJoinRequestAsync
@@ -968,12 +968,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
@@ -998,12 +998,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
@@ -1012,7 +1012,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
@@ -1031,7 +1031,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
@@ -1055,28 +1055,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
@@ -1090,15 +1090,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
@@ -1108,15 +1108,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
@@ -1171,12 +1171,12 @@ memberIntroEvt gInfo reMember =
-- sent it, so the recipient verifies the owner signature.
forwardGroupRoster :: User -> GroupInfo -> GroupMember -> CM ()
forwardGroupRoster user gInfo subscriber = do
vr <- chatVersionRange
cxt <- chatStoreCxt
withStore' (\db -> getGroupRoster db gInfo) >>= \case
Nothing -> pure ()
Just (ownerGMId, brokerTs, sm@SignedMsg {signedBody}) ->
forM_ (eitherToMaybe (J.eitherDecodeStrict' signedBody) :: Maybe (ChatMessage 'Json)) $ \chatMsg ->
withStore' (\db -> runExceptT $ getGroupMemberById db vr user ownerGMId) >>= \case
withStore' (\db -> runExceptT $ getGroupMemberById db cxt user ownerGMId) >>= \case
Right owner -> do
let fwd = GrpMsgForward {fwdSender = FwdMember (memberId' owner) (memberShortenedName owner), fwdBrokerTs = brokerTs}
sendFwdMemberMessage subscriber fwd (VMSigned MSSVerified sm chatMsg)
@@ -1185,11 +1185,11 @@ forwardGroupRoster user gInfo subscriber = do
-- 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
introduceInChannel cxt user gInfo subscriber@GroupMember {activeConn = Just conn, indexInGroup = subscriberIdx} = do
(owners, rosterMems) <- withStore' $ \db ->
(,) <$> getGroupOwners db vr user gInfo <*> getGroupRosterMembers db vr user gInfo
(,) <$> getGroupOwners db cxt user gInfo <*> getGroupRosterMembers db cxt user gInfo
let modMs = owners <> rosterMems
void $ sendGroupMessage' user gInfo modMs $ XGrpMemNew (memberInfo gInfo subscriber) Nothing
withStore' $ \db ->
@@ -1379,9 +1379,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))
@@ -1389,17 +1389,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
@@ -1410,9 +1410,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
@@ -1422,12 +1422,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)
@@ -1506,14 +1506,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 ()
@@ -1548,16 +1548,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"
@@ -1677,25 +1677,25 @@ parseChatMessage' conn s =
where
errType = CEInvalidChatMessage conn Nothing (safeDecodeUtf8 s)
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'
@@ -1705,7 +1705,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
@@ -1731,8 +1731,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)
@@ -1747,7 +1747,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)
@@ -1861,8 +1861,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"
@@ -2061,13 +2061,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
@@ -2174,11 +2174,11 @@ sendGroupMessage' user gInfo members chatMsgEvent =
-- TODO after restoring from a stale backup (relays accept only strictly-greater versions)
bumpAndBroadcastRoster :: User -> GroupInfo -> CM ()
bumpAndBroadcastRoster user gInfo = do
vr <- chatVersionRange
cxt <- chatStoreCxt
let rosterVer = maybe (VersionRoster 0) (\(VersionRoster n) -> VersionRoster (n + 1)) (rosterVersion gInfo)
(relays, roster) <- withStore' $ \db -> do
relays <- getGroupRelayMembers db vr user gInfo
mods <- getGroupRosterMembers db vr user gInfo
relays <- getGroupRelayMembers db cxt user gInfo
mods <- getGroupRosterMembers db cxt user gInfo
setGroupRosterVersion db gInfo rosterVer
pure (relays, buildGroupRoster rosterVer mods)
forM_ (L.nonEmpty relays) $ \relays' ->
@@ -2188,8 +2188,8 @@ bumpAndBroadcastRoster user gInfo = do
sendGroupRosterToRelay :: User -> GroupInfo -> GroupMember -> CM ()
sendGroupRosterToRelay user gInfo relayMember =
forM_ (rosterVersion gInfo) $ \rosterVer -> do
vr <- chatVersionRange
mods <- withStore' $ \db -> getGroupRosterMembers db vr user gInfo
cxt <- chatStoreCxt
mods <- withStore' $ \db -> getGroupRosterMembers db cxt user gInfo
void $ sendGroupMessage' user gInfo [relayMember] (XGrpRoster (buildGroupRoster rosterVer mods))
sendGroupMessages :: MsgEncodingI e => User -> GroupInfo -> Maybe GroupChatScope -> ShowGroupAsSender -> [GroupMember] -> NonEmpty (ChatMsgEvent e) -> CM (NonEmpty (Either ChatError SndMessage), GroupSndResult)
@@ -2423,8 +2423,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
@@ -2444,8 +2444,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
@@ -2487,9 +2487,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))
@@ -2515,14 +2515,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_
@@ -2815,13 +2815,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)
@@ -2860,8 +2860,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
@@ -2911,6 +2911,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
+138 -134
View File
@@ -124,10 +124,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.
@@ -189,27 +189,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
@@ -242,13 +242,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
@@ -261,10 +261,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
@@ -289,12 +289,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
@@ -329,13 +329,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
@@ -347,13 +347,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
@@ -364,20 +364,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
@@ -580,7 +580,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)
@@ -632,7 +632,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
@@ -743,7 +743,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
@@ -811,7 +811,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)
@@ -819,7 +819,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"
@@ -893,7 +893,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
@@ -929,13 +929,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
@@ -958,12 +958,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"
@@ -1224,7 +1224,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
confId <- withStore $ \db -> do
confId <- getRelayConfId db m
liftIO $ updateGroupMemberStatus db userId m GSMemAccepted
void $ setRelayKey db vr user m (MemberKey relayKey) relayProfile
void $ setRelayKey db cxt user m (MemberKey relayKey) relayProfile
pure confId
allowAgentConnectionAsync user conn confId XOk
else
@@ -1313,7 +1313,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
@@ -1336,7 +1336,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 ()
@@ -1361,7 +1361,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, newlyActiveGMIds) <- 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, newlyActiveLinks, newlyActiveGMIds) <- liftIO $ foldrM (updateRelay db) ([], False, [], []) relays
@@ -1374,7 +1374,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} ->
@@ -1385,7 +1385,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
void $ sendGroupMessages user gInfo Nothing False recipients events
-- send the current roster to relays that just became active so they can serve joiners
forM_ newlyActiveGMIds $ \gmId ->
(withStore (\db -> getGroupMemberById db vr user gmId) >>= sendGroupRosterToRelay user gInfo) `catchAllErrors` eToView
(withStore (\db -> getGroupMemberById db cxt user gmId) >>= sendGroupRosterToRelay user gInfo) `catchAllErrors` eToView
where
updateRelay :: DB.Connection -> GroupRelay -> ([GroupRelay], Bool, [ShortLinkContact], [GroupMemberId]) -> IO ([GroupRelay], Bool, [ShortLinkContact], [GroupMemberId])
updateRelay db relay@GroupRelay {groupMemberId, relayLink, relayStatus} (acc, changed, newlyActiveLinks, newlyActiveGMIds) =
@@ -1427,7 +1427,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
@@ -1559,7 +1559,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
@@ -1585,10 +1585,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
@@ -1603,7 +1603,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
memberJoinRequestViaRelay :: InvitationId -> VersionRangeChat -> Maybe SignedMsg -> Profile -> MemberId -> MemberKey -> Maybe MemberId -> CM ()
@@ -1611,8 +1611,8 @@ 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
existing_ <- withStore' $ \db -> eitherToMaybe <$> runExceptT (getGroupMemberByMemberId db vr user gInfo joiningMemberId)
gInfo <- withStore $ \db -> getGroupInfo db cxt user groupId
existing_ <- withStore' $ \db -> eitherToMaybe <$> runExceptT (getGroupMemberByMemberId db cxt user gInfo joiningMemberId)
case existing_ of
Just rosterMem
-- a privileged memberId's key is owner-authoritative (the roster); the joiner must prove
@@ -1800,7 +1800,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
@@ -1816,7 +1816,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
@@ -1889,7 +1889,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
@@ -1897,7 +1897,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}
@@ -2058,7 +2058,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
@@ -2096,13 +2096,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_
@@ -2192,7 +2192,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
@@ -2223,7 +2223,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')
@@ -2335,7 +2335,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_
@@ -2403,14 +2403,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
@@ -2419,7 +2419,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
@@ -2447,7 +2447,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
@@ -2485,7 +2485,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
@@ -2501,7 +2501,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)
@@ -2510,7 +2510,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
@@ -2536,7 +2536,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'
@@ -2577,7 +2577,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}
@@ -2586,7 +2586,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
@@ -2655,7 +2655,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
@@ -2699,7 +2699,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 ()
@@ -2721,7 +2721,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'
@@ -2769,7 +2769,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
@@ -2785,7 +2785,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
@@ -2815,7 +2815,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
@@ -2964,14 +2964,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'
@@ -2981,15 +2981,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)
@@ -3003,7 +3003,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
if sameMemberId memId (membership gInfo)
then pure Nothing
else
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}
-- roster-established privileged member: the relay may update the profile only,
-- never the role or key (those are owner-authoritative via the roster, and
@@ -3016,7 +3016,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
-- TODO [relays] member: surface relay-key-mismatch as a dedicated event / chat item / relay state
when (assertedKey /= memberPubKey unknownMember) $
messageWarning $ "x.grp.mem.new: relay asserted key differs from roster-established key, keeping roster key, memberId=" <> safeDecodeUtf8 (strEncode memId)
updatedMember <- withStore $ \db -> updateRosterMemberAnnounced db vr user m unknownMember memInfo initialStatus
updatedMember <- withStore $ \db -> updateRosterMemberAnnounced db cxt user m unknownMember memInfo initialStatus
-- roster members can't be pending, so no members-require-attention update
gInfo' <- updatePublicGroupData user gInfo
toView $ CEvtUnknownMemberAnnounced user gInfo' m unknownMember updatedMember
@@ -3027,7 +3027,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
messageError "x.grp.mem.new: privileged role not established by roster" $> Nothing
| otherwise -> 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
@@ -3083,10 +3083,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"
@@ -3107,7 +3107,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
@@ -3118,7 +3118,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
@@ -3127,7 +3127,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"
@@ -3138,7 +3138,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.
@@ -3162,7 +3162,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)
@@ -3171,7 +3171,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
-- in relay groups the roster delivers the chat item for previously-unknown privileged members
Left _
@@ -3242,7 +3242,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
let rosterIds = map (\RosterMember {memberId} -> memberId) entries
acc <- foldrM applyRosterEntry ([], []) entries
-- absent privileged members revert to the joiner default
currentPriv <- liftIO $ getGroupRosterMembers db vr user gInfo
currentPriv <- liftIO $ getGroupRosterMembers db cxt user gInfo
liftIO $ forM_ currentPriv $ \m ->
when (memberId' m `notElem` rosterIds) $
updateGroupMemberRole db user m defaultRole
@@ -3253,7 +3253,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
apply `catchAllErrors` \_ -> pure (cs, as)
where
applied m = (cs, ((m :: GroupMember) {memberRole = role}, memberRole' m) : as)
apply = getCreateUnknownGMByMemberId db vr user gInfo memberId name defaultRole True >>= \case
apply = getCreateUnknownGMByMemberId db cxt user gInfo memberId name defaultRole True >>= \case
Nothing -> pure (cs, as)
Just (m, _) -> case memberPubKey m of
Just k
@@ -3311,7 +3311,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
@@ -3335,7 +3335,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
@@ -3357,7 +3357,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}}
@@ -3507,7 +3507,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
@@ -3534,7 +3534,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
@@ -3542,7 +3542,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
@@ -3553,7 +3553,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'
@@ -3562,7 +3562,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
@@ -3593,7 +3593,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)
@@ -3650,8 +3650,12 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
Just sm@SignedMsg {chatBinding, signatures, signedBody}
| GroupMember {memberPubKey = Just pubKey, memberId} <- member ->
case chatBinding of
CBGroup | Just GroupKeys {publicGroupId} <- groupKeys gInfo ->
signed MSSVerified <$ guard (verifyGroupSig pubKey publicGroupId memberId signatures signedBody)
CBGroup
| Just GroupKeys {publicGroupId} <- groupKeys gInfo ->
signed MSSVerified <$ guard (verifyGroupSig pubKey publicGroupId memberId signatures signedBody)
| otherwise ->
let prefix = smpEncode chatBinding <> smpEncode (memberId, pubKey) -- forward compatibility for verifying signed messages in p2p groups
in signed MSSVerified <$ guard (all (\(MsgSignature KRMember sig) -> C.verify (C.APublicVerifyKey C.SEd25519 pubKey) sig (prefix <> signedBody)) signatures)
_ -> signed MSSSignedNoKey <$ guard signatureOptional
| otherwise -> signed MSSSignedNoKey <$ guard (signatureOptional || unverifiedAllowed membership member tag)
where
@@ -3723,7 +3727,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
@@ -3747,14 +3751,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
@@ -3774,20 +3778,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
@@ -3803,7 +3807,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
@@ -3862,19 +3866,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
@@ -3914,7 +3918,7 @@ runDeliveryJobWorker a deliveryKey Worker {doWork} = do
senders <- withStore' $ \db ->
fmap catMaybes . forM senderGMIds $ \sId ->
fmap (join . eitherToMaybe) . runExceptT $ do
sender <- getNonRemovedMemberById db vr user sId
sender <- getNonRemovedMemberById db cxt user sId
-- owners are already known to every member (group link + owner-intro in introduceInChannel),
-- so we never disseminate their profile (redundant, and races with joins re-announcing the owner)
if memberRole' sender == GROwner
@@ -3932,7 +3936,7 @@ runDeliveryJobWorker a deliveryKey Worker {doWork} = do
then pure (body, [], [], [])
else do
-- all members' profiles disseminate; privileged key/role come from the roster, not here
let (encoderErrs, validLabeled) = partitionEithers [(\bs -> (s, bs)) <$> encodeMemberNew vr gInfo s | (s, _) <- senders]
let (encoderErrs, validLabeled) = partitionEithers [(\bs -> (s, bs)) <$> encodeMemberNew (vr cxt) gInfo s | (s, _) <- senders]
(extBody', inBody, overflowLabeled, large1) = batchProfilesWithBody maxEncodedMsgLength body validLabeled
(overflowBatches', large2) = batchProfiles maxEncodedMsgLength overflowLabeled
packerErrs = [ChatError (CEInternalError $ "oversized profile element for member " <> show (groupMemberId' s)) | s <- large1 <> large2]
@@ -3950,7 +3954,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)
@@ -3995,7 +3999,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
@@ -4005,14 +4009,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
@@ -4022,14 +4026,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
@@ -4080,7 +4084,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
@@ -4088,10 +4092,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
@@ -4140,7 +4144,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)
@@ -4168,7 +4172,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 ()
@@ -4200,5 +4204,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
src/Simplex/Chat/Store/Connections.hs
+13 -13
View File
@@ -74,8 +74,8 @@ getChatLockEntity db agentConnId = do
-- TODO consider whether ConnFailed connections should be excluded:
-- - from receiving: getConnectionEntity, getContactConnEntityByConnReqHash
-- - from subscribing: getContactConnsToSub, getUCLConnsToSub, getMemberConnsToSub, getPendingConnsToSub
getConnectionEntity :: DB.Connection -> VersionRangeChat -> User -> AgentConnId -> ExceptT StoreError IO ConnectionEntity
getConnectionEntity db vr user@User {userId, userContactId} agentConnId = do
getConnectionEntity :: DB.Connection -> StoreCxt -> User -> AgentConnId -> ExceptT StoreError IO ConnectionEntity
getConnectionEntity db cxt user@User {userId, userContactId} agentConnId = do
c@Connection {connType, entityId} <- getConnection_
case entityId of
Nothing ->
@@ -90,7 +90,7 @@ getConnectionEntity db vr user@User {userId, userContactId} agentConnId = do
where
getConnection_ :: ExceptT StoreError IO Connection
getConnection_ = ExceptT $ do
firstRow (toConnection vr) (SEConnectionNotFound agentConnId) $
firstRow (toConnection cxt) (SEConnectionNotFound agentConnId) $
DB.query
db
[sql|
@@ -172,7 +172,7 @@ getConnectionEntity db vr user@User {userId, userContactId} agentConnId = do
liftIO $ bitraverse (addGroupChatTags db) pure gm
toGroupAndMember :: Connection -> GroupInfoRow :. GroupMemberRow -> (GroupInfo, GroupMember)
toGroupAndMember c (groupInfoRow :. memberRow) =
let groupInfo = toGroupInfo vr userContactId [] groupInfoRow
let groupInfo = toGroupInfo cxt userContactId [] groupInfoRow
member = toGroupMember userContactId memberRow
in (groupInfo, (member :: GroupMember) {activeConn = Just c})
getUserContact_ :: Int64 -> ExceptT StoreError IO UserContact
@@ -191,17 +191,17 @@ getConnectionEntity db vr user@User {userId, userContactId} agentConnId = do
userContact_ [(cReq, groupId)] = Right UserContact {userContactLinkId, connReqContact = cReq, groupId}
userContact_ _ = Left SEUserContactLinkNotFound
getConnectionEntityByConnReq :: DB.Connection -> VersionRangeChat -> User -> (ConnReqInvitation, ConnReqInvitation) -> IO (Maybe ConnectionEntity)
getConnectionEntityByConnReq db vr user@User {userId} (cReqSchema1, cReqSchema2) = do
getConnectionEntityByConnReq :: DB.Connection -> StoreCxt -> User -> (ConnReqInvitation, ConnReqInvitation) -> IO (Maybe ConnectionEntity)
getConnectionEntityByConnReq db cxt user@User {userId} (cReqSchema1, cReqSchema2) = do
connId_ <-
maybeFirstRow fromOnly $
DB.query db "SELECT agent_conn_id FROM connections WHERE user_id = ? AND conn_req_inv IN (?,?) LIMIT 1" (userId, cReqSchema1, cReqSchema2)
maybe (pure Nothing) (fmap eitherToMaybe . runExceptT . getConnectionEntity db vr user) connId_
maybe (pure Nothing) (fmap eitherToMaybe . runExceptT . getConnectionEntity db cxt user) connId_
getConnectionEntityViaShortLink :: DB.Connection -> VersionRangeChat -> User -> ShortLinkInvitation -> IO (Maybe (ConnReqInvitation, ConnectionEntity))
getConnectionEntityViaShortLink db vr user@User {userId} shortLink = fmap eitherToMaybe $ runExceptT $ do
getConnectionEntityViaShortLink :: DB.Connection -> StoreCxt -> User -> ShortLinkInvitation -> IO (Maybe (ConnReqInvitation, ConnectionEntity))
getConnectionEntityViaShortLink db cxt user@User {userId} shortLink = fmap eitherToMaybe $ runExceptT $ do
(cReq, connId) <- ExceptT getConnReqConnId
(cReq,) <$> getConnectionEntity db vr user connId
(cReq,) <$> getConnectionEntity db cxt user connId
where
getConnReqConnId =
firstRow' toConnReqConnId (SEInternalError "connection not found") $
@@ -222,8 +222,8 @@ getConnectionEntityViaShortLink db vr user@User {userId} shortLink = fmap either
-- multiple connections can have same via_contact_uri_hash if request was repeated;
-- this function searches for latest connection with contact so that "known contact" plan would be chosen;
-- deleted connections are filtered out to allow re-connecting via same contact address
getContactConnEntityByConnReqHash :: DB.Connection -> VersionRangeChat -> User -> (ConnReqUriHash, ConnReqUriHash) -> IO (Maybe ConnectionEntity)
getContactConnEntityByConnReqHash db vr user@User {userId} (cReqHash1, cReqHash2) = do
getContactConnEntityByConnReqHash :: DB.Connection -> StoreCxt -> User -> (ConnReqUriHash, ConnReqUriHash) -> IO (Maybe ConnectionEntity)
getContactConnEntityByConnReqHash db cxt user@User {userId} (cReqHash1, cReqHash2) = do
connId_ <-
maybeFirstRow fromOnly $
DB.query
@@ -240,7 +240,7 @@ getContactConnEntityByConnReqHash db vr user@User {userId} (cReqHash1, cReqHash2
) c
|]
(userId, cReqHash1, cReqHash2, ConnDeleted)
maybe (pure Nothing) (fmap eitherToMaybe . runExceptT . getConnectionEntity db vr user) connId_
maybe (pure Nothing) (fmap eitherToMaybe . runExceptT . getConnectionEntity db cxt user) connId_
getContactConnsToSub :: DB.Connection -> User -> Bool -> IO [ConnId]
getContactConnsToSub db User {userId} filterToSubscribe =
src/Simplex/Chat/Store/ContactRequest.hs
+10 -10
View File
@@ -49,7 +49,7 @@ import Database.SQLite.Simple.QQ (sql)
createOrUpdateContactRequest ::
DB.Connection ->
TVar ChaChaDRG ->
VersionRangeChat ->
StoreCxt ->
User ->
Int64 ->
UserContactLink ->
@@ -65,7 +65,7 @@ createOrUpdateContactRequest ::
createOrUpdateContactRequest
db
gVar
vr
cxt
user@User {userId, userContactId}
uclId
UserContactLink {addressSettings = AddressSettings {businessAddress}}
@@ -89,7 +89,7 @@ createOrUpdateContactRequest
Nothing ->
liftIO (getAcceptedBusinessChat xContactId) >>= \case
Just gInfo@GroupInfo {businessChat = Just BusinessChatInfo {customerId}} -> do
clientMember <- getGroupMemberByMemberId db vr user gInfo customerId
clientMember <- getGroupMemberByMemberId db cxt user gInfo customerId
cr <- liftIO $ getContactRequestByXContactId xContactId
pure $ RSAcceptedRequest cr (REBusinessChat gInfo clientMember)
Just GroupInfo {businessChat = Nothing} -> throwError SEInvalidBusinessChatContactRequest
@@ -104,7 +104,7 @@ createOrUpdateContactRequest
getAcceptedContact :: XContactId -> IO (Maybe Contact)
getAcceptedContact xContactId = do
ct_ <-
maybeFirstRow (toContact vr user []) $
maybeFirstRow (toContact cxt user []) $
DB.query
db
[sql|
@@ -128,7 +128,7 @@ createOrUpdateContactRequest
getAcceptedBusinessChat :: XContactId -> IO (Maybe GroupInfo)
getAcceptedBusinessChat xContactId = do
g_ <-
maybeFirstRow (toGroupInfo vr userContactId []) $
maybeFirstRow (toGroupInfo cxt userContactId []) $
DB.query
db
(groupInfoQuery <> " WHERE g.business_xcontact_id = ? AND g.user_id = ? AND mu.contact_id = ?")
@@ -200,12 +200,12 @@ createOrUpdateContactRequest
"UPDATE contact_requests SET contact_id = ? WHERE contact_request_id = ?"
(contactId, contactRequestId)
ucr <- getContactRequest db user contactRequestId
ct <- getContact db vr user contactId
ct <- getContact db cxt user contactId
pure $ RSCurrentRequest Nothing ucr (Just $ REContact ct)
createBusinessChat = do
let groupPreferences = maybe defaultBusinessGroupPrefs businessGroupPrefs $ preferences' user
(gInfo@GroupInfo {groupId}, clientMember) <-
createBusinessRequestGroup db vr gVar user cReqChatVRange profile profileId ldn groupPreferences
createBusinessRequestGroup db cxt gVar user cReqChatVRange profile profileId ldn groupPreferences
liftIO $
DB.execute
db
@@ -278,13 +278,13 @@ createOrUpdateContactRequest
getRequestEntity UserContactRequest {contactRequestId, contactId_, businessGroupId_} =
case (contactId_, businessGroupId_) of
(Just contactId, Nothing) -> do
ct <- getContact db vr user contactId
ct <- getContact db cxt user contactId
pure $ Just (REContact ct)
(Nothing, Just businessGroupId) -> do
gInfo <- getGroupInfo db vr user businessGroupId
gInfo <- getGroupInfo db cxt user businessGroupId
case gInfo of
GroupInfo {businessChat = Just BusinessChatInfo {customerId}} -> do
clientMember <- getGroupMemberByMemberId db vr user gInfo customerId
clientMember <- getGroupMemberByMemberId db cxt user gInfo customerId
pure $ Just (REBusinessChat gInfo clientMember)
_ -> throwError SEInvalidBusinessChatContactRequest
(Nothing, Nothing) -> pure Nothing
src/Simplex/Chat/Store/Delivery.hs
+5 -5
View File
@@ -348,8 +348,8 @@ updateDeliveryJobStatus_ db jobId status errReason_ = do
(status, errReason_, currentTs, jobId)
-- TODO [relays] possible improvement is to prioritize owners and "active" members
getGroupMembersByCursor :: DB.Connection -> VersionRangeChat -> User -> GroupInfo -> Maybe GroupMemberId -> Maybe GroupMemberId -> Int -> IO [GroupMember]
getGroupMembersByCursor db vr user@User {userContactId} GroupInfo {groupId} cursorGMId_ singleSenderGMId_ count = do
getGroupMembersByCursor :: DB.Connection -> StoreCxt -> User -> GroupInfo -> Maybe GroupMemberId -> Maybe GroupMemberId -> Int -> IO [GroupMember]
getGroupMembersByCursor db cxt user@User {userContactId} GroupInfo {groupId} cursorGMId_ singleSenderGMId_ count = do
gmIds :: [Int64] <-
map fromOnly <$> case cursorGMId_ of
Nothing ->
@@ -367,13 +367,13 @@ getGroupMembersByCursor db vr user@User {userContactId} GroupInfo {groupId} curs
:. (cursorGMId, count)
)
#if defined(dbPostgres)
map (toContactMember vr user) <$>
map (toContactMember cxt user) <$>
DB.query
db
(groupMemberQuery <> " WHERE m.group_member_id IN ?")
(groupMemberQuery <> " WHERE m.group_member_id IN ? ORDER BY m.group_member_id ASC")
(Only (In gmIds))
#else
rights <$> mapM (runExceptT . getGroupMemberById db vr user) gmIds
rights <$> mapM (runExceptT . getGroupMemberById db cxt user) gmIds
#endif
where
query =
src/Simplex/Chat/Store/Direct.hs
+44 -44
View File
@@ -243,8 +243,8 @@ createRelayMemberConnectionAsync db user@User {userId} gInfo GroupMember {groupM
where
customUserProfileId_ = localProfileId <$> incognitoMembershipProfile gInfo
createRelayTestConnection :: DB.Connection -> VersionRangeChat -> User -> ConnId -> ConnStatus -> VersionChat -> SubscriptionMode -> ExceptT StoreError IO Connection
createRelayTestConnection db vr user@User {userId} agentConnId connStatus chatV subMode = do
createRelayTestConnection :: DB.Connection -> StoreCxt -> User -> ConnId -> ConnStatus -> VersionChat -> SubscriptionMode -> ExceptT StoreError IO Connection
createRelayTestConnection db cxt user@User {userId} agentConnId connStatus chatV subMode = do
currentTs <- liftIO getCurrentTime
liftIO $
DB.execute
@@ -261,7 +261,7 @@ createRelayTestConnection db vr user@User {userId} agentConnId connStatus chatV
:. (BI True, currentTs, currentTs)
)
connId <- liftIO $ insertedRowId db
getConnectionById db vr user connId
getConnectionById db cxt user connId
updateConnLinkData :: DB.Connection -> User -> Connection -> ConnReqContact -> ConnReqUriHash -> Maybe GroupLinkId -> VersionChat -> PQSupport -> IO ()
updateConnLinkData db User {userId} Connection {connId} cReq cReqHash groupLinkId_ chatV pqSup = do
@@ -285,13 +285,13 @@ setPreparedGroupStartedConnection db groupId = do
"UPDATE groups SET conn_link_started_connection = ?, updated_at = ? WHERE group_id = ?"
(BI True, currentTs, groupId)
getConnReqContactXContactId :: DB.Connection -> VersionRangeChat -> User -> ConnReqUriHash -> ConnReqUriHash -> IO (Either (Maybe Connection) Contact)
getConnReqContactXContactId db vr user@User {userId} cReqHash1 cReqHash2 =
getContactByConnReqHash db vr user cReqHash1 cReqHash2 >>= maybe (Left <$> getConnection) (pure . Right)
getConnReqContactXContactId :: DB.Connection -> StoreCxt -> User -> ConnReqUriHash -> ConnReqUriHash -> IO (Either (Maybe Connection) Contact)
getConnReqContactXContactId db cxt user@User {userId} cReqHash1 cReqHash2 =
getContactByConnReqHash db cxt user cReqHash1 cReqHash2 >>= maybe (Left <$> getConnection) (pure . Right)
where
getConnection :: IO (Maybe Connection)
getConnection =
maybeFirstRow (toConnection vr) $
maybeFirstRow (toConnection cxt) $
DB.query
db
[sql|
@@ -305,10 +305,10 @@ getConnReqContactXContactId db vr user@User {userId} cReqHash1 cReqHash2 =
|]
(userId, cReqHash1, userId, cReqHash2)
getContactByConnReqHash :: DB.Connection -> VersionRangeChat -> User -> ConnReqUriHash -> ConnReqUriHash -> IO (Maybe Contact)
getContactByConnReqHash db vr user@User {userId} cReqHash1 cReqHash2 = do
getContactByConnReqHash :: DB.Connection -> StoreCxt -> User -> ConnReqUriHash -> ConnReqUriHash -> IO (Maybe Contact)
getContactByConnReqHash db cxt user@User {userId} cReqHash1 cReqHash2 = do
ct <-
maybeFirstRow (toContact vr user []) $
maybeFirstRow (toContact cxt user []) $
DB.query
db
[sql|
@@ -394,18 +394,18 @@ createIncognitoProfile db User {userId} p = do
createdAt <- getCurrentTime
createIncognitoProfile_ db userId createdAt p
createPreparedContact :: DB.Connection -> VersionRangeChat -> User -> Profile -> ACreatedConnLink -> Maybe SharedMsgId -> ExceptT StoreError IO Contact
createPreparedContact db vr user p connLinkToConnect welcomeSharedMsgId = do
createPreparedContact :: DB.Connection -> StoreCxt -> User -> Profile -> ACreatedConnLink -> Maybe SharedMsgId -> ExceptT StoreError IO Contact
createPreparedContact db cxt user p connLinkToConnect welcomeSharedMsgId = do
currentTs <- liftIO getCurrentTime
let prepared = Just (connLinkToConnect, welcomeSharedMsgId)
ctUserPreferences = newContactUserPrefs user p
contactId <- createContact_ db user p ctUserPreferences prepared "" currentTs
getContact db vr user contactId
getContact db cxt user contactId
updatePreparedContactUser :: DB.Connection -> VersionRangeChat -> User -> Contact -> User -> ExceptT StoreError IO Contact
updatePreparedContactUser :: DB.Connection -> StoreCxt -> User -> Contact -> User -> ExceptT StoreError IO Contact
updatePreparedContactUser
db
vr
cxt
user
Contact {contactId, localDisplayName = oldLDN, profile = profile@LocalProfile {profileId, displayName}}
newUser@User {userId = newUserId} = do
@@ -438,15 +438,15 @@ updatePreparedContactUser
|]
(newUserId, currentTs, contactId)
safeDeleteLDN db user oldLDN
getContact db vr newUser contactId
getContact db cxt newUser contactId
createDirectContact :: DB.Connection -> VersionRangeChat -> User -> Connection -> Profile -> ExceptT StoreError IO Contact
createDirectContact db vr user Connection {connId, localAlias} p = do
createDirectContact :: DB.Connection -> StoreCxt -> User -> Connection -> Profile -> ExceptT StoreError IO Contact
createDirectContact db cxt user Connection {connId, localAlias} p = do
currentTs <- liftIO getCurrentTime
let ctUserPreferences = newContactUserPrefs user p
contactId <- createContact_ db user p ctUserPreferences Nothing localAlias currentTs
liftIO $ DB.execute db "UPDATE connections SET contact_id = ?, updated_at = ? WHERE connection_id = ?" (contactId, currentTs, connId)
getContact db vr user contactId
getContact db cxt user contactId
deleteContactConnections :: DB.Connection -> User -> Contact -> IO ()
deleteContactConnections db User {userId} Contact {contactId} = do
@@ -500,13 +500,13 @@ deleteContactWithoutGroups db user@User {userId} ct@Contact {contactId, localDis
deleteUnusedIncognitoProfileById_ db user profileId
-- TODO remove in future versions: only used for legacy contact cleanup
getDeletedContacts :: DB.Connection -> VersionRangeChat -> User -> IO [Contact]
getDeletedContacts db vr user@User {userId} = do
getDeletedContacts :: DB.Connection -> StoreCxt -> User -> IO [Contact]
getDeletedContacts db cxt user@User {userId} = do
contactIds <- map fromOnly <$> DB.query db "SELECT contact_id FROM contacts WHERE user_id = ? AND deleted = 1" (Only userId)
rights <$> mapM (runExceptT . getDeletedContact db vr user) contactIds
rights <$> mapM (runExceptT . getDeletedContact db cxt user) contactIds
getDeletedContact :: DB.Connection -> VersionRangeChat -> User -> Int64 -> ExceptT StoreError IO Contact
getDeletedContact db vr user contactId = getContact_ db vr user contactId True
getDeletedContact :: DB.Connection -> StoreCxt -> User -> Int64 -> ExceptT StoreError IO Contact
getDeletedContact db cxt user contactId = getContact_ db cxt user contactId True
deleteContactProfile_ :: DB.Connection -> UserId -> ContactId -> IO ()
deleteContactProfile_ db userId contactId =
@@ -756,15 +756,15 @@ updateContactLDN_ db user@User {userId} contactId displayName newName updatedAt
(newName, updatedAt, userId, contactId)
safeDeleteLDN db user displayName
getContactByName :: DB.Connection -> VersionRangeChat -> User -> ContactName -> ExceptT StoreError IO Contact
getContactByName db vr user localDisplayName = do
getContactByName :: DB.Connection -> StoreCxt -> User -> ContactName -> ExceptT StoreError IO Contact
getContactByName db cxt user localDisplayName = do
cId <- getContactIdByName db user localDisplayName
getContact db vr user cId
getContact db cxt user cId
getUserContacts :: DB.Connection -> VersionRangeChat -> User -> IO [Contact]
getUserContacts db vr user@User {userId} = do
getUserContacts :: DB.Connection -> StoreCxt -> User -> IO [Contact]
getUserContacts db cxt user@User {userId} = do
contactIds <- map fromOnly <$> DB.query db "SELECT contact_id FROM contacts WHERE user_id = ? AND deleted = 0" (Only userId)
contacts <- rights <$> mapM (runExceptT . getContact db vr user) contactIds
contacts <- rights <$> mapM (runExceptT . getContact db cxt user) contactIds
pure $ filter (\Contact {activeConn} -> isJust activeConn) contacts
getUserContactLinkIdByCReq :: DB.Connection -> Int64 -> ExceptT StoreError IO (Maybe Int64)
@@ -890,22 +890,22 @@ getContactIdByName db User {userId} cName =
ExceptT . firstRow fromOnly (SEContactNotFoundByName cName) $
DB.query db "SELECT contact_id FROM contacts WHERE user_id = ? AND local_display_name = ? AND deleted = 0" (userId, cName)
getContactViaShortLinkToConnect :: forall c. ConnectionModeI c => DB.Connection -> VersionRangeChat -> User -> ConnShortLink c -> ExceptT StoreError IO (Maybe (ConnectionRequestUri c, Contact))
getContactViaShortLinkToConnect db vr user@User {userId} shortLink = do
getContactViaShortLinkToConnect :: forall c. ConnectionModeI c => DB.Connection -> StoreCxt -> User -> ConnShortLink c -> ExceptT StoreError IO (Maybe (ConnectionRequestUri c, Contact))
getContactViaShortLinkToConnect db cxt user@User {userId} shortLink = do
liftIO (maybeFirstRow id $ DB.query db "SELECT contact_id, conn_full_link_to_connect FROM contacts WHERE user_id = ? AND conn_short_link_to_connect = ?" (userId, shortLink)) >>= \case
Just (ctId :: Int64, Just (ACR cMode cReq)) ->
case testEquality cMode (sConnectionMode @c) of
Just Refl -> Just . (cReq,) <$> getContact db vr user ctId
Just Refl -> Just . (cReq,) <$> getContact db cxt user ctId
Nothing -> pure Nothing
_ -> pure Nothing
getContact :: DB.Connection -> VersionRangeChat -> User -> Int64 -> ExceptT StoreError IO Contact
getContact db vr user contactId = getContact_ db vr user contactId False
getContact :: DB.Connection -> StoreCxt -> User -> Int64 -> ExceptT StoreError IO Contact
getContact db cxt user contactId = getContact_ db cxt user contactId False
getContact_ :: DB.Connection -> VersionRangeChat -> User -> Int64 -> Bool -> ExceptT StoreError IO Contact
getContact_ db vr user@User {userId} contactId deleted = do
getContact_ :: DB.Connection -> StoreCxt -> User -> Int64 -> Bool -> ExceptT StoreError IO Contact
getContact_ db cxt user@User {userId} contactId deleted = do
chatTags <- liftIO $ getDirectChatTags db contactId
ExceptT . firstRow (toContact vr user chatTags) (SEContactNotFound contactId) $
ExceptT . firstRow (toContact cxt user chatTags) (SEContactNotFound contactId) $
DB.query
db
[sql|
@@ -932,8 +932,8 @@ getUserByContactRequestId db contactRequestId =
ExceptT . firstRow toUser (SEUserNotFoundByContactRequestId contactRequestId) $
DB.query db (userQuery <> " JOIN contact_requests cr ON cr.user_id = u.user_id WHERE cr.contact_request_id = ?") (Only contactRequestId)
getContactConnections :: DB.Connection -> VersionRangeChat -> UserId -> Contact -> IO [Connection]
getContactConnections db vr userId Contact {contactId} =
getContactConnections :: DB.Connection -> StoreCxt -> UserId -> Contact -> IO [Connection]
getContactConnections db cxt userId Contact {contactId} =
connections =<< liftIO getConnections_
where
getConnections_ =
@@ -950,11 +950,11 @@ getContactConnections db vr userId Contact {contactId} =
|]
(userId, userId, contactId)
connections [] = pure []
connections rows = pure $ map (toConnection vr) rows
connections rows = pure $ map (toConnection cxt) rows
getConnectionById :: DB.Connection -> VersionRangeChat -> User -> Int64 -> ExceptT StoreError IO Connection
getConnectionById db vr User {userId} connId = ExceptT $ do
firstRow (toConnection vr) (SEConnectionNotFoundById connId) $
getConnectionById :: DB.Connection -> StoreCxt -> User -> Int64 -> ExceptT StoreError IO Connection
getConnectionById db cxt User {userId} connId = ExceptT $ do
firstRow (toConnection cxt) (SEConnectionNotFoundById connId) $
DB.query
db
[sql|
src/Simplex/Chat/Store/Files.hs
+9 -9
View File
@@ -570,19 +570,19 @@ getRcvFileTransfer_ db userId fileId = do
Just fp -> pure fp
cancelled = maybe False unBI cancelled_
acceptRcvInlineFT :: DB.Connection -> VersionRangeChat -> User -> FileTransferId -> FilePath -> ExceptT StoreError IO AChatItem
acceptRcvInlineFT db vr user fileId filePath = do
acceptRcvInlineFT :: DB.Connection -> StoreCxt -> User -> FileTransferId -> FilePath -> ExceptT StoreError IO AChatItem
acceptRcvInlineFT db cxt user fileId filePath = do
liftIO $ acceptRcvFT_ db user fileId filePath False (Just IFMOffer) =<< getCurrentTime
getChatItemByFileId db vr user fileId
getChatItemByFileId db cxt user fileId
startRcvInlineFT :: DB.Connection -> User -> RcvFileTransfer -> FilePath -> Maybe InlineFileMode -> IO ()
startRcvInlineFT db user RcvFileTransfer {fileId} filePath rcvFileInline =
acceptRcvFT_ db user fileId filePath False rcvFileInline =<< getCurrentTime
xftpAcceptRcvFT :: DB.Connection -> VersionRangeChat -> User -> FileTransferId -> FilePath -> Bool -> ExceptT StoreError IO AChatItem
xftpAcceptRcvFT db vr user fileId filePath userApprovedRelays = do
xftpAcceptRcvFT :: DB.Connection -> StoreCxt -> User -> FileTransferId -> FilePath -> Bool -> ExceptT StoreError IO AChatItem
xftpAcceptRcvFT db cxt user fileId filePath userApprovedRelays = do
liftIO $ acceptRcvFT_ db user fileId filePath userApprovedRelays Nothing =<< getCurrentTime
getChatItemByFileId db vr user fileId
getChatItemByFileId db cxt user fileId
acceptRcvFT_ :: DB.Connection -> User -> FileTransferId -> FilePath -> Bool -> Maybe InlineFileMode -> UTCTime -> IO ()
acceptRcvFT_ db User {userId} fileId filePath userApprovedRelays rcvFileInline currentTs = do
@@ -860,9 +860,9 @@ getLocalCryptoFile db userId fileId sent =
pure $ CryptoFile filePath fileCryptoArgs
_ -> throwError $ SEFileNotFound fileId
updateDirectCIFileStatus :: forall d. MsgDirectionI d => DB.Connection -> VersionRangeChat -> User -> Int64 -> CIFileStatus d -> ExceptT StoreError IO AChatItem
updateDirectCIFileStatus db vr user fileId fileStatus = do
aci@(AChatItem cType d cInfo ci) <- getChatItemByFileId db vr user fileId
updateDirectCIFileStatus :: forall d. MsgDirectionI d => DB.Connection -> StoreCxt -> User -> Int64 -> CIFileStatus d -> ExceptT StoreError IO AChatItem
updateDirectCIFileStatus db cxt user fileId fileStatus = do
aci@(AChatItem cType d cInfo ci) <- getChatItemByFileId db cxt user fileId
case (cType, testEquality d $ msgDirection @d) of
(SCTDirect, Just Refl) -> do
liftIO $ updateCIFileStatus db user fileId fileStatus
src/Simplex/Chat/Store/Groups.hs
+222 -222
View File
@@ -258,9 +258,9 @@ createGroupLink db gVar user@User {userId} groupInfo@GroupInfo {groupId, localDi
void $ createConnection_ db userId ConnUserContact (Just userContactLinkId) agentConnId ConnNew initialChatVersion chatInitialVRange Nothing Nothing Nothing 0 currentTs subMode PQSupportOff
getGroupLink db user groupInfo
getGroupLinkConnection :: DB.Connection -> VersionRangeChat -> User -> GroupInfo -> ExceptT StoreError IO Connection
getGroupLinkConnection db vr User {userId} groupInfo@GroupInfo {groupId} =
ExceptT . firstRow (toConnection vr) (SEGroupLinkNotFound groupInfo) $
getGroupLinkConnection :: DB.Connection -> StoreCxt -> User -> GroupInfo -> ExceptT StoreError IO Connection
getGroupLinkConnection db cxt User {userId} groupInfo@GroupInfo {groupId} =
ExceptT . firstRow (toConnection cxt) (SEGroupLinkNotFound groupInfo) $
DB.query
db
[sql|
@@ -355,8 +355,8 @@ setGroupLinkShortLink db gLnk@GroupLink {userContactLinkId, connLinkContact = CC
pure gLnk {connLinkContact = CCLink connFullLink (Just shortLink), shortLinkDataSet = True, shortLinkLargeDataSet = BoolDef True}
-- | creates completely new group with a single member - the current user
createNewGroup :: DB.Connection -> VersionRangeChat -> User -> GroupProfile -> Maybe Profile -> Bool -> MemberId -> Maybe GroupKeys -> Maybe Int64 -> ExceptT StoreError IO GroupInfo
createNewGroup db vr user@User {userId} groupProfile incognitoProfile useRelays memberId groupKeys publicMemberCount_ = ExceptT $ do
createNewGroup :: DB.Connection -> StoreCxt -> User -> GroupProfile -> Maybe Profile -> Bool -> MemberId -> Maybe GroupKeys -> Maybe Int64 -> ExceptT StoreError IO GroupInfo
createNewGroup db cxt user@User {userId} groupProfile incognitoProfile useRelays memberId groupKeys publicMemberCount_ = ExceptT $ do
let GroupProfile {displayName, fullName, shortDescr, description, image, publicGroup, groupPreferences, memberAdmission} = groupProfile
(groupType_, groupLink_, publicGroupId_) = case publicGroup of
Just PublicGroupProfile {groupType, groupLink, publicGroupId} -> (Just groupType, Just groupLink, Just publicGroupId)
@@ -401,7 +401,7 @@ createNewGroup db vr user@User {userId} groupProfile incognitoProfile useRelays
)
insertedRowId db
let memberPubKey = C.publicKey . memberPrivKey <$> groupKeys
membership <- createContactMemberInv_ db user groupId Nothing user (MemberIdRole memberId GROwner) GCUserMember GSMemCreator IBUser customUserProfileId memberPubKey currentTs vr
membership <- createContactMemberInv_ db user groupId Nothing user (MemberIdRole memberId GROwner) GCUserMember GSMemCreator IBUser customUserProfileId memberPubKey currentTs (vr cxt)
let chatSettings = ChatSettings {enableNtfs = MFAll, sendRcpts = Nothing, favorite = False}
pure
GroupInfo
@@ -432,13 +432,13 @@ createNewGroup db vr user@User {userId} groupProfile incognitoProfile useRelays
}
-- | creates a new group record for the group the current user was invited to, or returns an existing one
createGroupInvitation :: DB.Connection -> VersionRangeChat -> User -> Contact -> GroupInvitation -> Maybe ProfileId -> ExceptT StoreError IO (GroupInfo, GroupMemberId)
createGroupInvitation :: DB.Connection -> StoreCxt -> User -> Contact -> GroupInvitation -> Maybe ProfileId -> ExceptT StoreError IO (GroupInfo, GroupMemberId)
createGroupInvitation _ _ _ Contact {localDisplayName, activeConn = Nothing} _ _ = throwError $ SEContactNotReady localDisplayName
createGroupInvitation db vr user@User {userId} contact@Contact {contactId, activeConn = Just Connection {peerChatVRange}} GroupInvitation {fromMember, invitedMember, connRequest, groupProfile, business} incognitoProfileId = do
createGroupInvitation db cxt user@User {userId} contact@Contact {contactId, activeConn = Just Connection {peerChatVRange}} GroupInvitation {fromMember, invitedMember, connRequest, groupProfile, business} incognitoProfileId = do
liftIO getInvitationGroupId_ >>= \case
Nothing -> createGroupInvitation_
Just gId -> do
gInfo@GroupInfo {membership, groupProfile = p'} <- getGroupInfo db vr user gId
gInfo@GroupInfo {membership, groupProfile = p'} <- getGroupInfo db cxt user gId
hostId <- getHostMemberId_ db user gId
let GroupMember {groupMemberId, memberId, memberRole} = membership
MemberIdRole {memberId = invMemberId, memberRole = invMemberRole} = invitedMember
@@ -477,9 +477,9 @@ createGroupInvitation db vr user@User {userId} contact@Contact {contactId, activ
|]
((profileId, localDisplayName, connRequest, userId, BI True, currentTs, currentTs, currentTs, currentTs) :. businessChatInfoRow business)
insertedRowId db
let hostVRange = adjustedMemberVRange vr peerChatVRange
let hostVRange = adjustedMemberVRange (vr cxt) peerChatVRange
GroupMember {groupMemberId} <- createContactMemberInv_ db user groupId Nothing contact fromMember GCHostMember GSMemInvited IBUnknown Nothing Nothing currentTs hostVRange
membership <- createContactMemberInv_ db user groupId (Just groupMemberId) user invitedMember GCUserMember GSMemInvited (IBContact contactId) incognitoProfileId Nothing currentTs vr
membership <- createContactMemberInv_ db user groupId (Just groupMemberId) user invitedMember GCUserMember GSMemInvited (IBContact contactId) incognitoProfileId Nothing currentTs (vr cxt)
let chatSettings = ChatSettings {enableNtfs = MFAll, sendRcpts = Nothing, favorite = False}
pure
( GroupInfo
@@ -622,8 +622,8 @@ deleteContactCardKeepConn db connId Contact {contactId, profile = LocalProfile {
DB.execute db "DELETE FROM contacts WHERE contact_id = ?" (Only contactId)
DB.execute db "DELETE FROM contact_profiles WHERE contact_profile_id = ?" (Only profileId)
createPreparedGroup :: DB.Connection -> TVar ChaChaDRG -> VersionRangeChat -> User -> GroupProfile -> Bool -> CreatedLinkContact -> Maybe SharedMsgId -> Bool -> GroupMemberRole -> Maybe Int64 -> ExceptT StoreError IO (GroupInfo, Maybe GroupMember)
createPreparedGroup db gVar vr user@User {userId, userContactId} groupProfile business connLinkToConnect welcomeSharedMsgId useRelays userMemberRole publicMemberCount_ = do
createPreparedGroup :: DB.Connection -> TVar ChaChaDRG -> StoreCxt -> User -> GroupProfile -> Bool -> CreatedLinkContact -> Maybe SharedMsgId -> Bool -> GroupMemberRole -> Maybe Int64 -> ExceptT StoreError IO (GroupInfo, Maybe GroupMember)
createPreparedGroup db gVar cxt user@User {userId, userContactId} groupProfile business connLinkToConnect welcomeSharedMsgId useRelays userMemberRole publicMemberCount_ = do
currentTs <- liftIO getCurrentTime
let prepared = Just (connLinkToConnect, welcomeSharedMsgId)
(groupId, groupLDN) <- createGroup_ db userId groupProfile prepared Nothing useRelays Nothing publicMemberCount_ currentTs
@@ -637,11 +637,11 @@ createPreparedGroup db gVar vr user@User {userId, userContactId} groupProfile bu
else pure $ MemberId $ encodeUtf8 groupLDN <> "_user_unknown_id"
let userMember = MemberIdRole userMemberId userMemberRole
-- TODO [member keys] user key must be included here. Should key be added when group is prepared?
membership <- createContactMemberInv_ db user groupId hostMemberId_ user userMember GCUserMember GSMemUnknown IBUnknown Nothing Nothing currentTs vr
hostMember_ <- forM hostMemberId_ $ getGroupMember db vr user groupId
membership <- createContactMemberInv_ db user groupId hostMemberId_ user userMember GCUserMember GSMemUnknown IBUnknown Nothing Nothing currentTs (vr cxt)
hostMember_ <- forM hostMemberId_ $ getGroupMember db cxt user groupId
forM_ hostMember_ $ \hostMember ->
when business $ liftIO $ setGroupBusinessChatInfo groupId membership hostMember
g <- getGroupInfo db vr user groupId
g <- getGroupInfo db cxt user groupId
pure (g, hostMember_)
where
insertHost_ currentTs groupId groupLDN = do
@@ -681,13 +681,13 @@ updateBusinessChatInfo db groupId businessChatInfo =
|]
(businessChatInfoRow businessChatInfo :. (Only groupId))
updatePreparedGroupUser :: DB.Connection -> VersionRangeChat -> User -> GroupInfo -> Maybe GroupMember -> User -> ExceptT StoreError IO GroupInfo
updatePreparedGroupUser db vr user gInfo@GroupInfo {groupId, membership} hostMember_ newUser@User {userId = newUserId} = do
updatePreparedGroupUser :: DB.Connection -> StoreCxt -> User -> GroupInfo -> Maybe GroupMember -> User -> ExceptT StoreError IO GroupInfo
updatePreparedGroupUser db cxt user gInfo@GroupInfo {groupId, membership} hostMember_ newUser@User {userId = newUserId} = do
currentTs <- liftIO getCurrentTime
updateGroup gInfo currentTs
liftIO $ updateMembership membership currentTs
forM_ hostMember_ $ \hostMember -> updateHostMember hostMember currentTs
getGroupInfo db vr newUser groupId
getGroupInfo db cxt newUser groupId
where
updateGroup GroupInfo {localDisplayName = oldGroupLDN, groupProfile = GroupProfile {displayName = groupDisplayName}} currentTs =
ExceptT . withLocalDisplayName db newUserId groupDisplayName $ \newGroupLDN -> runExceptT $ do
@@ -753,21 +753,21 @@ updatePreparedGroupUser db vr user gInfo@GroupInfo {groupId, membership} hostMem
(newUserId, currentTs, hostProfileId)
safeDeleteLDN db user oldHostLDN
updatePreparedUserAndHostMembersInvited :: DB.Connection -> VersionRangeChat -> User -> GroupInfo -> GroupMember -> GroupLinkInvitation -> ExceptT StoreError IO (GroupInfo, GroupMember)
updatePreparedUserAndHostMembersInvited db vr user gInfo hostMember GroupLinkInvitation {fromMember, fromMemberName, invitedMember, groupProfile, accepted, business} = do
updatePreparedUserAndHostMembersInvited :: DB.Connection -> StoreCxt -> User -> GroupInfo -> GroupMember -> GroupLinkInvitation -> ExceptT StoreError IO (GroupInfo, GroupMember)
updatePreparedUserAndHostMembersInvited db cxt user gInfo hostMember GroupLinkInvitation {fromMember, fromMemberName, invitedMember, groupProfile, accepted, business} = do
let fromMemberProfile = profileFromName fromMemberName
initialStatus = maybe GSMemAccepted (acceptanceToStatus $ memberAdmission groupProfile) accepted
updatePreparedUserAndHostMembers' db vr user gInfo hostMember fromMember fromMemberProfile invitedMember groupProfile business initialStatus
updatePreparedUserAndHostMembers' db cxt user gInfo hostMember fromMember fromMemberProfile invitedMember groupProfile business initialStatus
updatePreparedUserAndHostMembersRejected :: DB.Connection -> VersionRangeChat -> User -> GroupInfo -> GroupMember -> GroupLinkRejection -> ExceptT StoreError IO (GroupInfo, GroupMember)
updatePreparedUserAndHostMembersRejected db vr user gInfo hostMember GroupLinkRejection {fromMember = fromMember@MemberIdRole {memberId}, invitedMember, groupProfile} = do
updatePreparedUserAndHostMembersRejected :: DB.Connection -> StoreCxt -> User -> GroupInfo -> GroupMember -> GroupLinkRejection -> ExceptT StoreError IO (GroupInfo, GroupMember)
updatePreparedUserAndHostMembersRejected db cxt user gInfo hostMember GroupLinkRejection {fromMember = fromMember@MemberIdRole {memberId}, invitedMember, groupProfile} = do
let fromMemberProfile = profileFromName $ nameFromMemberId memberId
updatePreparedUserAndHostMembers' db vr user gInfo hostMember fromMember fromMemberProfile invitedMember groupProfile Nothing GSMemRejected
updatePreparedUserAndHostMembers' db cxt user gInfo hostMember fromMember fromMemberProfile invitedMember groupProfile Nothing GSMemRejected
updatePreparedUserAndHostMembers' :: DB.Connection -> VersionRangeChat -> User -> GroupInfo -> GroupMember -> MemberIdRole -> Profile -> MemberIdRole -> GroupProfile -> Maybe BusinessChatInfo -> GroupMemberStatus -> ExceptT StoreError IO (GroupInfo, GroupMember)
updatePreparedUserAndHostMembers' :: DB.Connection -> StoreCxt -> User -> GroupInfo -> GroupMember -> MemberIdRole -> Profile -> MemberIdRole -> GroupProfile -> Maybe BusinessChatInfo -> GroupMemberStatus -> ExceptT StoreError IO (GroupInfo, GroupMember)
updatePreparedUserAndHostMembers'
db
vr
cxt
user
gInfo@GroupInfo {groupId, membership, groupProfile = gp, businessChat}
hostMember
@@ -786,7 +786,7 @@ updatePreparedUserAndHostMembers'
void $ updateGroupProfile db user gInfo groupProfile
when (isJust businessChat && isJust business) $
liftIO $ updateBusinessChatInfo db groupId business
gInfo' <- getGroupInfo db vr user groupId
gInfo' <- getGroupInfo db cxt user groupId
pure (gInfo', hostMember')
where
updateUserMember currentTs = do
@@ -817,23 +817,23 @@ updatePreparedUserAndHostMembers'
WHERE group_member_id = ?
|]
(memberId, memberRole, currentTs, gmId)
getGroupMemberById db vr user gmId
getGroupMemberById db cxt user gmId
createGroupInvitedViaLink :: DB.Connection -> VersionRangeChat -> User -> Connection -> GroupLinkInvitation -> ExceptT StoreError IO (GroupInfo, GroupMember)
createGroupInvitedViaLink db vr user conn GroupLinkInvitation {fromMember, fromMemberName, invitedMember, groupProfile, accepted, business} = do
createGroupInvitedViaLink :: DB.Connection -> StoreCxt -> User -> Connection -> GroupLinkInvitation -> ExceptT StoreError IO (GroupInfo, GroupMember)
createGroupInvitedViaLink db cxt user conn GroupLinkInvitation {fromMember, fromMemberName, invitedMember, groupProfile, accepted, business} = do
let fromMemberProfile = profileFromName fromMemberName
initialStatus = maybe GSMemAccepted (acceptanceToStatus $ memberAdmission groupProfile) accepted
createGroupViaLink' db vr user conn fromMember fromMemberProfile invitedMember groupProfile business initialStatus
createGroupViaLink' db cxt user conn fromMember fromMemberProfile invitedMember groupProfile business initialStatus
createGroupRejectedViaLink :: DB.Connection -> VersionRangeChat -> User -> Connection -> GroupLinkRejection -> ExceptT StoreError IO (GroupInfo, GroupMember)
createGroupRejectedViaLink db vr user conn GroupLinkRejection {fromMember = fromMember@MemberIdRole {memberId}, invitedMember, groupProfile} = do
createGroupRejectedViaLink :: DB.Connection -> StoreCxt -> User -> Connection -> GroupLinkRejection -> ExceptT StoreError IO (GroupInfo, GroupMember)
createGroupRejectedViaLink db cxt user conn GroupLinkRejection {fromMember = fromMember@MemberIdRole {memberId}, invitedMember, groupProfile} = do
let fromMemberProfile = profileFromName $ nameFromMemberId memberId
createGroupViaLink' db vr user conn fromMember fromMemberProfile invitedMember groupProfile Nothing GSMemRejected
createGroupViaLink' db cxt user conn fromMember fromMemberProfile invitedMember groupProfile Nothing GSMemRejected
createGroupViaLink' :: DB.Connection -> VersionRangeChat -> User -> Connection -> MemberIdRole -> Profile -> MemberIdRole -> GroupProfile -> Maybe BusinessChatInfo -> GroupMemberStatus -> ExceptT StoreError IO (GroupInfo, GroupMember)
createGroupViaLink' :: DB.Connection -> StoreCxt -> User -> Connection -> MemberIdRole -> Profile -> MemberIdRole -> GroupProfile -> Maybe BusinessChatInfo -> GroupMemberStatus -> ExceptT StoreError IO (GroupInfo, GroupMember)
createGroupViaLink'
db
vr
cxt
user@User {userId, userContactId}
Connection {connId, customUserProfileId}
fromMember
@@ -848,9 +848,9 @@ createGroupViaLink'
liftIO $ DB.execute db "UPDATE connections SET conn_type = ?, group_member_id = ?, updated_at = ? WHERE connection_id = ?" (ConnMember, hostMemberId, currentTs, connId)
-- using IBUnknown since host is created without contact
-- TODO [member keys] this is currently not used with public groups. If it needs to be used, member keys need to be added
void $ createContactMemberInv_ db user groupId (Just hostMemberId) user invitedMember GCUserMember membershipStatus IBUnknown customUserProfileId Nothing currentTs vr
void $ createContactMemberInv_ db user groupId (Just hostMemberId) user invitedMember GCUserMember membershipStatus IBUnknown customUserProfileId Nothing currentTs (vr cxt)
liftIO $ setViaGroupLinkUri db groupId connId
(,) <$> getGroupInfo db vr user groupId <*> getGroupMemberById db vr user hostMemberId
(,) <$> getGroupInfo db cxt user groupId <*> getGroupMemberById db cxt user hostMemberId
where
insertHost_ currentTs groupId = do
(localDisplayName, profileId) <- createNewMemberProfile_ db user fromMemberProfile currentTs
@@ -911,10 +911,10 @@ setGroupInvitationChatItemId db User {userId} groupId chatItemId = do
-- TODO return the last connection that is ready, not any last connection
-- requires updating connection status
getGroup :: DB.Connection -> VersionRangeChat -> User -> GroupId -> ExceptT StoreError IO Group
getGroup db vr user groupId = do
gInfo <- getGroupInfo db vr user groupId
members <- liftIO $ getGroupMembers db vr user gInfo
getGroup :: DB.Connection -> StoreCxt -> User -> GroupId -> ExceptT StoreError IO Group
getGroup db cxt user groupId = do
gInfo <- getGroupInfo db cxt user groupId
members <- liftIO $ getGroupMembers db cxt user gInfo
pure $ Group gInfo members
deleteGroupChatItems :: DB.Connection -> User -> GroupInfo -> IO ()
@@ -1008,18 +1008,18 @@ deleteGroupProfile_ db userId groupId =
|]
(userId, groupId)
getInProgressGroups :: DB.Connection -> VersionRangeChat -> User -> UTCTime -> IO [GroupInfo]
getInProgressGroups db vr user@User {userId} createdAtCutoff = do
getInProgressGroups :: DB.Connection -> StoreCxt -> User -> UTCTime -> IO [GroupInfo]
getInProgressGroups db cxt user@User {userId} createdAtCutoff = do
groupIds <- map fromOnly <$>
DB.query
db
"SELECT group_id FROM groups WHERE user_id = ? AND creating_in_progress = 1 AND created_at <= ?"
(userId, createdAtCutoff)
rights <$> mapM (runExceptT . getGroupInfo db vr user) groupIds
rights <$> mapM (runExceptT . getGroupInfo db cxt user) groupIds
getBaseGroupDetails :: DB.Connection -> VersionRangeChat -> User -> Maybe ContactId -> Maybe Text -> IO [GroupInfo]
getBaseGroupDetails db vr User {userId, userContactId} _contactId_ search_ = do
map (toGroupInfo vr userContactId [])
getBaseGroupDetails :: DB.Connection -> StoreCxt -> User -> Maybe ContactId -> Maybe Text -> IO [GroupInfo]
getBaseGroupDetails db cxt User {userId, userContactId} _contactId_ search_ = do
map (toGroupInfo cxt userContactId [])
<$> DB.query db (groupInfoQuery <> " " <> condition) (userId, userContactId, search, search, search, search)
where
condition =
@@ -1047,22 +1047,22 @@ getContactGroupPreferences db User {userId} Contact {contactId} = do
|]
(userId, contactId)
getGroupInfoByName :: DB.Connection -> VersionRangeChat -> User -> GroupName -> ExceptT StoreError IO GroupInfo
getGroupInfoByName db vr user gName = do
getGroupInfoByName :: DB.Connection -> StoreCxt -> User -> GroupName -> ExceptT StoreError IO GroupInfo
getGroupInfoByName db cxt user gName = do
gId <- getGroupIdByName db user gName
getGroupInfo db vr user gId
getGroupInfo db cxt user gId
getGroupMember :: DB.Connection -> VersionRangeChat -> User -> GroupId -> GroupMemberId -> ExceptT StoreError IO GroupMember
getGroupMember db vr user@User {userId} groupId groupMemberId =
ExceptT . firstRow (toContactMember vr user) (SEGroupMemberNotFound groupMemberId) $
getGroupMember :: DB.Connection -> StoreCxt -> User -> GroupId -> GroupMemberId -> ExceptT StoreError IO GroupMember
getGroupMember db cxt user@User {userId} groupId groupMemberId =
ExceptT . firstRow (toContactMember cxt user) (SEGroupMemberNotFound groupMemberId) $
DB.query
db
(groupMemberQuery <> " WHERE m.group_id = ? AND m.group_member_id = ? AND m.user_id = ?")
(groupId, groupMemberId, userId)
getHostMember :: DB.Connection -> VersionRangeChat -> User -> GroupId -> ExceptT StoreError IO GroupMember
getHostMember db vr user groupId =
ExceptT . firstRow (toContactMember vr user) (SEGroupHostMemberNotFound groupId) $
getHostMember :: DB.Connection -> StoreCxt -> User -> GroupId -> ExceptT StoreError IO GroupMember
getHostMember db cxt user groupId =
ExceptT . firstRow (toContactMember cxt user) (SEGroupHostMemberNotFound groupId) $
DB.query
db
(groupMemberQuery <> " WHERE m.group_id = ? AND m.member_category = ?")
@@ -1101,54 +1101,54 @@ toMentionedMember (groupMemberId, memberId, memberRole, displayName, localAlias)
let memberRef = Just CIMentionMember {groupMemberId, displayName, localAlias, memberRole}
in CIMention {memberId, memberRef}
getGroupMemberById :: DB.Connection -> VersionRangeChat -> User -> GroupMemberId -> ExceptT StoreError IO GroupMember
getGroupMemberById db vr user@User {userId} groupMemberId =
ExceptT . firstRow (toContactMember vr user) (SEGroupMemberNotFound groupMemberId) $
getGroupMemberById :: DB.Connection -> StoreCxt -> User -> GroupMemberId -> ExceptT StoreError IO GroupMember
getGroupMemberById db cxt user@User {userId} groupMemberId =
ExceptT . firstRow (toContactMember cxt user) (SEGroupMemberNotFound groupMemberId) $
DB.query
db
(groupMemberQuery <> " WHERE m.group_member_id = ? AND m.user_id = ?")
(groupMemberId, userId)
getNonRemovedMemberById :: DB.Connection -> VersionRangeChat -> User -> GroupMemberId -> ExceptT StoreError IO GroupMember
getNonRemovedMemberById db vr user@User {userId} groupMemberId =
ExceptT . firstRow (toContactMember vr user) (SEGroupMemberNotFound groupMemberId) $
getNonRemovedMemberById :: DB.Connection -> StoreCxt -> User -> GroupMemberId -> ExceptT StoreError IO GroupMember
getNonRemovedMemberById db cxt user@User {userId} groupMemberId =
ExceptT . firstRow (toContactMember cxt user) (SEGroupMemberNotFound groupMemberId) $
DB.query
db
(groupMemberQuery <> " WHERE m.group_member_id = ? AND m.user_id = ? AND m.member_status NOT IN (?,?,?,?)")
(groupMemberId, userId, GSMemRejected, GSMemRemoved, GSMemLeft, GSMemGroupDeleted)
getGroupMemberByIndex :: DB.Connection -> VersionRangeChat -> User -> GroupInfo -> Int64 -> ExceptT StoreError IO GroupMember
getGroupMemberByIndex db vr user GroupInfo {groupId} indexInGroup =
ExceptT . firstRow (toContactMember vr user) (SEGroupMemberNotFoundByIndex indexInGroup) $
getGroupMemberByIndex :: DB.Connection -> StoreCxt -> User -> GroupInfo -> Int64 -> ExceptT StoreError IO GroupMember
getGroupMemberByIndex db cxt user GroupInfo {groupId} indexInGroup =
ExceptT . firstRow (toContactMember cxt user) (SEGroupMemberNotFoundByIndex indexInGroup) $
DB.query
db
(groupMemberQuery <> " WHERE m.group_id = ? AND m.index_in_group = ?")
(groupId, indexInGroup)
getSupportScopeMemberByIndex :: DB.Connection -> VersionRangeChat -> User -> GroupInfo -> GroupMemberId -> Int64 -> ExceptT StoreError IO GroupMember
getSupportScopeMemberByIndex db vr user GroupInfo {groupId} scopeGMId indexInGroup =
ExceptT . firstRow (toContactMember vr user) (SEGroupMemberNotFoundByIndex indexInGroup) $
getSupportScopeMemberByIndex :: DB.Connection -> StoreCxt -> User -> GroupInfo -> GroupMemberId -> Int64 -> ExceptT StoreError IO GroupMember
getSupportScopeMemberByIndex db cxt user GroupInfo {groupId} scopeGMId indexInGroup =
ExceptT . firstRow (toContactMember cxt user) (SEGroupMemberNotFoundByIndex indexInGroup) $
DB.query
db
(groupMemberQuery <> " WHERE m.group_id = ? AND m.index_in_group = ? AND (m.member_role IN (?,?,?) OR m.group_member_id = ?)")
(groupId, indexInGroup, GRModerator, GRAdmin, GROwner, scopeGMId)
getGroupMemberByMemberId :: DB.Connection -> VersionRangeChat -> User -> GroupInfo -> MemberId -> ExceptT StoreError IO GroupMember
getGroupMemberByMemberId db vr user GroupInfo {groupId} memberId =
ExceptT . firstRow (toContactMember vr user) (SEGroupMemberNotFoundByMemberId memberId) $
getGroupMemberByMemberId :: DB.Connection -> StoreCxt -> User -> GroupInfo -> MemberId -> ExceptT StoreError IO GroupMember
getGroupMemberByMemberId db cxt user GroupInfo {groupId} memberId =
ExceptT . firstRow (toContactMember cxt user) (SEGroupMemberNotFoundByMemberId memberId) $
DB.query
db
(groupMemberQuery <> " WHERE m.group_id = ? AND m.member_id = ?")
(groupId, memberId)
getCreateUnknownGMByMemberId :: DB.Connection -> VersionRangeChat -> User -> GroupInfo -> MemberId -> ContactName -> GroupMemberRole -> Bool -> ExceptT StoreError IO (Maybe (GroupMember, Bool))
getCreateUnknownGMByMemberId db vr user gInfo memberId memberName unknownMemberRole allowCreate = do
liftIO (runExceptT $ getGroupMemberByMemberId db vr user gInfo memberId) >>= \case
getCreateUnknownGMByMemberId :: DB.Connection -> StoreCxt -> User -> GroupInfo -> MemberId -> ContactName -> GroupMemberRole -> Bool -> ExceptT StoreError IO (Maybe (GroupMember, Bool))
getCreateUnknownGMByMemberId db cxt user gInfo memberId memberName unknownMemberRole allowCreate = do
liftIO (runExceptT $ getGroupMemberByMemberId db cxt user gInfo memberId) >>= \case
Right m -> pure $ Just (m, False)
Left (SEGroupMemberNotFoundByMemberId _)
| allowCreate -> do
let name = if T.null memberName then nameFromMemberId memberId else memberName
m <- createNewUnknownGroupMember db vr user gInfo memberId name unknownMemberRole
m <- createNewUnknownGroupMember db cxt user gInfo memberId name unknownMemberRole
pure $ Just (m, True)
| otherwise -> pure Nothing
Left e -> throwError e
@@ -1167,43 +1167,43 @@ getGroupMemberIdViaMemberId db User {userId} GroupInfo {groupId} memberId =
"SELECT group_member_id FROM group_members WHERE user_id = ? AND group_id = ? AND member_id = ?"
(userId, groupId, memberId)
getGroupMembers :: DB.Connection -> VersionRangeChat -> User -> GroupInfo -> IO [GroupMember]
getGroupMembers db vr user@User {userId, userContactId} GroupInfo {groupId} =
map (toContactMember vr user)
getGroupMembers :: DB.Connection -> StoreCxt -> User -> GroupInfo -> IO [GroupMember]
getGroupMembers db cxt user@User {userId, userContactId} GroupInfo {groupId} =
map (toContactMember cxt user)
<$> DB.query
db
(groupMemberQuery <> " WHERE m.user_id = ? AND m.group_id = ? AND (m.contact_id IS NULL OR m.contact_id != ?)")
(userId, groupId, userContactId)
getGroupMembersByIndexes :: DB.Connection -> VersionRangeChat -> User -> GroupInfo -> [Int64] -> IO [GroupMember]
getGroupMembersByIndexes db vr user gInfo indexesInGroup = do
getGroupMembersByIndexes :: DB.Connection -> StoreCxt -> User -> GroupInfo -> [Int64] -> IO [GroupMember]
getGroupMembersByIndexes db cxt user gInfo indexesInGroup = do
#if defined(dbPostgres)
let GroupInfo {groupId} = gInfo
map (toContactMember vr user) <$>
map (toContactMember cxt user) <$>
DB.query
db
(groupMemberQuery <> " WHERE m.group_id = ? AND m.index_in_group IN ?")
(groupId, In indexesInGroup)
#else
rights <$> mapM (runExceptT . getGroupMemberByIndex db vr user gInfo) indexesInGroup
rights <$> mapM (runExceptT . getGroupMemberByIndex db cxt user gInfo) indexesInGroup
#endif
getSupportScopeMembersByIndexes :: DB.Connection -> VersionRangeChat -> User -> GroupInfo -> GroupMemberId -> [Int64] -> IO [GroupMember]
getSupportScopeMembersByIndexes db vr user gInfo scopeGMId indexesInGroup = do
getSupportScopeMembersByIndexes :: DB.Connection -> StoreCxt -> User -> GroupInfo -> GroupMemberId -> [Int64] -> IO [GroupMember]
getSupportScopeMembersByIndexes db cxt user gInfo scopeGMId indexesInGroup = do
#if defined(dbPostgres)
let GroupInfo {groupId} = gInfo
map (toContactMember vr user) <$>
map (toContactMember cxt user) <$>
DB.query
db
(groupMemberQuery <> " WHERE m.group_id = ? AND m.index_in_group IN ? AND (m.member_role IN (?,?,?) OR m.group_member_id = ?)")
(groupId, In indexesInGroup, GRModerator, GRAdmin, GROwner, scopeGMId)
#else
rights <$> mapM (runExceptT . getSupportScopeMemberByIndex db vr user gInfo scopeGMId) indexesInGroup
rights <$> mapM (runExceptT . getSupportScopeMemberByIndex db cxt user gInfo scopeGMId) indexesInGroup
#endif
getGroupModerators :: DB.Connection -> VersionRangeChat -> User -> GroupInfo -> IO [GroupMember]
getGroupModerators db vr user@User {userId, userContactId} GroupInfo {groupId} = do
map (toContactMember vr user)
getGroupModerators :: DB.Connection -> StoreCxt -> User -> GroupInfo -> IO [GroupMember]
getGroupModerators db cxt user@User {userId, userContactId} GroupInfo {groupId} = do
map (toContactMember cxt user)
<$> DB.query
db
(groupMemberQuery <> " WHERE m.user_id = ? AND m.group_id = ? AND (m.contact_id IS NULL OR m.contact_id != ?) AND m.member_role IN (?,?,?)")
@@ -1212,33 +1212,33 @@ getGroupModerators db vr user@User {userId, userContactId} GroupInfo {groupId} =
-- Moderators and admins only, excluding owners and non-current members.
-- Used for roster-related paths where owners must not be touched (owners are
-- link-anchored), and left/removed members must not appear in the saved roster.
getGroupRosterMembers :: DB.Connection -> VersionRangeChat -> User -> GroupInfo -> IO [GroupMember]
getGroupRosterMembers db vr user@User {userId, userContactId} GroupInfo {groupId} = do
filter memberCurrent . map (toContactMember vr user)
getGroupRosterMembers :: DB.Connection -> StoreCxt -> User -> GroupInfo -> IO [GroupMember]
getGroupRosterMembers db cxt user@User {userId, userContactId} GroupInfo {groupId} = do
filter memberCurrent . map (toContactMember cxt user)
<$> DB.query
db
(groupMemberQuery <> " WHERE m.user_id = ? AND m.group_id = ? AND (m.contact_id IS NULL OR m.contact_id != ?) AND m.member_role IN (?,?)")
(userId, groupId, userContactId, GRModerator, GRAdmin)
getGroupOwners :: DB.Connection -> VersionRangeChat -> User -> GroupInfo -> IO [GroupMember]
getGroupOwners db vr user@User {userId, userContactId} GroupInfo {groupId} = do
filter memberCurrent . map (toContactMember vr user)
getGroupOwners :: DB.Connection -> StoreCxt -> User -> GroupInfo -> IO [GroupMember]
getGroupOwners db cxt user@User {userId, userContactId} GroupInfo {groupId} = do
filter memberCurrent . map (toContactMember cxt user)
<$> DB.query
db
(groupMemberQuery <> " WHERE m.user_id = ? AND m.group_id = ? AND (m.contact_id IS NULL OR m.contact_id != ?) AND m.member_role = ?")
(userId, groupId, userContactId, GROwner)
getGroupRelayMembers :: DB.Connection -> VersionRangeChat -> User -> GroupInfo -> IO [GroupMember]
getGroupRelayMembers db vr user@User {userId, userContactId} GroupInfo {groupId} = do
map (toContactMember vr user)
getGroupRelayMembers :: DB.Connection -> StoreCxt -> User -> GroupInfo -> IO [GroupMember]
getGroupRelayMembers db cxt user@User {userId, userContactId} GroupInfo {groupId} = do
map (toContactMember cxt user)
<$> DB.query
db
(groupMemberQuery <> " WHERE m.user_id = ? AND m.group_id = ? AND m.contact_id IS DISTINCT FROM ? AND m.member_role = ?")
(userId, groupId, userContactId, GRRelay)
getGroupMembersForExpiration :: DB.Connection -> VersionRangeChat -> User -> GroupInfo -> IO [GroupMember]
getGroupMembersForExpiration db vr user@User {userId, userContactId} GroupInfo {groupId} = do
map (toContactMember vr user)
getGroupMembersForExpiration :: DB.Connection -> StoreCxt -> User -> GroupInfo -> IO [GroupMember]
getGroupMembersForExpiration db cxt user@User {userId, userContactId} GroupInfo {groupId} = do
map (toContactMember cxt user)
<$> DB.query
db
( groupMemberQuery
@@ -1253,22 +1253,22 @@ getGroupMembersForExpiration db vr user@User {userId, userContactId} GroupInfo {
)
(groupId, userId, userContactId, GSMemRemoved, GSMemLeft, GSMemGroupDeleted, GSMemUnknown)
getRemovedMembersToCleanup :: DB.Connection -> VersionRangeChat -> User -> UTCTime -> IO [GroupMember]
getRemovedMembersToCleanup db vr user@User {userId} cutoffTs =
map (toContactMember vr user)
getRemovedMembersToCleanup :: DB.Connection -> StoreCxt -> User -> UTCTime -> IO [GroupMember]
getRemovedMembersToCleanup db cxt user@User {userId} cutoffTs =
map (toContactMember cxt user)
<$> DB.query
db
(groupMemberQuery <> " WHERE m.user_id = ? AND m.removed_at < ?")
(userId, cutoffTs)
getGroupInvitation :: DB.Connection -> VersionRangeChat -> User -> GroupId -> ExceptT StoreError IO ReceivedGroupInvitation
getGroupInvitation db vr user groupId =
getGroupInvitation :: DB.Connection -> StoreCxt -> User -> GroupId -> ExceptT StoreError IO ReceivedGroupInvitation
getGroupInvitation db cxt user groupId =
getConnRec_ user >>= \case
Just connRequest -> do
groupInfo@GroupInfo {membership} <- getGroupInfo db vr user groupId
groupInfo@GroupInfo {membership} <- getGroupInfo db cxt user groupId
when (memberStatus membership /= GSMemInvited) $ throwError SEGroupAlreadyJoined
hostId <- getHostMemberId_ db user groupId
fromMember <- getGroupMember db vr user groupId hostId
fromMember <- getGroupMember db cxt user groupId hostId
pure ReceivedGroupInvitation {fromMember, connRequest, groupInfo}
_ -> throwError SEGroupInvitationNotFound
where
@@ -1445,8 +1445,8 @@ setGroupMemberKeyRole db GroupMember {groupMemberId} pubKey role = do
currentTs <- getCurrentTime
DB.execute db "UPDATE group_members SET member_pub_key = ?, member_role = ?, updated_at = ? WHERE group_member_id = ?" (pubKey, role, currentTs, groupMemberId)
createRelayForOwner :: DB.Connection -> VersionRangeChat -> TVar ChaChaDRG -> User -> GroupInfo -> UserChatRelay -> ExceptT StoreError IO GroupMember
createRelayForOwner db vr gVar user@User {userId, userContactId} GroupInfo {groupId, membership} UserChatRelay {relayProfile = RelayProfile {displayName}} = do
createRelayForOwner :: DB.Connection -> StoreCxt -> TVar ChaChaDRG -> User -> GroupInfo -> UserChatRelay -> ExceptT StoreError IO GroupMember
createRelayForOwner db cxt gVar user@User {userId, userContactId} GroupInfo {groupId, membership} UserChatRelay {relayProfile = RelayProfile {displayName}} = do
currentTs <- liftIO getCurrentTime
let relayProfile = profileFromName displayName
(localDisplayName, memProfileId) <- createNewMemberProfile_ db user relayProfile currentTs
@@ -1465,14 +1465,14 @@ createRelayForOwner db vr gVar user@User {userId, userContactId} GroupInfo {grou
:. (userId, localDisplayName, memProfileId, currentTs, currentTs)
)
liftIO $ insertedRowId db
getGroupMemberById db vr user groupMemberId
getGroupMemberById db cxt user groupMemberId
getCreateRelayForMember :: DB.Connection -> VersionRangeChat -> TVar ChaChaDRG -> User -> GroupInfo -> ShortLinkContact -> ExceptT StoreError IO GroupMember
getCreateRelayForMember db vr gVar user@User {userId, userContactId} GroupInfo {groupId, localDisplayName = groupLDN} relayLink =
getCreateRelayForMember :: DB.Connection -> StoreCxt -> TVar ChaChaDRG -> User -> GroupInfo -> ShortLinkContact -> ExceptT StoreError IO GroupMember
getCreateRelayForMember db cxt gVar user@User {userId, userContactId} GroupInfo {groupId, localDisplayName = groupLDN} relayLink =
liftIO getGroupMemberByRelayLink >>= maybe createRelayMember pure
where
getGroupMemberByRelayLink =
maybeFirstRow (toContactMember vr user) $
maybeFirstRow (toContactMember cxt user) $
DB.query
db
#if defined(dbPostgres)
@@ -1503,10 +1503,10 @@ getCreateRelayForMember db vr gVar user@User {userId, userContactId} GroupInfo {
:. (userId, localDisplayName, profileId, currentTs, currentTs, relayLink)
)
insertedRowId db
getGroupMember db vr user groupId groupMemberId
getGroupMember db cxt user groupId groupMemberId
createRelayConnection :: DB.Connection -> VersionRangeChat -> User -> Int64 -> ConnId -> ConnStatus -> VersionChat -> SubscriptionMode -> ExceptT StoreError IO Connection
createRelayConnection db vr user@User {userId} groupMemberId agentConnId connStatus chatV subMode = do
createRelayConnection :: DB.Connection -> StoreCxt -> User -> Int64 -> ConnId -> ConnStatus -> VersionChat -> SubscriptionMode -> ExceptT StoreError IO Connection
createRelayConnection db cxt user@User {userId} groupMemberId agentConnId connStatus chatV subMode = do
currentTs <- liftIO getCurrentTime
liftIO $
DB.execute
@@ -1523,7 +1523,7 @@ createRelayConnection db vr user@User {userId} groupMemberId agentConnId connSta
:. (currentTs, currentTs)
)
connId <- liftIO $ insertedRowId db
getConnectionById db vr user connId
getConnectionById db cxt user connId
updateRelayStatus :: DB.Connection -> GroupRelay -> RelayStatus -> IO GroupRelay
updateRelayStatus db relay@GroupRelay {groupRelayId} relayStatus =
@@ -1540,8 +1540,8 @@ updateRelayStatus_ db relayId relayStatus = do
currentTs <- getCurrentTime
DB.execute db "UPDATE group_relays SET relay_status = ?, updated_at = ? WHERE group_relay_id = ?" (relayStatus, currentTs, relayId)
setRelayKey :: DB.Connection -> VersionRangeChat -> User -> GroupMember -> MemberKey -> Profile -> ExceptT StoreError IO (GroupMember, GroupRelay)
setRelayKey db vr user m (MemberKey relayKey) profile = do
setRelayKey :: DB.Connection -> StoreCxt -> User -> GroupMember -> MemberKey -> Profile -> ExceptT StoreError IO (GroupMember, GroupRelay)
setRelayKey db cxt user m (MemberKey relayKey) profile = do
let gmId = groupMemberId' m
currentTs <- liftIO getCurrentTime
liftIO $ DB.execute
@@ -1553,7 +1553,7 @@ setRelayKey db vr user m (MemberKey relayKey) profile = do
|]
(relayKey, currentTs, gmId)
void $ updateMemberProfile db user m profile
(,) <$> getGroupMemberById db vr user gmId <*> getGroupRelayByGMId db gmId
(,) <$> getGroupMemberById db cxt user gmId <*> getGroupRelayByGMId db gmId
setRelayLinkConfId :: DB.Connection -> GroupMember -> ConfirmationId -> ShortLinkContact -> IO ()
setRelayLinkConfId db m confId relayLink = do
@@ -1621,8 +1621,8 @@ setGroupInProgressDone db GroupInfo {groupId} = do
"UPDATE groups SET creating_in_progress = 0, updated_at = ? WHERE group_id = ?"
(currentTs, groupId)
createRelayRequestGroup :: DB.Connection -> VersionRangeChat -> User -> GroupRelayInvitation -> InvitationId -> VersionRangeChat -> Int64 -> GroupMemberStatus -> RelayStatus -> ExceptT StoreError IO (GroupInfo, GroupMember)
createRelayRequestGroup db vr user@User {userId} GroupRelayInvitation {fromMember, fromMemberProfile, relayMemberId, groupLink} invId reqChatVRange initialDelay memberStatus relayStatus = do
createRelayRequestGroup :: DB.Connection -> StoreCxt -> User -> GroupRelayInvitation -> InvitationId -> VersionRangeChat -> Int64 -> GroupMemberStatus -> RelayStatus -> ExceptT StoreError IO (GroupInfo, GroupMember)
createRelayRequestGroup db cxt user@User {userId} GroupRelayInvitation {fromMember, fromMemberProfile, relayMemberId, groupLink} invId reqChatVRange initialDelay memberStatus relayStatus = do
currentTs <- liftIO getCurrentTime
-- Create group with placeholder profile
let Profile {displayName = fromMemberLDN} = fromMemberProfile
@@ -1642,9 +1642,9 @@ createRelayRequestGroup db vr user@User {userId} GroupRelayInvitation {fromMembe
ownerMemberId <- insertOwner_ currentTs groupId
let relayMember = MemberIdRole relayMemberId GRRelay
-- TODO [member keys] should relays use member keys?
_membership <- createContactMemberInv_ db user groupId (Just ownerMemberId) user relayMember GCUserMember memberStatus IBUnknown Nothing Nothing currentTs vr
ownerMember <- getGroupMember db vr user groupId ownerMemberId
g <- getGroupInfo db vr user groupId
_membership <- createContactMemberInv_ db user groupId (Just ownerMemberId) user relayMember GCUserMember memberStatus IBUnknown Nothing Nothing currentTs (vr cxt)
ownerMember <- getGroupMember db cxt user groupId ownerMemberId
g <- getGroupInfo db cxt user groupId
pure (g, ownerMember)
where
setRelayRequestData_ groupId currentTs =
@@ -1696,8 +1696,8 @@ updateRelayOwnStatus_ db GroupInfo {groupId} relayStatus = do
-- Flip every RSRejected row sharing the targeted group's relay_request_group_link
-- to RSInactive in one statement; returns the refreshed GroupInfo for the targeted groupId.
allowRelayGroup :: DB.Connection -> VersionRangeChat -> User -> GroupId -> ExceptT StoreError IO GroupInfo
allowRelayGroup db vr user@User {userId} groupId = do
allowRelayGroup :: DB.Connection -> StoreCxt -> User -> GroupId -> ExceptT StoreError IO GroupInfo
allowRelayGroup db cxt user@User {userId} groupId = do
currentTs <- liftIO getCurrentTime
liftIO $
DB.execute
@@ -1710,7 +1710,7 @@ allowRelayGroup db vr user@User {userId} groupId = do
AND relay_own_status = ?
|]
(RSInactive, currentTs, currentTs, userId, groupId, RSRejected)
getGroupInfo db vr user groupId
getGroupInfo db cxt user groupId
isRelayGroupRejected :: DB.Connection -> User -> ShortLinkContact -> IO Bool
isRelayGroupRejected db User {userId} groupLink =
@@ -1729,9 +1729,9 @@ isRelayGroupRejected db User {userId} groupLink =
(userId, groupLink, RSRejected)
)
getRelayServedGroups :: DB.Connection -> VersionRangeChat -> User -> IO [GroupInfo]
getRelayServedGroups db vr User {userId, userContactId} = do
map (toGroupInfo vr userContactId [])
getRelayServedGroups :: DB.Connection -> StoreCxt -> User -> IO [GroupInfo]
getRelayServedGroups db cxt User {userId, userContactId} = do
map (toGroupInfo cxt userContactId [])
<$> DB.query
db
( groupInfoQuery
@@ -1739,10 +1739,10 @@ getRelayServedGroups db vr User {userId, userContactId} = do
)
(userId, userContactId, RSAccepted, RSActive)
getRelayInactiveGroups :: DB.Connection -> VersionRangeChat -> User -> NominalDiffTime -> IO [GroupInfo]
getRelayInactiveGroups db vr User {userId, userContactId} ttl = do
getRelayInactiveGroups :: DB.Connection -> StoreCxt -> User -> NominalDiffTime -> IO [GroupInfo]
getRelayInactiveGroups db cxt User {userId, userContactId} ttl = do
cutoffTs <- addUTCTime (- ttl) <$> getCurrentTime
map (toGroupInfo vr userContactId [])
map (toGroupInfo cxt userContactId [])
<$> DB.query
db
( groupInfoQuery
@@ -1854,10 +1854,10 @@ createJoiningMemberConnection
Connection {connId} <- createConnection_ db userId ConnMember (Just groupMemberId) agentConnId ConnNew chatV cReqChatVRange Nothing (Just uclId) Nothing 0 createdAt subMode PQSupportOff
setCommandConnId db user cmdId connId
createBusinessRequestGroup :: DB.Connection -> VersionRangeChat -> TVar ChaChaDRG -> User -> VersionRangeChat -> Profile -> Int64 -> Text -> GroupPreferences -> ExceptT StoreError IO (GroupInfo, GroupMember)
createBusinessRequestGroup :: DB.Connection -> StoreCxt -> TVar ChaChaDRG -> User -> VersionRangeChat -> Profile -> Int64 -> Text -> GroupPreferences -> ExceptT StoreError IO (GroupInfo, GroupMember)
createBusinessRequestGroup
db
vr
cxt
gVar
user@User {userId, userContactId}
cReqChatVRange
@@ -1869,8 +1869,8 @@ createBusinessRequestGroup
(groupId, membership@GroupMember {memberId = userMemberId}) <- insertGroup_ currentTs
(groupMemberId, memberId) <- insertClientMember_ currentTs groupId membership
liftIO $ DB.execute db "UPDATE groups SET business_member_id = ?, customer_member_id = ? WHERE group_id = ?" (userMemberId, memberId, groupId)
groupInfo <- getGroupInfo db vr user groupId
clientMember <- getGroupMemberById db vr user groupMemberId
groupInfo <- getGroupInfo db cxt user groupId
clientMember <- getGroupMemberById db cxt user groupMemberId
pure (groupInfo, clientMember)
where
insertGroup_ currentTs = do
@@ -1893,7 +1893,7 @@ createBusinessRequestGroup
groupId <- liftIO $ insertedRowId db
memberId <- liftIO $ encodedRandomBytes gVar 12
-- TODO [member keys] we could support member keys in business groups to allow binding agreements (though identity keys would be better for it.
membership <- createContactMemberInv_ db user groupId Nothing user (MemberIdRole (MemberId memberId) GROwner) GCUserMember GSMemCreator IBUser Nothing Nothing currentTs vr
membership <- createContactMemberInv_ db user groupId Nothing user (MemberIdRole (MemberId memberId) GROwner) GCUserMember GSMemCreator IBUser Nothing Nothing currentTs (vr cxt)
pure (groupId, membership)
VersionRange minV maxV = cReqChatVRange
insertClientMember_ currentTs groupId membership =
@@ -1917,8 +1917,8 @@ createBusinessRequestGroup
groupMemberId <- liftIO $ insertedRowId db
pure (groupMemberId, MemberId memId)
getContactViaMember :: DB.Connection -> VersionRangeChat -> User -> GroupMember -> ExceptT StoreError IO Contact
getContactViaMember db vr user@User {userId} GroupMember {groupMemberId} = do
getContactViaMember :: DB.Connection -> StoreCxt -> User -> GroupMember -> ExceptT StoreError IO Contact
getContactViaMember db cxt user@User {userId} GroupMember {groupMemberId} = do
contactId <-
ExceptT $
firstRow fromOnly (SEContactNotFoundByMemberId groupMemberId) $
@@ -1932,7 +1932,7 @@ getContactViaMember db vr user@User {userId} GroupMember {groupMemberId} = do
LIMIT 1
|]
(userId, groupMemberId)
getContact db vr user contactId
getContact db cxt user contactId
setNewContactMemberConnRequest :: DB.Connection -> User -> GroupMember -> ConnReqInvitation -> IO ()
setNewContactMemberConnRequest db User {userId} GroupMember {groupMemberId} connRequest = do
@@ -1959,18 +1959,18 @@ createMemberConnectionAsync db user@User {userId} groupMemberId (cmdId, agentCon
-- This is called once before connecting to relays, unlike createConnReqConnection -> setPreparedGroupLinkInfo_,
-- which is used in single-connection flows.
updatePreparedRelayedGroup ::
DB.Connection -> VersionRangeChat -> User -> GroupInfo -> ConnReqContact -> ConnReqUriHash -> Maybe Profile ->
DB.Connection -> StoreCxt -> User -> GroupInfo -> ConnReqContact -> ConnReqUriHash -> Maybe Profile ->
C.PublicKeyEd25519 -> C.PrivateKeyEd25519 -> Maybe Int64 ->
ExceptT StoreError IO GroupInfo
updatePreparedRelayedGroup db vr user@User {userId} gInfo cReq cReqHash incognitoProfile rootPubKey memberPrivKey publicMemberCount_ = do
updatePreparedRelayedGroup db cxt user@User {userId} gInfo cReq cReqHash incognitoProfile rootPubKey memberPrivKey publicMemberCount_ = do
currentTs <- liftIO getCurrentTime
customUserProfileId <- liftIO $ mapM (createIncognitoProfile_ db userId currentTs) incognitoProfile
liftIO $ setPreparedGroupLinkInfo_ db gInfo cReq cReqHash customUserProfileId publicMemberCount_ currentTs
liftIO $ updateGroupMemberKeys db (groupId' gInfo) rootPubKey memberPrivKey (groupMemberId' $ membership gInfo)
getGroupInfo db vr user (groupId' gInfo)
getGroupInfo db cxt user (groupId' gInfo)
updatePublicMemberCount :: DB.Connection -> VersionRangeChat -> User -> GroupInfo -> ExceptT StoreError IO GroupInfo
updatePublicMemberCount db vr user GroupInfo {groupId} = do
updatePublicMemberCount :: DB.Connection -> StoreCxt -> User -> GroupInfo -> ExceptT StoreError IO GroupInfo
updatePublicMemberCount db cxt user GroupInfo {groupId} = do
liftIO $ do
totalCount <- fromMaybe 0 <$> maybeFirstRow fromOnly
(DB.query db "SELECT summary_current_members_count FROM groups WHERE group_id = ?" (Only groupId))
@@ -1986,13 +1986,13 @@ updatePublicMemberCount db vr user GroupInfo {groupId} = do
let publicCount = max 0 (totalCount - relayCount) :: Int64
currentTs <- getCurrentTime
DB.execute db "UPDATE groups SET public_member_count = ?, updated_at = ? WHERE group_id = ?" (publicCount, currentTs, groupId)
getGroupInfo db vr user groupId
getGroupInfo db cxt user groupId
setPublicMemberCount :: DB.Connection -> VersionRangeChat -> User -> GroupInfo -> Int64 -> ExceptT StoreError IO GroupInfo
setPublicMemberCount db vr user GroupInfo {groupId} publicCount = do
setPublicMemberCount :: DB.Connection -> StoreCxt -> User -> GroupInfo -> Int64 -> ExceptT StoreError IO GroupInfo
setPublicMemberCount db cxt user GroupInfo {groupId} publicCount = do
currentTs <- liftIO getCurrentTime
liftIO $ DB.execute db "UPDATE groups SET public_member_count = ?, updated_at = ? WHERE group_id = ?" (publicCount, currentTs, groupId)
getGroupInfo db vr user groupId
getGroupInfo db cxt user groupId
updateGroupMemberKeys :: DB.Connection -> GroupId -> C.PublicKeyEd25519 -> C.PrivateKeyEd25519 -> GroupMemberId -> IO ()
updateGroupMemberKeys db groupId rootPubKey memberPrivKey membershipGMId = do
@@ -2494,8 +2494,8 @@ updateGroupProfileFromMember db user g@GroupInfo {groupId} Profile {displayName
let publicGroupAccess = toPublicGroupAccess accessRow
in GroupProfile {displayName, fullName, shortDescr, description, image, publicGroup = toPublicGroupProfile groupType_ groupLink_ publicGroupId_ publicGroupAccess, groupPreferences, memberAdmission}
getGroupInfoByUserContactLinkConnReq :: DB.Connection -> VersionRangeChat -> User -> (ConnReqContact, ConnReqContact) -> IO (Maybe GroupInfo)
getGroupInfoByUserContactLinkConnReq db vr user@User {userId} (cReqSchema1, cReqSchema2) = do
getGroupInfoByUserContactLinkConnReq :: DB.Connection -> StoreCxt -> User -> (ConnReqContact, ConnReqContact) -> IO (Maybe GroupInfo)
getGroupInfoByUserContactLinkConnReq db cxt user@User {userId} (cReqSchema1, cReqSchema2) = do
-- fmap join is to support group_id = NULL if non-group contact request is sent to this function (e.g., if client data is appended).
groupId_ <-
fmap join . maybeFirstRow fromOnly $
@@ -2507,12 +2507,12 @@ getGroupInfoByUserContactLinkConnReq db vr user@User {userId} (cReqSchema1, cReq
WHERE user_id = ? AND conn_req_contact IN (?,?)
|]
(userId, cReqSchema1, cReqSchema2)
maybe (pure Nothing) (fmap eitherToMaybe . runExceptT . getGroupInfo db vr user) groupId_
maybe (pure Nothing) (fmap eitherToMaybe . runExceptT . getGroupInfo db cxt user) groupId_
getGroupInfoViaUserShortLink :: DB.Connection -> VersionRangeChat -> User -> ShortLinkContact -> IO (Maybe (ConnReqContact, GroupInfo))
getGroupInfoViaUserShortLink db vr user@User {userId} shortLink = fmap eitherToMaybe $ runExceptT $ do
getGroupInfoViaUserShortLink :: DB.Connection -> StoreCxt -> User -> ShortLinkContact -> IO (Maybe (ConnReqContact, GroupInfo))
getGroupInfoViaUserShortLink db cxt user@User {userId} shortLink = fmap eitherToMaybe $ runExceptT $ do
(cReq, groupId) <- ExceptT getConnReqGroup
(cReq,) <$> getGroupInfo db vr user groupId
(cReq,) <$> getGroupInfo db cxt user groupId
where
getConnReqGroup =
firstRow' toConnReqGroupId (SEInternalError "group link not found") $
@@ -2529,14 +2529,14 @@ getGroupInfoViaUserShortLink db vr user@User {userId} shortLink = fmap eitherToM
(cReq, Just groupId) -> Right (cReq, groupId)
_ -> Left $ SEInternalError "no conn req or group ID"
getGroupViaShortLinkToConnect :: DB.Connection -> VersionRangeChat -> User -> ShortLinkContact -> ExceptT StoreError IO (Maybe (ConnReqContact, GroupInfo))
getGroupViaShortLinkToConnect db vr user@User {userId} shortLink =
getGroupViaShortLinkToConnect :: DB.Connection -> StoreCxt -> User -> ShortLinkContact -> ExceptT StoreError IO (Maybe (ConnReqContact, GroupInfo))
getGroupViaShortLinkToConnect db cxt user@User {userId} shortLink =
liftIO (maybeFirstRow id $ DB.query db "SELECT group_id, conn_full_link_to_connect FROM groups WHERE user_id = ? AND conn_short_link_to_connect = ?" (userId, shortLink)) >>= \case
Just (gId :: Int64, Just cReq) -> Just . (cReq,) <$> getGroupInfo db vr user gId
Just (gId :: Int64, Just cReq) -> Just . (cReq,) <$> getGroupInfo db cxt user gId
_ -> pure Nothing
getGroupInfoByGroupLinkHash :: DB.Connection -> VersionRangeChat -> User -> (ConnReqUriHash, ConnReqUriHash) -> IO (Maybe GroupInfo)
getGroupInfoByGroupLinkHash db vr user@User {userId, userContactId} (groupLinkHash1, groupLinkHash2) = do
getGroupInfoByGroupLinkHash :: DB.Connection -> StoreCxt -> User -> (ConnReqUriHash, ConnReqUriHash) -> IO (Maybe GroupInfo)
getGroupInfoByGroupLinkHash db cxt user@User {userId, userContactId} (groupLinkHash1, groupLinkHash2) = do
groupId_ <-
maybeFirstRow fromOnly $
DB.query
@@ -2550,7 +2550,7 @@ getGroupInfoByGroupLinkHash db vr user@User {userId, userContactId} (groupLinkHa
LIMIT 1
|]
(userId, groupLinkHash1, groupLinkHash2, userContactId, GSMemRemoved, GSMemLeft, GSMemGroupDeleted, GSMemUnknown)
maybe (pure Nothing) (fmap eitherToMaybe . runExceptT . getGroupInfo db vr user) groupId_
maybe (pure Nothing) (fmap eitherToMaybe . runExceptT . getGroupInfo db cxt user) groupId_
getGroupIdByName :: DB.Connection -> User -> GroupName -> ExceptT StoreError IO GroupId
getGroupIdByName db User {userId} gName =
@@ -2562,8 +2562,8 @@ getGroupMemberIdByName db User {userId} groupId groupMemberName =
ExceptT . firstRow fromOnly (SEGroupMemberNameNotFound groupId groupMemberName) $
DB.query db "SELECT group_member_id FROM group_members WHERE user_id = ? AND group_id = ? AND local_display_name = ?" (userId, groupId, groupMemberName)
getActiveMembersByName :: DB.Connection -> VersionRangeChat -> User -> ContactName -> ExceptT StoreError IO [(GroupInfo, GroupMember)]
getActiveMembersByName db vr user@User {userId} groupMemberName = do
getActiveMembersByName :: DB.Connection -> StoreCxt -> User -> ContactName -> ExceptT StoreError IO [(GroupInfo, GroupMember)]
getActiveMembersByName db cxt user@User {userId} groupMemberName = do
groupMemberIds :: [(GroupId, GroupMemberId)] <-
liftIO $
DB.query
@@ -2576,17 +2576,17 @@ getActiveMembersByName db vr user@User {userId} groupMemberName = do
|]
(userId, groupMemberName, GSMemConnected, GSMemComplete, GCUserMember)
possibleMembers <- forM groupMemberIds $ \(groupId, groupMemberId) -> do
groupInfo <- getGroupInfo db vr user groupId
groupMember <- getGroupMember db vr user groupId groupMemberId
groupInfo <- getGroupInfo db cxt user groupId
groupMember <- getGroupMember db cxt user groupId groupMemberId
pure (groupInfo, groupMember)
pure $ sortOn (Down . ts . fst) possibleMembers
where
ts GroupInfo {chatTs, updatedAt} = fromMaybe updatedAt chatTs
getMatchingContacts :: DB.Connection -> VersionRangeChat -> User -> Contact -> IO [Contact]
getMatchingContacts db vr user@User {userId} Contact {contactId, profile = LocalProfile {displayName, fullName, shortDescr, image}} = do
getMatchingContacts :: DB.Connection -> StoreCxt -> User -> Contact -> IO [Contact]
getMatchingContacts db cxt user@User {userId} Contact {contactId, profile = LocalProfile {displayName, fullName, shortDescr, image}} = do
contactIds <- map fromOnly <$> DB.query db q (userId, contactId, CSActive, displayName, fullName, shortDescr, image)
rights <$> mapM (runExceptT . getContact db vr user) contactIds
rights <$> mapM (runExceptT . getContact db cxt user) contactIds
where
-- this query is different from one in getMatchingMemberContacts
-- it checks that it's not the same contact
@@ -2601,10 +2601,10 @@ getMatchingContacts db vr user@User {userId} Contact {contactId, profile = Local
AND p.short_descr IS NOT DISTINCT FROM ? AND p.image IS NOT DISTINCT FROM ?
|]
getMatchingMembers :: DB.Connection -> VersionRangeChat -> User -> Contact -> IO [GroupMember]
getMatchingMembers db vr user@User {userId} Contact {profile = LocalProfile {displayName, fullName, shortDescr, image}} = do
getMatchingMembers :: DB.Connection -> StoreCxt -> User -> Contact -> IO [GroupMember]
getMatchingMembers db cxt user@User {userId} Contact {profile = LocalProfile {displayName, fullName, shortDescr, image}} = do
memberIds <- map fromOnly <$> DB.query db q (userId, GCUserMember, displayName, fullName, shortDescr, image)
filter memberCurrent . rights <$> mapM (runExceptT . getGroupMemberById db vr user) memberIds
filter memberCurrent . rights <$> mapM (runExceptT . getGroupMemberById db cxt user) memberIds
where
-- only match with members without associated contact
q =
@@ -2618,11 +2618,11 @@ getMatchingMembers db vr user@User {userId} Contact {profile = LocalProfile {dis
AND p.short_descr IS NOT DISTINCT FROM ? AND p.image IS NOT DISTINCT FROM ?
|]
getMatchingMemberContacts :: DB.Connection -> VersionRangeChat -> User -> GroupMember -> IO [Contact]
getMatchingMemberContacts :: DB.Connection -> StoreCxt -> User -> GroupMember -> IO [Contact]
getMatchingMemberContacts _ _ _ GroupMember {memberContactId = Just _} = pure []
getMatchingMemberContacts db vr user@User {userId} GroupMember {memberProfile = LocalProfile {displayName, fullName, shortDescr, image}} = do
getMatchingMemberContacts db cxt user@User {userId} GroupMember {memberProfile = LocalProfile {displayName, fullName, shortDescr, image}} = do
contactIds <- map fromOnly <$> DB.query db q (userId, CSActive, displayName, fullName, shortDescr, image)
rights <$> mapM (runExceptT . getContact db vr user) contactIds
rights <$> mapM (runExceptT . getContact db cxt user) contactIds
where
q =
[sql|
@@ -2655,8 +2655,8 @@ createSentProbeHash db userId probeId to = do
"INSERT INTO sent_probe_hashes (sent_probe_id, contact_id, group_member_id, user_id, created_at, updated_at) VALUES (?,?,?,?,?,?)"
(probeId, ctId, gmId, userId, currentTs, currentTs)
matchReceivedProbe :: DB.Connection -> VersionRangeChat -> User -> ContactOrMember -> Probe -> IO [ContactOrMember]
matchReceivedProbe db vr user@User {userId} from (Probe probe) = do
matchReceivedProbe :: DB.Connection -> StoreCxt -> User -> ContactOrMember -> Probe -> IO [ContactOrMember]
matchReceivedProbe db cxt user@User {userId} from (Probe probe) = do
let probeHash = C.sha256Hash probe
cgmIds <-
DB.query
@@ -2677,7 +2677,7 @@ matchReceivedProbe db vr user@User {userId} from (Probe probe) = do
"INSERT INTO received_probes (contact_id, group_member_id, probe, probe_hash, user_id, created_at, updated_at) VALUES (?,?,?,?,?,?,?)"
(ctId, gmId, Binary probe, Binary probeHash, userId, currentTs, currentTs)
let cgmIds' = filterFirstContactId cgmIds
catMaybes <$> mapM (getContactOrMember_ db vr user) cgmIds'
catMaybes <$> mapM (getContactOrMember_ db cxt user) cgmIds'
where
filterFirstContactId :: [(Maybe ContactId, Maybe GroupId, Maybe GroupMemberId)] -> [(Maybe ContactId, Maybe GroupId, Maybe GroupMemberId)]
filterFirstContactId cgmIds = do
@@ -2687,8 +2687,8 @@ matchReceivedProbe db vr user@User {userId} from (Probe probe) = do
(x : _) -> [x]
ctIds' <> memIds
matchReceivedProbeHash :: DB.Connection -> VersionRangeChat -> User -> ContactOrMember -> ProbeHash -> IO (Maybe (ContactOrMember, Probe))
matchReceivedProbeHash db vr user@User {userId} from (ProbeHash probeHash) = do
matchReceivedProbeHash :: DB.Connection -> StoreCxt -> User -> ContactOrMember -> ProbeHash -> IO (Maybe (ContactOrMember, Probe))
matchReceivedProbeHash db cxt user@User {userId} from (ProbeHash probeHash) = do
probeIds <-
maybeFirstRow id $
DB.query
@@ -2708,11 +2708,11 @@ matchReceivedProbeHash db vr user@User {userId} from (ProbeHash probeHash) = do
db
"INSERT INTO received_probes (contact_id, group_member_id, probe_hash, user_id, created_at, updated_at) VALUES (?,?,?,?,?,?)"
(ctId, gmId, Binary probeHash, userId, currentTs, currentTs)
pure probeIds $>>= \(Only probe :. cgmIds) -> (,Probe probe) <$$> getContactOrMember_ db vr user cgmIds
pure probeIds $>>= \(Only probe :. cgmIds) -> (,Probe probe) <$$> getContactOrMember_ db cxt user cgmIds
matchSentProbe :: DB.Connection -> VersionRangeChat -> User -> ContactOrMember -> Probe -> IO (Maybe ContactOrMember)
matchSentProbe db vr user@User {userId} _from (Probe probe) = do
cgmIds $>>= getContactOrMember_ db vr user
matchSentProbe :: DB.Connection -> StoreCxt -> User -> ContactOrMember -> Probe -> IO (Maybe ContactOrMember)
matchSentProbe db cxt user@User {userId} _from (Probe probe) = do
cgmIds $>>= getContactOrMember_ db cxt user
where
(ctId, gmId) = contactOrMemberIds _from
cgmIds =
@@ -2731,11 +2731,11 @@ matchSentProbe db vr user@User {userId} _from (Probe probe) = do
|]
(userId, Binary probe, ctId, gmId)
getContactOrMember_ :: DB.Connection -> VersionRangeChat -> User -> (Maybe ContactId, Maybe GroupId, Maybe GroupMemberId) -> IO (Maybe ContactOrMember)
getContactOrMember_ db vr user ids =
getContactOrMember_ :: DB.Connection -> StoreCxt -> User -> (Maybe ContactId, Maybe GroupId, Maybe GroupMemberId) -> IO (Maybe ContactOrMember)
getContactOrMember_ db cxt user ids =
fmap eitherToMaybe . runExceptT $ case ids of
(Just ctId, _, _) -> COMContact <$> getContact db vr user ctId
(_, Just gId, Just gmId) -> COMGroupMember <$> getGroupMember db vr user gId gmId
(Just ctId, _, _) -> COMContact <$> getContact db cxt user ctId
(_, Just gId, Just gmId) -> COMGroupMember <$> getGroupMember db cxt user gId gmId
_ -> throwError $ SEInternalError ""
associateMemberWithContactRecord :: DB.Connection -> User -> Contact -> GroupMember -> IO ()
@@ -2756,10 +2756,10 @@ associateMemberWithContactRecord
when (memProfileId /= profileId) $ deleteUnusedProfile_ db userId memProfileId
when (memLDN /= localDisplayName) $ deleteUnusedDisplayName_ db userId memLDN
associateContactWithMemberRecord :: DB.Connection -> VersionRangeChat -> User -> GroupMember -> Contact -> ExceptT StoreError IO Contact
associateContactWithMemberRecord :: DB.Connection -> StoreCxt -> User -> GroupMember -> Contact -> ExceptT StoreError IO Contact
associateContactWithMemberRecord
db
vr
cxt
user@User {userId}
GroupMember {groupId, groupMemberId, localDisplayName = memLDN, memberProfile = LocalProfile {profileId = memProfileId}}
Contact {contactId, localDisplayName, profile = LocalProfile {profileId}} = do
@@ -2783,7 +2783,7 @@ associateContactWithMemberRecord
(memLDN, memProfileId, currentTs, userId, contactId)
when (profileId /= memProfileId) $ deleteUnusedProfile_ db userId profileId
when (localDisplayName /= memLDN) $ deleteUnusedDisplayName_ db userId localDisplayName
getContact db vr user contactId
getContact db cxt user contactId
deleteUnusedDisplayName_ :: DB.Connection -> UserId -> ContactName -> IO ()
deleteUnusedDisplayName_ db userId localDisplayName =
@@ -2939,15 +2939,15 @@ createMemberContact
mergedPreferences = contactUserPreferences user userPreferences preferences $ connIncognito ctConn
pure Contact {contactId, localDisplayName, profile = memberProfile, activeConn = Just ctConn, contactUsed = True, contactStatus = CSActive, chatSettings = defaultChatSettings, userPreferences, mergedPreferences, createdAt = currentTs, updatedAt = currentTs, chatTs = Just currentTs, preparedContact = Nothing, contactRequestId = Nothing, contactGroupMemberId = Just groupMemberId, contactGrpInvSent = False, groupDirectInv = Nothing, chatTags = [], chatItemTTL = Nothing, uiThemes = Nothing, chatDeleted = False, customData = Nothing}
getMemberContact :: DB.Connection -> VersionRangeChat -> User -> ContactId -> ExceptT StoreError IO (GroupInfo, GroupMember, Contact, ConnReqInvitation)
getMemberContact db vr user contactId = do
ct <- getContact db vr user contactId
getMemberContact :: DB.Connection -> StoreCxt -> User -> ContactId -> ExceptT StoreError IO (GroupInfo, GroupMember, Contact, ConnReqInvitation)
getMemberContact db cxt user contactId = do
ct <- getContact db cxt user contactId
let Contact {contactGroupMemberId, activeConn} = ct
case (activeConn, contactGroupMemberId) of
(Just Connection {connId}, Just groupMemberId) -> do
cReq <- getConnReqInv db connId
m@GroupMember {groupId} <- getGroupMemberById db vr user groupMemberId
g <- getGroupInfo db vr user groupId
m@GroupMember {groupId} <- getGroupMemberById db cxt user groupMemberId
g <- getGroupInfo db cxt user groupId
pure (g, m, ct, cReq)
_ ->
throwError $ SEMemberContactGroupMemberNotFound contactId
@@ -3056,13 +3056,13 @@ createMemberContactConn
forM_ cmdId_ $ \cmdId -> setCommandConnId db user cmdId connId
pure connId
getMemberContactInvited :: DB.Connection -> VersionRangeChat -> User -> ContactId -> ExceptT StoreError IO (GroupInfo, Connection, Contact, GroupDirectInvitation)
getMemberContactInvited db vr user contactId = do
ct@Contact {groupDirectInv = groupDirectInv_} <- getContact db vr user contactId
getMemberContactInvited :: DB.Connection -> StoreCxt -> User -> ContactId -> ExceptT StoreError IO (GroupInfo, Connection, Contact, GroupDirectInvitation)
getMemberContactInvited db cxt user contactId = do
ct@Contact {groupDirectInv = groupDirectInv_} <- getContact db cxt user contactId
case groupDirectInv_ of
Just groupDirectInv@GroupDirectInvitation {fromGroupId_ = Just groupId, fromGroupMemberId_ = Just _gmId, fromGroupMemberConnId_ = Just mConnId} -> do
g <- getGroupInfo db vr user groupId
mConn <- getConnectionById db vr user mConnId
g <- getGroupInfo db cxt user groupId
mConn <- getConnectionById db cxt user mConnId
pure (g, mConn, ct, groupDirectInv)
_ ->
throwError $ SEMemberContactGroupMemberNotFound contactId
@@ -3124,8 +3124,8 @@ setXGrpLinkMemReceived db mId xGrpLinkMemReceived = do
"UPDATE group_members SET xgrplinkmem_received = ?, updated_at = ? WHERE group_member_id = ?"
(BI xGrpLinkMemReceived, currentTs, mId)
createNewUnknownGroupMember :: DB.Connection -> VersionRangeChat -> User -> GroupInfo -> MemberId -> Text -> GroupMemberRole -> ExceptT StoreError IO GroupMember
createNewUnknownGroupMember db vr user@User {userId, userContactId} GroupInfo {groupId} memberId memberName unknownMemberRole = do
createNewUnknownGroupMember :: DB.Connection -> StoreCxt -> User -> GroupInfo -> MemberId -> Text -> GroupMemberRole -> ExceptT StoreError IO GroupMember
createNewUnknownGroupMember db cxt user@User {userId, userContactId} GroupInfo {groupId} memberId memberName unknownMemberRole = do
currentTs <- liftIO getCurrentTime
let memberProfile = profileFromName memberName
(localDisplayName, profileId) <- createNewMemberProfile_ db user memberProfile currentTs
@@ -3145,12 +3145,12 @@ createNewUnknownGroupMember db vr user@User {userId, userContactId} GroupInfo {g
:. (minV, maxV)
)
groupMemberId <- liftIO $ insertedRowId db
getGroupMemberById db vr user groupMemberId
getGroupMemberById db cxt user groupMemberId
where
VersionRange minV maxV = vr
VersionRange minV maxV = vr cxt
createLinkOwnerMember :: DB.Connection -> VersionRangeChat -> User -> GroupInfo -> Maybe ContactId -> MemberId -> C.PublicKeyEd25519 -> ExceptT StoreError IO GroupMember
createLinkOwnerMember db vr user@User {userId, userContactId} GroupInfo {groupId} contactId_ memberId ownerKey = do
createLinkOwnerMember :: DB.Connection -> StoreCxt -> User -> GroupInfo -> Maybe ContactId -> MemberId -> C.PublicKeyEd25519 -> ExceptT StoreError IO GroupMember
createLinkOwnerMember db cxt user@User {userId, userContactId} GroupInfo {groupId} contactId_ memberId ownerKey = do
currentTs <- liftIO getCurrentTime
let memberProfile = profileFromName $ nameFromMemberId memberId
(localDisplayName, profileId) <- createNewMemberProfile_ db user memberProfile currentTs
@@ -3170,15 +3170,15 @@ createLinkOwnerMember db vr user@User {userId, userContactId} GroupInfo {groupId
:. (minV, maxV)
)
groupMemberId <- liftIO $ insertedRowId db
getGroupMemberById db vr user groupMemberId
getGroupMemberById db cxt user groupMemberId
where
VersionRange minV maxV = vr
VersionRange minV maxV = vr cxt
-- member_pub_key is not updated here — introduced members are owners
-- whose keys are loaded from link data (trusted out-of-band).
-- Updating from an in-band message would allow a compromised relay to substitute keys.
updatePreparedChannelMember :: DB.Connection -> VersionRangeChat -> User -> GroupMember -> MemberInfo -> ExceptT StoreError IO GroupMember
updatePreparedChannelMember db vr user@User {userId} member@GroupMember {groupMemberId, memberChatVRange} MemberInfo {memberRole, v, profile} = do
updatePreparedChannelMember :: DB.Connection -> StoreCxt -> User -> GroupMember -> MemberInfo -> ExceptT StoreError IO GroupMember
updatePreparedChannelMember db cxt user@User {userId} member@GroupMember {groupMemberId, memberChatVRange} MemberInfo {memberRole, v, profile} = do
_ <- updateMemberProfile db user member profile
currentTs <- liftIO getCurrentTime
liftIO $
@@ -3194,12 +3194,12 @@ updatePreparedChannelMember db vr user@User {userId} member@GroupMember {groupMe
WHERE user_id = ? AND group_member_id = ?
|]
(memberRole, GSMemIntroduced, minV, maxV, currentTs, userId, groupMemberId)
getGroupMemberById db vr user groupMemberId
getGroupMemberById db cxt user groupMemberId
where
VersionRange minV maxV = maybe memberChatVRange fromChatVRange v
updateUnknownMemberAnnounced :: DB.Connection -> VersionRangeChat -> User -> GroupMember -> GroupMember -> MemberInfo -> GroupMemberStatus -> ExceptT StoreError IO GroupMember
updateUnknownMemberAnnounced db vr user@User {userId} invitingMember unknownMember@GroupMember {groupMemberId, memberChatVRange} MemberInfo {memberRole, v, profile, memberKey} status = do
updateUnknownMemberAnnounced :: DB.Connection -> StoreCxt -> User -> GroupMember -> GroupMember -> MemberInfo -> GroupMemberStatus -> ExceptT StoreError IO GroupMember
updateUnknownMemberAnnounced db cxt user@User {userId} invitingMember unknownMember@GroupMember {groupMemberId, memberChatVRange} MemberInfo {memberRole, v, profile, memberKey} status = do
_ <- updateMemberProfile db user unknownMember profile
currentTs <- liftIO getCurrentTime
liftIO $
@@ -3220,15 +3220,15 @@ updateUnknownMemberAnnounced db vr user@User {userId} invitingMember unknownMemb
( (memberRole, GCPostMember, status, groupMemberId' invitingMember)
:. (minV, maxV, memberPubKey_, currentTs, userId, groupMemberId)
)
getGroupMemberById db vr user groupMemberId
getGroupMemberById db cxt user groupMemberId
where
VersionRange minV maxV = maybe memberChatVRange fromChatVRange v
memberPubKey_ = (\(MemberKey k) -> k) <$> memberKey
-- Like updateUnknownMemberAnnounced but preserves member_role and member_pub_key
-- (roster-established for moderators/admins; the dissemination carries only the profile).
updateRosterMemberAnnounced :: DB.Connection -> VersionRangeChat -> User -> GroupMember -> GroupMember -> MemberInfo -> GroupMemberStatus -> ExceptT StoreError IO GroupMember
updateRosterMemberAnnounced db vr user@User {userId} invitingMember unknownMember@GroupMember {groupMemberId, memberChatVRange} MemberInfo {v, profile} status = do
updateRosterMemberAnnounced :: DB.Connection -> StoreCxt -> User -> GroupMember -> GroupMember -> MemberInfo -> GroupMemberStatus -> ExceptT StoreError IO GroupMember
updateRosterMemberAnnounced db cxt user@User {userId} invitingMember unknownMember@GroupMember {groupMemberId, memberChatVRange} MemberInfo {v, profile} status = do
_ <- updateMemberProfile db user unknownMember profile
currentTs <- liftIO getCurrentTime
liftIO $
@@ -3245,7 +3245,7 @@ updateRosterMemberAnnounced db vr user@User {userId} invitingMember unknownMembe
WHERE user_id = ? AND group_member_id = ?
|]
((GCPostMember, status, groupMemberId' invitingMember) :. (minV, maxV, currentTs, userId, groupMemberId))
getGroupMemberById db vr user groupMemberId
getGroupMemberById db cxt user groupMemberId
where
VersionRange minV maxV = maybe memberChatVRange fromChatVRange v
src/Simplex/Chat/Store/Messages.hs
+65 -65
View File
@@ -403,8 +403,8 @@ data MemberAttention
| MAReset
deriving (Show)
updateChatTsStats :: DB.Connection -> VersionRangeChat -> User -> ChatDirection c d -> UTCTime -> Maybe (Int, MemberAttention, Int) -> IO (ChatInfo c)
updateChatTsStats db vr user@User {userId} chatDirection chatTs chatStats_ = case toChatInfo chatDirection of
updateChatTsStats :: DB.Connection -> StoreCxt -> User -> ChatDirection c d -> UTCTime -> Maybe (Int, MemberAttention, Int) -> IO (ChatInfo c)
updateChatTsStats db cxt user@User {userId} chatDirection chatTs chatStats_ = case toChatInfo chatDirection of
DirectChat ct@Contact {contactId} -> do
DB.execute
db
@@ -513,7 +513,7 @@ updateChatTsStats db vr user@User {userId} chatDirection chatTs chatStats_ = cas
WHERE group_member_id = ?
|]
(chatTs, unread, mentions, groupMemberId)
m_ <- runExceptT $ getGroupMemberById db vr user groupMemberId
m_ <- runExceptT $ getGroupMemberById db cxt user groupMemberId
pure $ either (const m) id m_ -- Left shouldn't happen, but types require it
LocalChat nf@NoteFolder {noteFolderId} -> do
DB.execute
@@ -527,8 +527,8 @@ setSupportChatTs :: DB.Connection -> GroupMemberId -> UTCTime -> IO ()
setSupportChatTs db groupMemberId chatTs =
DB.execute db "UPDATE group_members SET support_chat_ts = ? WHERE group_member_id = ?" (chatTs, groupMemberId)
setSupportChatMemberAttention :: DB.Connection -> VersionRangeChat -> User -> GroupInfo -> GroupMember -> Int64 -> IO (GroupInfo, GroupMember)
setSupportChatMemberAttention db vr user g m memberAttention = do
setSupportChatMemberAttention :: DB.Connection -> StoreCxt -> User -> GroupInfo -> GroupMember -> Int64 -> IO (GroupInfo, GroupMember)
setSupportChatMemberAttention db cxt user g m memberAttention = do
m' <- updateGMAttention
g' <- updateGroupMembersRequireAttention db user g m m'
pure (g', m')
@@ -539,7 +539,7 @@ setSupportChatMemberAttention db vr user g m memberAttention = do
db
"UPDATE group_members SET support_chat_items_member_attention = ?, updated_at = ? WHERE group_member_id = ?"
(memberAttention, currentTs, groupMemberId' m)
m_ <- runExceptT $ getGroupMemberById db vr user (groupMemberId' m)
m_ <- runExceptT $ getGroupMemberById db cxt user (groupMemberId' m)
pure $ either (const m) id m_ -- Left shouldn't happen, but types require it
createNewSndChatItem :: DB.Connection -> User -> ChatDirection c 'MDSnd -> ShowGroupAsSender -> SndMessage -> CIContent 'MDSnd -> Maybe (CIQuote c) -> Maybe CIForwardedFrom -> Maybe CITimed -> Bool -> Bool -> UTCTime -> IO ChatItemId
@@ -730,8 +730,8 @@ getChatItemQuote_ db User {userId, userContactId} chatDirection QuotedMsg {msgRe
ciQuoteGroup [] = ciQuote Nothing $ CIQGroupRcv Nothing
ciQuoteGroup ((Only itemId :. memberRow) : _) = ciQuote itemId . CIQGroupRcv . Just $ toGroupMember userContactId memberRow
getChatPreviews :: DB.Connection -> VersionRangeChat -> User -> Bool -> PaginationByTime -> ChatListQuery -> IO [Either StoreError AChat]
getChatPreviews db vr user withPCC pagination query = do
getChatPreviews :: DB.Connection -> StoreCxt -> User -> Bool -> PaginationByTime -> ChatListQuery -> IO [Either StoreError AChat]
getChatPreviews db cxt user withPCC pagination query = do
directChats <- findDirectChatPreviews_ db user pagination query
groupChats <- findGroupChatPreviews_ db user pagination query
localChats <- findLocalChatPreviews_ db user pagination query
@@ -753,8 +753,8 @@ getChatPreviews db vr user withPCC pagination query = do
PTBefore _ count -> take count . sortBy (comparing $ Down . ts)
getChatPreview :: AChatPreviewData -> ExceptT StoreError IO AChat
getChatPreview (ACPD cType cpd) = case cType of
SCTDirect -> getDirectChatPreview_ db vr user cpd
SCTGroup -> getGroupChatPreview_ db vr user cpd
SCTDirect -> getDirectChatPreview_ db cxt user cpd
SCTGroup -> getGroupChatPreview_ db cxt user cpd
SCTLocal -> getLocalChatPreview_ db user cpd
SCTContactRequest -> let (ContactRequestPD _ chat) = cpd in pure chat
SCTContactConnection -> let (ContactConnectionPD _ chat) = cpd in pure chat
@@ -871,9 +871,9 @@ findDirectChatPreviews_ db User {userId} pagination clq =
PTAfter ts count -> DB.query db (query <> " AND ct.chat_ts > ? ORDER BY ct.chat_ts ASC LIMIT ?") (params :. (ts, count))
PTBefore ts count -> DB.query db (query <> " AND ct.chat_ts < ? ORDER BY ct.chat_ts DESC LIMIT ?") (params :. (ts, count))
getDirectChatPreview_ :: DB.Connection -> VersionRangeChat -> User -> ChatPreviewData 'CTDirect -> ExceptT StoreError IO AChat
getDirectChatPreview_ db vr user (DirectChatPD _ contactId lastItemId_ stats) = do
contact <- getContact db vr user contactId
getDirectChatPreview_ :: DB.Connection -> StoreCxt -> User -> ChatPreviewData 'CTDirect -> ExceptT StoreError IO AChat
getDirectChatPreview_ db cxt user (DirectChatPD _ contactId lastItemId_ stats) = do
contact <- getContact db cxt user contactId
ts <- liftIO getCurrentTime
lastItem <- case lastItemId_ of
Just lastItemId -> do
@@ -982,9 +982,9 @@ findGroupChatPreviews_ db User {userId} pagination clq =
PTAfter ts count -> DB.query db (query <> " AND g.chat_ts > ? ORDER BY g.chat_ts ASC LIMIT ?") (params :. (ts, count))
PTBefore ts count -> DB.query db (query <> " AND g.chat_ts < ? ORDER BY g.chat_ts DESC LIMIT ?") (params :. (ts, count))
getGroupChatPreview_ :: DB.Connection -> VersionRangeChat -> User -> ChatPreviewData 'CTGroup -> ExceptT StoreError IO AChat
getGroupChatPreview_ db vr user (GroupChatPD _ groupId lastItemId_ stats) = do
groupInfo <- getGroupInfo db vr user groupId
getGroupChatPreview_ :: DB.Connection -> StoreCxt -> User -> ChatPreviewData 'CTGroup -> ExceptT StoreError IO AChat
getGroupChatPreview_ db cxt user (GroupChatPD _ groupId lastItemId_ stats) = do
groupInfo <- getGroupInfo db cxt user groupId
ts <- liftIO getCurrentTime
lastItem <- case lastItemId_ of
Just lastItemId -> do
@@ -1220,10 +1220,10 @@ getChatContentTypes db User {userId} (ChatRef cType chatId chatScope_) = case cT
("SELECT DISTINCT msg_content_tag FROM chat_items WHERE user_id = ? AND " <> cond <> " AND msg_content_tag IS NOT NULL ORDER BY msg_content_tag")
((userId, chatId) :. params)
getDirectChat :: DB.Connection -> VersionRangeChat -> User -> Int64 -> Maybe MsgContentTag -> ChatPagination -> Maybe Text -> ExceptT StoreError IO (Chat 'CTDirect, Maybe NavigationInfo)
getDirectChat db vr user contactId contentFilter pagination search_ = do
getDirectChat :: DB.Connection -> StoreCxt -> User -> Int64 -> Maybe MsgContentTag -> ChatPagination -> Maybe Text -> ExceptT StoreError IO (Chat 'CTDirect, Maybe NavigationInfo)
getDirectChat db cxt user contactId contentFilter pagination search_ = do
let search = fromMaybe "" search_
ct <- getContact db vr user contactId
ct <- getContact db cxt user contactId
case pagination of
CPLast count -> (,Nothing) <$> getDirectChatLast_ db user ct contentFilter count search
CPAfter afterId count -> (,Nothing) <$> getDirectChatAfter_ db user ct contentFilter afterId count search
@@ -1440,11 +1440,11 @@ getContactNavInfo_ db User {userId} Contact {contactId} afterCI = do
:. (userId, contactId, ciCreatedAt afterCI, cChatItemId afterCI)
)
getGroupChat :: DB.Connection -> VersionRangeChat -> User -> Int64 -> Maybe GroupChatScope -> Maybe MsgContentTag -> ChatPagination -> Maybe Text -> ExceptT StoreError IO (Chat 'CTGroup, Maybe NavigationInfo)
getGroupChat db vr user groupId scope_ contentFilter pagination search_ = do
getGroupChat :: DB.Connection -> StoreCxt -> User -> Int64 -> Maybe GroupChatScope -> Maybe MsgContentTag -> ChatPagination -> Maybe Text -> ExceptT StoreError IO (Chat 'CTGroup, Maybe NavigationInfo)
getGroupChat db cxt user groupId scope_ contentFilter pagination search_ = do
let search = fromMaybe "" search_
g <- getGroupInfo db vr user groupId
scopeInfo <- mapM (getCreateGroupChatScopeInfo db vr user g) scope_
g <- getGroupInfo db cxt user groupId
scopeInfo <- mapM (getCreateGroupChatScopeInfo db cxt user g) scope_
case pagination of
CPLast count -> (,Nothing) <$> getGroupChatLast_ db user g scopeInfo contentFilter count search emptyChatStats
CPAfter afterId count -> (,Nothing) <$> getGroupChatAfter_ db user g scopeInfo contentFilter afterId count search
@@ -1454,31 +1454,31 @@ getGroupChat db vr user groupId scope_ contentFilter pagination search_ = do
unless (T.null search) $ throwError $ SEInternalError "initial chat pagination doesn't support search"
getGroupChatInitial_ db user g scopeInfo contentFilter count
getCreateGroupChatScopeInfo :: DB.Connection -> VersionRangeChat -> User -> GroupInfo -> GroupChatScope -> ExceptT StoreError IO GroupChatScopeInfo
getCreateGroupChatScopeInfo db vr user GroupInfo {membership} = \case
getCreateGroupChatScopeInfo :: DB.Connection -> StoreCxt -> User -> GroupInfo -> GroupChatScope -> ExceptT StoreError IO GroupChatScopeInfo
getCreateGroupChatScopeInfo db cxt user GroupInfo {membership} = \case
GCSMemberSupport Nothing -> do
when (isNothing $ supportChat membership) $ do
ts <- liftIO getCurrentTime
liftIO $ setSupportChatTs db (groupMemberId' membership) ts
pure $ GCSIMemberSupport {groupMember_ = Nothing}
GCSMemberSupport (Just gmId) -> do
m <- getGroupMemberById db vr user gmId
m <- getGroupMemberById db cxt user gmId
when (isNothing $ supportChat m) $ do
ts <- liftIO getCurrentTime
liftIO $ setSupportChatTs db gmId ts
pure GCSIMemberSupport {groupMember_ = Just m}
getGroupChatScopeInfoForItem :: DB.Connection -> VersionRangeChat -> User -> GroupInfo -> ChatItemId -> ExceptT StoreError IO (Maybe GroupChatScopeInfo)
getGroupChatScopeInfoForItem db vr user g itemId =
getGroupChatScopeForItem_ db itemId >>= mapM (getGroupChatScopeInfo db vr user g)
getGroupChatScopeInfoForItem :: DB.Connection -> StoreCxt -> User -> GroupInfo -> ChatItemId -> ExceptT StoreError IO (Maybe GroupChatScopeInfo)
getGroupChatScopeInfoForItem db cxt user g itemId =
getGroupChatScopeForItem_ db itemId >>= mapM (getGroupChatScopeInfo db cxt user g)
getGroupChatScopeInfo :: DB.Connection -> VersionRangeChat -> User -> GroupInfo -> GroupChatScope -> ExceptT StoreError IO GroupChatScopeInfo
getGroupChatScopeInfo db vr user GroupInfo {membership} = \case
getGroupChatScopeInfo :: DB.Connection -> StoreCxt -> User -> GroupInfo -> GroupChatScope -> ExceptT StoreError IO GroupChatScopeInfo
getGroupChatScopeInfo db cxt user GroupInfo {membership} = \case
GCSMemberSupport Nothing -> case supportChat membership of
Nothing -> throwError $ SEInternalError "no moderators support chat"
Just _supportChat -> pure $ GCSIMemberSupport {groupMember_ = Nothing}
GCSMemberSupport (Just gmId) -> do
m <- getGroupMemberById db vr user gmId
m <- getGroupMemberById db cxt user gmId
case supportChat m of
Nothing -> throwError $ SEInternalError "no support chat"
Just _supportChat -> pure GCSIMemberSupport {groupMember_ = Just m}
@@ -2084,8 +2084,8 @@ updateGroupChatItemsRead db User {userId} GroupInfo {groupId} = do
|]
(CISRcvRead, currentTs, userId, groupId, CISRcvNew)
updateSupportChatItemsRead :: DB.Connection -> VersionRangeChat -> User -> GroupInfo -> GroupChatScopeInfo -> IO (GroupInfo, GroupMember)
updateSupportChatItemsRead db vr user@User {userId} g@GroupInfo {groupId, membership} scopeInfo = do
updateSupportChatItemsRead :: DB.Connection -> StoreCxt -> User -> GroupInfo -> GroupChatScopeInfo -> IO (GroupInfo, GroupMember)
updateSupportChatItemsRead db cxt user@User {userId} g@GroupInfo {groupId, membership} scopeInfo = do
currentTs <- getCurrentTime
case scopeInfo of
GCSIMemberSupport {groupMember_} -> do
@@ -2123,7 +2123,7 @@ updateSupportChatItemsRead db vr user@User {userId} g@GroupInfo {groupId, member
WHERE group_member_id = ?
|]
(currentTs, groupMemberId)
m_ <- runExceptT $ getGroupMemberById db vr user groupMemberId
m_ <- runExceptT $ getGroupMemberById db cxt user groupMemberId
pure $ either (const m) id m_ -- Left shouldn't happen, but types require it
getGroupUnreadTimedItems :: DB.Connection -> User -> GroupId -> Maybe GroupChatScope -> IO [(ChatItemId, Int)]
@@ -2151,8 +2151,8 @@ getGroupUnreadTimedItems db User {userId} groupId scope =
|]
(userId, groupId, GCSTMemberSupport_, groupMemberId_, CISRcvNew)
updateGroupChatItemsReadList :: DB.Connection -> VersionRangeChat -> User -> GroupInfo -> Maybe GroupChatScopeInfo -> NonEmpty ChatItemId -> ExceptT StoreError IO ([(ChatItemId, Int)], GroupInfo)
updateGroupChatItemsReadList db vr user@User {userId} g@GroupInfo {groupId} scopeInfo_ itemIds = do
updateGroupChatItemsReadList :: DB.Connection -> StoreCxt -> User -> GroupInfo -> Maybe GroupChatScopeInfo -> NonEmpty ChatItemId -> ExceptT StoreError IO ([(ChatItemId, Int)], GroupInfo)
updateGroupChatItemsReadList db cxt user@User {userId} g@GroupInfo {groupId} scopeInfo_ itemIds = do
currentTs <- liftIO getCurrentTime
-- Possible improvement is to differentiate retrieval queries for each scope,
-- but we rely on UI to not pass item IDs from incorrect scope.
@@ -2161,7 +2161,7 @@ updateGroupChatItemsReadList db vr user@User {userId} g@GroupInfo {groupId} scop
Nothing -> pure g
Just scopeInfo@GCSIMemberSupport {groupMember_} -> do
let decStats = countReadItems groupMember_ readItemsData
liftIO $ updateGroupScopeUnreadStats db vr user g scopeInfo decStats
liftIO $ updateGroupScopeUnreadStats db cxt user g scopeInfo decStats
pure (timedItems readItemsData, g')
where
getUpdateGroupItem :: UTCTime -> ChatItemId -> IO (Maybe (ChatItemId, Maybe Int, Maybe UTCTime, Maybe GroupMemberId, Maybe BoolInt))
@@ -2196,8 +2196,8 @@ updateGroupChatItemsReadList db vr user@User {userId} g@GroupInfo {groupId} scop
addTimedItem acc (itemId, Just ttl, Nothing, _, _) = (itemId, ttl) : acc
addTimedItem acc _ = acc
updateGroupScopeUnreadStats :: DB.Connection -> VersionRangeChat -> User -> GroupInfo -> GroupChatScopeInfo -> (Int, Int, Int) -> IO GroupInfo
updateGroupScopeUnreadStats db vr user g@GroupInfo {membership} scopeInfo (unread, unanswered, mentions) =
updateGroupScopeUnreadStats :: DB.Connection -> StoreCxt -> User -> GroupInfo -> GroupChatScopeInfo -> (Int, Int, Int) -> IO GroupInfo
updateGroupScopeUnreadStats db cxt user g@GroupInfo {membership} scopeInfo (unread, unanswered, mentions) =
case scopeInfo of
GCSIMemberSupport {groupMember_} -> case groupMember_ of
Nothing -> do
@@ -2235,7 +2235,7 @@ updateGroupScopeUnreadStats db vr user g@GroupInfo {membership} scopeInfo (unrea
|]
#endif
(unread, unanswered, mentions, currentTs, groupMemberId)
m_ <- runExceptT $ getGroupMemberById db vr user groupMemberId
m_ <- runExceptT $ getGroupMemberById db cxt user groupMemberId
pure $ either (const m) id m_ -- Left shouldn't happen, but types require it
setGroupChatItemsDeleteAt :: DB.Connection -> User -> GroupId -> [(ChatItemId, Int)] -> UTCTime -> IO [(ChatItemId, UTCTime)]
@@ -2410,8 +2410,8 @@ toGroupChatItem
ciTimed :: Maybe CITimed
ciTimed = timedTTL >>= \ttl -> Just CITimed {ttl, deleteAt = timedDeleteAt}
getAllChatItems :: DB.Connection -> VersionRangeChat -> User -> ChatPagination -> Maybe Text -> ExceptT StoreError IO [AChatItem]
getAllChatItems db vr user@User {userId} pagination search_ = do
getAllChatItems :: DB.Connection -> StoreCxt -> User -> ChatPagination -> Maybe Text -> ExceptT StoreError IO [AChatItem]
getAllChatItems db cxt user@User {userId} pagination search_ = do
itemRefs <-
rights . map toChatItemRef <$> case pagination of
CPLast count -> liftIO $ getAllChatItemsLast_ count
@@ -2423,12 +2423,12 @@ getAllChatItems db vr user@User {userId} pagination search_ = do
liftIO getFirstUnreadItemId_ >>= \case
Just itemId -> liftIO . getAllChatItemsAround_ itemId count . aChatItemTs =<< getAChatItem_ itemId
Nothing -> liftIO $ getAllChatItemsLast_ count
mapM (uncurry (getAChatItem db vr user)) itemRefs
mapM (uncurry (getAChatItem db cxt user)) itemRefs
where
search = fromMaybe "" search_
getAChatItem_ itemId = do
chatRef <- getChatRefViaItemId db user itemId
getAChatItem db vr user chatRef itemId
getAChatItem db cxt user chatRef itemId
getAllChatItemsLast_ count =
reverse
<$> DB.query
@@ -3236,8 +3236,8 @@ deleteLocalChatItem db User {userId} NoteFolder {noteFolderId} ci = do
|]
(userId, noteFolderId, itemId)
getChatItemByFileId :: DB.Connection -> VersionRangeChat -> User -> Int64 -> ExceptT StoreError IO AChatItem
getChatItemByFileId db vr user@User {userId} fileId = do
getChatItemByFileId :: DB.Connection -> StoreCxt -> User -> Int64 -> ExceptT StoreError IO AChatItem
getChatItemByFileId db cxt user@User {userId} fileId = do
(chatRef, itemId) <-
ExceptT . firstRow' toChatItemRef (SEChatItemNotFoundByFileId fileId) $
DB.query
@@ -3250,16 +3250,16 @@ getChatItemByFileId db vr user@User {userId} fileId = do
LIMIT 1
|]
(userId, fileId)
getAChatItem db vr user chatRef itemId
getAChatItem db cxt user chatRef itemId
lookupChatItemByFileId :: DB.Connection -> VersionRangeChat -> User -> Int64 -> ExceptT StoreError IO (Maybe AChatItem)
lookupChatItemByFileId db vr user fileId = do
fmap Just (getChatItemByFileId db vr user fileId) `catchError` \case
lookupChatItemByFileId :: DB.Connection -> StoreCxt -> User -> Int64 -> ExceptT StoreError IO (Maybe AChatItem)
lookupChatItemByFileId db cxt user fileId = do
fmap Just (getChatItemByFileId db cxt user fileId) `catchError` \case
SEChatItemNotFoundByFileId {} -> pure Nothing
e -> throwError e
getChatItemByGroupId :: DB.Connection -> VersionRangeChat -> User -> GroupId -> ExceptT StoreError IO AChatItem
getChatItemByGroupId db vr user@User {userId} groupId = do
getChatItemByGroupId :: DB.Connection -> StoreCxt -> User -> GroupId -> ExceptT StoreError IO AChatItem
getChatItemByGroupId db cxt user@User {userId} groupId = do
(chatRef, itemId) <-
ExceptT . firstRow' toChatItemRef (SEChatItemNotFoundByGroupId groupId) $
DB.query
@@ -3272,7 +3272,7 @@ getChatItemByGroupId db vr user@User {userId} groupId = do
LIMIT 1
|]
(userId, groupId)
getAChatItem db vr user chatRef itemId
getAChatItem db cxt user chatRef itemId
getChatRefViaItemId :: DB.Connection -> User -> ChatItemId -> ExceptT StoreError IO ChatRef
getChatRefViaItemId db User {userId} itemId = do
@@ -3285,17 +3285,17 @@ getChatRefViaItemId db User {userId} itemId = do
(Nothing, Just groupId) -> Right $ ChatRef CTGroup groupId Nothing
(_, _) -> Left $ SEBadChatItem itemId Nothing
getAChatItem :: DB.Connection -> VersionRangeChat -> User -> ChatRef -> ChatItemId -> ExceptT StoreError IO AChatItem
getAChatItem db vr user (ChatRef cType chatId scope) itemId = do
getAChatItem :: DB.Connection -> StoreCxt -> User -> ChatRef -> ChatItemId -> ExceptT StoreError IO AChatItem
getAChatItem db cxt user (ChatRef cType chatId scope) itemId = do
aci <- case cType of
CTDirect -> do
ct <- getContact db vr user chatId
ct <- getContact db cxt user chatId
(CChatItem msgDir ci) <- getDirectChatItem db user chatId itemId
pure $ AChatItem SCTDirect msgDir (DirectChat ct) ci
CTGroup -> do
gInfo <- getGroupInfo db vr user chatId
gInfo <- getGroupInfo db cxt user chatId
(CChatItem msgDir ci) <- getGroupChatItem db user chatId itemId
scopeInfo <- mapM (getGroupChatScopeInfo db vr user gInfo) scope
scopeInfo <- mapM (getGroupChatScopeInfo db cxt user gInfo) scope
pure $ AChatItem SCTGroup msgDir (GroupChat gInfo scopeInfo) ci
CTLocal -> do
nf <- getNoteFolder db user chatId
@@ -3471,8 +3471,8 @@ setGroupReaction db GroupInfo {groupId} m itemMemberId itemSharedMId sent reacti
|]
(groupId, groupMemberId' m, itemSharedMId, itemMemberId, BI sent, reaction)
getReactionMembers :: DB.Connection -> VersionRangeChat -> User -> GroupId -> SharedMsgId -> MsgReaction -> IO [MemberReaction]
getReactionMembers db vr user groupId itemSharedMId reaction = do
getReactionMembers :: DB.Connection -> StoreCxt -> User -> GroupId -> SharedMsgId -> MsgReaction -> IO [MemberReaction]
getReactionMembers db cxt user groupId itemSharedMId reaction = do
reactions <-
DB.query
db
@@ -3486,7 +3486,7 @@ getReactionMembers db vr user groupId itemSharedMId reaction = do
where
toMemberReaction :: (GroupMemberId, UTCTime) -> ExceptT StoreError IO MemberReaction
toMemberReaction (groupMemberId, reactionTs) = do
groupMember <- getGroupMemberById db vr user groupMemberId
groupMember <- getGroupMemberById db cxt user groupMemberId
pure MemberReaction {groupMember, reactionTs}
getTimedItems :: DB.Connection -> User -> UTCTime -> IO [((ChatRef, ChatItemId), UTCTime)]
@@ -3584,9 +3584,9 @@ createCIModeration db GroupInfo {groupId} moderatorMember itemMemberId itemShare
|]
(groupId, groupMemberId' moderatorMember, itemMemberId, itemSharedMId, msgId, moderatedAtTs)
getCIModeration :: DB.Connection -> VersionRangeChat -> User -> GroupInfo -> MemberId -> Maybe SharedMsgId -> IO (Maybe CIModeration)
getCIModeration :: DB.Connection -> StoreCxt -> User -> GroupInfo -> MemberId -> Maybe SharedMsgId -> IO (Maybe CIModeration)
getCIModeration _ _ _ _ _ Nothing = pure Nothing
getCIModeration db vr user GroupInfo {groupId} itemMemberId (Just sharedMsgId) = do
getCIModeration db cxt user GroupInfo {groupId} itemMemberId (Just sharedMsgId) = do
r_ <-
maybeFirstRow id $
DB.query
@@ -3600,7 +3600,7 @@ getCIModeration db vr user GroupInfo {groupId} itemMemberId (Just sharedMsgId) =
(groupId, itemMemberId, sharedMsgId)
case r_ of
Just (moderationId, moderatorId, createdByMsgId, moderatedAt) -> do
runExceptT (getGroupMember db vr user groupId moderatorId) >>= \case
runExceptT (getGroupMember db cxt user groupId moderatorId) >>= \case
Right moderatorMember -> pure (Just CIModeration {moderationId, moderatorMember, createdByMsgId, moderatedAt})
_ -> pure Nothing
_ -> pure Nothing
src/Simplex/Chat/Store/Profiles.hs
+9 -9
View File
@@ -388,9 +388,9 @@ createUserContactLink db User {userId} agentConnId (CCLink cReq shortLink) subMo
userContactLinkId <- insertedRowId db
void $ createConnection_ db userId ConnUserContact (Just userContactLinkId) agentConnId ConnNew initialChatVersion chatInitialVRange Nothing Nothing Nothing 0 currentTs subMode CR.PQSupportOff
getUserAddressConnection :: DB.Connection -> VersionRangeChat -> User -> ExceptT StoreError IO Connection
getUserAddressConnection db vr User {userId} = do
ExceptT . firstRow (toConnection vr) SEUserContactLinkNotFound $
getUserAddressConnection :: DB.Connection -> StoreCxt -> User -> ExceptT StoreError IO Connection
getUserAddressConnection db cxt User {userId} = do
ExceptT . firstRow (toConnection cxt) SEUserContactLinkNotFound $
DB.query
db
[sql|
@@ -533,8 +533,8 @@ setUserContactLinkShortLink db userContactLinkId shortLink =
|]
(shortLink, BI True, BI True, BI False, userContactLinkId)
getContactWithoutConnViaAddress :: DB.Connection -> VersionRangeChat -> User -> (ConnReqContact, ConnReqContact) -> IO (Maybe Contact)
getContactWithoutConnViaAddress db vr user@User {userId} (cReqSchema1, cReqSchema2) = do
getContactWithoutConnViaAddress :: DB.Connection -> StoreCxt -> User -> (ConnReqContact, ConnReqContact) -> IO (Maybe Contact)
getContactWithoutConnViaAddress db cxt user@User {userId} (cReqSchema1, cReqSchema2) = do
ctId_ <-
maybeFirstRow fromOnly $
DB.query
@@ -547,10 +547,10 @@ getContactWithoutConnViaAddress db vr user@User {userId} (cReqSchema1, cReqSchem
WHERE cp.user_id = ? AND cp.contact_link IN (?,?) AND c.connection_id IS NULL
|]
(userId, cReqSchema1, cReqSchema2)
maybe (pure Nothing) (fmap eitherToMaybe . runExceptT . getContact db vr user) ctId_
maybe (pure Nothing) (fmap eitherToMaybe . runExceptT . getContact db cxt user) ctId_
getContactWithoutConnViaShortAddress :: DB.Connection -> VersionRangeChat -> User -> ShortLinkContact -> IO (Maybe Contact)
getContactWithoutConnViaShortAddress db vr user@User {userId} shortLink = do
getContactWithoutConnViaShortAddress :: DB.Connection -> StoreCxt -> User -> ShortLinkContact -> IO (Maybe Contact)
getContactWithoutConnViaShortAddress db cxt user@User {userId} shortLink = do
ctId_ <-
maybeFirstRow fromOnly $
DB.query
@@ -563,7 +563,7 @@ getContactWithoutConnViaShortAddress db vr user@User {userId} shortLink = do
WHERE cp.user_id = ? AND cp.contact_link = ? AND c.connection_id IS NULL
|]
(userId, shortLink)
maybe (pure Nothing) (fmap eitherToMaybe . runExceptT . getContact db vr user) ctId_
maybe (pure Nothing) (fmap eitherToMaybe . runExceptT . getContact db cxt user) ctId_
updateUserAddressSettings :: DB.Connection -> Int64 -> AddressSettings -> IO ()
updateUserAddressSettings db userContactLinkId AddressSettings {businessAddress, autoAccept, autoReply} =
src/Simplex/Chat/Store/Shared.hs
+18 -18
View File
@@ -228,12 +228,12 @@ type ConnectionRow = (Int64, ConnId, Int, Maybe Int64, Maybe Int64, BoolInt, May
type MaybeConnectionRow = (Maybe Int64, Maybe ConnId, Maybe Int, Maybe Int64, Maybe Int64, Maybe BoolInt, Maybe GroupLinkId, Maybe XContactId) :. (Maybe Int64, Maybe ConnStatus, Maybe ConnType, Maybe BoolInt, Maybe LocalAlias) :. EntityIdsRow :. (Maybe UTCTime, Maybe Text, Maybe UTCTime, Maybe PQSupport, Maybe PQEncryption, Maybe PQEncryption, Maybe PQEncryption, Maybe Int, Maybe Int, Maybe VersionChat, Maybe VersionChat, Maybe VersionChat)
toConnection :: VersionRangeChat -> ConnectionRow -> Connection
toConnection vr ((connId, acId, connLevel, viaContact, viaUserContactLink, BI viaGroupLink, groupLinkId, xContactId) :. (customUserProfileId, connStatus, connType, BI contactConnInitiated, localAlias) :. (contactId, groupMemberId, userContactLinkId) :. (createdAt, code_, verifiedAt_, pqSupport, pqEncryption, pqSndEnabled, pqRcvEnabled, authErrCounter, quotaErrCounter, chatV, minVer, maxVer)) =
toConnection :: StoreCxt -> ConnectionRow -> Connection
toConnection cxt ((connId, acId, connLevel, viaContact, viaUserContactLink, BI viaGroupLink, groupLinkId, xContactId) :. (customUserProfileId, connStatus, connType, BI contactConnInitiated, localAlias) :. (contactId, groupMemberId, userContactLinkId) :. (createdAt, code_, verifiedAt_, pqSupport, pqEncryption, pqSndEnabled, pqRcvEnabled, authErrCounter, quotaErrCounter, chatV, minVer, maxVer)) =
Connection
{ connId,
agentConnId = AgentConnId acId,
connChatVersion = fromMaybe (vr `peerConnChatVersion` peerChatVRange) chatV,
connChatVersion = fromMaybe (vr cxt `peerConnChatVersion` peerChatVRange) chatV,
peerChatVRange = peerChatVRange,
connLevel,
viaContact,
@@ -263,9 +263,9 @@ toConnection vr ((connId, acId, connLevel, viaContact, viaUserContactLink, BI vi
entityId_ ConnMember = groupMemberId
entityId_ ConnUserContact = userContactLinkId
toMaybeConnection :: VersionRangeChat -> MaybeConnectionRow -> Maybe Connection
toMaybeConnection vr ((Just connId, Just agentConnId, Just connLevel, viaContact, viaUserContactLink, Just viaGroupLink, groupLinkId, xContactId) :. (customUserProfileId, Just connStatus, Just connType, Just contactConnInitiated, Just localAlias) :. (contactId, groupMemberId, userContactLinkId) :. (Just createdAt, code_, verifiedAt_, Just pqSupport, Just pqEncryption, pqSndEnabled_, pqRcvEnabled_, Just authErrCounter, Just quotaErrCounter, connChatVersion, Just minVer, Just maxVer)) =
Just $ toConnection vr ((connId, agentConnId, connLevel, viaContact, viaUserContactLink, viaGroupLink, groupLinkId, xContactId) :. (customUserProfileId, connStatus, connType, contactConnInitiated, localAlias) :. (contactId, groupMemberId, userContactLinkId) :. (createdAt, code_, verifiedAt_, pqSupport, pqEncryption, pqSndEnabled_, pqRcvEnabled_, authErrCounter, quotaErrCounter, connChatVersion, minVer, maxVer))
toMaybeConnection :: StoreCxt -> MaybeConnectionRow -> Maybe Connection
toMaybeConnection cxt ((Just connId, Just agentConnId, Just connLevel, viaContact, viaUserContactLink, Just viaGroupLink, groupLinkId, xContactId) :. (customUserProfileId, Just connStatus, Just connType, Just contactConnInitiated, Just localAlias) :. (contactId, groupMemberId, userContactLinkId) :. (Just createdAt, code_, verifiedAt_, Just pqSupport, Just pqEncryption, pqSndEnabled_, pqRcvEnabled_, Just authErrCounter, Just quotaErrCounter, connChatVersion, Just minVer, Just maxVer)) =
Just $ toConnection cxt ((connId, agentConnId, connLevel, viaContact, viaUserContactLink, viaGroupLink, groupLinkId, xContactId) :. (customUserProfileId, connStatus, connType, contactConnInitiated, localAlias) :. (contactId, groupMemberId, userContactLinkId) :. (createdAt, code_, verifiedAt_, pqSupport, pqEncryption, pqSndEnabled_, pqRcvEnabled_, authErrCounter, quotaErrCounter, connChatVersion, minVer, maxVer))
toMaybeConnection _ _ = Nothing
createConnection_ :: DB.Connection -> UserId -> ConnType -> Maybe Int64 -> ConnId -> ConnStatus -> VersionChat -> VersionRangeChat -> Maybe ContactId -> Maybe Int64 -> Maybe ProfileId -> Int -> UTCTime -> SubscriptionMode -> PQSupport -> IO Connection
@@ -488,10 +488,10 @@ type ContactRow' = (ProfileId, ContactName, ContactName, Text, Maybe Text, Maybe
type ContactRow = Only ContactId :. ContactRow'
toContact :: VersionRangeChat -> User -> [ChatTagId] -> ContactRow :. MaybeConnectionRow -> Contact
toContact vr user chatTags ((Only contactId :. (profileId, localDisplayName, displayName, fullName, shortDescr, image, contactLink, peerType, localAlias, BI contactUsed, contactStatus) :. (enableNtfs_, sendRcpts, BI favorite, preferences, userPreferences, createdAt, updatedAt, chatTs) :. preparedContactRow :. (contactRequestId, contactGroupMemberId, BI contactGrpInvSent) :. groupDirectInvRow :. (uiThemes, BI chatDeleted, customData, chatItemTTL)) :. connRow) =
toContact :: StoreCxt -> User -> [ChatTagId] -> ContactRow :. MaybeConnectionRow -> Contact
toContact cxt user chatTags ((Only contactId :. (profileId, localDisplayName, displayName, fullName, shortDescr, image, contactLink, peerType, localAlias, BI contactUsed, contactStatus) :. (enableNtfs_, sendRcpts, BI favorite, preferences, userPreferences, createdAt, updatedAt, chatTs) :. preparedContactRow :. (contactRequestId, contactGroupMemberId, BI contactGrpInvSent) :. groupDirectInvRow :. (uiThemes, BI chatDeleted, customData, chatItemTTL)) :. connRow) =
let profile = LocalProfile {profileId, displayName, fullName, shortDescr, image, contactLink, peerType, preferences, localAlias}
activeConn = toMaybeConnection vr connRow
activeConn = toMaybeConnection cxt connRow
chatSettings = ChatSettings {enableNtfs = fromMaybe MFAll enableNtfs_, sendRcpts = unBI <$> sendRcpts, favorite}
incognito = maybe False connIncognito activeConn
mergedPreferences = contactUserPreferences user userPreferences preferences incognito
@@ -673,9 +673,9 @@ type GroupMemberRow = (GroupMemberId, GroupId, Int64, MemberId, VersionChat, Ver
type ProfileRow = (ProfileId, ContactName, Text, Maybe Text, Maybe ImageData, Maybe ConnLinkContact, Maybe ChatPeerType, LocalAlias, Maybe Preferences)
toGroupInfo :: VersionRangeChat -> Int64 -> [ChatTagId] -> GroupInfoRow -> GroupInfo
toGroupInfo vr userContactId chatTags ((groupId, localDisplayName, displayName, fullName, shortDescr, localAlias, description, image, groupType_, groupLink_, publicGroupId_) :. accessRow :. (enableNtfs_, sendRcpts, BI favorite, groupPreferences, memberAdmission) :. (createdAt, updatedAt, chatTs, userMemberProfileSentAt) :. preparedGroupRow :. businessRow :. (BI useRelays, relayOwnStatus, uiThemes, currentMembers, publicMemberCount, rosterVersion, customData, chatItemTTL, membersRequireAttention, viaGroupLinkUri) :. groupKeysRow :. userMemberRow) =
let membership = (toGroupMember userContactId userMemberRow) {memberChatVRange = vr}
toGroupInfo :: StoreCxt -> Int64 -> [ChatTagId] -> GroupInfoRow -> GroupInfo
toGroupInfo cxt userContactId chatTags ((groupId, localDisplayName, displayName, fullName, shortDescr, localAlias, description, image, groupType_, groupLink_, publicGroupId_) :. accessRow :. (enableNtfs_, sendRcpts, BI favorite, groupPreferences, memberAdmission) :. (createdAt, updatedAt, chatTs, userMemberProfileSentAt) :. preparedGroupRow :. businessRow :. (BI useRelays, relayOwnStatus, uiThemes, currentMembers, publicMemberCount, rosterVersion, customData, chatItemTTL, membersRequireAttention, viaGroupLinkUri) :. groupKeysRow :. userMemberRow) =
let membership = (toGroupMember userContactId userMemberRow) {memberChatVRange = vr cxt}
chatSettings = ChatSettings {enableNtfs = fromMaybe MFAll enableNtfs_, sendRcpts = unBI <$> sendRcpts, favorite}
fullGroupPreferences = mergeGroupPreferences groupPreferences
publicGroup = toPublicGroupProfile groupType_ groupLink_ publicGroupId_ (toPublicGroupAccess accessRow)
@@ -756,9 +756,9 @@ groupMemberQuery =
LEFT JOIN connections c ON c.group_member_id = m.group_member_id
|]
toContactMember :: VersionRangeChat -> User -> (GroupMemberRow :. MaybeConnectionRow) -> GroupMember
toContactMember vr User {userContactId} (memberRow :. connRow) =
(toGroupMember userContactId memberRow) {activeConn = toMaybeConnection vr connRow}
toContactMember :: StoreCxt -> User -> (GroupMemberRow :. MaybeConnectionRow) -> GroupMember
toContactMember cxt User {userContactId} (memberRow :. connRow) =
(toGroupMember userContactId memberRow) {activeConn = toMaybeConnection cxt connRow}
rowToLocalProfile :: ProfileRow -> LocalProfile
rowToLocalProfile (profileId, displayName, fullName, shortDescr, image, contactLink, peerType, localAlias, preferences) =
@@ -875,10 +875,10 @@ addGroupChatTags db g@GroupInfo {groupId} = do
chatTags <- getGroupChatTags db groupId
pure (g :: GroupInfo) {chatTags}
getGroupInfo :: DB.Connection -> VersionRangeChat -> User -> Int64 -> ExceptT StoreError IO GroupInfo
getGroupInfo db vr User {userId, userContactId} groupId = ExceptT $ do
getGroupInfo :: DB.Connection -> StoreCxt -> User -> Int64 -> ExceptT StoreError IO GroupInfo
getGroupInfo db cxt User {userId, userContactId} groupId = ExceptT $ do
chatTags <- getGroupChatTags db groupId
firstRow (toGroupInfo vr userContactId chatTags) (SEGroupNotFound groupId) $
firstRow (toGroupInfo cxt userContactId chatTags) (SEGroupNotFound groupId) $
DB.query
db
(groupInfoQuery <> " WHERE g.group_id = ? AND g.user_id = ? AND mu.contact_id = ?")
src/Simplex/Chat/Types.hs
+4
View File
@@ -2036,6 +2036,10 @@ type VersionChat = Version ChatVersion
type VersionRangeChat = VersionRange ChatVersion
-- | Store-wide context passed to store functions in place of the bare `vr`
-- parameter. Built from config by mkStoreCxt; more fields are added here over time.
newtype StoreCxt = StoreCxt {vr :: VersionRangeChat}
pattern VersionChat :: Word16 -> VersionChat
pattern VersionChat v = Version v