From 583c3c28a4313920c4f045d242d2ffc1785bc3c0 Mon Sep 17 00:00:00 2001 From: "Evgeny @ SimpleX Chat" <259188159+evgeny-simplex@users.noreply.github.com> Date: Fri, 11 Sep 2026 21:03:13 +0000 Subject: [PATCH] refactor --- .../src/Directory/Store.hs | 2 +- plans/2026-09-04-feed-broadcast-chat.md | 5 +- plans/2026-09-11-feed-jobs-split.md | 3 +- src/Simplex/Chat/Library/Commands.hs | 29 +++--- src/Simplex/Chat/Library/Internal.hs | 41 ++++----- src/Simplex/Chat/Library/Subscriber.hs | 32 +++---- src/Simplex/Chat/Store/Direct.hs | 3 +- src/Simplex/Chat/Store/Feeds.hs | 28 +++--- src/Simplex/Chat/Store/Messages.hs | 88 ++++++++++++++++--- src/Simplex/Chat/Store/Shared.hs | 3 +- 10 files changed, 146 insertions(+), 88 deletions(-) diff --git a/apps/simplex-directory-service/src/Directory/Store.hs b/apps/simplex-directory-service/src/Directory/Store.hs index ba36d4cc21..ea7f7f5ee0 100644 --- a/apps/simplex-directory-service/src/Directory/Store.hs +++ b/apps/simplex-directory-service/src/Directory/Store.hs @@ -465,7 +465,7 @@ toMaybeGroupLink _ = Nothing -- group with its registration and its join link (user_contact_links) in one query groupReqQuery :: Query -groupReqQuery = "SELECT " <> groupInfoQueryFields <> groupRegFields <> groupLinkFields <> groupInfoQueryFrom <> groupLinkJoin <> groupRegFromCond +groupReqQuery = groupInfoQueryFields <> groupRegFields <> groupLinkFields <> groupInfoQueryFrom <> groupLinkJoin <> groupRegFromCond where groupRegFields = ", r.group_id, r.user_group_reg_id, r.contact_id, r.owner_member_id, r.group_reg_status, r.group_promoted, r.created_at " groupLinkFields = ", uc.user_contact_link_id, uc.conn_req_contact, uc.short_link_contact, uc.short_link_data_set, uc.short_link_large_data_set, uc.group_link_id, uc.group_link_member_role " diff --git a/plans/2026-09-04-feed-broadcast-chat.md b/plans/2026-09-04-feed-broadcast-chat.md index 99040811eb..2e5918277b 100644 --- a/plans/2026-09-04-feed-broadcast-chat.md +++ b/plans/2026-09-04-feed-broadcast-chat.md @@ -21,7 +21,10 @@ implementing: - The feed item's own reactions come from `getFeedCIReactions` inside `getFeedChatItem`, as the direct and group item getters do. - `CRBroadcastSent` and `viewSentBroadcast` are removed; the broadcast bot - matches `CRNewChatItems` and replies "Message is sent to the feed". + matches `CRNewChatItems` and replies "Message is being delivered to all contacts". +- `contactQuery`, `contactQueryFields` and `contactQueryFrom` are defined in + `Store/Direct.hs` after `getContact_`, not in `Store/Shared.hs`, and keep + `SELECT` inside the fields fragment as `groupInfoQueryFields` does. - Tests create the feed with `createCCFeed` (as `createCCNoteFolder`), since test users are created by `createUserRecordAt` directly. diff --git a/plans/2026-09-11-feed-jobs-split.md b/plans/2026-09-11-feed-jobs-split.md index 5e980565a7..94782104a2 100644 --- a/plans/2026-09-11-feed-jobs-split.md +++ b/plans/2026-09-11-feed-jobs-split.md @@ -93,8 +93,7 @@ Feed job statements move to `src/Simplex/Chat/Store/Feeds.hs`: `src/Simplex/Chat/Library/Subscriber.hs`: - `runDeliveryJobWorker` loses its `case deliveryKey` and handles groups only -- add `runFeedJobWorker` with the same `jobLoop`/`withWork_` shape -- extract the shared shape as `jobWorkerLoop :: Int64 -> Worker -> CM () -> CM ()` plus `jobOperation`, parameterised by the read, the processor and the error writer +- add `runFeedJobWorker` with the same `forever`/`withWork_` shape; `runDeliveryJobWorker` keeps its master shape - `getDeliveryJobWorker` handles `DeliveryWorkerKey`; add `getFeedJobWorker` for `FeedJobKey` - `startDeliveryJobWorkers` reads group scopes; add `startFeedJobWorkers` reading feed scopes - `startFeedWorkers` uses `getFeedJobWorker` diff --git a/src/Simplex/Chat/Library/Commands.hs b/src/Simplex/Chat/Library/Commands.hs index 7f1afe1ad0..ece864ae14 100644 --- a/src/Simplex/Chat/Library/Commands.hs +++ b/src/Simplex/Chat/Library/Commands.hs @@ -81,11 +81,10 @@ import Simplex.Chat.Store.ContactRequest import Simplex.Chat.Store.Connections import Simplex.Chat.Store.Delivery import Simplex.Chat.Store.Direct +import Simplex.Chat.Store.Feeds import Simplex.Chat.Store.Files import Simplex.Chat.Store.Groups import Simplex.Chat.Store.Messages -import Simplex.Chat.Store.Feeds hiding (detachFeedInstances) -import qualified Simplex.Chat.Store.Feeds as Store import Simplex.Chat.Store.NoteFolders import Simplex.Chat.Store.Profiles import Simplex.Chat.Store.Shared @@ -818,7 +817,7 @@ processChatCommand cxt nm = \case when changed $ addInitialAndNewCIVersions db itemId (chatItemTs' ci, oldMC) (currentTs, mc) let edited = itemLive /= Just True - when (itemFeed == Just CIFLinked) $ Store.detachFeedInstances db [itemId] + when (itemFeed == Just CIFLinked) $ detachFeedInstances db [itemId] updateDirectChatItem' db user contactId (detachedInstance ci) (CISndMsgContent mc) edited live Nothing $ Just msgId startUpdatedTimedItemThread user (ChatRef CTDirect contactId Nothing) ci ci' pure $ CRChatItemUpdated user (AChatItem SCTDirect SMDSnd (DirectChat ct) ci') @@ -854,7 +853,7 @@ processChatCommand cxt nm = \case when changed $ addInitialAndNewCIVersions db itemId (chatItemTs' ci, oldMC) (currentTs, mc) let edited = itemLive /= Just True - when (itemFeed == Just CIFLinked) $ Store.detachFeedInstances db [itemId] + when (itemFeed == Just CIFLinked) $ detachFeedInstances db [itemId] ci' <- updateGroupChatItem db user groupId (detachedInstance ci) (CISndMsgContent mc) edited live $ Just msgId updateGroupCIMentions db gInfo ci' ciMentions startUpdatedTimedItemThread user (ChatRef CTGroup groupId scope) ci ci' @@ -901,12 +900,12 @@ processChatCommand cxt nm = \case APIDeleteChatItem (ChatRef cType chatId scope) itemIds mode -> withUser $ \user -> case cType of CTDirect -> withContactLock "deleteChatItem" chatId $ do (ct, items) <- getCommandDirectChatItems user chatId itemIds - let markDeleted items' = do - items'' <- detachFeedInstances items' - markDirectCIsDeleted user ct items'' =<< liftIO getCurrentTime + let markDeleted = do + items' <- detachFeedItems items + markDirectCIsDeleted user ct items' =<< liftIO getCurrentTime deletions <- case mode of CIDMInternal -> deleteDirectCIs user ct items - CIDMInternalMark -> markDeleted items + CIDMInternalMark -> markDeleted CIDMHistory -> throwChatError CEInvalidChatItemDelete CIDMBroadcast -> do assertDeletable items @@ -917,7 +916,7 @@ processChatCommand cxt nm = \case sendDirectContactMessages user ct events' if featureAllowed SCFFullDelete forUser ct then deleteDirectCIs user ct items - else markDeleted items + else markDeleted pure $ CRChatItemsDeleted user deletions True False CTGroup -> withGroupLock "deleteChatItem" chatId $ do (gInfo, items) <- getCommandGroupChatItems user chatId itemIds @@ -928,7 +927,7 @@ processChatCommand cxt nm = \case | publicGroupEditor gInfo (membership gInfo) -> throwChatError CEInvalidChatItemDelete | otherwise -> deleteGroupCIs user gInfo chatScopeInfo items Nothing =<< liftIO getCurrentTime CIDMInternalMark -> do - items' <- detachFeedInstances items + items' <- detachFeedItems items markGroupCIsDeleted user gInfo chatScopeInfo items' Nothing =<< liftIO getCurrentTime CIDMBroadcast -> do recipients <- getGroupRecipients cxt user gInfo chatScopeInfo groupKnockingVersion @@ -4249,11 +4248,11 @@ processChatCommand cxt nm = \case ciIds <- concat <$> withStore' (\db -> forM items $ \(CChatItem _ ci) -> markMessageReportsDeleted db user gInfo ci membership deletedTs) unless (null ciIds) $ toView $ CEvtGroupChatItemsDeleted user gInfo ciIds True (Just membership) let m = if moderation then Just membership else Nothing - fullDelete = groupFeatureUserAllowed SGFFullDelete gInfo - items' <- if fullDelete && not moderation then pure items else detachFeedInstances items - if fullDelete - then deleteGroupCIs user gInfo chatScopeInfo items' m deletedTs - else markGroupCIsDeleted user gInfo chatScopeInfo items' m deletedTs + if groupFeatureUserAllowed SGFFullDelete gInfo + then deleteGroupCIs user gInfo chatScopeInfo items m deletedTs + else do + items' <- detachFeedItems items + markGroupCIsDeleted user gInfo chatScopeInfo items' m deletedTs updateGroupProfileByName :: GroupName -> (GroupProfile -> GroupProfile) -> CM ChatResponse updateGroupProfileByName = updateGroupProfileByName_ Nothing updateGroupProfileByName_ :: Maybe GroupFeature -> GroupName -> (GroupProfile -> GroupProfile) -> CM ChatResponse diff --git a/src/Simplex/Chat/Library/Internal.hs b/src/Simplex/Chat/Library/Internal.hs index f83e7733b9..1d37305551 100644 --- a/src/Simplex/Chat/Library/Internal.hs +++ b/src/Simplex/Chat/Library/Internal.hs @@ -70,7 +70,7 @@ import Simplex.Chat.Delivery (FeedJobAction (..)) import Simplex.Chat.Store import Simplex.Chat.Store.ContactRequest import Simplex.Chat.Store.Direct -import qualified Simplex.Chat.Store.Feeds as Store +import Simplex.Chat.Store.Feeds import Simplex.Chat.Store.Files import Simplex.Chat.Store.Groups import Simplex.Chat.Store.Messages @@ -529,9 +529,9 @@ itemsFilesInfo = mapMaybe itemFileInfo SMDSnd | isJust itemFeed -> Nothing _ -> mkCIFileInfo <$> file -detachFeedInstances :: forall c. [CChatItem c] -> CM [CChatItem c] -detachFeedInstances items = do - unless (null linkedIds) $ withStore' $ \db -> Store.detachFeedInstances db linkedIds +detachFeedItems :: forall c. [CChatItem c] -> CM [CChatItem c] +detachFeedItems items = do + unless (null linkedIds) $ withStore' $ \db -> detachFeedInstances db linkedIds pure $ map detached items where linkedIds = mapMaybe linkedItemId items @@ -2270,13 +2270,17 @@ createSndMessage chatMsgEvent connOrGroupId = liftEither . runIdentity =<< lift (createSndMessages $ Identity (connOrGroupId, Nothing, chatMsgEvent)) createSndMessages :: forall e t. (MsgEncodingI e, Traversable t) => t (ConnOrGroupId, Maybe MsgSigning, ChatMsgEvent e) -> CM' (t (Either ChatError SndMessage)) -createSndMessages = createSndMessages_ Nothing - -createFeedMessage :: Feed -> Maybe SharedMsgId -> ChatItemId -> ChatMsgEvent 'Json -> CM SndMessage -createFeedMessage feed sharedMsgId_ feedItemId event = do - mkMsg <- feedMessageMaker - createdAt <- liftIO getCurrentTime - withStore $ \db -> mkMsg db feed sharedMsgId_ feedItemId event createdAt +createSndMessages idsEvents = do + g <- asks random + vr <- chatVersionRange' + withStoreBatch $ \db -> fmap (createMsg db g vr) idsEvents + where + createMsg :: DB.Connection -> TVar ChaChaDRG -> VersionRangeChat -> (ConnOrGroupId, Maybe MsgSigning, ChatMsgEvent e) -> IO (Either ChatError SndMessage) + createMsg db g vr (connOrGroupId, msgSigning_, evnt) = runExceptT $ do + withExceptT ChatErrorStore $ createNewSndMessage db g connOrGroupId Nothing evnt msgSigning_ encodeMessage + where + encodeMessage sharedMsgId = + encodeChatMessage maxEncodedMsgLength ChatMessage {chatVRange = vr, msgId = Just sharedMsgId, chatMsgEvent = evnt} feedMessageMaker :: CM (DB.Connection -> Feed -> Maybe SharedMsgId -> ChatItemId -> ChatMsgEvent 'Json -> UTCTime -> ExceptT StoreError IO SndMessage) feedMessageMaker = do @@ -2294,7 +2298,7 @@ createFeedFileDescrJobs feed feedItemId events = do createdAt <- liftIO getCurrentTime withStore $ \db -> do msgs <- mapM (\evt -> mkMsg db feed Nothing feedItemId evt createdAt) events - liftIO $ Store.createFeedJobs db (feedId' feed) feedItemId $ FJAFileDescr (L.map msgId' msgs) + liftIO $ createFeedJobs db (feedId' feed) feedItemId $ FJAFileDescr (L.map msgId' msgs) feedId' :: Feed -> FeedId feedId' Feed {feedId} = feedId @@ -2305,19 +2309,6 @@ msgId' SndMessage {msgId} = msgId aFeedItem :: Feed -> CChatItem 'CTFeed -> AChatItem aFeedItem feed (CChatItem md ci) = AChatItem SCTFeed md (FeedChat feed) ci -createSndMessages_ :: forall e t. (MsgEncodingI e, Traversable t) => Maybe SharedMsgId -> t (ConnOrGroupId, Maybe MsgSigning, ChatMsgEvent e) -> CM' (t (Either ChatError SndMessage)) -createSndMessages_ sharedMsgId_ idsEvents = do - g <- asks random - vr <- chatVersionRange' - withStoreBatch $ \db -> fmap (createMsg db g vr) idsEvents - where - createMsg :: DB.Connection -> TVar ChaChaDRG -> VersionRangeChat -> (ConnOrGroupId, Maybe MsgSigning, ChatMsgEvent e) -> IO (Either ChatError SndMessage) - createMsg db g vr (connOrGroupId, msgSigning_, evnt) = runExceptT $ do - withExceptT ChatErrorStore $ createNewSndMessage db g connOrGroupId sharedMsgId_ evnt msgSigning_ encodeMessage - where - encodeMessage sharedMsgId = - encodeChatMessage maxEncodedMsgLength ChatMessage {chatVRange = vr, msgId = Just sharedMsgId, chatMsgEvent = evnt} - groupMsgSigning :: Bool -> GroupInfo -> ChatMsgEvent e -> Maybe MsgSigning groupMsgSigning sign GroupInfo {membership = GroupMember {memberId}, groupKeys} evt = case groupKeys of Just gks@GroupKeys {memberPrivKey} | shouldSign -> Just $ MsgSigning CBGroup bindingData KRMember memberPrivKey diff --git a/src/Simplex/Chat/Library/Subscriber.hs b/src/Simplex/Chat/Library/Subscriber.hs index 5436c4e56b..c1bfb3d33f 100644 --- a/src/Simplex/Chat/Library/Subscriber.hs +++ b/src/Simplex/Chat/Library/Subscriber.hs @@ -4198,16 +4198,22 @@ runDeliveryJobWorker a deliveryKey Worker {doWork} = do user <- getUserByGroupId db groupId gInfo <- getGroupInfo db cxt user groupId pure (user, gInfo) - jobWorkerLoop delay doWork $ - withWork_ a doWork (withStore' $ \db -> getNextDeliveryJob db deliveryKey) $ \job -> - processDeliveryJob cxt user gInfo job - `catchAllErrors` \e -> do - withStore' $ \db -> setDeliveryJobErrStatus db (deliveryJobId job) (tshow e) - eToView e + forever $ do + unless (delay == 0) $ liftIO $ threadDelay' delay + lift $ waitForWork doWork + runDeliveryJobOperation cxt user gInfo where (groupId, workerScope) = deliveryKey - processDeliveryJob :: StoreCxt -> User -> GroupInfo -> MessageDeliveryJob -> CM () - processDeliveryJob cxt user gInfo job = + runDeliveryJobOperation :: StoreCxt -> User -> GroupInfo -> CM () + runDeliveryJobOperation cxt user gInfo = do + withWork_ a doWork (withStore' $ \db -> getNextDeliveryJob db deliveryKey) $ \job -> + processDeliveryJob job + `catchAllErrors` \e -> do + withStore' $ \db -> setDeliveryJobErrStatus db (deliveryJobId job) (tshow e) + eToView e + where + processDeliveryJob :: MessageDeliveryJob -> CM () + processDeliveryJob job = case jobScopeImpliedSpec jobScope of DJDeliveryJob _includePending | not (relayServesGroup gInfo) -> do @@ -4382,12 +4388,6 @@ runDeliveryJobWorker a deliveryKey Worker {doWork} = do Nothing -> VRValue Nothing msgBody -- sending to one member, do not reference body Just 1 -> VRValue (Just 1) msgBody Just _ -> VRRef 1 -jobWorkerLoop :: Int64 -> TMVar () -> CM () -> CM () -jobWorkerLoop delay doWork operation = forever $ do - unless (delay == 0) $ liftIO $ threadDelay' delay - lift $ waitForWork doWork - operation - runFeedJobWorker :: AgentClient -> FeedJobKey -> Worker -> CM () runFeedJobWorker a feedKey@(feedId, scope) Worker {doWork} = do delay <- asks $ deliveryWorkerDelay . config @@ -4397,7 +4397,9 @@ runFeedJobWorker a feedKey@(feedId, scope) Worker {doWork} = do feed <- getFeed db user feedId pure (user, feed) bucketSize <- asks $ feedBucketSize . config - jobWorkerLoop delay doWork $ + forever $ do + unless (delay == 0) $ liftIO $ threadDelay' delay + lift $ waitForWork doWork withWork_ a doWork (withStore' $ \db -> getNextFeedJob db feedKey) $ \job -> processFeedJob cxt user feed bucketSize job `catchAllErrors` jobError user feed job where diff --git a/src/Simplex/Chat/Store/Direct.hs b/src/Simplex/Chat/Store/Direct.hs index 9ceadb694e..ac99d3cbe4 100644 --- a/src/Simplex/Chat/Store/Direct.hs +++ b/src/Simplex/Chat/Store/Direct.hs @@ -976,11 +976,12 @@ getContact_ db cxt user@User {userId} contactId deleted = do (userId, contactId, BI deleted) contactQuery :: Query -contactQuery = "SELECT " <> contactQueryFields <> " " <> contactQueryFrom +contactQuery = contactQueryFields <> " " <> contactQueryFrom contactQueryFields :: Query contactQueryFields = [sql| + SELECT -- Contact ct.contact_id, ct.contact_profile_id, ct.local_display_name, cp.display_name, cp.full_name, cp.short_descr, cp.description, cp.image, cp.contact_link, cp.chat_peer_type, cp.local_alias, ct.contact_used, ct.contact_status, ct.enable_ntfs, ct.send_rcpts, ct.favorite, ct.drop_feed, cp.preferences, ct.user_preferences, ct.created_at, ct.updated_at, ct.chat_ts, ct.conn_full_link_to_connect, ct.conn_short_link_to_connect, ct.welcome_shared_msg_id, ct.request_shared_msg_id, ct.contact_request_id, cr2.rejection_supported, diff --git a/src/Simplex/Chat/Store/Feeds.hs b/src/Simplex/Chat/Store/Feeds.hs index cdd5e426a7..db3f8345b9 100644 --- a/src/Simplex/Chat/Store/Feeds.hs +++ b/src/Simplex/Chat/Store/Feeds.hs @@ -111,12 +111,11 @@ deleteFeedCIs db User {userId} Feed {feedId} = do getFeedContactsByCursor :: DB.Connection -> StoreCxt -> User -> ChatItemId -> Maybe ContactId -> Int -> IO [(Contact, Maybe ChatItemId)] getFeedContactsByCursor db cxt user@User {userId} feedItemId cursorId_ count = do currentTs <- getCurrentTime - map (\(Only itemId_ :. row) -> (toContact currentTs cxt user [] row, itemId_)) + map (\(row :. Only itemId_) -> (toContact currentTs cxt user [] row, itemId_)) <$> DB.query db - ( "SELECT i.chat_item_id, " - <> contactQueryFields - <> " " + ( contactQueryFields + <> ", i.chat_item_id " <> contactQueryFrom <> " LEFT JOIN chat_items i ON i.feed_item_id = ? AND i.contact_id = ct.contact_id" <> " WHERE ct.user_id = ? AND ct.deleted = 0 AND ct.is_user = 0 AND ct.contact_id > ?" @@ -127,12 +126,11 @@ getFeedContactsByCursor db cxt user@User {userId} feedItemId cursorId_ count = d getFeedCustomerGroupsByCursor :: DB.Connection -> StoreCxt -> User -> ChatItemId -> Maybe GroupId -> Int -> IO [(GroupInfo, Maybe ChatItemId)] getFeedCustomerGroupsByCursor db cxt User {userId, userContactId} feedItemId cursorId_ count = do currentTs <- getCurrentTime - map (\(Only itemId_ :. row) -> (toGroupInfo currentTs cxt userContactId [] row, itemId_)) + map (\(row :. Only itemId_) -> (toGroupInfo currentTs cxt userContactId [] row, itemId_)) <$> DB.query db - ( "SELECT i.chat_item_id, " - <> groupInfoQueryFields - <> " " + ( groupInfoQueryFields + <> ", i.chat_item_id " <> groupInfoQueryFrom <> " LEFT JOIN chat_items i ON i.feed_item_id = ? AND i.group_id = g.group_id" <> " WHERE g.user_id = ? AND mu.contact_id = ? AND g.business_chat = ? AND g.group_id > ?" @@ -182,12 +180,11 @@ instanceSpecCond = \case getFeedContactInstancesByCursor :: DB.Connection -> StoreCxt -> User -> ChatItemId -> FeedJobAction -> Maybe ContactId -> Int -> IO [(Contact, ChatItemId)] getFeedContactInstancesByCursor db cxt user@User {userId} feedItemId spec cursorId_ count = do currentTs <- getCurrentTime - map (\(Only itemId :. row) -> (toContact currentTs cxt user [] row, itemId)) + map (\(row :. Only itemId) -> (toContact currentTs cxt user [] row, itemId)) <$> DB.query db - ( "SELECT i.chat_item_id, " - <> contactQueryFields - <> " " + ( contactQueryFields + <> ", i.chat_item_id " <> contactQueryFrom <> " JOIN chat_items i ON i.contact_id = ct.contact_id" <> " WHERE i.user_id = ? AND i.feed_item_id = ? AND i.contact_id > ?" @@ -199,12 +196,11 @@ getFeedContactInstancesByCursor db cxt user@User {userId} feedItemId spec cursor getFeedGroupInstancesByCursor :: DB.Connection -> StoreCxt -> User -> ChatItemId -> FeedJobAction -> Maybe GroupId -> Int -> IO [(GroupInfo, ChatItemId)] getFeedGroupInstancesByCursor db cxt User {userId, userContactId} feedItemId spec cursorId_ count = do currentTs <- getCurrentTime - map (\(Only itemId :. row) -> (toGroupInfo currentTs cxt userContactId [] row, itemId)) + map (\(row :. Only itemId) -> (toGroupInfo currentTs cxt userContactId [] row, itemId)) <$> DB.query db - ( "SELECT i.chat_item_id, " - <> groupInfoQueryFields - <> " " + ( groupInfoQueryFields + <> ", i.chat_item_id " <> groupInfoQueryFrom <> " JOIN chat_items i ON i.group_id = g.group_id" <> " WHERE i.user_id = ? AND mu.contact_id = ? AND i.feed_item_id = ? AND i.group_id > ?" diff --git a/src/Simplex/Chat/Store/Messages.hs b/src/Simplex/Chat/Store/Messages.hs index 6652ed7973..22b46079e4 100644 --- a/src/Simplex/Chat/Store/Messages.hs +++ b/src/Simplex/Chat/Store/Messages.hs @@ -47,7 +47,6 @@ module Simplex.Chat.Store.Messages insertChatItemMessage_, getFeedChat, getFeedChatItem, - getFeedCIReactions, getFeedChatItemIdByText, updateFeedChatItem', updateFeedChatItemStatus, @@ -1346,20 +1345,21 @@ getDirectChatLast_ db user ct contentFilter count search = do safeGetDirectItem :: DB.Connection -> User -> Contact -> UTCTime -> ChatItemId -> IO (CChatItem 'CTDirect) safeGetDirectItem db user ct currentTs itemId = runExceptT (getDirectCIWithReactions db user ct itemId) - >>= pure <$> safeToChatItem CIDirectSnd currentTs itemId + >>= pure <$> safeToDirectItem currentTs itemId -safeToChatItem :: CIDirection c 'MDSnd -> UTCTime -> ChatItemId -> Either StoreError (CChatItem c) -> CChatItem c -safeToChatItem chatDir currentTs itemId = \case +safeToDirectItem :: UTCTime -> ChatItemId -> Either StoreError (CChatItem 'CTDirect) -> CChatItem 'CTDirect +safeToDirectItem currentTs itemId = \case Right ci -> ci - Left e@(SEBadChatItem _ (Just itemTs)) -> badChatItem itemTs e - Left e -> badChatItem currentTs e + Left e@(SEBadChatItem _ (Just itemTs)) -> badDirectItem itemTs e + Left e -> badDirectItem currentTs e where - badChatItem ts e = + badDirectItem :: UTCTime -> StoreError -> CChatItem 'CTDirect + badDirectItem ts e = let errorText = T.pack $ show e in CChatItem SMDSnd ChatItem - { chatDir, + { chatDir = CIDirectSnd, meta = dummyMeta itemId ts errorText, content = CIInvalidJSON errorText, mentions = M.empty, @@ -1697,7 +1697,29 @@ getChatItemIDs db User {userId} cInfo contentFilter range count search = case cI safeGetGroupItem :: DB.Connection -> User -> GroupInfo -> UTCTime -> ChatItemId -> IO (CChatItem 'CTGroup) safeGetGroupItem db user g currentTs itemId = runExceptT (getGroupCIWithReactions db user g itemId) - >>= pure <$> safeToChatItem CIGroupSnd currentTs itemId + >>= pure <$> safeToGroupItem currentTs itemId + +safeToGroupItem :: UTCTime -> ChatItemId -> Either StoreError (CChatItem 'CTGroup) -> CChatItem 'CTGroup +safeToGroupItem currentTs itemId = \case + Right ci -> ci + Left e@(SEBadChatItem _ (Just itemTs)) -> badGroupItem itemTs e + Left e -> badGroupItem currentTs e + where + badGroupItem :: UTCTime -> StoreError -> CChatItem 'CTGroup + badGroupItem ts e = + let errorText = T.pack $ show e + in CChatItem + SMDSnd + ChatItem + { chatDir = CIGroupSnd, + meta = dummyMeta itemId ts errorText, + content = CIInvalidJSON errorText, + mentions = M.empty, + formattedText = Nothing, + quotedItem = Nothing, + reactions = [], + file = Nothing + } getGroupMemberChatItemLast :: DB.Connection -> User -> GroupId -> GroupMemberId -> ExceptT StoreError IO (CChatItem 'CTGroup) getGroupMemberChatItemLast db user@User {userId} groupId groupMemberId = do @@ -1915,7 +1937,29 @@ getLocalChatLast_ db user nf contentFilter count search = do safeGetLocalItem :: DB.Connection -> User -> NoteFolder -> UTCTime -> ChatItemId -> IO (CChatItem 'CTLocal) safeGetLocalItem db user NoteFolder {noteFolderId} currentTs itemId = runExceptT (getLocalChatItem db user noteFolderId itemId) - >>= pure <$> safeToChatItem CILocalSnd currentTs itemId + >>= pure <$> safeToLocalItem currentTs itemId + +safeToLocalItem :: UTCTime -> ChatItemId -> Either StoreError (CChatItem 'CTLocal) -> CChatItem 'CTLocal +safeToLocalItem currentTs itemId = \case + Right ci -> ci + Left e@(SEBadChatItem _ (Just itemTs)) -> badLocalItem itemTs e + Left e -> badLocalItem currentTs e + where + badLocalItem :: UTCTime -> StoreError -> CChatItem 'CTLocal + badLocalItem ts e = + let errorText = T.pack $ show e + in CChatItem + SMDSnd + ChatItem + { chatDir = CILocalSnd, + meta = dummyMeta itemId ts errorText, + content = CIInvalidJSON errorText, + mentions = M.empty, + formattedText = Nothing, + quotedItem = Nothing, + reactions = [], + file = Nothing + } getLocalChatAfter_ :: DB.Connection -> User -> NoteFolder -> Maybe MsgContentTag -> ChatItemId -> Int -> Text -> ExceptT StoreError IO (Chat 'CTLocal) getLocalChatAfter_ db user nf@NoteFolder {noteFolderId} contentFilter afterId count search = do @@ -3385,7 +3429,29 @@ getFeedCIReactions db User {userId} itemSharedMsgId = safeGetFeedItem :: DB.Connection -> User -> Feed -> UTCTime -> ChatItemId -> IO (CChatItem 'CTFeed) safeGetFeedItem db user Feed {feedId} currentTs itemId = runExceptT (getFeedChatItem db user feedId itemId) - >>= pure <$> safeToChatItem CIFeedSnd currentTs itemId + >>= pure <$> safeToFeedItem currentTs itemId + +safeToFeedItem :: UTCTime -> ChatItemId -> Either StoreError (CChatItem 'CTFeed) -> CChatItem 'CTFeed +safeToFeedItem currentTs itemId = \case + Right ci -> ci + Left e@(SEBadChatItem _ (Just itemTs)) -> badFeedItem itemTs e + Left e -> badFeedItem currentTs e + where + badFeedItem :: UTCTime -> StoreError -> CChatItem 'CTFeed + badFeedItem ts e = + let errorText = T.pack $ show e + in CChatItem + SMDSnd + ChatItem + { chatDir = CIFeedSnd, + meta = dummyMeta itemId ts errorText, + content = CIInvalidJSON errorText, + mentions = M.empty, + formattedText = Nothing, + quotedItem = Nothing, + reactions = [], + file = Nothing + } getFeedChat :: DB.Connection -> User -> FeedId -> Maybe MsgContentTag -> ChatPagination -> Maybe Text -> ExceptT StoreError IO (Chat 'CTFeed, Maybe NavigationInfo) getFeedChat db user feedId contentFilter pagination search_ = do diff --git a/src/Simplex/Chat/Store/Shared.hs b/src/Simplex/Chat/Store/Shared.hs index 4f2aa5d01e..b8d2021f70 100644 --- a/src/Simplex/Chat/Store/Shared.hs +++ b/src/Simplex/Chat/Store/Shared.hs @@ -799,11 +799,12 @@ toBusinessChatInfo businessDomain (Just chatType, Just businessId, Just customer toBusinessChatInfo _ _ = Nothing groupInfoQuery :: Query -groupInfoQuery = "SELECT " <> groupInfoQueryFields <> " " <> groupInfoQueryFrom +groupInfoQuery = groupInfoQueryFields <> " " <> groupInfoQueryFrom groupInfoQueryFields :: Query groupInfoQueryFields = [sql| + SELECT -- GroupInfo g.group_id, g.local_display_name, gp.display_name, gp.full_name, gp.short_descr, g.local_alias, gp.description, gp.image, gp.group_type, gp.group_link, gp.public_group_id, gp.group_web_page, gp.group_domain, gp.domain_web_page, gp.allow_embedding, gp.group_domain_proof,