From af22348bf81dd8cb43a7863dd6535ddce8bacea3 Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com> Date: Sun, 24 Dec 2023 13:27:51 +0000 Subject: [PATCH] core: use version from config, add tests (#3588) * core: use version from config, add tests * comment * refactor --- src/Simplex/Chat.hs | 295 ++++++++++++++------------ src/Simplex/Chat/Protocol.hs | 4 + src/Simplex/Chat/Remote/Protocol.hs | 1 - src/Simplex/Chat/Store/Connections.hs | 25 +-- src/Simplex/Chat/Store/Files.hs | 25 +-- src/Simplex/Chat/Store/Groups.hs | 115 +++++----- src/Simplex/Chat/Store/Messages.hs | 45 ++-- tests/ChatClient.hs | 35 ++- tests/ChatTests/Groups.hs | 49 +++-- tests/ChatTests/Utils.hs | 22 +- 10 files changed, 348 insertions(+), 268 deletions(-) diff --git a/src/Simplex/Chat.hs b/src/Simplex/Chat.hs index a8b1284b9..9e3994173 100644 --- a/src/Simplex/Chat.hs +++ b/src/Simplex/Chat.hs @@ -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 diff --git a/src/Simplex/Chat/Protocol.hs b/src/Simplex/Chat/Protocol.hs index 5cda18c29..a0df9f986 100644 --- a/src/Simplex/Chat/Protocol.hs +++ b/src/Simplex/Chat/Protocol.hs @@ -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 diff --git a/src/Simplex/Chat/Remote/Protocol.hs b/src/Simplex/Chat/Remote/Protocol.hs index b8ff84709..7b3d70ff9 100644 --- a/src/Simplex/Chat/Remote/Protocol.hs +++ b/src/Simplex/Chat/Remote/Protocol.hs @@ -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) diff --git a/src/Simplex/Chat/Store/Connections.hs b/src/Simplex/Chat/Store/Connections.hs index a72b23886..580120b2a 100644 --- a/src/Simplex/Chat/Store/Connections.hs +++ b/src/Simplex/Chat/Store/Connections.hs @@ -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 diff --git a/src/Simplex/Chat/Store/Files.hs b/src/Simplex/Chat/Store/Files.hs index b92dbc3e3..4d419c572 100644 --- a/src/Simplex/Chat/Store/Files.hs +++ b/src/Simplex/Chat/Store/Files.hs @@ -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 diff --git a/src/Simplex/Chat/Store/Groups.hs b/src/Simplex/Chat/Store/Groups.hs index 746d7df12..206662636 100644 --- a/src/Simplex/Chat/Store/Groups.hs +++ b/src/Simplex/Chat/Store/Groups.hs @@ -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 diff --git a/src/Simplex/Chat/Store/Messages.hs b/src/Simplex/Chat/Store/Messages.hs index 5b19c3c70..fc840849a 100644 --- a/src/Simplex/Chat/Store/Messages.hs +++ b/src/Simplex/Chat/Store/Messages.hs @@ -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 diff --git a/tests/ChatClient.hs b/tests/ChatClient.hs index 044d95eaa..c390d20ab 100644 --- a/tests/ChatClient.hs +++ b/tests/ChatClient.hs @@ -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 = diff --git a/tests/ChatTests/Groups.hs b/tests/ChatTests/Groups.hs index fa5b4a9ef..15ed2fbf1 100644 --- a/tests/ChatTests/Groups.hs +++ b/tests/ChatTests/Groups.hs @@ -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 "#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" diff --git a/tests/ChatTests/Utils.hs b/tests/ChatTests/Utils.hs index 1fc00d913..65fa3bc4c 100644 --- a/tests/ChatTests/Utils.hs +++ b/tests/ChatTests/Utils.hs @@ -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}}