From 49bd866c4ba69b13bdf37388bacb14d0655f54d4 Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin Date: Sun, 10 Mar 2024 20:52:29 +0000 Subject: [PATCH] core: pass version range to determine missing connection version (#3887) * core: pass version range function to store methods * pass current version to Connection to determine agreed version with peer * simplify --- src/Simplex/Chat.hs | 343 +++++++++++++------------- src/Simplex/Chat/Store/Connections.hs | 11 +- src/Simplex/Chat/Store/Direct.hs | 70 +++--- src/Simplex/Chat/Store/Files.hs | 34 +-- src/Simplex/Chat/Store/Groups.hs | 217 ++++++++-------- src/Simplex/Chat/Store/Messages.hs | 41 +-- src/Simplex/Chat/Store/Profiles.hs | 21 +- src/Simplex/Chat/Store/Shared.hs | 27 +- src/Simplex/Chat/Types.hs | 9 +- tests/ChatTests/Utils.hs | 9 +- 10 files changed, 397 insertions(+), 385 deletions(-) diff --git a/src/Simplex/Chat.hs b/src/Simplex/Chat.hs index 068d3197fa..74eb38f57f 100644 --- a/src/Simplex/Chat.hs +++ b/src/Simplex/Chat.hs @@ -367,12 +367,11 @@ startChatController mainApp = do subscribeUsers :: forall m. ChatMonad' m => Bool -> [User] -> m () subscribeUsers onlyNeeded users = do let (us, us') = partition activeUser users - -- TODO PQ this is only used to set membership version range - vr <- chatVersionRange PQSupportOff + vr <- chatVersionRange subscribe vr us subscribe vr us' where - subscribe :: VersionRangeChat -> [User] -> m () + subscribe :: (PQSupport -> VersionRangeChat) -> [User] -> m () subscribe vr = mapM_ $ runExceptT . subscribeUserConnections vr onlyNeeded Agent.subscribeConnections startFilesToReceive :: forall m. ChatMonad' m => [User] -> m () @@ -451,11 +450,10 @@ 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 cmd = - -- TODO PQ this is only used to set membership version range (?) - chatVersionRange PQSupportOff >>= (`processChatCommand'` cmd) + chatVersionRange >>= (`processChatCommand'` cmd) {-# INLINE processChatCommand #-} -processChatCommand' :: forall m. ChatMonad m => VersionRangeChat -> ChatCommand -> m ChatResponse +processChatCommand' :: forall m. ChatMonad m => (PQSupport -> VersionRangeChat) -> ChatCommand -> m ChatResponse processChatCommand' vr = \case ShowActiveUser -> withUser' $ pure . CRActiveUser CreateActiveUser NewUser {profile, sameServers, pastTimestamp} -> do @@ -598,7 +596,7 @@ processChatCommand' vr = \case SetContactMergeEnabled onOff -> chatWriteVar contactMergeEnabled onOff >> ok_ APISetPQEncryption onOff -> chatWriteVar pqExperimentalEnabled onOff >> ok_ APISetContactPQ ctId pqEnc -> withUser $ \user -> do - ct@Contact {activeConn} <- withStore $ \db -> getContact db user ctId + ct@Contact {activeConn} <- withStore $ \db -> getContact db vr user ctId case activeConn of Just conn@Connection {connId, pqSupport, pqEncryption} | pqEncryption == pqEnc -> pure $ CRContactPQAllowed user ct pqEnc @@ -645,7 +643,7 @@ processChatCommand' vr = \case APIGetChat (ChatRef cType cId) pagination search -> withUser $ \user -> case cType of -- TODO optimize queries calculating ChatStats, currently they're disabled CTDirect -> do - directChat <- withStore (\db -> getDirectChat db user cId pagination search) + directChat <- withStore (\db -> getDirectChat db vr user cId pagination search) pure $ CRApiChat user (AChat SCTDirect directChat) CTGroup -> do groupChat <- withStore (\db -> getGroupChat db vr user cId pagination search) @@ -671,7 +669,7 @@ processChatCommand' vr = \case pure $ CRChatItemInfo user aci ChatItemInfo {itemVersions, memberDeliveryStatuses} APISendMessage (ChatRef cType chatId) live itemTTL (ComposedMessage file_ quotedItemId_ mc) -> withUser $ \user -> withChatLock "sendMessage" $ case cType of CTDirect -> do - ct@Contact {contactId, contactUsed} <- withStore $ \db -> getContact db user chatId + ct@Contact {contactId, contactUsed} <- withStore $ \db -> getContact db vr user chatId assertDirectAllowed user MDSnd ct XMsgNew_ unless contactUsed $ withStore' $ \db -> updateContactUsed db user ct if isVoice mc && not (featureAllowed SCFVoice forUser ct) @@ -769,7 +767,7 @@ processChatCommand' vr = \case pure . CRNewChatItem user $ AChatItem SCTLocal SMDSnd (LocalChat nf) ci APIUpdateChatItem (ChatRef cType chatId) itemId live mc -> withUser $ \user -> withChatLock "updateChatItem" $ case cType of CTDirect -> do - ct@Contact {contactId} <- withStore $ \db -> getContact db user chatId + ct@Contact {contactId} <- withStore $ \db -> getContact db vr user chatId assertDirectAllowed user MDSnd ct XMsgUpdate_ cci <- withStore $ \db -> getDirectCIWithReactions db user ct itemId case cci of @@ -827,7 +825,7 @@ processChatCommand' vr = \case CTContactConnection -> pure $ chatCmdError (Just user) "not supported" APIDeleteChatItem (ChatRef cType chatId) itemId mode -> withUser $ \user -> withChatLock "deleteChatItem" $ case cType of CTDirect -> do - (ct, CChatItem msgDir ci@ChatItem {meta = CIMeta {itemSharedMsgId, editable}}) <- withStore $ \db -> (,) <$> getContact db user chatId <*> getDirectChatItem db user chatId itemId + (ct, CChatItem msgDir ci@ChatItem {meta = CIMeta {itemSharedMsgId, editable}}) <- withStore $ \db -> (,) <$> getContact db vr user chatId <*> getDirectChatItem db user chatId itemId case (mode, msgDir, itemSharedMsgId, editable) of (CIDMInternal, _, _, _) -> deleteDirectCI user ct ci True False (CIDMBroadcast, SMDSnd, Just itemSharedMId, True) -> do @@ -864,7 +862,7 @@ processChatCommand' vr = \case (_, _) -> throwChatError CEInvalidChatItemDelete APIChatItemReaction (ChatRef cType chatId) itemId add reaction -> withUser $ \user -> withChatLock "chatItemReaction" $ case cType of CTDirect -> - withStore (\db -> (,) <$> getContact db user chatId <*> getDirectChatItem db user chatId itemId) >>= \case + withStore (\db -> (,) <$> getContact db vr user chatId <*> getDirectChatItem db user chatId itemId) >>= \case (ct, CChatItem md ci@ChatItem {meta = CIMeta {itemSharedMsgId = Just itemSharedMId}}) -> do unless (featureAllowed SCFReactions forUser ct) $ throwChatError (CECommandError $ "feature not allowed " <> T.unpack (chatFeatureNameText CFReactions)) @@ -941,7 +939,7 @@ processChatCommand' vr = \case APIChatUnread (ChatRef cType chatId) unreadChat -> withUser $ \user -> case cType of CTDirect -> do withStore $ \db -> do - ct <- getContact db user chatId + ct <- getContact db vr user chatId liftIO $ updateContactUnreadChat db user ct unreadChat ok user CTGroup -> do @@ -957,14 +955,14 @@ processChatCommand' vr = \case _ -> pure $ chatCmdError (Just user) "not supported" APIDeleteChat (ChatRef cType chatId) notify -> withUser $ \user@User {userId} -> case cType of CTDirect -> do - ct <- withStore $ \db -> getContact db user chatId + ct <- withStore $ \db -> getContact db vr user chatId filesInfo <- withStore' $ \db -> getContactFileInfo db user ct withChatLock "deleteChat direct" . procCmd $ do cancelFilesInProgress user filesInfo deleteFilesLocally filesInfo let doSendDel = contactReady ct && contactActive ct && notify when doSendDel $ void (sendDirectContactMessage user ct XDirectDel) `catchChatError` const (pure ()) - contactConnIds <- map aConnId <$> withStore' (\db -> getContactConnections db userId ct) + contactConnIds <- map aConnId <$> withStore' (\db -> getContactConnections db vr userId ct) deleteAgentConnectionsAsync' user contactConnIds doSendDel -- functions below are called in separate transactions to prevent crashes on android -- (possibly, race condition on integrity check?) @@ -1005,7 +1003,7 @@ processChatCommand' vr = \case where deleteUnusedContact :: DB.Connection -> ContactId -> IO (Either ChatError (Maybe StoreError, [ConnId])) deleteUnusedContact db contactId = runExceptT . withExceptT ChatErrorStore $ do - ct <- getContact db user contactId + ct <- getContact db vr user contactId ifM ((directOrUsed ct ||) . isJust <$> liftIO (checkContactHasGroups db user ct)) (pure (Nothing, [])) @@ -1013,14 +1011,14 @@ processChatCommand' vr = \case where getConnections :: Contact -> ExceptT StoreError IO (Maybe StoreError, [ConnId]) getConnections ct = do - conns <- liftIO $ getContactConnections db userId ct + conns <- liftIO $ getContactConnections db vr userId ct e_ <- (setContactDeleted db user ct $> Nothing) `catchStoreError` (pure . Just) pure (e_, map aConnId conns) CTLocal -> pure $ chatCmdError (Just user) "not supported" CTContactRequest -> pure $ chatCmdError (Just user) "not supported" APIClearChat (ChatRef cType chatId) -> withUser $ \user@User {userId} -> case cType of CTDirect -> do - ct <- withStore $ \db -> getContact db user chatId + ct <- withStore $ \db -> getContact db vr user chatId filesInfo <- withStore' $ \db -> getContactFileInfo db user ct cancelFilesInProgress user filesInfo deleteFilesLocally filesInfo @@ -1032,7 +1030,7 @@ processChatCommand' vr = \case cancelFilesInProgress user filesInfo deleteFilesLocally filesInfo withStore' $ \db -> deleteGroupCIs db user gInfo - membersToDelete <- withStore' $ \db -> getGroupMembersForExpiration db user gInfo + membersToDelete <- withStore' $ \db -> getGroupMembersForExpiration db vr user gInfo forM_ membersToDelete $ \m -> withStore' $ \db -> deleteGroupMember db user m pure $ CRChatCleared user (AChatInfo SCTGroup $ GroupChat gInfo) CTLocal -> do @@ -1062,7 +1060,7 @@ processChatCommand' vr = \case pure $ CRContactRequestRejected user cReq APISendCallInvitation contactId callType -> withUser $ \user -> do -- party initiating call - ct <- withStore $ \db -> getContact db user contactId + ct <- withStore $ \db -> getContact db vr user contactId assertDirectAllowed user MDSnd ct XCallInv_ if featureAllowed SCFCalls forUser ct then do @@ -1146,7 +1144,7 @@ processChatCommand' vr = \case _ -> Nothing rcvCallInvitation (contactId, callTs, peerCallType, sharedKey) = runExceptT . withStore $ \db -> do user <- getUserByContactId db contactId - contact <- getContact db user contactId + contact <- getContact db vr user contactId pure RcvCallInvitation {user, contact, callType = peerCallType, sharedKey, callTs} APIGetNetworkStatuses -> withUser $ \_ -> CRNetworkStatuses Nothing . map (uncurry ConnNetworkStatus) . M.toList <$> chatReadVar connNetworkStatuses @@ -1155,11 +1153,11 @@ processChatCommand' vr = \case updateCallItemStatus user ct call receivedStatus Nothing $> Just call APIUpdateProfile userId profile -> withUserId userId (`updateProfile` profile) APISetContactPrefs contactId prefs' -> withUser $ \user -> do - ct <- withStore $ \db -> getContact db user contactId + ct <- withStore $ \db -> getContact db vr user contactId updateContactPrefs user ct prefs' APISetContactAlias contactId localAlias -> withUser $ \user@User {userId} -> do ct' <- withStore $ \db -> do - ct <- getContact db user contactId + ct <- getContact db vr user contactId liftIO $ updateContactAlias db userId ct localAlias pure $ CRContactAliasUpdated user ct' APISetConnectionAlias connId localAlias -> withUser $ \user@User {userId} -> do @@ -1234,7 +1232,7 @@ processChatCommand' vr = \case APISetChatSettings (ChatRef cType chatId) chatSettings -> withUser $ \user -> case cType of CTDirect -> do ct <- withStore $ \db -> do - ct <- getContact db user chatId + ct <- getContact db vr user chatId liftIO $ updateContactSettings db user chatId chatSettings pure ct forM_ (contactConnId ct) $ \connId -> @@ -1252,13 +1250,13 @@ processChatCommand' vr = \case APISetMemberSettings gId gMemberId settings -> withUser $ \user -> do m <- withStore $ \db -> do liftIO $ updateGroupMemberSettings db user gId gMemberId settings - getGroupMember db user gId gMemberId + getGroupMember db vr user gId gMemberId let ntfOn = showMessages $ memberSettings m toggleNtf user m ntfOn ok user APIContactInfo contactId -> withUser $ \user@User {userId} -> do -- [incognito] print user's incognito profile for this contact - ct@Contact {activeConn} <- withStore $ \db -> getContact db user contactId + ct@Contact {activeConn} <- withStore $ \db -> getContact db vr user contactId incognitoProfile <- case activeConn of Nothing -> pure Nothing Just Connection {customUserProfileId} -> @@ -1269,39 +1267,39 @@ processChatCommand' vr = \case (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 vr user gId <*> getGroupMember db user gId gMemberId + (g, m) <- withStore $ \db -> (,) <$> getGroupInfo db vr user gId <*> getGroupMember db vr user gId gMemberId connectionStats <- mapM (withAgent . flip getConnectionServers) (memberConnId m) pure $ CRGroupMemberInfo user g m connectionStats APISwitchContact contactId -> withUser $ \user -> do - ct <- withStore $ \db -> getContact db user contactId + ct <- withStore $ \db -> getContact db vr user contactId case contactConnId ct of Just connId -> do connectionStats <- withAgent $ \a -> switchConnectionAsync a "" connId pure $ CRContactSwitchStarted user ct connectionStats Nothing -> throwChatError $ CEContactNotActive ct APISwitchGroupMember gId gMemberId -> withUser $ \user -> do - (g, m) <- withStore $ \db -> (,) <$> getGroupInfo db vr user gId <*> getGroupMember db user gId gMemberId + (g, m) <- withStore $ \db -> (,) <$> getGroupInfo db vr user gId <*> getGroupMember db vr user gId gMemberId case memberConnId m of Just connId -> do connectionStats <- withAgent (\a -> switchConnectionAsync a "" connId) pure $ CRGroupMemberSwitchStarted user g m connectionStats _ -> throwChatError CEGroupMemberNotActive APIAbortSwitchContact contactId -> withUser $ \user -> do - ct <- withStore $ \db -> getContact db user contactId + ct <- withStore $ \db -> getContact db vr user contactId case contactConnId ct of Just connId -> do connectionStats <- withAgent $ \a -> abortConnectionSwitch a connId pure $ CRContactSwitchAborted user ct connectionStats Nothing -> throwChatError $ CEContactNotActive ct APIAbortSwitchGroupMember gId gMemberId -> withUser $ \user -> do - (g, m) <- withStore $ \db -> (,) <$> getGroupInfo db vr user gId <*> getGroupMember db user gId gMemberId + (g, m) <- withStore $ \db -> (,) <$> getGroupInfo db vr user gId <*> getGroupMember db vr user gId gMemberId case memberConnId m of Just connId -> do connectionStats <- withAgent $ \a -> abortConnectionSwitch a connId pure $ CRGroupMemberSwitchAborted user g m connectionStats _ -> throwChatError CEGroupMemberNotActive APISyncContactRatchet contactId force -> withUser $ \user -> withChatLock "syncContactRatchet" $ do - ct <- withStore $ \db -> getContact db user contactId + ct <- withStore $ \db -> getContact db vr user contactId case contactConn ct of Just conn@Connection {pqSupport} -> do cStats@ConnectionStats {ratchetSyncState = rss} <- withAgent $ \a -> synchronizeRatchet a (aConnId conn) pqSupport force @@ -1309,7 +1307,7 @@ processChatCommand' vr = \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 vr user gId <*> getGroupMember db user gId gMemberId + (g, m) <- withStore $ \db -> (,) <$> getGroupInfo db vr user gId <*> getGroupMember db vr user gId gMemberId case memberConnId m of Just connId -> do cStats@ConnectionStats {ratchetSyncState = rss} <- withAgent $ \a -> synchronizeRatchet a connId PQSupportOff force @@ -1317,7 +1315,7 @@ processChatCommand' vr = \case pure $ CRGroupMemberRatchetSyncStarted user g m cStats _ -> throwChatError CEGroupMemberNotActive APIGetContactCode contactId -> withUser $ \user -> do - ct@Contact {activeConn} <- withStore $ \db -> getContact db user contactId + ct@Contact {activeConn} <- withStore $ \db -> getContact db vr user contactId case activeConn of Just conn@Connection {connId} -> do code <- getConnectionCode $ aConnId conn @@ -1331,7 +1329,7 @@ processChatCommand' vr = \case pure $ CRContactCode user ct' code Nothing -> throwChatError $ CEContactNotActive ct APIGetGroupMemberCode gId gMemberId -> withUser $ \user -> do - (g, m@GroupMember {activeConn}) <- withStore $ \db -> (,) <$> getGroupInfo db vr user gId <*> getGroupMember db user gId gMemberId + (g, m@GroupMember {activeConn}) <- withStore $ \db -> (,) <$> getGroupInfo db vr user gId <*> getGroupMember db vr user gId gMemberId case activeConn of Just conn@Connection {connId} -> do code <- getConnectionCode $ aConnId conn @@ -1345,24 +1343,24 @@ processChatCommand' vr = \case pure $ CRGroupMemberCode user g m' code _ -> throwChatError CEGroupMemberNotActive APIVerifyContact contactId code -> withUser $ \user -> do - ct@Contact {activeConn} <- withStore $ \db -> getContact db user contactId + ct@Contact {activeConn} <- withStore $ \db -> getContact db vr user contactId case activeConn of Just conn -> verifyConnectionCode user conn code Nothing -> throwChatError $ CEContactNotActive ct APIVerifyGroupMember gId gMemberId code -> withUser $ \user -> do - GroupMember {activeConn} <- withStore $ \db -> getGroupMember db user gId gMemberId + GroupMember {activeConn} <- withStore $ \db -> getGroupMember db vr user gId gMemberId case activeConn of Just conn -> verifyConnectionCode user conn code _ -> throwChatError CEGroupMemberNotActive APIEnableContact contactId -> withUser $ \user -> do - ct@Contact {activeConn} <- withStore $ \db -> getContact db user contactId + ct@Contact {activeConn} <- withStore $ \db -> getContact db vr user contactId case activeConn of Just conn -> do withStore' $ \db -> setConnectionAuthErrCounter db user conn 0 ok user Nothing -> throwChatError $ CEContactNotActive ct APIEnableGroupMember gId gMemberId -> withUser $ \user -> do - GroupMember {activeConn} <- withStore $ \db -> getGroupMember db user gId gMemberId + GroupMember {activeConn} <- withStore $ \db -> getGroupMember db vr user gId gMemberId case activeConn of Just conn -> do withStore' $ \db -> setConnectionAuthErrCounter db user conn 0 @@ -1373,7 +1371,7 @@ processChatCommand' vr = \case SetShowMemberMessages gName mName showMessages -> withUser $ \user -> do (gId, mId) <- getGroupAndMemberId user gName mName gInfo <- withStore $ \db -> getGroupInfo db vr user gId - m <- withStore $ \db -> getGroupMember db user gId mId + m <- withStore $ \db -> getGroupMember db vr user gId mId let GroupInfo {membership = GroupMember {memberRole = membershipRole}} = gInfo when (membershipRole >= GRAdmin) $ throwChatError $ CECantBlockMemberForSelf gInfo m showMessages let settings = (memberSettings m) {showMessages} @@ -1437,7 +1435,7 @@ processChatCommand' vr = \case -- TODO PQ the error above should be CEIncompatibleConnReqVersion, also the same API should be called in Plan Just (agentV, pqSup') -> do let chatV = agentToChatVersion agentV - dm <- encodeConnInfoPQ pqSup' (Just chatV) $ XInfo profileToSend + dm <- encodeConnInfoPQ pqSup' chatV $ XInfo profileToSend connId <- withAgent $ \a -> joinConnection a (aUserId user) True cReq dm pqSup' subMode conn <- withStore' $ \db -> createDirectConnection db user connId cReq ConnJoined (incognitoProfile $> profileToSend) subMode chatV pqSup' pure $ CRSentConfirmation user conn @@ -1452,7 +1450,7 @@ processChatCommand' vr = \case _ -> processChatCommand $ APIConnect userId incognito aCReqUri Connect _ Nothing -> throwChatError CEInvalidConnReq APIConnectContactViaAddress userId incognito contactId -> withUserId userId $ \user -> do - ct@Contact {activeConn, profile = LocalProfile {contactLink}} <- withStore $ \db -> getContact db user contactId + ct@Contact {activeConn, profile = LocalProfile {contactLink}} <- withStore $ \db -> getContact db vr user contactId when (isJust activeConn) $ throwChatError (CECommandError "contact already has connection") case contactLink of Just cReq -> connectContactViaAddress user incognito ct cReq @@ -1468,7 +1466,7 @@ processChatCommand' vr = \case DeleteContact cName -> withContactName cName $ \ctId -> APIDeleteChat (ChatRef CTDirect ctId) True ClearContact cName -> withContactName cName $ APIClearChat . ChatRef CTDirect APIListContacts userId -> withUserId userId $ \user -> - CRContactsList user <$> withStore' (`getUserContacts` user) + CRContactsList user <$> withStore' (\db -> getUserContacts db vr user) ListContacts -> withUser $ \User {userId} -> processChatCommand $ APIListContacts userId APICreateMyAddress userId -> withUserId userId $ \user -> withChatLock "createMyAddress" . procCmd $ do @@ -1480,7 +1478,7 @@ processChatCommand' vr = \case CreateMyAddress -> withUser $ \User {userId} -> processChatCommand $ APICreateMyAddress userId APIDeleteMyAddress userId -> withUserId userId $ \user@User {profile = p} -> do - conns <- withStore (`getUserAddressConnections` user) + conns <- withStore $ \db -> getUserAddressConnections db vr user withChatLock "deleteMyAddress" $ do deleteAgentConnectionsAsync user $ map aConnId conns withStore' (`deleteUserAddress` user) @@ -1546,7 +1544,7 @@ processChatCommand' vr = \case _ -> throwChatError $ CECommandError "not supported" SendMemberContactMessage gName mName msg -> withUser $ \user -> do (gId, mId) <- getGroupAndMemberId user gName mName - m <- withStore $ \db -> getGroupMember db user gId mId + m <- withStore $ \db -> getGroupMember db vr user gId mId let mc = MCText msg case memberContactId m of Nothing -> do @@ -1565,7 +1563,7 @@ processChatCommand' vr = \case let mc = MCText msg processChatCommand . APISendMessage chatRef True Nothing $ ComposedMessage Nothing Nothing mc SendMessageBroadcast msg -> withUser $ \user -> do - contacts <- withStore' (`getUserContacts` user) + contacts <- withStore' $ \db -> getUserContacts db vr user let cts = filter (\ct -> contactReady ct && contactActive ct && directOrUsed ct) contacts ChatConfig {logLevel} <- asks config withChatLock "sendMessageBroadcast" . procCmd $ do @@ -1617,7 +1615,7 @@ processChatCommand' vr = \case 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 vr user groupId <*> getContact db user contactId + (group, contact) <- withStore $ \db -> (,) <$> getGroup db vr user groupId <*> getContact db vr user contactId assertDirectAllowed user MDSnd contact XGrpInv_ let Group gInfo members = group Contact {localDisplayName = cName} = contact @@ -1648,7 +1646,7 @@ processChatCommand' vr = \case withChatLock "joinGroup" . procCmd $ do (invitation, ct) <- withStore $ \db -> do inv@ReceivedGroupInvitation {fromMember} <- getGroupInvitation db vr user groupId - (inv,) <$> getContactViaMember db user fromMember + (inv,) <$> getContactViaMember db vr user fromMember let ReceivedGroupInvitation {fromMember, connRequest, groupInfo = g@GroupInfo {membership}} = invitation GroupMember {memberId = membershipMemId} = membership Contact {activeConn} = ct @@ -1657,7 +1655,7 @@ processChatCommand' vr = \case subMode <- chatReadVar subscriptionMode dm <- encodeConnInfo $ XGrpAcpt membershipMemId agentConnId <- withAgent $ \a -> joinConnection a (aUserId user) True connRequest dm PQSupportOff subMode - let chatV = vr `compatibleChatVersion` peerChatVRange + let chatV = vr PQSupportOff `peerConnChatVersion` peerChatVRange withStore' $ \db -> do createMemberConnection db userId fromMember agentConnId chatV peerChatVRange subMode updateGroupMemberStatus db userId fromMember GSMemAccepted @@ -1681,7 +1679,7 @@ processChatCommand' vr = \case withStore' $ \db -> updateGroupMemberRole db user m memRole case mStatus of GSMemInvited -> do - withStore (\db -> (,) <$> mapM (getContact db user) memberContactId <*> liftIO (getMemberInvitation db user $ groupMemberId' m)) >>= \case + withStore (\db -> (,) <$> mapM (getContact db vr user) memberContactId <*> liftIO (getMemberInvitation db user $ groupMemberId' m)) >>= \case (Just ct, Just cReq) -> sendGrpInvitation user ct gInfo (m :: GroupMember) {memberRole = memRole} cReq _ -> throwChatError $ CEGroupCantResendInvitation gInfo cName _ -> do @@ -1707,7 +1705,7 @@ processChatCommand' vr = \case toView $ CRNewChatItem user (AChatItem SCTGroup SMDSnd (GroupChat gInfo) ci) bm' <- withStore $ \db -> do liftIO $ updateGroupMemberBlocked db user groupId memberId mrs - getGroupMember db user groupId memberId + getGroupMember db vr user groupId memberId toggleNtf user bm' (not blocked) pure CRMemberBlockedForAllUser {user, groupInfo = gInfo, member = bm', blocked} where @@ -1773,7 +1771,7 @@ processChatCommand' vr = \case APIListGroups userId contactId_ search_ -> withUserId userId $ \user -> 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 + ct_ <- forM cName_ $ \cName -> withStore $ \db -> getContactByName db vr user cName processChatCommand $ APIListGroups userId (contactId' <$> ct_) search_ APIUpdateGroupProfile groupId p' -> withUser $ \user -> do g <- withStore $ \db -> getGroup db vr user groupId @@ -1812,7 +1810,7 @@ processChatCommand' vr = \case (_, 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 vr user gId <*> getGroupMember db user gId gMemberId + (g, m) <- withStore $ \db -> (,) <$> getGroupInfo db vr user gId <*> getGroupMember db vr user gId gMemberId assertUserGroupRole g GRAuthor unless (groupFeatureAllowed SGFDirectMessages g) $ throwChatError $ CECommandError "direct messages not allowed" case memberConn m of @@ -1935,7 +1933,7 @@ processChatCommand' vr = \case withStore (\db -> liftIO $ lookupChatRefByFileId db user fileId) >>= \case Nothing -> pure () Just (ChatRef CTDirect contactId) -> do - (contact, sharedMsgId) <- withStore $ \db -> (,) <$> getContact db user contactId <*> getSharedMsgIdByFileId db userId fileId + (contact, sharedMsgId) <- withStore $ \db -> (,) <$> getContact db vr user contactId <*> getSharedMsgIdByFileId db userId fileId void . sendDirectContactMessage user contact $ XFileCancel sharedMsgId Just (ChatRef CTGroup groupId) -> do (Group gInfo ms, sharedMsgId) <- withStore $ \db -> (,) <$> getGroup db vr user groupId <*> getSharedMsgIdByFileId db userId fileId @@ -1992,7 +1990,7 @@ processChatCommand' vr = \case let p = (fromLocalProfile profile :: Profile) {preferences = Just . setPreference f (Just allowed) $ preferences' user} updateProfile user p SetContactFeature (ACF f) cName allowed_ -> withUser $ \user -> do - ct@Contact {userPreferences} <- withStore $ \db -> getContactByName db user cName + ct@Contact {userPreferences} <- withStore $ \db -> getContactByName db vr user cName let prefs' = setPreference f allowed_ $ Just userPreferences updateContactPrefs user ct prefs' SetGroupFeature (AGF f) gName enabled -> @@ -2004,7 +2002,7 @@ processChatCommand' vr = \case p = (fromLocalProfile profile :: Profile) {preferences = Just . setPreference' SCFTimedMessages (Just pref) $ preferences' user} updateProfile user p SetContactTimedMessages cName timedMessagesEnabled_ -> withUser $ \user -> do - ct@Contact {userPreferences = userPreferences@Preferences {timedMessages}} <- withStore $ \db -> getContactByName db user cName + ct@Contact {userPreferences = userPreferences@Preferences {timedMessages}} <- withStore $ \db -> getContactByName db vr user cName let currentTTL = timedMessages >>= \TimedMessagesPreference {ttl} -> ttl pref_ = tmeToPref currentTTL <$> timedMessagesEnabled_ prefs' = setPreference' SCFTimedMessages pref_ $ Just userPreferences @@ -2149,7 +2147,7 @@ processChatCommand' vr = \case case groupLinkId of -- contact address Nothing -> - withStore' (\db -> getConnReqContactXContactId db user cReqHash) >>= \case + withStore' (\db -> getConnReqContactXContactId db vr user cReqHash) >>= \case (Just contact, _) -> pure $ CRContactAlreadyExists user contact (_, xContactId_) -> procCmd $ do let randomXContactId = XContactId <$> drgRandomBytes 16 @@ -2157,7 +2155,7 @@ processChatCommand' vr = \case connect' Nothing cReqHash xContactId False -- group link Just gLinkId -> - withStore' (\db -> getConnReqContactXContactId db user cReqHash) >>= \case + withStore' (\db -> getConnReqContactXContactId db vr user cReqHash) >>= \case (Just _contact, _) -> procCmd $ do -- allow repeat contact request newXContactId <- XContactId <$> drgRandomBytes 16 @@ -2179,7 +2177,7 @@ processChatCommand' vr = \case pqSup <- chatReadVar pqExperimentalEnabled (connId, incognitoProfile, subMode, chatV) <- requestContact user incognito cReq newXContactId False pqSup let cReqHash = ConnReqUriHash . C.sha256Hash $ strEncode cReq - ct' <- withStore $ \db -> createAddressContactConnection db user ct connId cReqHash newXContactId incognitoProfile subMode chatV pqSup + ct' <- withStore $ \db -> createAddressContactConnection db vr user ct connId cReqHash newXContactId incognitoProfile subMode chatV pqSup pure $ CRSentInvitationToContact user ct' incognitoProfile requestContact :: User -> IncognitoEnabled -> ConnectionRequestUri 'CMContact -> XContactId -> Bool -> PQSupport -> m (ConnId, Maybe Profile, SubscriptionMode, VersionChat) requestContact user incognito cReq xContactId inGroup pqSup = do @@ -2193,7 +2191,7 @@ processChatCommand' vr = \case Nothing -> throwChatError CEInvalidConnReq Just (agentV, _) -> do let chatV = agentToChatVersion agentV - dm <- encodeConnInfoPQ pqSup (Just chatV) (XContact profileToSend $ Just xContactId) + dm <- encodeConnInfoPQ pqSup chatV (XContact profileToSend $ Just xContactId) subMode <- chatReadVar subscriptionMode connId <- withAgent $ \a -> joinConnection a (aUserId user) True cReq dm pqSup subMode pure (connId, incognitoProfile, subMode, chatV) @@ -2216,7 +2214,7 @@ processChatCommand' vr = \case | otherwise = do when (n /= n') $ checkValidName n' -- read contacts before user update to correctly merge preferences - contacts <- withStore' (`getUserContacts` user) + contacts <- withStore' $ \db -> getUserContacts db vr user user' <- updateUser asks currentUser >>= atomically . (`writeTVar` Just user') withChatLock "updateProfile" . procCmd $ do @@ -2309,7 +2307,7 @@ processChatCommand' vr = \case withCurrentCall ctId action = do (user, ct) <- withStore $ \db -> do user <- getUserByContactId db ctId - (user,) <$> getContact db user ctId + (user,) <$> getContact db vr user ctId calls <- asks currentCalls withChatLock "currentCall" $ atomically (TM.lookup ctId calls) >>= \case @@ -2426,7 +2424,7 @@ processChatCommand' vr = \case (chatId, chatSettings) <- case cType of CTDirect -> withStore $ \db -> do ctId <- getContactIdByName db user name - Contact {chatSettings} <- getContact db user ctId + Contact {chatSettings} <- getContact db vr user ctId pure (ctId, chatSettings) CTGroup -> withStore $ \db -> do @@ -2467,7 +2465,7 @@ processChatCommand' vr = \case Nothing -> withStore' (\db -> getContactConnEntityByConnReqHash db vr user cReqHashes) >>= \case Nothing -> - withStore' (\db -> getContactWithoutConnViaAddress db user cReqSchemas) >>= \case + withStore' (\db -> getContactWithoutConnViaAddress db vr user cReqSchemas) >>= \case Nothing -> pure $ CPContactAddress CAPOk Just ct -> pure $ CPContactAddress (CAPContactViaAddress ct) Just (RcvDirectMsgConnection _conn Nothing) -> pure $ CPContactAddress CAPConnectingConfirmReconnect @@ -2757,8 +2755,7 @@ acceptFileReceive user@User {userId} RcvFileTransfer {fileId, xftpRcvFile, fileI unless (fileStatus == RFSNew) $ case fileStatus of RFSCancelled _ -> throwChatError $ CEFileCancelled fName _ -> throwChatError $ CEFileAlreadyReceiving fName - -- TODO PQ this is only used to set membership version range - vr <- chatVersionRange PQSupportOff + vr <- chatVersionRange case (xftpRcvFile, fileConnReq) of -- direct file protocol (Nothing, Just connReq) -> do @@ -2783,10 +2780,10 @@ acceptFileReceive user@User {userId} RcvFileTransfer {fileId, xftpRcvFile, fileI chatRef <- withStoreCtx (Just "acceptFileReceive, getChatRefByFileId") $ \db -> getChatRefByFileId db user fileId case (chatRef, grpMemberId) of (ChatRef CTDirect contactId, Nothing) -> do - ct <- withStoreCtx (Just "acceptFileReceive, getContact") $ \db -> getContact db user contactId + ct <- withStoreCtx (Just "acceptFileReceive, getContact") $ \db -> getContact db vr user contactId acceptFile CFCreateConnFileInvDirect $ \msg -> void $ sendDirectContactMessage user ct msg (ChatRef CTGroup groupId, Just memId) -> do - GroupMember {activeConn} <- withStoreCtx (Just "acceptFileReceive, getGroupMember") $ \db -> getGroupMember db user groupId memId + GroupMember {activeConn} <- withStoreCtx (Just "acceptFileReceive, getGroupMember") $ \db -> getGroupMember db vr user groupId memId case activeConn of Just conn -> do acceptFile CFCreateConnFileInvGroup $ \msg -> void $ sendDirectMemberMessage conn msg groupId @@ -2797,8 +2794,7 @@ acceptFileReceive user@User {userId} RcvFileTransfer {fileId, xftpRcvFile, fileI acceptFile cmdFunction send = do filePath <- getRcvFilePath fileId filePath_ fName True inline <- receiveInline - -- TODO PQ this is only used to set membership version range - vr <- chatVersionRange PQSupportOff + vr <- chatVersionRange if | inline -> do -- accepting inline @@ -2845,8 +2841,7 @@ receiveViaURI user@User {userId} FileDescriptionURI {description} cf@CryptoFile startReceivingFile :: ChatMonad m => User -> FileTransferId -> m () startReceivingFile user fileId = do - -- TODO PQ this is only used to set membership version range - vr <- chatVersionRange PQSupportOff + vr <- chatVersionRange ci <- withStoreCtx (Just "startReceivingFile, updateRcvFileStatus ...") $ \db -> do liftIO $ updateRcvFileStatus db fileId FSConnected liftIO $ updateCIFileStatus db user fileId $ CIFSRcvTransfer 0 1 @@ -2890,10 +2885,11 @@ getRcvFilePath fileId fPath_ fn keepHandle = case fPath_ of acceptContactRequest :: ChatMonad m => User -> UserContactRequest -> Maybe IncognitoProfile -> Bool -> m Contact acceptContactRequest user UserContactRequest {agentInvitationId = AgentInvId invId, cReqChatVRange, localDisplayName = cName, profileId, profile = cp, userContactLinkId, xContactId, pqSupport} incognitoProfile contactUsed = do subMode <- chatReadVar subscriptionMode - let profileToSend = profileToSendOnAccept user incognitoProfile False pqSup <- chatReadVar pqExperimentalEnabled - let pqSup' = pqSup `CR.pqSupportAnd` pqSupport - chatV <- pqCompatibleVersion pqSup cReqChatVRange + vr <- chatVersionRange + let profileToSend = profileToSendOnAccept user incognitoProfile False + chatV = vr pqSup `peerConnChatVersion` cReqChatVRange + pqSup' = pqSup `CR.pqSupportAnd` pqSupport dm <- encodeConnInfoPQ pqSup' chatV $ XInfo profileToSend acId <- withAgent $ \a -> acceptContact a True invId dm pqSup' subMode withStore' $ \db -> createAcceptedContact db user acId chatV cReqChatVRange cName profileId cp userContactLinkId xContactId incognitoProfile subMode pqSup' contactUsed @@ -2902,7 +2898,8 @@ acceptContactRequestAsync :: ChatMonad m => User -> UserContactRequest -> Maybe acceptContactRequestAsync user UserContactRequest {agentInvitationId = AgentInvId invId, cReqChatVRange, localDisplayName = cName, profileId, profile = p, userContactLinkId, xContactId} incognitoProfile contactUsed pqSup = do subMode <- chatReadVar subscriptionMode let profileToSend = profileToSendOnAccept user incognitoProfile False - chatV <- chatReadVar pqExperimentalEnabled >>= (`pqCompatibleVersion` cReqChatVRange) + vr <- chatVersionRange + chatV <- (\pq -> vr pq `peerConnChatVersion` cReqChatVRange) <$> chatReadVar pqExperimentalEnabled (cmdId, acId) <- agentAcceptContactAsync user True invId (XInfo profileToSend) subMode pqSup chatV withStore' $ \db -> do ct@Contact {activeConn} <- createAcceptedContact db user acId chatV cReqChatVRange cName profileId p userContactLinkId xContactId incognitoProfile subMode pqSup contactUsed @@ -2931,11 +2928,12 @@ acceptGroupJoinRequestAsync groupSize = Just currentMemCount } subMode <- chatReadVar subscriptionMode - chatV <- chatReadVar pqExperimentalEnabled >>= (`pqCompatibleVersion` cReqChatVRange) + vr <- chatVersionRange + chatV <- (\pq -> vr pq `peerConnChatVersion` cReqChatVRange) <$> chatReadVar pqExperimentalEnabled connIds <- agentAcceptContactAsync user True invId msg subMode PQSupportOff chatV withStore $ \db -> do liftIO $ createAcceptedMemberConnection db user connIds chatV ucr groupMemberId subMode - getGroupMemberById db user groupMemberId + getGroupMemberById db vr user groupMemberId profileToSendOnAccept :: User -> Maybe IncognitoProfile -> Bool -> Profile profileToSendOnAccept user ip = userProfileToSend user (getIncognitoProfile <$> ip) Nothing @@ -2946,12 +2944,14 @@ profileToSendOnAccept user ip = userProfileToSend user (getIncognitoProfile <$> deleteGroupLink' :: ChatMonad m => User -> GroupInfo -> m () deleteGroupLink' user gInfo = do - conn <- withStore $ \db -> getGroupLinkConnection db user gInfo + vr <- chatVersionRange + conn <- withStore $ \db -> getGroupLinkConnection db vr user gInfo deleteGroupLink_ user gInfo conn deleteGroupLinkIfExists :: ChatMonad m => User -> GroupInfo -> m () deleteGroupLinkIfExists user gInfo = do - conn_ <- eitherToMaybe <$> withStore' (\db -> runExceptT $ getGroupLinkConnection db user gInfo) + vr <- chatVersionRange + conn_ <- eitherToMaybe <$> withStore' (\db -> runExceptT $ getGroupLinkConnection db vr user gInfo) mapM_ (deleteGroupLink_ user gInfo) conn_ deleteGroupLink_ :: ChatMonad m => User -> GroupInfo -> Connection -> m () @@ -2980,7 +2980,7 @@ agentSubscriber = do type AgentBatchSubscribe m = AgentClient -> [ConnId] -> ExceptT AgentErrorType m (Map ConnId (Either AgentErrorType ())) -subscribeUserConnections :: forall m. ChatMonad m => VersionRangeChat -> Bool -> AgentBatchSubscribe m -> User -> m () +subscribeUserConnections :: forall m. ChatMonad m => (PQSupport -> VersionRangeChat) -> Bool -> AgentBatchSubscribe m -> User -> m () subscribeUserConnections vr onlyNeeded agentBatchSubscribe user@User {userId} = do -- get user connections ce <- asks $ subscriptionEvents . config @@ -3036,12 +3036,12 @@ subscribeUserConnections vr onlyNeeded agentBatchSubscribe user@User {userId} = } getContactConns :: m ([ConnId], Map ConnId Contact) getContactConns = do - cts <- withStore_ ("subscribeUserConnections " <> show userId <> ", getUserContacts") getUserContacts + cts <- withStore_ ("subscribeUserConnections " <> show userId <> ", getUserContacts") (`getUserContacts` vr) let cts' = mapMaybe (\ct -> (,ct) <$> contactConnId ct) $ filter contactActive cts pure (map fst cts', M.fromList cts') getUserContactLinkConns :: m ([ConnId], Map ConnId UserContact) getUserContactLinkConns = do - (cs, ucs) <- unzip <$> withStore_ ("subscribeUserConnections " <> show userId <> ", getUserContactLinks") getUserContactLinks + (cs, ucs) <- unzip <$> withStore_ ("subscribeUserConnections " <> show userId <> ", getUserContactLinks") (`getUserContactLinks` vr) let connIds = map aConnId cs pure (connIds, M.fromList $ zip connIds ucs) getGroupMemberConns :: m ([Group], [ConnId], Map ConnId GroupMember) @@ -3181,7 +3181,8 @@ cleanupManager = do timedItems <- withStoreCtx' (Just "cleanupManager, getTimedItems") $ \db -> getTimedItems db user startTimedThreadCutoff forM_ timedItems $ \(itemRef, deleteAt) -> startTimedItemThread user itemRef deleteAt `catchChatError` const (pure ()) cleanupDeletedContacts user = do - contacts <- withStore' (`getDeletedContacts` user) + vr <- chatVersionRange + contacts <- withStore' $ \db -> getDeletedContacts db vr user forM_ contacts $ \ct -> withStore (\db -> deleteContactWithoutGroups db user ct) `catchChatError` (toView . CRChatError (Just user)) @@ -3221,11 +3222,10 @@ deleteTimedItem user (ChatRef cType chatId, itemId) deleteAt = do ts <- liftIO getCurrentTime liftIO $ threadDelay' $ diffToMicroseconds $ diffUTCTime deleteAt ts waitChatStartedAndActivated - -- TODO PQ this is only used to set membership version range - vr <- chatVersionRange PQSupportOff + vr <- chatVersionRange case cType of CTDirect -> do - (ct, CChatItem _ ci) <- withStore $ \db -> (,) <$> getContact db user chatId <*> getDirectChatItem db user chatId itemId + (ct, CChatItem _ ci) <- withStore $ \db -> (,) <$> getContact db vr user chatId <*> getDirectChatItem db user chatId itemId deleteDirectCI user ct ci True True >>= toView CTGroup -> do (gInfo, CChatItem _ ci) <- withStore $ \db -> (,) <$> getGroupInfo db vr user chatId <*> getGroupChatItem db user chatId itemId @@ -3243,17 +3243,16 @@ startUpdatedTimedItemThread user chatRef ci ci' = expireChatItems :: forall m. ChatMonad m => User -> Int64 -> Bool -> m () expireChatItems user@User {userId} ttl sync = do currentTs <- liftIO getCurrentTime - -- TODO PQ this is only used to set membership version range - vr <- chatVersionRange PQSupportOff + 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 waitChatStartedAndActivated - contacts <- withStoreCtx' (Just "expireChatItems, getUserContacts") (`getUserContacts` user) + contacts <- withStoreCtx' (Just "expireChatItems, getUserContacts") $ \db -> getUserContacts db vr user loop contacts $ processContact expirationDate waitChatStartedAndActivated - groups <- withStoreCtx' (Just "expireChatItems, getUserGroupDetails") (\db -> getUserGroupDetails db vr user Nothing Nothing) - loop groups $ processGroup expirationDate createdAtCutoff + groups <- withStoreCtx' (Just "expireChatItems, getUserGroupDetails") $ \db -> getUserGroupDetails db vr user Nothing Nothing + loop groups $ processGroup vr expirationDate createdAtCutoff where loop :: [a] -> (a -> m ()) -> m () loop [] _ = pure () @@ -3275,14 +3274,14 @@ expireChatItems user@User {userId} ttl sync = do cancelFilesInProgress user filesInfo deleteFilesLocally filesInfo withStoreCtx' (Just "processContact, deleteContactExpiredCIs") $ \db -> deleteContactExpiredCIs db user ct expirationDate - processGroup :: UTCTime -> UTCTime -> GroupInfo -> m () - processGroup expirationDate createdAtCutoff gInfo = do + processGroup :: (PQSupport -> VersionRangeChat) -> UTCTime -> UTCTime -> GroupInfo -> m () + processGroup vr expirationDate createdAtCutoff gInfo = do waitChatStartedAndActivated filesInfo <- withStoreCtx' (Just "processGroup, getGroupExpiredFileInfo") $ \db -> getGroupExpiredFileInfo db user gInfo expirationDate createdAtCutoff cancelFilesInProgress user filesInfo deleteFilesLocally filesInfo withStoreCtx' (Just "processGroup, deleteGroupExpiredCIs") $ \db -> deleteGroupExpiredCIs db user gInfo expirationDate createdAtCutoff - membersToDelete <- withStoreCtx' (Just "processGroup, getGroupMembersForExpiration") $ \db -> getGroupMembersForExpiration db user gInfo + membersToDelete <- withStoreCtx' (Just "processGroup, getGroupMembersForExpiration") $ \db -> getGroupMembersForExpiration db vr user gInfo forM_ membersToDelete $ \m -> withStoreCtx' (Just "processGroup, deleteGroupMember") $ \db -> deleteGroupMember db user m processAgentMessage :: forall m. ChatMonad m => ACorrId -> ConnId -> ACommand 'Agent 'AEConn -> m () @@ -3291,8 +3290,7 @@ processAgentMessage _ connId (DEL_RCVQ srv qId err_) = processAgentMessage _ connId DEL_CONN = toView $ CRAgentConnDeleted (AgentConnId connId) processAgentMessage corrId connId msg = do - -- TODO PQ this is only used to set membership version range (?) - vr <- chatVersionRange PQSupportOff + vr <- chatVersionRange withStore' (`getUserByAConnId` AgentConnId connId) >>= \case Just user -> processAgentMessageConn vr user corrId connId msg `catchChatError` (toView . CRChatError (Just user)) _ -> throwChatError $ CENoConnectionUser (AgentConnId connId) @@ -3331,8 +3329,7 @@ processAgentMsgSndFile _corrId aFileId msg = (ft@FileTransferMeta {fileId, xftpRedirectFor, cancelled}, sfts) <- withStore $ \db -> do fileId <- getXFTPSndFileDBId db user $ AgentSndFileId aFileId getSndFileTransfer db user fileId - -- TODO PQ this is only used to set membership version range - vr <- chatVersionRange PQSupportOff + vr <- chatVersionRange unless cancelled $ case msg of SFPROG sndProgress sndTotal -> do let status = CIFSSndTransfer {sndProgress, sndTotal} @@ -3369,7 +3366,7 @@ processAgentMsgSndFile _corrId aFileId msg = withStore' $ \db -> updateSndFTDeliveryXFTP db sft msgDeliveryId withAgent (`xftpDeleteSndFileInternal` aFileId) (_, _, SMDSnd, GroupChat g@GroupInfo {groupId}) -> do - ms <- withStore' $ \db -> getGroupMembers db user g + ms <- withStore' $ \db -> getGroupMembers db vr user g let rfdsMemberFTs = zip rfds $ memberFTs ms extraRFDs = drop (length rfdsMemberFTs) rfds withStore' $ \db -> createExtraSndFTDescrs db user fileId (map fileDescrText extraRFDs) @@ -3418,7 +3415,7 @@ processAgentMsgSndFile _corrId aFileId msg = case L.nonEmpty fds of Just fds' -> loopSend fds' Nothing -> pure msgDeliveryId - sendFileError :: Text -> Int64 -> VersionRangeChat -> FileTransferMeta -> m () + sendFileError :: Text -> Int64 -> (PQSupport -> VersionRangeChat) -> FileTransferMeta -> m () sendFileError err fileId vr ft = do logError $ "Sent file error: " <> err ci <- withStore $ \db -> do @@ -3453,8 +3450,7 @@ processAgentMsgRcvFile _corrId aFileId msg = ft@RcvFileTransfer {fileId} <- withStore $ \db -> do fileId <- getXFTPRcvFileDBId db $ AgentRcvFileId aFileId getRcvFileTransfer db user fileId - -- TODO PQ this is only used to set membership version range - vr <- chatVersionRange PQSupportOff + vr <- chatVersionRange unless (rcvFileCompleteOrCancelled ft) $ case msg of RFPROG rcvProgress rcvTotal -> do let status = CIFSRcvTransfer {rcvProgress, rcvTotal} @@ -3485,7 +3481,7 @@ processAgentMsgRcvFile _corrId aFileId msg = agentXFTPDeleteRcvFile aFileId fileId toView $ CRRcvFileError user ci e ft -processAgentMessageConn :: forall m. ChatMonad m => VersionRangeChat -> User -> ACorrId -> ConnId -> ACommand 'Agent 'AEConn -> m () +processAgentMessageConn :: forall m. ChatMonad m => (PQSupport -> VersionRangeChat) -> 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 @@ -3773,7 +3769,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = sendXGrpMemInv hostConnId (Just directConnReq) XGrpMemIntroCont {groupId, groupMemberId, memberId, groupConnReq} -- [async agent commands] group link auto-accept continuation on receiving INV CFCreateConnGrpInv -> do - ct <- withStore $ \db -> getContactViaMember db user m + ct <- withStore $ \db -> getContactViaMember db vr user m withStore' $ \db -> setNewContactMemberConnRequest db user m cReq groupLinkId <- withStore' $ \db -> getGroupLinkId db user gInfo sendGrpInvitation ct m groupLinkId @@ -3857,7 +3853,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = toView $ CRJoinedGroupMember user gInfo m {memberStatus = GSMemConnected} let Connection {viaUserContactLink} = conn when (isJust viaUserContactLink && isNothing (memberContactId m)) sendXGrpLinkMem - members <- withStore' $ \db -> getGroupMembers db user gInfo + members <- withStore' $ \db -> getGroupMembers db vr user gInfo void . sendGroupMessage user gInfo members . XGrpMemNew $ memberInfo m sendIntroductions members when (groupFeatureAllowed SGFHistory gInfo) sendHistory @@ -3867,7 +3863,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = profileToSend = profileToSendOnAccept user profileMode True void $ sendDirectMemberMessage conn (XGrpLinkMem profileToSend) groupId sendIntroductions members = do - intros <- withStore' $ \db -> createIntroductions db (maxVersion vr) members m + intros <- withStore' $ \db -> createIntroductions db (maxVersion $ vr PQSupportOff) members m shuffledIntros <- liftIO $ shuffleIntros intros if m `supportsVersion` batchSendVersion then do @@ -3971,7 +3967,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = pure msgForwardEvents _ -> do let memCategory = memberCategory m - withStore' (\db -> getViaGroupContact db user m) >>= \case + withStore' (\db -> getViaGroupContact db vr user m) >>= \case Nothing -> do notifyMemberConnected gInfo m Nothing let connectedIncognito = memberIncognito membership @@ -3988,12 +3984,12 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = sendXGrpMemCon = \case GCPreMember -> forM_ (invitedByGroupMemberId membership) $ \hostId -> do - host <- withStore $ \db -> getGroupMember db user groupId hostId + host <- withStore $ \db -> getGroupMember db vr user groupId hostId forM_ (memberConn host) $ \hostConn -> void $ sendDirectMemberMessage hostConn (XGrpMemCon memberId) groupId GCPostMember -> forM_ (invitedByGroupMemberId m) $ \invitingMemberId -> do - im <- withStore $ \db -> getGroupMember db user groupId invitingMemberId + im <- withStore $ \db -> getGroupMember db vr user groupId invitingMemberId forM_ (memberConn im) $ \imConn -> void $ sendDirectMemberMessage imConn (XGrpMemCon memberId) groupId _ -> messageWarning "sendXGrpMemCon: member category GCPreMember or GCPostMember is expected" @@ -4066,10 +4062,10 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = -- members introduced to this invited member introducedMembers <- if memberCategory m == GCInviteeMember - then withStore' $ \db -> getForwardIntroducedMembers db user m highlyAvailable + then withStore' $ \db -> getForwardIntroducedMembers db vr user m highlyAvailable else pure [] -- invited members to which this member was introduced - invitedMembers <- withStore' $ \db -> getForwardInvitedMembers db user m highlyAvailable + invitedMembers <- withStore' $ \db -> getForwardInvitedMembers db vr user m highlyAvailable let GroupMember {memberId} = m ms = forwardedToGroupMembers (introducedMembers <> invitedMembers) chatMsg' msg = XGrpMsgForward memberId chatMsg' brokerTs @@ -4218,13 +4214,13 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = fileInvConnReq@(CRInvitationUri _ _) -> case cmdFunction of -- [async agent commands] direct XFileAcptInv continuation on receiving INV CFCreateConnFileInvDirect -> do - ct <- withStore $ \db -> getContactByFileId db user fileId + ct <- withStore $ \db -> getContactByFileId db vr user fileId sharedMsgId <- withStore $ \db -> getSharedMsgIdByFileId db userId fileId void $ sendDirectContactMessage user ct (XFileAcptInv sharedMsgId (Just fileInvConnReq) fileName) -- [async agent commands] group XFileAcptInv continuation on receiving INV CFCreateConnFileInvGroup -> case grpMemberId of Just gMemberId -> do - GroupMember {groupId, activeConn} <- withStore $ \db -> getGroupMemberById db user gMemberId + GroupMember {groupId, activeConn} <- withStore $ \db -> getGroupMemberById db vr user gMemberId case activeConn of Just gMemberConn -> do sharedMsgId <- withStore $ \db -> getSharedMsgIdByFileId db userId fileId @@ -4315,7 +4311,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = where profileContactRequest :: InvitationId -> VersionRangeChat -> Profile -> Maybe XContactId -> PQSupport -> m () profileContactRequest invId chatVRange p xContactId_ reqPQSup = do - withStore (\db -> createOrUpdateContactRequest db user userContactLinkId invId chatVRange p xContactId_ reqPQSup) >>= \case + withStore (\db -> createOrUpdateContactRequest db vr user userContactLinkId invId chatVRange p xContactId_ reqPQSup) >>= \case CORContact contact -> toView $ CRContactRequestAlreadyAccepted user contact CORRequest cReq -> do ucl <- withStore $ \db -> getUserContactLinkById db userId userContactLinkId @@ -4452,9 +4448,9 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = sendProbe probe cs <- if doProbeContacts - then map COMContact <$> withStore' (\db -> getMatchingContacts db user ct) + then map COMContact <$> withStore' (\db -> getMatchingContacts db vr user ct) else pure [] - ms <- map COMGroupMember <$> withStore' (\db -> getMatchingMembers db user ct) + ms <- map COMGroupMember <$> withStore' (\db -> getMatchingMembers db vr user ct) sendProbeHashes (cs <> ms) probe probeId else sendProbe . Probe =<< liftIO (encodedRandomBytes gVar 32) where @@ -4470,7 +4466,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = then do (probe, probeId) <- withStore $ \db -> createSentProbe db gVar userId $ COMGroupMember m sendProbe probe - cs <- map COMContact <$> withStore' (\db -> getMatchingMemberContacts db user m) + cs <- map COMContact <$> withStore' (\db -> getMatchingMemberContacts db vr user m) sendProbeHashes cs probe probeId else sendProbe . Probe =<< liftIO (encodedRandomBytes gVar 32) where @@ -4676,7 +4672,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = | isVoice content && not (groupFeatureAllowed SGFVoice gInfo) = rejected GFVoice | not (isVoice content) && isJust fInv_ && not (groupFeatureAllowed SGFFiles gInfo) = rejected GFFiles | otherwise = - withStore' (\db -> getCIModeration db user gInfo memberId sharedMsgId_) >>= \case + withStore' (\db -> getCIModeration db vr user gInfo memberId sharedMsgId_) >>= \case Just ciModeration -> do applyModeration ciModeration withStore' $ \db -> deleteCIModeration db gInfo memberId sharedMsgId_ @@ -4848,7 +4844,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = subMode <- chatReadVar subscriptionMode dm <- encodeConnInfo XOk connIds <- joinAgentConnectionAsync user True fileConnReq dm subMode - withStore' $ \db -> createSndDirectFTConnection db user fileId connIds subMode + withStore' $ \db -> createSndDirectFTConnection db vr user fileId connIds subMode -- receiving inline _ -> do event <- withStore $ \db -> do @@ -4945,7 +4941,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = -- [async agent commands] no continuation needed, but command should be asynchronous for stability dm <- encodeConnInfo XOk connIds <- joinAgentConnectionAsync user True fileConnReq dm subMode - withStore' $ \db -> createSndGroupFileTransferConnection db user fileId connIds m subMode + withStore' $ \db -> createSndGroupFileTransferConnection db vr user fileId connIds m subMode (_, Just conn) -> do -- receiving inline event <- withStore $ \db -> do @@ -5012,7 +5008,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = if directOrUsed c then do ct' <- withStore' $ \db -> updateContactStatus db user c CSDeleted - contactConns <- withStore' $ \db -> getContactConnections db userId ct' + contactConns <- withStore' $ \db -> getContactConnections db vr userId ct' deleteAgentConnectionsAsync user $ map aConnId contactConns forM_ contactConns $ \conn -> withStore' $ \db -> updateConnectionStatus db conn ConnDeleted activeConn' <- forM (contactConn ct') $ \conn -> pure conn {connStatus = ConnDeleted} @@ -5021,7 +5017,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = toView $ CRNewChatItem user (AChatItem SCTDirect SMDRcv (DirectChat ct'') ci) toView $ CRContactDeletedByContact user ct'' else do - contactConns <- withStore' $ \db -> getContactConnections db userId c + contactConns <- withStore' $ \db -> getContactConnections db vr userId c deleteAgentConnectionsAsync user $ map aConnId contactConns withStore $ \db -> deleteContact db user c where @@ -5092,7 +5088,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = toView $ CRGroupMemberUpdated user gInfo m m' pure m' Just mContactId -> do - mCt <- withStore $ \db -> getContact db user mContactId + mCt <- withStore $ \db -> getContact db vr user mContactId if canUpdateProfile mCt then do (m', ct') <- withStore $ \db -> updateContactMemberProfile db user m mCt p' @@ -5133,7 +5129,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = contactMerge <- readTVarIO =<< asks contactMergeEnabled -- [incognito] unless connected incognito when (contactMerge && not (contactOrMemberIncognito cgm2)) $ do - cgm1s <- withStore' $ \db -> matchReceivedProbe db user cgm2 probe + cgm1s <- withStore' $ \db -> matchReceivedProbe db vr user cgm2 probe let cgm1s' = filter (not . contactOrMemberIncognito) cgm1s probeMatches cgm1s' cgm2 where @@ -5149,7 +5145,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = contactMerge <- readTVarIO =<< asks contactMergeEnabled -- [incognito] unless connected incognito when (contactMerge && not (contactOrMemberIncognito cgm1)) $ do - cgm2Probe_ <- withStore' $ \db -> matchReceivedProbeHash db user cgm1 probeHash + cgm2Probe_ <- withStore' $ \db -> matchReceivedProbeHash db vr user cgm1 probeHash forM_ cgm2Probe_ $ \(cgm2, probe) -> unless (contactOrMemberIncognito cgm2) . void $ probeMatch cgm1 cgm2 probe @@ -5181,7 +5177,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = xInfoProbeOk :: ContactOrMember -> Probe -> m () xInfoProbeOk cgm1 probe = do - cgm2 <- withStore' $ \db -> matchSentProbe db user cgm1 probe + cgm2 <- withStore' $ \db -> matchSentProbe db vr user cgm1 probe case cgm1 of COMContact c1@Contact {contactId = cId1} -> case cgm2 of @@ -5317,7 +5313,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = _ -> pure Nothing where merge c1' c2' = do - c2'' <- withStore $ \db -> mergeContactRecords db user c1' c2' + c2'' <- withStore $ \db -> mergeContactRecords db vr user c1' c2' toView $ CRContactsMerged user c1' c2' c2'' when (directOrUsed c2'') $ showSecurityCodeChanged c2'' pure $ Just c2'' @@ -5362,7 +5358,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = associateContactWithMember :: GroupMember -> Contact -> m Contact associateContactWithMember m1@GroupMember {groupId} c2 = do - c2' <- withStore $ \db -> associateContactWithMemberRecord db user m1 c2 + c2' <- withStore $ \db -> associateContactWithMemberRecord db vr user m1 c2 g <- withStore $ \db -> getGroupInfo db vr user groupId toView $ CRContactAndMemberAssociated user c2 g m1 c2' pure c2' @@ -5388,9 +5384,9 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = xGrpMemNew gInfo m memInfo@(MemberInfo memId memRole _ _) msg brokerTs = do checkHostRole m memRole unless (sameMemberId memId $ membership gInfo) $ - withStore' (\db -> runExceptT $ getGroupMemberByMemberId db user gInfo memId) >>= \case + withStore' (\db -> runExceptT $ getGroupMemberByMemberId db vr user gInfo memId) >>= \case Right unknownMember@GroupMember {memberStatus = GSMemUnknown} -> do - updatedMember <- withStore $ \db -> updateUnknownMemberAnnounced db user m unknownMember memInfo + updatedMember <- withStore $ \db -> updateUnknownMemberAnnounced db vr user m unknownMember memInfo toView $ CRUnknownMemberAnnounced user gInfo m unknownMember updatedMember memberAnnouncedToView updatedMember Right _ -> messageError "x.grp.mem.new error: member already exists" @@ -5408,7 +5404,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = xGrpMemIntro gInfo@GroupInfo {chatSettings} m@GroupMember {memberRole, localDisplayName = c} memInfo@(MemberInfo memId _ memChatVRange _) memRestrictions = do case memberCategory m of GCHostMember -> - withStore' (\db -> runExceptT $ getGroupMemberByMemberId db user gInfo memId) >>= \case + withStore' (\db -> runExceptT $ getGroupMemberByMemberId db vr user gInfo memId) >>= \case Right _ -> messageError "x.grp.mem.intro ignored: member already exists" Left _ -> do when (memberRole < GRAdmin) $ throwChatError (CEGroupContactRole c) @@ -5421,7 +5417,8 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = | maxVersion mcvr >= groupDirectInvVersion -> pure Nothing | otherwise -> Just <$> createConn subMode let customUserProfileId = localProfileId <$> incognitoMembershipProfile gInfo - chatV = (vr `compatibleChatVersion` ) . fromChatVRange =<< memChatVRange + vr' = vr PQSupportOff + chatV = maybe (minVersion vr') (\peerVR -> vr' `peerConnChatVersion` fromChatVRange peerVR) memChatVRange void $ withStore $ \db -> createIntroReMember db user gInfo m chatV memInfo memRestrictions groupConnIds directConnIds customUserProfileId subMode _ -> messageError "x.grp.mem.intro can be only sent by host member" where @@ -5429,7 +5426,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = sendXGrpMemInv :: Int64 -> Maybe ConnReqInvitation -> XGrpMemIntroCont -> m () sendXGrpMemInv hostConnId directConnReq XGrpMemIntroCont {groupId, groupMemberId, memberId, groupConnReq} = do - hostConn <- withStore $ \db -> getConnectionById db user hostConnId + hostConn <- withStore $ \db -> getConnectionById db vr user hostConnId let msg = XGrpMemInv memberId IntroInvitation {groupConnReq, directConnReq} void $ sendDirectMemberMessage hostConn msg groupId withStore' $ \db -> updateGroupMemberStatusById db userId groupMemberId GSMemIntroInvited @@ -5438,7 +5435,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = xGrpMemInv gInfo@GroupInfo {groupId} m memId introInv = do case memberCategory m of GCInviteeMember -> - withStore' (\db -> runExceptT $ getGroupMemberByMemberId db user gInfo memId) >>= \case + withStore' (\db -> runExceptT $ getGroupMemberByMemberId db vr user gInfo memId) >>= \case Left _ -> messageError "x.grp.mem.inv error: referenced member does not exist" Right reMember -> do GroupMemberIntro {introId} <- withStore $ \db -> saveIntroInvitation db reMember m introInv @@ -5452,7 +5449,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = let GroupMember {memberId = membershipMemId} = membership checkHostRole m memRole toMember <- - withStore' (\db -> runExceptT $ getGroupMemberByMemberId db user gInfo memId) >>= \case + withStore' (\db -> runExceptT $ getGroupMemberByMemberId db vr user gInfo memId) >>= \case -- TODO if the missed messages are correctly sent as soon as there is connection before anything else is sent -- the situation when member does not exist is an error -- member receiving x.grp.mem.fwd should have also received x.grp.mem.new prior to that. @@ -5469,7 +5466,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = directConnIds <- forM directConnReq $ \dcr -> joinAgentConnectionAsync user True dcr dm subMode let customUserProfileId = localProfileId <$> incognitoMembershipProfile gInfo mcvr = maybe chatInitialVRange fromChatVRange memChatVRange - chatV = vr `compatibleChatVersion` mcvr + chatV = vr PQSupportOff `peerConnChatVersion` mcvr withStore' $ \db -> createIntroToMemberContact db user m toMember chatV mcvr groupConnIds directConnIds customUserProfileId subMode xGrpMemRole :: GroupInfo -> GroupMember -> MemberId -> GroupMemberRole -> RcvMessage -> UTCTime -> m () @@ -5478,7 +5475,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = let gInfo' = gInfo {membership = membership {memberRole = memRole}} in changeMemberRole gInfo' membership $ RGEUserRole memRole | otherwise = - withStore' (\db -> runExceptT $ getGroupMemberByMemberId db user gInfo memId) >>= \case + withStore' (\db -> runExceptT $ getGroupMemberByMemberId db vr user gInfo memId) >>= \case Right member -> changeMemberRole gInfo member $ RGEMemberRole (groupMemberId' member) (fromLocalProfile $ memberProfile member) memRole Left _ -> messageError "x.grp.mem.role with unknown member ID" where @@ -5507,7 +5504,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = -- member shouldn't receive this message about themselves messageError "x.grp.mem.restrict: admin blocks you" | otherwise = - withStore' (\db -> runExceptT $ getGroupMemberByMemberId db user gInfo memId) >>= \case + withStore' (\db -> runExceptT $ getGroupMemberByMemberId db vr user gInfo memId) >>= \case Right bm@GroupMember {groupMemberId = bmId, memberRole, memberProfile = bmp} | senderRole < GRAdmin || senderRole < memberRole -> messageError "x.grp.mem.restrict with insufficient member permissions" | otherwise -> do @@ -5526,12 +5523,12 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = setMemberBlocked bmId = withStore $ \db -> do liftIO $ updateGroupMemberBlocked db user groupId bmId restriction - getGroupMember db user groupId bmId + getGroupMember db vr user groupId bmId blocked = mrsBlocked restriction xGrpMemCon :: GroupInfo -> GroupMember -> MemberId -> m () xGrpMemCon gInfo sendingMember memId = do - refMember <- withStore $ \db -> getGroupMemberByMemberId db user gInfo memId + refMember <- withStore $ \db -> getGroupMemberByMemberId db vr user gInfo memId case (memberCategory sendingMember, memberCategory refMember) of (GCInviteeMember, GCInviteeMember) -> withStore' (\db -> runExceptT $ getIntroduction db refMember sendingMember) >>= \case @@ -5575,13 +5572,13 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = then checkRole membership $ do deleteGroupLinkIfExists user gInfo -- member records are not deleted to keep history - members <- withStore' $ \db -> getGroupMembers db user gInfo + members <- withStore' $ \db -> getGroupMembers db vr user gInfo deleteMembersConnections user members withStore' $ \db -> updateGroupMemberStatus db userId membership GSMemRemoved deleteMemberItem RGEUserDeleted toView $ CRDeletedMemberUser user gInfo {membership = membership {memberStatus = GSMemRemoved}} m else - withStore' (\db -> runExceptT $ getGroupMemberByMemberId db user gInfo memId) >>= \case + withStore' (\db -> runExceptT $ getGroupMemberByMemberId db vr user gInfo memId) >>= \case Left _ -> messageError "x.grp.mem.del with unknown member ID" Right member@GroupMember {groupMemberId, memberProfile} -> checkRole member $ do @@ -5613,7 +5610,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = xGrpDel gInfo@GroupInfo {membership} m@GroupMember {memberRole} msg brokerTs = do when (memberRole /= GROwner) $ throwChatError $ CEGroupUserRole gInfo GROwner ms <- withStore' $ \db -> do - members <- getGroupMembers db user gInfo + members <- getGroupMembers db vr user gInfo updateGroupMemberStatus db userId membership GSMemGroupDeleted pure members -- member records are not deleted to keep history @@ -5642,7 +5639,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = case memberContactId of Nothing -> createNewContact subMode Just mContactId -> do - mCt <- withStore $ \db -> getContact db user mContactId + mCt <- withStore $ \db -> getContact db vr user mContactId let Contact {activeConn, contactGrpInvSent} = mCt forM_ activeConn $ \Connection {connId} -> if contactGrpInvSent @@ -5685,7 +5682,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = xGrpMsgForward :: GroupInfo -> GroupMember -> MemberId -> ChatMessage 'Json -> UTCTime -> m () xGrpMsgForward gInfo@GroupInfo {groupId} m@GroupMember {memberRole, localDisplayName} memberId msg msgTs = do when (memberRole < GRAdmin) $ throwChatError (CEGroupContactRole localDisplayName) - withStore' (\db -> runExceptT $ getGroupMemberByMemberId db user gInfo memberId) >>= \case + withStore' (\db -> runExceptT $ getGroupMemberByMemberId db vr user gInfo memberId) >>= \case Right author -> processForwardedMsg author msg Left (SEGroupMemberNotFoundByMemberId _) -> do unknownAuthor <- createUnknownMember gInfo memberId @@ -5846,13 +5843,11 @@ updateMemberChatVRange mem@GroupMember {groupMemberId} conn@Connection {connId, pure (mem {memberChatVRange = msgVRange, activeConn = Just conn'}, conn') else pure (mem, conn) -upgradedConnVersion :: ChatMonad' m => PQSupport -> Maybe VersionChat -> VersionRangeChat -> m (Maybe VersionChat) -upgradedConnVersion pqSup v_ vr = do - v_' <- pqCompatibleVersion pqSup vr - pure $ case (v_, v_') of - (Just v, Just v') -> Just $ max v v' - (Nothing, v'@Just {}) -> v' - (v, Nothing) -> v +upgradedConnVersion :: ChatMonad' m => PQSupport -> VersionChat -> VersionRangeChat -> m VersionChat +upgradedConnVersion pqSup v peerVR = do + vr <- chatVersionRange + -- don't allow reducing agreed connection version + pure $ maybe v (\(Compatible v') -> max v v') $ vr pqSup `compatibleVersion` peerVR parseFileDescription :: (ChatMonad m, FilePartyI p) => Text -> m (ValidFileDescription p) parseFileDescription = @@ -5894,7 +5889,7 @@ parseChatMessage conn s = do sendFileChunk :: ChatMonad m => User -> SndFileTransfer -> m () sendFileChunk user ft@SndFileTransfer {fileId, fileStatus, agentConnId = AgentConnId acId} = unless (fileStatus == FSComplete || fileStatus == FSCancelled) $ do - vr <- chatVersionRange PQSupportOff + vr <- chatVersionRange withStore' (`createSndFileChunk` ft) >>= \case Just chunkNo -> sendFileChunkNo ft chunkNo Nothing -> do @@ -6017,7 +6012,8 @@ cancelSndFileTransfer user@User {userId} ft@SndFileTransfer {fileId, connId, age deleteSndFileChunks db ft when sendCancel $ case fileInline of Just _ -> do - (sharedMsgId, conn) <- withStore $ \db -> (,) <$> getSharedMsgIdByFileId db userId fileId <*> getConnectionById db user connId + vr <- chatVersionRange + (sharedMsgId, conn) <- withStore $ \db -> (,) <$> getSharedMsgIdByFileId db userId fileId <*> getConnectionById db vr user connId void $ sendDirectMessage_ conn PQSupportOff (BFileChunk sharedMsgId FileChunkCancel) (ConnectionId connId) _ -> withAgent $ \a -> void . sendMessage a acId PQEncOff SMP.noMsgFlags $ smpEncode FileChunkCancel pure fileConnId @@ -6096,7 +6092,7 @@ createSndMessage chatMsgEvent connOrGroupId pqSup = createSndMessages :: forall e m t. (MsgEncodingI e, ChatMonad' m, Traversable t) => t (ConnOrGroupId, PQSupport, ChatMsgEvent e) -> m (t (Either ChatError SndMessage)) createSndMessages idsEvents = do g <- asks random - ChatConfig {chatVRange = vr} <- asks config + vr <- chatVersionRange withStoreBatch $ \db -> fmap (createMsg db g vr) idsEvents where createMsg :: DB.Connection -> TVar ChaChaDRG -> (PQSupport -> VersionRangeChat) -> (ConnOrGroupId, PQSupport, ChatMsgEvent e) -> IO (Either ChatError SndMessage) @@ -6147,17 +6143,17 @@ batchSndMessagesJSON = batchMessages maxRawMsgLength . L.toList encodeConnInfo :: (MsgEncodingI e, ChatMonad m) => ChatMsgEvent e -> m ByteString encodeConnInfo chatMsgEvent = do - vr <- chatVersionRange PQSupportOff - encodeConnInfoPQ PQSupportOff (Just $ maxVersion vr) chatMsgEvent + vr <- chatVersionRange + encodeConnInfoPQ PQSupportOff (maxVersion $ vr PQSupportOff) chatMsgEvent -- TODO PQ check size after compression (in compressedBatchMsgBody_ ?) -encodeConnInfoPQ :: (MsgEncodingI e, ChatMonad m) => PQSupport -> Maybe VersionChat -> ChatMsgEvent e -> m ByteString +encodeConnInfoPQ :: (MsgEncodingI e, ChatMonad m) => PQSupport -> VersionChat -> ChatMsgEvent e -> m ByteString encodeConnInfoPQ pqSup v chatMsgEvent = do - chatVRange <- chatVersionRange pqSup - let msg = ChatMessage {chatVRange, msgId = Nothing, chatMsgEvent} + vr <- chatVersionRange + let msg = ChatMessage {chatVRange = vr pqSup, msgId = Nothing, chatMsgEvent} case encodeChatMessage maxConnInfoLength msg of ECMEncoded encodedBody -> case pqSup of - PQSupportOn | maybe False (>= pqEncryptionCompressionVersion) v -> liftIO $ compressedBatchMsgBody encodedBody + PQSupportOn | v >= pqEncryptionCompressionVersion -> liftIO $ compressedBatchMsgBody encodedBody _ -> pure encodedBody ECMLarge -> throwChatError $ CEException "large message" where @@ -6189,7 +6185,7 @@ deliverMessagesB msgReqs = do where compressBodies = liftIO $ withCompressCtx (toEnum maxRawMsgLength) $ \cctx -> do forME msgReqs $ \mr@(conn@Connection {pqSupport, connChatVersion}, msgFlags, msgBody, msgId) -> Right <$> case pqSupport of - PQSupportOn | maybe False (>= pqEncryptionCompressionVersion) connChatVersion -> + PQSupportOn | connChatVersion >= pqEncryptionCompressionVersion -> (\cBody -> (conn, msgFlags, cBody, msgId)) <$> compressedBatchMsgBody_ cctx msgBody _ -> pure mr toAgent = \case @@ -6337,7 +6333,8 @@ saveGroupRcvMsg user groupId authorMember conn@Connection {connId} agentMsgMeta withStore (\db -> createNewMessageAndRcvMsgDelivery db (GroupId groupId) newMsg sharedMsgId_ rcvMsgDelivery $ Just amGroupMemId) `catchChatError` \e -> case e of ChatErrorStore (SEDuplicateGroupMessage _ _ _ (Just forwardedByGroupMemberId)) -> do - fm <- withStore $ \db -> getGroupMember db user groupId forwardedByGroupMemberId + vr <- chatVersionRange + fm <- withStore $ \db -> getGroupMember db vr user groupId forwardedByGroupMemberId forM_ (memberConn fm) $ \fmConn -> void $ sendDirectMemberMessage fmConn (XGrpMemCon amMemId) groupId throwError e @@ -6352,7 +6349,8 @@ saveGroupFwdRcvMsg user groupId forwardingMember refAuthorMember@GroupMember {me withStore (\db -> createNewRcvMessage db (GroupId groupId) newMsg sharedMsgId_ refAuthorId fwdMemberId) `catchChatError` \e -> case e of ChatErrorStore (SEDuplicateGroupMessage _ _ (Just authorGroupMemberId) Nothing) -> do - am@GroupMember {memberId = amMemberId} <- withStore $ \db -> getGroupMember db user groupId authorGroupMemberId + vr <- chatVersionRange + am@GroupMember {memberId = amMemberId} <- withStore $ \db -> getGroupMember db vr user groupId authorGroupMemberId if sameMemberId refMemberId am then forM_ (memberConn forwardingMember) $ \fmConn -> void $ sendDirectMemberMessage fmConn (XGrpMemCon amMemberId) groupId @@ -6467,7 +6465,7 @@ allowAgentConnectionAsync user conn@Connection {connId, pqSupport, connChatVersi withAgent $ \a -> allowConnectionAsync a (aCorrId cmdId) (aConnId conn) confId dm withStore' $ \db -> updateConnectionStatus db conn ConnAccepted -agentAcceptContactAsync :: (MsgEncodingI e, ChatMonad m) => User -> Bool -> InvitationId -> ChatMsgEvent e -> SubscriptionMode -> PQSupport -> Maybe VersionChat -> m (CommandId, ConnId) +agentAcceptContactAsync :: (MsgEncodingI e, ChatMonad m) => User -> Bool -> InvitationId -> ChatMsgEvent e -> SubscriptionMode -> PQSupport -> VersionChat -> m (CommandId, ConnId) agentAcceptContactAsync user enableNtfs invId msg subMode pqSup chatV = do cmdId <- withStore' $ \db -> createCommand db user Nothing CFAcceptContact dm <- encodeConnInfoPQ pqSup chatV msg @@ -6705,16 +6703,11 @@ waitChatStartedAndActivated = do activated <- readTVar chatActivated unless (isJust started && activated) retry -chatVersionRange :: ChatMonad' m => PQSupport -> m VersionRangeChat -chatVersionRange pq = do +chatVersionRange :: ChatMonad' m => m (PQSupport -> VersionRangeChat) +chatVersionRange = do ChatConfig {chatVRange} <- asks config - pure $ chatVRange pq - -compatibleChatVersion :: VersionRangeChat -> VersionRangeChat -> Maybe VersionChat -compatibleChatVersion vr vr' = (\(Compatible v) -> v) <$> (vr `compatibleVersion` vr') - -pqCompatibleVersion :: ChatMonad' m => PQSupport -> VersionRangeChat -> m (Maybe VersionChat) -pqCompatibleVersion pq vr' = (`compatibleChatVersion` vr') <$> chatVersionRange pq + pure chatVRange +{-# INLINE chatVersionRange #-} chatCommandP :: Parser ChatCommand chatCommandP = diff --git a/src/Simplex/Chat/Store/Connections.hs b/src/Simplex/Chat/Store/Connections.hs index 3bb4f3bf45..f8e9fa3401 100644 --- a/src/Simplex/Chat/Store/Connections.hs +++ b/src/Simplex/Chat/Store/Connections.hs @@ -34,9 +34,10 @@ import Simplex.Chat.Types.Preferences 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.Crypto.Ratchet (PQSupport) import Simplex.Messaging.Util (eitherToMaybe) -getConnectionEntity :: DB.Connection -> VersionRangeChat -> User -> AgentConnId -> ExceptT StoreError IO ConnectionEntity +getConnectionEntity :: DB.Connection -> (PQSupport -> VersionRangeChat) -> User -> AgentConnId -> ExceptT StoreError IO ConnectionEntity getConnectionEntity db vr user@User {userId, userContactId} agentConnId = do c@Connection {connType, entityId} <- getConnection_ case entityId of @@ -54,7 +55,7 @@ getConnectionEntity db vr user@User {userId, userContactId} agentConnId = do where getConnection_ :: ExceptT StoreError IO Connection getConnection_ = ExceptT $ do - firstRow toConnection (SEConnectionNotFound agentConnId) $ + firstRow (toConnection vr) (SEConnectionNotFound agentConnId) $ DB.query db [sql| @@ -157,7 +158,7 @@ getConnectionEntity db vr user@User {userId, userContactId} agentConnId = do userContact_ [(cReq, groupId)] = Right UserContact {userContactLinkId, connReqContact = cReq, groupId} userContact_ _ = Left SEUserContactLinkNotFound -getConnectionEntityByConnReq :: DB.Connection -> VersionRangeChat -> User -> (ConnReqInvitation, ConnReqInvitation) -> IO (Maybe ConnectionEntity) +getConnectionEntityByConnReq :: DB.Connection -> (PQSupport -> VersionRangeChat) -> User -> (ConnReqInvitation, ConnReqInvitation) -> IO (Maybe ConnectionEntity) getConnectionEntityByConnReq db vr user@User {userId} (cReqSchema1, cReqSchema2) = do connId_ <- maybeFirstRow fromOnly $ @@ -168,7 +169,7 @@ getConnectionEntityByConnReq db vr user@User {userId} (cReqSchema1, cReqSchema2) -- multiple connections can have same via_contact_uri_hash if request was repeated; -- this function searches for latest connection with contact so that "known contact" plan would be chosen; -- deleted connections are filtered out to allow re-connecting via same contact address -getContactConnEntityByConnReqHash :: DB.Connection -> VersionRangeChat -> User -> (ConnReqUriHash, ConnReqUriHash) -> IO (Maybe ConnectionEntity) +getContactConnEntityByConnReqHash :: DB.Connection -> (PQSupport -> VersionRangeChat) -> User -> (ConnReqUriHash, ConnReqUriHash) -> IO (Maybe ConnectionEntity) getContactConnEntityByConnReqHash db vr user@User {userId} (cReqHash1, cReqHash2) = do connId_ <- maybeFirstRow fromOnly $ @@ -188,7 +189,7 @@ getContactConnEntityByConnReqHash db vr user@User {userId} (cReqHash1, cReqHash2 (userId, cReqHash1, cReqHash2, ConnDeleted) maybe (pure Nothing) (fmap eitherToMaybe . runExceptT . getConnectionEntity db vr user) connId_ -getConnectionsToSubscribe :: DB.Connection -> VersionRangeChat -> IO ([ConnId], [ConnectionEntity]) +getConnectionsToSubscribe :: DB.Connection -> (PQSupport -> VersionRangeChat) -> 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 diff --git a/src/Simplex/Chat/Store/Direct.hs b/src/Simplex/Chat/Store/Direct.hs index d3806fe34c..47174a59a6 100644 --- a/src/Simplex/Chat/Store/Direct.hs +++ b/src/Simplex/Chat/Store/Direct.hs @@ -125,11 +125,11 @@ deletePendingContactConnection db userId connId = |] (userId, connId, ConnContact) -createAddressContactConnection :: DB.Connection -> User -> Contact -> ConnId -> ConnReqUriHash -> XContactId -> Maybe Profile -> SubscriptionMode -> VersionChat -> PQSupport -> ExceptT StoreError IO Contact -createAddressContactConnection db user@User {userId} Contact {contactId} acId cReqHash xContactId incognitoProfile subMode chatV pqSup = do +createAddressContactConnection :: DB.Connection -> (PQSupport -> VersionRangeChat) -> User -> Contact -> ConnId -> ConnReqUriHash -> XContactId -> Maybe Profile -> SubscriptionMode -> VersionChat -> PQSupport -> ExceptT StoreError IO Contact +createAddressContactConnection db vr user@User {userId} Contact {contactId} acId cReqHash xContactId incognitoProfile subMode chatV pqSup = do PendingContactConnection {pccConnId} <- liftIO $ createConnReqConnection db userId acId cReqHash xContactId incognitoProfile Nothing subMode chatV pqSup liftIO $ DB.execute db "UPDATE connections SET contact_id = ? WHERE connection_id = ?" (contactId, pccConnId) - getContact db user contactId + getContact db vr user contactId createConnReqConnection :: DB.Connection -> UserId -> ConnId -> ConnReqUriHash -> XContactId -> Maybe Profile -> Maybe GroupLinkId -> SubscriptionMode -> VersionChat -> PQSupport -> IO PendingContactConnection createConnReqConnection db userId acId cReqHash xContactId incognitoProfile groupLinkId subMode chatV pqSup = do @@ -152,9 +152,9 @@ createConnReqConnection db userId acId cReqHash xContactId incognitoProfile grou pccConnId <- insertedRowId db pure PendingContactConnection {pccConnId, pccAgentConnId = AgentConnId acId, pccConnStatus, viaContactUri = True, viaUserContactLink = Nothing, groupLinkId, customUserProfileId, connReqInv = Nothing, localAlias = "", createdAt, updatedAt = createdAt} -getConnReqContactXContactId :: DB.Connection -> User -> ConnReqUriHash -> IO (Maybe Contact, Maybe XContactId) -getConnReqContactXContactId db user@User {userId} cReqHash = do - getContactByConnReqHash db user cReqHash >>= \case +getConnReqContactXContactId :: DB.Connection -> (PQSupport -> VersionRangeChat) -> User -> ConnReqUriHash -> IO (Maybe Contact, Maybe XContactId) +getConnReqContactXContactId db vr user@User {userId} cReqHash = do + getContactByConnReqHash db vr user cReqHash >>= \case c@(Just _) -> pure (c, Nothing) Nothing -> (Nothing,) <$> getXContactId where @@ -166,9 +166,9 @@ getConnReqContactXContactId db user@User {userId} cReqHash = do "SELECT xcontact_id FROM connections WHERE user_id = ? AND via_contact_uri_hash = ? LIMIT 1" (userId, cReqHash) -getContactByConnReqHash :: DB.Connection -> User -> ConnReqUriHash -> IO (Maybe Contact) -getContactByConnReqHash db user@User {userId} cReqHash = - maybeFirstRow (toContact user) $ +getContactByConnReqHash :: DB.Connection -> (PQSupport -> VersionRangeChat) -> User -> ConnReqUriHash -> IO (Maybe Contact) +getContactByConnReqHash db vr user@User {userId} cReqHash = + maybeFirstRow (toContact vr user) $ DB.query db [sql| @@ -278,13 +278,13 @@ setContactDeleted db user@User {userId} ct@Contact {contactId} = do currentTs <- getCurrentTime DB.execute db "UPDATE contacts SET deleted = 1, updated_at = ? WHERE user_id = ? AND contact_id = ?" (currentTs, userId, contactId) -getDeletedContacts :: DB.Connection -> User -> IO [Contact] -getDeletedContacts db user@User {userId} = do +getDeletedContacts :: DB.Connection -> (PQSupport -> VersionRangeChat) -> User -> IO [Contact] +getDeletedContacts db vr user@User {userId} = do contactIds <- map fromOnly <$> DB.query db "SELECT contact_id FROM contacts WHERE user_id = ? AND deleted = 1" (Only userId) - rights <$> mapM (runExceptT . getDeletedContact db user) contactIds + rights <$> mapM (runExceptT . getDeletedContact db vr user) contactIds -getDeletedContact :: DB.Connection -> User -> Int64 -> ExceptT StoreError IO Contact -getDeletedContact db user contactId = getContact_ db user contactId True +getDeletedContact :: DB.Connection -> (PQSupport -> VersionRangeChat) -> User -> Int64 -> ExceptT StoreError IO Contact +getDeletedContact db vr user contactId = getContact_ db vr user contactId True deleteContactProfile_ :: DB.Connection -> UserId -> ContactId -> IO () deleteContactProfile_ db userId contactId = @@ -520,19 +520,19 @@ updateContactLDN_ db user@User {userId} contactId displayName newName updatedAt (newName, updatedAt, userId, contactId) safeDeleteLDN db user displayName -getContactByName :: DB.Connection -> User -> ContactName -> ExceptT StoreError IO Contact -getContactByName db user localDisplayName = do +getContactByName :: DB.Connection -> (PQSupport -> VersionRangeChat) -> User -> ContactName -> ExceptT StoreError IO Contact +getContactByName db vr user localDisplayName = do cId <- getContactIdByName db user localDisplayName - getContact db user cId + getContact db vr user cId -getUserContacts :: DB.Connection -> User -> IO [Contact] -getUserContacts db user@User {userId} = do +getUserContacts :: DB.Connection -> (PQSupport -> VersionRangeChat) -> User -> IO [Contact] +getUserContacts db vr user@User {userId} = do contactIds <- map fromOnly <$> DB.query db "SELECT contact_id FROM contacts WHERE user_id = ? AND deleted = 0" (Only userId) - contacts <- rights <$> mapM (runExceptT . getContact db user) contactIds + contacts <- rights <$> mapM (runExceptT . getContact db vr user) contactIds pure $ filter (\Contact {activeConn} -> isJust activeConn) contacts -createOrUpdateContactRequest :: DB.Connection -> User -> Int64 -> InvitationId -> VersionRangeChat -> Profile -> Maybe XContactId -> PQSupport -> ExceptT StoreError IO ContactOrRequest -createOrUpdateContactRequest db user@User {userId} userContactLinkId invId (VersionRange minV maxV) Profile {displayName, fullName, image, contactLink, preferences} xContactId_ pqSup = +createOrUpdateContactRequest :: DB.Connection -> (PQSupport -> VersionRangeChat) -> User -> Int64 -> InvitationId -> VersionRangeChat -> Profile -> Maybe XContactId -> PQSupport -> ExceptT StoreError IO ContactOrRequest +createOrUpdateContactRequest db vr user@User {userId} userContactLinkId invId (VersionRange minV maxV) Profile {displayName, fullName, image, contactLink, preferences} xContactId_ pqSup = liftIO (maybeM getContact' xContactId_) >>= \case Just contact -> pure $ CORContact contact Nothing -> CORRequest <$> createOrUpdate_ @@ -571,7 +571,7 @@ createOrUpdateContactRequest db user@User {userId} userContactLinkId invId (Vers insertedRowId db getContact' :: XContactId -> IO (Maybe Contact) getContact' xContactId = - maybeFirstRow (toContact user) $ + maybeFirstRow (toContact vr user) $ DB.query db [sql| @@ -709,7 +709,7 @@ deleteContactRequest db User {userId} contactRequestId = do (userId, userId, contactRequestId, userId) DB.execute db "DELETE FROM contact_requests WHERE user_id = ? AND contact_request_id = ?" (userId, contactRequestId) -createAcceptedContact :: DB.Connection -> User -> ConnId -> Maybe VersionChat -> VersionRangeChat -> ContactName -> ProfileId -> Profile -> Int64 -> Maybe XContactId -> Maybe IncognitoProfile -> SubscriptionMode -> PQSupport -> Bool -> IO Contact +createAcceptedContact :: DB.Connection -> User -> ConnId -> VersionChat -> VersionRangeChat -> ContactName -> ProfileId -> Profile -> Int64 -> Maybe XContactId -> Maybe IncognitoProfile -> SubscriptionMode -> PQSupport -> Bool -> IO Contact createAcceptedContact db user@User {userId, profile = LocalProfile {preferences}} agentConnId connChatVersion cReqChatVRange localDisplayName profileId profile userContactLinkId xContactId incognitoProfile subMode pqSup contactUsed = do DB.execute db "DELETE FROM contact_requests WHERE user_id = ? AND local_display_name = ?" (userId, localDisplayName) createdAt <- getCurrentTime @@ -731,12 +731,12 @@ getContactIdByName db User {userId} cName = ExceptT . firstRow fromOnly (SEContactNotFoundByName cName) $ DB.query db "SELECT contact_id FROM contacts WHERE user_id = ? AND local_display_name = ? AND deleted = 0" (userId, cName) -getContact :: DB.Connection -> User -> Int64 -> ExceptT StoreError IO Contact -getContact db user contactId = getContact_ db user contactId False +getContact :: DB.Connection -> (PQSupport -> VersionRangeChat) -> User -> Int64 -> ExceptT StoreError IO Contact +getContact db vr user contactId = getContact_ db vr user contactId False -getContact_ :: DB.Connection -> User -> Int64 -> Bool -> ExceptT StoreError IO Contact -getContact_ db user@User {userId} contactId deleted = - ExceptT . firstRow (toContact user) (SEContactNotFound contactId) $ +getContact_ :: DB.Connection -> (PQSupport -> VersionRangeChat) -> User -> Int64 -> Bool -> ExceptT StoreError IO Contact +getContact_ db vr user@User {userId} contactId deleted = + ExceptT . firstRow (toContact vr user) (SEContactNotFound contactId) $ DB.query db [sql| @@ -790,8 +790,8 @@ getPendingContactConnections db User {userId} = do |] [":user_id" := userId, ":conn_type" := ConnContact] -getContactConnections :: DB.Connection -> UserId -> Contact -> IO [Connection] -getContactConnections db userId Contact {contactId} = +getContactConnections :: DB.Connection -> (PQSupport -> VersionRangeChat) -> UserId -> Contact -> IO [Connection] +getContactConnections db vr userId Contact {contactId} = connections =<< liftIO getConnections_ where getConnections_ = @@ -808,11 +808,11 @@ getContactConnections db userId Contact {contactId} = |] (userId, userId, contactId) connections [] = pure [] - connections rows = pure $ map toConnection rows + connections rows = pure $ map (toConnection vr) rows -getConnectionById :: DB.Connection -> User -> Int64 -> ExceptT StoreError IO Connection -getConnectionById db User {userId} connId = ExceptT $ do - firstRow toConnection (SEConnectionNotFoundById connId) $ +getConnectionById :: DB.Connection -> (PQSupport -> VersionRangeChat) -> User -> Int64 -> ExceptT StoreError IO Connection +getConnectionById db vr User {userId} connId = ExceptT $ do + firstRow (toConnection vr) (SEConnectionNotFoundById connId) $ DB.query db [sql| diff --git a/src/Simplex/Chat/Store/Files.hs b/src/Simplex/Chat/Store/Files.hs index 0965150605..e77681bb9b 100644 --- a/src/Simplex/Chat/Store/Files.hs +++ b/src/Simplex/Chat/Store/Files.hs @@ -116,6 +116,7 @@ import Simplex.Messaging.Crypto.File (CryptoFile (..), CryptoFileArgs (..)) import qualified Simplex.Messaging.Crypto.File as CF import Simplex.Messaging.Crypto.Ratchet as CR import Simplex.Messaging.Protocol (SubscriptionMode (..)) +import Simplex.Messaging.Version import System.FilePath (takeFileName) getLiveSndFileTransfers :: DB.Connection -> User -> IO [SndFileTransfer] @@ -173,10 +174,10 @@ getPendingSndChunks db fileId connId = |] (fileId, connId) -createSndDirectFTConnection :: DB.Connection -> User -> Int64 -> (CommandId, ConnId) -> SubscriptionMode -> IO () -createSndDirectFTConnection db user@User {userId} fileId (cmdId, acId) subMode = do +createSndDirectFTConnection :: DB.Connection -> (PQSupport -> VersionRangeChat) -> User -> Int64 -> (CommandId, ConnId) -> SubscriptionMode -> IO () +createSndDirectFTConnection db vr user@User {userId} fileId (cmdId, acId) subMode = do currentTs <- getCurrentTime - Connection {connId} <- createSndFileConnection_ db userId fileId acId subMode + Connection {connId} <- createSndFileConnection_ db vr userId fileId acId subMode setCommandConnId db user cmdId connId DB.execute db @@ -193,10 +194,10 @@ createSndGroupFileTransfer db userId GroupInfo {groupId} filePath FileInvitation fileId <- insertedRowId db pure FileTransferMeta {fileId, xftpSndFile = Nothing, xftpRedirectFor = Nothing, fileName, filePath, fileSize, fileInline, chunkSize, cancelled = False} -createSndGroupFileTransferConnection :: DB.Connection -> User -> Int64 -> (CommandId, ConnId) -> GroupMember -> SubscriptionMode -> IO () -createSndGroupFileTransferConnection db user@User {userId} fileId (cmdId, acId) GroupMember {groupMemberId} subMode = do +createSndGroupFileTransferConnection :: DB.Connection -> (PQSupport -> VersionRangeChat) -> User -> Int64 -> (CommandId, ConnId) -> GroupMember -> SubscriptionMode -> IO () +createSndGroupFileTransferConnection db vr user@User {userId} fileId (cmdId, acId) GroupMember {groupMemberId} subMode = do currentTs <- getCurrentTime - Connection {connId} <- createSndFileConnection_ db userId fileId acId subMode + Connection {connId} <- createSndFileConnection_ db vr userId fileId acId subMode setCommandConnId db user cmdId connId DB.execute db @@ -429,11 +430,10 @@ lookupChatRefByFileId db User {userId} fileId = (userId, fileId) -- TODO v6.0 remove -createSndFileConnection_ :: DB.Connection -> UserId -> Int64 -> ConnId -> SubscriptionMode -> IO Connection -createSndFileConnection_ db userId fileId agentConnId subMode = do +createSndFileConnection_ :: DB.Connection -> (PQSupport -> VersionRangeChat) -> UserId -> Int64 -> ConnId -> SubscriptionMode -> IO Connection +createSndFileConnection_ db vr userId fileId agentConnId subMode = do currentTs <- getCurrentTime - -- TODO PQ use range from minVersion of the current range? - createConnection_ db userId ConnSndFile (Just fileId) agentConnId (Just initialChatVersion) chatInitialVRange Nothing Nothing Nothing 0 currentTs subMode CR.PQSupportOff + createConnection_ db userId ConnSndFile (Just fileId) agentConnId (minVersion $ vr PQSupportOff) chatInitialVRange Nothing Nothing Nothing 0 currentTs subMode CR.PQSupportOff updateSndFileStatus :: DB.Connection -> SndFileTransfer -> FileStatus -> IO () updateSndFileStatus db SndFileTransfer {fileId, connId} status = do @@ -695,7 +695,7 @@ getRcvFileTransfer_ db userId fileId = do _ -> pure Nothing cancelled = fromMaybe False cancelled_ -acceptRcvFileTransfer :: DB.Connection -> VersionRangeChat -> User -> Int64 -> (CommandId, ConnId) -> ConnStatus -> FilePath -> SubscriptionMode -> ExceptT StoreError IO AChatItem +acceptRcvFileTransfer :: DB.Connection -> (PQSupport -> VersionRangeChat) -> 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 @@ -707,16 +707,16 @@ acceptRcvFileTransfer db vr user@User {userId} fileId (cmdId, acId) connStatus f setCommandConnId db user cmdId connId runExceptT $ getChatItemByFileId db vr user fileId -getContactByFileId :: DB.Connection -> User -> FileTransferId -> ExceptT StoreError IO Contact -getContactByFileId db user@User {userId} fileId = do +getContactByFileId :: DB.Connection -> (PQSupport -> VersionRangeChat) -> User -> FileTransferId -> ExceptT StoreError IO Contact +getContactByFileId db vr user@User {userId} fileId = do cId <- getContactIdByFileId - getContact db user cId + getContact db vr user cId where getContactIdByFileId = ExceptT . firstRow fromOnly (SEContactNotFoundByFileId fileId) $ DB.query db "SELECT contact_id FROM files WHERE user_id = ? AND file_id = ?" (userId, fileId) -acceptRcvInlineFT :: DB.Connection -> VersionRangeChat -> User -> FileTransferId -> FilePath -> ExceptT StoreError IO AChatItem +acceptRcvInlineFT :: DB.Connection -> (PQSupport -> VersionRangeChat) -> 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 vr user fileId @@ -725,7 +725,7 @@ startRcvInlineFT :: DB.Connection -> User -> RcvFileTransfer -> FilePath -> Mayb startRcvInlineFT db user RcvFileTransfer {fileId} filePath rcvFileInline = acceptRcvFT_ db user fileId filePath rcvFileInline =<< getCurrentTime -xftpAcceptRcvFT :: DB.Connection -> VersionRangeChat -> User -> FileTransferId -> FilePath -> ExceptT StoreError IO AChatItem +xftpAcceptRcvFT :: DB.Connection -> (PQSupport -> VersionRangeChat) -> User -> FileTransferId -> FilePath -> ExceptT StoreError IO AChatItem xftpAcceptRcvFT db vr user fileId filePath = do liftIO $ acceptRcvFT_ db user fileId filePath Nothing =<< getCurrentTime getChatItemByFileId db vr user fileId @@ -1000,7 +1000,7 @@ getLocalCryptoFile db userId fileId sent = pure $ CryptoFile filePath fileCryptoArgs _ -> throwError $ SEFileNotFound fileId -updateDirectCIFileStatus :: forall d. MsgDirectionI d => DB.Connection -> VersionRangeChat -> User -> Int64 -> CIFileStatus d -> ExceptT StoreError IO AChatItem +updateDirectCIFileStatus :: forall d. MsgDirectionI d => DB.Connection -> (PQSupport -> VersionRangeChat) -> User -> Int64 -> CIFileStatus d -> ExceptT StoreError IO AChatItem updateDirectCIFileStatus db vr user fileId fileStatus = do aci@(AChatItem cType d cInfo ci) <- getChatItemByFileId db vr user fileId case (cType, testEquality d $ msgDirection @d) of diff --git a/src/Simplex/Chat/Store/Groups.hs b/src/Simplex/Chat/Store/Groups.hs index 3b81d5b242..254b8dab59 100644 --- a/src/Simplex/Chat/Store/Groups.hs +++ b/src/Simplex/Chat/Store/Groups.hs @@ -142,7 +142,7 @@ import Simplex.Messaging.Agent.Protocol (ConnId, UserId) import Simplex.Messaging.Agent.Store.SQLite (firstRow, maybeFirstRow) import qualified Simplex.Messaging.Agent.Store.SQLite.DB as DB import qualified Simplex.Messaging.Crypto as C -import Simplex.Messaging.Crypto.Ratchet (pattern PQEncOff, pattern PQSupportOff) +import Simplex.Messaging.Crypto.Ratchet (PQSupport, pattern PQEncOff, pattern PQSupportOff) import Simplex.Messaging.Protocol (SubscriptionMode (..)) import Simplex.Messaging.Util (eitherToMaybe, ($>>=), (<$$>)) import Simplex.Messaging.Version @@ -154,9 +154,9 @@ type GroupMemberRow = ((Int64, Int64, MemberId, VersionChat, VersionChat, GroupM type MaybeGroupMemberRow = ((Maybe Int64, Maybe Int64, Maybe MemberId, Maybe VersionChat, Maybe VersionChat, Maybe GroupMemberRole, Maybe GroupMemberCategory, Maybe GroupMemberStatus, Maybe Bool, Maybe MemberRestrictionStatus) :. (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 :: VersionRangeChat -> Int64 -> GroupInfoRow -> GroupInfo +toGroupInfo :: (PQSupport -> VersionRangeChat) -> Int64 -> GroupInfoRow -> GroupInfo toGroupInfo vr userContactId ((groupId, localDisplayName, displayName, fullName, description, image, hostConnCustomUserProfileId, enableNtfs_, sendRcpts, favorite, groupPreferences) :. (createdAt, updatedAt, chatTs, userMemberProfileSentAt) :. userMemberRow) = - let membership = (toGroupMember userContactId userMemberRow) {memberChatVRange = vr} + let membership = (toGroupMember userContactId userMemberRow) {memberChatVRange = vr PQSupportOff} chatSettings = ChatSettings {enableNtfs = fromMaybe MFAll enableNtfs_, sendRcpts, favorite} fullGroupPreferences = mergeGroupPreferences groupPreferences groupProfile = GroupProfile {displayName, fullName, description, image, groupPreferences} @@ -186,11 +186,11 @@ createGroupLink db User {userId} groupInfo@GroupInfo {groupId, localDisplayName} "INSERT INTO user_contact_links (user_id, group_id, group_link_id, local_display_name, conn_req_contact, group_link_member_role, auto_accept, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?,?)" (userId, groupId, groupLinkId, "group_link_" <> localDisplayName, cReq, memberRole, True, currentTs, currentTs) userContactLinkId <- insertedRowId db - void $ createConnection_ db userId ConnUserContact (Just userContactLinkId) agentConnId (Just initialChatVersion) chatInitialVRange Nothing Nothing Nothing 0 currentTs subMode PQSupportOff + void $ createConnection_ db userId ConnUserContact (Just userContactLinkId) agentConnId initialChatVersion chatInitialVRange Nothing Nothing Nothing 0 currentTs subMode PQSupportOff -getGroupLinkConnection :: DB.Connection -> User -> GroupInfo -> ExceptT StoreError IO Connection -getGroupLinkConnection db User {userId} groupInfo@GroupInfo {groupId} = - ExceptT . firstRow toConnection (SEGroupLinkNotFound groupInfo) $ +getGroupLinkConnection :: DB.Connection -> (PQSupport -> VersionRangeChat) -> User -> GroupInfo -> ExceptT StoreError IO Connection +getGroupLinkConnection db vr User {userId} groupInfo@GroupInfo {groupId} = + ExceptT . firstRow (toConnection vr) (SEGroupLinkNotFound groupInfo) $ DB.query db [sql| @@ -261,7 +261,7 @@ 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 -> VersionRangeChat -> ExceptT StoreError IO (GroupInfo, GroupMember) +getGroupAndMember :: DB.Connection -> User -> Int64 -> (PQSupport -> VersionRangeChat) -> ExceptT StoreError IO (GroupInfo, GroupMember) getGroupAndMember db User {userId, userContactId} groupMemberId vr = ExceptT . firstRow toGroupAndMember (SEInternalError "referenced group member not found") $ DB.query @@ -303,10 +303,10 @@ getGroupAndMember db User {userId, userContactId} groupMemberId vr = toGroupAndMember (groupInfoRow :. memberRow :. connRow) = let groupInfo = toGroupInfo vr userContactId groupInfoRow member = toGroupMember userContactId memberRow - in (groupInfo, (member :: GroupMember) {activeConn = toMaybeConnection connRow}) + in (groupInfo, (member :: GroupMember) {activeConn = toMaybeConnection vr connRow}) -- | creates completely new group with a single member - the current user -createNewGroup :: DB.Connection -> VersionRangeChat -> TVar ChaChaDRG -> User -> GroupProfile -> Maybe Profile -> ExceptT StoreError IO GroupInfo +createNewGroup :: DB.Connection -> (PQSupport -> VersionRangeChat) -> 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 @@ -348,7 +348,7 @@ createNewGroup db vr gVar user@User {userId} groupProfile incognitoProfile = Exc } -- | creates a new group record for the group the current user was invited to, or returns an existing one -createGroupInvitation :: DB.Connection -> VersionRangeChat -> User -> Contact -> GroupInvitation -> Maybe ProfileId -> ExceptT StoreError IO (GroupInfo, GroupMemberId) +createGroupInvitation :: DB.Connection -> (PQSupport -> VersionRangeChat) -> User -> Contact -> GroupInvitation -> Maybe ProfileId -> ExceptT StoreError IO (GroupInfo, GroupMemberId) createGroupInvitation _ _ _ Contact {localDisplayName, activeConn = Nothing} _ _ = throwError $ SEContactNotReady localDisplayName createGroupInvitation db vr user@User {userId} contact@Contact {contactId, activeConn = Just Connection {customUserProfileId, peerChatVRange}} GroupInvitation {fromMember, invitedMember, connRequest, groupProfile} incognitoProfileId = do liftIO getInvitationGroupId_ >>= \case @@ -393,7 +393,7 @@ createGroupInvitation db vr user@User {userId} contact@Contact {contactId, activ |] (profileId, localDisplayName, connRequest, customUserProfileId, userId, True, currentTs, currentTs, currentTs, currentTs) insertedRowId db - let hostVRange = peerChatVRange + let hostVRange = const $ adjustedMemberVRange vr 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 vr let chatSettings = ChatSettings {enableNtfs = MFAll, sendRcpts = Nothing, favorite = False} @@ -414,13 +414,18 @@ createGroupInvitation db vr user@User {userId} contact@Contact {contactId, activ groupMemberId ) +adjustedMemberVRange :: (PQSupport -> VersionRangeChat) -> VersionRangeChat -> VersionRangeChat +adjustedMemberVRange getVR vr@(VersionRange minV maxV) = + let maxV' = min maxV (maxVersion $ getVR PQSupportOff) + in fromMaybe vr $ safeVersionRange minV (max minV maxV') + getHostMemberId_ :: DB.Connection -> User -> GroupId -> ExceptT StoreError IO GroupMemberId getHostMemberId_ db User {userId} groupId = ExceptT . firstRow fromOnly (SEHostMemberIdNotFound groupId) $ DB.query db "SELECT group_member_id FROM group_members WHERE user_id = ? AND group_id = ? AND member_category = ?" (userId, groupId, GCHostMember) -createContactMemberInv_ :: IsContact a => DB.Connection -> User -> GroupId -> Maybe GroupMemberId -> a -> MemberIdRole -> GroupMemberCategory -> GroupMemberStatus -> InvitedBy -> Maybe ProfileId -> UTCTime -> VersionRangeChat -> ExceptT StoreError IO GroupMember -createContactMemberInv_ db User {userId, userContactId} groupId invitedByGroupMemberId userOrContact MemberIdRole {memberId, memberRole} memberCategory memberStatus invitedBy incognitoProfileId createdAt memberChatVRange@(VersionRange minV maxV) = do +createContactMemberInv_ :: IsContact a => DB.Connection -> User -> GroupId -> Maybe GroupMemberId -> a -> MemberIdRole -> GroupMemberCategory -> GroupMemberStatus -> InvitedBy -> Maybe ProfileId -> UTCTime -> (PQSupport -> VersionRangeChat) -> ExceptT StoreError IO GroupMember +createContactMemberInv_ db User {userId, userContactId} groupId invitedByGroupMemberId userOrContact MemberIdRole {memberId, memberRole} memberCategory memberStatus invitedBy incognitoProfileId createdAt vr = do incognitoProfile <- forM incognitoProfileId $ \profileId -> getProfileById db userId profileId (localDisplayName, memberProfile) <- case (incognitoProfile, incognitoProfileId) of (Just profile@LocalProfile {displayName}, Just profileId) -> @@ -447,6 +452,7 @@ createContactMemberInv_ db User {userId, userContactId} groupId invitedByGroupMe memberChatVRange } where + memberChatVRange@(VersionRange minV maxV) = vr PQSupportOff insertMember_ :: IO ContactName insertMember_ = do let localDisplayName = localDisplayName' userOrContact @@ -482,7 +488,7 @@ createContactMemberInv_ db User {userId, userContactId} groupId invitedByGroupMe ) pure $ Right incognitoLdn -createGroupInvitedViaLink :: DB.Connection -> VersionRangeChat -> User -> Connection -> GroupLinkInvitation -> ExceptT StoreError IO (GroupInfo, GroupMember) +createGroupInvitedViaLink :: DB.Connection -> (PQSupport -> VersionRangeChat) -> User -> Connection -> GroupLinkInvitation -> ExceptT StoreError IO (GroupInfo, GroupMember) createGroupInvitedViaLink db vr @@ -496,7 +502,7 @@ createGroupInvitedViaLink -- using IBUnknown since host is created without contact void $ createContactMemberInv_ db user groupId (Just hostMemberId) user invitedMember GCUserMember GSMemAccepted IBUnknown customUserProfileId currentTs vr liftIO $ setViaGroupLinkHash db groupId connId - (,) <$> getGroupInfo db vr user groupId <*> getGroupMemberById db user hostMemberId + (,) <$> getGroupInfo db vr user groupId <*> getGroupMemberById db vr user hostMemberId where insertGroup_ currentTs = ExceptT $ do let GroupProfile {displayName, fullName, description, image, groupPreferences} = groupProfile @@ -553,10 +559,10 @@ setGroupInvitationChatItemId db User {userId} groupId chatItemId = do -- TODO return the last connection that is ready, not any last connection -- requires updating connection status -getGroup :: DB.Connection -> VersionRangeChat -> User -> GroupId -> ExceptT StoreError IO Group +getGroup :: DB.Connection -> (PQSupport -> VersionRangeChat) -> User -> GroupId -> ExceptT StoreError IO Group getGroup db vr user groupId = do gInfo <- getGroupInfo db vr user groupId - members <- liftIO $ getGroupMembers db user gInfo + members <- liftIO $ getGroupMembers db vr user gInfo pure $ Group gInfo members deleteGroupConnectionsAndFiles :: DB.Connection -> User -> GroupInfo -> [GroupMember] -> IO () @@ -608,12 +614,12 @@ deleteGroupProfile_ db userId groupId = |] (userId, groupId) -getUserGroups :: DB.Connection -> VersionRangeChat -> User -> IO [Group] +getUserGroups :: DB.Connection -> (PQSupport -> VersionRangeChat) -> 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 vr user) groupIds -getUserGroupDetails :: DB.Connection -> VersionRangeChat -> User -> Maybe ContactId -> Maybe String -> IO [GroupInfo] +getUserGroupDetails :: DB.Connection -> (PQSupport -> VersionRangeChat) -> User -> Maybe ContactId -> Maybe String -> IO [GroupInfo] getUserGroupDetails db vr User {userId, userContactId} _contactId_ search_ = map (toGroupInfo vr userContactId) <$> DB.query @@ -636,7 +642,7 @@ getUserGroupDetails db vr User {userId, userContactId} _contactId_ search_ = where search = fromMaybe "" search_ -getUserGroupsWithSummary :: DB.Connection -> VersionRangeChat -> User -> Maybe ContactId -> Maybe String -> IO [(GroupInfo, GroupSummary)] +getUserGroupsWithSummary :: DB.Connection -> (PQSupport -> VersionRangeChat) -> 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) @@ -677,7 +683,7 @@ 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 -> VersionRangeChat -> User -> GroupName -> ExceptT StoreError IO GroupInfo +getGroupInfoByName :: DB.Connection -> (PQSupport -> VersionRangeChat) -> User -> GroupName -> ExceptT StoreError IO GroupInfo getGroupInfoByName db vr user gName = do gId <- getGroupIdByName db user gName getGroupInfo db vr user gId @@ -701,41 +707,41 @@ groupMemberQuery = ) |] -getGroupMember :: DB.Connection -> User -> GroupId -> GroupMemberId -> ExceptT StoreError IO GroupMember -getGroupMember db user@User {userId} groupId groupMemberId = - ExceptT . firstRow (toContactMember user) (SEGroupMemberNotFound groupMemberId) $ +getGroupMember :: DB.Connection -> (PQSupport -> VersionRangeChat) -> User -> GroupId -> GroupMemberId -> ExceptT StoreError IO GroupMember +getGroupMember db vr user@User {userId} groupId groupMemberId = + ExceptT . firstRow (toContactMember vr user) (SEGroupMemberNotFound groupMemberId) $ DB.query db (groupMemberQuery <> " WHERE m.group_id = ? AND m.group_member_id = ? AND m.user_id = ?") (userId, groupId, groupMemberId, userId) -getGroupMemberById :: DB.Connection -> User -> GroupMemberId -> ExceptT StoreError IO GroupMember -getGroupMemberById db user@User {userId} groupMemberId = - ExceptT . firstRow (toContactMember user) (SEGroupMemberNotFound groupMemberId) $ +getGroupMemberById :: DB.Connection -> (PQSupport -> VersionRangeChat) -> User -> GroupMemberId -> ExceptT StoreError IO GroupMember +getGroupMemberById db vr user@User {userId} groupMemberId = + ExceptT . firstRow (toContactMember vr user) (SEGroupMemberNotFound groupMemberId) $ DB.query db (groupMemberQuery <> " WHERE m.group_member_id = ? AND m.user_id = ?") (userId, groupMemberId, userId) -getGroupMemberByMemberId :: DB.Connection -> User -> GroupInfo -> MemberId -> ExceptT StoreError IO GroupMember -getGroupMemberByMemberId db user@User {userId} GroupInfo {groupId} memberId = - ExceptT . firstRow (toContactMember user) (SEGroupMemberNotFoundByMemberId memberId) $ +getGroupMemberByMemberId :: DB.Connection -> (PQSupport -> VersionRangeChat) -> User -> GroupInfo -> MemberId -> ExceptT StoreError IO GroupMember +getGroupMemberByMemberId db vr user@User {userId} GroupInfo {groupId} memberId = + ExceptT . firstRow (toContactMember vr user) (SEGroupMemberNotFoundByMemberId memberId) $ DB.query db (groupMemberQuery <> " WHERE m.group_id = ? AND m.member_id = ?") (userId, groupId, memberId) -getGroupMembers :: DB.Connection -> User -> GroupInfo -> IO [GroupMember] -getGroupMembers db user@User {userId, userContactId} GroupInfo {groupId} = do - map (toContactMember user) +getGroupMembers :: DB.Connection -> (PQSupport -> VersionRangeChat) -> User -> GroupInfo -> IO [GroupMember] +getGroupMembers db vr user@User {userId, userContactId} GroupInfo {groupId} = do + map (toContactMember vr user) <$> DB.query db (groupMemberQuery <> " WHERE m.group_id = ? AND m.user_id = ? AND (m.contact_id IS NULL OR m.contact_id != ?)") (userId, groupId, userId, userContactId) -getGroupMembersForExpiration :: DB.Connection -> User -> GroupInfo -> IO [GroupMember] -getGroupMembersForExpiration db user@User {userId, userContactId} GroupInfo {groupId} = do - map (toContactMember user) +getGroupMembersForExpiration :: DB.Connection -> (PQSupport -> VersionRangeChat) -> User -> GroupInfo -> IO [GroupMember] +getGroupMembersForExpiration db vr user@User {userId, userContactId} GroupInfo {groupId} = do + map (toContactMember vr user) <$> DB.query db ( groupMemberQuery @@ -749,9 +755,9 @@ getGroupMembersForExpiration db user@User {userId, userContactId} GroupInfo {gro ) (userId, groupId, userId, userContactId, GSMemRemoved, GSMemLeft, GSMemGroupDeleted, GSMemUnknown) -toContactMember :: User -> (GroupMemberRow :. MaybeConnectionRow) -> GroupMember -toContactMember User {userContactId} (memberRow :. connRow) = - (toGroupMember userContactId memberRow) {activeConn = toMaybeConnection connRow} +toContactMember :: (PQSupport -> VersionRangeChat) -> User -> (GroupMemberRow :. MaybeConnectionRow) -> GroupMember +toContactMember vr User {userContactId} (memberRow :. connRow) = + (toGroupMember userContactId memberRow) {activeConn = toMaybeConnection vr connRow} getGroupCurrentMembersCount :: DB.Connection -> User -> GroupInfo -> IO Int getGroupCurrentMembersCount db User {userId} GroupInfo {groupId} = do @@ -767,14 +773,14 @@ getGroupCurrentMembersCount db User {userId} GroupInfo {groupId} = do (groupId, userId) pure $ length $ filter memberCurrent' statuses -getGroupInvitation :: DB.Connection -> VersionRangeChat -> User -> GroupId -> ExceptT StoreError IO ReceivedGroupInvitation +getGroupInvitation :: DB.Connection -> (PQSupport -> VersionRangeChat) -> User -> GroupId -> ExceptT StoreError IO ReceivedGroupInvitation getGroupInvitation db vr user groupId = getConnRec_ user >>= \case Just connRequest -> do 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 + fromMember <- getGroupMember db vr user groupId hostId pure ReceivedGroupInvitation {fromMember, connRequest, groupInfo} _ -> throwError SEGroupInvitationNotFound where @@ -832,7 +838,7 @@ createNewContactMember db gVar User {userId, userContactId} GroupInfo {groupId, :. (minV, maxV) ) -createNewContactMemberAsync :: DB.Connection -> TVar ChaChaDRG -> User -> GroupInfo -> Contact -> GroupMemberRole -> (CommandId, ConnId) -> Maybe VersionChat -> VersionRangeChat -> SubscriptionMode -> ExceptT StoreError IO () +createNewContactMemberAsync :: DB.Connection -> TVar ChaChaDRG -> User -> GroupInfo -> Contact -> GroupMemberRole -> (CommandId, ConnId) -> VersionChat -> VersionRangeChat -> SubscriptionMode -> ExceptT StoreError IO () createNewContactMemberAsync db gVar user@User {userId, userContactId} GroupInfo {groupId, membership} Contact {contactId, localDisplayName, profile} memberRole (cmdId, agentConnId) chatV peerChatVRange subMode = createWithRandomId gVar $ \memId -> do createdAt <- liftIO getCurrentTime @@ -889,7 +895,7 @@ createAcceptedMember :. (minV, maxV) ) -createAcceptedMemberConnection :: DB.Connection -> User -> (CommandId, ConnId) -> Maybe VersionChat -> UserContactRequest -> GroupMemberId -> SubscriptionMode -> IO () +createAcceptedMemberConnection :: DB.Connection -> User -> (CommandId, ConnId) -> VersionChat -> UserContactRequest -> GroupMemberId -> SubscriptionMode -> IO () createAcceptedMemberConnection db user@User {userId} @@ -902,8 +908,8 @@ createAcceptedMemberConnection Connection {connId} <- createConnection_ db userId ConnMember (Just groupMemberId) agentConnId chatV cReqChatVRange Nothing (Just userContactLinkId) Nothing 0 createdAt subMode PQSupportOff setCommandConnId db user cmdId connId -getContactViaMember :: DB.Connection -> User -> GroupMember -> ExceptT StoreError IO Contact -getContactViaMember db user@User {userId} GroupMember {groupMemberId} = do +getContactViaMember :: DB.Connection -> (PQSupport -> VersionRangeChat) -> User -> GroupMember -> ExceptT StoreError IO Contact +getContactViaMember db vr user@User {userId} GroupMember {groupMemberId} = do contactId <- ExceptT $ firstRow fromOnly (SEContactNotFoundByMemberId groupMemberId) $ @@ -917,7 +923,7 @@ getContactViaMember db user@User {userId} GroupMember {groupMemberId} = do LIMIT 1 |] (userId, groupMemberId) - getContact db user contactId + getContact db vr user contactId setNewContactMemberConnRequest :: DB.Connection -> User -> GroupMember -> ConnReqInvitation -> IO () setNewContactMemberConnRequest db User {userId} GroupMember {groupMemberId} connRequest = do @@ -929,12 +935,12 @@ getMemberInvitation db User {userId} groupMemberId = fmap join . maybeFirstRow fromOnly $ DB.query db "SELECT sent_inv_queue_info FROM group_members WHERE group_member_id = ? AND user_id = ?" (groupMemberId, userId) -createMemberConnection :: DB.Connection -> UserId -> GroupMember -> ConnId -> Maybe VersionChat -> VersionRangeChat -> SubscriptionMode -> IO () +createMemberConnection :: DB.Connection -> UserId -> GroupMember -> ConnId -> VersionChat -> VersionRangeChat -> SubscriptionMode -> IO () createMemberConnection db userId GroupMember {groupMemberId} agentConnId chatV peerChatVRange subMode = do currentTs <- getCurrentTime void $ createMemberConnection_ db userId groupMemberId agentConnId chatV peerChatVRange Nothing 0 currentTs subMode -createMemberConnectionAsync :: DB.Connection -> User -> GroupMemberId -> (CommandId, ConnId) -> Maybe VersionChat -> VersionRangeChat -> SubscriptionMode -> IO () +createMemberConnectionAsync :: DB.Connection -> User -> GroupMemberId -> (CommandId, ConnId) -> VersionChat -> VersionRangeChat -> SubscriptionMode -> IO () createMemberConnectionAsync db user@User {userId} groupMemberId (cmdId, agentConnId) chatV peerChatVRange subMode = do currentTs <- getCurrentTime Connection {connId} <- createMemberConnection_ db userId groupMemberId agentConnId chatV peerChatVRange Nothing 0 currentTs subMode @@ -1163,10 +1169,10 @@ getIntroduction db reMember toMember = ExceptT $ do in Right GroupMemberIntro {introId, reMember, toMember, introStatus, introInvitation} toIntro _ = Left SEIntroNotFound -getForwardIntroducedMembers :: DB.Connection -> User -> GroupMember -> Bool -> IO [GroupMember] -getForwardIntroducedMembers db user invitee highlyAvailable = do +getForwardIntroducedMembers :: DB.Connection -> (PQSupport -> VersionRangeChat) -> User -> GroupMember -> Bool -> IO [GroupMember] +getForwardIntroducedMembers db vr user invitee highlyAvailable = do memberIds <- map fromOnly <$> query - filter memberCurrent . rights <$> mapM (runExceptT . getGroupMemberById db user) memberIds + filter memberCurrent . rights <$> mapM (runExceptT . getGroupMemberById db vr user) memberIds where mId = groupMemberId' invitee query @@ -1183,10 +1189,10 @@ getForwardIntroducedMembers db user invitee highlyAvailable = do WHERE to_group_member_id = ? AND intro_status NOT IN (?,?,?) |] -getForwardInvitedMembers :: DB.Connection -> User -> GroupMember -> Bool -> IO [GroupMember] -getForwardInvitedMembers db user forwardMember highlyAvailable = do +getForwardInvitedMembers :: DB.Connection -> (PQSupport -> VersionRangeChat) -> User -> GroupMember -> Bool -> IO [GroupMember] +getForwardInvitedMembers db vr user forwardMember highlyAvailable = do memberIds <- map fromOnly <$> query - filter memberCurrent . rights <$> mapM (runExceptT . getGroupMemberById db user) memberIds + filter memberCurrent . rights <$> mapM (runExceptT . getGroupMemberById db vr user) memberIds where mId = groupMemberId' forwardMember query @@ -1203,7 +1209,7 @@ getForwardInvitedMembers db user forwardMember highlyAvailable = do WHERE re_group_member_id = ? AND intro_status NOT IN (?,?,?) |] -createIntroReMember :: DB.Connection -> User -> GroupInfo -> GroupMember -> Maybe VersionChat -> MemberInfo -> Maybe MemberRestrictions -> (CommandId, ConnId) -> Maybe (CommandId, ConnId) -> Maybe ProfileId -> SubscriptionMode -> ExceptT StoreError IO GroupMember +createIntroReMember :: DB.Connection -> User -> GroupInfo -> GroupMember -> VersionChat -> MemberInfo -> Maybe MemberRestrictions -> (CommandId, ConnId) -> Maybe (CommandId, ConnId) -> Maybe ProfileId -> SubscriptionMode -> ExceptT StoreError IO GroupMember createIntroReMember db user@User {userId} @@ -1236,7 +1242,7 @@ createIntroReMember liftIO $ setCommandConnId db user groupCmdId groupConnId pure (member :: GroupMember) {activeConn = Just conn} -createIntroToMemberContact :: DB.Connection -> User -> GroupMember -> GroupMember -> Maybe VersionChat -> VersionRangeChat -> (CommandId, ConnId) -> Maybe (CommandId, ConnId) -> Maybe ProfileId -> SubscriptionMode -> IO () +createIntroToMemberContact :: DB.Connection -> User -> GroupMember -> GroupMember -> VersionChat -> VersionRangeChat -> (CommandId, ConnId) -> Maybe (CommandId, ConnId) -> Maybe ProfileId -> SubscriptionMode -> IO () createIntroToMemberContact db user@User {userId} GroupMember {memberContactId = viaContactId, activeConn} _to@GroupMember {groupMemberId, localDisplayName} chatV mcvr (groupCmdId, groupAgentConnId) directConnIds customUserProfileId subMode = do let cLevel = 1 + maybe 0 (\Connection {connLevel} -> connLevel) activeConn currentTs <- getCurrentTime @@ -1273,11 +1279,11 @@ createIntroToMemberContact db user@User {userId} GroupMember {memberContactId = |] [":contact_id" := contactId, ":updated_at" := ts, ":group_member_id" := groupMemberId] -createMemberConnection_ :: DB.Connection -> UserId -> Int64 -> ConnId -> Maybe VersionChat -> VersionRangeChat -> Maybe Int64 -> Int -> UTCTime -> SubscriptionMode -> IO Connection +createMemberConnection_ :: DB.Connection -> UserId -> Int64 -> ConnId -> VersionChat -> VersionRangeChat -> Maybe Int64 -> Int -> UTCTime -> SubscriptionMode -> IO Connection createMemberConnection_ db userId groupMemberId agentConnId chatV peerChatVRange viaContact connLevel currentTs subMode = createConnection_ db userId ConnMember (Just groupMemberId) agentConnId chatV peerChatVRange viaContact Nothing Nothing connLevel currentTs subMode PQSupportOff -getViaGroupMember :: DB.Connection -> VersionRangeChat -> User -> Contact -> IO (Maybe (GroupInfo, GroupMember)) +getViaGroupMember :: DB.Connection -> (PQSupport -> VersionRangeChat) -> User -> Contact -> IO (Maybe (GroupInfo, GroupMember)) getViaGroupMember db vr User {userId, userContactId} Contact {contactId} = maybeFirstRow toGroupAndMember $ DB.query @@ -1320,10 +1326,10 @@ getViaGroupMember db vr User {userId, userContactId} Contact {contactId} = toGroupAndMember (groupInfoRow :. memberRow :. connRow) = let groupInfo = toGroupInfo vr userContactId groupInfoRow member = toGroupMember userContactId memberRow - in (groupInfo, (member :: GroupMember) {activeConn = toMaybeConnection connRow}) + in (groupInfo, (member :: GroupMember) {activeConn = toMaybeConnection vr connRow}) -getViaGroupContact :: DB.Connection -> User -> GroupMember -> IO (Maybe Contact) -getViaGroupContact db user@User {userId} GroupMember {groupMemberId} = do +getViaGroupContact :: DB.Connection -> (PQSupport -> VersionRangeChat) -> User -> GroupMember -> IO (Maybe Contact) +getViaGroupContact db vr user@User {userId} GroupMember {groupMemberId} = do contactId_ <- maybeFirstRow fromOnly $ DB.query @@ -1337,7 +1343,7 @@ getViaGroupContact db user@User {userId} GroupMember {groupMemberId} = do LIMIT 1 |] (userId, groupMemberId) - maybe (pure Nothing) (fmap eitherToMaybe . runExceptT . getContact db user) contactId_ + maybe (pure Nothing) (fmap eitherToMaybe . runExceptT . getContact db vr user) contactId_ updateGroupProfile :: DB.Connection -> User -> GroupInfo -> GroupProfile -> ExceptT StoreError IO GroupInfo updateGroupProfile db user@User {userId} g@GroupInfo {groupId, localDisplayName, groupProfile = GroupProfile {displayName}} p'@GroupProfile {displayName = newName, fullName, description, image, groupPreferences} @@ -1373,7 +1379,7 @@ updateGroupProfile db user@User {userId} g@GroupInfo {groupId, localDisplayName, (ldn, currentTs, userId, groupId) safeDeleteLDN db user localDisplayName -getGroupInfo :: DB.Connection -> VersionRangeChat -> User -> Int64 -> ExceptT StoreError IO GroupInfo +getGroupInfo :: DB.Connection -> (PQSupport -> VersionRangeChat) -> User -> Int64 -> ExceptT StoreError IO GroupInfo getGroupInfo db vr User {userId, userContactId} groupId = ExceptT . firstRow (toGroupInfo vr userContactId) (SEGroupNotFound groupId) $ DB.query @@ -1396,7 +1402,7 @@ getGroupInfo db vr User {userId, userContactId} groupId = |] (groupId, userId, userContactId) -getGroupInfoByUserContactLinkConnReq :: DB.Connection -> VersionRangeChat -> User -> (ConnReqContact, ConnReqContact) -> IO (Maybe GroupInfo) +getGroupInfoByUserContactLinkConnReq :: DB.Connection -> (PQSupport -> VersionRangeChat) -> User -> (ConnReqContact, ConnReqContact) -> IO (Maybe GroupInfo) getGroupInfoByUserContactLinkConnReq db vr user@User {userId} (cReqSchema1, cReqSchema2) = do groupId_ <- maybeFirstRow fromOnly $ @@ -1410,7 +1416,7 @@ getGroupInfoByUserContactLinkConnReq db vr user@User {userId} (cReqSchema1, cReq (userId, cReqSchema1, cReqSchema2) maybe (pure Nothing) (fmap eitherToMaybe . runExceptT . getGroupInfo db vr user) groupId_ -getGroupInfoByGroupLinkHash :: DB.Connection -> VersionRangeChat -> User -> (ConnReqUriHash, ConnReqUriHash) -> IO (Maybe GroupInfo) +getGroupInfoByGroupLinkHash :: DB.Connection -> (PQSupport -> VersionRangeChat) -> User -> (ConnReqUriHash, ConnReqUriHash) -> IO (Maybe GroupInfo) getGroupInfoByGroupLinkHash db vr user@User {userId, userContactId} (groupLinkHash1, groupLinkHash2) = do groupId_ <- maybeFirstRow fromOnly $ @@ -1437,7 +1443,7 @@ getGroupMemberIdByName db User {userId} groupId groupMemberName = ExceptT . firstRow fromOnly (SEGroupMemberNameNotFound groupId groupMemberName) $ DB.query db "SELECT group_member_id FROM group_members WHERE user_id = ? AND group_id = ? AND local_display_name = ?" (userId, groupId, groupMemberName) -getActiveMembersByName :: DB.Connection -> VersionRangeChat -> User -> ContactName -> ExceptT StoreError IO [(GroupInfo, GroupMember)] +getActiveMembersByName :: DB.Connection -> (PQSupport -> VersionRangeChat) -> User -> ContactName -> ExceptT StoreError IO [(GroupInfo, GroupMember)] getActiveMembersByName db vr user@User {userId} groupMemberName = do groupMemberIds :: [(GroupId, GroupMemberId)] <- liftIO $ @@ -1452,19 +1458,19 @@ getActiveMembersByName db vr user@User {userId} groupMemberName = do (userId, groupMemberName, GSMemConnected, GSMemComplete, GCUserMember) possibleMembers <- forM groupMemberIds $ \(groupId, groupMemberId) -> do groupInfo <- getGroupInfo db vr user groupId - groupMember <- getGroupMember db user groupId groupMemberId + groupMember <- getGroupMember db vr user groupId groupMemberId pure (groupInfo, groupMember) pure $ sortOn (Down . ts . fst) possibleMembers where ts GroupInfo {chatTs, updatedAt} = fromMaybe updatedAt chatTs -getMatchingContacts :: DB.Connection -> User -> Contact -> IO [Contact] -getMatchingContacts db user@User {userId} Contact {contactId, profile = LocalProfile {displayName, fullName, image}} = do +getMatchingContacts :: DB.Connection -> (PQSupport -> VersionRangeChat) -> User -> Contact -> IO [Contact] +getMatchingContacts db vr user@User {userId} Contact {contactId, profile = LocalProfile {displayName, fullName, image}} = do contactIds <- map fromOnly <$> case image of Just img -> DB.query db (q <> " AND p.image = ?") (userId, contactId, CSActive, displayName, fullName, img) Nothing -> DB.query db (q <> " AND p.image is NULL") (userId, contactId, CSActive, displayName, fullName) - rights <$> mapM (runExceptT . getContact db user) contactIds + rights <$> mapM (runExceptT . getContact db vr user) contactIds where -- this query is different from one in getMatchingMemberContacts -- it checks that it's not the same contact @@ -1478,13 +1484,13 @@ getMatchingContacts db user@User {userId} Contact {contactId, profile = LocalPro AND p.display_name = ? AND p.full_name = ? |] -getMatchingMembers :: DB.Connection -> User -> Contact -> IO [GroupMember] -getMatchingMembers db user@User {userId} Contact {profile = LocalProfile {displayName, fullName, image}} = do +getMatchingMembers :: DB.Connection -> (PQSupport -> VersionRangeChat) -> User -> Contact -> IO [GroupMember] +getMatchingMembers db vr user@User {userId} Contact {profile = LocalProfile {displayName, fullName, image}} = do memberIds <- map fromOnly <$> case image of Just img -> DB.query db (q <> " AND p.image = ?") (userId, GCUserMember, displayName, fullName, img) Nothing -> DB.query db (q <> " AND p.image is NULL") (userId, GCUserMember, displayName, fullName) - filter memberCurrent . rights <$> mapM (runExceptT . getGroupMemberById db user) memberIds + filter memberCurrent . rights <$> mapM (runExceptT . getGroupMemberById db vr user) memberIds where -- only match with members without associated contact q = @@ -1497,14 +1503,14 @@ getMatchingMembers db user@User {userId} Contact {profile = LocalProfile {displa AND p.display_name = ? AND p.full_name = ? |] -getMatchingMemberContacts :: DB.Connection -> User -> GroupMember -> IO [Contact] -getMatchingMemberContacts _ _ GroupMember {memberContactId = Just _} = pure [] -getMatchingMemberContacts db user@User {userId} GroupMember {memberProfile = LocalProfile {displayName, fullName, image}} = do +getMatchingMemberContacts :: DB.Connection -> (PQSupport -> VersionRangeChat) -> User -> GroupMember -> IO [Contact] +getMatchingMemberContacts _ _ _ GroupMember {memberContactId = Just _} = pure [] +getMatchingMemberContacts db vr user@User {userId} GroupMember {memberProfile = LocalProfile {displayName, fullName, image}} = do contactIds <- map fromOnly <$> case image of Just img -> DB.query db (q <> " AND p.image = ?") (userId, CSActive, displayName, fullName, img) Nothing -> DB.query db (q <> " AND p.image is NULL") (userId, CSActive, displayName, fullName) - rights <$> mapM (runExceptT . getContact db user) contactIds + rights <$> mapM (runExceptT . getContact db vr user) contactIds where q = [sql| @@ -1536,8 +1542,8 @@ createSentProbeHash db userId probeId to = do "INSERT INTO sent_probe_hashes (sent_probe_id, contact_id, group_member_id, user_id, created_at, updated_at) VALUES (?,?,?,?,?,?)" (probeId, ctId, gmId, userId, currentTs, currentTs) -matchReceivedProbe :: DB.Connection -> User -> ContactOrMember -> Probe -> IO [ContactOrMember] -matchReceivedProbe db user@User {userId} from (Probe probe) = do +matchReceivedProbe :: DB.Connection -> (PQSupport -> VersionRangeChat) -> User -> ContactOrMember -> Probe -> IO [ContactOrMember] +matchReceivedProbe db vr user@User {userId} from (Probe probe) = do let probeHash = C.sha256Hash probe cgmIds <- DB.query @@ -1558,7 +1564,7 @@ matchReceivedProbe db user@User {userId} from (Probe probe) = do "INSERT INTO received_probes (contact_id, group_member_id, probe, probe_hash, user_id, created_at, updated_at) VALUES (?,?,?,?,?,?,?)" (ctId, gmId, probe, probeHash, userId, currentTs, currentTs) let cgmIds' = filterFirstContactId cgmIds - catMaybes <$> mapM (getContactOrMember_ db user) cgmIds' + catMaybes <$> mapM (getContactOrMember_ db vr user) cgmIds' where filterFirstContactId :: [(Maybe ContactId, Maybe GroupId, Maybe GroupMemberId)] -> [(Maybe ContactId, Maybe GroupId, Maybe GroupMemberId)] filterFirstContactId cgmIds = do @@ -1568,8 +1574,8 @@ matchReceivedProbe db user@User {userId} from (Probe probe) = do (x : _) -> [x] ctIds' <> memIds -matchReceivedProbeHash :: DB.Connection -> User -> ContactOrMember -> ProbeHash -> IO (Maybe (ContactOrMember, Probe)) -matchReceivedProbeHash db user@User {userId} from (ProbeHash probeHash) = do +matchReceivedProbeHash :: DB.Connection -> (PQSupport -> VersionRangeChat) -> User -> ContactOrMember -> ProbeHash -> IO (Maybe (ContactOrMember, Probe)) +matchReceivedProbeHash db vr user@User {userId} from (ProbeHash probeHash) = do probeIds <- maybeFirstRow id $ DB.query @@ -1589,11 +1595,11 @@ matchReceivedProbeHash db user@User {userId} from (ProbeHash probeHash) = do db "INSERT INTO received_probes (contact_id, group_member_id, probe_hash, user_id, created_at, updated_at) VALUES (?,?,?,?,?,?)" (ctId, gmId, probeHash, userId, currentTs, currentTs) - pure probeIds $>>= \(Only probe :. cgmIds) -> (,Probe probe) <$$> getContactOrMember_ db user cgmIds + pure probeIds $>>= \(Only probe :. cgmIds) -> (,Probe probe) <$$> getContactOrMember_ db vr user cgmIds -matchSentProbe :: DB.Connection -> User -> ContactOrMember -> Probe -> IO (Maybe ContactOrMember) -matchSentProbe db user@User {userId} _from (Probe probe) = do - cgmIds $>>= getContactOrMember_ db user +matchSentProbe :: DB.Connection -> (PQSupport -> VersionRangeChat) -> User -> ContactOrMember -> Probe -> IO (Maybe ContactOrMember) +matchSentProbe db vr user@User {userId} _from (Probe probe) = do + cgmIds $>>= getContactOrMember_ db vr user where (ctId, gmId) = contactOrMemberIds _from cgmIds = @@ -1612,16 +1618,16 @@ matchSentProbe db user@User {userId} _from (Probe probe) = do |] (userId, probe, ctId, gmId) -getContactOrMember_ :: DB.Connection -> User -> (Maybe ContactId, Maybe GroupId, Maybe GroupMemberId) -> IO (Maybe ContactOrMember) -getContactOrMember_ db user ids = +getContactOrMember_ :: DB.Connection -> (PQSupport -> VersionRangeChat) -> User -> (Maybe ContactId, Maybe GroupId, Maybe GroupMemberId) -> IO (Maybe ContactOrMember) +getContactOrMember_ db vr user ids = fmap eitherToMaybe . runExceptT $ case ids of - (Just ctId, _, _) -> COMContact <$> getContact db user ctId - (_, Just gId, Just gmId) -> COMGroupMember <$> getGroupMember db user gId gmId + (Just ctId, _, _) -> COMContact <$> getContact db vr user ctId + (_, Just gId, Just gmId) -> COMGroupMember <$> getGroupMember db vr user gId gmId _ -> throwError $ SEInternalError "" -- if requested merge direction is overruled (toFromContacts), keepLDN is kept -mergeContactRecords :: DB.Connection -> User -> Contact -> Contact -> ExceptT StoreError IO Contact -mergeContactRecords db user@User {userId} to@Contact {localDisplayName = keepLDN} from = do +mergeContactRecords :: DB.Connection -> (PQSupport -> VersionRangeChat) -> User -> Contact -> Contact -> ExceptT StoreError IO Contact +mergeContactRecords db vr user@User {userId} to@Contact {localDisplayName = keepLDN} from = do let (toCt, fromCt) = toFromContacts to from Contact {contactId = toContactId, localDisplayName = toLDN} = toCt Contact {contactId = fromContactId, localDisplayName = fromLDN} = fromCt @@ -1679,7 +1685,7 @@ mergeContactRecords db user@User {userId} to@Contact {localDisplayName = keepLDN WHERE user_id = ? AND local_display_name = ? |] (keepLDN, currentTs, userId, toLDN) - getContact db user toContactId + getContact db vr user toContactId where toFromContacts :: Contact -> Contact -> (Contact, Contact) toFromContacts c1 c2 @@ -1710,9 +1716,10 @@ associateMemberWithContactRecord when (memProfileId /= profileId) $ deleteUnusedProfile_ db userId memProfileId when (memLDN /= localDisplayName) $ deleteUnusedDisplayName_ db userId memLDN -associateContactWithMemberRecord :: DB.Connection -> User -> GroupMember -> Contact -> ExceptT StoreError IO Contact +associateContactWithMemberRecord :: DB.Connection -> (PQSupport -> VersionRangeChat) -> User -> GroupMember -> Contact -> ExceptT StoreError IO Contact associateContactWithMemberRecord db + vr user@User {userId} GroupMember {groupId, groupMemberId, localDisplayName = memLDN, memberProfile = LocalProfile {profileId = memProfileId}} Contact {contactId, localDisplayName, profile = LocalProfile {profileId}} = do @@ -1736,7 +1743,7 @@ associateContactWithMemberRecord (memLDN, memProfileId, currentTs, userId, contactId) when (profileId /= memProfileId) $ deleteUnusedProfile_ db userId profileId when (localDisplayName /= memLDN) $ deleteUnusedDisplayName_ db userId localDisplayName - getContact db user contactId + getContact db vr user contactId deleteUnusedDisplayName_ :: DB.Connection -> UserId -> ContactName -> IO () deleteUnusedDisplayName_ db userId localDisplayName = @@ -1946,14 +1953,14 @@ 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 -> VersionRangeChat -> User -> ContactId -> ExceptT StoreError IO (GroupInfo, GroupMember, Contact, ConnReqInvitation) +getMemberContact :: DB.Connection -> (PQSupport -> VersionRangeChat) -> User -> ContactId -> ExceptT StoreError IO (GroupInfo, GroupMember, Contact, ConnReqInvitation) getMemberContact db vr user contactId = do - ct <- getContact db user contactId + ct <- getContact db vr 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 + m@GroupMember {groupId} <- getGroupMemberById db vr user groupMemberId g <- getGroupInfo db vr user groupId pure (g, m, ct, cReq) _ -> @@ -2126,7 +2133,7 @@ setXGrpLinkMemReceived db mId xGrpLinkMemReceived = do "UPDATE group_members SET xgrplinkmem_received = ?, updated_at = ? WHERE group_member_id = ?" (xGrpLinkMemReceived, currentTs, mId) -createNewUnknownGroupMember :: DB.Connection -> VersionRangeChat -> User -> GroupInfo -> MemberId -> Text -> ExceptT StoreError IO GroupMember +createNewUnknownGroupMember :: DB.Connection -> (PQSupport -> VersionRangeChat) -> User -> GroupInfo -> MemberId -> Text -> ExceptT StoreError IO GroupMember createNewUnknownGroupMember db vr user@User {userId, userContactId} GroupInfo {groupId} memberId memberName = do currentTs <- liftIO getCurrentTime let memberProfile = profileFromName memberName @@ -2146,12 +2153,12 @@ createNewUnknownGroupMember db vr user@User {userId, userContactId} GroupInfo {g :. (minV, maxV) ) insertedRowId db - getGroupMemberById db user groupMemberId + getGroupMemberById db vr user groupMemberId where - VersionRange minV maxV = vr + VersionRange minV maxV = vr PQSupportOff -updateUnknownMemberAnnounced :: DB.Connection -> User -> GroupMember -> GroupMember -> MemberInfo -> ExceptT StoreError IO GroupMember -updateUnknownMemberAnnounced db user@User {userId} invitingMember unknownMember@GroupMember {groupMemberId, memberChatVRange} MemberInfo {memberRole, v, profile} = do +updateUnknownMemberAnnounced :: DB.Connection -> (PQSupport -> VersionRangeChat) -> User -> GroupMember -> GroupMember -> MemberInfo -> ExceptT StoreError IO GroupMember +updateUnknownMemberAnnounced db vr user@User {userId} invitingMember unknownMember@GroupMember {groupMemberId, memberChatVRange} MemberInfo {memberRole, v, profile} = do _ <- updateMemberProfile db user unknownMember profile currentTs <- liftIO getCurrentTime liftIO $ @@ -2171,7 +2178,7 @@ updateUnknownMemberAnnounced db user@User {userId} invitingMember unknownMember@ ( (memberRole, GCPostMember, GSMemAnnounced, groupMemberId' invitingMember) :. (minV, maxV, currentTs, userId, groupMemberId) ) - getGroupMemberById db user groupMemberId + getGroupMemberById db vr user groupMemberId where VersionRange minV maxV = maybe memberChatVRange fromChatVRange v diff --git a/src/Simplex/Chat/Store/Messages.hs b/src/Simplex/Chat/Store/Messages.hs index 1a69e16e27..05b1a153b2 100644 --- a/src/Simplex/Chat/Store/Messages.hs +++ b/src/Simplex/Chat/Store/Messages.hs @@ -145,6 +145,7 @@ import Simplex.Messaging.Agent.Protocol (AgentMsgId, ConnId, MsgMeta (..), UserI import Simplex.Messaging.Agent.Store.SQLite (firstRow, firstRow', maybeFirstRow) import qualified Simplex.Messaging.Agent.Store.SQLite.DB as DB import qualified Simplex.Messaging.Crypto as C +import Simplex.Messaging.Crypto.Ratchet (PQSupport) import Simplex.Messaging.Crypto.File (CryptoFile (..), CryptoFileArgs (..)) import Simplex.Messaging.Util (eitherToMaybe) import UnliftIO.STM @@ -481,7 +482,7 @@ getChatItemQuote_ db User {userId, userContactId} chatDirection QuotedMsg {msgRe ciQuoteGroup [] = ciQuote Nothing $ CIQGroupRcv Nothing ciQuoteGroup ((Only itemId :. memberRow) : _) = ciQuote itemId . CIQGroupRcv . Just $ toGroupMember userContactId memberRow -getChatPreviews :: DB.Connection -> VersionRangeChat -> User -> Bool -> PaginationByTime -> ChatListQuery -> IO [Either StoreError AChat] +getChatPreviews :: DB.Connection -> (PQSupport -> VersionRangeChat) -> 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 @@ -504,7 +505,7 @@ getChatPreviews db vr user withPCC pagination query = do PTBefore _ count -> take count . sortBy (comparing $ Down . ts) getChatPreview :: AChatPreviewData -> ExceptT StoreError IO AChat getChatPreview (ACPD cType cpd) = case cType of - SCTDirect -> getDirectChatPreview_ db user cpd + SCTDirect -> getDirectChatPreview_ db vr user cpd SCTGroup -> getGroupChatPreview_ db vr user cpd SCTLocal -> getLocalChatPreview_ db user cpd SCTContactRequest -> let (ContactRequestPD _ chat) = cpd in pure chat @@ -618,9 +619,9 @@ findDirectChatPreviews_ db User {userId} pagination clq = ) ([":user_id" := userId, ":rcv_new" := CISRcvNew, ":search" := search] <> pagParams) -getDirectChatPreview_ :: DB.Connection -> User -> ChatPreviewData 'CTDirect -> ExceptT StoreError IO AChat -getDirectChatPreview_ db user (DirectChatPD _ contactId lastItemId_ stats) = do - contact <- getContact db user contactId +getDirectChatPreview_ :: DB.Connection -> (PQSupport -> VersionRangeChat) -> User -> ChatPreviewData 'CTDirect -> ExceptT StoreError IO AChat +getDirectChatPreview_ db vr user (DirectChatPD _ contactId lastItemId_ stats) = do + contact <- getContact db vr user contactId lastItem <- case lastItemId_ of Just lastItemId -> (: []) <$> getDirectChatItem db user contactId lastItemId Nothing -> pure [] @@ -714,7 +715,7 @@ findGroupChatPreviews_ db User {userId} pagination clq = ) ([":user_id" := userId, ":rcv_new" := CISRcvNew, ":search" := search] <> pagParams) -getGroupChatPreview_ :: DB.Connection -> VersionRangeChat -> User -> ChatPreviewData 'CTGroup -> ExceptT StoreError IO AChat +getGroupChatPreview_ :: DB.Connection -> (PQSupport -> VersionRangeChat) -> 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 @@ -919,10 +920,10 @@ getContactConnectionChatPreviews_ db User {userId} pagination clq = case clq of aChat = AChat SCTContactConnection $ Chat (ContactConnection conn) [] stats in ACPD SCTContactConnection $ ContactConnectionPD updatedAt aChat -getDirectChat :: DB.Connection -> User -> Int64 -> ChatPagination -> Maybe String -> ExceptT StoreError IO (Chat 'CTDirect) -getDirectChat db user contactId pagination search_ = do +getDirectChat :: DB.Connection -> (PQSupport -> VersionRangeChat) -> User -> Int64 -> ChatPagination -> Maybe String -> ExceptT StoreError IO (Chat 'CTDirect) +getDirectChat db vr user contactId pagination search_ = do let search = fromMaybe "" search_ - ct <- getContact db user contactId + ct <- getContact db vr user contactId liftIO $ case pagination of CPLast count -> getDirectChatLast_ db user ct count search CPAfter afterId count -> getDirectChatAfter_ db user ct afterId count search @@ -1039,7 +1040,7 @@ getDirectChatBefore_ db user@User {userId} ct@Contact {contactId} beforeChatItem |] (userId, contactId, search, beforeChatItemId, count) -getGroupChat :: DB.Connection -> VersionRangeChat -> User -> Int64 -> ChatPagination -> Maybe String -> ExceptT StoreError IO (Chat 'CTGroup) +getGroupChat :: DB.Connection -> (PQSupport -> VersionRangeChat) -> 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 vr user groupId @@ -1505,7 +1506,7 @@ toGroupChatItem currentTs userContactId (((itemId, itemTs, AMsgDirection msgDir, ciTimed :: Maybe CITimed ciTimed = timedTTL >>= \ttl -> Just CITimed {ttl, deleteAt = timedDeleteAt} -getAllChatItems :: DB.Connection -> VersionRangeChat -> User -> ChatPagination -> Maybe String -> ExceptT StoreError IO [AChatItem] +getAllChatItems :: DB.Connection -> (PQSupport -> VersionRangeChat) -> User -> ChatPagination -> Maybe String -> ExceptT StoreError IO [AChatItem] getAllChatItems db vr user@User {userId} pagination search_ = do itemRefs <- rights . map toChatItemRef <$> case pagination of @@ -2149,7 +2150,7 @@ deleteLocalChatItem db User {userId} NoteFolder {noteFolderId} ci = do |] (userId, noteFolderId, itemId) -getChatItemByFileId :: DB.Connection -> VersionRangeChat -> User -> Int64 -> ExceptT StoreError IO AChatItem +getChatItemByFileId :: DB.Connection -> (PQSupport -> VersionRangeChat) -> User -> Int64 -> ExceptT StoreError IO AChatItem getChatItemByFileId db vr user@User {userId} fileId = do (chatRef, itemId) <- ExceptT . firstRow' toChatItemRef (SEChatItemNotFoundByFileId fileId) $ @@ -2165,13 +2166,13 @@ getChatItemByFileId db vr user@User {userId} fileId = do (userId, fileId) getAChatItem db vr user chatRef itemId -lookupChatItemByFileId :: DB.Connection -> VersionRangeChat -> User -> Int64 -> ExceptT StoreError IO (Maybe AChatItem) +lookupChatItemByFileId :: DB.Connection -> (PQSupport -> VersionRangeChat) -> User -> Int64 -> ExceptT StoreError IO (Maybe AChatItem) lookupChatItemByFileId db vr user fileId = do fmap Just (getChatItemByFileId db vr user fileId) `catchError` \case SEChatItemNotFoundByFileId {} -> pure Nothing e -> throwError e -getChatItemByGroupId :: DB.Connection -> VersionRangeChat -> User -> GroupId -> ExceptT StoreError IO AChatItem +getChatItemByGroupId :: DB.Connection -> (PQSupport -> VersionRangeChat) -> User -> GroupId -> ExceptT StoreError IO AChatItem getChatItemByGroupId db vr user@User {userId} groupId = do (chatRef, itemId) <- ExceptT . firstRow' toChatItemRef (SEChatItemNotFoundByGroupId groupId) $ @@ -2197,10 +2198,10 @@ getChatRefViaItemId db User {userId} itemId = do (Nothing, Just groupId) -> Right $ ChatRef CTGroup groupId (_, _) -> Left $ SEBadChatItem itemId Nothing -getAChatItem :: DB.Connection -> VersionRangeChat -> User -> ChatRef -> ChatItemId -> ExceptT StoreError IO AChatItem +getAChatItem :: DB.Connection -> (PQSupport -> VersionRangeChat) -> 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 + ct <- getContact db vr user contactId (CChatItem msgDir ci) <- getDirectChatItem db user contactId itemId pure $ AChatItem SCTDirect msgDir (DirectChat ct) ci ChatRef CTGroup groupId -> do @@ -2437,9 +2438,9 @@ createCIModeration db GroupInfo {groupId} moderatorMember itemMemberId itemShare |] (groupId, groupMemberId' moderatorMember, itemMemberId, itemSharedMId, msgId, moderatedAtTs) -getCIModeration :: DB.Connection -> User -> GroupInfo -> MemberId -> Maybe SharedMsgId -> IO (Maybe CIModeration) -getCIModeration _ _ _ _ Nothing = pure Nothing -getCIModeration db user GroupInfo {groupId} itemMemberId (Just sharedMsgId) = do +getCIModeration :: DB.Connection -> (PQSupport -> VersionRangeChat) -> User -> GroupInfo -> MemberId -> Maybe SharedMsgId -> IO (Maybe CIModeration) +getCIModeration _ _ _ _ _ Nothing = pure Nothing +getCIModeration db vr user GroupInfo {groupId} itemMemberId (Just sharedMsgId) = do r_ <- maybeFirstRow id $ DB.query @@ -2453,7 +2454,7 @@ getCIModeration db user GroupInfo {groupId} itemMemberId (Just sharedMsgId) = do (groupId, itemMemberId, sharedMsgId) case r_ of Just (moderationId, moderatorId, createdByMsgId, moderatedAt) -> do - runExceptT (getGroupMember db user groupId moderatorId) >>= \case + runExceptT (getGroupMember db vr user groupId moderatorId) >>= \case Right moderatorMember -> pure (Just CIModeration {moderationId, moderatorMember, createdByMsgId, moderatedAt}) _ -> pure Nothing _ -> pure Nothing diff --git a/src/Simplex/Chat/Store/Profiles.hs b/src/Simplex/Chat/Store/Profiles.hs index 0d47982aca..512c857b23 100644 --- a/src/Simplex/Chat/Store/Profiles.hs +++ b/src/Simplex/Chat/Store/Profiles.hs @@ -86,6 +86,7 @@ import Simplex.Messaging.Agent.Store.SQLite (firstRow, maybeFirstRow) import qualified Simplex.Messaging.Agent.Store.SQLite.DB as DB import qualified Simplex.Messaging.Crypto as C import qualified Simplex.Messaging.Crypto.Ratchet as CR +import Simplex.Messaging.Crypto.Ratchet (PQSupport) import Simplex.Messaging.Encoding.String import Simplex.Messaging.Parsers (defaultJSON) import Simplex.Messaging.Protocol (BasicAuth (..), ProtoServerWithAuth (..), ProtocolServer (..), ProtocolTypeI (..), SubscriptionMode) @@ -324,16 +325,16 @@ createUserContactLink db User {userId} agentConnId cReq subMode = "INSERT INTO user_contact_links (user_id, conn_req_contact, created_at, updated_at) VALUES (?,?,?,?)" (userId, cReq, currentTs, currentTs) userContactLinkId <- insertedRowId db - void $ createConnection_ db userId ConnUserContact (Just userContactLinkId) agentConnId (Just initialChatVersion) chatInitialVRange Nothing Nothing Nothing 0 currentTs subMode CR.PQSupportOff + void $ createConnection_ db userId ConnUserContact (Just userContactLinkId) agentConnId initialChatVersion chatInitialVRange Nothing Nothing Nothing 0 currentTs subMode CR.PQSupportOff -getUserAddressConnections :: DB.Connection -> User -> ExceptT StoreError IO [Connection] -getUserAddressConnections db User {userId} = do +getUserAddressConnections :: DB.Connection -> (PQSupport -> VersionRangeChat) -> User -> ExceptT StoreError IO [Connection] +getUserAddressConnections db vr User {userId} = do cs <- liftIO getUserAddressConnections_ if null cs then throwError SEUserContactLinkNotFound else pure cs where getUserAddressConnections_ :: IO [Connection] getUserAddressConnections_ = - map toConnection + map (toConnection vr) <$> DB.query db [sql| @@ -347,8 +348,8 @@ getUserAddressConnections db User {userId} = do |] (userId, userId) -getUserContactLinks :: DB.Connection -> User -> IO [(Connection, UserContact)] -getUserContactLinks db User {userId} = +getUserContactLinks :: DB.Connection -> (PQSupport -> VersionRangeChat) -> User -> IO [(Connection, UserContact)] +getUserContactLinks db vr User {userId} = map toUserContactConnection <$> DB.query db @@ -365,7 +366,7 @@ getUserContactLinks db User {userId} = (userId, userId) where toUserContactConnection :: (ConnectionRow :. (Int64, ConnReqContact, Maybe GroupId)) -> (Connection, UserContact) - toUserContactConnection (connRow :. (userContactLinkId, connReqContact, groupId)) = (toConnection connRow, UserContact {userContactLinkId, connReqContact, groupId}) + toUserContactConnection (connRow :. (userContactLinkId, connReqContact, groupId)) = (toConnection vr connRow, UserContact {userContactLinkId, connReqContact, groupId}) deleteUserAddress :: DB.Connection -> User -> IO () deleteUserAddress db user@User {userId} = do @@ -473,8 +474,8 @@ getUserContactLinkByConnReq db User {userId} (cReqSchema1, cReqSchema2) = |] (userId, cReqSchema1, cReqSchema2) -getContactWithoutConnViaAddress :: DB.Connection -> User -> (ConnReqContact, ConnReqContact) -> IO (Maybe Contact) -getContactWithoutConnViaAddress db user@User {userId} (cReqSchema1, cReqSchema2) = do +getContactWithoutConnViaAddress :: DB.Connection -> (PQSupport -> VersionRangeChat) -> User -> (ConnReqContact, ConnReqContact) -> IO (Maybe Contact) +getContactWithoutConnViaAddress db vr user@User {userId} (cReqSchema1, cReqSchema2) = do ctId_ <- maybeFirstRow fromOnly $ DB.query @@ -487,7 +488,7 @@ getContactWithoutConnViaAddress db user@User {userId} (cReqSchema1, cReqSchema2) WHERE cp.user_id = ? AND cp.contact_link IN (?,?) AND c.connection_id IS NULL |] (userId, cReqSchema1, cReqSchema2) - maybe (pure Nothing) (fmap eitherToMaybe . runExceptT . getContact db user) ctId_ + maybe (pure Nothing) (fmap eitherToMaybe . runExceptT . getContact db vr user) ctId_ updateUserAddressAutoAccept :: DB.Connection -> User -> Maybe AutoAccept -> ExceptT StoreError IO UserContactLink updateUserAddressAutoAccept db user@User {userId} autoAccept = do diff --git a/src/Simplex/Chat/Store/Shared.hs b/src/Simplex/Chat/Store/Shared.hs index 0650dd23de..6d5c41c1a5 100644 --- a/src/Simplex/Chat/Store/Shared.hs +++ b/src/Simplex/Chat/Store/Shared.hs @@ -155,13 +155,13 @@ type ConnectionRow = (Int64, ConnId, Int, Maybe Int64, Maybe Int64, Bool, Maybe type MaybeConnectionRow = (Maybe Int64, Maybe ConnId, Maybe Int, Maybe Int64, Maybe Int64, Maybe Bool, Maybe GroupLinkId, Maybe Int64, Maybe ConnStatus, Maybe ConnType, Maybe Bool, Maybe LocalAlias) :. EntityIdsRow :. (Maybe UTCTime, Maybe Text, Maybe UTCTime, Maybe PQSupport, Maybe PQEncryption, Maybe PQEncryption, Maybe PQEncryption, Maybe Int, Maybe VersionChat, Maybe VersionChat, Maybe VersionChat) -toConnection :: ConnectionRow -> Connection -toConnection ((connId, acId, connLevel, viaContact, viaUserContactLink, viaGroupLink, groupLinkId, customUserProfileId, connStatus, connType, contactConnInitiated, localAlias) :. (contactId, groupMemberId, sndFileId, rcvFileId, userContactLinkId) :. (createdAt, code_, verifiedAt_, pqSupport, pqEncryption, pqSndEnabled, pqRcvEnabled, authErrCounter, connChatVersion, minVer, maxVer)) = +toConnection :: (PQSupport -> VersionRangeChat) -> ConnectionRow -> Connection +toConnection vr ((connId, acId, connLevel, viaContact, viaUserContactLink, viaGroupLink, groupLinkId, customUserProfileId, connStatus, connType, contactConnInitiated, localAlias) :. (contactId, groupMemberId, sndFileId, rcvFileId, userContactLinkId) :. (createdAt, code_, verifiedAt_, pqSupport, pqEncryption, pqSndEnabled, pqRcvEnabled, authErrCounter, chatV, minVer, maxVer)) = Connection { connId, agentConnId = AgentConnId acId, - connChatVersion, -- TODO we could avoid maybe here by computing compatible version, but it would require passing current version range here as well - peerChatVRange = fromMaybe (versionToRange maxVer) $ safeVersionRange minVer maxVer, + connChatVersion = fromMaybe (vr pqSupport `peerConnChatVersion` peerChatVRange) chatV, + peerChatVRange = peerChatVRange, connLevel, viaContact, viaUserContactLink, @@ -182,6 +182,7 @@ toConnection ((connId, acId, connLevel, viaContact, viaUserContactLink, viaGroup createdAt } where + peerChatVRange = fromMaybe (versionToRange maxVer) $ safeVersionRange minVer maxVer entityId_ :: ConnType -> Maybe Int64 entityId_ ConnContact = contactId entityId_ ConnMember = groupMemberId @@ -189,12 +190,12 @@ toConnection ((connId, acId, connLevel, viaContact, viaUserContactLink, viaGroup entityId_ ConnSndFile = sndFileId entityId_ ConnUserContact = userContactLinkId -toMaybeConnection :: MaybeConnectionRow -> Maybe Connection -toMaybeConnection ((Just connId, Just agentConnId, Just connLevel, viaContact, viaUserContactLink, Just viaGroupLink, groupLinkId, customUserProfileId, Just connStatus, Just connType, Just contactConnInitiated, Just localAlias) :. (contactId, groupMemberId, sndFileId, rcvFileId, userContactLinkId) :. (Just createdAt, code_, verifiedAt_, Just pqSupport, Just pqEncryption, pqSndEnabled_, pqRcvEnabled_, Just authErrCounter, connChatVersion, Just minVer, Just maxVer)) = - Just $ toConnection ((connId, agentConnId, connLevel, viaContact, viaUserContactLink, viaGroupLink, groupLinkId, customUserProfileId, connStatus, connType, contactConnInitiated, localAlias) :. (contactId, groupMemberId, sndFileId, rcvFileId, userContactLinkId) :. (createdAt, code_, verifiedAt_, pqSupport, pqEncryption, pqSndEnabled_, pqRcvEnabled_, authErrCounter, connChatVersion, minVer, maxVer)) -toMaybeConnection _ = Nothing +toMaybeConnection :: (PQSupport -> VersionRangeChat) -> MaybeConnectionRow -> Maybe Connection +toMaybeConnection vr ((Just connId, Just agentConnId, Just connLevel, viaContact, viaUserContactLink, Just viaGroupLink, groupLinkId, customUserProfileId, Just connStatus, Just connType, Just contactConnInitiated, Just localAlias) :. (contactId, groupMemberId, sndFileId, rcvFileId, userContactLinkId) :. (Just createdAt, code_, verifiedAt_, Just pqSupport, Just pqEncryption, pqSndEnabled_, pqRcvEnabled_, Just authErrCounter, connChatVersion, Just minVer, Just maxVer)) = + Just $ toConnection vr ((connId, agentConnId, connLevel, viaContact, viaUserContactLink, viaGroupLink, groupLinkId, customUserProfileId, connStatus, connType, contactConnInitiated, localAlias) :. (contactId, groupMemberId, sndFileId, rcvFileId, userContactLinkId) :. (createdAt, code_, verifiedAt_, pqSupport, pqEncryption, pqSndEnabled_, pqRcvEnabled_, authErrCounter, connChatVersion, minVer, maxVer)) +toMaybeConnection _ _ = Nothing -createConnection_ :: DB.Connection -> UserId -> ConnType -> Maybe Int64 -> ConnId -> Maybe VersionChat -> VersionRangeChat -> Maybe ContactId -> Maybe Int64 -> Maybe ProfileId -> Int -> UTCTime -> SubscriptionMode -> PQSupport -> IO Connection +createConnection_ :: DB.Connection -> UserId -> ConnType -> Maybe Int64 -> ConnId -> VersionChat -> VersionRangeChat -> Maybe ContactId -> Maybe Int64 -> Maybe ProfileId -> Int -> UTCTime -> SubscriptionMode -> PQSupport -> IO Connection createConnection_ db userId connType entityId acId connChatVersion peerChatVRange@(VersionRange minV maxV) viaContact viaUserContactLink customUserProfileId connLevel currentTs subMode pqSup = do viaLinkGroupId :: Maybe Int64 <- fmap join . forM viaUserContactLink $ \ucLinkId -> maybeFirstRow fromOnly $ DB.query db "SELECT group_id FROM user_contact_links WHERE user_id = ? AND user_contact_link_id = ? AND group_id IS NOT NULL" (userId, ucLinkId) @@ -296,7 +297,7 @@ updateConnPQEnabledCON db connId pqEnabled = |] (pqEnabled, pqEnabled, connId) -setPeerChatVRange :: DB.Connection -> Int64 -> Maybe VersionChat -> VersionRangeChat -> IO () +setPeerChatVRange :: DB.Connection -> Int64 -> VersionChat -> VersionRangeChat -> IO () setPeerChatVRange db connId chatV (VersionRange minVer maxVer) = DB.execute db @@ -370,10 +371,10 @@ deleteUnusedIncognitoProfileById_ db User {userId} profileId = type ContactRow = (ContactId, ProfileId, ContactName, Maybe Int64, ContactName, Text, Maybe ImageData, Maybe ConnReqContact, LocalAlias, Bool, ContactStatus) :. (Maybe MsgFilter, Maybe Bool, Bool, Maybe Preferences, Preferences, UTCTime, UTCTime, Maybe UTCTime, Maybe GroupMemberId, Bool) -toContact :: User -> ContactRow :. MaybeConnectionRow -> Contact -toContact user (((contactId, profileId, localDisplayName, viaGroup, displayName, fullName, image, contactLink, localAlias, contactUsed, contactStatus) :. (enableNtfs_, sendRcpts, favorite, preferences, userPreferences, createdAt, updatedAt, chatTs, contactGroupMemberId, contactGrpInvSent)) :. connRow) = +toContact :: (PQSupport -> VersionRangeChat) -> User -> ContactRow :. MaybeConnectionRow -> Contact +toContact vr user (((contactId, profileId, localDisplayName, viaGroup, displayName, fullName, image, contactLink, localAlias, contactUsed, contactStatus) :. (enableNtfs_, sendRcpts, favorite, preferences, userPreferences, createdAt, updatedAt, chatTs, contactGroupMemberId, contactGrpInvSent)) :. connRow) = let profile = LocalProfile {profileId, displayName, fullName, image, contactLink, preferences, localAlias} - activeConn = toMaybeConnection connRow + activeConn = toMaybeConnection vr connRow chatSettings = ChatSettings {enableNtfs = fromMaybe MFAll enableNtfs_, sendRcpts, favorite} incognito = maybe False connIncognito activeConn mergedPreferences = contactUserPreferences user userPreferences preferences incognito diff --git a/src/Simplex/Chat/Types.hs b/src/Simplex/Chat/Types.hs index 18fe5ad1ac..f16913439d 100644 --- a/src/Simplex/Chat/Types.hs +++ b/src/Simplex/Chat/Types.hs @@ -1291,7 +1291,7 @@ type ConnReqContact = ConnectionRequestUri 'CMContact data Connection = Connection { connId :: Int64, agentConnId :: AgentConnId, - connChatVersion :: Maybe VersionChat, + connChatVersion :: VersionChat, peerChatVRange :: VersionRangeChat, connLevel :: Int, viaContact :: Maybe Int64, -- group member contact ID, if not direct connection @@ -1649,6 +1649,13 @@ pattern VersionChat v = Version v -- this newtype exists to have a concise JSON encoding of version ranges in chat protocol messages in the form of "1-2" or just "1" newtype ChatVersionRange = ChatVersionRange {fromChatVRange :: VersionRangeChat} deriving (Eq, Show) +-- TODO v6.0 review +peerConnChatVersion :: VersionRangeChat -> VersionRangeChat -> VersionChat +peerConnChatVersion _local@(VersionRange lmin lmax) _peer@(VersionRange rmin rmax) + | lmin <= rmax && rmin <= lmax = min lmax rmax -- compatible + | rmin > lmax = rmin + | otherwise = rmax + initialChatVersion :: VersionChat initialChatVersion = VersionChat 1 diff --git a/tests/ChatTests/Utils.hs b/tests/ChatTests/Utils.hs index 16a75377fd..fe80a1a532 100644 --- a/tests/ChatTests/Utils.hs +++ b/tests/ChatTests/Utils.hs @@ -586,13 +586,13 @@ pqRcvForContact :: TestCC -> ContactId -> IO PQEncryption pqRcvForContact = pqForContact_ pqRcvEnabled PQEncOff pqForContact :: TestCC -> ContactId -> IO PQEncryption -pqForContact = pqForContact_ (Just . connPQEnabled) PQEncOff +pqForContact = pqForContact_ (Just . connPQEnabled) (error "impossible") pqSupportForCt :: TestCC -> ContactId -> IO PQSupport pqSupportForCt = pqForContact_ (\Connection {pqSupport} -> Just pqSupport) PQSupportOff pqVerForContact :: TestCC -> ContactId -> IO VersionChat -pqVerForContact = pqForContact_ connChatVersion (VersionChat 0) +pqVerForContact = pqForContact_ (Just . connChatVersion) (error "impossible") pqForContact_ :: (Connection -> Maybe a) -> a -> TestCC -> ContactId -> IO a pqForContact_ pqSel def cc contactId = (fromMaybe def . pqSel) <$> getCtConn cc contactId @@ -601,10 +601,11 @@ getCtConn :: TestCC -> ContactId -> IO Connection getCtConn cc contactId = getTestCCContact cc contactId >>= maybe (fail "no connection") pure . contactConn getTestCCContact :: TestCC -> ContactId -> IO Contact -getTestCCContact cc contactId = +getTestCCContact cc contactId = do + let TestCC {chatController = ChatController {config = ChatConfig {chatVRange = vr}}} = cc withCCTransaction cc $ \db -> withCCUser cc $ \user -> - runExceptT (getContact db user contactId) >>= either (fail . show) pure + runExceptT (getContact db vr user contactId) >>= either (fail . show) pure lastItemId :: HasCallStack => TestCC -> IO String lastItemId cc = do