IntenseFinance/simplex-chat
3
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

core: use version from config, add tests (#3588)

Browse Source 
* core: use version from config, add tests

* comment

* refactor
This commit is contained in:
Evgeny Poberezkin 2023-12-24 13:27:51 +00:00 committed by GitHub
parent 5a6670998c
commit af22348bf8
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
10 changed files with 348 additions and 268 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

295
src/Simplex/Chat.hs
View File

@ -276,28 +276,28 @@ newChatController
logFilePath = logFile,
contactMergeEnabled
}
where
configServers :: DefaultAgentServers
configServers =
let smp' = fromMaybe (defaultServers.smp) (nonEmpty smpServers)
xftp' = fromMaybe (defaultServers.xftp) (nonEmpty xftpServers)
in defaultServers {smp = smp', xftp = xftp', netCfg = networkConfig}
agentServers :: ChatConfig -> IO InitialAgentServers
agentServers config@ChatConfig {defaultServers = defServers@DefaultAgentServers {ntf, netCfg}} = do
users <- withTransaction chatStore getUsers
smp' <- getUserServers users SPSMP
xftp' <- getUserServers users SPXFTP
pure InitialAgentServers {smp = smp', xftp = xftp', ntf, netCfg}
where
getUserServers :: forall p. (ProtocolTypeI p, UserProtocol p) => [User] -> SProtocolType p -> IO (Map UserId (NonEmpty (ProtoServerWithAuth p)))
getUserServers users protocol = case users of
[] -> pure $ M.fromList [(1, cfgServers protocol defServers)]
_ -> M.fromList <$> initialServers
where
initialServers :: IO [(UserId, NonEmpty (ProtoServerWithAuth p))]
initialServers = mapM (\u -> (aUserId u,) <$> userServers u) users
userServers :: User -> IO (NonEmpty (ProtoServerWithAuth p))
userServers user' = activeAgentServers config protocol <$> withTransaction chatStore (`getProtocolServers` user')
where
configServers :: DefaultAgentServers
configServers =
let smp' = fromMaybe (defaultServers.smp) (nonEmpty smpServers)
xftp' = fromMaybe (defaultServers.xftp) (nonEmpty xftpServers)
in defaultServers {smp = smp', xftp = xftp', netCfg = networkConfig}
agentServers :: ChatConfig -> IO InitialAgentServers
agentServers config@ChatConfig {defaultServers = defServers@DefaultAgentServers {ntf, netCfg}} = do
users <- withTransaction chatStore getUsers
smp' <- getUserServers users SPSMP
xftp' <- getUserServers users SPXFTP
pure InitialAgentServers {smp = smp', xftp = xftp', ntf, netCfg}
where
getUserServers :: forall p. (ProtocolTypeI p, UserProtocol p) => [User] -> SProtocolType p -> IO (Map UserId (NonEmpty (ProtoServerWithAuth p)))
getUserServers users protocol = case users of
[] -> pure $ M.fromList [(1, cfgServers protocol defServers)]
_ -> M.fromList <$> initialServers
where
initialServers :: IO [(UserId, NonEmpty (ProtoServerWithAuth p))]
initialServers = mapM (\u -> (aUserId u,) <$> userServers u) users
userServers :: User -> IO (NonEmpty (ProtoServerWithAuth p))
userServers user' = activeAgentServers config protocol <$> withTransaction chatStore (`getProtocolServers` user')
activeAgentServers :: UserProtocol p => ChatConfig -> SProtocolType p -> [ServerCfg p] -> NonEmpty (ProtoServerWithAuth p)
activeAgentServers ChatConfig {defaultServers} p =
@ -356,11 +356,12 @@ startChatController subConns enableExpireCIs startXFTPWorkers = do
subscribeUsers :: forall m. ChatMonad' m => Bool -> [User] -> m ()
subscribeUsers onlyNeeded users = do
let (us, us') = partition activeUser users
subscribe us
subscribe us'
vr <- chatVersionRange
subscribe vr us
subscribe vr us'
where
subscribe :: [User] -> m ()
subscribe = mapM_ $ runExceptT . subscribeUserConnections onlyNeeded Agent.subscribeConnections
subscribe :: VersionRange -> [User] -> m ()
subscribe vr = mapM_ $ runExceptT . subscribeUserConnections vr onlyNeeded Agent.subscribeConnections
startFilesToReceive :: forall m. ChatMonad' m => [User] -> m ()
startFilesToReceive users = do
@ -437,7 +438,11 @@ parseChatCommand = A.parseOnly chatCommandP . B.dropWhileEnd isSpace
-- | Chat API commands interpreted in context of a local zone
processChatCommand :: forall m. ChatMonad m => ChatCommand -> m ChatResponse
processChatCommand = \case
processChatCommand cmd = chatVersionRange >>= (`processChatCommand'` cmd)
{-# INLINE processChatCommand #-}
processChatCommand' :: forall m. ChatMonad m => VersionRange -> ChatCommand -> m ChatResponse
processChatCommand' vr = \case
ShowActiveUser -> withUser' $ pure . CRActiveUser
CreateActiveUser NewUser {profile, sameServers, pastTimestamp} -> do
forM_ profile $ \Profile {displayName} -> checkValidName displayName
@ -607,7 +612,7 @@ processChatCommand = \case
. M.assocs
<$> withConnection st (readTVarIO . DB.slow)
APIGetChats {userId, pendingConnections, pagination, query} -> withUserId' userId $ \user -> do
(errs, previews) <- partitionEithers <$> withStore' (\db -> getChatPreviews db user pendingConnections pagination query)
(errs, previews) <- partitionEithers <$> withStore' (\db -> getChatPreviews db vr user pendingConnections pagination query)
unless (null errs) $ toView $ CRChatErrors (Just user) (map ChatErrorStore errs)
pure $ CRApiChats user previews
APIGetChat (ChatRef cType cId) pagination search -> withUser $ \user -> case cType of
@ -616,16 +621,16 @@ processChatCommand = \case
directChat <- withStore (\db -> getDirectChat db user cId pagination search)
pure $ CRApiChat user (AChat SCTDirect directChat)
CTGroup -> do
groupChat <- withStore (\db -> getGroupChat db user cId pagination search)
groupChat <- withStore (\db -> getGroupChat db vr user cId pagination search)
pure $ CRApiChat user (AChat SCTGroup groupChat)
CTContactRequest -> pure $ chatCmdError (Just user) "not implemented"
CTContactConnection -> pure $ chatCmdError (Just user) "not supported"
APIGetChatItems pagination search -> withUser $ \user -> do
chatItems <- withStore $ \db -> getAllChatItems db user pagination search
chatItems <- withStore $ \db -> getAllChatItems db vr user pagination search
pure $ CRChatItems user Nothing chatItems
APIGetChatItemInfo chatRef itemId -> withUser $ \user -> do
(aci@(AChatItem cType dir _ ci), versions) <- withStore $ \db ->
(,) <$> getAChatItem db user chatRef itemId <*> liftIO (getChatItemVersions db itemId)
(,) <$> getAChatItem db vr user chatRef itemId <*> liftIO (getChatItemVersions db itemId)
let itemVersions = if null versions then maybeToList $ mkItemVersion ci else versions
memberDeliveryStatuses <- case (cType, dir) of
(SCTGroup, SMDSnd) -> do
@ -699,7 +704,7 @@ processChatCommand = \case
quoteData ChatItem {content = CIRcvMsgContent qmc} = pure (qmc, CIQDirectRcv, False)
quoteData _ = throwChatError CEInvalidQuote
CTGroup -> do
g@(Group gInfo _) <- withStore $ \db -> getGroup db user chatId
g@(Group gInfo _) <- withStore $ \db -> getGroup db vr user chatId
assertUserGroupRole gInfo GRAuthor
send g
where
@ -804,7 +809,7 @@ processChatCommand = \case
_ -> throwChatError CEInvalidChatItemUpdate
CChatItem SMDRcv _ -> throwChatError CEInvalidChatItemUpdate
CTGroup -> do
Group gInfo@GroupInfo {groupId} ms <- withStore $ \db -> getGroup db user chatId
Group gInfo@GroupInfo {groupId} ms <- withStore $ \db -> getGroup db vr user chatId
assertUserGroupRole gInfo GRAuthor
cci <- withStore $ \db -> getGroupCIWithReactions db user gInfo itemId
case cci of
@ -840,7 +845,7 @@ processChatCommand = \case
else markDirectCIDeleted user ct ci msgId True =<< liftIO getCurrentTime
(CIDMBroadcast, _, _, _) -> throwChatError CEInvalidChatItemDelete
CTGroup -> do
Group gInfo ms <- withStore $ \db -> getGroup db user chatId
Group gInfo ms <- withStore $ \db -> getGroup db vr user chatId
CChatItem msgDir ci@ChatItem {meta = CIMeta {itemSharedMsgId, editable}} <- withStore $ \db -> getGroupChatItem db user chatId itemId
case (mode, msgDir, itemSharedMsgId, editable) of
(CIDMInternal, _, _, _) -> deleteGroupCI user gInfo ci True False Nothing =<< liftIO getCurrentTime
@ -852,7 +857,7 @@ processChatCommand = \case
CTContactRequest -> pure $ chatCmdError (Just user) "not supported"
CTContactConnection -> pure $ chatCmdError (Just user) "not supported"
APIDeleteMemberChatItem gId mId itemId -> withUser $ \user -> withChatLock "deleteChatItem" $ do
Group gInfo@GroupInfo {membership} ms <- withStore $ \db -> getGroup db user gId
Group gInfo@GroupInfo {membership} ms <- withStore $ \db -> getGroup db vr user gId
CChatItem _ ci@ChatItem {chatDir, meta = CIMeta {itemSharedMsgId}} <- withStore $ \db -> getGroupChatItem db user gId itemId
case (chatDir, itemSharedMsgId) of
(CIGroupRcv GroupMember {groupMemberId, memberRole, memberId}, Just itemSharedMId) -> do
@ -881,7 +886,7 @@ processChatCommand = \case
pure $ CRChatItemReaction user add r
_ -> throwChatError $ CECommandError "reaction not possible - no shared item ID"
CTGroup ->
withStore (\db -> (,) <$> getGroup db user chatId <*> getGroupChatItem db user chatId itemId) >>= \case
withStore (\db -> (,) <$> getGroup db vr user chatId <*> getGroupChatItem db user chatId itemId) >>= \case
(Group g@GroupInfo {membership} ms, CChatItem md ci@ChatItem {meta = CIMeta {itemSharedMsgId = Just itemSharedMId}}) -> do
unless (groupFeatureAllowed SGFReactions g) $
throwChatError (CECommandError $ "feature not allowed " <> T.unpack (chatFeatureNameText CFReactions))
@ -940,7 +945,7 @@ processChatCommand = \case
ok user
CTGroup -> do
withStore $ \db -> do
Group {groupInfo} <- getGroup db user chatId
Group {groupInfo} <- getGroup db vr user chatId
liftIO $ updateGroupUnreadChat db user groupInfo unreadChat
ok user
_ -> pure $ chatCmdError (Just user) "not supported"
@ -965,7 +970,7 @@ processChatCommand = \case
withStore' $ \db -> deletePendingContactConnection db userId chatId
pure $ CRContactConnectionDeleted user conn
CTGroup -> do
Group gInfo@GroupInfo {membership} members <- withStore $ \db -> getGroup db user chatId
Group gInfo@GroupInfo {membership} members <- withStore $ \db -> getGroup db vr user chatId
let isOwner = membership.memberRole == GROwner
canDelete = isOwner || not (memberCurrent membership)
unless canDelete $ throwChatError $ CEGroupUserRole gInfo GROwner
@ -1008,7 +1013,7 @@ processChatCommand = \case
withStore' $ \db -> deleteContactCIs db user ct
pure $ CRChatCleared user (AChatInfo SCTDirect $ DirectChat ct)
CTGroup -> do
gInfo <- withStore $ \db -> getGroupInfo db user chatId
gInfo <- withStore $ \db -> getGroupInfo db vr user chatId
filesInfo <- withStore' $ \db -> getGroupFileInfo db user gInfo
deleteFilesAndConns user filesInfo
withStore' $ \db -> deleteGroupCIs db user gInfo
@ -1152,7 +1157,7 @@ processChatCommand = \case
user_ <- withStore' (`getUserByAConnId` agentConnId)
connEntity_ <-
pure user_ $>>= \user ->
withStore (\db -> Just <$> getConnectionEntity db user agentConnId) `catchChatError` (\e -> toView (CRChatError (Just user) e) $> Nothing)
withStore (\db -> Just <$> getConnectionEntity db vr user agentConnId) `catchChatError` (\e -> toView (CRChatError (Just user) e) $> Nothing)
pure CRNtfMessages {user_, connEntity_, msgTs = msgTs', ntfMessages = map ntfMsgInfo msgs}
APIGetUserProtoServers userId (AProtocolType p) -> withUserId userId $ \user -> withServerProtocol p $ do
ChatConfig {defaultServers} <- asks config
@ -1215,7 +1220,7 @@ processChatCommand = \case
ok user
CTGroup -> do
ms <- withStore $ \db -> do
Group _ ms <- getGroup db user chatId
Group _ ms <- getGroup db vr user chatId
liftIO $ updateGroupSettings db user chatId chatSettings
pure ms
forM_ (filter memberActive ms) $ \m -> forM_ (memberConnId m) $ \connId ->
@ -1240,10 +1245,10 @@ processChatCommand = \case
connectionStats <- mapM (withAgent . flip getConnectionServers) (contactConnId ct)
pure $ CRContactInfo user ct connectionStats (fmap fromLocalProfile incognitoProfile)
APIGroupInfo gId -> withUser $ \user -> do
(g, s) <- withStore $ \db -> (,) <$> getGroupInfo db user gId <*> liftIO (getGroupSummary db user gId)
(g, s) <- withStore $ \db -> (,) <$> getGroupInfo db vr user gId <*> liftIO (getGroupSummary db user gId)
pure $ CRGroupInfo user g s
APIGroupMemberInfo gId gMemberId -> withUser $ \user -> do
(g, m) <- withStore $ \db -> (,) <$> getGroupInfo db user gId <*> getGroupMember db user gId gMemberId
(g, m) <- withStore $ \db -> (,) <$> getGroupInfo db vr user gId <*> getGroupMember db user gId gMemberId
connectionStats <- mapM (withAgent . flip getConnectionServers) (memberConnId m)
pure $ CRGroupMemberInfo user g m connectionStats
APISwitchContact contactId -> withUser $ \user -> do
@ -1254,7 +1259,7 @@ processChatCommand = \case
pure $ CRContactSwitchStarted user ct connectionStats
Nothing -> throwChatError $ CEContactNotActive ct
APISwitchGroupMember gId gMemberId -> withUser $ \user -> do
(g, m) <- withStore $ \db -> (,) <$> getGroupInfo db user gId <*> getGroupMember db user gId gMemberId
(g, m) <- withStore $ \db -> (,) <$> getGroupInfo db vr user gId <*> getGroupMember db user gId gMemberId
case memberConnId m of
Just connId -> do
connectionStats <- withAgent (\a -> switchConnectionAsync a "" connId)
@ -1268,7 +1273,7 @@ processChatCommand = \case
pure $ CRContactSwitchAborted user ct connectionStats
Nothing -> throwChatError $ CEContactNotActive ct
APIAbortSwitchGroupMember gId gMemberId -> withUser $ \user -> do
(g, m) <- withStore $ \db -> (,) <$> getGroupInfo db user gId <*> getGroupMember db user gId gMemberId
(g, m) <- withStore $ \db -> (,) <$> getGroupInfo db vr user gId <*> getGroupMember db user gId gMemberId
case memberConnId m of
Just connId -> do
connectionStats <- withAgent $ \a -> abortConnectionSwitch a connId
@ -1283,7 +1288,7 @@ processChatCommand = \case
pure $ CRContactRatchetSyncStarted user ct cStats
Nothing -> throwChatError $ CEContactNotActive ct
APISyncGroupMemberRatchet gId gMemberId force -> withUser $ \user -> withChatLock "syncGroupMemberRatchet" $ do
(g, m) <- withStore $ \db -> (,) <$> getGroupInfo db user gId <*> getGroupMember db user gId gMemberId
(g, m) <- withStore $ \db -> (,) <$> getGroupInfo db vr user gId <*> getGroupMember db user gId gMemberId
case memberConnId m of
Just connId -> do
cStats@ConnectionStats {ratchetSyncState = rss} <- withAgent $ \a -> synchronizeRatchet a connId force
@ -1305,7 +1310,7 @@ processChatCommand = \case
pure $ CRContactCode user ct' code
Nothing -> throwChatError $ CEContactNotActive ct
APIGetGroupMemberCode gId gMemberId -> withUser $ \user -> do
(g, m@GroupMember {activeConn}) <- withStore $ \db -> (,) <$> getGroupInfo db user gId <*> getGroupMember db user gId gMemberId
(g, m@GroupMember {activeConn}) <- withStore $ \db -> (,) <$> getGroupInfo db vr user gId <*> getGroupMember db user gId gMemberId
case activeConn of
Just conn@Connection {connId} -> do
code <- getConnectionCode $ aConnId conn
@ -1487,7 +1492,7 @@ processChatCommand = \case
let chatRef = ChatRef CTDirect ctId
processChatCommand . APISendMessage chatRef False Nothing $ ComposedMessage Nothing Nothing mc
Left _ ->
withStore' (\db -> runExceptT $ getActiveMembersByName db user name) >>= \case
withStore' (\db -> runExceptT $ getActiveMembersByName db vr user name) >>= \case
Right [(gInfo, member)] -> do
let GroupInfo {localDisplayName = gName} = gInfo
GroupMember {localDisplayName = mName} = member
@ -1507,7 +1512,7 @@ processChatCommand = \case
let mc = MCText msg
case memberContactId m of
Nothing -> do
gInfo <- withStore $ \db -> getGroupInfo db user gId
gInfo <- withStore $ \db -> getGroupInfo db vr user gId
toView $ CRNoMemberContactCreating user gInfo m
processChatCommand (APICreateMemberContact gId mId) >>= \case
cr@(CRNewMemberContact _ Contact {contactId} _ _) -> do
@ -1567,13 +1572,13 @@ processChatCommand = \case
gVar <- asks random
-- [incognito] generate incognito profile for group membership
incognitoProfile <- if incognito then Just <$> liftIO generateRandomProfile else pure Nothing
groupInfo <- withStore $ \db -> createNewGroup db gVar user gProfile incognitoProfile
groupInfo <- withStore $ \db -> createNewGroup db vr gVar user gProfile incognitoProfile
pure $ CRGroupCreated user groupInfo
NewGroup incognito gProfile -> withUser $ \User {userId} ->
processChatCommand $ APINewGroup userId incognito gProfile
APIAddMember groupId contactId memRole -> withUser $ \user -> withChatLock "addMember" $ do
-- TODO for large groups: no need to load all members to determine if contact is a member
(group, contact) <- withStore $ \db -> (,) <$> getGroup db user groupId <*> getContact db user contactId
(group, contact) <- withStore $ \db -> (,) <$> getGroup db vr user groupId <*> getContact db user contactId
assertDirectAllowed user MDSnd contact XGrpInv_
let Group gInfo members = group
Contact {localDisplayName = cName} = contact
@ -1603,7 +1608,7 @@ processChatCommand = \case
APIJoinGroup groupId -> withUser $ \user@User {userId} -> do
withChatLock "joinGroup" . procCmd $ do
(invitation, ct) <- withStore $ \db -> do
inv@ReceivedGroupInvitation {fromMember} <- getGroupInvitation db user groupId
inv@ReceivedGroupInvitation {fromMember} <- getGroupInvitation db vr user groupId
(inv,) <$> getContactViaMember db user fromMember
let ReceivedGroupInvitation {fromMember, connRequest, groupInfo = g@GroupInfo {membership}} = invitation
Contact {activeConn} = ct
@ -1621,14 +1626,14 @@ processChatCommand = \case
Nothing -> throwChatError $ CEContactNotActive ct
where
updateCIGroupInvitationStatus user = do
AChatItem _ _ cInfo ChatItem {content, meta = CIMeta {itemId}} <- withStore $ \db -> getChatItemByGroupId db user groupId
AChatItem _ _ cInfo ChatItem {content, meta = CIMeta {itemId}} <- withStore $ \db -> getChatItemByGroupId db vr user groupId
case (cInfo, content) of
(DirectChat ct, CIRcvGroupInvitation ciGroupInv memRole) -> do
let aciContent = ACIContent SMDRcv $ CIRcvGroupInvitation ciGroupInv {status = CIGISAccepted} memRole
updateDirectChatItemView user ct itemId aciContent False Nothing
_ -> pure () -- prohibited
APIMemberRole groupId memberId memRole -> withUser $ \user -> do
Group gInfo@GroupInfo {membership} members <- withStore $ \db -> getGroup db user groupId
Group gInfo@GroupInfo {membership} members <- withStore $ \db -> getGroup db vr user groupId
if memberId == groupMemberId' membership
then changeMemberRole user gInfo members membership $ SGEUserRole memRole
else case find ((== memberId) . groupMemberId') members of
@ -1652,7 +1657,7 @@ processChatCommand = \case
toView $ CRNewChatItem user (AChatItem SCTGroup SMDSnd (GroupChat gInfo) ci)
pure CRMemberRoleUser {user, groupInfo = gInfo, member = m {memberRole = memRole}, fromRole = mRole, toRole = memRole}
APIRemoveMember groupId memberId -> withUser $ \user -> do
Group gInfo members <- withStore $ \db -> getGroup db user groupId
Group gInfo members <- withStore $ \db -> getGroup db vr user groupId
case find ((== memberId) . groupMemberId') members of
Nothing -> throwChatError CEGroupMemberNotFound
Just m@GroupMember {memberId = mId, memberRole = mRole, memberStatus = mStatus, memberProfile} -> do
@ -1671,7 +1676,7 @@ processChatCommand = \case
deleteOrUpdateMemberRecord user m
pure $ CRUserDeletedMember user gInfo m {memberStatus = GSMemRemoved}
APILeaveGroup groupId -> withUser $ \user@User {userId} -> do
Group gInfo@GroupInfo {membership} members <- withStore $ \db -> getGroup db user groupId
Group gInfo@GroupInfo {membership} members <- withStore $ \db -> getGroup db vr user groupId
withChatLock "leaveGroup" . procCmd $ do
(msg, _) <- sendGroupMessage user gInfo members XGrpLeave
ci <- saveSndChatItem user (CDGroupSnd gInfo) msg (CISndGroupEvent SGEUserLeft)
@ -1683,7 +1688,7 @@ processChatCommand = \case
withStore' $ \db -> updateGroupMemberStatus db userId membership GSMemLeft
pure $ CRLeftMemberUser user gInfo {membership = membership {memberStatus = GSMemLeft}}
APIListMembers groupId -> withUser $ \user ->
CRGroupMembers user <$> withStore (\db -> getGroup db user groupId)
CRGroupMembers user <$> withStore (\db -> getGroup db vr user groupId)
AddMember gName cName memRole -> withUser $ \user -> do
(groupId, contactId) <- withStore $ \db -> (,) <$> getGroupIdByName db user gName <*> getContactIdByName db user cName
processChatCommand $ APIAddMember groupId contactId memRole
@ -1705,23 +1710,23 @@ processChatCommand = \case
groupId <- withStore $ \db -> getGroupIdByName db user gName
processChatCommand $ APIListMembers groupId
APIListGroups userId contactId_ search_ -> withUserId userId $ \user ->
CRGroupsList user <$> withStore' (\db -> getUserGroupsWithSummary db user contactId_ search_)
CRGroupsList user <$> withStore' (\db -> getUserGroupsWithSummary db vr user contactId_ search_)
ListGroups cName_ search_ -> withUser $ \user@User {userId} -> do
ct_ <- forM cName_ $ \cName -> withStore $ \db -> getContactByName db user cName
processChatCommand $ APIListGroups userId (contactId' <$> ct_) search_
APIUpdateGroupProfile groupId p' -> withUser $ \user -> do
g <- withStore $ \db -> getGroup db user groupId
g <- withStore $ \db -> getGroup db vr user groupId
runUpdateGroupProfile user g p'
UpdateGroupNames gName GroupProfile {displayName, fullName} ->
updateGroupProfileByName gName $ \p -> p {displayName, fullName}
ShowGroupProfile gName -> withUser $ \user ->
CRGroupProfile user <$> withStore (\db -> getGroupInfoByName db user gName)
CRGroupProfile user <$> withStore (\db -> getGroupInfoByName db vr user gName)
UpdateGroupDescription gName description ->
updateGroupProfileByName gName $ \p -> p {description}
ShowGroupDescription gName -> withUser $ \user ->
CRGroupDescription user <$> withStore (\db -> getGroupInfoByName db user gName)
CRGroupDescription user <$> withStore (\db -> getGroupInfoByName db vr user gName)
APICreateGroupLink groupId mRole -> withUser $ \user -> withChatLock "createGroupLink" $ do
gInfo <- withStore $ \db -> getGroupInfo db user groupId
gInfo <- withStore $ \db -> getGroupInfo db vr user groupId
assertUserGroupRole gInfo GRAdmin
when (mRole > GRMember) $ throwChatError $ CEGroupMemberInitialRole gInfo mRole
groupLinkId <- GroupLinkId <$> drgRandomBytes 16
@ -1731,22 +1736,22 @@ processChatCommand = \case
withStore $ \db -> createGroupLink db user gInfo connId cReq groupLinkId mRole subMode
pure $ CRGroupLinkCreated user gInfo cReq mRole
APIGroupLinkMemberRole groupId mRole' -> withUser $ \user -> withChatLock "groupLinkMemberRole " $ do
gInfo <- withStore $ \db -> getGroupInfo db user groupId
gInfo <- withStore $ \db -> getGroupInfo db vr user groupId
(groupLinkId, groupLink, mRole) <- withStore $ \db -> getGroupLink db user gInfo
assertUserGroupRole gInfo GRAdmin
when (mRole' > GRMember) $ throwChatError $ CEGroupMemberInitialRole gInfo mRole'
when (mRole' /= mRole) $ withStore' $ \db -> setGroupLinkMemberRole db user groupLinkId mRole'
pure $ CRGroupLink user gInfo groupLink mRole'
APIDeleteGroupLink groupId -> withUser $ \user -> withChatLock "deleteGroupLink" $ do
gInfo <- withStore $ \db -> getGroupInfo db user groupId
gInfo <- withStore $ \db -> getGroupInfo db vr user groupId
deleteGroupLink' user gInfo
pure $ CRGroupLinkDeleted user gInfo
APIGetGroupLink groupId -> withUser $ \user -> do
gInfo <- withStore $ \db -> getGroupInfo db user groupId
gInfo <- withStore $ \db -> getGroupInfo db vr user groupId
(_, groupLink, mRole) <- withStore $ \db -> getGroupLink db user gInfo
pure $ CRGroupLink user gInfo groupLink mRole
APICreateMemberContact gId gMemberId -> withUser $ \user -> do
(g, m) <- withStore $ \db -> (,) <$> getGroupInfo db user gId <*> getGroupMember db user gId gMemberId
(g, m) <- withStore $ \db -> (,) <$> getGroupInfo db vr user gId <*> getGroupMember db user gId gMemberId
assertUserGroupRole g GRAuthor
unless (groupFeatureAllowed SGFDirectMessages g) $ throwChatError $ CECommandError "direct messages not allowed"
case memberConn m of
@ -1762,7 +1767,7 @@ processChatCommand = \case
pure $ CRNewMemberContact user ct g m
_ -> throwChatError CEGroupMemberNotActive
APISendMemberContactInvitation contactId msgContent_ -> withUser $ \user -> do
(g, m, ct, cReq) <- withStore $ \db -> getMemberContact db user contactId
(g, m, ct, cReq) <- withStore $ \db -> getMemberContact db vr user contactId
when (contactGrpInvSent ct) $ throwChatError $ CECommandError "x.grp.direct.inv already sent"
case memberConn m of
Just mConn -> do
@ -1794,7 +1799,7 @@ processChatCommand = \case
processChatCommand . APISendMessage (ChatRef CTGroup groupId) False Nothing $ ComposedMessage Nothing (Just quotedItemId) mc
LastChats count_ -> withUser' $ \user -> do
let count = fromMaybe 5000 count_
(errs, previews) <- partitionEithers <$> withStore' (\db -> getChatPreviews db user False (PTLast count) clqNoFilters)
(errs, previews) <- partitionEithers <$> withStore' (\db -> getChatPreviews db vr user False (PTLast count) clqNoFilters)
unless (null errs) $ toView $ CRChatErrors (Just user) (map ChatErrorStore errs)
pure $ CRChats previews
LastMessages (Just chatName) count search -> withUser $ \user -> do
@ -1802,22 +1807,22 @@ processChatCommand = \case
chatResp <- processChatCommand $ APIGetChat chatRef (CPLast count) search
pure $ CRChatItems user (Just chatName) (aChatItems . chat $ chatResp)
LastMessages Nothing count search -> withUser $ \user -> do
chatItems <- withStore $ \db -> getAllChatItems db user (CPLast count) search
chatItems <- withStore $ \db -> getAllChatItems db vr user (CPLast count) search
pure $ CRChatItems user Nothing chatItems
LastChatItemId (Just chatName) index -> withUser $ \user -> do
chatRef <- getChatRef user chatName
chatResp <- processChatCommand (APIGetChat chatRef (CPLast $ index + 1) Nothing)
pure $ CRChatItemId user (fmap aChatItemId . listToMaybe . aChatItems . chat $ chatResp)
LastChatItemId Nothing index -> withUser $ \user -> do
chatItems <- withStore $ \db -> getAllChatItems db user (CPLast $ index + 1) Nothing
chatItems <- withStore $ \db -> getAllChatItems db vr user (CPLast $ index + 1) Nothing
pure $ CRChatItemId user (fmap aChatItemId . listToMaybe $ chatItems)
ShowChatItem (Just itemId) -> withUser $ \user -> do
chatItem <- withStore $ \db -> do
chatRef <- getChatRefViaItemId db user itemId
getAChatItem db user chatRef itemId
getAChatItem db vr user chatRef itemId
pure $ CRChatItems user Nothing ((: []) chatItem)
ShowChatItem Nothing -> withUser $ \user -> do
chatItems <- withStore $ \db -> getAllChatItems db user (CPLast 1) Nothing
chatItems <- withStore $ \db -> getAllChatItems db vr user (CPLast 1) Nothing
pure $ CRChatItems user Nothing chatItems
ShowChatItemInfo chatName msg -> withUser $ \user -> do
chatRef <- getChatRef user chatName
@ -1867,10 +1872,10 @@ processChatCommand = \case
contact <- withStore $ \db -> getContact db user contactId
void . sendDirectContactMessage contact $ XFileCancel sharedMsgId
ChatRef CTGroup groupId -> do
Group gInfo ms <- withStore $ \db -> getGroup db user groupId
Group gInfo ms <- withStore $ \db -> getGroup db vr user groupId
void . sendGroupMessage user gInfo ms $ XFileCancel sharedMsgId
_ -> throwChatError $ CEFileInternal "invalid chat ref for file transfer"
ci <- withStore $ \db -> getChatItemByFileId db user fileId
ci <- withStore $ \db -> getChatItemByFileId db vr user fileId
pure $ CRSndFileCancelled user ci ftm fts
where
fileCancelledOrCompleteSMP SndFileTransfer {fileStatus = s} =
@ -1881,7 +1886,7 @@ processChatCommand = \case
| otherwise -> case xftpRcvFile of
Nothing -> do
cancelRcvFileTransfer user ftr >>= mapM_ (deleteAgentConnectionAsync user)
ci <- withStore $ \db -> getChatItemByFileId db user fileId
ci <- withStore $ \db -> getChatItemByFileId db vr user fileId
pure $ CRRcvFileCancelled user ci ftr
Just XFTPRcvFile {agentRcvFileId} -> do
forM_ (liveRcvFileTransferPath ftr) $ \filePath -> do
@ -1894,10 +1899,10 @@ processChatCommand = \case
updateCIFileStatus db user fileId CIFSRcvInvitation
updateRcvFileStatus db fileId FSNew
updateRcvFileAgentId db fileId Nothing
getChatItemByFileId db user fileId
getChatItemByFileId db vr user fileId
pure $ CRRcvFileCancelled user ci ftr
FileStatus fileId -> withUser $ \user -> do
ci@(AChatItem _ _ _ ChatItem {file}) <- withStore $ \db -> getChatItemByFileId db user fileId
ci@(AChatItem _ _ _ ChatItem {file}) <- withStore $ \db -> getChatItemByFileId db vr user fileId
case file of
Just CIFile {fileProtocol = FPXFTP} ->
pure $ CRFileTransferStatusXFTP user ci
@ -2199,7 +2204,7 @@ processChatCommand = \case
updateGroupProfileByName :: GroupName -> (GroupProfile -> GroupProfile) -> m ChatResponse
updateGroupProfileByName gName update = withUser $ \user -> do
g@(Group GroupInfo {groupProfile = p} _) <- withStore $ \db ->
getGroupIdByName db user gName >>= getGroup db user
getGroupIdByName db user gName >>= getGroup db vr user
runUpdateGroupProfile user g $ update p
withCurrentCall :: ContactId -> (User -> Contact -> Call -> m (Maybe Call)) -> m ChatResponse
withCurrentCall ctId action = do
@ -2314,15 +2319,16 @@ processChatCommand = \case
ctId <- getContactIdByName db user name
Contact {chatSettings} <- getContact db user ctId
pure (ctId, chatSettings)
CTGroup -> withStore $ \db -> do
gId <- getGroupIdByName db user name
GroupInfo {chatSettings} <- getGroupInfo db user gId
pure (gId, chatSettings)
CTGroup ->
withStore $ \db -> do
gId <- getGroupIdByName db user name
GroupInfo {chatSettings} <- getGroupInfo db vr user gId
pure (gId, chatSettings)
_ -> throwChatError $ CECommandError "not supported"
processChatCommand $ APISetChatSettings (ChatRef cType chatId) $ updateSettings chatSettings
connectPlan :: User -> AConnectionRequestUri -> m ConnectionPlan
connectPlan user (ACR SCMInvitation cReq) = do
withStore' (\db -> getConnectionEntityByConnReq db user cReqSchemas) >>= \case
withStore' (\db -> getConnectionEntityByConnReq db vr user cReqSchemas) >>= \case
Nothing -> pure $ CPInvitationLink ILPOk
Just (RcvDirectMsgConnection conn ct_) -> do
let Connection {connStatus, contactConnInitiated} = conn
@ -2351,7 +2357,7 @@ processChatCommand = \case
withStore' (\db -> getUserContactLinkByConnReq db user cReqSchemas) >>= \case
Just _ -> pure $ CPContactAddress CAPOwnLink
Nothing ->
withStore' (\db -> getContactConnEntityByConnReqHash db user cReqHashes) >>= \case
withStore' (\db -> getContactConnEntityByConnReqHash db vr user cReqHashes) >>= \case
Nothing ->
withStore' (\db -> getContactWithoutConnViaAddress db user cReqSchemas) >>= \case
Nothing -> pure $ CPContactAddress CAPOk
@ -2364,11 +2370,11 @@ processChatCommand = \case
Just _ -> throwChatError $ CECommandError "found connection entity is not RcvDirectMsgConnection"
-- group link
Just _ ->
withStore' (\db -> getGroupInfoByUserContactLinkConnReq db user cReqSchemas) >>= \case
withStore' (\db -> getGroupInfoByUserContactLinkConnReq db vr user cReqSchemas) >>= \case
Just g -> pure $ CPGroupLink (GLPOwnLink g)
Nothing -> do
connEnt_ <- withStore' $ \db -> getContactConnEntityByConnReqHash db user cReqHashes
gInfo_ <- withStore' $ \db -> getGroupInfoByGroupLinkHash db user cReqHashes
connEnt_ <- withStore' $ \db -> getContactConnEntityByConnReqHash db vr user cReqHashes
gInfo_ <- withStore' $ \db -> getGroupInfoByGroupLinkHash db vr user cReqHashes
case (gInfo_, connEnt_) of
(Nothing, Nothing) -> pure $ CPGroupLink GLPOk
(Nothing, Just (RcvDirectMsgConnection _conn Nothing)) -> pure $ CPGroupLink GLPConnectingConfirmReconnect
@ -2598,6 +2604,7 @@ acceptFileReceive user@User {userId} RcvFileTransfer {fileId, xftpRcvFile, fileI
unless (fileStatus == RFSNew) $ case fileStatus of
RFSCancelled _ -> throwChatError $ CEFileCancelled fName
_ -> throwChatError $ CEFileAlreadyReceiving fName
vr <- chatVersionRange
case (xftpRcvFile, fileConnReq) of
-- direct file protocol
(Nothing, Just connReq) -> do
@ -2605,14 +2612,14 @@ acceptFileReceive user@User {userId} RcvFileTransfer {fileId, xftpRcvFile, fileI
dm <- directMessage $ XFileAcpt fName
connIds <- joinAgentConnectionAsync user True connReq dm subMode
filePath <- getRcvFilePath fileId filePath_ fName True
withStoreCtx (Just "acceptFileReceive, acceptRcvFileTransfer") $ \db -> acceptRcvFileTransfer db user fileId connIds ConnJoined filePath subMode
withStoreCtx (Just "acceptFileReceive, acceptRcvFileTransfer") $ \db -> acceptRcvFileTransfer db vr user fileId connIds ConnJoined filePath subMode
-- XFTP
(Just XFTPRcvFile {}, _) -> do
filePath <- getRcvFilePath fileId filePath_ fName False
(ci, rfd) <- withStoreCtx (Just "acceptFileReceive, xftpAcceptRcvFT ...") $ \db -> do
-- marking file as accepted and reading description in the same transaction
-- to prevent race condition with appending description
ci <- xftpAcceptRcvFT db user fileId filePath
ci <- xftpAcceptRcvFT db vr user fileId filePath
rfd <- getRcvFileDescrByRcvFileId db fileId
pure (ci, rfd)
receiveViaCompleteFD user fileId rfd cryptoArgs
@ -2636,10 +2643,11 @@ acceptFileReceive user@User {userId} RcvFileTransfer {fileId, xftpRcvFile, fileI
acceptFile cmdFunction send = do
filePath <- getRcvFilePath fileId filePath_ fName True
inline <- receiveInline
vr <- chatVersionRange
if
| inline -> do
-- accepting inline
ci <- withStoreCtx (Just "acceptFile, acceptRcvInlineFT") $ \db -> acceptRcvInlineFT db user fileId filePath
ci <- withStoreCtx (Just "acceptFile, acceptRcvInlineFT") $ \db -> acceptRcvInlineFT db vr user fileId filePath
sharedMsgId <- withStore $ \db -> getSharedMsgIdByFileId db userId fileId
send $ XFileAcptInv sharedMsgId Nothing fName
pure ci
@ -2648,7 +2656,7 @@ acceptFileReceive user@User {userId} RcvFileTransfer {fileId, xftpRcvFile, fileI
-- accepting via a new connection
subMode <- chatReadVar subscriptionMode
connIds <- createAgentConnectionAsync user cmdFunction True SCMInvitation subMode
withStoreCtx (Just "acceptFile, acceptRcvFileTransfer") $ \db -> acceptRcvFileTransfer db user fileId connIds ConnNew filePath subMode
withStoreCtx (Just "acceptFile, acceptRcvFileTransfer") $ \db -> acceptRcvFileTransfer db vr user fileId connIds ConnNew filePath subMode
receiveInline :: m Bool
receiveInline = do
ChatConfig {fileChunkSize, inlineFiles = InlineFilesConfig {receiveChunks, offerChunks}} <- asks config
@ -2669,10 +2677,11 @@ receiveViaCompleteFD user fileId RcvFileDescr {fileDescrText, fileDescrComplete}
startReceivingFile :: ChatMonad m => User -> FileTransferId -> m ()
startReceivingFile user fileId = do
vr <- chatVersionRange
ci <- withStoreCtx (Just "startReceivingFile, updateRcvFileStatus ...") $ \db -> do
liftIO $ updateRcvFileStatus db fileId FSConnected
liftIO $ updateCIFileStatus db user fileId $ CIFSRcvTransfer 0 1
getChatItemByFileId db user fileId
getChatItemByFileId db vr user fileId
toView $ CRRcvFileStart user ci
getRcvFilePath :: forall m. ChatMonad m => FileTransferId -> Maybe FilePath -> String -> Bool -> m FilePath
@ -2788,14 +2797,14 @@ agentSubscriber = do
type AgentBatchSubscribe m = AgentClient -> [ConnId] -> ExceptT AgentErrorType m (Map ConnId (Either AgentErrorType ()))
subscribeUserConnections :: forall m. ChatMonad m => Bool -> AgentBatchSubscribe m -> User -> m ()
subscribeUserConnections onlyNeeded agentBatchSubscribe user@User {userId} = do
subscribeUserConnections :: forall m. ChatMonad m => VersionRange -> Bool -> AgentBatchSubscribe m -> User -> m ()
subscribeUserConnections vr onlyNeeded agentBatchSubscribe user@User {userId} = do
-- get user connections
ce <- asks $ subscriptionEvents . config
(conns, cts, ucs, gs, ms, sfts, rfts, pcs) <-
if onlyNeeded
then do
(conns, entities) <- withStore' getConnectionsToSubscribe
(conns, entities) <- withStore' (`getConnectionsToSubscribe` vr)
let (cts, ucs, ms, sfts, rfts, pcs) = foldl' addEntity (M.empty, M.empty, M.empty, M.empty, M.empty, M.empty) entities
pure (conns, cts, ucs, [], ms, sfts, rfts, pcs)
else do
@ -2845,7 +2854,7 @@ subscribeUserConnections onlyNeeded agentBatchSubscribe user@User {userId} = do
getContactConns :: m ([ConnId], Map ConnId Contact)
getContactConns = do
cts <- withStore_ ("subscribeUserConnections " <> show userId <> ", getUserContacts") getUserContacts
let connIds = catMaybes $ map contactConnId (filter contactActive cts)
let connIds = mapMaybe contactConnId (filter contactActive cts)
pure (connIds, M.fromList $ zip connIds cts)
getUserContactLinkConns :: m ([ConnId], Map ConnId UserContact)
getUserContactLinkConns = do
@ -2854,7 +2863,7 @@ subscribeUserConnections onlyNeeded agentBatchSubscribe user@User {userId} = do
pure (connIds, M.fromList $ zip connIds ucs)
getGroupMemberConns :: m ([Group], [ConnId], Map ConnId GroupMember)
getGroupMemberConns = do
gs <- withStore_ ("subscribeUserConnections " <> show userId <> ", getUserGroups") getUserGroups
gs <- withStore_ ("subscribeUserConnections " <> show userId <> ", getUserGroups") (`getUserGroups` vr)
let mPairs = concatMap (\(Group _ ms) -> mapMaybe (\m -> (,m) <$> memberConnId m) (filter (not . memberRemoved) ms)) gs
pure (gs, map fst mPairs, M.fromList mPairs)
getSndFileTransferConns :: m ([ConnId], Map ConnId SndFileTransfer)
@ -3029,12 +3038,13 @@ deleteTimedItem user (ChatRef cType chatId, itemId) deleteAt = do
ts <- liftIO getCurrentTime
liftIO $ threadDelay' $ diffToMicroseconds $ diffUTCTime deleteAt ts
waitChatStarted
vr <- chatVersionRange
case cType of
CTDirect -> do
(ct, CChatItem _ ci) <- withStore $ \db -> (,) <$> getContact db user chatId <*> getDirectChatItem db user chatId itemId
deleteDirectCI user ct ci True True >>= toView
CTGroup -> do
(gInfo, CChatItem _ ci) <- withStore $ \db -> (,) <$> getGroupInfo db user chatId <*> getGroupChatItem db user chatId itemId
(gInfo, CChatItem _ ci) <- withStore $ \db -> (,) <$> getGroupInfo db vr user chatId <*> getGroupChatItem db user chatId itemId
deletedTs <- liftIO getCurrentTime
deleteGroupCI user gInfo ci True True Nothing deletedTs >>= toView
_ -> toView . CRChatError (Just user) . ChatError $ CEInternalError "bad deleteTimedItem cType"
@ -3049,12 +3059,13 @@ startUpdatedTimedItemThread user chatRef ci ci' =
expireChatItems :: forall m. ChatMonad m => User -> Int64 -> Bool -> m ()
expireChatItems user@User {userId} ttl sync = do
currentTs <- liftIO getCurrentTime
vr <- chatVersionRange
let expirationDate = addUTCTime (-1 * fromIntegral ttl) currentTs
-- this is to keep group messages created during last 12 hours even if they're expired according to item_ts
createdAtCutoff = addUTCTime (-43200 :: NominalDiffTime) currentTs
contacts <- withStoreCtx' (Just "expireChatItems, getUserContacts") (`getUserContacts` user)
loop contacts $ processContact expirationDate
groups <- withStoreCtx' (Just "expireChatItems, getUserGroupDetails") (\db -> getUserGroupDetails db user Nothing Nothing)
groups <- withStoreCtx' (Just "expireChatItems, getUserGroupDetails") (\db -> getUserGroupDetails db vr user Nothing Nothing)
loop groups $ processGroup expirationDate createdAtCutoff
where
loop :: [a] -> (a -> m ()) -> m ()
@ -3088,9 +3099,10 @@ processAgentMessage _ connId (DEL_RCVQ srv qId err_) =
toView $ CRAgentRcvQueueDeleted (AgentConnId connId) srv (AgentQueueId qId) err_
processAgentMessage _ connId DEL_CONN =
toView $ CRAgentConnDeleted (AgentConnId connId)
processAgentMessage corrId connId msg =
processAgentMessage corrId connId msg = do
vr <- chatVersionRange
withStore' (`getUserByAConnId` AgentConnId connId) >>= \case
Just user -> processAgentMessageConn user corrId connId msg `catchChatError` (toView . CRChatError (Just user))
Just user -> processAgentMessageConn vr user corrId connId msg `catchChatError` (toView . CRChatError (Just user))
_ -> throwChatError $ CENoConnectionUser (AgentConnId connId)
processAgentMessageNoConn :: forall m. ChatMonad m => ACommand 'Agent 'AENone -> m ()
@ -3127,17 +3139,18 @@ processAgentMsgSndFile _corrId aFileId msg =
(ft@FileTransferMeta {fileId, cancelled}, sfts) <- withStore $ \db -> do
fileId <- getXFTPSndFileDBId db user $ AgentSndFileId aFileId
getSndFileTransfer db user fileId
vr <- chatVersionRange
unless cancelled $ case msg of
SFPROG sndProgress sndTotal -> do
let status = CIFSSndTransfer {sndProgress, sndTotal}
ci <- withStore $ \db -> do
liftIO $ updateCIFileStatus db user fileId status
getChatItemByFileId db user fileId
getChatItemByFileId db vr user fileId
toView $ CRSndFileProgressXFTP user ci ft sndProgress sndTotal
SFDONE sndDescr rfds -> do
withStore' $ \db -> setSndFTPrivateSndDescr db user fileId (fileDescrText sndDescr)
ci@(AChatItem _ d cInfo _ci@ChatItem {meta = CIMeta {itemSharedMsgId = msgId_, itemDeleted}}) <-
withStore $ \db -> getChatItemByFileId db user fileId
withStore $ \db -> getChatItemByFileId db vr user fileId
case (msgId_, itemDeleted) of
(Just sharedMsgId, Nothing) -> do
when (length rfds < length sfts) $ throwChatError $ CEInternalError "not enough XFTP file descriptions to send"
@ -3157,7 +3170,7 @@ processAgentMsgSndFile _corrId aFileId msg =
forM_ rfdsMemberFTs $ \mt -> sendToMember mt `catchChatError` (toView . CRChatError (Just user))
ci' <- withStore $ \db -> do
liftIO $ updateCIFileStatus db user fileId CIFSSndComplete
getChatItemByFileId db user fileId
getChatItemByFileId db vr user fileId
withAgent (`xftpDeleteSndFileInternal` aFileId)
toView $ CRSndFileCompleteXFTP user ci' ft
where
@ -3181,7 +3194,7 @@ processAgentMsgSndFile _corrId aFileId msg =
| otherwise -> do
ci <- withStore $ \db -> do
liftIO $ updateFileCancelled db user fileId CIFSSndError
getChatItemByFileId db user fileId
getChatItemByFileId db vr user fileId
withAgent (`xftpDeleteSndFileInternal` aFileId)
toView $ CRSndFileError user ci
where
@ -3228,12 +3241,13 @@ processAgentMsgRcvFile _corrId aFileId msg =
ft@RcvFileTransfer {fileId} <- withStore $ \db -> do
fileId <- getXFTPRcvFileDBId db $ AgentRcvFileId aFileId
getRcvFileTransfer db user fileId
vr <- chatVersionRange
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
getChatItemByFileId db user fileId
getChatItemByFileId db vr user fileId
toView $ CRRcvFileProgressXFTP user ci rcvProgress rcvTotal
RFDONE xftpPath ->
case liveRcvFileTransferPath ft of
@ -3245,7 +3259,7 @@ processAgentMsgRcvFile _corrId aFileId msg =
liftIO $ do
updateRcvFileStatus db fileId FSComplete
updateCIFileStatus db user fileId CIFSRcvComplete
getChatItemByFileId db user fileId
getChatItemByFileId db vr user fileId
agentXFTPDeleteRcvFile aFileId fileId
toView $ CRRcvFileComplete user ci
RFERR e
@ -3254,13 +3268,13 @@ processAgentMsgRcvFile _corrId aFileId msg =
| otherwise -> do
ci <- withStore $ \db -> do
liftIO $ updateFileCancelled db user fileId CIFSRcvError
getChatItemByFileId db user fileId
getChatItemByFileId db vr user fileId
agentXFTPDeleteRcvFile aFileId fileId
toView $ CRRcvFileError user ci e
processAgentMessageConn :: forall m. ChatMonad m => User -> ACorrId -> ConnId -> ACommand 'Agent 'AEConn -> m ()
processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
entity <- withStore (\db -> getConnectionEntity db user $ AgentConnId agentConnId) >>= updateConnStatus
processAgentMessageConn :: forall m. ChatMonad m => VersionRange -> User -> ACorrId -> ConnId -> ACommand 'Agent 'AEConn -> m ()
processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = do
entity <- withStore (\db -> getConnectionEntity db vr user $ AgentConnId agentConnId) >>= updateConnStatus
case agentMessage of
END -> case entity of
RcvDirectMsgConnection _ (Just ct) -> toView $ CRContactAnotherClient user ct
@ -3406,7 +3420,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
XOk -> pure ()
_ -> messageError "INFO for existing contact must have x.grp.mem.info, x.info or x.ok"
CON ->
withStore' (\db -> getViaGroupMember db user ct) >>= \case
withStore' (\db -> getViaGroupMember db vr user ct) >>= \case
Nothing -> do
-- [incognito] print incognito profile used for this contact
incognitoProfile <- forM customUserProfileId $ \profileId -> withStore (\db -> getProfileById db userId profileId)
@ -3427,7 +3441,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
ci <- saveSndChatItem user (CDDirectSnd ct) msg (CISndMsgContent mc)
toView $ CRNewChatItem user (AChatItem SCTDirect SMDSnd (DirectChat ct) ci)
forM_ groupId_ $ \groupId -> do
groupInfo <- withStore $ \db -> getGroupInfo db user groupId
groupInfo <- withStore $ \db -> getGroupInfo db vr user groupId
subMode <- chatReadVar subscriptionMode
groupConnIds <- createAgentConnectionAsync user CFCreateConnGrpInv True SCMInvitation subMode
gVar <- asks random
@ -3595,7 +3609,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
profileToSend = profileToSendOnAccept user profileMode
void $ sendDirectMessage conn (XGrpLinkMem profileToSend) (GroupId groupId)
sendIntroductions members = do
intros <- withStore' $ \db -> createIntroductions db members m
intros <- withStore' $ \db -> createIntroductions db (maxVersion vr) members m
shuffledIntros <- liftIO $ shuffleIntros intros
if isCompatibleRange (memberChatVRange' m) batchSendVRange
then do
@ -3885,7 +3899,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
CON -> do
ci <- withStore $ \db -> do
liftIO $ updateSndFileStatus db ft FSConnected
updateDirectCIFileStatus db user fileId $ CIFSSndTransfer 0 1
updateDirectCIFileStatus db vr user fileId $ CIFSSndTransfer 0 1
toView $ CRSndFileStart user ci ft
sendFileChunk user ft
SENT msgId -> do
@ -3899,7 +3913,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
getChatRefByFileId db user fileId >>= \case
ChatRef CTDirect _ -> liftIO $ updateFileCancelled db user fileId CIFSSndCancelled
_ -> pure ()
getChatItemByFileId db user fileId
getChatItemByFileId db vr user fileId
toView $ CRSndFileRcvCancelled user ci ft
_ -> throwChatError $ CEFileSend fileId err
MSG meta _ _ -> withAckMessage' agentConnId conn meta $ pure ()
@ -3965,7 +3979,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
FileChunkCancel ->
unless (rcvFileCompleteOrCancelled ft) $ do
cancelRcvFileTransfer user ft >>= mapM_ (deleteAgentConnectionAsync user)
ci <- withStore $ \db -> getChatItemByFileId db user fileId
ci <- withStore $ \db -> getChatItemByFileId db vr user fileId
toView $ CRRcvFileSndCancelled user ci ft
FileChunk {chunkNo, chunkBytes = chunk} -> do
case integrity of
@ -3988,7 +4002,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
updateRcvFileStatus db fileId FSComplete
updateCIFileStatus db user fileId CIFSRcvComplete
deleteRcvFileChunks db ft
getChatItemByFileId db user fileId
getChatItemByFileId db vr user fileId
toView $ CRRcvFileComplete user ci
forM_ conn_ $ \conn -> deleteAgentConnectionAsync user (aConnId conn)
RcvChunkDuplicate -> ack $ pure ()
@ -4031,7 +4045,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
ct <- acceptContactRequestAsync user cReq incognitoProfile True
toView $ CRAcceptingContactRequest user ct
Just groupId -> do
gInfo <- withStore $ \db -> getGroupInfo db user groupId
gInfo <- withStore $ \db -> getGroupInfo db vr user groupId
let profileMode = ExistingIncognito <$> incognitoMembershipProfile gInfo
if isCompatibleRange chatVRange groupLinkNoContactVRange
then do
@ -4524,14 +4538,14 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
ft <- withStore (\db -> getRcvFileTransfer db user fileId)
unless (rcvFileCompleteOrCancelled ft) $ do
cancelRcvFileTransfer user ft >>= mapM_ (deleteAgentConnectionAsync user)
ci <- withStore $ \db -> getChatItemByFileId db user fileId
ci <- withStore $ \db -> getChatItemByFileId db vr user fileId
toView $ CRRcvFileSndCancelled user ci ft
xFileAcptInv :: Contact -> SharedMsgId -> Maybe ConnReqInvitation -> String -> MsgMeta -> m ()
xFileAcptInv ct sharedMsgId fileConnReq_ fName msgMeta = do
checkIntegrityCreateItem (CDDirectRcv ct) msgMeta
fileId <- withStore $ \db -> getDirectFileIdBySharedMsgId db user ct sharedMsgId
(AChatItem _ _ _ ci) <- withStore $ \db -> getChatItemByFileId db user fileId
(AChatItem _ _ _ ci) <- withStore $ \db -> getChatItemByFileId db vr 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
@ -4546,7 +4560,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
-- receiving inline
_ -> do
event <- withStore $ \db -> do
ci' <- updateDirectCIFileStatus db user fileId $ CIFSSndTransfer 0 1
ci' <- updateDirectCIFileStatus db vr user fileId $ CIFSSndTransfer 0 1
sft <- createSndDirectInlineFT db ct ft
pure $ CRSndFileStart user ci' sft
toView event
@ -4574,7 +4588,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
ci@(AChatItem _ _ _ ChatItem {file}) <- withStore $ \db -> do
liftIO $ updateSndFileStatus db sft FSComplete
liftIO $ deleteSndFileChunks db sft
updateDirectCIFileStatus db user fileId CIFSSndComplete
updateDirectCIFileStatus db vr user fileId CIFSSndComplete
case file of
Just CIFile {fileProtocol = FPXFTP} -> do
ft <- withStore $ \db -> getFileTransferMeta db user fileId
@ -4619,7 +4633,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
ft <- withStore (\db -> getRcvFileTransfer db user fileId)
unless (rcvFileCompleteOrCancelled ft) $ do
cancelRcvFileTransfer user ft >>= mapM_ (deleteAgentConnectionAsync user)
ci <- withStore $ \db -> getChatItemByFileId db user fileId
ci <- withStore $ \db -> getChatItemByFileId db vr user fileId
toView $ CRRcvFileSndCancelled user ci ft
else messageError "x.file.cancel: group member attempted to cancel file of another member" -- shouldn't happen now that query includes group member id
(SMDSnd, _) -> messageError "x.file.cancel: group member attempted invalid file cancel"
@ -4627,7 +4641,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
xFileAcptInvGroup :: GroupInfo -> GroupMember -> SharedMsgId -> Maybe ConnReqInvitation -> String -> m ()
xFileAcptInvGroup GroupInfo {groupId} m@GroupMember {activeConn} sharedMsgId fileConnReq_ fName = do
fileId <- withStore $ \db -> getGroupFileIdBySharedMsgId db userId groupId sharedMsgId
(AChatItem _ _ _ ci) <- withStore $ \db -> getChatItemByFileId db user fileId
(AChatItem _ _ _ ci) <- withStore $ \db -> getChatItemByFileId db vr user fileId
assertSMPAcceptNotProhibited ci
-- TODO check that it's not already accepted
ft@FileTransferMeta {fileName, fileSize, fileInline, cancelled} <- withStore (\db -> getFileTransferMeta db user fileId)
@ -4643,7 +4657,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
(_, Just conn) -> do
-- receiving inline
event <- withStore $ \db -> do
ci' <- updateDirectCIFileStatus db user fileId $ CIFSSndTransfer 0 1
ci' <- updateDirectCIFileStatus db vr user fileId $ CIFSSndTransfer 0 1
sft <- liftIO $ createSndGroupInlineFT db m conn ft
pure $ CRSndFileStart user ci' sft
toView event
@ -4667,7 +4681,8 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
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 = membership@GroupMember {groupMemberId, memberId}}, hostId) <- withStore $ \db -> createGroupInvitation db user ct inv customUserProfileId
(gInfo@GroupInfo {groupId, localDisplayName, groupProfile, membership = membership@GroupMember {groupMemberId, memberId}}, hostId) <-
withStore $ \db -> createGroupInvitation db vr user ct inv customUserProfileId
if sameGroupLinkId groupLinkId groupLinkId'
then do
subMode <- chatReadVar subscriptionMode
@ -5018,14 +5033,14 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
associateMemberWithContact :: Contact -> GroupMember -> m Contact
associateMemberWithContact c1 m2@GroupMember {groupId} = do
withStore' $ \db -> associateMemberWithContactRecord db user c1 m2
g <- withStore $ \db -> getGroupInfo db user groupId
g <- withStore $ \db -> getGroupInfo db vr user groupId
toView $ CRContactAndMemberAssociated user c1 g m2 c1
pure c1
associateContactWithMember :: GroupMember -> Contact -> m Contact
associateContactWithMember m1@GroupMember {groupId} c2 = do
c2' <- withStore $ \db -> associateContactWithMemberRecord db user m1 c2
g <- withStore $ \db -> getGroupInfo db user groupId
g <- withStore $ \db -> getGroupInfo db vr user groupId
toView $ CRContactAndMemberAssociated user c2 g m1 c2'
pure c2'
@ -5040,7 +5055,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
toView $ CRContactConnecting user ct
pure conn'
XGrpLinkInv glInv -> do
(gInfo, host) <- withStore $ \db -> createGroupInvitedViaLink db user conn' glInv
(gInfo, host) <- withStore $ \db -> createGroupInvitedViaLink db vr user conn' glInv
toView $ CRGroupLinkConnecting user gInfo host
pure conn'
-- TODO show/log error, other events in SMP confirmation
@ -5440,14 +5455,15 @@ parseChatMessage conn s = do
sendFileChunk :: ChatMonad m => User -> SndFileTransfer -> m ()
sendFileChunk user ft@SndFileTransfer {fileId, fileStatus, agentConnId = AgentConnId acId} =
unless (fileStatus == FSComplete || fileStatus == FSCancelled) $
unless (fileStatus == FSComplete || fileStatus == FSCancelled) $ do
vr <- chatVersionRange
withStore' (`createSndFileChunk` ft) >>= \case
Just chunkNo -> sendFileChunkNo ft chunkNo
Nothing -> do
ci <- withStore $ \db -> do
liftIO $ updateSndFileStatus db ft FSComplete
liftIO $ deleteSndFileChunks db ft
updateDirectCIFileStatus db user fileId CIFSSndComplete
updateDirectCIFileStatus db vr user fileId CIFSSndComplete
toView $ CRSndFileComplete user ci ft
closeFileHandle fileId sndFiles
deleteAgentConnectionAsync user acId
@ -5612,8 +5628,8 @@ sendDirectMessage conn chatMsgEvent connOrGroupId = do
createSndMessage :: (MsgEncodingI e, ChatMonad m) => ChatMsgEvent e -> ConnOrGroupId -> m SndMessage
createSndMessage chatMsgEvent connOrGroupId = do
gVar <- asks random
ChatConfig {chatVRange} <- asks config
withStore $ \db -> createNewSndMessage db gVar connOrGroupId chatMsgEvent (encodeMessage chatVRange)
vr <- chatVersionRange
withStore $ \db -> createNewSndMessage db gVar connOrGroupId chatMsgEvent (encodeMessage vr)
where
encodeMessage chatVRange sharedMsgId =
encodeChatMessage ChatMessage {chatVRange, msgId = Just sharedMsgId, chatMsgEvent}
@ -5639,8 +5655,8 @@ sendGroupMemberMessages user conn@Connection {connId} events groupId = do
createSndMessages :: m [Either ChatError SndMessage]
createSndMessages = do
gVar <- asks random
ChatConfig {chatVRange} <- asks config
withStoreBatch $ \db -> map (createMsg db gVar chatVRange) (toList events)
vr <- chatVersionRange
withStoreBatch $ \db -> map (createMsg db gVar vr) (toList events)
createMsg db gVar chatVRange evnt = do
r <- runExceptT $ createNewSndMessage db gVar (GroupId groupId) evnt (encodeMessage chatVRange evnt)
pure $ first ChatErrorStore r
@ -5649,7 +5665,7 @@ sendGroupMemberMessages user conn@Connection {connId} events groupId = do
directMessage :: (MsgEncodingI e, ChatMonad m) => ChatMsgEvent e -> m ByteString
directMessage chatMsgEvent = do
ChatConfig {chatVRange} <- asks config
chatVRange <- chatVersionRange
let r = encodeChatMessage ChatMessage {chatVRange, msgId = Nothing, chatMsgEvent}
case r of
ECMEncoded encodedBody -> pure . LB.toStrict $ encodedBody
@ -6102,6 +6118,11 @@ waitChatStarted = do
agentStarted <- asks agentAsync
atomically $ readTVar agentStarted >>= \a -> unless (isJust a) retry
chatVersionRange :: ChatMonad' m => m VersionRange
chatVersionRange = do
ChatConfig {chatVRange} <- asks config
pure chatVRange
chatCommandP :: Parser ChatCommand
chatCommandP =
choice

4
src/Simplex/Chat/Protocol.hs
View File

@ -52,9 +52,13 @@ import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, fromTextField_, fstTo
import Simplex.Messaging.Util (eitherToMaybe, safeDecodeUtf8, (<$?>))
import Simplex.Messaging.Version hiding (version)
-- This should not be used directly in code, instead use `maxVersion chatVRange` from ChatConfig.
-- This indirection is needed for backward/forward compatibility testing.
-- Testing with real app versions is still needed, as tests use the current code with different version ranges, not the old code.
currentChatVersion :: Version
currentChatVersion = 5
-- This should not be used directly in code, instead use `chatVRange` from ChatConfig (see comment above)
supportedChatVRange :: VersionRange
supportedChatVRange = mkVersionRange 1 currentChatVersion

1
src/Simplex/Chat/Remote/Protocol.hs
View File

@ -38,7 +38,6 @@ import Simplex.Chat.Controller
import Simplex.Chat.Remote.Transport
import Simplex.Chat.Remote.Types
import Simplex.FileTransfer.Description (FileDigest (..))
import Simplex.Messaging.Agent.Client (agentDRG)
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Crypto.File (CryptoFile (..))
import Simplex.Messaging.Crypto.Lazy (LazyByteString)

25
src/Simplex/Chat/Store/Connections.hs
View File

@ -35,9 +35,10 @@ import Simplex.Messaging.Agent.Protocol (ConnId)
import Simplex.Messaging.Agent.Store.SQLite (firstRow, firstRow', maybeFirstRow)
import qualified Simplex.Messaging.Agent.Store.SQLite.DB as DB
import Simplex.Messaging.Util (eitherToMaybe)
import Simplex.Messaging.Version (VersionRange)
getConnectionEntity :: DB.Connection -> User -> AgentConnId -> ExceptT StoreError IO ConnectionEntity
getConnectionEntity db user@User {userId, userContactId} agentConnId = do
getConnectionEntity :: DB.Connection -> VersionRange -> User -> AgentConnId -> ExceptT StoreError IO ConnectionEntity
getConnectionEntity db vr user@User {userId, userContactId} agentConnId = do
c@Connection {connType, entityId} <- getConnection_
case entityId of
Nothing ->
@ -115,7 +116,7 @@ getConnectionEntity db user@User {userId, userContactId} agentConnId = do
(groupMemberId, userId, userContactId)
toGroupAndMember :: Connection -> GroupInfoRow :. GroupMemberRow -> (GroupInfo, GroupMember)
toGroupAndMember c (groupInfoRow :. memberRow) =
let groupInfo = toGroupInfo userContactId groupInfoRow
let groupInfo = toGroupInfo vr userContactId groupInfoRow
member = toGroupMember userContactId memberRow
in (groupInfo, (member :: GroupMember) {activeConn = Just c})
getConnSndFileTransfer_ :: Int64 -> Connection -> ExceptT StoreError IO SndFileTransfer
@ -154,19 +155,19 @@ getConnectionEntity db user@User {userId, userContactId} agentConnId = do
userContact_ [(cReq, groupId)] = Right UserContact {userContactLinkId, connReqContact = cReq, groupId}
userContact_ _ = Left SEUserContactLinkNotFound
getConnectionEntityByConnReq :: DB.Connection -> User -> (ConnReqInvitation, ConnReqInvitation) -> IO (Maybe ConnectionEntity)
getConnectionEntityByConnReq db user@User {userId} (cReqSchema1, cReqSchema2) = do
getConnectionEntityByConnReq :: DB.Connection -> VersionRange -> User -> (ConnReqInvitation, ConnReqInvitation) -> IO (Maybe ConnectionEntity)
getConnectionEntityByConnReq db vr 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 user) connId_
maybe (pure Nothing) (fmap eitherToMaybe . runExceptT . getConnectionEntity db vr user) connId_
-- search connection for connection plan:
-- 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 -> User -> (ConnReqUriHash, ConnReqUriHash) -> IO (Maybe ConnectionEntity)
getContactConnEntityByConnReqHash db user@User {userId} (cReqHash1, cReqHash2) = do
getContactConnEntityByConnReqHash :: DB.Connection -> VersionRange -> User -> (ConnReqUriHash, ConnReqUriHash) -> IO (Maybe ConnectionEntity)
getContactConnEntityByConnReqHash db vr user@User {userId} (cReqHash1, cReqHash2) = do
connId_ <-
maybeFirstRow fromOnly $
DB.query
@ -183,14 +184,14 @@ getContactConnEntityByConnReqHash db user@User {userId} (cReqHash1, cReqHash2) =
)
|]
(userId, cReqHash1, cReqHash2, ConnDeleted)
maybe (pure Nothing) (fmap eitherToMaybe . runExceptT . getConnectionEntity db user) connId_
maybe (pure Nothing) (fmap eitherToMaybe . runExceptT . getConnectionEntity db vr user) connId_
getConnectionsToSubscribe :: DB.Connection -> IO ([ConnId], [ConnectionEntity])
getConnectionsToSubscribe db = do
getConnectionsToSubscribe :: DB.Connection -> VersionRange -> IO ([ConnId], [ConnectionEntity])
getConnectionsToSubscribe db vr = do
aConnIds <- map fromOnly <$> DB.query_ db "SELECT agent_conn_id FROM connections where to_subscribe = 1"
entities <- forM aConnIds $ \acId -> do
getUserByAConnId db acId >>= \case
Just user -> eitherToMaybe <$> runExceptT (getConnectionEntity db user acId)
Just user -> eitherToMaybe <$> runExceptT (getConnectionEntity db vr user acId)
Nothing -> pure Nothing
unsetConnectionToSubscribe db
let connIds = map (\(AgentConnId connId) -> connId) aConnIds

25
src/Simplex/Chat/Store/Files.hs
View File

@ -107,6 +107,7 @@ import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Crypto.File (CryptoFile (..), CryptoFileArgs (..))
import qualified Simplex.Messaging.Crypto.File as CF
import Simplex.Messaging.Protocol (SubscriptionMode (..))
import Simplex.Messaging.Version (VersionRange)
getLiveSndFileTransfers :: DB.Connection -> User -> IO [SndFileTransfer]
getLiveSndFileTransfers db User {userId} = do
@ -677,8 +678,8 @@ getRcvFileTransfer_ db userId fileId = do
_ -> pure Nothing
cancelled = fromMaybe False cancelled_
acceptRcvFileTransfer :: DB.Connection -> User -> Int64 -> (CommandId, ConnId) -> ConnStatus -> FilePath -> SubscriptionMode -> ExceptT StoreError IO AChatItem
acceptRcvFileTransfer db user@User {userId} fileId (cmdId, acId) connStatus filePath subMode = ExceptT $ do
acceptRcvFileTransfer :: DB.Connection -> VersionRange -> User -> Int64 -> (CommandId, ConnId) -> ConnStatus -> FilePath -> SubscriptionMode -> ExceptT StoreError IO AChatItem
acceptRcvFileTransfer db vr user@User {userId} fileId (cmdId, acId) connStatus filePath subMode = ExceptT $ do
currentTs <- getCurrentTime
acceptRcvFT_ db user fileId filePath Nothing currentTs
DB.execute
@ -687,7 +688,7 @@ acceptRcvFileTransfer db user@User {userId} fileId (cmdId, acId) connStatus file
(acId, connStatus, ConnRcvFile, fileId, userId, currentTs, currentTs, subMode == SMOnlyCreate)
connId <- insertedRowId db
setCommandConnId db user cmdId connId
runExceptT $ getChatItemByFileId db user fileId
runExceptT $ getChatItemByFileId db vr user fileId
getContactByFileId :: DB.Connection -> User -> FileTransferId -> ExceptT StoreError IO Contact
getContactByFileId db user@User {userId} fileId = do
@ -698,19 +699,19 @@ getContactByFileId db user@User {userId} fileId = do
ExceptT . firstRow fromOnly (SEContactNotFoundByFileId fileId) $
DB.query db "SELECT contact_id FROM files WHERE user_id = ? AND file_id = ?" (userId, fileId)
acceptRcvInlineFT :: DB.Connection -> User -> FileTransferId -> FilePath -> ExceptT StoreError IO AChatItem
acceptRcvInlineFT db user fileId filePath = do
acceptRcvInlineFT :: DB.Connection -> VersionRange -> User -> FileTransferId -> FilePath -> ExceptT StoreError IO AChatItem
acceptRcvInlineFT db vr user fileId filePath = do
liftIO $ acceptRcvFT_ db user fileId filePath (Just IFMOffer) =<< getCurrentTime
getChatItemByFileId db user fileId
getChatItemByFileId db vr user fileId
startRcvInlineFT :: DB.Connection -> User -> RcvFileTransfer -> FilePath -> Maybe InlineFileMode -> IO ()
startRcvInlineFT db user RcvFileTransfer {fileId} filePath rcvFileInline =
acceptRcvFT_ db user fileId filePath rcvFileInline =<< getCurrentTime
xftpAcceptRcvFT :: DB.Connection -> User -> FileTransferId -> FilePath -> ExceptT StoreError IO AChatItem
xftpAcceptRcvFT db user fileId filePath = do
xftpAcceptRcvFT :: DB.Connection -> VersionRange -> User -> FileTransferId -> FilePath -> ExceptT StoreError IO AChatItem
xftpAcceptRcvFT db vr user fileId filePath = do
liftIO $ acceptRcvFT_ db user fileId filePath Nothing =<< getCurrentTime
getChatItemByFileId db user fileId
getChatItemByFileId db vr user fileId
acceptRcvFT_ :: DB.Connection -> User -> FileTransferId -> FilePath -> Maybe InlineFileMode -> UTCTime -> IO ()
acceptRcvFT_ db User {userId} fileId filePath rcvFileInline currentTs = do
@ -930,9 +931,9 @@ getLocalCryptoFile db userId fileId sent =
FileTransferMeta {filePath, xftpSndFile} <- getFileTransferMeta_ db userId fileId
pure $ CryptoFile filePath $ xftpSndFile >>= \f -> f.cryptoArgs
updateDirectCIFileStatus :: forall d. MsgDirectionI d => DB.Connection -> User -> Int64 -> CIFileStatus d -> ExceptT StoreError IO AChatItem
updateDirectCIFileStatus db user fileId fileStatus = do
aci@(AChatItem cType d cInfo ci) <- getChatItemByFileId db user fileId
updateDirectCIFileStatus :: forall d. MsgDirectionI d => DB.Connection -> VersionRange -> 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
case (cType, testEquality d $ msgDirection @d) of
(SCTDirect, Just Refl) -> do
liftIO $ updateCIFileStatus db user fileId fileStatus

115
src/Simplex/Chat/Store/Groups.hs
View File

@ -128,7 +128,7 @@ import Data.Time.Clock (UTCTime (..), getCurrentTime)
import Database.SQLite.Simple (NamedParam (..), Only (..), Query (..), (:.) (..))
import Database.SQLite.Simple.QQ (sql)
import Simplex.Chat.Messages
import Simplex.Chat.Protocol (currentChatVersion, groupForwardVRange, supportedChatVRange)
import Simplex.Chat.Protocol (groupForwardVRange)
import Simplex.Chat.Store.Direct
import Simplex.Chat.Store.Shared
import Simplex.Chat.Types
@ -148,9 +148,9 @@ type GroupMemberRow = ((Int64, Int64, MemberId, Version, Version, GroupMemberRol
type MaybeGroupMemberRow = ((Maybe Int64, Maybe Int64, Maybe MemberId, Maybe Version, Maybe Version, Maybe GroupMemberRole, Maybe GroupMemberCategory, Maybe GroupMemberStatus, Maybe Bool) :. (Maybe Int64, Maybe GroupMemberId, Maybe ContactName, Maybe ContactId, Maybe ProfileId, Maybe ProfileId, Maybe ContactName, Maybe Text, Maybe ImageData, Maybe ConnReqContact, Maybe LocalAlias, Maybe Preferences))
toGroupInfo :: Int64 -> GroupInfoRow -> GroupInfo
toGroupInfo userContactId ((groupId, localDisplayName, displayName, fullName, description, image, hostConnCustomUserProfileId, enableNtfs_, sendRcpts, favorite, groupPreferences) :. (createdAt, updatedAt, chatTs) :. userMemberRow) =
let membership = (toGroupMember userContactId userMemberRow) {memberChatVRange = JVersionRange supportedChatVRange}
toGroupInfo :: VersionRange -> Int64 -> GroupInfoRow -> GroupInfo
toGroupInfo vr userContactId ((groupId, localDisplayName, displayName, fullName, description, image, hostConnCustomUserProfileId, enableNtfs_, sendRcpts, favorite, groupPreferences) :. (createdAt, updatedAt, chatTs) :. userMemberRow) =
let membership = (toGroupMember userContactId userMemberRow) {memberChatVRange = JVersionRange vr}
chatSettings = ChatSettings {enableNtfs = fromMaybe MFAll enableNtfs_, sendRcpts, favorite}
fullGroupPreferences = mergeGroupPreferences groupPreferences
groupProfile = GroupProfile {displayName, fullName, description, image, groupPreferences}
@ -252,8 +252,8 @@ setGroupLinkMemberRole :: DB.Connection -> User -> Int64 -> GroupMemberRole -> I
setGroupLinkMemberRole db User {userId} userContactLinkId memberRole =
DB.execute db "UPDATE user_contact_links SET group_link_member_role = ? WHERE user_id = ? AND user_contact_link_id = ?" (memberRole, userId, userContactLinkId)
getGroupAndMember :: DB.Connection -> User -> Int64 -> ExceptT StoreError IO (GroupInfo, GroupMember)
getGroupAndMember db User {userId, userContactId} groupMemberId =
getGroupAndMember :: DB.Connection -> User -> Int64 -> VersionRange -> ExceptT StoreError IO (GroupInfo, GroupMember)
getGroupAndMember db User {userId, userContactId} groupMemberId vr =
ExceptT . firstRow toGroupAndMember (SEInternalError "referenced group member not found") $
DB.query
db
@ -289,13 +289,13 @@ getGroupAndMember db User {userId, userContactId} groupMemberId =
where
toGroupAndMember :: (GroupInfoRow :. GroupMemberRow :. MaybeConnectionRow) -> (GroupInfo, GroupMember)
toGroupAndMember (groupInfoRow :. memberRow :. connRow) =
let groupInfo = toGroupInfo userContactId groupInfoRow
let groupInfo = toGroupInfo vr userContactId groupInfoRow
member = toGroupMember userContactId memberRow
in (groupInfo, (member :: GroupMember) {activeConn = toMaybeConnection connRow})
-- | creates completely new group with a single member - the current user
createNewGroup :: DB.Connection -> TVar ChaChaDRG -> User -> GroupProfile -> Maybe Profile -> ExceptT StoreError IO GroupInfo
createNewGroup db gVar user@User {userId} groupProfile incognitoProfile = ExceptT $ do
createNewGroup :: DB.Connection -> VersionRange -> TVar ChaChaDRG -> User -> GroupProfile -> Maybe Profile -> ExceptT StoreError IO GroupInfo
createNewGroup db vr gVar user@User {userId} groupProfile incognitoProfile = ExceptT $ do
let GroupProfile {displayName, fullName, description, image, groupPreferences} = groupProfile
fullGroupPreferences = mergeGroupPreferences groupPreferences
currentTs <- getCurrentTime
@ -313,18 +313,18 @@ createNewGroup db gVar user@User {userId} groupProfile incognitoProfile = Except
(ldn, userId, profileId, True, currentTs, currentTs, currentTs)
insertedRowId db
memberId <- liftIO $ encodedRandomBytes gVar 12
membership <- createContactMemberInv_ db user groupId Nothing user (MemberIdRole (MemberId memberId) GROwner) GCUserMember GSMemCreator IBUser customUserProfileId currentTs supportedChatVRange
membership <- createContactMemberInv_ db user groupId Nothing user (MemberIdRole (MemberId memberId) GROwner) GCUserMember GSMemCreator IBUser customUserProfileId currentTs vr
let chatSettings = ChatSettings {enableNtfs = MFAll, sendRcpts = Nothing, favorite = False}
pure GroupInfo {groupId, localDisplayName = ldn, groupProfile, fullGroupPreferences, membership, hostConnCustomUserProfileId = Nothing, chatSettings, createdAt = currentTs, updatedAt = currentTs, chatTs = Just currentTs}
-- | creates a new group record for the group the current user was invited to, or returns an existing one
createGroupInvitation :: DB.Connection -> User -> Contact -> GroupInvitation -> Maybe ProfileId -> ExceptT StoreError IO (GroupInfo, GroupMemberId)
createGroupInvitation _ _ Contact {localDisplayName, activeConn = Nothing} _ _ = throwError $ SEContactNotReady localDisplayName
createGroupInvitation db user@User {userId} contact@Contact {contactId, activeConn = Just hostConn@Connection {customUserProfileId}} GroupInvitation {fromMember, invitedMember, connRequest, groupProfile} incognitoProfileId = do
createGroupInvitation :: DB.Connection -> VersionRange -> 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 hostConn@Connection {customUserProfileId}} GroupInvitation {fromMember, invitedMember, connRequest, groupProfile} incognitoProfileId = do
liftIO getInvitationGroupId_ >>= \case
Nothing -> createGroupInvitation_
Just gId -> do
gInfo@GroupInfo {membership, groupProfile = p'} <- getGroupInfo db user gId
gInfo@GroupInfo {membership, groupProfile = p'} <- getGroupInfo db vr user gId
hostId <- getHostMemberId_ db user gId
let GroupMember {groupMemberId, memberId, memberRole} = membership
MemberIdRole {memberId = memberId', memberRole = memberRole'} = invitedMember
@ -360,7 +360,7 @@ createGroupInvitation db user@User {userId} contact@Contact {contactId, activeCo
insertedRowId db
let JVersionRange hostVRange = hostConn.peerChatVRange
GroupMember {groupMemberId} <- createContactMemberInv_ db user groupId Nothing contact fromMember GCHostMember GSMemInvited IBUnknown Nothing currentTs hostVRange
membership <- createContactMemberInv_ db user groupId (Just groupMemberId) user invitedMember GCUserMember GSMemInvited (IBContact contactId) incognitoProfileId currentTs supportedChatVRange
membership <- createContactMemberInv_ db user groupId (Just groupMemberId) user invitedMember GCUserMember GSMemInvited (IBContact contactId) incognitoProfileId currentTs vr
let chatSettings = ChatSettings {enableNtfs = MFAll, sendRcpts = Nothing, favorite = False}
pure (GroupInfo {groupId, localDisplayName, groupProfile, fullGroupPreferences, membership, hostConnCustomUserProfileId = customUserProfileId, chatSettings, createdAt = currentTs, updatedAt = currentTs, chatTs = Just currentTs}, groupMemberId)
@ -431,9 +431,10 @@ createContactMemberInv_ db User {userId, userContactId} groupId invitedByGroupMe
)
pure $ Right incognitoLdn
createGroupInvitedViaLink :: DB.Connection -> User -> Connection -> GroupLinkInvitation -> ExceptT StoreError IO (GroupInfo, GroupMember)
createGroupInvitedViaLink :: DB.Connection -> VersionRange -> User -> Connection -> GroupLinkInvitation -> ExceptT StoreError IO (GroupInfo, GroupMember)
createGroupInvitedViaLink
db
vr
user@User {userId, userContactId}
Connection {connId, customUserProfileId}
GroupLinkInvitation {fromMember, fromMemberName, invitedMember, groupProfile} = do
@ -442,9 +443,9 @@ createGroupInvitedViaLink
hostMemberId <- insertHost_ currentTs groupId
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
void $ createContactMemberInv_ db user groupId (Just hostMemberId) user invitedMember GCUserMember GSMemAccepted IBUnknown customUserProfileId currentTs supportedChatVRange
void $ createContactMemberInv_ db user groupId (Just hostMemberId) user invitedMember GCUserMember GSMemAccepted IBUnknown customUserProfileId currentTs vr
liftIO $ setViaGroupLinkHash db groupId connId
(,) <$> getGroupInfo db user groupId <*> getGroupMemberById db user hostMemberId
(,) <$> getGroupInfo db vr user groupId <*> getGroupMemberById db user hostMemberId
where
insertGroup_ currentTs = ExceptT $ do
let GroupProfile {displayName, fullName, description, image, groupPreferences} = groupProfile
@ -497,9 +498,9 @@ 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 -> User -> GroupId -> ExceptT StoreError IO Group
getGroup db user groupId = do
gInfo <- getGroupInfo db user groupId
getGroup :: DB.Connection -> VersionRange -> User -> GroupId -> ExceptT StoreError IO Group
getGroup db vr user groupId = do
gInfo <- getGroupInfo db vr user groupId
members <- liftIO $ getGroupMembers db user gInfo
pure $ Group gInfo members
@ -552,14 +553,14 @@ deleteGroupProfile_ db userId groupId =
|]
(userId, groupId)
getUserGroups :: DB.Connection -> User -> IO [Group]
getUserGroups db user@User {userId} = do
getUserGroups :: DB.Connection -> VersionRange -> User -> IO [Group]
getUserGroups db vr user@User {userId} = do
groupIds <- map fromOnly <$> DB.query db "SELECT group_id FROM groups WHERE user_id = ?" (Only userId)
rights <$> mapM (runExceptT . getGroup db user) groupIds
rights <$> mapM (runExceptT . getGroup db vr user) groupIds
getUserGroupDetails :: DB.Connection -> User -> Maybe ContactId -> Maybe String -> IO [GroupInfo]
getUserGroupDetails db User {userId, userContactId} _contactId_ search_ =
map (toGroupInfo userContactId)
getUserGroupDetails :: DB.Connection -> VersionRange -> User -> Maybe ContactId -> Maybe String -> IO [GroupInfo]
getUserGroupDetails db vr User {userId, userContactId} _contactId_ search_ =
map (toGroupInfo vr userContactId)
<$> DB.query
db
[sql|
@ -577,9 +578,9 @@ getUserGroupDetails db User {userId, userContactId} _contactId_ search_ =
where
search = fromMaybe "" search_
getUserGroupsWithSummary :: DB.Connection -> User -> Maybe ContactId -> Maybe String -> IO [(GroupInfo, GroupSummary)]
getUserGroupsWithSummary db user _contactId_ search_ =
getUserGroupDetails db user _contactId_ search_
getUserGroupsWithSummary :: DB.Connection -> VersionRange -> User -> Maybe ContactId -> Maybe String -> IO [(GroupInfo, GroupSummary)]
getUserGroupsWithSummary db vr user _contactId_ search_ =
getUserGroupDetails db vr user _contactId_ search_
>>= mapM (\g@GroupInfo {groupId} -> (g,) <$> getGroupSummary db user groupId)
-- the statuses on non-current members should match memberCurrent' function
@ -620,10 +621,10 @@ checkContactHasGroups :: DB.Connection -> User -> Contact -> IO (Maybe GroupId)
checkContactHasGroups db User {userId} Contact {contactId} =
maybeFirstRow fromOnly $ DB.query db "SELECT group_id FROM group_members WHERE user_id = ? AND contact_id = ? LIMIT 1" (userId, contactId)
getGroupInfoByName :: DB.Connection -> User -> GroupName -> ExceptT StoreError IO GroupInfo
getGroupInfoByName db user gName = do
getGroupInfoByName :: DB.Connection -> VersionRange -> User -> GroupName -> ExceptT StoreError IO GroupInfo
getGroupInfoByName db vr user gName = do
gId <- getGroupIdByName db user gName
getGroupInfo db user gId
getGroupInfo db vr user gId
groupMemberQuery :: Query
groupMemberQuery =
@ -709,11 +710,11 @@ getGroupCurrentMembersCount db User {userId} GroupInfo {groupId} = do
(groupId, userId)
pure $ length $ filter memberCurrent' statuses
getGroupInvitation :: DB.Connection -> User -> GroupId -> ExceptT StoreError IO ReceivedGroupInvitation
getGroupInvitation db user groupId =
getGroupInvitation :: DB.Connection -> VersionRange -> User -> GroupId -> ExceptT StoreError IO ReceivedGroupInvitation
getGroupInvitation db vr user groupId =
getConnRec_ user >>= \case
Just connRequest -> do
groupInfo@GroupInfo {membership} <- getGroupInfo db user groupId
groupInfo@GroupInfo {membership} <- getGroupInfo db vr user groupId
when (memberStatus membership /= GSMemInvited) $ throwError SEGroupAlreadyJoined
hostId <- getHostMemberId_ db user groupId
fromMember <- getGroupMember db user groupId hostId
@ -1005,8 +1006,8 @@ updateGroupMemberRole :: DB.Connection -> User -> GroupMember -> GroupMemberRole
updateGroupMemberRole db User {userId} GroupMember {groupMemberId} memRole =
DB.execute db "UPDATE group_members SET member_role = ? WHERE user_id = ? AND group_member_id = ?" (memRole, userId, groupMemberId)
createIntroductions :: DB.Connection -> [GroupMember] -> GroupMember -> IO [GroupMemberIntro]
createIntroductions db members toMember = do
createIntroductions :: DB.Connection -> Version -> [GroupMember] -> GroupMember -> IO [GroupMemberIntro]
createIntroductions db chatV members toMember = do
let reMembers = filter (\m -> memberCurrent m && groupMemberId' m /= groupMemberId' toMember) members
if null reMembers
then pure []
@ -1023,7 +1024,7 @@ createIntroductions db members toMember = do
(re_group_member_id, to_group_member_id, intro_status, intro_chat_protocol_version, created_at, updated_at)
VALUES (?,?,?,?,?,?)
|]
(groupMemberId' reMember, groupMemberId' toMember, GMIntroPending, currentChatVersion, ts, ts)
(groupMemberId' reMember, groupMemberId' toMember, GMIntroPending, chatV, ts, ts)
introId <- insertedRowId db
pure GroupMemberIntro {introId, reMember, toMember, introStatus = GMIntroPending, introInvitation = Nothing}
@ -1201,8 +1202,8 @@ createIntroToMemberContact db user@User {userId} GroupMember {memberContactId =
createMemberConnection_ :: DB.Connection -> UserId -> Int64 -> ConnId -> VersionRange -> Maybe Int64 -> Int -> UTCTime -> SubscriptionMode -> IO Connection
createMemberConnection_ db userId groupMemberId agentConnId peerChatVRange viaContact = createConnection_ db userId ConnMember (Just groupMemberId) agentConnId peerChatVRange viaContact Nothing Nothing
getViaGroupMember :: DB.Connection -> User -> Contact -> IO (Maybe (GroupInfo, GroupMember))
getViaGroupMember db User {userId, userContactId} Contact {contactId} =
getViaGroupMember :: DB.Connection -> VersionRange -> User -> Contact -> IO (Maybe (GroupInfo, GroupMember))
getViaGroupMember db vr User {userId, userContactId} Contact {contactId} =
maybeFirstRow toGroupAndMember $
DB.query
db
@ -1239,7 +1240,7 @@ getViaGroupMember db User {userId, userContactId} Contact {contactId} =
where
toGroupAndMember :: (GroupInfoRow :. GroupMemberRow :. MaybeConnectionRow) -> (GroupInfo, GroupMember)
toGroupAndMember (groupInfoRow :. memberRow :. connRow) =
let groupInfo = toGroupInfo userContactId groupInfoRow
let groupInfo = toGroupInfo vr userContactId groupInfoRow
member = toGroupMember userContactId memberRow
in (groupInfo, (member :: GroupMember) {activeConn = toMaybeConnection connRow})
@ -1294,9 +1295,9 @@ updateGroupProfile db User {userId} g@GroupInfo {groupId, localDisplayName, grou
(ldn, currentTs, userId, groupId)
DB.execute db "DELETE FROM display_names WHERE local_display_name = ? AND user_id = ?" (localDisplayName, userId)
getGroupInfo :: DB.Connection -> User -> Int64 -> ExceptT StoreError IO GroupInfo
getGroupInfo db User {userId, userContactId} groupId =
ExceptT . firstRow (toGroupInfo userContactId) (SEGroupNotFound groupId) $
getGroupInfo :: DB.Connection -> VersionRange -> User -> Int64 -> ExceptT StoreError IO GroupInfo
getGroupInfo db vr User {userId, userContactId} groupId =
ExceptT . firstRow (toGroupInfo vr userContactId) (SEGroupNotFound groupId) $
DB.query
db
[sql|
@ -1315,8 +1316,8 @@ getGroupInfo db User {userId, userContactId} groupId =
|]
(groupId, userId, userContactId)
getGroupInfoByUserContactLinkConnReq :: DB.Connection -> User -> (ConnReqContact, ConnReqContact) -> IO (Maybe GroupInfo)
getGroupInfoByUserContactLinkConnReq db user@User {userId} (cReqSchema1, cReqSchema2) = do
getGroupInfoByUserContactLinkConnReq :: DB.Connection -> VersionRange -> User -> (ConnReqContact, ConnReqContact) -> IO (Maybe GroupInfo)
getGroupInfoByUserContactLinkConnReq db vr user@User {userId} (cReqSchema1, cReqSchema2) = do
groupId_ <-
maybeFirstRow fromOnly $
DB.query
@ -1327,10 +1328,10 @@ getGroupInfoByUserContactLinkConnReq db user@User {userId} (cReqSchema1, cReqSch
WHERE user_id = ? AND conn_req_contact IN (?,?)
|]
(userId, cReqSchema1, cReqSchema2)
maybe (pure Nothing) (fmap eitherToMaybe . runExceptT . getGroupInfo db user) groupId_
maybe (pure Nothing) (fmap eitherToMaybe . runExceptT . getGroupInfo db vr user) groupId_
getGroupInfoByGroupLinkHash :: DB.Connection -> User -> (ConnReqUriHash, ConnReqUriHash) -> IO (Maybe GroupInfo)
getGroupInfoByGroupLinkHash db user@User {userId, userContactId} (groupLinkHash1, groupLinkHash2) = do
getGroupInfoByGroupLinkHash :: DB.Connection -> VersionRange -> User -> (ConnReqUriHash, ConnReqUriHash) -> IO (Maybe GroupInfo)
getGroupInfoByGroupLinkHash db vr user@User {userId, userContactId} (groupLinkHash1, groupLinkHash2) = do
groupId_ <-
maybeFirstRow fromOnly $
DB.query
@ -1344,7 +1345,7 @@ getGroupInfoByGroupLinkHash db user@User {userId, userContactId} (groupLinkHash1
LIMIT 1
|]
(userId, groupLinkHash1, groupLinkHash2, userContactId, GSMemRemoved, GSMemLeft, GSMemGroupDeleted)
maybe (pure Nothing) (fmap eitherToMaybe . runExceptT . getGroupInfo db user) groupId_
maybe (pure Nothing) (fmap eitherToMaybe . runExceptT . getGroupInfo db vr user) groupId_
getGroupIdByName :: DB.Connection -> User -> GroupName -> ExceptT StoreError IO GroupId
getGroupIdByName db User {userId} gName =
@ -1356,8 +1357,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 -> User -> ContactName -> ExceptT StoreError IO [(GroupInfo, GroupMember)]
getActiveMembersByName db user@User {userId} groupMemberName = do
getActiveMembersByName :: DB.Connection -> VersionRange -> User -> ContactName -> ExceptT StoreError IO [(GroupInfo, GroupMember)]
getActiveMembersByName db vr user@User {userId} groupMemberName = do
groupMemberIds :: [(GroupId, GroupMemberId)] <-
liftIO $
DB.query
@ -1370,7 +1371,7 @@ getActiveMembersByName db user@User {userId} groupMemberName = do
|]
(userId, groupMemberName, GSMemConnected, GSMemComplete, GCUserMember)
possibleMembers <- forM groupMemberIds $ \(groupId, groupMemberId) -> do
groupInfo <- getGroupInfo db user groupId
groupInfo <- getGroupInfo db vr user groupId
groupMember <- getGroupMember db user groupId groupMemberId
pure (groupInfo, groupMember)
pure $ sortOn (Down . ts . fst) possibleMembers
@ -1827,15 +1828,15 @@ createMemberContact
mergedPreferences = contactUserPreferences user userPreferences preferences $ connIncognito ctConn
pure Contact {contactId, localDisplayName, profile = memberProfile, activeConn = Just ctConn, viaGroup = Nothing, contactUsed = True, contactStatus = CSActive, chatSettings = defaultChatSettings, userPreferences, mergedPreferences, createdAt = currentTs, updatedAt = currentTs, chatTs = Just currentTs, contactGroupMemberId = Just groupMemberId, contactGrpInvSent = False}
getMemberContact :: DB.Connection -> User -> ContactId -> ExceptT StoreError IO (GroupInfo, GroupMember, Contact, ConnReqInvitation)
getMemberContact db user contactId = do
getMemberContact :: DB.Connection -> VersionRange -> User -> ContactId -> ExceptT StoreError IO (GroupInfo, GroupMember, Contact, ConnReqInvitation)
getMemberContact db vr user contactId = do
ct <- getContact db 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 user groupMemberId
g <- getGroupInfo db user groupId
g <- getGroupInfo db vr user groupId
pure (g, m, ct, cReq)
_ ->
throwError $ SEMemberContactGroupMemberNotFound contactId

45
src/Simplex/Chat/Store/Messages.hs
View File

@ -134,6 +134,7 @@ import qualified Simplex.Messaging.Agent.Store.SQLite.DB as DB
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Crypto.File (CryptoFile (..), CryptoFileArgs (..))
import Simplex.Messaging.Util (eitherToMaybe)
import Simplex.Messaging.Version (VersionRange)
import UnliftIO.STM
deleteContactCIs :: DB.Connection -> User -> Contact -> IO ()
@ -461,8 +462,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 -> User -> Bool -> PaginationByTime -> ChatListQuery -> IO [Either StoreError AChat]
getChatPreviews db user withPCC pagination query = do
getChatPreviews :: DB.Connection -> VersionRange -> User -> Bool -> PaginationByTime -> ChatListQuery -> IO [Either StoreError AChat]
getChatPreviews db vr user withPCC pagination query = do
directChats <- findDirectChatPreviews_ db user pagination query
groupChats <- findGroupChatPreviews_ db user pagination query
cReqChats <- getContactRequestChatPreviews_ db user pagination query
@ -483,7 +484,7 @@ getChatPreviews db user withPCC pagination query = do
getChatPreview :: AChatPreviewData -> ExceptT StoreError IO AChat
getChatPreview (ACPD cType cpd) = case cType of
SCTDirect -> getDirectChatPreview_ db user cpd
SCTGroup -> getGroupChatPreview_ db user cpd
SCTGroup -> getGroupChatPreview_ db vr user cpd
SCTContactRequest -> let (ContactRequestPD _ chat) = cpd in pure chat
SCTContactConnection -> let (ContactConnectionPD _ chat) = cpd in pure chat
@ -688,9 +689,9 @@ findGroupChatPreviews_ db User {userId} pagination clq =
)
([":user_id" := userId, ":rcv_new" := CISRcvNew, ":search" := search] <> pagParams)
getGroupChatPreview_ :: DB.Connection -> User -> ChatPreviewData 'CTGroup -> ExceptT StoreError IO AChat
getGroupChatPreview_ db user (GroupChatPD _ groupId lastItemId_ stats) = do
groupInfo <- getGroupInfo db user groupId
getGroupChatPreview_ :: DB.Connection -> VersionRange -> User -> ChatPreviewData 'CTGroup -> ExceptT StoreError IO AChat
getGroupChatPreview_ db vr user (GroupChatPD _ groupId lastItemId_ stats) = do
groupInfo <- getGroupInfo db vr user groupId
lastItem <- case lastItemId_ of
Just lastItemId -> (: []) <$> getGroupChatItem db user groupId lastItemId
Nothing -> pure []
@ -874,10 +875,10 @@ getDirectChatBefore_ db User {userId} ct@Contact {contactId} beforeChatItemId co
|]
(userId, contactId, search, beforeChatItemId, count)
getGroupChat :: DB.Connection -> User -> Int64 -> ChatPagination -> Maybe String -> ExceptT StoreError IO (Chat 'CTGroup)
getGroupChat db user groupId pagination search_ = do
getGroupChat :: DB.Connection -> VersionRange -> User -> Int64 -> ChatPagination -> Maybe String -> ExceptT StoreError IO (Chat 'CTGroup)
getGroupChat db vr user groupId pagination search_ = do
let search = fromMaybe "" search_
g <- getGroupInfo db user groupId
g <- getGroupInfo db vr user groupId
case pagination of
CPLast count -> getGroupChatLast_ db user g count search
CPAfter afterId count -> getGroupChatAfter_ db user g afterId count search
@ -1185,19 +1186,19 @@ toGroupChatItem currentTs userContactId (((itemId, itemTs, AMsgDirection msgDir,
ciTimed :: Maybe CITimed
ciTimed = timedTTL >>= \ttl -> Just CITimed {ttl, deleteAt = timedDeleteAt}
getAllChatItems :: DB.Connection -> User -> ChatPagination -> Maybe String -> ExceptT StoreError IO [AChatItem]
getAllChatItems db user@User {userId} pagination search_ = do
getAllChatItems :: DB.Connection -> VersionRange -> User -> ChatPagination -> Maybe String -> ExceptT StoreError IO [AChatItem]
getAllChatItems db vr user@User {userId} pagination search_ = do
itemRefs <-
rights . map toChatItemRef <$> case pagination of
CPLast count -> liftIO $ getAllChatItemsLast_ count
CPAfter afterId count -> liftIO . getAllChatItemsAfter_ afterId count . aChatItemTs =<< getAChatItem_ afterId
CPBefore beforeId count -> liftIO . getAllChatItemsBefore_ beforeId count . aChatItemTs =<< getAChatItem_ beforeId
mapM (uncurry (getAChatItem db user) >=> liftIO . getACIReactions db) itemRefs
mapM (uncurry (getAChatItem db vr user) >=> liftIO . getACIReactions db) itemRefs
where
search = fromMaybe "" search_
getAChatItem_ itemId = do
chatRef <- getChatRefViaItemId db user itemId
getAChatItem db user chatRef itemId
getAChatItem db vr user chatRef itemId
getAllChatItemsLast_ count =
reverse
<$> DB.query
@ -1713,8 +1714,8 @@ getGroupChatItemIdByText' db User {userId} groupId msg =
|]
(userId, groupId, msg <> "%")
getChatItemByFileId :: DB.Connection -> User -> Int64 -> ExceptT StoreError IO AChatItem
getChatItemByFileId db user@User {userId} fileId = do
getChatItemByFileId :: DB.Connection -> VersionRange -> User -> Int64 -> ExceptT StoreError IO AChatItem
getChatItemByFileId db vr user@User {userId} fileId = do
(chatRef, itemId) <-
ExceptT . firstRow' toChatItemRef (SEChatItemNotFoundByFileId fileId) $
DB.query
@ -1727,10 +1728,10 @@ getChatItemByFileId db user@User {userId} fileId = do
LIMIT 1
|]
(userId, fileId)
getAChatItem db user chatRef itemId
getAChatItem db vr user chatRef itemId
getChatItemByGroupId :: DB.Connection -> User -> GroupId -> ExceptT StoreError IO AChatItem
getChatItemByGroupId db user@User {userId} groupId = do
getChatItemByGroupId :: DB.Connection -> VersionRange -> User -> GroupId -> ExceptT StoreError IO AChatItem
getChatItemByGroupId db vr user@User {userId} groupId = do
(chatRef, itemId) <-
ExceptT . firstRow' toChatItemRef (SEChatItemNotFoundByGroupId groupId) $
DB.query
@ -1743,7 +1744,7 @@ getChatItemByGroupId db user@User {userId} groupId = do
LIMIT 1
|]
(userId, groupId)
getAChatItem db user chatRef itemId
getAChatItem db vr user chatRef itemId
getChatRefViaItemId :: DB.Connection -> User -> ChatItemId -> ExceptT StoreError IO ChatRef
getChatRefViaItemId db User {userId} itemId = do
@ -1755,14 +1756,14 @@ getChatRefViaItemId db User {userId} itemId = do
(Nothing, Just groupId) -> Right $ ChatRef CTGroup groupId
(_, _) -> Left $ SEBadChatItem itemId
getAChatItem :: DB.Connection -> User -> ChatRef -> ChatItemId -> ExceptT StoreError IO AChatItem
getAChatItem db user chatRef itemId = case chatRef of
getAChatItem :: DB.Connection -> VersionRange -> User -> ChatRef -> ChatItemId -> ExceptT StoreError IO AChatItem
getAChatItem db vr user chatRef itemId = case chatRef of
ChatRef CTDirect contactId -> do
ct <- getContact db user contactId
(CChatItem msgDir ci) <- getDirectChatItem db user contactId itemId
pure $ AChatItem SCTDirect msgDir (DirectChat ct) ci
ChatRef CTGroup groupId -> do
gInfo <- getGroupInfo db user groupId
gInfo <- getGroupInfo db vr user groupId
(CChatItem msgDir ci) <- getGroupChatItem db user groupId itemId
pure $ AChatItem SCTGroup msgDir (GroupChat gInfo) ci
_ -> throwError $ SEChatItemNotFound itemId

35
tests/ChatClient.hs
View File

@ -128,16 +128,43 @@ testCfg =
xftpFileConfig = Nothing
}
testAgentCfgVPrev :: AgentConfig
testAgentCfgVPrev =
testAgentCfg
{ smpAgentVRange = prevRange $ smpAgentVRange testAgentCfg,
smpClientVRange = prevRange $ smpClientVRange testAgentCfg,
e2eEncryptVRange = prevRange $ e2eEncryptVRange testAgentCfg,
smpCfg = (smpCfg testAgentCfg) {serverVRange = prevRange $ serverVRange $ smpCfg testAgentCfg}
}
testAgentCfgV1 :: AgentConfig
testAgentCfgV1 =
testAgentCfg
{ smpClientVRange = mkVersionRange 1 1,
smpAgentVRange = mkVersionRange 1 1,
smpCfg = (smpCfg testAgentCfg) {serverVRange = mkVersionRange 1 1}
{ smpClientVRange = v1Range,
smpAgentVRange = v1Range,
e2eEncryptVRange = v1Range,
smpCfg = (smpCfg testAgentCfg) {serverVRange = v1Range}
}
testCfgVPrev :: ChatConfig
testCfgVPrev =
testCfg
{ chatVRange = prevRange $ chatVRange testCfg,
agentConfig = testAgentCfgVPrev
}
testCfgV1 :: ChatConfig
testCfgV1 = testCfg {agentConfig = testAgentCfgV1}
testCfgV1 =
testCfg
{ chatVRange = v1Range,
agentConfig = testAgentCfgV1
}
prevRange :: VersionRange -> VersionRange
prevRange vr = vr {maxVersion = maxVersion vr - 1}
v1Range :: VersionRange
v1Range = mkVersionRange 1 1
testCfgCreateGroupDirect :: ChatConfig
testCfgCreateGroupDirect =

49
tests/ChatTests/Groups.hs
View File

@ -24,8 +24,9 @@ import Test.Hspec
chatGroupTests :: SpecWith FilePath
chatGroupTests = do
describe "chat groups" $ do
it "add contacts, create group and send/receive messages" testGroup
it "add contacts, create group and send/receive messages, check messages" testGroupCheckMessages
describe "add contacts, create group and send/receive messages" testGroupMatrix
it "v1: add contacts, create group and send/receive messages" testGroup
it "v1: add contacts, create group and send/receive messages, check messages" testGroupCheckMessages
it "create group with incognito membership" testNewGroupIncognito
it "create and join group with 4 members" testGroup2
it "create and delete group" testGroupDelete
@ -146,15 +147,19 @@ chatGroupTests = do
testGroup :: HasCallStack => FilePath -> IO ()
testGroup =
testChatCfg3 testCfgCreateGroupDirect aliceProfile bobProfile cathProfile $
\alice bob cath -> testGroupShared alice bob cath False
\alice bob cath -> testGroupShared alice bob cath False True
testGroupCheckMessages :: HasCallStack => FilePath -> IO ()
testGroupCheckMessages =
testChatCfg3 testCfgCreateGroupDirect aliceProfile bobProfile cathProfile $
\alice bob cath -> testGroupShared alice bob cath True
\alice bob cath -> testGroupShared alice bob cath True True
testGroupShared :: HasCallStack => TestCC -> TestCC -> TestCC -> Bool -> IO ()
testGroupShared alice bob cath checkMessages = do
testGroupMatrix :: SpecWith FilePath
testGroupMatrix =
versionTestMatrix3 $ \alice bob cath -> testGroupShared alice bob cath False False
testGroupShared :: HasCallStack => TestCC -> TestCC -> TestCC -> Bool -> Bool -> IO ()
testGroupShared alice bob cath checkMessages directConnections = do
connectUsers alice bob
connectUsers alice cath
alice ##> "/g team"
@ -206,7 +211,8 @@ testGroupShared alice bob cath checkMessages = do
(alice <# "#team cath> hey team")
(bob <# "#team cath> hey team")
msgItem2 <- lastItemId alice
bob <##> cath
when directConnections $
bob <##> cath
when checkMessages $ getReadChats msgItem1 msgItem2
-- list groups
alice ##> "/gs"
@ -263,17 +269,34 @@ testGroupShared alice bob cath checkMessages = do
(cath </)
cath ##> "#team hello"
cath <## "you are no longer a member of the group"
bob <##> cath
when directConnections $
bob <##> cath
-- delete contact
alice ##> "/d bob"
alice <## "bob: contact is deleted"
bob <## "alice (Alice) deleted contact with you"
alice `send` "@bob hey"
alice
<### [ "@bob hey",
"member #team bob does not have direct connection, creating",
"peer chat protocol version range incompatible"
]
if directConnections
then
alice
<### [ "@bob hey",
"member #team bob does not have direct connection, creating",
"peer chat protocol version range incompatible"
]
else do
alice
<### [ WithTime "@bob hey",
"member #team bob does not have direct connection, creating",
"contact for member #team bob is created",
"sent invitation to connect directly to member #team bob",
"bob (Bob): contact is connected"
]
bob
<### [ "#team alice is creating direct contact alice with you",
WithTime "alice> hey",
"alice: security code changed",
"alice (Alice): contact is connected"
]
when checkMessages $ threadDelay 1000000
alice #> "#team checking connection"
bob <# "#team alice> checking connection"

22
tests/ChatTests/Utils.hs
View File

@ -69,20 +69,22 @@ ifCI xrun run d t = do
versionTestMatrix2 :: (HasCallStack => TestCC -> TestCC -> IO ()) -> SpecWith FilePath
versionTestMatrix2 runTest = do
it "v2" $ testChat2 aliceProfile bobProfile runTest
it "current" $ testChat2 aliceProfile bobProfile runTest
it "prev" $ testChatCfg2 testCfgVPrev aliceProfile bobProfile runTest
it "prev to curr" $ runTestCfg2 testCfg testCfgVPrev runTest
it "curr to prev" $ runTestCfg2 testCfgVPrev testCfg runTest
it "v1" $ testChatCfg2 testCfgV1 aliceProfile bobProfile runTest
it "v1 to v2" $ runTestCfg2 testCfg testCfgV1 runTest
it "v2 to v1" $ runTestCfg2 testCfgV1 testCfg runTest
-- versionTestMatrix3 :: (HasCallStack => TestCC -> TestCC -> TestCC -> IO ()) -> SpecWith FilePath
-- versionTestMatrix3 runTest = do
-- it "v2" $ testChat3 aliceProfile bobProfile cathProfile runTest
-- it "v1" $ testChatCfg3 testCfgV1 aliceProfile bobProfile cathProfile runTest
-- it "v1 to v2" $ runTestCfg3 testCfg testCfgV1 testCfgV1 runTest
-- it "v2+v1 to v2" $ runTestCfg3 testCfg testCfg testCfgV1 runTest
-- it "v2 to v1" $ runTestCfg3 testCfgV1 testCfg testCfg runTest
-- it "v2+v1 to v1" $ runTestCfg3 testCfgV1 testCfg testCfgV1 runTest
versionTestMatrix3 :: (HasCallStack => TestCC -> TestCC -> TestCC -> IO ()) -> SpecWith FilePath
versionTestMatrix3 runTest = do
it "current" $ testChat3 aliceProfile bobProfile cathProfile runTest
it "prev" $ testChatCfg3 testCfgVPrev aliceProfile bobProfile cathProfile runTest
it "prev to curr" $ runTestCfg3 testCfg testCfgVPrev testCfgVPrev runTest
it "curr+prev to curr" $ runTestCfg3 testCfg testCfg testCfgVPrev runTest
it "curr to prev" $ runTestCfg3 testCfgVPrev testCfg testCfg runTest
it "curr+prev to prev" $ runTestCfg3 testCfgVPrev testCfg testCfgVPrev runTest
inlineCfg :: Integer -> ChatConfig
inlineCfg n = testCfg {inlineFiles = defaultInlineFilesConfig {sendChunks = 0, offerChunks = n, receiveChunks = n}}