From ca166d7f96f87801099e21c23547fc9203e14e10 Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin Date: Mon, 29 Jul 2024 15:12:18 +0100 Subject: [PATCH] use priority database access --- cabal.project | 2 +- scripts/nix/sha256map.nix | 2 +- src/Simplex/Chat.hs | 553 +++++++++++++++++---------------- src/Simplex/Chat/Controller.hs | 19 +- 4 files changed, 295 insertions(+), 281 deletions(-) diff --git a/cabal.project b/cabal.project index 5767cbfa97..e7f15c90ad 100644 --- a/cabal.project +++ b/cabal.project @@ -12,7 +12,7 @@ constraints: zip +disable-bzip2 +disable-zstd source-repository-package type: git location: https://github.com/simplex-chat/simplexmq.git - tag: 2de16cfae89661605b468df71eff8b8e8188ef86 + tag: 26b35e284f2c98752ff7b9b7239d9eca3945550f source-repository-package type: git diff --git a/scripts/nix/sha256map.nix b/scripts/nix/sha256map.nix index ceae107df5..cecf0b1120 100644 --- a/scripts/nix/sha256map.nix +++ b/scripts/nix/sha256map.nix @@ -1,5 +1,5 @@ { - "https://github.com/simplex-chat/simplexmq.git"."2de16cfae89661605b468df71eff8b8e8188ef86" = "00bgpy3gygqhmcbb2r5i8kryc5vn667bdg5s3xl3lf7y9m13g047"; + "https://github.com/simplex-chat/simplexmq.git"."26b35e284f2c98752ff7b9b7239d9eca3945550f" = "01il40awlx3aw6cmc2h1yv8x6x510kfirw7qc4aar79h22rhdcj1"; "https://github.com/simplex-chat/hs-socks.git"."a30cc7a79a08d8108316094f8f2f82a0c5e1ac51" = "0yasvnr7g91k76mjkamvzab2kvlb1g5pspjyjn2fr6v83swjhj38"; "https://github.com/simplex-chat/direct-sqlcipher.git"."f814ee68b16a9447fbb467ccc8f29bdd3546bfd9" = "1ql13f4kfwkbaq7nygkxgw84213i0zm7c1a8hwvramayxl38dq5d"; "https://github.com/simplex-chat/sqlcipher-simple.git"."a46bd361a19376c5211f1058908fc0ae6bf42446" = "1z0r78d8f0812kxbgsm735qf6xx8lvaz27k1a0b4a2m0sshpd5gl"; diff --git a/src/Simplex/Chat.hs b/src/Simplex/Chat.hs index 0d85d6a7cd..2afe0d13ee 100644 --- a/src/Simplex/Chat.hs +++ b/src/Simplex/Chat.hs @@ -389,7 +389,7 @@ startChatController :: Bool -> Bool -> CM' (Async ()) startChatController mainApp enableSndFiles = do asks smpAgent >>= liftIO . resumeAgentClient unless mainApp $ chatWriteVar' subscriptionMode SMOnlyCreate - users <- fromRight [] <$> runExceptT (withStore' getUsers) + users <- fromRight [] <$> runExceptT (withFastStore' getUsers) restoreCalls s <- asks agentAsync readTVarIO s >>= maybe (start s users) (pure . fst) @@ -457,7 +457,7 @@ startReceiveUserFiles user = do restoreCalls :: CM' () restoreCalls = do - savedCalls <- fromRight [] <$> runExceptT (withStore' getCalls) + savedCalls <- fromRight [] <$> runExceptT (withFastStore' getCalls) let callsMap = M.fromList $ map (\call@Call {contactId} -> (contactId, call)) savedCalls calls <- asks currentCalls atomically $ writeTVar calls callsMap @@ -529,15 +529,15 @@ processChatCommand' vr = \case u <- asks currentUser (smp, smpServers) <- chooseServers SPSMP (xftp, xftpServers) <- chooseServers SPXFTP - users <- withStore' getUsers + users <- withFastStore' getUsers forM_ users $ \User {localDisplayName = n, activeUser, viewPwdHash} -> when (n == displayName) . throwChatError $ if activeUser || isNothing viewPwdHash then CEUserExists displayName else CEInvalidDisplayName {displayName, validName = ""} auId <- withAgent (\a -> createUser a smp xftp) ts <- liftIO $ getCurrentTime >>= if pastTimestamp then coupleDaysAgo else pure - user <- withStore $ \db -> createUserRecordAt db (AgentUserId auId) p True ts - when (null users) $ withStore (\db -> createContact db user simplexContactProfile) `catchChatError` \_ -> pure () - withStore $ \db -> createNoteFolder db user + user <- withFastStore $ \db -> createUserRecordAt db (AgentUserId auId) p True ts + when (null users) $ withFastStore (\db -> createContact db user simplexContactProfile) `catchChatError` \_ -> pure () + withFastStore $ \db -> createNoteFolder db user storeServers user smpServers storeServers user xftpServers atomically . writeTVar u $ Just user @@ -548,42 +548,42 @@ processChatCommand' vr = \case | sameServers = asks currentUser >>= readTVarIO >>= \case Nothing -> throwChatError CENoActiveUser - Just user -> chosenServers =<< withStore' (`getProtocolServers` user) + Just user -> chosenServers =<< withFastStore' (`getProtocolServers` user) | otherwise = chosenServers [] where chosenServers servers = do cfg <- asks config pure (useServers cfg protocol servers, servers) storeServers user servers = - unless (null servers) . withStore $ + unless (null servers) . withFastStore $ \db -> overwriteProtocolServers db user servers coupleDaysAgo t = (`addUTCTime` t) . fromInteger . negate . (+ (2 * day)) <$> randomRIO (0, day) day = 86400 - ListUsers -> CRUsersList <$> withStore' getUsersInfo + ListUsers -> CRUsersList <$> withFastStore' getUsersInfo APISetActiveUser userId' viewPwd_ -> do unlessM (lift chatStarted) $ throwChatError CEChatNotStarted user_ <- chatReadVar currentUser user' <- privateGetUser userId' validateUserPassword_ user_ user' viewPwd_ - withStore' (`setActiveUser` userId') + withFastStore' (`setActiveUser` userId') let user'' = user' {activeUser = True} chatWriteVar currentUser $ Just user'' pure $ CRActiveUser user'' SetActiveUser uName viewPwd_ -> do - tryChatError (withStore (`getUserIdByName` uName)) >>= \case + tryChatError (withFastStore (`getUserIdByName` uName)) >>= \case Left _ -> throwChatError CEUserUnknown Right userId -> processChatCommand $ APISetActiveUser userId viewPwd_ - SetAllContactReceipts onOff -> withUser $ \_ -> withStore' (`updateAllContactReceipts` onOff) >> ok_ + SetAllContactReceipts onOff -> withUser $ \_ -> withFastStore' (`updateAllContactReceipts` onOff) >> ok_ APISetUserContactReceipts userId' settings -> withUser $ \user -> do user' <- privateGetUser userId' validateUserPassword user user' Nothing - withStore' $ \db -> updateUserContactReceipts db user' settings + withFastStore' $ \db -> updateUserContactReceipts db user' settings ok user SetUserContactReceipts settings -> withUser $ \User {userId} -> processChatCommand $ APISetUserContactReceipts userId settings APISetUserGroupReceipts userId' settings -> withUser $ \user -> do user' <- privateGetUser userId' validateUserPassword user user' Nothing - withStore' $ \db -> updateUserGroupReceipts db user' settings + withFastStore' $ \db -> updateUserGroupReceipts db user' settings ok user SetUserGroupReceipts settings -> withUser $ \User {userId} -> processChatCommand $ APISetUserGroupReceipts userId settings APIHideUser userId' (UserPwd viewPwd) -> withUser $ \user -> do @@ -592,7 +592,7 @@ processChatCommand' vr = \case Just _ -> throwChatError $ CEUserAlreadyHidden userId' _ -> do when (T.null viewPwd) $ throwChatError $ CEEmptyUserPassword userId' - users <- withStore' getUsers + users <- withFastStore' getUsers unless (length (filter (isNothing . viewPwdHash) users) > 1) $ throwChatError $ CECantHideLastUser userId' viewPwdHash' <- hashPassword setUserPrivacy user user' {viewPwdHash = viewPwdHash', showNtfs = False} @@ -633,7 +633,7 @@ processChatCommand' vr = \case lift $ withAgent' foregroundAgent chatWriteVar chatActivated True when restoreChat $ do - users <- withStore' getUsers + users <- withFastStore' getUsers lift $ do void . forkIO $ subscribeUsers True users void . forkIO $ startFilesToReceive users @@ -681,8 +681,8 @@ processChatCommand' vr = \case fileErrs <- lift $ importArchive cfg setStoreChanged pure $ CRArchiveImported fileErrs - APISaveAppSettings as -> withStore' (`saveAppSettings` as) >> ok_ - APIGetAppSettings platformDefaults -> CRAppSettings <$> withStore' (`getAppSettings` platformDefaults) + APISaveAppSettings as -> withFastStore' (`saveAppSettings` as) >> ok_ + APIGetAppSettings platformDefaults -> CRAppSettings <$> withFastStore' (`getAppSettings` platformDefaults) APIDeleteStorage -> withStoreChanged deleteStorage APIStorageEncryption cfg -> withStoreChanged $ sqlCipherExport cfg TestStorageEncryption key -> sqlCipherTestKey key >> ok_ @@ -701,31 +701,31 @@ processChatCommand' vr = \case . M.assocs <$> withConnection st (readTVarIO . DB.slow) APIGetChats {userId, pendingConnections, pagination, query} -> withUserId' userId $ \user -> do - (errs, previews) <- partitionEithers <$> withStore' (\db -> getChatPreviews db vr user pendingConnections pagination query) + (errs, previews) <- partitionEithers <$> withFastStore' (\db -> getChatPreviews db vr user pendingConnections pagination query) unless (null errs) $ toView $ CRChatErrors (Just user) (map ChatErrorStore errs) pure $ CRApiChats user previews APIGetChat (ChatRef cType cId) pagination search -> withUser $ \user -> case cType of -- TODO optimize queries calculating ChatStats, currently they're disabled CTDirect -> do - directChat <- withStore (\db -> getDirectChat db vr user cId pagination search) + directChat <- withFastStore (\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) + groupChat <- withFastStore (\db -> getGroupChat db vr user cId pagination search) pure $ CRApiChat user (AChat SCTGroup groupChat) CTLocal -> do - localChat <- withStore (\db -> getLocalChat db user cId pagination search) + localChat <- withFastStore (\db -> getLocalChat db user cId pagination search) pure $ CRApiChat user (AChat SCTLocal localChat) CTContactRequest -> pure $ chatCmdError (Just user) "not implemented" CTContactConnection -> pure $ chatCmdError (Just user) "not supported" APIGetChatItems pagination search -> withUser $ \user -> do - chatItems <- withStore $ \db -> getAllChatItems db vr user pagination search + chatItems <- withFastStore $ \db -> getAllChatItems db vr user pagination search pure $ CRChatItems user Nothing chatItems APIGetChatItemInfo chatRef itemId -> withUser $ \user -> do - (aci@(AChatItem cType dir _ ci), versions) <- withStore $ \db -> + (aci@(AChatItem cType dir _ ci), versions) <- withFastStore $ \db -> (,) <$> getAChatItem db vr user chatRef itemId <*> liftIO (getChatItemVersions db itemId) let itemVersions = if null versions then maybeToList $ mkItemVersion ci else versions memberDeliveryStatuses <- case (cType, dir) of - (SCTGroup, SMDSnd) -> L.nonEmpty <$> withStore' (`getGroupSndStatuses` itemId) + (SCTGroup, SMDSnd) -> L.nonEmpty <$> withFastStore' (`getGroupSndStatuses` itemId) _ -> pure Nothing forwardedFromChatItem <- getForwardedFromItem user ci pure $ CRChatItemInfo user aci ChatItemInfo {itemVersions, memberDeliveryStatuses, forwardedFromChatItem} @@ -733,9 +733,9 @@ processChatCommand' vr = \case getForwardedFromItem :: User -> ChatItem c d -> CM (Maybe AChatItem) getForwardedFromItem user ChatItem {meta = CIMeta {itemForwarded}} = case itemForwarded of Just (CIFFContact _ _ (Just ctId) (Just fwdItemId)) -> - Just <$> withStore (\db -> getAChatItem db vr user (ChatRef CTDirect ctId) fwdItemId) + Just <$> withFastStore (\db -> getAChatItem db vr user (ChatRef CTDirect ctId) fwdItemId) Just (CIFFGroup _ _ (Just gId) (Just fwdItemId)) -> - Just <$> withStore (\db -> getAChatItem db vr user (ChatRef CTGroup gId) fwdItemId) + Just <$> withFastStore (\db -> getAChatItem db vr user (ChatRef CTGroup gId) fwdItemId) _ -> pure Nothing APISendMessage (ChatRef cType chatId) live itemTTL cm -> withUser $ \user -> case cType of CTDirect -> @@ -751,9 +751,9 @@ processChatCommand' vr = \case createNoteFolderContentItem user folderId cm Nothing APIUpdateChatItem (ChatRef cType chatId) itemId live mc -> withUser $ \user -> case cType of CTDirect -> withContactLock "updateChatItem" chatId $ do - ct@Contact {contactId} <- withStore $ \db -> getContact db vr user chatId + ct@Contact {contactId} <- withFastStore $ \db -> getContact db vr user chatId assertDirectAllowed user MDSnd ct XMsgUpdate_ - cci <- withStore $ \db -> getDirectCIWithReactions db user ct itemId + cci <- withFastStore $ \db -> getDirectCIWithReactions db user ct itemId case cci of CChatItem SMDSnd ci@ChatItem {meta = CIMeta {itemSharedMsgId, itemTimed, itemLive, editable}, content = ciContent} -> do case (ciContent, itemSharedMsgId, editable) of @@ -762,7 +762,7 @@ processChatCommand' vr = \case if changed || fromMaybe False itemLive then do (SndMessage {msgId}, _) <- sendDirectContactMessage user ct (XMsgUpdate itemSharedMId mc (ttl' <$> itemTimed) (justTrue . (live &&) =<< itemLive)) - ci' <- withStore' $ \db -> do + ci' <- withFastStore' $ \db -> do currentTs <- liftIO getCurrentTime when changed $ addInitialAndNewCIVersions db itemId (chatItemTs' ci, oldMC) (currentTs, mc) @@ -774,12 +774,12 @@ processChatCommand' vr = \case _ -> throwChatError CEInvalidChatItemUpdate CChatItem SMDRcv _ -> throwChatError CEInvalidChatItemUpdate CTGroup -> withGroupLock "updateChatItem" chatId $ do - Group gInfo@GroupInfo {groupId, membership} ms <- withStore $ \db -> getGroup db vr user chatId + Group gInfo@GroupInfo {groupId, membership} ms <- withFastStore $ \db -> getGroup db vr user chatId assertUserGroupRole gInfo GRAuthor if prohibitedSimplexLinks gInfo membership mc then pure $ chatCmdError (Just user) ("feature not allowed " <> T.unpack (groupFeatureNameText GFSimplexLinks)) else do - cci <- withStore $ \db -> getGroupCIWithReactions db user gInfo itemId + cci <- withFastStore $ \db -> getGroupCIWithReactions db user gInfo itemId case cci of CChatItem SMDSnd ci@ChatItem {meta = CIMeta {itemSharedMsgId, itemTimed, itemLive, editable}, content = ciContent} -> do case (ciContent, itemSharedMsgId, editable) of @@ -788,7 +788,7 @@ processChatCommand' vr = \case if changed || fromMaybe False itemLive then do (SndMessage {msgId}, _) <- sendGroupMessage user gInfo ms (XMsgUpdate itemSharedMId mc (ttl' <$> itemTimed) (justTrue . (live &&) =<< itemLive)) - ci' <- withStore' $ \db -> do + ci' <- withFastStore' $ \db -> do currentTs <- liftIO getCurrentTime when changed $ addInitialAndNewCIVersions db itemId (chatItemTs' ci, oldMC) (currentTs, mc) @@ -800,11 +800,11 @@ processChatCommand' vr = \case _ -> throwChatError CEInvalidChatItemUpdate CChatItem SMDRcv _ -> throwChatError CEInvalidChatItemUpdate CTLocal -> do - (nf@NoteFolder {noteFolderId}, cci) <- withStore $ \db -> (,) <$> getNoteFolder db user chatId <*> getLocalChatItem db user chatId itemId + (nf@NoteFolder {noteFolderId}, cci) <- withFastStore $ \db -> (,) <$> getNoteFolder db user chatId <*> getLocalChatItem db user chatId itemId case cci of CChatItem SMDSnd ci@ChatItem {content = CISndMsgContent oldMC} | mc == oldMC -> pure $ CRChatItemNotChanged user (AChatItem SCTLocal SMDSnd (LocalChat nf) ci) - | otherwise -> withStore' $ \db -> do + | otherwise -> withFastStore' $ \db -> do currentTs <- getCurrentTime addInitialAndNewCIVersions db itemId (chatItemTs' ci, oldMC) (currentTs, mc) ci' <- updateLocalChatItem' db user noteFolderId ci (CISndMsgContent mc) True @@ -814,7 +814,7 @@ processChatCommand' vr = \case CTContactConnection -> pure $ chatCmdError (Just user) "not supported" APIDeleteChatItem (ChatRef cType chatId) itemId mode -> withUser $ \user -> case cType of CTDirect -> withContactLock "deleteChatItem" chatId $ do - (ct, CChatItem msgDir ci@ChatItem {meta = CIMeta {itemSharedMsgId, deletable}}) <- withStore $ \db -> (,) <$> getContact db vr user chatId <*> getDirectChatItem db user chatId itemId + (ct, CChatItem msgDir ci@ChatItem {meta = CIMeta {itemSharedMsgId, deletable}}) <- withFastStore $ \db -> (,) <$> getContact db vr user chatId <*> getDirectChatItem db user chatId itemId case (mode, msgDir, itemSharedMsgId, deletable) of (CIDMInternal, _, _, _) -> deleteDirectCI user ct ci True False (CIDMBroadcast, SMDSnd, Just itemSharedMId, True) -> do @@ -825,8 +825,8 @@ processChatCommand' vr = \case else markDirectCIDeleted user ct ci msgId True =<< liftIO getCurrentTime (CIDMBroadcast, _, _, _) -> throwChatError CEInvalidChatItemDelete CTGroup -> withGroupLock "deleteChatItem" chatId $ do - Group gInfo ms <- withStore $ \db -> getGroup db vr user chatId - CChatItem msgDir ci@ChatItem {meta = CIMeta {itemSharedMsgId, deletable}} <- withStore $ \db -> getGroupChatItem db user chatId itemId + Group gInfo ms <- withFastStore $ \db -> getGroup db vr user chatId + CChatItem msgDir ci@ChatItem {meta = CIMeta {itemSharedMsgId, deletable}} <- withFastStore $ \db -> getGroupChatItem db user chatId itemId case (mode, msgDir, itemSharedMsgId, deletable) of (CIDMInternal, _, _, _) -> deleteGroupCI user gInfo ci True False Nothing =<< liftIO getCurrentTime (CIDMBroadcast, SMDSnd, Just itemSharedMId, True) -> do @@ -835,13 +835,13 @@ processChatCommand' vr = \case delGroupChatItem user gInfo ci msgId Nothing (CIDMBroadcast, _, _, _) -> throwChatError CEInvalidChatItemDelete CTLocal -> do - (nf, CChatItem _ ci) <- withStore $ \db -> (,) <$> getNoteFolder db user chatId <*> getLocalChatItem db user chatId itemId + (nf, CChatItem _ ci) <- withFastStore $ \db -> (,) <$> getNoteFolder db user chatId <*> getLocalChatItem db user chatId itemId deleteLocalCI user nf ci True False CTContactRequest -> pure $ chatCmdError (Just user) "not supported" CTContactConnection -> pure $ chatCmdError (Just user) "not supported" APIDeleteMemberChatItem gId mId itemId -> withUser $ \user -> withGroupLock "deleteChatItem" gId $ do - Group gInfo@GroupInfo {membership} ms <- withStore $ \db -> getGroup db vr user gId - CChatItem _ ci@ChatItem {chatDir, meta = CIMeta {itemSharedMsgId}} <- withStore $ \db -> getGroupChatItem db user gId itemId + Group gInfo@GroupInfo {membership} ms <- withFastStore $ \db -> getGroup db vr user gId + CChatItem _ ci@ChatItem {chatDir, meta = CIMeta {itemSharedMsgId}} <- withFastStore $ \db -> getGroupChatItem db user gId itemId case (chatDir, itemSharedMsgId) of (CIGroupRcv GroupMember {groupMemberId, memberRole, memberId}, Just itemSharedMId) -> do when (groupMemberId /= mId) $ throwChatError CEInvalidChatItemDelete @@ -852,17 +852,17 @@ processChatCommand' vr = \case APIChatItemReaction (ChatRef cType chatId) itemId add reaction -> withUser $ \user -> case cType of CTDirect -> withContactLock "chatItemReaction" chatId $ - withStore (\db -> (,) <$> getContact db vr user chatId <*> getDirectChatItem db user chatId itemId) >>= \case + withFastStore (\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)) unless (ciReactionAllowed ci) $ throwChatError (CECommandError "reaction not allowed - chat item has no content") - rs <- withStore' $ \db -> getDirectReactions db ct itemSharedMId True + rs <- withFastStore' $ \db -> getDirectReactions db ct itemSharedMId True checkReactionAllowed rs (SndMessage {msgId}, _) <- sendDirectContactMessage user ct $ XMsgReact itemSharedMId Nothing reaction add createdAt <- liftIO getCurrentTime - reactions <- withStore' $ \db -> do + reactions <- withFastStore' $ \db -> do setDirectReaction db ct itemSharedMId True reaction add msgId createdAt liftIO $ getDirectCIReactions db ct itemSharedMId let ci' = CChatItem md ci {reactions} @@ -871,18 +871,18 @@ processChatCommand' vr = \case _ -> throwChatError $ CECommandError "reaction not possible - no shared item ID" CTGroup -> withGroupLock "chatItemReaction" chatId $ - withStore (\db -> (,) <$> getGroup db vr user chatId <*> getGroupChatItem db user chatId itemId) >>= \case + withFastStore (\db -> (,) <$> getGroup db vr user chatId <*> getGroupChatItem db user chatId itemId) >>= \case (Group g@GroupInfo {membership} ms, CChatItem md ci@ChatItem {meta = CIMeta {itemSharedMsgId = Just itemSharedMId}}) -> do unless (groupFeatureAllowed SGFReactions g) $ throwChatError (CECommandError $ "feature not allowed " <> T.unpack (chatFeatureNameText CFReactions)) unless (ciReactionAllowed ci) $ throwChatError (CECommandError "reaction not allowed - chat item has no content") let GroupMember {memberId = itemMemberId} = chatItemMember g ci - rs <- withStore' $ \db -> getGroupReactions db g membership itemMemberId itemSharedMId True + rs <- withFastStore' $ \db -> getGroupReactions db g membership itemMemberId itemSharedMId True checkReactionAllowed rs (SndMessage {msgId}, _) <- sendGroupMessage user g ms (XMsgReact itemSharedMId (Just itemMemberId) reaction add) createdAt <- liftIO getCurrentTime - reactions <- withStore' $ \db -> do + reactions <- withFastStore' $ \db -> do setGroupReaction db g membership itemMemberId itemSharedMId True reaction add msgId createdAt liftIO $ getGroupCIReactions db g itemMemberId itemSharedMId let ci' = CChatItem md ci {reactions} @@ -916,7 +916,7 @@ processChatCommand' vr = \case prepareForward :: User -> CM (ComposedMessage, Maybe CIForwardedFrom) prepareForward user = case fromCType of CTDirect -> withContactLock "forwardChatItem, from contact" fromChatId $ do - (ct, CChatItem _ ci) <- withStore $ \db -> do + (ct, CChatItem _ ci) <- withFastStore $ \db -> do ct <- getContact db vr user fromChatId cci <- getDirectChatItem db user fromChatId itemId pure (ct, cci) @@ -930,7 +930,7 @@ processChatCommand' vr = \case | localAlias /= "" = localAlias | otherwise = displayName CTGroup -> withGroupLock "forwardChatItem, from group" fromChatId $ do - (gInfo, CChatItem _ ci) <- withStore $ \db -> do + (gInfo, CChatItem _ ci) <- withFastStore $ \db -> do gInfo <- getGroupInfo db vr user fromChatId cci <- getGroupChatItem db user fromChatId itemId pure (gInfo, cci) @@ -942,7 +942,7 @@ processChatCommand' vr = \case forwardName :: GroupInfo -> ContactName forwardName GroupInfo {groupProfile = GroupProfile {displayName}} = displayName CTLocal -> do - (CChatItem _ ci) <- withStore $ \db -> getLocalChatItem db user fromChatId itemId + (CChatItem _ ci) <- withFastStore $ \db -> getLocalChatItem db user fromChatId itemId (mc, _) <- forwardMC ci file <- forwardCryptoFile ci let ciff = forwardCIFF ci Nothing @@ -1003,56 +1003,56 @@ processChatCommand' vr = \case when (B.length ch /= chSize') $ throwError $ CF.FTCEFileIOError "encrypting file: unexpected EOF" liftIO . CF.hPut w $ LB.fromStrict ch when (size' > 0) $ copyChunks r w size' - APIUserRead userId -> withUserId userId $ \user -> withStore' (`setUserChatsRead` user) >> ok user + APIUserRead userId -> withUserId userId $ \user -> withFastStore' (`setUserChatsRead` user) >> ok user UserRead -> withUser $ \User {userId} -> processChatCommand $ APIUserRead userId APIChatRead (ChatRef cType chatId) fromToIds -> withUser $ \_ -> case cType of CTDirect -> do - user <- withStore $ \db -> getUserByContactId db chatId - timedItems <- withStore' $ \db -> getDirectUnreadTimedItems db user chatId fromToIds + user <- withFastStore $ \db -> getUserByContactId db chatId + timedItems <- withFastStore' $ \db -> getDirectUnreadTimedItems db user chatId fromToIds ts <- liftIO getCurrentTime forM_ timedItems $ \(itemId, ttl) -> do let deleteAt = addUTCTime (realToFrac ttl) ts - withStore' $ \db -> setDirectChatItemDeleteAt db user chatId itemId deleteAt + withFastStore' $ \db -> setDirectChatItemDeleteAt db user chatId itemId deleteAt startProximateTimedItemThread user (ChatRef CTDirect chatId, itemId) deleteAt - withStore' $ \db -> updateDirectChatItemsRead db user chatId fromToIds + withFastStore' $ \db -> updateDirectChatItemsRead db user chatId fromToIds ok user CTGroup -> do - user@User {userId} <- withStore $ \db -> getUserByGroupId db chatId - timedItems <- withStore' $ \db -> getGroupUnreadTimedItems db user chatId fromToIds + user@User {userId} <- withFastStore $ \db -> getUserByGroupId db chatId + timedItems <- withFastStore' $ \db -> getGroupUnreadTimedItems db user chatId fromToIds ts <- liftIO getCurrentTime forM_ timedItems $ \(itemId, ttl) -> do let deleteAt = addUTCTime (realToFrac ttl) ts - withStore' $ \db -> setGroupChatItemDeleteAt db user chatId itemId deleteAt + withFastStore' $ \db -> setGroupChatItemDeleteAt db user chatId itemId deleteAt startProximateTimedItemThread user (ChatRef CTGroup chatId, itemId) deleteAt - withStore' $ \db -> updateGroupChatItemsRead db userId chatId fromToIds + withFastStore' $ \db -> updateGroupChatItemsRead db userId chatId fromToIds ok user CTLocal -> do - user <- withStore $ \db -> getUserByNoteFolderId db chatId - withStore' $ \db -> updateLocalChatItemsRead db user chatId fromToIds + user <- withFastStore $ \db -> getUserByNoteFolderId db chatId + withFastStore' $ \db -> updateLocalChatItemsRead db user chatId fromToIds ok user CTContactRequest -> pure $ chatCmdError Nothing "not supported" CTContactConnection -> pure $ chatCmdError Nothing "not supported" APIChatUnread (ChatRef cType chatId) unreadChat -> withUser $ \user -> case cType of CTDirect -> do - withStore $ \db -> do + withFastStore $ \db -> do ct <- getContact db vr user chatId liftIO $ updateContactUnreadChat db user ct unreadChat ok user CTGroup -> do - withStore $ \db -> do + withFastStore $ \db -> do Group {groupInfo} <- getGroup db vr user chatId liftIO $ updateGroupUnreadChat db user groupInfo unreadChat ok user CTLocal -> do - withStore $ \db -> do + withFastStore $ \db -> do nf <- getNoteFolder db user chatId liftIO $ updateNoteFolderUnreadChat db user nf unreadChat ok user _ -> pure $ chatCmdError (Just user) "not supported" APIDeleteChat cRef@(ChatRef cType chatId) cdm -> withUser $ \user@User {userId} -> case cType of CTDirect -> do - ct <- withStore $ \db -> getContact db vr user chatId - filesInfo <- withStore' $ \db -> getContactFileInfo db user ct + ct <- withFastStore $ \db -> getContact db vr user chatId + filesInfo <- withFastStore' $ \db -> getContactFileInfo db user ct withContactLock "deleteChat direct" chatId . procCmd $ case cdm of CDMFull notify -> do @@ -1061,33 +1061,33 @@ processChatCommand' vr = \case sendDelDeleteConns ct notify -- functions below are called in separate transactions to prevent crashes on android -- (possibly, race condition on integrity check?) - withStore' $ \db -> do + withFastStore' $ \db -> do deleteContactConnections db user ct deleteContactFiles db user ct - withStore $ \db -> deleteContact db user ct + withFastStore $ \db -> deleteContact db user ct pure $ CRContactDeleted user ct CDMEntity notify -> do cancelFilesInProgress user filesInfo sendDelDeleteConns ct notify - ct' <- withStore $ \db -> do + ct' <- withFastStore $ \db -> do liftIO $ deleteContactConnections db user ct liftIO $ void $ updateContactStatus db user ct CSDeletedByUser getContact db vr user chatId pure $ CRContactDeleted user ct' CDMMessages -> do void $ processChatCommand $ APIClearChat cRef - withStore' $ \db -> setContactChatDeleted db user ct True + withFastStore' $ \db -> setContactChatDeleted db user ct True pure $ CRContactDeleted user ct {chatDeleted = True} where sendDelDeleteConns ct notify = do let doSendDel = contactReady ct && contactActive ct && notify when doSendDel $ void (sendDirectContactMessage user ct XDirectDel) `catchChatError` const (pure ()) - contactConnIds <- map aConnId <$> withStore' (\db -> getContactConnections db vr userId ct) + contactConnIds <- map aConnId <$> withFastStore' (\db -> getContactConnections db vr userId ct) deleteAgentConnectionsAsync' user contactConnIds doSendDel CTContactConnection -> withConnectionLock "deleteChat contactConnection" chatId . procCmd $ do - conn@PendingContactConnection {pccAgentConnId = AgentConnId acId} <- withStore $ \db -> getPendingContactConnection db userId chatId + conn@PendingContactConnection {pccAgentConnId = AgentConnId acId} <- withFastStore $ \db -> getPendingContactConnection db userId chatId deleteAgentConnectionAsync user acId - withStore' $ \db -> deletePendingContactConnection db userId chatId + withFastStore' $ \db -> deletePendingContactConnection db userId chatId pure $ CRContactConnectionDeleted user conn CTGroup -> do Group gInfo@GroupInfo {membership} members <- withStore $ \db -> getGroup db vr user chatId @@ -1133,34 +1133,34 @@ processChatCommand' vr = \case 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 vr user chatId - filesInfo <- withStore' $ \db -> getContactFileInfo db user ct + ct <- withFastStore $ \db -> getContact db vr user chatId + filesInfo <- withFastStore' $ \db -> getContactFileInfo db user ct cancelFilesInProgress user filesInfo deleteFilesLocally filesInfo - withStore' $ \db -> deleteContactCIs db user ct + withFastStore' $ \db -> deleteContactCIs db user ct pure $ CRChatCleared user (AChatInfo SCTDirect $ DirectChat ct) CTGroup -> do - gInfo <- withStore $ \db -> getGroupInfo db vr user chatId - filesInfo <- withStore' $ \db -> getGroupFileInfo db user gInfo + gInfo <- withFastStore $ \db -> getGroupInfo db vr user chatId + filesInfo <- withFastStore' $ \db -> getGroupFileInfo db user gInfo cancelFilesInProgress user filesInfo deleteFilesLocally filesInfo - withStore' $ \db -> deleteGroupCIs db user gInfo - membersToDelete <- withStore' $ \db -> getGroupMembersForExpiration db vr user gInfo - forM_ membersToDelete $ \m -> withStore' $ \db -> deleteGroupMember db user m + withFastStore' $ \db -> deleteGroupCIs db user gInfo + membersToDelete <- withFastStore' $ \db -> getGroupMembersForExpiration db vr user gInfo + forM_ membersToDelete $ \m -> withFastStore' $ \db -> deleteGroupMember db user m pure $ CRChatCleared user (AChatInfo SCTGroup $ GroupChat gInfo) CTLocal -> do - nf <- withStore $ \db -> getNoteFolder db user chatId - filesInfo <- withStore' $ \db -> getNoteFolderFileInfo db user nf + nf <- withFastStore $ \db -> getNoteFolder db user chatId + filesInfo <- withFastStore' $ \db -> getNoteFolderFileInfo db user nf deleteFilesLocally filesInfo - withStore' $ \db -> deleteNoteFolderFiles db userId nf - withStore' $ \db -> deleteNoteFolderCIs db user nf + withFastStore' $ \db -> deleteNoteFolderFiles db userId nf + withFastStore' $ \db -> deleteNoteFolderCIs db user nf pure $ CRChatCleared user (AChatInfo SCTLocal $ LocalChat nf) CTContactConnection -> pure $ chatCmdError (Just user) "not supported" CTContactRequest -> pure $ chatCmdError (Just user) "not supported" APIAcceptContact incognito connReqId -> withUser $ \_ -> do - (user@User {userId}, cReq@UserContactRequest {userContactLinkId}) <- withStore $ \db -> getContactRequest' db connReqId + (user@User {userId}, cReq@UserContactRequest {userContactLinkId}) <- withFastStore $ \db -> getContactRequest' db connReqId withUserContactLock "acceptContact" userContactLinkId $ do - ucl <- withStore $ \db -> getUserContactLinkById db userId userContactLinkId + ucl <- withFastStore $ \db -> getUserContactLinkById db userId userContactLinkId let contactUsed = (\(_, groupId_, _) -> isNothing groupId_) ucl -- [incognito] generate profile to send, create connection with incognito profile incognitoProfile <- if incognito then Just . NewIncognito <$> liftIO generateRandomProfile else pure Nothing @@ -1168,7 +1168,7 @@ processChatCommand' vr = \case pure $ CRAcceptingContactRequest user ct APIRejectContact connReqId -> withUser $ \user -> do cReq@UserContactRequest {userContactLinkId, agentContactConnId = AgentConnId connId, agentInvitationId = AgentInvId invId} <- - withStore $ \db -> + withFastStore $ \db -> getContactRequest db user connReqId `storeFinally` liftIO (deleteContactRequest db user connReqId) withUserContactLock "rejectContact" userContactLinkId $ do @@ -1176,7 +1176,7 @@ processChatCommand' vr = \case pure $ CRContactRequestRejected user cReq APISendCallInvitation contactId callType -> withUser $ \user -> do -- party initiating call - ct <- withStore $ \db -> getContact db vr user contactId + ct <- withFastStore $ \db -> getContact db vr user contactId assertDirectAllowed user MDSnd ct XCallInv_ if featureAllowed SCFCalls forUser ct then do @@ -1196,14 +1196,14 @@ processChatCommand' vr = \case ok user else pure $ chatCmdError (Just user) ("feature not allowed " <> T.unpack (chatFeatureNameText CFCalls)) SendCallInvitation cName callType -> withUser $ \user -> do - contactId <- withStore $ \db -> getContactIdByName db user cName + contactId <- withFastStore $ \db -> getContactIdByName db user cName processChatCommand $ APISendCallInvitation contactId callType APIRejectCall contactId -> -- party accepting call withCurrentCall contactId $ \user ct Call {chatItemId, callState} -> case callState of CallInvitationReceived {} -> do let aciContent = ACIContent SMDRcv $ CIRcvCall CISCallRejected 0 - withStore' $ \db -> updateDirectChatItemsRead db user contactId $ Just (chatItemId, chatItemId) + withFastStore' $ \db -> updateDirectChatItemsRead db user contactId $ Just (chatItemId, chatItemId) timed_ <- contactCITimed ct updateDirectChatItemView user ct chatItemId aciContent False False timed_ Nothing forM_ (timed_ >>= timedDeleteAt') $ @@ -1219,7 +1219,7 @@ processChatCommand' vr = \case callState' = CallOfferSent {localCallType = callType, peerCallType, localCallSession = rtcSession, sharedKey} aciContent = ACIContent SMDRcv $ CIRcvCall CISCallAccepted 0 (SndMessage {msgId}, _) <- sendDirectContactMessage user ct (XCallOffer callId offer) - withStore' $ \db -> updateDirectChatItemsRead db user contactId $ Just (chatItemId, chatItemId) + withFastStore' $ \db -> updateDirectChatItemsRead db user contactId $ Just (chatItemId, chatItemId) updateDirectChatItemView user ct chatItemId aciContent False False Nothing $ Just msgId pure $ Just call {callState = callState'} _ -> throwChatError . CECallState $ callStateTag callState @@ -1262,7 +1262,7 @@ processChatCommand' vr = \case callInvitation Call {contactId, callState, callTs} = case callState of CallInvitationReceived {peerCallType, sharedKey} -> Just (contactId, callTs, peerCallType, sharedKey) _ -> Nothing - rcvCallInvitation (contactId, callTs, peerCallType, sharedKey) = runExceptT . withStore $ \db -> do + rcvCallInvitation (contactId, callTs, peerCallType, sharedKey) = runExceptT . withFastStore $ \db -> do user <- getUserByContactId db contactId contact <- getContact db vr user contactId pure RcvCallInvitation {user, contact, callType = peerCallType, sharedKey, callTs} @@ -1273,20 +1273,20 @@ 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 vr user contactId + ct <- withFastStore $ \db -> getContact db vr user contactId updateContactPrefs user ct prefs' APISetContactAlias contactId localAlias -> withUser $ \user@User {userId} -> do - ct' <- withStore $ \db -> do + ct' <- withFastStore $ \db -> do ct <- getContact db vr user contactId liftIO $ updateContactAlias db userId ct localAlias pure $ CRContactAliasUpdated user ct' APISetConnectionAlias connId localAlias -> withUser $ \user@User {userId} -> do - conn' <- withStore $ \db -> do + conn' <- withFastStore $ \db -> do conn <- getPendingContactConnection db userId connId liftIO $ updateContactConnectionAlias db userId conn localAlias pure $ CRConnectionAliasUpdated user conn' APISetUserUIThemes uId uiThemes -> withUser $ \user@User {userId} -> do - user'@User {userId = uId'} <- withStore $ \db -> do + user'@User {userId = uId'} <- withFastStore $ \db -> do user' <- getUser db uId liftIO $ setUserUIThemes db user uiThemes pure user' @@ -1294,12 +1294,12 @@ processChatCommand' vr = \case ok user' APISetChatUIThemes (ChatRef cType chatId) uiThemes -> withUser $ \user -> case cType of CTDirect -> do - withStore $ \db -> do + withFastStore $ \db -> do ct <- getContact db vr user chatId liftIO $ setContactUIThemes db user ct uiThemes ok user CTGroup -> do - withStore $ \db -> do + withFastStore $ \db -> do g <- getGroupInfo db vr user chatId liftIO $ setGroupUIThemes db user g uiThemes ok user @@ -1321,13 +1321,13 @@ processChatCommand' vr = \case pure CRNtfMessages {user_, connEntity_, msgTs = msgTs', ntfMessage_ = ntfMsgInfo <$> msg} APIGetUserProtoServers userId (AProtocolType p) -> withUserId userId $ \user -> withServerProtocol p $ do cfg@ChatConfig {defaultServers} <- asks config - servers <- withStore' (`getProtocolServers` user) + servers <- withFastStore' (`getProtocolServers` user) pure $ CRUserProtoServers user $ AUPS $ UserProtoServers p (useServers cfg p servers) (cfgServers p defaultServers) GetUserProtoServers aProtocol -> withUser $ \User {userId} -> processChatCommand $ APIGetUserProtoServers userId aProtocol APISetUserProtoServers userId (APSC p (ProtoServersConfig servers)) | null servers || any (\ServerCfg {enabled} -> enabled) servers -> withUserId userId $ \user -> withServerProtocol p $ do - withStore $ \db -> overwriteProtocolServers db user servers + withFastStore $ \db -> overwriteProtocolServers db user servers cfg <- asks config lift $ withAgent' $ \a -> setProtocolServers a (aUserId user) $ useServers cfg p servers ok user @@ -1343,21 +1343,21 @@ processChatCommand' vr = \case withChatLock "setChatItemTTL" $ do case newTTL_ of Nothing -> do - withStore' $ \db -> setChatItemTTL db user newTTL_ + withFastStore' $ \db -> setChatItemTTL db user newTTL_ lift $ setExpireCIFlag user False Just newTTL -> do - oldTTL <- withStore' (`getChatItemTTL` user) + oldTTL <- withFastStore' (`getChatItemTTL` user) when (maybe True (newTTL <) oldTTL) $ do lift $ setExpireCIFlag user False expireChatItems user newTTL True - withStore' $ \db -> setChatItemTTL db user newTTL_ + withFastStore' $ \db -> setChatItemTTL db user newTTL_ lift $ startExpireCIThread user lift . whenM chatStarted $ setExpireCIFlag user True ok user SetChatItemTTL newTTL_ -> withUser' $ \User {userId} -> do processChatCommand $ APISetChatItemTTL userId newTTL_ APIGetChatItemTTL userId -> withUserId' userId $ \user -> do - ttl <- withStore' (`getChatItemTTL` user) + ttl <- withFastStore' (`getChatItemTTL` user) pure $ CRChatItemTTL user ttl GetChatItemTTL -> withUser' $ \User {userId} -> do processChatCommand $ APIGetChatItemTTL userId @@ -1375,7 +1375,7 @@ processChatCommand' vr = \case ok_ APISetChatSettings (ChatRef cType chatId) chatSettings -> withUser $ \user -> case cType of CTDirect -> do - ct <- withStore $ \db -> do + ct <- withFastStore $ \db -> do ct <- getContact db vr user chatId liftIO $ updateContactSettings db user chatId chatSettings pure ct @@ -1383,7 +1383,7 @@ processChatCommand' vr = \case withAgent $ \a -> toggleConnectionNtfs a connId (chatHasNtfs chatSettings) ok user CTGroup -> do - ms <- withStore $ \db -> do + ms <- withFastStore $ \db -> do Group _ ms <- getGroup db vr user chatId liftIO $ updateGroupSettings db user chatId chatSettings pure ms @@ -1392,7 +1392,7 @@ processChatCommand' vr = \case ok user _ -> pure $ chatCmdError (Just user) "not supported" APISetMemberSettings gId gMemberId settings -> withUser $ \user -> do - m <- withStore $ \db -> do + m <- withFastStore $ \db -> do liftIO $ updateGroupMemberSettings db user gId gMemberId settings getGroupMember db vr user gId gMemberId let ntfOn = showMessages $ memberSettings m @@ -1400,60 +1400,60 @@ processChatCommand' vr = \case 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 vr user contactId + ct@Contact {activeConn} <- withFastStore $ \db -> getContact db vr user contactId incognitoProfile <- case activeConn of Nothing -> pure Nothing Just Connection {customUserProfileId} -> - forM customUserProfileId $ \profileId -> withStore (\db -> getProfileById db userId profileId) + forM customUserProfileId $ \profileId -> withFastStore (\db -> getProfileById db userId profileId) connectionStats <- mapM (withAgent . flip getConnectionServers) (contactConnId ct) pure $ CRContactInfo user ct connectionStats (fmap fromLocalProfile incognitoProfile) APIContactQueueInfo contactId -> withUser $ \user -> do - ct@Contact {activeConn} <- withStore $ \db -> getContact db vr user contactId + ct@Contact {activeConn} <- withFastStore $ \db -> getContact db vr user contactId case activeConn of Just conn -> getConnQueueInfo user conn Nothing -> throwChatError $ CEContactNotActive ct APIGroupInfo gId -> withUser $ \user -> do - (g, s) <- withStore $ \db -> (,) <$> getGroupInfo db vr user gId <*> liftIO (getGroupSummary db user gId) + (g, s) <- withFastStore $ \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 vr user gId gMemberId + (g, m) <- withFastStore $ \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 APIGroupMemberQueueInfo gId gMemberId -> withUser $ \user -> do - GroupMember {activeConn} <- withStore $ \db -> getGroupMember db vr user gId gMemberId + GroupMember {activeConn} <- withFastStore $ \db -> getGroupMember db vr user gId gMemberId case activeConn of Just conn -> getConnQueueInfo user conn Nothing -> throwChatError CEGroupMemberNotActive APISwitchContact contactId -> withUser $ \user -> do - ct <- withStore $ \db -> getContact db vr user contactId + ct <- withFastStore $ \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 vr user gId gMemberId + (g, m) <- withFastStore $ \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 vr user contactId + ct <- withFastStore $ \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 vr user gId gMemberId + (g, m) <- withFastStore $ \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 -> withContactLock "syncContactRatchet" contactId $ do - ct <- withStore $ \db -> getContact db vr user contactId + ct <- withFastStore $ \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 @@ -1461,7 +1461,7 @@ processChatCommand' vr = \case pure $ CRContactRatchetSyncStarted user ct cStats Nothing -> throwChatError $ CEContactNotActive ct APISyncGroupMemberRatchet gId gMemberId force -> withUser $ \user -> withGroupLock "syncGroupMemberRatchet" gId $ do - (g, m) <- withStore $ \db -> (,) <$> getGroupInfo db vr user gId <*> getGroupMember db vr user gId gMemberId + (g, m) <- withFastStore $ \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 @@ -1469,7 +1469,7 @@ processChatCommand' vr = \case pure $ CRGroupMemberRatchetSyncStarted user g m cStats _ -> throwChatError CEGroupMemberNotActive APIGetContactCode contactId -> withUser $ \user -> do - ct@Contact {activeConn} <- withStore $ \db -> getContact db vr user contactId + ct@Contact {activeConn} <- withFastStore $ \db -> getContact db vr user contactId case activeConn of Just conn@Connection {connId} -> do code <- getConnectionCode $ aConnId conn @@ -1477,13 +1477,13 @@ processChatCommand' vr = \case Just SecurityCode {securityCode} | sameVerificationCode code securityCode -> pure ct | otherwise -> do - withStore' $ \db -> setConnectionVerified db user connId Nothing + withFastStore' $ \db -> setConnectionVerified db user connId Nothing pure (ct :: Contact) {activeConn = Just $ (conn :: Connection) {connectionCode = Nothing}} _ -> pure ct 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 vr user gId gMemberId + (g, m@GroupMember {activeConn}) <- withFastStore $ \db -> (,) <$> getGroupInfo db vr user gId <*> getGroupMember db vr user gId gMemberId case activeConn of Just conn@Connection {connId} -> do code <- getConnectionCode $ aConnId conn @@ -1491,48 +1491,48 @@ processChatCommand' vr = \case Just SecurityCode {securityCode} | sameVerificationCode code securityCode -> pure m | otherwise -> do - withStore' $ \db -> setConnectionVerified db user connId Nothing + withFastStore' $ \db -> setConnectionVerified db user connId Nothing pure (m :: GroupMember) {activeConn = Just $ (conn :: Connection) {connectionCode = Nothing}} _ -> pure m pure $ CRGroupMemberCode user g m' code _ -> throwChatError CEGroupMemberNotActive APIVerifyContact contactId code -> withUser $ \user -> do - ct@Contact {activeConn} <- withStore $ \db -> getContact db vr user contactId + ct@Contact {activeConn} <- withFastStore $ \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 vr user gId gMemberId + GroupMember {activeConn} <- withFastStore $ \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 vr user contactId + ct@Contact {activeConn} <- withFastStore $ \db -> getContact db vr user contactId case activeConn of Just conn -> do - withStore' $ \db -> setAuthErrCounter db user conn 0 + withFastStore' $ \db -> setAuthErrCounter db user conn 0 ok user Nothing -> throwChatError $ CEContactNotActive ct APIEnableGroupMember gId gMemberId -> withUser $ \user -> do - GroupMember {activeConn} <- withStore $ \db -> getGroupMember db vr user gId gMemberId + GroupMember {activeConn} <- withFastStore $ \db -> getGroupMember db vr user gId gMemberId case activeConn of Just conn -> do - withStore' $ \db -> setAuthErrCounter db user conn 0 + withFastStore' $ \db -> setAuthErrCounter db user conn 0 ok user _ -> throwChatError CEGroupMemberNotActive SetShowMessages cName ntfOn -> updateChatSettings cName (\cs -> cs {enableNtfs = ntfOn}) SetSendReceipts cName rcptsOn_ -> updateChatSettings cName (\cs -> cs {sendRcpts = rcptsOn_}) 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 vr user gId mId + gInfo <- withFastStore $ \db -> getGroupInfo db vr user gId + m <- withFastStore $ \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} processChatCommand $ APISetMemberSettings gId mId settings ContactInfo cName -> withContactName cName APIContactInfo ShowGroupInfo gName -> withUser $ \user -> do - groupId <- withStore $ \db -> getGroupIdByName db user gName + groupId <- withFastStore $ \db -> getGroupIdByName db user gName processChatCommand $ APIGroupInfo groupId GroupMemberInfo gName mName -> withMemberName gName mName APIGroupMemberInfo ContactQueueInfo cName -> withContactName cName APIContactQueueInfo @@ -1557,12 +1557,12 @@ processChatCommand' vr = \case subMode <- chatReadVar subscriptionMode (connId, cReq) <- withAgent $ \a -> createConnection a (aUserId user) True SCMInvitation Nothing IKPQOn subMode -- TODO PQ pass minVersion from the current range - conn <- withStore' $ \db -> createDirectConnection db user connId cReq ConnNew incognitoProfile subMode initialChatVersion PQSupportOn + conn <- withFastStore' $ \db -> createDirectConnection db user connId cReq ConnNew incognitoProfile subMode initialChatVersion PQSupportOn pure $ CRInvitation user cReq conn AddContact incognito -> withUser $ \User {userId} -> processChatCommand $ APIAddContact userId incognito APISetConnectionIncognito connId incognito -> withUser $ \user@User {userId} -> do - conn'_ <- withStore $ \db -> do + conn'_ <- withFastStore $ \db -> do conn@PendingContactConnection {pccConnStatus, customUserProfileId} <- getPendingContactConnection db userId connId case (pccConnStatus, customUserProfileId, incognito) of (ConnNew, Nothing, True) -> liftIO $ do @@ -1590,7 +1590,7 @@ processChatCommand' vr = \case let chatV = agentToChatVersion agentV dm <- encodeConnInfoPQ pqSup' chatV $ XInfo profileToSend connId <- withAgent $ \a -> prepareConnectionToJoin a (aUserId user) True cReq pqSup' - conn@PendingContactConnection {pccConnId} <- withStore' $ \db -> createDirectConnection db user connId cReq ConnJoined (incognitoProfile $> profileToSend) subMode chatV pqSup' + conn@PendingContactConnection {pccConnId} <- withFastStore' $ \db -> createDirectConnection db user connId cReq ConnJoined (incognitoProfile $> profileToSend) subMode chatV pqSup' joinPreparedAgentConnection user pccConnId connId cReq dm pqSup' subMode pure $ CRSentConfirmation user conn APIConnect userId incognito (Just (ACR SCMContact cReq)) -> withUserId userId $ \user -> connectViaContact user incognito cReq @@ -1604,7 +1604,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 vr user contactId + ct@Contact {activeConn, profile = LocalProfile {contactLink}} <- withFastStore $ \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 @@ -1620,23 +1620,23 @@ processChatCommand' vr = \case DeleteContact cName cdm -> withContactName cName $ \ctId -> APIDeleteChat (ChatRef CTDirect ctId) cdm ClearContact cName -> withContactName cName $ APIClearChat . ChatRef CTDirect APIListContacts userId -> withUserId userId $ \user -> - CRContactsList user <$> withStore' (\db -> getUserContacts db vr user) + CRContactsList user <$> withFastStore' (\db -> getUserContacts db vr user) ListContacts -> withUser $ \User {userId} -> processChatCommand $ APIListContacts userId APICreateMyAddress userId -> withUserId userId $ \user -> procCmd $ do subMode <- chatReadVar subscriptionMode (connId, cReq) <- withAgent $ \a -> createConnection a (aUserId user) True SCMContact Nothing IKPQOn subMode - withStore $ \db -> createUserContactLink db user connId cReq subMode + withFastStore $ \db -> createUserContactLink db user connId cReq subMode pure $ CRUserContactLinkCreated user cReq CreateMyAddress -> withUser $ \User {userId} -> processChatCommand $ APICreateMyAddress userId APIDeleteMyAddress userId -> withUserId userId $ \user@User {profile = p} -> do - conns <- withStore $ \db -> getUserAddressConnections db vr user + conns <- withFastStore $ \db -> getUserAddressConnections db vr user withChatLock "deleteMyAddress" $ do deleteAgentConnectionsAsync user $ map aConnId conns - withStore' (`deleteUserAddress` user) + withFastStore' (`deleteUserAddress` user) let p' = (fromLocalProfile p :: Profile) {contactLink = Nothing} - r <- updateProfile_ user p' $ withStore' $ \db -> setUserProfileContactLink db user Nothing + r <- updateProfile_ user p' $ withFastStore' $ \db -> setUserProfileContactLink db user Nothing let user' = case r of CRUserProfileUpdated u' _ _ _ -> u' _ -> user @@ -1644,54 +1644,54 @@ processChatCommand' vr = \case DeleteMyAddress -> withUser $ \User {userId} -> processChatCommand $ APIDeleteMyAddress userId APIShowMyAddress userId -> withUserId' userId $ \user -> - CRUserContactLink user <$> withStore (`getUserAddress` user) + CRUserContactLink user <$> withFastStore (`getUserAddress` user) ShowMyAddress -> withUser' $ \User {userId} -> processChatCommand $ APIShowMyAddress userId APISetProfileAddress userId False -> withUserId userId $ \user@User {profile = p} -> do let p' = (fromLocalProfile p :: Profile) {contactLink = Nothing} - updateProfile_ user p' $ withStore' $ \db -> setUserProfileContactLink db user Nothing + updateProfile_ user p' $ withFastStore' $ \db -> setUserProfileContactLink db user Nothing APISetProfileAddress userId True -> withUserId userId $ \user@User {profile = p} -> do - ucl@UserContactLink {connReqContact} <- withStore (`getUserAddress` user) + ucl@UserContactLink {connReqContact} <- withFastStore (`getUserAddress` user) let p' = (fromLocalProfile p :: Profile) {contactLink = Just connReqContact} - updateProfile_ user p' $ withStore' $ \db -> setUserProfileContactLink db user $ Just ucl + updateProfile_ user p' $ withFastStore' $ \db -> setUserProfileContactLink db user $ Just ucl SetProfileAddress onOff -> withUser $ \User {userId} -> processChatCommand $ APISetProfileAddress userId onOff APIAddressAutoAccept userId autoAccept_ -> withUserId userId $ \user -> do - contactLink <- withStore (\db -> updateUserAddressAutoAccept db user autoAccept_) + contactLink <- withFastStore (\db -> updateUserAddressAutoAccept db user autoAccept_) pure $ CRUserContactLinkUpdated user contactLink AddressAutoAccept autoAccept_ -> withUser $ \User {userId} -> processChatCommand $ APIAddressAutoAccept userId autoAccept_ AcceptContact incognito cName -> withUser $ \User {userId} -> do - connReqId <- withStore $ \db -> getContactRequestIdByName db userId cName + connReqId <- withFastStore $ \db -> getContactRequestIdByName db userId cName processChatCommand $ APIAcceptContact incognito connReqId RejectContact cName -> withUser $ \User {userId} -> do - connReqId <- withStore $ \db -> getContactRequestIdByName db userId cName + connReqId <- withFastStore $ \db -> getContactRequestIdByName db userId cName processChatCommand $ APIRejectContact connReqId ForwardMessage toChatName fromContactName forwardedMsg -> withUser $ \user -> do - contactId <- withStore $ \db -> getContactIdByName db user fromContactName - forwardedItemId <- withStore $ \db -> getDirectChatItemIdByText' db user contactId forwardedMsg + contactId <- withFastStore $ \db -> getContactIdByName db user fromContactName + forwardedItemId <- withFastStore $ \db -> getDirectChatItemIdByText' db user contactId forwardedMsg toChatRef <- getChatRef user toChatName processChatCommand $ APIForwardChatItem toChatRef (ChatRef CTDirect contactId) forwardedItemId Nothing ForwardGroupMessage toChatName fromGroupName fromMemberName_ forwardedMsg -> withUser $ \user -> do - groupId <- withStore $ \db -> getGroupIdByName db user fromGroupName - forwardedItemId <- withStore $ \db -> getGroupChatItemIdByText db user groupId fromMemberName_ forwardedMsg + groupId <- withFastStore $ \db -> getGroupIdByName db user fromGroupName + forwardedItemId <- withFastStore $ \db -> getGroupChatItemIdByText db user groupId fromMemberName_ forwardedMsg toChatRef <- getChatRef user toChatName processChatCommand $ APIForwardChatItem toChatRef (ChatRef CTGroup groupId) forwardedItemId Nothing ForwardLocalMessage toChatName forwardedMsg -> withUser $ \user -> do - folderId <- withStore (`getUserNoteFolderId` user) - forwardedItemId <- withStore $ \db -> getLocalChatItemIdByText' db user folderId forwardedMsg + folderId <- withFastStore (`getUserNoteFolderId` user) + forwardedItemId <- withFastStore $ \db -> getLocalChatItemIdByText' db user folderId forwardedMsg toChatRef <- getChatRef user toChatName processChatCommand $ APIForwardChatItem toChatRef (ChatRef CTLocal folderId) forwardedItemId Nothing SendMessage (ChatName cType name) msg -> withUser $ \user -> do let mc = MCText msg case cType of CTDirect -> - withStore' (\db -> runExceptT $ getContactIdByName db user name) >>= \case + withFastStore' (\db -> runExceptT $ getContactIdByName db user name) >>= \case Right ctId -> do let chatRef = ChatRef CTDirect ctId processChatCommand . APISendMessage chatRef False Nothing $ ComposedMessage Nothing Nothing mc Left _ -> - withStore' (\db -> runExceptT $ getActiveMembersByName db vr user name) >>= \case + withFastStore' (\db -> runExceptT $ getActiveMembersByName db vr user name) >>= \case Right [(gInfo, member)] -> do let GroupInfo {localDisplayName = gName} = gInfo GroupMember {localDisplayName = mName} = member @@ -1701,22 +1701,22 @@ processChatCommand' vr = \case _ -> throwChatError $ CEContactNotFound name Nothing CTGroup -> do - gId <- withStore $ \db -> getGroupIdByName db user name + gId <- withFastStore $ \db -> getGroupIdByName db user name let chatRef = ChatRef CTGroup gId processChatCommand . APISendMessage chatRef False Nothing $ ComposedMessage Nothing Nothing mc CTLocal | name == "" -> do - folderId <- withStore (`getUserNoteFolderId` user) + folderId <- withFastStore (`getUserNoteFolderId` user) processChatCommand . APICreateChatItem folderId $ ComposedMessage Nothing Nothing mc | otherwise -> throwChatError $ CECommandError "not supported" _ -> throwChatError $ CECommandError "not supported" SendMemberContactMessage gName mName msg -> withUser $ \user -> do (gId, mId) <- getGroupAndMemberId user gName mName - m <- withStore $ \db -> getGroupMember db vr user gId mId + m <- withFastStore $ \db -> getGroupMember db vr user gId mId let mc = MCText msg case memberContactId m of Nothing -> do - g <- withStore $ \db -> getGroupInfo db vr user gId + g <- withFastStore $ \db -> getGroupInfo db vr user gId unless (groupFeatureMemberAllowed SGFDirectMessages (membership g) g) $ throwChatError $ CECommandError "direct messages not allowed" toView $ CRNoMemberContactCreating user g m processChatCommand (APICreateMemberContact gId mId) >>= \case @@ -1732,7 +1732,7 @@ processChatCommand' vr = \case let mc = MCText msg processChatCommand . APISendMessage chatRef True Nothing $ ComposedMessage Nothing Nothing mc SendMessageBroadcast msg -> withUser $ \user -> do - contacts <- withStore' $ \db -> getUserContacts db vr user + contacts <- withFastStore' $ \db -> getUserContacts db vr user withChatLock "sendMessageBroadcast" . procCmd $ do let ctConns_ = L.nonEmpty $ foldr addContactConn [] contacts case ctConns_ of @@ -1768,8 +1768,8 @@ processChatCommand' vr = \case createCI db user createdAt (ct, sndMsg) = void $ createNewSndChatItem db user (CDDirectSnd ct) sndMsg (CISndMsgContent mc) Nothing Nothing Nothing False createdAt SendMessageQuote cName (AMsgDirection msgDir) quotedMsg msg -> withUser $ \user@User {userId} -> do - contactId <- withStore $ \db -> getContactIdByName db user cName - quotedItemId <- withStore $ \db -> getDirectChatItemIdByText db userId contactId msgDir quotedMsg + contactId <- withFastStore $ \db -> getContactIdByName db user cName + quotedItemId <- withFastStore $ \db -> getDirectChatItemIdByText db userId contactId msgDir quotedMsg let mc = MCText msg processChatCommand . APISendMessage (ChatRef CTDirect contactId) False Nothing $ ComposedMessage Nothing (Just quotedItemId) mc DeleteMessage chatName deletedMsg -> withUser $ \user -> do @@ -1778,7 +1778,7 @@ processChatCommand' vr = \case processChatCommand $ APIDeleteChatItem chatRef deletedItemId CIDMBroadcast DeleteMemberMessage gName mName deletedMsg -> withUser $ \user -> do (gId, mId) <- getGroupAndMemberId user gName mName - deletedItemId <- withStore $ \db -> getGroupChatItemIdByText db user gId (Just mName) deletedMsg + deletedItemId <- withFastStore $ \db -> getGroupChatItemIdByText db user gId (Just mName) deletedMsg processChatCommand $ APIDeleteMemberChatItem gId mId deletedItemId EditMessage chatName editedMsg msg -> withUser $ \user -> do chatRef <- getChatRef user chatName @@ -1798,14 +1798,14 @@ processChatCommand' vr = \case gVar <- asks random -- [incognito] generate incognito profile for group membership incognitoProfile <- if incognito then Just <$> liftIO generateRandomProfile else pure Nothing - groupInfo <- withStore $ \db -> createNewGroup db vr gVar user gProfile incognitoProfile + groupInfo <- withFastStore $ \db -> createNewGroup db vr gVar user gProfile incognitoProfile createInternalChatItem user (CDGroupSnd groupInfo) (CISndGroupE2EEInfo $ E2EInfo {pqEnabled = PQEncOff}) Nothing pure $ CRGroupCreated user groupInfo NewGroup incognito gProfile -> withUser $ \User {userId} -> processChatCommand $ APINewGroup userId incognito gProfile APIAddMember groupId contactId memRole -> withUser $ \user -> withGroupLock "addMember" groupId $ 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 vr user contactId + (group, contact) <- withFastStore $ \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 @@ -1820,13 +1820,13 @@ processChatCommand' vr = \case gVar <- asks random subMode <- chatReadVar subscriptionMode (agentConnId, cReq) <- withAgent $ \a -> createConnection a (aUserId user) True SCMInvitation Nothing IKPQOff subMode - member <- withStore $ \db -> createNewContactMember db gVar user gInfo contact memRole agentConnId cReq subMode + member <- withFastStore $ \db -> createNewContactMember db gVar user gInfo contact memRole agentConnId cReq subMode sendInvitation member cReq pure $ CRSentGroupInvitation user gInfo contact member Just member@GroupMember {groupMemberId, memberStatus, memberRole = mRole} | memberStatus == GSMemInvited -> do - unless (mRole == memRole) $ withStore' $ \db -> updateGroupMemberRole db user member memRole - withStore' (\db -> getMemberInvitation db user groupMemberId) >>= \case + unless (mRole == memRole) $ withFastStore' $ \db -> updateGroupMemberRole db user member memRole + withFastStore' (\db -> getMemberInvitation db user groupMemberId) >>= \case Just cReq -> do sendInvitation member {memberRole = memRole} cReq pure $ CRSentGroupInvitation user gInfo contact member {memberRole = memRole} @@ -1834,7 +1834,7 @@ processChatCommand' vr = \case | otherwise -> throwChatError $ CEGroupDuplicateMember cName APIJoinGroup groupId -> withUser $ \user@User {userId} -> do withGroupLock "joinGroup" groupId . procCmd $ do - (invitation, ct) <- withStore $ \db -> do + (invitation, ct) <- withFastStore $ \db -> do inv@ReceivedGroupInvitation {fromMember} <- getGroupInvitation db vr user groupId (inv,) <$> getContactViaMember db vr user fromMember let ReceivedGroupInvitation {fromMember, connRequest, groupInfo = g@GroupInfo {membership}} = invitation @@ -1846,14 +1846,14 @@ processChatCommand' vr = \case dm <- encodeConnInfo $ XGrpAcpt membershipMemId agentConnId <- withAgent $ \a -> prepareConnectionToJoin a (aUserId user) True connRequest PQSupportOff let chatV = vr `peerConnChatVersion` peerChatVRange - cId <- withStore' $ \db -> do + cId <- withFastStore' $ \db -> do Connection {connId = cId} <- createMemberConnection db userId fromMember agentConnId chatV peerChatVRange subMode updateGroupMemberStatus db userId fromMember GSMemAccepted updateGroupMemberStatus db userId membership GSMemAccepted pure cId void (withAgent $ \a -> joinConnection a (aUserId user) (Just agentConnId) True connRequest dm PQSupportOff subMode) `catchChatError` \e -> do - withStore' $ \db -> do + withFastStore' $ \db -> do deleteConnectionRecord db user cId updateGroupMemberStatus db userId fromMember GSMemInvited updateGroupMemberStatus db userId membership GSMemInvited @@ -1863,7 +1863,7 @@ processChatCommand' vr = \case pure $ CRUserAcceptedGroupSent user g {membership = membership {memberStatus = GSMemAccepted}} Nothing Nothing -> throwChatError $ CEContactNotActive ct APIMemberRole groupId memberId memRole -> withUser $ \user -> do - Group gInfo@GroupInfo {membership} members <- withStore $ \db -> getGroup db vr user groupId + Group gInfo@GroupInfo {membership} members <- withFastStore $ \db -> getGroup db vr user groupId if memberId == groupMemberId' membership then changeMemberRole user gInfo members membership $ SGEUserRole memRole else case find ((== memberId) . groupMemberId') members of @@ -1875,10 +1875,10 @@ processChatCommand' vr = \case assertUserGroupRole gInfo $ maximum [GRAdmin, mRole, memRole] withGroupLock "memberRole" groupId . procCmd $ do unless (mRole == memRole) $ do - withStore' $ \db -> updateGroupMemberRole db user m memRole + withFastStore' $ \db -> updateGroupMemberRole db user m memRole case mStatus of GSMemInvited -> do - withStore (\db -> (,) <$> mapM (getContact db vr user) memberContactId <*> liftIO (getMemberInvitation db user $ groupMemberId' m)) >>= \case + withFastStore (\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 @@ -1887,7 +1887,7 @@ processChatCommand' vr = \case toView $ CRNewChatItem user (AChatItem SCTGroup SMDSnd (GroupChat gInfo) ci) pure CRMemberRoleUser {user, groupInfo = gInfo, member = m {memberRole = memRole}, fromRole = mRole, toRole = memRole} APIBlockMemberForAll groupId memberId blocked -> withUser $ \user -> do - Group gInfo@GroupInfo {membership} members <- withStore $ \db -> getGroup db vr user groupId + Group gInfo@GroupInfo {membership} members <- withFastStore $ \db -> getGroup db vr user groupId when (memberId == groupMemberId' membership) $ throwChatError $ CECommandError "can't block/unblock self" case splitMember memberId members of Nothing -> throwChatError $ CEException "expected to find a single blocked member" @@ -1902,7 +1902,7 @@ processChatCommand' vr = \case let ciContent = CISndGroupEvent $ SGEMemberBlocked memberId (fromLocalProfile bmp) blocked ci <- saveSndChatItem user (CDGroupSnd gInfo) msg ciContent toView $ CRNewChatItem user (AChatItem SCTGroup SMDSnd (GroupChat gInfo) ci) - bm' <- withStore $ \db -> do + bm' <- withFastStore $ \db -> do liftIO $ updateGroupMemberBlocked db user groupId memberId mrs getGroupMember db vr user groupId memberId toggleNtf user bm' (not blocked) @@ -1912,7 +1912,7 @@ processChatCommand' vr = \case (_, []) -> Nothing (ms1, bm : ms2) -> Just (bm, ms1 <> ms2) APIRemoveMember groupId memberId -> withUser $ \user -> do - Group gInfo members <- withStore $ \db -> getGroup db vr user groupId + Group gInfo members <- withFastStore $ \db -> getGroup db vr user groupId case find ((== memberId) . groupMemberId') members of Nothing -> throwChatError CEGroupMemberNotFound Just m@GroupMember {memberId = mId, memberRole = mRole, memberStatus = mStatus, memberProfile} -> do @@ -1921,7 +1921,7 @@ processChatCommand' vr = \case case mStatus of GSMemInvited -> do deleteMemberConnection user m - withStore' $ \db -> deleteGroupMember db user m + withFastStore' $ \db -> deleteGroupMember db user m _ -> do (msg, _) <- sendGroupMessage user gInfo members $ XGrpMemDel mId ci <- saveSndChatItem user (CDGroupSnd gInfo) msg (CISndGroupEvent $ SGEMemberDeleted memberId (fromLocalProfile memberProfile)) @@ -1931,8 +1931,8 @@ processChatCommand' vr = \case deleteOrUpdateMemberRecord user m pure $ CRUserDeletedMember user gInfo m {memberStatus = GSMemRemoved} APILeaveGroup groupId -> withUser $ \user@User {userId} -> do - Group gInfo@GroupInfo {membership} members <- withStore $ \db -> getGroup db vr user groupId - filesInfo <- withStore' $ \db -> getGroupFileInfo db user gInfo + Group gInfo@GroupInfo {membership} members <- withFastStore $ \db -> getGroup db vr user groupId + filesInfo <- withFastStore' $ \db -> getGroupFileInfo db user gInfo withGroupLock "leaveGroup" groupId . procCmd $ do cancelFilesInProgress user filesInfo (msg, _) <- sendGroupMessage' user gInfo members XGrpLeave @@ -1942,74 +1942,74 @@ processChatCommand' vr = \case deleteGroupLinkIfExists user gInfo -- member records are not deleted to keep history deleteMembersConnections' user members True - withStore' $ \db -> updateGroupMemberStatus db userId membership GSMemLeft + withFastStore' $ \db -> updateGroupMemberStatus db userId membership GSMemLeft pure $ CRLeftMemberUser user gInfo {membership = membership {memberStatus = GSMemLeft}} APIListMembers groupId -> withUser $ \user -> - CRGroupMembers user <$> withStore (\db -> getGroup db vr user groupId) + CRGroupMembers user <$> withFastStore (\db -> getGroup db vr user groupId) AddMember gName cName memRole -> withUser $ \user -> do - (groupId, contactId) <- withStore $ \db -> (,) <$> getGroupIdByName db user gName <*> getContactIdByName db user cName + (groupId, contactId) <- withFastStore $ \db -> (,) <$> getGroupIdByName db user gName <*> getContactIdByName db user cName processChatCommand $ APIAddMember groupId contactId memRole JoinGroup gName -> withUser $ \user -> do - groupId <- withStore $ \db -> getGroupIdByName db user gName + groupId <- withFastStore $ \db -> getGroupIdByName db user gName processChatCommand $ APIJoinGroup groupId MemberRole gName gMemberName memRole -> withMemberName gName gMemberName $ \gId gMemberId -> APIMemberRole gId gMemberId memRole BlockForAll gName gMemberName blocked -> withMemberName gName gMemberName $ \gId gMemberId -> APIBlockMemberForAll gId gMemberId blocked RemoveMember gName gMemberName -> withMemberName gName gMemberName APIRemoveMember LeaveGroup gName -> withUser $ \user -> do - groupId <- withStore $ \db -> getGroupIdByName db user gName + groupId <- withFastStore $ \db -> getGroupIdByName db user gName processChatCommand $ APILeaveGroup groupId DeleteGroup gName -> withUser $ \user -> do - groupId <- withStore $ \db -> getGroupIdByName db user gName + groupId <- withFastStore $ \db -> getGroupIdByName db user gName processChatCommand $ APIDeleteChat (ChatRef CTGroup groupId) (CDMFull True) ClearGroup gName -> withUser $ \user -> do - groupId <- withStore $ \db -> getGroupIdByName db user gName + groupId <- withFastStore $ \db -> getGroupIdByName db user gName processChatCommand $ APIClearChat (ChatRef CTGroup groupId) ListMembers gName -> withUser $ \user -> do - groupId <- withStore $ \db -> getGroupIdByName db user gName + groupId <- withFastStore $ \db -> getGroupIdByName db user gName processChatCommand $ APIListMembers groupId APIListGroups userId contactId_ search_ -> withUserId userId $ \user -> - CRGroupsList user <$> withStore' (\db -> getUserGroupsWithSummary db vr user contactId_ search_) + CRGroupsList user <$> withFastStore' (\db -> getUserGroupsWithSummary db vr user contactId_ search_) ListGroups cName_ search_ -> withUser $ \user@User {userId} -> do - ct_ <- forM cName_ $ \cName -> withStore $ \db -> getContactByName db vr user cName + ct_ <- forM cName_ $ \cName -> withFastStore $ \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 + g <- withFastStore $ \db -> getGroup db vr user groupId runUpdateGroupProfile user g p' UpdateGroupNames gName GroupProfile {displayName, fullName} -> updateGroupProfileByName gName $ \p -> p {displayName, fullName} ShowGroupProfile gName -> withUser $ \user -> - CRGroupProfile user <$> withStore (\db -> getGroupInfoByName db vr user gName) + CRGroupProfile user <$> withFastStore (\db -> getGroupInfoByName db vr user gName) UpdateGroupDescription gName description -> updateGroupProfileByName gName $ \p -> p {description} ShowGroupDescription gName -> withUser $ \user -> - CRGroupDescription user <$> withStore (\db -> getGroupInfoByName db vr user gName) + CRGroupDescription user <$> withFastStore (\db -> getGroupInfoByName db vr user gName) APICreateGroupLink groupId mRole -> withUser $ \user -> withGroupLock "createGroupLink" groupId $ do - gInfo <- withStore $ \db -> getGroupInfo db vr user groupId + gInfo <- withFastStore $ \db -> getGroupInfo db vr user groupId assertUserGroupRole gInfo GRAdmin when (mRole > GRMember) $ throwChatError $ CEGroupMemberInitialRole gInfo mRole groupLinkId <- GroupLinkId <$> drgRandomBytes 16 subMode <- chatReadVar subscriptionMode let crClientData = encodeJSON $ CRDataGroup groupLinkId (connId, cReq) <- withAgent $ \a -> createConnection a (aUserId user) True SCMContact (Just crClientData) IKPQOff subMode - withStore $ \db -> createGroupLink db user gInfo connId cReq groupLinkId mRole subMode + withFastStore $ \db -> createGroupLink db user gInfo connId cReq groupLinkId mRole subMode pure $ CRGroupLinkCreated user gInfo cReq mRole APIGroupLinkMemberRole groupId mRole' -> withUser $ \user -> withGroupLock "groupLinkMemberRole" groupId $ do - gInfo <- withStore $ \db -> getGroupInfo db vr user groupId - (groupLinkId, groupLink, mRole) <- withStore $ \db -> getGroupLink db user gInfo + gInfo <- withFastStore $ \db -> getGroupInfo db vr user groupId + (groupLinkId, groupLink, mRole) <- withFastStore $ \db -> getGroupLink db user gInfo assertUserGroupRole gInfo GRAdmin when (mRole' > GRMember) $ throwChatError $ CEGroupMemberInitialRole gInfo mRole' - when (mRole' /= mRole) $ withStore' $ \db -> setGroupLinkMemberRole db user groupLinkId mRole' + when (mRole' /= mRole) $ withFastStore' $ \db -> setGroupLinkMemberRole db user groupLinkId mRole' pure $ CRGroupLink user gInfo groupLink mRole' APIDeleteGroupLink groupId -> withUser $ \user -> withGroupLock "deleteGroupLink" groupId $ do - gInfo <- withStore $ \db -> getGroupInfo db vr user groupId + gInfo <- withFastStore $ \db -> getGroupInfo db vr user groupId deleteGroupLink' user gInfo pure $ CRGroupLinkDeleted user gInfo APIGetGroupLink groupId -> withUser $ \user -> do - gInfo <- withStore $ \db -> getGroupInfo db vr user groupId - (_, groupLink, mRole) <- withStore $ \db -> getGroupLink db user gInfo + gInfo <- withFastStore $ \db -> getGroupInfo db vr user groupId + (_, groupLink, mRole) <- withFastStore $ \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 vr user gId gMemberId + (g, m) <- withFastStore $ \db -> (,) <$> getGroupInfo db vr user gId <*> getGroupMember db vr user gId gMemberId assertUserGroupRole g GRAuthor unless (groupFeatureMemberAllowed SGFDirectMessages (membership g) g) $ throwChatError $ CECommandError "direct messages not allowed" case memberConn m of @@ -2020,19 +2020,19 @@ processChatCommand' vr = \case -- TODO PQ should negotitate contact connection with PQSupportOn? (connId, cReq) <- withAgent $ \a -> createConnection a (aUserId user) True SCMInvitation Nothing IKPQOff subMode -- [incognito] reuse membership incognito profile - ct <- withStore' $ \db -> createMemberContact db user connId cReq g m mConn subMode + ct <- withFastStore' $ \db -> createMemberContact db user connId cReq g m mConn subMode -- TODO not sure it is correct to set connections status here? lift $ setContactNetworkStatus ct NSConnected pure $ CRNewMemberContact user ct g m _ -> throwChatError CEGroupMemberNotActive APISendMemberContactInvitation contactId msgContent_ -> withUser $ \user -> do - (g@GroupInfo {groupId}, m, ct, cReq) <- withStore $ \db -> getMemberContact db vr user contactId + (g@GroupInfo {groupId}, m, ct, cReq) <- withFastStore $ \db -> getMemberContact db vr user contactId when (contactGrpInvSent ct) $ throwChatError $ CECommandError "x.grp.direct.inv already sent" case memberConn m of Just mConn -> do let msg = XGrpDirectInv cReq msgContent_ (sndMsg, _, _) <- sendDirectMemberMessage mConn msg groupId - withStore' $ \db -> setContactGrpInvSent db ct True + withFastStore' $ \db -> setContactGrpInvSent db ct True let ct' = ct {contactGrpInvSent = True} forM_ msgContent_ $ \mc -> do ci <- saveSndChatItem user (CDDirectSnd ct') sndMsg (CISndMsgContent mc) @@ -2040,28 +2040,28 @@ processChatCommand' vr = \case pure $ CRNewMemberContactSentInv user ct' g m _ -> throwChatError CEGroupMemberNotActive CreateGroupLink gName mRole -> withUser $ \user -> do - groupId <- withStore $ \db -> getGroupIdByName db user gName + groupId <- withFastStore $ \db -> getGroupIdByName db user gName processChatCommand $ APICreateGroupLink groupId mRole GroupLinkMemberRole gName mRole -> withUser $ \user -> do - groupId <- withStore $ \db -> getGroupIdByName db user gName + groupId <- withFastStore $ \db -> getGroupIdByName db user gName processChatCommand $ APIGroupLinkMemberRole groupId mRole DeleteGroupLink gName -> withUser $ \user -> do - groupId <- withStore $ \db -> getGroupIdByName db user gName + groupId <- withFastStore $ \db -> getGroupIdByName db user gName processChatCommand $ APIDeleteGroupLink groupId ShowGroupLink gName -> withUser $ \user -> do - groupId <- withStore $ \db -> getGroupIdByName db user gName + groupId <- withFastStore $ \db -> getGroupIdByName db user gName processChatCommand $ APIGetGroupLink groupId SendGroupMessageQuote gName cName quotedMsg msg -> withUser $ \user -> do - groupId <- withStore $ \db -> getGroupIdByName db user gName - quotedItemId <- withStore $ \db -> getGroupChatItemIdByText db user groupId cName quotedMsg + groupId <- withFastStore $ \db -> getGroupIdByName db user gName + quotedItemId <- withFastStore $ \db -> getGroupChatItemIdByText db user groupId cName quotedMsg let mc = MCText msg processChatCommand . APISendMessage (ChatRef CTGroup groupId) False Nothing $ ComposedMessage Nothing (Just quotedItemId) mc ClearNoteFolder -> withUser $ \user -> do - folderId <- withStore (`getUserNoteFolderId` user) + folderId <- withFastStore (`getUserNoteFolderId` user) processChatCommand $ APIClearChat (ChatRef CTLocal folderId) LastChats count_ -> withUser' $ \user -> do let count = fromMaybe 5000 count_ - (errs, previews) <- partitionEithers <$> withStore' (\db -> getChatPreviews db vr user False (PTLast count) clqNoFilters) + (errs, previews) <- partitionEithers <$> withFastStore' (\db -> getChatPreviews db vr user False (PTLast count) clqNoFilters) unless (null errs) $ toView $ CRChatErrors (Just user) (map ChatErrorStore errs) pure $ CRChats previews LastMessages (Just chatName) count search -> withUser $ \user -> do @@ -2069,22 +2069,22 @@ processChatCommand' vr = \case chatResp <- processChatCommand $ APIGetChat chatRef (CPLast count) search pure $ CRChatItems user (Just chatName) (aChatItems . chat $ chatResp) LastMessages Nothing count search -> withUser $ \user -> do - chatItems <- withStore $ \db -> getAllChatItems db vr user (CPLast count) search + chatItems <- withFastStore $ \db -> getAllChatItems db vr user (CPLast count) search pure $ CRChatItems user Nothing chatItems LastChatItemId (Just chatName) index -> withUser $ \user -> do chatRef <- getChatRef user chatName chatResp <- processChatCommand (APIGetChat chatRef (CPLast $ index + 1) Nothing) pure $ CRChatItemId user (fmap aChatItemId . listToMaybe . aChatItems . chat $ chatResp) LastChatItemId Nothing index -> withUser $ \user -> do - chatItems <- withStore $ \db -> getAllChatItems db vr user (CPLast $ index + 1) Nothing + chatItems <- withFastStore $ \db -> getAllChatItems db vr user (CPLast $ index + 1) Nothing pure $ CRChatItemId user (fmap aChatItemId . listToMaybe $ chatItems) ShowChatItem (Just itemId) -> withUser $ \user -> do - chatItem <- withStore $ \db -> do + chatItem <- withFastStore $ \db -> do chatRef <- getChatRefViaItemId db user itemId getAChatItem db vr user chatRef itemId pure $ CRChatItems user Nothing ((: []) chatItem) ShowChatItem Nothing -> withUser $ \user -> do - chatItems <- withStore $ \db -> getAllChatItems db vr user (CPLast 1) Nothing + chatItems <- withFastStore $ \db -> getAllChatItems db vr user (CPLast 1) Nothing pure $ CRChatItems user Nothing chatItems ShowChatItemInfo chatName msg -> withUser $ \user -> do chatRef <- getChatRef user chatName @@ -2108,6 +2108,7 @@ processChatCommand' vr = \case ForwardFile chatName fileId -> forwardFile chatName fileId SendFile ForwardImage chatName fileId -> forwardFile chatName fileId SendImage SendFileDescription _chatName _f -> pure $ chatCmdError Nothing "TODO" + -- TODO to use priority transactions we need a parameter that differentiates manual and automatic acceptance ReceiveFile fileId userApprovedRelays encrypted_ rcvInline_ filePath_ -> withUser $ \_ -> withFileLock "receiveFile" fileId . procCmd $ do (user, ft@RcvFileTransfer {fileStatus}) <- withStore (`getRcvFileTransferById` fileId) @@ -2122,7 +2123,7 @@ processChatCommand' vr = \case ok_ CancelFile fileId -> withUser $ \user@User {userId} -> withFileLock "cancelFile" fileId . procCmd $ - withStore (\db -> getFileTransfer db user fileId) >>= \case + withFastStore (\db -> getFileTransfer db user fileId) >>= \case FTSnd ftm@FileTransferMeta {xftpSndFile, cancelled} fts | cancelled -> throwChatError $ CEFileCancel fileId "file already cancelled" | not (null fts) && all fileCancelledOrCompleteSMP fts -> @@ -2130,16 +2131,16 @@ processChatCommand' vr = \case | otherwise -> do fileAgentConnIds <- cancelSndFile user ftm fts True deleteAgentConnectionsAsync user fileAgentConnIds - withStore (\db -> liftIO $ lookupChatRefByFileId db user fileId) >>= \case + withFastStore (\db -> liftIO $ lookupChatRefByFileId db user fileId) >>= \case Nothing -> pure () Just (ChatRef CTDirect contactId) -> do - (contact, sharedMsgId) <- withStore $ \db -> (,) <$> getContact db vr user contactId <*> getSharedMsgIdByFileId db userId fileId + (contact, sharedMsgId) <- withFastStore $ \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 + (Group gInfo ms, sharedMsgId) <- withFastStore $ \db -> (,) <$> getGroup db vr user groupId <*> getSharedMsgIdByFileId db userId fileId void . sendGroupMessage user gInfo ms $ XFileCancel sharedMsgId Just _ -> throwChatError $ CEFileInternal "invalid chat ref for file transfer" - ci <- withStore $ \db -> lookupChatItemByFileId db vr user fileId + ci <- withFastStore $ \db -> lookupChatItemByFileId db vr user fileId pure $ CRSndFileCancelled user ci ftm fts where fileCancelledOrCompleteSMP SndFileTransfer {fileStatus = s} = @@ -2150,7 +2151,7 @@ processChatCommand' vr = \case | otherwise -> case xftpRcvFile of Nothing -> do cancelRcvFileTransfer user ftr >>= mapM_ (deleteAgentConnectionAsync user) - ci <- withStore $ \db -> lookupChatItemByFileId db vr user fileId + ci <- withFastStore $ \db -> lookupChatItemByFileId db vr user fileId pure $ CRRcvFileCancelled user ci ftr Just XFTPRcvFile {agentRcvFileId} -> do forM_ (liveRcvFileTransferPath ftr) $ \filePath -> do @@ -2161,9 +2162,9 @@ processChatCommand' vr = \case aci_ <- resetRcvCIFileStatus user fileId CIFSRcvInvitation pure $ CRRcvFileCancelled user aci_ ftr FileStatus fileId -> withUser $ \user -> do - withStore (\db -> lookupChatItemByFileId db vr user fileId) >>= \case + withFastStore (\db -> lookupChatItemByFileId db vr user fileId) >>= \case Nothing -> do - fileStatus <- withStore $ \db -> getFileTransferProgress db user fileId + fileStatus <- withFastStore $ \db -> getFileTransferProgress db user fileId pure $ CRFileTransferStatus user fileStatus Just ci@(AChatItem _ _ _ ChatItem {file}) -> case file of Just CIFile {fileProtocol = FPLocal} -> @@ -2171,7 +2172,7 @@ processChatCommand' vr = \case Just CIFile {fileProtocol = FPXFTP} -> pure $ CRFileTransferStatusXFTP user ci _ -> do - fileStatus <- withStore $ \db -> getFileTransferProgress db user fileId + fileStatus <- withFastStore $ \db -> getFileTransferProgress db user fileId pure $ CRFileTransferStatus user fileStatus ShowProfile -> withUser $ \user@User {profile} -> pure $ CRUserProfile user (fromLocalProfile profile) UpdateProfile displayName fullName -> withUser $ \user@User {profile} -> do @@ -2185,7 +2186,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 vr user cName + ct@Contact {userPreferences} <- withFastStore $ \db -> getContactByName db vr user cName let prefs' = setPreference f allowed_ $ Just userPreferences updateContactPrefs user ct prefs' SetGroupFeature (AGFNR f) gName enabled -> @@ -2200,7 +2201,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 vr user cName + ct@Contact {userPreferences = userPreferences@Preferences {timedMessages}} <- withFastStore $ \db -> getContactByName db vr user cName let currentTTL = timedMessages >>= \TimedMessagesPreference {ttl} -> ttl pref_ = tmeToPref currentTTL <$> timedMessagesEnabled_ prefs' = setPreference' SCFTimedMessages pref_ $ Just userPreferences @@ -2244,7 +2245,7 @@ processChatCommand' vr = \case ShowVersion -> do -- simplexmqCommitQ makes iOS builds crash m( let versionInfo = coreVersionInfo "" - chatMigrations <- map upMigration <$> withStore' (Migrations.getCurrent . DB.conn) + chatMigrations <- map upMigration <$> withFastStore' (Migrations.getCurrent . DB.conn) agentMigrations <- withAgent getAgentMigrations pure $ CRVersionInfo {versionInfo, chatMigrations, agentMigrations} DebugLocks -> lift $ do @@ -2317,10 +2318,10 @@ processChatCommand' vr = \case getChatRef :: User -> ChatName -> CM ChatRef getChatRef user (ChatName cType name) = ChatRef cType <$> case cType of - CTDirect -> withStore $ \db -> getContactIdByName db user name - CTGroup -> withStore $ \db -> getGroupIdByName db user name + CTDirect -> withFastStore $ \db -> getContactIdByName db user name + CTGroup -> withFastStore $ \db -> getGroupIdByName db user name CTLocal - | name == "" -> withStore (`getUserNoteFolderId` user) + | name == "" -> withFastStore (`getUserNoteFolderId` user) | otherwise -> throwChatError $ CECommandError "not supported" _ -> throwChatError $ CECommandError "not supported" checkChatStopped :: CM ChatResponse -> CM ChatResponse @@ -2332,10 +2333,10 @@ processChatCommand' vr = \case checkStoreNotChanged :: CM ChatResponse -> CM ChatResponse checkStoreNotChanged = ifM (asks chatStoreChanged >>= readTVarIO) (throwChatError CEChatStoreChanged) withUserName :: UserName -> (UserId -> ChatCommand) -> CM ChatResponse - withUserName uName cmd = withStore (`getUserIdByName` uName) >>= processChatCommand . cmd + withUserName uName cmd = withFastStore (`getUserIdByName` uName) >>= processChatCommand . cmd withContactName :: ContactName -> (ContactId -> ChatCommand) -> CM ChatResponse withContactName cName cmd = withUser $ \user -> - withStore (\db -> getContactIdByName db user cName) >>= processChatCommand . cmd + withFastStore (\db -> getContactIdByName db user cName) >>= processChatCommand . cmd withMemberName :: GroupName -> ContactName -> (GroupId -> GroupMemberId -> ChatCommand) -> CM ChatResponse withMemberName gName mName cmd = withUser $ \user -> getGroupAndMemberId user gName mName >>= processChatCommand . uncurry cmd @@ -2345,23 +2346,23 @@ processChatCommand' vr = \case verifyConnectionCode user conn@Connection {connId} (Just code) = do code' <- getConnectionCode $ aConnId conn let verified = sameVerificationCode code code' - when verified . withStore' $ \db -> setConnectionVerified db user connId $ Just code' + when verified . withFastStore' $ \db -> setConnectionVerified db user connId $ Just code' pure $ CRConnectionVerified user verified code' verifyConnectionCode user conn@Connection {connId} _ = do code' <- getConnectionCode $ aConnId conn - withStore' $ \db -> setConnectionVerified db user connId Nothing + withFastStore' $ \db -> setConnectionVerified db user connId Nothing pure $ CRConnectionVerified user False code' getSentChatItemIdByText :: User -> ChatRef -> Text -> CM Int64 getSentChatItemIdByText user@User {userId, localDisplayName} (ChatRef cType cId) msg = case cType of - CTDirect -> withStore $ \db -> getDirectChatItemIdByText db userId cId SMDSnd msg - CTGroup -> withStore $ \db -> getGroupChatItemIdByText db user cId (Just localDisplayName) msg - CTLocal -> withStore $ \db -> getLocalChatItemIdByText db user cId SMDSnd msg + CTDirect -> withFastStore $ \db -> getDirectChatItemIdByText db userId cId SMDSnd msg + CTGroup -> withFastStore $ \db -> getGroupChatItemIdByText db user cId (Just localDisplayName) msg + CTLocal -> withFastStore $ \db -> getLocalChatItemIdByText db user cId SMDSnd msg _ -> throwChatError $ CECommandError "not supported" getChatItemIdByText :: User -> ChatRef -> Text -> CM Int64 getChatItemIdByText user (ChatRef cType cId) msg = case cType of - CTDirect -> withStore $ \db -> getDirectChatItemIdByText' db user cId msg - CTGroup -> withStore $ \db -> getGroupChatItemIdByText' db user cId msg - CTLocal -> withStore $ \db -> getLocalChatItemIdByText' db user cId msg + CTDirect -> withFastStore $ \db -> getDirectChatItemIdByText' db user cId msg + CTGroup -> withFastStore $ \db -> getGroupChatItemIdByText' db user cId msg + CTLocal -> withFastStore $ \db -> getLocalChatItemIdByText' db user cId msg _ -> throwChatError $ CECommandError "not supported" connectViaContact :: User -> IncognitoEnabled -> ConnectionRequestUri 'CMContact -> CM ChatResponse connectViaContact user@User {userId} incognito cReq@(CRContactUri ConnReqUriData {crClientData}) = withInvitationLock "connectViaContact" (strEncode cReq) $ do @@ -2370,7 +2371,7 @@ processChatCommand' vr = \case case groupLinkId of -- contact address Nothing -> - withStore' (\db -> getConnReqContactXContactId db vr user cReqHash) >>= \case + withFastStore' (\db -> getConnReqContactXContactId db vr user cReqHash) >>= \case (Just contact, _) -> pure $ CRContactAlreadyExists user contact (_, xContactId_) -> procCmd $ do let randomXContactId = XContactId <$> drgRandomBytes 16 @@ -2378,7 +2379,7 @@ processChatCommand' vr = \case connect' Nothing cReqHash xContactId False -- group link Just gLinkId -> - withStore' (\db -> getConnReqContactXContactId db vr user cReqHash) >>= \case + withFastStore' (\db -> getConnReqContactXContactId db vr user cReqHash) >>= \case (Just _contact, _) -> procCmd $ do -- allow repeat contact request newXContactId <- XContactId <$> drgRandomBytes 16 @@ -2394,7 +2395,7 @@ processChatCommand' vr = \case -- [incognito] generate profile to send incognitoProfile <- if incognito then Just <$> liftIO generateRandomProfile else pure Nothing subMode <- chatReadVar subscriptionMode - conn@PendingContactConnection {pccConnId} <- withStore' $ \db -> createConnReqConnection db userId connId cReqHash xContactId incognitoProfile groupLinkId subMode chatV pqSup + conn@PendingContactConnection {pccConnId} <- withFastStore' $ \db -> createConnReqConnection db userId connId cReqHash xContactId incognitoProfile groupLinkId subMode chatV pqSup joinContact user pccConnId connId cReq incognitoProfile xContactId inGroup pqSup chatV pure $ CRSentInvitation user conn incognitoProfile connectContactViaAddress :: User -> IncognitoEnabled -> Contact -> ConnectionRequestUri 'CMContact -> CM ChatResponse @@ -2407,7 +2408,7 @@ processChatCommand' vr = \case -- [incognito] generate profile to send incognitoProfile <- if incognito then Just <$> liftIO generateRandomProfile else pure Nothing subMode <- chatReadVar subscriptionMode - (pccConnId, ct') <- withStore $ \db -> createAddressContactConnection db vr user ct connId cReqHash newXContactId incognitoProfile subMode chatV pqSup + (pccConnId, ct') <- withFastStore $ \db -> createAddressContactConnection db vr user ct connId cReqHash newXContactId incognitoProfile subMode chatV pqSup joinContact user pccConnId connId cReq incognitoProfile newXContactId False pqSup chatV pure $ CRSentInvitationToContact user ct' incognitoProfile prepareContact :: User -> ConnectionRequestUri 'CMContact -> PQSupport -> CM (ConnId, VersionChat) @@ -2431,7 +2432,7 @@ processChatCommand' vr = \case joinPreparedAgentConnection user pccConnId connId cReq connInfo pqSup subMode = do void (withAgent $ \a -> joinConnection a (aUserId user) (Just connId) True cReq connInfo pqSup subMode) `catchChatError` \e -> do - withStore' $ \db -> deleteConnectionRecord db user pccConnId + withFastStore' $ \db -> deleteConnectionRecord db user pccConnId withAgent $ \a -> deleteConnectionAsync a False connId throwError e contactMember :: Contact -> [GroupMember] -> Maybe GroupMember @@ -2446,14 +2447,14 @@ processChatCommand' vr = \case when (fromInteger fileSize > maxFileSize) $ throwChatError $ CEFileSize f pure fileSize updateProfile :: User -> Profile -> CM ChatResponse - updateProfile user p' = updateProfile_ user p' $ withStore $ \db -> updateUserProfile db user p' + updateProfile user p' = updateProfile_ user p' $ withFastStore $ \db -> updateUserProfile db user p' updateProfile_ :: User -> Profile -> CM User -> CM ChatResponse updateProfile_ user@User {profile = p@LocalProfile {displayName = n}} p'@Profile {displayName = n'} updateUser | p' == fromLocalProfile p = pure $ CRUserProfileNoChange user | otherwise = do when (n /= n') $ checkValidName n' -- read contacts before user update to correctly merge preferences - contacts <- withStore' $ \db -> getUserContacts db vr user + contacts <- withFastStore' $ \db -> getUserContacts db vr user user' <- updateUser asks currentUser >>= atomically . (`writeTVar` Just user') withChatLock "updateProfile" . procCmd $ do @@ -2631,34 +2632,34 @@ processChatCommand' vr = \case setUserPrivacy user@User {userId} user'@User {userId = userId'} | userId == userId' = do asks currentUser >>= atomically . (`writeTVar` Just user') - withStore' (`updateUserPrivacy` user') + withFastStore' (`updateUserPrivacy` user') pure $ CRUserPrivacy {user = user', updatedUser = user'} | otherwise = do - withStore' (`updateUserPrivacy` user') + withFastStore' (`updateUserPrivacy` user') pure $ CRUserPrivacy {user, updatedUser = user'} checkDeleteChatUser :: User -> CM () checkDeleteChatUser user@User {userId} = do - users <- withStore' getUsers + users <- withFastStore' getUsers let otherVisible = filter (\User {userId = userId', viewPwdHash} -> userId /= userId' && isNothing viewPwdHash) users when (activeUser user && length otherVisible > 0) $ throwChatError (CECantDeleteActiveUser userId) deleteChatUser :: User -> Bool -> CM ChatResponse deleteChatUser user delSMPQueues = do - filesInfo <- withStore' (`getUserFileInfo` user) + filesInfo <- withFastStore' (`getUserFileInfo` user) cancelFilesInProgress user filesInfo deleteFilesLocally filesInfo withAgent $ \a -> deleteUser a (aUserId user) delSMPQueues - withStore' (`deleteUserRecord` user) + withFastStore' (`deleteUserRecord` user) when (activeUser user) $ chatWriteVar currentUser Nothing ok_ updateChatSettings :: ChatName -> (ChatSettings -> ChatSettings) -> CM ChatResponse updateChatSettings (ChatName cType name) updateSettings = withUser $ \user -> do (chatId, chatSettings) <- case cType of - CTDirect -> withStore $ \db -> do + CTDirect -> withFastStore $ \db -> do ctId <- getContactIdByName db user name Contact {chatSettings} <- getContact db vr user ctId pure (ctId, chatSettings) CTGroup -> - withStore $ \db -> do + withFastStore $ \db -> do gId <- getGroupIdByName db user name GroupInfo {chatSettings} <- getGroupInfo db vr user gId pure (gId, chatSettings) @@ -2666,7 +2667,7 @@ processChatCommand' vr = \case processChatCommand $ APISetChatSettings (ChatRef cType chatId) $ updateSettings chatSettings connectPlan :: User -> AConnectionRequestUri -> CM ConnectionPlan connectPlan user (ACR SCMInvitation (CRInvitationUri crData e2e)) = do - withStore' (\db -> getConnectionEntityByConnReq db vr user cReqSchemas) >>= \case + withFastStore' (\db -> getConnectionEntityByConnReq db vr user cReqSchemas) >>= \case Nothing -> pure $ CPInvitationLink ILPOk Just (RcvDirectMsgConnection conn ct_) -> do let Connection {connStatus, contactConnInitiated} = conn @@ -2691,12 +2692,12 @@ processChatCommand' vr = \case case groupLinkId of -- contact address Nothing -> - withStore' (\db -> getUserContactLinkByConnReq db user cReqSchemas) >>= \case + withFastStore' (\db -> getUserContactLinkByConnReq db user cReqSchemas) >>= \case Just _ -> pure $ CPContactAddress CAPOwnLink Nothing -> - withStore' (\db -> getContactConnEntityByConnReqHash db vr user cReqHashes) >>= \case + withFastStore' (\db -> getContactConnEntityByConnReqHash db vr user cReqHashes) >>= \case Nothing -> - withStore' (\db -> getContactWithoutConnViaAddress db vr user cReqSchemas) >>= \case + withFastStore' (\db -> getContactWithoutConnViaAddress db vr user cReqSchemas) >>= \case Nothing -> pure $ CPContactAddress CAPOk Just ct -> pure $ CPContactAddress (CAPContactViaAddress ct) Just (RcvDirectMsgConnection _conn Nothing) -> pure $ CPContactAddress CAPConnectingConfirmReconnect @@ -2707,11 +2708,11 @@ processChatCommand' vr = \case Just _ -> throwChatError $ CECommandError "found connection entity is not RcvDirectMsgConnection" -- group link Just _ -> - withStore' (\db -> getGroupInfoByUserContactLinkConnReq db vr user cReqSchemas) >>= \case + withFastStore' (\db -> getGroupInfoByUserContactLinkConnReq db vr user cReqSchemas) >>= \case Just g -> pure $ CPGroupLink (GLPOwnLink g) Nothing -> do - connEnt_ <- withStore' $ \db -> getContactConnEntityByConnReqHash db vr user cReqHashes - gInfo_ <- withStore' $ \db -> getGroupInfoByGroupLinkHash db vr user cReqHashes + connEnt_ <- withFastStore' $ \db -> getContactConnEntityByConnReqHash db vr user cReqHashes + gInfo_ <- withFastStore' $ \db -> getGroupInfoByGroupLinkHash db vr user cReqHashes case (gInfo_, connEnt_) of (Nothing, Nothing) -> pure $ CPGroupLink GLPOk (Nothing, Just (RcvDirectMsgConnection _conn Nothing)) -> pure $ CPGroupLink GLPConnectingConfirmReconnect @@ -2734,7 +2735,7 @@ processChatCommand' vr = \case cReqHashes = bimap hash hash cReqSchemas hash = ConnReqUriHash . C.sha256Hash . strEncode updateCIGroupInvitationStatus user GroupInfo {groupId} newStatus = do - AChatItem _ _ cInfo ChatItem {content, meta = CIMeta {itemId}} <- withStore $ \db -> getChatItemByGroupId db vr user groupId + AChatItem _ _ cInfo ChatItem {content, meta = CIMeta {itemId}} <- withFastStore $ \db -> getChatItemByGroupId db vr user groupId case (cInfo, content) of (DirectChat ct@Contact {contactId}, CIRcvGroupInvitation ciGroupInv@CIGroupInvitation {status} memRole) | status == CIGISPending -> do @@ -2746,9 +2747,9 @@ processChatCommand' vr = \case _ -> pure () -- prohibited sendContactContentMessage :: User -> ContactId -> Bool -> Maybe Int -> ComposedMessage -> Maybe CIForwardedFrom -> CM ChatResponse sendContactContentMessage user contactId live itemTTL (ComposedMessage file_ quotedItemId_ mc) itemForwarded = do - ct@Contact {contactUsed} <- withStore $ \db -> getContact db vr user contactId + ct@Contact {contactUsed} <- withFastStore $ \db -> getContact db vr user contactId assertDirectAllowed user MDSnd ct XMsgNew_ - unless contactUsed $ withStore' $ \db -> updateContactUsed db user ct + unless contactUsed $ withFastStore' $ \db -> updateContactUsed db user ct if isVoice mc && not (featureAllowed SCFVoice forUser ct) then pure $ chatCmdError (Just user) ("feature not allowed " <> T.unpack (chatFeatureNameText CFVoice)) else do @@ -2771,7 +2772,7 @@ processChatCommand' vr = \case (Nothing, Just _) -> pure (MCForward (ExtMsgContent mc fInv_ (ttl' <$> timed_) (justTrue live)), Nothing) (Just quotedItemId, Nothing) -> do CChatItem _ qci@ChatItem {meta = CIMeta {itemTs, itemSharedMsgId}, formattedText, file} <- - withStore $ \db -> getDirectChatItem db user contactId quotedItemId + withFastStore $ \db -> getDirectChatItem db user contactId quotedItemId (origQmc, qd, sent) <- quoteData qci let msgRef = MsgRef {msgId = itemSharedMsgId, sentAt = itemTs, sent, memberId = Nothing} qmc = quoteContent mc origQmc file @@ -2786,7 +2787,7 @@ processChatCommand' vr = \case quoteData _ = throwChatError CEInvalidQuote sendGroupContentMessage :: User -> GroupId -> Bool -> Maybe Int -> ComposedMessage -> Maybe CIForwardedFrom -> CM ChatResponse sendGroupContentMessage user groupId live itemTTL (ComposedMessage file_ quotedItemId_ mc) itemForwarded = do - g@(Group gInfo _) <- withStore $ \db -> getGroup db vr user groupId + g@(Group gInfo _) <- withFastStore $ \db -> getGroup db vr user groupId assertUserGroupRole gInfo GRAuthor send g where @@ -2799,7 +2800,7 @@ processChatCommand' vr = \case (msgContainer, quotedItem_) <- prepareGroupMsg user gInfo mc quotedItemId_ itemForwarded fInv_ timed_ live (msg, groupSndResult) <- sendGroupMessage user gInfo ms (XMsgNew msgContainer) ci <- saveSndChatItem' user (CDGroupSnd gInfo) msg (CISndMsgContent mc) ciFile_ quotedItem_ itemForwarded timed_ live - withStore' $ \db -> do + withFastStore' $ \db -> do let GroupSndResult {sentTo, pending, forwarded} = groupSndResult createMemberSndStatuses db ci sentTo GSSNew createMemberSndStatuses db ci forwarded GSSForwarded @@ -2820,20 +2821,20 @@ processChatCommand' vr = \case (fInv, ciFile, ft) <- xftpSndFileTransfer_ user file fileSize n $ Just contactOrGroup case contactOrGroup of CGContact Contact {activeConn} -> forM_ activeConn $ \conn -> - withStore' $ \db -> createSndFTDescrXFTP db user Nothing conn ft dummyFileDescr + withFastStore' $ \db -> createSndFTDescrXFTP db user Nothing conn ft dummyFileDescr CGGroup (Group _ ms) -> forM_ ms $ \m -> saveMemberFD m `catchChatError` (toView . CRChatError (Just user)) where -- we are not sending files to pending members, same as with inline files saveMemberFD m@GroupMember {activeConn = Just conn@Connection {connStatus}} = when ((connStatus == ConnReady || connStatus == ConnSndReady) && not (connDisabled conn)) $ - withStore' $ + withFastStore' $ \db -> createSndFTDescrXFTP db user (Just m) conn ft dummyFileDescr saveMemberFD _ = pure () pure (fInv, ciFile) createNoteFolderContentItem :: User -> NoteFolderId -> ComposedMessage -> Maybe CIForwardedFrom -> CM ChatResponse createNoteFolderContentItem user folderId (ComposedMessage file_ quotedItemId_ mc) itemForwarded = do forM_ quotedItemId_ $ \_ -> throwError $ ChatError $ CECommandError "not supported" - nf <- withStore $ \db -> getNoteFolder db user folderId + nf <- withFastStore $ \db -> getNoteFolder db user folderId createdAt <- liftIO getCurrentTime let content = CISndMsgContent mc let cd = CDLocalSnd nf @@ -2842,13 +2843,13 @@ processChatCommand' vr = \case fsFilePath <- lift $ toFSFilePath filePath fileSize <- liftIO $ CF.getFileContentsSize $ CryptoFile fsFilePath cryptoArgs chunkSize <- asks $ fileChunkSize . config - withStore' $ \db -> do + withFastStore' $ \db -> do fileId <- createLocalFile CIFSSndStored db user nf ciId createdAt cf fileSize chunkSize pure CIFile {fileId, fileName = takeFileName filePath, fileSize, fileSource = Just cf, fileStatus = CIFSSndStored, fileProtocol = FPLocal} let ci = mkChatItem cd ciId content ciFile_ Nothing Nothing itemForwarded Nothing False createdAt Nothing createdAt pure . CRNewChatItem user $ AChatItem SCTLocal SMDSnd (LocalChat nf) ci getConnQueueInfo user Connection {connId, agentConnId = AgentConnId acId} = do - msgInfo <- withStore' (`getLastRcvMsgInfo` connId) + msgInfo <- withFastStore' (`getLastRcvMsgInfo` connId) CRQueueInfo user msgInfo <$> withAgent (`getConnectionQueueInfo` acId) contactCITimed :: Contact -> CM (Maybe CITimed) diff --git a/src/Simplex/Chat/Controller.hs b/src/Simplex/Chat/Controller.hs index 66a4aca95d..b7eff9101a 100644 --- a/src/Simplex/Chat/Controller.hs +++ b/src/Simplex/Chat/Controller.hs @@ -73,7 +73,7 @@ import Simplex.Messaging.Agent.Client (AgentLocks, AgentQueuesInfo (..), AgentWo import Simplex.Messaging.Agent.Env.SQLite (AgentConfig, NetworkConfig, ServerCfg) import Simplex.Messaging.Agent.Lock import Simplex.Messaging.Agent.Protocol -import Simplex.Messaging.Agent.Store.SQLite (MigrationConfirmation, SQLiteStore, UpMigration, withTransaction) +import Simplex.Messaging.Agent.Store.SQLite (MigrationConfirmation, SQLiteStore, UpMigration, withTransaction, withTransactionPriority) import Simplex.Messaging.Agent.Store.SQLite.DB (SlowQueryStats (..)) import qualified Simplex.Messaging.Agent.Store.SQLite.DB as DB import Simplex.Messaging.Client (SMPProxyFallback (..), SMPProxyMode (..), SocksMode (..)) @@ -1393,11 +1393,24 @@ toView' ev = do withStore' :: (DB.Connection -> IO a) -> CM a withStore' action = withStore $ liftIO . action +{-# INLINE withStore' #-} + +withFastStore' :: (DB.Connection -> IO a) -> CM a +withFastStore' action = withFastStore $ liftIO . action +{-# INLINE withFastStore' #-} withStore :: (DB.Connection -> ExceptT StoreError IO a) -> CM a -withStore action = do +withStore = withStorePriority False +{-# INLINE withStore #-} + +withFastStore :: (DB.Connection -> ExceptT StoreError IO a) -> CM a +withFastStore = withStorePriority True +{-# INLINE withFastStore #-} + +withStorePriority :: Bool -> (DB.Connection -> ExceptT StoreError IO a) -> CM a +withStorePriority priority action = do ChatController {chatStore} <- ask - liftIOEither $ withTransaction chatStore (runExceptT . withExceptT ChatErrorStore . action) `E.catches` handleDBErrors + liftIOEither $ withTransactionPriority chatStore priority (runExceptT . withExceptT ChatErrorStore . action) `E.catches` handleDBErrors withStoreBatch :: Traversable t => (DB.Connection -> t (IO (Either ChatError a))) -> CM' (t (Either ChatError a)) withStoreBatch actions = do