dandri/simplex-chat
1
0
Fork 0
mirror of https://github.com/simplex-chat/simplex-chat.git synced 2026-09-27 17:58:47 +00:00
Code Issues Packages Projects Releases Wiki Activity

implement

Browse Source
This commit is contained in:
Evgeny @ SimpleX Chat
2026-09-11 09:51:44 +00:00
parent 5a78d9894f
commit bf6d2fbda5
34 changed files with 1907 additions and 436 deletions
Download Patch File Download Diff File Expand all files Collapse all files
apps/simplex-broadcast-bot/src/Broadcast/Bot.hs
+2 -2
View File
@@ -49,8 +49,8 @@ broadcastBot BroadcastBotOpts {publishers, welcomeMessage, prohibitedMessage} _u
| allowContent mc ->
void $ forkIO $
sendChatCmd cc (SendMessageBroadcast mc) >>= \case
Right CRBroadcastSent {successes, failures} ->
sendReply $ "Forwarded to " <> tshow successes <> " contact(s), " <> tshow failures <> " errors"
-- delivery to the recipients continues in feed delivery jobs
Right CRNewChatItems {} -> sendReply "Message is being delivered to all contacts"
r -> putStrLn $ "Error broadcasting message: " <> show r
| otherwise ->
sendReply "!1 Message is not supported!"
apps/simplex-directory-service/src/Directory/Store.hs
+1 -1
View File
@@ -465,7 +465,7 @@ toMaybeGroupLink _ = Nothing
-- group with its registration and its join link (user_contact_links) in one query
groupReqQuery :: Query
groupReqQuery = groupInfoQueryFields <> groupRegFields <> groupLinkFields <> groupInfoQueryFrom <> groupLinkJoin <> groupRegFromCond
groupReqQuery = "SELECT " <> 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 "
bots/src/API/Docs/Commands.hs
+2
View File
@@ -285,6 +285,7 @@ cliCommands =
"SetContactFeature",
"SetContactTimedMessages",
"SetGroupFeature",
"SetDropFeed",
"SetGroupFeatureRole",
"SetGroupMemberAdmissionReview",
"SetGroupTimedMessages",
@@ -408,6 +409,7 @@ undocumentedCommands =
"APISendCallExtraInfo",
"APISendCallInvitation",
"APISendCallOffer",
"APISendFeedMessage",
"APISendServiceRequest",
"APISetAppFilePaths",
"APISetChatItemTTL",
bots/src/API/Docs/Responses.hs
-1
View File
@@ -129,7 +129,6 @@ undocumentedResponses =
"CRAppSettings",
"CRArchiveExported",
"CRArchiveImported",
"CRBroadcastSent",
"CRCallInvitations",
"CRChatCleared",
"CRChatContentTypes",
bots/src/API/Docs/Types.hs
+5 -1
View File
@@ -230,11 +230,12 @@ chatTypesDocsData =
(sti @ChatRef, STRecord, "", [], Param "chatType" <> Param "chatId" <> Optional "" (Param "$0") "chatScope", "Used in API commands. Chat scope can only be passed with groups."),
(sti @ChatSettings, STRecord, "", [], "", ""),
(sti @ChatStats, STRecord, "", [], "", ""),
(sti @ChatType, STEnum, "CT", ["CTContactRequest", "CTContactConnection"], Choice "self" [("direct", "@"), ("group", "#"), ("local", "*")] "", ""),
(sti @ChatType, STEnum, "CT", ["CTContactRequest", "CTContactConnection"], Choice "self" [("direct", "@"), ("group", "#"), ("local", "*"), ("feed", "%")] "", ""),
(sti @ChatWallpaper, STRecord, "", [], "", ""),
(sti @ChatWallpaperScale, STEnum, "CWS", [], "", ""),
(sti @CICallStatus, STEnum, "CISCall", [], "", ""),
(sti @CIDeleteMode, STEnum, "CIDM", [], "", ""),
(sti @CIFeed, STEnum, "CIF", [], "", "Whether feed edits still apply to the message in this chat."),
(sti @CIForwardedFrom, STUnion, "CIFF", [], "", ""),
(sti @CIGroupInvitation, STRecord, "", [], "", ""),
(sti @CIGroupInvitationStatus, STEnum, "CIGIS", [], "", ""),
@@ -266,6 +267,7 @@ chatTypesDocsData =
(sti @E2EInfo, STRecord, "", [], "", ""),
(sti @ErrorType, STUnion, "", [], "", ""),
(sti @FeatureAllowed, STEnum, "FA", [], "", ""),
(sti @Feed, STRecord, "", [], "", "The chat of the messages broadcast to all contacts and customer groups."),
(sti @FileDescr, STRecord, "", [], "", ""),
(sti @FileError, STUnion, "FileErr", [], "", ""),
(sti @FileErrorType, STUnion, "", [], "", ""),
@@ -462,6 +464,7 @@ deriving instance Generic ChatWallpaper
deriving instance Generic ChatWallpaperScale
deriving instance Generic CICallStatus
deriving instance Generic CIDeleteMode
deriving instance Generic CIFeed
deriving instance Generic CIForwardedFrom
deriving instance Generic CIGroupInvitation
deriving instance Generic CIGroupInvitationStatus
@@ -493,6 +496,7 @@ deriving instance Generic DroppedMsg
deriving instance Generic E2EInfo
deriving instance Generic ErrorType
deriving instance Generic FeatureAllowed
deriving instance Generic Feed
deriving instance Generic FileDescr
deriving instance Generic FileError
deriving instance Generic FileErrorType
plans/2026-09-04-feed-broadcast-chat.md
+84 -65
View File
@@ -1,5 +1,34 @@
# Feed: a broadcast chat
Status: the core is implemented and compiles; the schema tests pass and the
schema dump is regenerated. Deviations from the sections below, made while
implementing:
- The bucket readers return `(Contact, ChatItemId)` and `(GroupInfo, ChatItemId)`
rather than whole instances: with no per-instance events the worker needs
the chat (for the connection, preferences and TTL) and the instance id
(to delete, mark or set status), and nothing else.
- `getFeedInstanceContactIdsByRange` and its group counterpart return
`Map chatId ChatItemId`, so an instance created by an earlier run of the
same bucket is reused rather than skipped.
- `createFeedInstanceItem` (`Store/Messages.hs`) is the instance writer, in
place of calling `createNewChatItem_` from the worker.
- 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".
- Tests create the feed with `createCCFeed` (as `createCCNoteFolder`), since
test users are created by `createUserRecordAt` directly.
Written of the Tests section: `tests/ChatTests/Feed.hs` — a broadcast with
`feedBucketSize = 1` to two contacts and two customer business groups, so
each stream runs three buckets; it asserts the four recipients receive the
message, the feed holds one item, and each recipient chat's last item is
the instance. The three existing tests that used `/feed` are updated.
Not written: the apps, the API docs, the Postgres migration, and the
remaining tests of the Tests section.
A feed is a per-user chat. Each item in it is a broadcast: one message sent to
every contact and, for a business, to every customer group. Each recipient chat
holds an instance of the broadcast as an ordinary sent item, marked as a feed
@@ -45,14 +74,15 @@ message id used here.
deletion, reactions, forwarding, expiration, disappearing messages. A
per-chat edit, or a per-chat deletion that keeps the row (a marked or a
moderated item), detaches the instance: `chat_items.item_feed` changes
from 1 (linked) to 2 (detached). Feed edits and feed deletes are applied
to linked instances only; feed file descriptions are sent for every
from 1 (linked) to 2 (detached). A feed edit is applied to linked
instances only, so it does not overwrite the per-chat text; a feed
deletion is a retraction of the broadcast and is applied to every
instance, linked or detached; a feed file description is sent for every
undeleted instance. The per-chat `XMsgUpdate` of an instance is sent with
`feed = Just True`, so a recipient with `dropFeed` discards it. Bulk
removals (`APIClearChat`, contact or group deletion, chat item expiration,
disappearing messages) remove instances; those recipients, and the
recipients of detached instances, are outside later feed edits and
deletes: the instances are the record of delivery.
disappearing messages) remove instances, and those recipients are outside
later feed edits and deletions: the instances are the record of delivery.
`chat_items.feed_item_id` (`ON DELETE SET NULL`) links every instance,
linked or detached, to the feed item and is the file join; after the feed
item is removed a remaining instance shows no file.
@@ -92,18 +122,16 @@ message id used here.
- Content: text, link, image, video, voice, file. One XFTP upload per
broadcast; one recipient description for everyone. Mentions, live
messages and the `ttl` parameter are rejected.
- Quotes: a feed item may quote an earlier item of the same feed. The quote
is `QuotedMsg {msgRef = MsgRef {msgId = Just quotedSharedMsgId, sentAt = itemTs, sent = True, memberId = Nothing}, content}`,
identical for every recipient (the shared id is the same everywhere), so
the body stays one. Direct recipients resolve it by the shared id
(`getChatItemQuote_`, `Store/Messages.hs:676`); group recipients show the
quote without a link to the item (`memberId = Nothing`, :683 — the
behaviour of channel quotes sent as group, `Internal.hs:230`). The
sender's feed item has `CIQuote {chatDir = CIQFeedSnd, itemId = Just quotedFeedItemId}`;
every instance stores the quote columns and the existing `ri` joins
(:2713, :3132) link it to the instance of the quoted broadcast in that
chat. A quote of an item outside the feed is rejected with
`SEInvalidQuote`.
- Quotes are rejected: `ChatTypeQuotable 'CTFeed` resolves to the existing
`TypeError` case, as for `CTLocal`. The wire format needs no change to
allow them later — the quote is part of the container.
- An instance does not call `updateChatTsStats`: a broadcast keeps the chat
list order and does not clear `chat_deleted` (`Store/Messages.hs:414`),
and one `UPDATE contacts` per recipient is avoided. A chat's preview line
is its last item, so it shows the broadcast on the next read.
- The job emits no per-instance events: instances are read when the chat is
opened. `CEvtNewChatItems`, `CEvtChatItemUpdated` and `CEvtChatItemsDeleted`
are emitted for the feed item only, with its status changes.
- Every feed event (`FeedJobAction`: new, file description, update, delete
for everyone, delete locally, mark deleted locally) is one job in each of
the two feed streams; the last of the two to complete finalises the
@@ -169,13 +197,12 @@ returns `(Maybe ContactId, Maybe GroupId, Maybe FeedId)`.
`jsonACIDirection` (:328).
- `ChatDirection` (:391): `CDFeedSnd :: Feed -> ChatDirection 'CTFeed 'MDSnd`;
`toCIDirection` (:400), `toChatInfo` (:410).
- `ChatTypeQuotable 'CTFeed = ()` (:643); `CIQDirection` (:649):
`CIQFeedSnd :: CIQDirection 'CTFeed`; `jsonCIQDirection` (:659)
`CIQFeedSnd -> JCIFeedSnd`; `jsonACIQDirection` (:667)
`JCIFeedSnd -> Right $ ACIQDirection SCTFeed CIQFeedSnd`;
`quoteMsgDirection` (:677) `CIQFeedSnd -> MDSnd`. `createNewSndChatItem`'s
`quoteRow` (`Store/Messages.hs:557`) gains `CIQFeedSnd -> (Just True, Nothing)`.
- `deletable'` (:542): the default branch applies to `SCTFeed`.
- `ChatTypeQuotable 'CTFeed` resolves to the existing `TypeError` case
(:646); `jsonACIQDirection` (:667): `JCIFeedSnd -> Left "unquotable"`.
- `deletable'` (:542): `SCTFeed` takes the `SCTLocal` branch
(`isNothing itemDeleted`), so a feed item stays deletable and editable
after a day; the 24-hour limit of a broadcast deletion is enforced by
`assertDeletable` (`Commands.hs:891`) for `CIDMBroadcast` only.
- `CIDeleted` (:1282): `CIDeleting :: Maybe UTCTime -> CIDeleted 'CTFeed`;
`JSONCIDeleted` (:1292): `JCIDDeleting {deletedTs}`; `jsonCIDeleted`,
`jsonACIDeleted`, `itemDeletedTs` (:1299-1318). `deletable'` and
@@ -391,7 +418,8 @@ New module `Store/Feeds.hs`:
+ `contactQueryFrom` joins,
`WHERE i.user_id = ? AND i.feed_item_id = ? AND i.contact_id > ? AND <spec> ORDER BY i.contact_id, c.connection_id LIMIT ?`
(`idx_chat_items_feed_item_contact`); `<spec>` is `i.item_feed = 1` for
`FJAUpdate` and the deletions, `i.item_deleted = 0` for `FJAFileDescr`.
`FJAUpdate`, `i.item_feed > 0` for the deletions, `i.item_deleted = 0`
for `FJAFileDescr`.
- `getFeedGroupInstancesByCursor db cxt user feedItemId spec cursor_ count :: IO [(GroupInfo, CChatItem 'CTGroup)]` —
the `getGroupChatItem` SELECT (:3094-3139) composed with
`groupInfoQueryFields`, `WHERE i.user_id = ? AND i.feed_item_id = ? AND i.group_id > ? AND <spec> ORDER BY i.group_id LIMIT ?`
@@ -446,7 +474,8 @@ New module `Store/Feeds.hs`:
transaction per bucket: `updateFeedInstances` (`item_content`, `item_text`,
`item_edited = 1`, `has_link`, `updated_at` for
`user_id = ? AND feed_item_id = ? AND item_feed = 1 AND contact_id > ? AND contact_id <= ?`,
and the group range), `deleteFeedInstances` and `markFeedInstancesDeleted`
and the group range; the deletions use `item_feed > 0`),
`deleteFeedInstances` and `markFeedInstancesDeleted`
by `executeMany` over the ids of each subset (the full-delete split is
decided in Haskell from `mergedPreferences`), reaction deletion by
`executeMany` over `(contact_id, shared_msg_id)`, instance statuses by
@@ -599,26 +628,17 @@ the `note_folders` shape (`Store/NoteFolders.hs:61`).
`Commands.hs`, `APISendFeedMessage feedId cm`, under `withFeedLock "sendFeed" feedId`:
1. `assertAllowedContent'`, `assertNoMentions`.
1. `assertAllowedContent'`, `assertNoMentions`; `quotedItemId` must be absent.
2. `feed <- getFeed`; `sharedMsgId <- getSharedMsgId` (:5030); `createdAt`.
Quote: for `quotedItemId`, `getFeedChatItem` must return an undeleted
`CIFeedSnd` item with `CISndMsgContent qmc` and `itemSharedMsgId = Just quotedSmId`
(otherwise `SEInvalidQuote`, as `quoteData`, `Internal.hs:227`);
`msgRef = MsgRef {msgId = Just quotedSmId, sentAt = itemTs, sent = True, memberId = Nothing}`,
`qmc' = quoteContent mc qmc file` (:367), the container is
`mcQuote QuotedMsg {msgRef, content = qmc'} mc` and the feed item's quote
`CIQuote {chatDir = CIQFeedSnd, itemId = Just quotedItemId, sharedMsgId = Just quotedSmId, sentAt = itemTs, content = qmc', formattedText}`;
`createNewChatItemNoMsg` gains the `Maybe (CIQuote c)` parameter for the
quote row, and the job passes the same row to every instance.
3. File: `checkSndFile`; `xftpSndFileTransfer_ user file fileSize 1 (Just $ CGFeed feed)`
(`Internal.hs:438`; `roundedFDCount 1` yields 4 descriptions, the first is
used); `xftpSndFileTransfer` (:4911) adds `CGFeed _ -> pure ()` — no
`snd_files` rows.
4. Feed item: `updateChatTsStats db cxt user (CDFeedSnd feed) createdAt Nothing`;
`createNewChatItemNoMsg db user (CDFeedSnd feed) False (CISndMsgContent mc) (Just sharedMsgId) quotedItem hasLink Nothing createdAt createdAt`;
`createNewChatItemNoMsg db user (CDFeedSnd feed) False (CISndMsgContent mc) (Just sharedMsgId) hasLink Nothing createdAt createdAt`;
`updateFileTransferChatItemId` for the file.
5. Message: `createFeedSndMessages sharedMsgId (Identity (FeedId feedId, Nothing, XMsgNew container {file = fInv_, feed = Just True}))`
(`container` from step 2, `fInv_ :: Maybe FileInvitation` from step 3);
5. Message: `createFeedSndMessages sharedMsgId (Identity (FeedId feedId, Nothing, XMsgNew (mcSimple mc) {file = fInv_, feed = Just True}))`
(`fInv_ :: Maybe FileInvitation` from step 3);
`insertChatItemMessage_ db feedItemId msgId createdAt`
(`Store/Messages.hs:669`, added to the module's export list).
6. Jobs: `createFeedJobs db feedId feedItemId (FJANew msgId)` — one
@@ -686,8 +706,8 @@ delivery, and a crash between delivery and the cursor sends nothing twice.
`FWSContacts` bucket, one range read: `FJANew` reads
`getFeedContactsByCursor` and `getContactsTagsByRange`; the other actions
read `getFeedContactInstancesByCursor` (contact and instance together,
linked instances for `FJAUpdate` and the deletions, undeleted instances for
`FJAFileDescr`) and the tags. Then, in memory:
linked instances for `FJAUpdate`, linked and detached for the deletions,
undeleted for `FJAFileDescr`) and the tags. Then, in memory:
1. Eligible for `FJANew`: `directOrUsed`, not `contactConnIncognito`,
`contactSendConn_` returns a connection. For the other actions every
@@ -697,10 +717,9 @@ linked instances for `FJAUpdate` and the deletions, undeleted instances for
chat's own TTL, with nothing in the body.
3. `FJANew`: instances first, one transaction: contacts in
`getFeedInstanceContactIdsByRange` are skipped; for the rest
`updateChatTsStats` and `createNewChatItem_` with `CDDirectSnd ct`, no
message id, the shared id, `CISndMsgContent` from the container, the
feed item's quote row, `Just CIFLinked`, `Just feedItemId`, `timed_`; the
items are built with `mkChatItem_`.
`createNewChatItem_` with `CDDirectSnd ct`, no message id, the shared id,
`CISndMsgContent` from the container, `Just CIFLinked`, `Just feedItemId`,
`timed_`. `updateChatTsStats` is not called.
4. Delivery: one `deliverMessagesB` over
`(conn, MsgFlags {notification = hasNotification tag}, (vor, msgIds))`
for the connections of the bucket outside `getDeliveredContactIdsByRange`;
@@ -708,23 +727,19 @@ linked instances for `FJAUpdate` and the deletions, undeleted instances for
by `executeMany`); `createContactPQSndItem` for contacts whose
`pqSndEnabled` changed, as `sendDirectContactMessages`
(`Internal.hs:2170`).
5. `FJAUpdate`: `updateFeedInstances` for the bucket range; the loaded
instances are updated in memory with `updatedChatItem`
(`Store/Messages.hs:2564`) and emitted as `CEvtChatItemUpdated`.
5. `FJAUpdate`: `updateFeedInstances` for the bucket range.
`FJADeleteBroadcast` delivers `XMsgDel`, then deletes the instances of
contacts with `featureAllowed SCFFullDelete forUser ct` and marks the
others (the rule of `APIDeleteChatItem`, `Commands.hs:857`);
`FJADeleteInternal` deletes; `FJADeleteMark` marks; marked items are
updated in memory as `markDirectChatItemDeleted` does (:2665); the
deletions are emitted as `CEvtChatItemsDeleted` with `byUser = True`.
`FJAFileDescr`: no instance change.
`FJADeleteInternal` deletes; `FJADeleteMark` marks. `FJAFileDescr`: no
instance change. The instances' files are not cancelled or deleted: the
file is the feed item's.
6. Timed instances: `startProximateTimedItemThread`.
7. `FJANew`: `CEvtNewChatItems user instances`.
8. `updateFeedDeliveryJobCursor` with the last contact id read; after the
7. `updateFeedDeliveryJobCursor` with the last contact id read; after the
first bucket of `FJANew` the feed item status becomes
`CISSndSent SSPPartial` (`updateFeedChatItemStatus`,
`CEvtChatItemsStatusesUpdated`).
9. Repeat while the bucket is full.
8. Repeat while the bucket is full.
`FWSGroups` bucket, two range reads: `FJANew` reads
`getFeedCustomerGroupsByCursor`; the other actions read
@@ -738,10 +753,10 @@ bucket's request list holds the broadcast body (shared as above) per member
connection to send to. One `deliverMessagesB` for the bucket;
`createPendingGroupMessage` by `executeMany` for pending members (the
message row is the feed's; `sendPendingGroupMessages`, `Internal.hs:2683`,
delivers it on connection); `FJANew`: instances with `CDGroupSnd g Nothing`,
`updateChatTsStats` and `timed_ = sndGroupCITimed False g Nothing`, then
`createMemberSndStatuses` from the per-group results; instance changes as
for contacts; cursor by group id. The job sends no profile update
delivers it on connection); `FJANew`: instances with `CDGroupSnd g Nothing`
and `timed_ = sndGroupCITimed False g Nothing` (no `updateChatTsStats`),
then `createMemberSndStatuses` from the per-group results; instance changes
as for contacts; cursor by group id. The job sends no profile update
(`sendGroupProfileUpdate`, `Internal.hs:2496`): `redactedMemberProfile`
(:1311) depends on each group's preferences and `presentUserBadge` (:2176)
produces a proof per presentation, so one body cannot serve all groups; a
@@ -977,7 +992,9 @@ unchanged.
1. `/feed` to three contacts and a customer group: instances in each chat
and recipients' items with `itemFeed = Just CIFLinked`; the feed item
reaches `CISSndSent SSPComplete`.
reaches `CISSndSent SSPComplete`. The sender's console shows no per-chat
items while the jobs run: instances are read with `/tail @contact`, and
the chats keep their order and their `chat_ts`.
2. Instance statuses after `SENT` and receipts.
3. A contact with `dropFeed` set receives nothing; a later feed edit and
delete are silent.
@@ -1015,8 +1032,10 @@ unchanged.
16. Per-chat edit of one instance: the recipient receives the edit, the
instance becomes `CIFDetached` with its own versions; a following feed
edit updates the other instances and recipients, and this chat keeps the
per-chat text; a following feed delete keeps this instance and the
recipient's message. A per-chat broadcast delete of an instance in a
chat without full delete marks and detaches it; a recipient with
`dropFeed` set receives nothing from a per-chat edit of a dropped
message.
per-chat text; a following feed delete still removes this instance and
retracts the recipient's message. A per-chat broadcast delete of an
instance in a chat without full delete marks and detaches it; a
recipient with `dropFeed` set receives nothing from a per-chat edit of a
dropped message.
17. A feed item older than a day is still editable and locally deletable; a
broadcast delete of it is rejected by `assertDeletable`.
simplex-chat.cabal
+2
View File
@@ -79,6 +79,7 @@ library
Simplex.Chat.Store.ContactRequest
Simplex.Chat.Store.Delivery
Simplex.Chat.Store.Direct
Simplex.Chat.Store.Feeds
Simplex.Chat.Store.Files
Simplex.Chat.Store.Groups
Simplex.Chat.Store.Messages
@@ -602,6 +603,7 @@ test-suite simplex-chat-test
ChatTests.Files
ChatTests.Forward
ChatTests.Groups
ChatTests.Feed
ChatTests.Local
ChatTests.Names
ChatTests.Profiles
src/Simplex/Chat/Controller.hs
+1 -2
View File
@@ -393,7 +393,7 @@ data ChatCommand
| APIUpdateChatTag ChatTagId ChatTagData
| APIReorderChatTags (NonEmpty ChatTagId)
| APICreateChatItems {noteFolderId :: NoteFolderId, composedMessages :: NonEmpty ComposedMessage}
| APISendFeedMessage {feedId :: FeedId, composedMessage :: ComposedMessage}
| APISendFeedMessage {feedId :: FeedId, feedMessage :: ComposedMessage}
| APIReportMessage {groupId :: GroupId, chatItemId :: ChatItemId, reportReason :: ReportReason, reportText :: Text}
| ReportMessage {groupName :: GroupName, contactName_ :: Maybe ContactName, reportReason :: ReportReason, reportedMessage :: Text}
| APIUpdateChatItem {chatRef :: ChatRef, chatItemId :: ChatItemId, liveMessage :: Bool, updatedMessage :: UpdatedMessage}
@@ -824,7 +824,6 @@ data ChatResponse
| CRReactionMembers {user :: User, memberReactions :: [MemberReaction]}
| CRChatItemsDeleted {user :: User, chatItemDeletions :: [ChatItemDeletion], byUser :: Bool, timed :: Bool}
| CRGroupChatItemsDeleted {user :: User, groupInfo :: GroupInfo, chatItemIDs :: [ChatItemId], byUser :: Bool, member_ :: Maybe GroupMember}
| CRBroadcastSent {user :: User, msgContent :: MsgContent, successes :: Int, failures :: Int, timestamp :: UTCTime}
| CRCmdOk {user_ :: Maybe User}
| CRChatHelp {helpSection :: HelpSection}
| CRWelcome {user :: User}
src/Simplex/Chat/Delivery.hs
+59
View File
@@ -12,6 +12,7 @@ module Simplex.Chat.Delivery where
import Data.ByteString.Char8 (ByteString)
import Data.Int (Int64)
import Data.List.NonEmpty (NonEmpty)
import qualified Data.List.NonEmpty as L
import Data.Maybe (fromMaybe)
import Data.Time.Clock (UTCTime)
import Simplex.Chat.Messages (ChatItemId, ChatType (..), GroupChatScopeInfo (..), MessageId, ShowGroupAsSender)
@@ -53,6 +54,9 @@ data DeliveryJobKey
data FeedWorkerScope = FWSContacts | FWSGroups
deriving (Eq, Ord, Show)
feedWorkerScopes :: [FeedWorkerScope]
feedWorkerScopes = [FWSContacts, FWSGroups]
instance FromField FeedWorkerScope where fromField = fromTextField_ textDecode
instance ToField FeedWorkerScope where toField = toField . textEncode
@@ -218,6 +222,61 @@ data FeedJobActionTag
| FJATDeleteMark
deriving (Show)
feedActionTag :: FeedJobAction -> FeedJobActionTag
feedActionTag = \case
FJANew _ -> FJATNew
FJAFileDescr _ -> FJATFileDescr
FJAUpdate _ -> FJATUpdate
FJADeleteBroadcast _ -> FJATDeleteBroadcast
FJADeleteInternal -> FJATDeleteInternal
FJADeleteMark -> FJATDeleteMark
feedActionMsgIds :: FeedJobAction -> [MessageId]
feedActionMsgIds = \case
FJANew msgId -> [msgId]
FJAFileDescr msgIds -> L.toList msgIds
FJAUpdate msgId -> [msgId]
FJADeleteBroadcast msgId -> [msgId]
FJADeleteInternal -> []
FJADeleteMark -> []
feedActionDelivers :: FeedJobAction -> Bool
feedActionDelivers = \case
FJADeleteInternal -> False
FJADeleteMark -> False
_ -> True
feedActionCreates :: FeedJobAction -> Bool
feedActionCreates = \case
FJANew _ -> True
_ -> False
feedActionDeletes :: FeedJobAction -> Bool
feedActionDeletes = \case
FJADeleteBroadcast _ -> True
FJADeleteInternal -> True
FJADeleteMark -> True
_ -> False
-- a marked instance stays in its chat, so the feed item stays in the feed
feedActionRemovesItem :: FeedJobAction -> Bool
feedActionRemovesItem = \case
FJADeleteBroadcast _ -> True
FJADeleteInternal -> True
_ -> False
-- which instances of the feed item the action applies to
data FeedInstanceSpec
= FISLinked -- a feed edit skips instances edited or deleted in their chat
| FISAny -- a feed deletion retracts the broadcast from detached instances too
| FISUndeleted -- a file description follows the message
feedActionInstances :: FeedJobAction -> FeedInstanceSpec
feedActionInstances = \case
FJAUpdate _ -> FISLinked
FJAFileDescr _ -> FISUndeleted
_ -> FISAny
instance FromField FeedJobActionTag where fromField = fromTextField_ textDecode
instance ToField FeedJobActionTag where toField = toField . textEncode
src/Simplex/Chat/Library/Commands.hs
+172 -61
View File
@@ -60,7 +60,7 @@ import Simplex.Chat.Badges (BadgeCredential (..), LocalBadge (..), badgeServerCr
import Simplex.Chat.Names (SimplexDomainProof (..), SimplexDomainClaim (..), claimDomain, mkDomainClaim)
import Simplex.Chat.Call
import Simplex.Chat.Controller
import Simplex.Chat.Delivery (DeliveryJobScope (..), DeliveryJobSpec (..), DeliveryWorkerScope (..))
import Simplex.Chat.Delivery (DeliveryJobKey (..), DeliveryJobScope (..), DeliveryJobSpec (..), DeliveryWorkerScope (..), FeedJobAction (..))
import Simplex.Chat.Files
import Simplex.Chat.Markdown
import Simplex.Chat.Messages
@@ -84,13 +84,15 @@ import Simplex.Chat.Store.Direct
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
import Simplex.Chat.Types
import Simplex.Chat.Types.Preferences
import Simplex.Chat.Types.Shared
import Simplex.Chat.Util (liftIOEither, zipWith3')
import Simplex.Chat.Util (liftIOEither)
import qualified Simplex.Chat.Util as U
import Simplex.Chat.Web (webPreviewWorker)
import Simplex.FileTransfer.Description (FileDescriptionURI (..), maxFileSizeHard)
@@ -441,6 +443,7 @@ processChatCommand cxt nm = \case
mapM_ (setUserServers db user ts) uss
createPresetContactCards db user `catchAllErrors` \_ -> pure ()
createNoteFolder db user
createFeed db user
pure user
atomically . writeTVar u $ Just user
pure $ CRActiveUser user
@@ -667,6 +670,9 @@ processChatCommand cxt nm = \case
CTLocal -> do
(localChat, navInfo) <- withFastStore (\db -> getLocalChat db user cId contentFilter pagination search)
pure $ CRApiChat user (AChat SCTLocal localChat) navInfo
CTFeed -> do
(feedChat, navInfo) <- withFastStore (\db -> getFeedChat db user cId contentFilter pagination search)
pure $ CRApiChat user (AChat SCTFeed feedChat) navInfo
CTContactRequest -> throwCmdError "not implemented"
CTContactConnection -> throwCmdError "not supported"
where
@@ -754,6 +760,34 @@ processChatCommand cxt nm = \case
APICreateChatItems folderId cms -> withUser $ \user -> do
forM_ cms $ \cm -> assertAllowedContent' cm >> assertNoMentions cm
createNoteFolderContentItems user folderId (L.map composedMessageReq cms)
APISendFeedMessage feedId cm@ComposedMessage {fileSource = file_, quotedItemId, msgContent = mc} -> withUser $ \user -> do
assertAllowedContent' cm
assertNoMentions cm
when (isJust quotedItemId) $ throwCmdError "quotes are not supported in feed"
withFeedLock "sendFeed" feedId $ do
feed <- withFastStore $ \db -> getFeed db user feedId
sharedMsgId <- getSharedMsgId
createdAt <- liftIO getCurrentTime
(fInv_, ciFile_) <- unzipMaybe3 <$> setupSndFileTransfer user feed
let hasLink = msgContentHasLink mc $ snd $ msgContentTexts mc
feedItemId <- withFastStore' $ \db -> do
void $ updateChatTsStats db cxt user (CDFeedSnd feed) createdAt Nothing
itemId <- createNewChatItemNoMsg db user (CDFeedSnd feed) False (CISndMsgContent mc) (Just sharedMsgId) hasLink Nothing createdAt createdAt
forM_ ciFile_ $ \CIFile {fileId} -> updateFileTransferChatItemId db fileId itemId createdAt
pure itemId
let mc' = (mcSimple mc) {file = fInv_, feed = Just True}
msg <- createFeedMessage feed (Just sharedMsgId) feedItemId $ XMsgNew mc'
withFastStore' $ \db -> createFeedJobs db feedId feedItemId (FJANew $ msgId' msg)
startFeedWorkers feedId
ci <- withFastStore $ \db -> getFeedChatItem db user feedId feedItemId
pure $ CRNewChatItems user [aFeedItem feed ci]
where
setupSndFileTransfer user@User {profile = LocalProfile {localBadge}} feed = forM file_ $ \file -> do
fileSize <- checkSndFile localBadge file
(fInv, ciFile, _) <- xftpSndFileTransfer_ user file fileSize 1 (Just $ CGFeed feed)
pure (fInv, ciFile)
unzipMaybe3 :: Maybe (a, b) -> (Maybe a, Maybe b)
unzipMaybe3 = maybe (Nothing, Nothing) (\(a, b) -> (Just a, Just b))
APIReportMessage gId reportedItemId reportReason reportText -> withUser $ \user ->
withGroupLock "reportMessage" gId $ do
gInfo <- withFastStore $ \db -> getGroupInfo db cxt user gId
@@ -771,20 +805,22 @@ processChatCommand cxt nm = \case
assertDirectAllowed user MDSnd ct XMsgUpdate_
cci <- withFastStore $ \db -> getDirectCIWithReactions db user ct itemId
case cci of
CChatItem SMDSnd ci@ChatItem {meta = CIMeta {itemSharedMsgId, itemTimed, itemLive, editable}, content = ciContent} -> do
CChatItem SMDSnd ci@ChatItem {meta = CIMeta {itemSharedMsgId, itemTimed, itemLive, editable, itemFeed}, content = ciContent} -> do
case (ciContent, itemSharedMsgId, editable) of
(CISndMsgContent oldMC, Just itemSharedMId, True) -> do
let changed = mc /= oldMC
if changed || fromMaybe False itemLive
then do
let event = XMsgUpdate itemSharedMId mc M.empty (ttl' <$> itemTimed) (justTrue . (live &&) =<< itemLive) Nothing Nothing
let event = XMsgUpdate itemSharedMId mc M.empty (ttl' <$> itemTimed) (justTrue . (live &&) =<< itemLive) Nothing Nothing (justTrue $ isJust itemFeed)
(SndMessage {msgId}, _) <- sendDirectContactMessage user ct event
ci' <- withFastStore' $ \db -> do
currentTs <- liftIO getCurrentTime
when changed $
addInitialAndNewCIVersions db itemId (chatItemTs' ci, oldMC) (currentTs, mc)
let edited = itemLive /= Just True
updateDirectChatItem' db user contactId ci (CISndMsgContent mc) edited live Nothing $ Just msgId
-- an edit in the chat detaches the instance: feed edits no longer apply to it
when (itemFeed == Just CIFLinked) $ Store.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')
else pure $ CRChatItemNotChanged user (AChatItem SCTDirect SMDSnd (DirectChat ct) ci)
@@ -800,7 +836,7 @@ processChatCommand cxt nm = \case
-- TODO [knocking] check chat item scope?
cci <- withFastStore $ \db -> getGroupCIWithReactions db user gInfo itemId
case cci of
CChatItem SMDSnd ci@ChatItem {meta = CIMeta {itemSharedMsgId, itemTimed, itemLive, editable, showGroupAsSender, msgVerified}, content = ciContent} -> do
CChatItem SMDSnd ci@ChatItem {meta = CIMeta {itemSharedMsgId, itemTimed, itemLive, editable, showGroupAsSender, msgVerified, itemFeed}, content = ciContent} -> do
case (ciContent, itemSharedMsgId, editable) of
(CISndMsgContent oldMC, Just itemSharedMId, True) -> do
chatScopeInfo <- mapM (getChatScopeInfo cxt user) scope
@@ -811,7 +847,7 @@ processChatCommand cxt nm = \case
ciMentions <- withFastStore $ \db -> getCIMentions db user gInfo ft_ mentions
let msgScope = toMsgScope gInfo <$> chatScopeInfo
mentions' = M.map (\CIMention {memberId} -> MsgMention {memberId}) ciMentions
event = XMsgUpdate itemSharedMId mc mentions' (ttl' <$> itemTimed) (justTrue . (live &&) =<< itemLive) msgScope (Just showGroupAsSender)
event = XMsgUpdate itemSharedMId mc mentions' (ttl' <$> itemTimed) (justTrue . (live &&) =<< itemLive) msgScope (Just showGroupAsSender) (justTrue $ isJust itemFeed)
reuseSign = case msgVerified of Just (MVSigned _) -> True; _ -> False
SndMessage {msgId} <- sendGroupMessage user gInfo scope recipients reuseSign event
ci' <- withFastStore' $ \db -> do
@@ -819,7 +855,9 @@ processChatCommand cxt nm = \case
when changed $
addInitialAndNewCIVersions db itemId (chatItemTs' ci, oldMC) (currentTs, mc)
let edited = itemLive /= Just True
ci' <- updateGroupChatItem db user groupId ci (CISndMsgContent mc) edited live $ Just msgId
-- an edit in the chat detaches the instance: feed edits no longer apply to it
when (itemFeed == Just CIFLinked) $ Store.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'
pure $ CRChatItemUpdated user (AChatItem SCTGroup SMDSnd (GroupChat gInfo chatScopeInfo) ci')
@@ -838,14 +876,38 @@ processChatCommand cxt nm = \case
ci' <- updateLocalChatItem' db user noteFolderId ci (CISndMsgContent mc) True
pure $ CRChatItemUpdated user (AChatItem SCTLocal SMDSnd (LocalChat nf) ci')
_ -> throwChatError CEInvalidChatItemUpdate
CTFeed -> withFeedLock "updateChatItem" chatId $ do
when live $ throwCmdError "live messages are not supported in feed"
unless (null mentions) $ throwCmdError "mentions are not supported in this chat"
(feed, cci) <- withFastStore $ \db -> (,) <$> getFeed db user chatId <*> getFeedChatItem db user chatId itemId
case cci of
CChatItem SMDSnd ci@ChatItem {meta = CIMeta {itemSharedMsgId, editable}, content = ciContent} ->
case (ciContent, itemSharedMsgId, editable) of
(CISndMsgContent oldMC, Just itemSharedMId, True)
| mc == oldMC -> pure $ CRChatItemNotChanged user (aFeedItem feed cci)
| otherwise -> do
let event = XMsgUpdate itemSharedMId mc M.empty Nothing Nothing Nothing Nothing (Just True)
msg <- createFeedMessage feed Nothing itemId event
ci' <- withFastStore' $ \db -> do
currentTs <- getCurrentTime
addInitialAndNewCIVersions db itemId (chatItemTs' ci, oldMC) (currentTs, mc)
createFeedJobs db chatId itemId (FJAUpdate $ msgId' msg)
updateFeedChatItem' db user chatId ci (CISndMsgContent mc) (msgContentHasLink mc $ snd $ msgContentTexts mc)
startFeedWorkers chatId
pure $ CRChatItemUpdated user (AChatItem SCTFeed SMDSnd (FeedChat feed) ci')
_ -> throwChatError CEInvalidChatItemUpdate
CTContactRequest -> throwCmdError "not supported"
CTContactConnection -> throwCmdError "not supported"
APIDeleteChatItem (ChatRef cType chatId scope) itemIds mode -> withUser $ \user -> case cType of
CTDirect -> withContactLock "deleteChatItem" chatId $ do
(ct, items) <- getCommandDirectChatItems user chatId itemIds
-- a deletion that keeps the row detaches the instance: feed edits no longer apply to it
let markDeleted items' = do
items'' <- detachFeedInstances items'
markDirectCIsDeleted user ct items'' =<< liftIO getCurrentTime
deletions <- case mode of
CIDMInternal -> deleteDirectCIs user ct items
CIDMInternalMark -> markDirectCIsDeleted user ct items =<< liftIO getCurrentTime
CIDMInternalMark -> markDeleted items
CIDMHistory -> throwChatError CEInvalidChatItemDelete
CIDMBroadcast -> do
assertDeletable items
@@ -856,7 +918,7 @@ processChatCommand cxt nm = \case
sendDirectContactMessages user ct events'
if featureAllowed SCFFullDelete forUser ct
then deleteDirectCIs user ct items
else markDirectCIsDeleted user ct items =<< liftIO getCurrentTime
else markDeleted items
pure $ CRChatItemsDeleted user deletions True False
CTGroup -> withGroupLock "deleteChatItem" chatId $ do
(gInfo, items) <- getCommandGroupChatItems user chatId itemIds
@@ -867,7 +929,8 @@ processChatCommand cxt nm = \case
| publicGroupEditor gInfo (membership gInfo) -> throwChatError CEInvalidChatItemDelete
| otherwise -> deleteGroupCIs user gInfo chatScopeInfo items Nothing =<< liftIO getCurrentTime
CIDMInternalMark -> do
markGroupCIsDeleted user gInfo chatScopeInfo items Nothing =<< liftIO getCurrentTime
items' <- detachFeedInstances items
markGroupCIsDeleted user gInfo chatScopeInfo items' Nothing =<< liftIO getCurrentTime
CIDMBroadcast -> do
recipients <- getGroupRecipients cxt user gInfo chatScopeInfo groupKnockingVersion
assertDeletable items
@@ -885,6 +948,42 @@ processChatCommand cxt nm = \case
CTLocal -> do
(nf, items) <- getCommandLocalChatItems user chatId itemIds
deleteLocalCIs user nf items True False
CTFeed -> withFeedLock "deleteChatItem" chatId $ do
(feed, items) <- getCommandFeedChatItems user chatId itemIds
when (null items) $ throwChatError CEInvalidChatItemDelete
case mode of
CIDMHistory -> throwChatError CEInvalidChatItemDelete
_ -> pure ()
deletions <- forM items $ \cci -> case cci of
CChatItem SMDSnd ci@ChatItem {meta = CIMeta {itemId, itemSharedMsgId, itemDeleted}} -> do
-- the item stays in the feed as CIDeleting until the jobs have removed every instance
action <- case (mode, itemDeleted) of
(_, Just (CIDeleted _)) -> throwChatError CEInvalidChatItemDelete
-- a repeated delete of an item being deleted re-enqueues the jobs with the earlier action
(_, Just (CIDeleting _)) -> feedDeleteAction feed itemId itemSharedMsgId CIDMInternal
(CIDMBroadcast, _) -> do
assertDeletable [cci]
feedDeleteAction feed itemId itemSharedMsgId CIDMBroadcast
(m, _) -> feedDeleteAction feed itemId itemSharedMsgId m
deletedTs <- liftIO getCurrentTime
ci' <- withFastStore' $ \db -> do
createFeedJobs db chatId itemId action
markFeedChatItemDeleted db user chatId ci (itemDeletedState mode deletedTs) deletedTs
pure $ ChatItemDeletion (aFeedItem feed cci) (Just $ AChatItem SCTFeed SMDSnd (FeedChat feed) ci')
startFeedWorkers chatId
pure $ CRChatItemsDeleted user deletions True False
where
itemDeletedState m deletedTs = case m of
CIDMInternalMark -> CIDeleted (Just deletedTs)
_ -> CIDeleting (Just deletedTs)
feedDeleteAction feed itemId sharedMsgId_ = \case
CIDMBroadcast -> case sharedMsgId_ of
Nothing -> throwChatError CEInvalidChatItemDelete
Just sharedMsgId -> do
msg <- createFeedMessage feed Nothing itemId (XMsgDel sharedMsgId Nothing Nothing False)
pure $ FJADeleteBroadcast (msgId' msg)
CIDMInternalMark -> pure FJADeleteMark
_ -> pure FJADeleteInternal
CTContactRequest -> throwCmdError "not supported"
CTContactConnection -> throwCmdError "not supported"
where
@@ -987,6 +1086,7 @@ processChatCommand cxt nm = \case
pure $ CRChatItemReaction user add r
_ -> throwCmdError "invalid reaction"
CTLocal -> throwCmdError "not supported"
CTFeed -> throwCmdError "not supported"
CTContactRequest -> throwCmdError "not supported"
CTContactConnection -> throwCmdError "not supported"
where
@@ -1005,6 +1105,7 @@ processChatCommand cxt nm = \case
CTDirect -> planForward user . snd =<< getCommandDirectChatItems user fromChatId itemIds
CTGroup -> planForward user . snd =<< getCommandGroupChatItems user fromChatId itemIds
CTLocal -> planForward user . snd =<< getCommandLocalChatItems user fromChatId itemIds
CTFeed -> planForward user . snd =<< getCommandFeedChatItems user fromChatId itemIds
CTContactRequest -> throwCmdError "not supported"
CTContactConnection -> throwCmdError "not supported"
where
@@ -1071,6 +1172,7 @@ processChatCommand cxt nm = \case
Just cmrs' ->
createNoteFolderContentItems user toChatId cmrs'
Nothing -> pure $ CRNewChatItems user []
CTFeed -> throwCmdError "not supported"
CTContactRequest -> throwCmdError "not supported"
CTContactConnection -> throwCmdError "not supported"
where
@@ -1114,15 +1216,18 @@ processChatCommand cxt nm = \case
sourceGroupType GroupInfo {groupProfile = GroupProfile {publicGroup}} = (\PublicGroupProfile {groupType} -> groupType) <$> publicGroup
CTLocal -> do
(_, items) <- getCommandLocalChatItems user fromChatId itemIds
catMaybes <$> mapM (\ci -> ciComposeMsgReq ci <$$> prepareMsgReq ci) items
where
ciComposeMsgReq :: CChatItem 'CTLocal -> (MsgContent, Maybe CryptoFile) -> ComposedMessageReq
ciComposeMsgReq (CChatItem _ ci) (mc', file) =
let ciff = forwardCIFF ci Nothing
in (composedMessage file mc', ciff, msgContentTexts mc', M.empty)
catMaybes <$> mapM (\ci -> noRefComposeMsgReq ci <$$> prepareMsgReq ci) items
CTFeed -> do
(_, items) <- getCommandFeedChatItems user fromChatId itemIds
catMaybes <$> mapM (\ci -> noRefComposeMsgReq ci <$$> prepareMsgReq ci) items
CTContactRequest -> throwCmdError "not supported"
CTContactConnection -> throwCmdError "not supported"
where
-- the user's own chats are not referenced as the source of a forward
noRefComposeMsgReq :: CChatItem c -> (MsgContent, Maybe CryptoFile) -> ComposedMessageReq
noRefComposeMsgReq (CChatItem _ ci) (mc', file) =
let ciff = forwardCIFF ci Nothing
in (composedMessage file mc', ciff, msgContentTexts mc', M.empty)
prepareMsgReq :: CChatItem c -> CM (Maybe (MsgContent, Maybe CryptoFile))
prepareMsgReq (CChatItem md ci) = forwardMsgContent ci $>>= forwardContent ci . dropOwnerSig
where
@@ -1265,6 +1370,8 @@ processChatCommand cxt nm = \case
user <- withFastStore $ \db -> getUserByNoteFolderId db chatId
withFastStore' $ \db -> updateLocalChatItemsRead db user chatId
ok user
-- the feed contains sent items only
CTFeed -> ok =<< withFastStore (\db -> getUserByFeedId db chatId)
CTContactRequest -> throwCmdError "not supported"
CTContactConnection -> throwCmdError "not supported"
APIChatItemsRead chatRef@(ChatRef cType chatId scope) itemIds -> withUser $ \_ -> case cType of
@@ -1291,6 +1398,7 @@ processChatCommand cxt nm = \case
forM_ timedItems $ \(itemId, deleteAt) -> startProximateTimedItemThread user (chatRef, itemId) deleteAt
pure $ CRItemsReadForChat user (AChatInfo SCTGroup $ GroupChat gInfo' Nothing)
CTLocal -> throwCmdError "not supported"
CTFeed -> throwCmdError "not supported"
CTContactRequest -> throwCmdError "not supported"
CTContactConnection -> throwCmdError "not supported"
APIChatUnread (ChatRef cType chatId scope) unreadChat -> withUser $ \user -> case cType of
@@ -1310,6 +1418,11 @@ processChatCommand cxt nm = \case
nf <- getNoteFolder db user chatId
liftIO $ updateNoteFolderUnreadChat db user nf unreadChat
ok user
CTFeed -> do
withFastStore $ \db -> do
feed <- getFeed db user chatId
liftIO $ updateFeedUnreadChat db user feed unreadChat
ok user
_ -> throwCmdError "not supported"
APIDeleteChat cRef@(ChatRef cType chatId scope) cdm -> withUser $ \user@User {userId} -> case cType of
CTDirect -> do
@@ -1405,6 +1518,14 @@ processChatCommand cxt nm = \case
withFastStore' $ \db -> deleteNoteFolderFiles db userId nf
withFastStore' $ \db -> deleteNoteFolderCIs db user nf
pure $ CRChatCleared user (AChatInfo SCTLocal $ LocalChat nf)
-- instances stay in their chats, with feed_item_id set to NULL by the FK
CTFeed -> withFeedLock "clearChat" chatId $ do
feed <- withFastStore $ \db -> getFeed db user chatId
filesInfo <- withFastStore' $ \db -> getFeedFileInfo db user feed
deleteCIFiles user filesInfo
withFastStore' $ \db -> deleteFeedFiles db user feed
withFastStore' $ \db -> deleteFeedCIs db user feed
pure $ CRChatCleared user (AChatInfo SCTFeed $ FeedChat feed)
_ -> throwCmdError "not supported"
APIAcceptContact incognito connReqId -> withUser $ \user@User {userId} -> do
uclData_ <- withFastStore $ \db -> do
@@ -1440,7 +1561,7 @@ processChatCommand cxt nm = \case
sendWelcomeMsg user ct ucl UserContactRequest {welcomeSharedMsgId} =
forM_ (autoReply $ addressSettings ucl) $ \mc -> case welcomeSharedMsgId of
Just smId ->
void $ sendDirectContactMessage user ct $ XMsgUpdate smId mc M.empty Nothing Nothing Nothing Nothing
void $ sendDirectContactMessage user ct $ XMsgUpdate smId mc M.empty Nothing Nothing Nothing Nothing Nothing
Nothing -> do
(msg, _) <- sendDirectContactMessage user ct $ XMsgNew $ mcSimple mc
ci <- saveSndChatItem user (CDDirectSnd ct) msg (CISndMsgContent mc)
@@ -2076,6 +2197,7 @@ processChatCommand cxt nm = \case
_ -> throwChatError CEGroupMemberNotActive
SetShowMessages cName ntfOn -> updateChatSettings cName (\cs -> cs {enableNtfs = ntfOn})
SetSendReceipts cName rcptsOn_ -> updateChatSettings cName (\cs -> cs {sendRcpts = rcptsOn_})
SetDropFeed cName dropOn -> updateChatSettings cName (\cs -> cs {dropFeed = BoolDef dropOn})
SetShowMemberMessages gName mName showMessages -> withUser $ \user -> do
(gId, mId) <- getGroupAndMemberId user gName mName
gInfo <- withFastStore $ \db -> getGroupInfo db cxt user gId
@@ -2623,45 +2745,8 @@ processChatCommand cxt nm = \case
let mc = MCText msg
processChatCommand cxt nm $ APISendMessages sendRef True Nothing False [ComposedMessage Nothing Nothing mc mentions]
SendMessageBroadcast mc -> withUser $ \user -> do
contacts <- withFastStore' $ \db -> getUserContacts db cxt user
withChatLock "sendMessageBroadcast" $ do
let ctConns_ = L.nonEmpty $ foldr addContactConn [] contacts
case ctConns_ of
Nothing -> do
timestamp <- liftIO getCurrentTime
pure CRBroadcastSent {user, msgContent = mc, successes = 0, failures = 0, timestamp}
Just (ctConns :: NonEmpty (Contact, Connection)) -> do
let idsEvts = L.map ctSndEvent ctConns
-- TODO Broadcast rework
-- In createNewSndMessage and encodeChatMessage we could use Nothing for sharedMsgId,
-- then we could reuse message body across broadcast.
-- Encoding different sharedMsgId and reusing body is meaningless as referencing will not work anyway.
-- As an improvement, single message record with its sharedMsgId could be created for new "broadcast" entity.
-- Then all recipients could refer to broadcast message using same sharedMsgId.
sndMsgs <- lift $ createSndMessages idsEvts
let msgReqs_ :: NonEmpty (Either ChatError ChatMsgReq) = L.zipWith (fmap . ctMsgReq) ctConns sndMsgs
(errs, ctSndMsgs :: [(Contact, SndMessage)]) <-
partitionEithers . L.toList . zipWith3' combineResults ctConns sndMsgs <$> deliverMessagesB msgReqs_
timestamp <- liftIO getCurrentTime
let hasLink = msgContentHasLink mc $ parseMaybeMarkdownList $ msgContentText mc
lift . void $ withStoreBatch' $ \db -> map (createCI db user hasLink timestamp) ctSndMsgs
pure CRBroadcastSent {user, msgContent = mc, successes = length ctSndMsgs, failures = length errs, timestamp}
where
addContactConn :: Contact -> [(Contact, Connection)] -> [(Contact, Connection)]
addContactConn ct ctConns = case contactSendConn_ ct of
Right conn | directOrUsed ct -> (ct, conn) : ctConns
_ -> ctConns
ctSndEvent :: (Contact, Connection) -> (ConnOrGroupId, Maybe MsgSigning, ChatMsgEvent 'Json)
ctSndEvent (_, Connection {connId}) = (ConnectionId connId, Nothing, XMsgNew $ mcSimple mc)
ctMsgReq :: (Contact, Connection) -> SndMessage -> ChatMsgReq
ctMsgReq (_, conn) SndMessage {msgId, msgBody} = (conn, MsgFlags {notification = hasNotification XMsgNew_}, (vrValue msgBody, [msgId]))
combineResults :: (Contact, Connection) -> Either ChatError SndMessage -> Either ChatError ([Int64], PQEncryption) -> Either ChatError (Contact, SndMessage)
combineResults (ct, _) (Right msg') (Right _) = Right (ct, msg')
combineResults _ (Left e) _ = Left e
combineResults _ _ (Left e) = Left e
createCI :: DB.Connection -> User -> Bool -> UTCTime -> (Contact, SndMessage) -> IO ()
createCI db user hasLink createdAt (ct, sndMsg) =
void $ createNewSndChatItem db user (CDDirectSnd ct) False sndMsg (CISndMsgContent mc) Nothing Nothing Nothing False hasLink createdAt
feedId <- withFastStore $ \db -> getUserFeedId db user
processChatCommand cxt nm $ APISendFeedMessage feedId (composedMessage Nothing mc)
SendMessageQuote cName (AMsgDirection msgDir) quotedMsg msg -> withUser $ \user@User {userId} -> do
contactId <- withFastStore $ \db -> getContactIdByName db user cName
quotedItemId <- withFastStore $ \db -> getDirectChatItemIdByText db userId contactId msgDir quotedMsg
@@ -3205,7 +3290,7 @@ processChatCommand cxt nm = \case
deleteGroupDeliveryTasks db gInfo
deleteGroupDeliveryJobs db gInfo
createMsgDeliveryJob db gInfo (DJSGroup {jobSpec = DJRelayRemoved}) [] body
lift . void $ getDeliveryJobWorker True (groupId, DWSGroup)
lift . void $ getDeliveryJobWorker True (DJKGroup groupId DWSGroup)
pure msg
leaveGroupSendMsg user gInfo = do
(members, recipients) <- getRecipients user gInfo
@@ -3654,6 +3739,7 @@ processChatCommand cxt nm = \case
CLUserContact ucId -> "UserContact " <> tshow ucId
CLContactRequest crId -> "ContactRequest " <> tshow crId
CLFile fId -> "File " <> tshow fId
CLFeed feedId -> "Feed " <> tshow feedId
DebugEvent event -> toView event >> ok_
GetAgentSubsTotal userId -> withUserId userId $ \user -> do
users <- withStore' $ \db -> getUsers db
@@ -3704,6 +3790,9 @@ processChatCommand cxt nm = \case
CTLocal
| name == "" -> withFastStore (`getUserNoteFolderId` user)
| otherwise -> throwCmdError "not supported"
CTFeed
| name == "" -> withFastStore (`getUserFeedId` user)
| otherwise -> throwCmdError "not supported"
_ -> throwCmdError "not supported"
pure $ ChatRef cType chatId Nothing
getSendAsGroup :: User -> ChatRef -> CM ShowGroupAsSender
@@ -3765,12 +3854,14 @@ processChatCommand cxt nm = \case
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
CTFeed -> withFastStore $ \db -> getFeedChatItemIdByText db user cId msg
_ -> throwCmdError "not supported"
getChatItemIdByText :: User -> ChatRef -> Text -> CM Int64
getChatItemIdByText user (ChatRef cType cId _scope) msg = case cType of
CTDirect -> withFastStore $ \db -> getDirectChatItemIdByText' db user cId msg
CTGroup -> withFastStore $ \db -> getGroupChatItemIdByText' db user cId msg
CTLocal -> withFastStore $ \db -> getLocalChatItemIdByText' db user cId msg
CTFeed -> withFastStore $ \db -> getFeedChatItemIdByText db user cId msg
_ -> throwCmdError "not supported"
connectViaInvitation :: User -> IncognitoEnabled -> CreatedLinkInvitation -> Maybe ContactId -> CM (Connection, Maybe Profile)
connectViaInvitation user@User {userId} incognito (CCLink cReq@(CRInvitationUri crData e2e) sLnk_) contactId_ =
@@ -4157,9 +4248,14 @@ 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
if groupFeatureUserAllowed SGFFullDelete gInfo
-- a deletion that keeps the row detaches the instance: feed edits no longer apply to it
if groupFeatureUserAllowed SGFFullDelete gInfo && not moderation
then deleteGroupCIs user gInfo chatScopeInfo items m deletedTs
else markGroupCIsDeleted user gInfo chatScopeInfo items m deletedTs
else do
items' <- detachFeedInstances items
if groupFeatureUserAllowed SGFFullDelete gInfo
then deleteGroupCIs user gInfo chatScopeInfo items' m deletedTs
else markGroupCIsDeleted user gInfo chatScopeInfo items' m deletedTs
updateGroupProfileByName :: GroupName -> (GroupProfile -> GroupProfile) -> CM ChatResponse
updateGroupProfileByName = updateGroupProfileByName_ Nothing
updateGroupProfileByName_ :: Maybe GroupFeature -> GroupName -> (GroupProfile -> GroupProfile) -> CM ChatResponse
@@ -4922,6 +5018,8 @@ processChatCommand cxt nm = \case
withFastStore' $
\db -> createSndFTDescrXFTP db user (Just m) conn ft dummyFileDescr
saveMemberFD _ = pure ()
-- one description is sent to every feed recipient, so there are no snd_files rows
CGFeed _ -> pure ()
pure (fInv, ciFile)
prepareSndItemsData ::
[ComposedMessageReq] ->
@@ -4972,6 +5070,15 @@ processChatCommand cxt nm = \case
where
getLocalCI :: DB.Connection -> ChatItemId -> IO (Either ChatError (CChatItem 'CTLocal))
getLocalCI db itemId = runExceptT . withExceptT ChatErrorStore $ getLocalChatItem db user nfId itemId
getCommandFeedChatItems :: User -> FeedId -> NonEmpty ChatItemId -> CM (Feed, [CChatItem 'CTFeed])
getCommandFeedChatItems user feedId itemIds = do
feed <- withStore $ \db -> getFeed db user feedId
(errs, items) <- lift $ partitionEithers <$> withStoreBatch (\db -> map (getFeedCI db) (L.toList itemIds))
unless (null errs) $ toView $ CEvtChatErrors errs
pure (feed, items)
where
getFeedCI :: DB.Connection -> ChatItemId -> IO (Either ChatError (CChatItem 'CTFeed))
getFeedCI db itemId = runExceptT . withExceptT ChatErrorStore $ getFeedChatItem db user feedId itemId
forwardMsgContent :: ChatItem c d -> CM (Maybe MsgContent)
forwardMsgContent ChatItem {meta = CIMeta {itemDeleted = Just _}} = pure Nothing -- this can be deleted after selection
forwardMsgContent ChatItem {content = CISndMsgContent fmc} = pure $ Just fmc
@@ -5518,6 +5625,7 @@ chatCommandP =
"/_update tag " *> (APIUpdateChatTag <$> A.decimal <* A.space <*> jsonP),
"/_reorder tags " *> (APIReorderChatTags <$> strP),
"/_create *" *> (APICreateChatItems <$> A.decimal <*> (" json " *> jsonP <|> " text " *> composedMessagesTextP)),
"/_feed " *> (APISendFeedMessage <$> A.decimal <*> (" json " *> jsonP <|> " text " *> (composedMessage Nothing <$> mcTextP))),
"/_report #" *> (APIReportMessage <$> A.decimal <* A.space <*> A.decimal <*> (" reason=" *> strP) <*> (A.space *> textP <|> pure "")),
"/report #" *> (ReportMessage <$> displayNameP <*> optional (" @" *> displayNameP) <*> _strP <* A.space <*> msgTextP),
"/_update item " *> (APIUpdateChatItem <$> chatRefP <* A.space <*> A.decimal <*> liveMessageP <*> (" json" *> jsonP <|> " text " *> updatedMessagesTextP)),
@@ -5741,6 +5849,8 @@ chatCommandP =
("\\\\ #" <|> "\\\\#") *> (DeleteMemberMessage <$> displayNameP <* A.space <* char_ '@' <*> displayNameP <* A.space <*> textP),
("! " <|> "!") *> (EditMessage <$> chatNameP <* A.space <*> (quotedMsg <|> pure "") <*> msgTextP),
ReactToMessage <$> (("+" $> True) <|> ("-" $> False)) <*> reactionP <* A.space <*> chatNameP' <* A.space <*> textP,
-- "/feed drop" must precede "/feed <text>": msgTextP consumes any text
"/feed drop " *> (SetDropFeed <$> chatNameP' <* A.space <*> onOffP),
"/feed " *> (SendMessageBroadcast . MCText <$> msgTextP),
("/chats" <|> "/cs") *> (LastChats <$> (" all" $> Nothing <|> Just <$> (A.space *> A.decimal <|> pure 20))),
("/tail" <|> "/t") *> (LastMessages <$> optional (A.space *> chatNameP) <*> msgCountP <*> pure Nothing),
@@ -5857,7 +5967,7 @@ chatCommandP =
ownerContactP = "contact=" *> (GroupOwnerContact <$> A.decimal <* " owner=" <*> strP)
imagePrefix = (<>) <$> "data:" <*> ("image/png;base64," <|> "image/jpg;base64,")
imageP = safeDecodeUtf8 <$> ((<>) <$> imagePrefix <*> (B64.encode <$> base64P))
chatTypeP = A.char '@' $> CTDirect <|> A.char '#' $> CTGroup <|> A.char '*' $> CTLocal <|> A.char ':' $> CTContactConnection
chatTypeP = A.char '@' $> CTDirect <|> A.char '#' $> CTGroup <|> A.char '*' $> CTLocal <|> A.char '%' $> CTFeed <|> A.char ':' $> CTContactConnection
chatPaginationP =
(CPLast <$ "count=" <*> A.decimal)
<|> (CPAfter <$ "after=" <*> A.decimal <* A.space <* "count=" <*> A.decimal)
@@ -5986,6 +6096,7 @@ chatCommandP =
chatNameP =
chatTypeP >>= \case
CTLocal -> pure $ ChatName CTLocal ""
CTFeed -> pure $ ChatName CTFeed ""
ct -> ChatName ct <$> displayNameP
chatNameP' = ChatName <$> (chatTypeP <|> pure CTDirect) <*> displayNameP
chatRefP = do
src/Simplex/Chat/Library/Internal.hs
+107 -35
View File
@@ -69,6 +69,7 @@ import Simplex.Chat.Protocol
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.Files
import Simplex.Chat.Store.Groups
import Simplex.Chat.Store.Messages
@@ -159,6 +160,10 @@ withFileLock :: Text -> Int64 -> CM a -> CM a
withFileLock name = withEntityLock name . CLFile
{-# INLINE withFileLock #-}
withFeedLock :: Text -> FeedId -> CM a -> CM a
withFeedLock name = withEntityLock name . CLFeed
{-# INLINE withFeedLock #-}
useServerCfgs :: forall p. UserProtocol p => SProtocolType p -> RandomAgentServers -> [(Text, ServerOperator)] -> [UserServer p] -> NonEmpty (ServerCfg p)
useServerCfgs p RandomAgentServers {smpServers, xftpServers} opDomains =
fromMaybe (rndAgentServers p) . L.nonEmpty . agentServerCfgs p opDomains
@@ -516,9 +521,38 @@ deleteFilesLocally files =
withFilesFolder :: (FilePath -> CM ()) -> CM ()
withFilesFolder action = asks filesFolder >>= readTVarIO >>= mapM_ action
-- a sender's feed instance renders the file of the feed item, which is not deleted with the instance
itemsFilesInfo :: [CChatItem c] -> [CIFileInfo]
itemsFilesInfo = mapMaybe itemFileInfo
where
itemFileInfo (CChatItem md ChatItem {file, meta = CIMeta {itemFeed}}) = case md of
SMDSnd | isJust itemFeed -> Nothing
_ -> mkCIFileInfo <$> file
-- a per-chat edit or deletion detaches an instance: feed edits no longer apply to it
detachFeedInstances :: forall c. [CChatItem c] -> CM [CChatItem c]
detachFeedInstances items = do
unless (null linkedIds) $ withStore' $ \db -> Store.detachFeedInstances db linkedIds
pure $ map detached items
where
linkedIds = mapMaybe linkedItemId items
linkedItemId :: CChatItem c -> Maybe ChatItemId
linkedItemId (CChatItem md ChatItem {meta = CIMeta {itemId, itemFeed}}) = case md of
SMDSnd | itemFeed == Just CIFLinked -> Just itemId
_ -> Nothing
detached :: CChatItem c -> CChatItem c
detached (CChatItem md ci) = case md of
SMDSnd -> CChatItem md (detachedInstance ci)
SMDRcv -> CChatItem md ci
detachedInstance :: ChatItem c 'MDSnd -> ChatItem c 'MDSnd
detachedInstance ci@ChatItem {meta}
| itemFeed meta == Just CIFLinked = ci {meta = meta {itemFeed = Just CIFDetached}}
| otherwise = ci
deleteDirectCIs :: User -> Contact -> [CChatItem 'CTDirect] -> CM [ChatItemDeletion]
deleteDirectCIs user ct items = do
let ciFilesInfo = mapMaybe (\(CChatItem _ ChatItem {file}) -> mkCIFileInfo <$> file) items
let ciFilesInfo = itemsFilesInfo items
deleteCIFiles user ciFilesInfo
(errs, deletions) <- lift $ partitionEithers <$> withStoreBatch' (\db -> map (deleteItem db) items)
unless (null errs) $ toView $ CEvtChatErrors errs
@@ -530,7 +564,7 @@ deleteDirectCIs user ct items = do
deleteGroupCIs :: User -> GroupInfo -> Maybe GroupChatScopeInfo -> [CChatItem 'CTGroup] -> Maybe GroupMember -> UTCTime -> CM [ChatItemDeletion]
deleteGroupCIs user gInfo chatScopeInfo items byGroupMember_ deletedTs = do
let ciFilesInfo = mapMaybe (\(CChatItem _ ChatItem {file}) -> mkCIFileInfo <$> file) items
let ciFilesInfo = itemsFilesInfo items
deleteCIFiles user ciFilesInfo
(errs, deletions) <- lift $ partitionEithers <$> withStoreBatch' (\db -> map (deleteItem db) items)
unless (null errs) $ toView $ CEvtChatErrors errs
@@ -594,7 +628,7 @@ deleteGroupMemberCIs_ db user gInfo member = do
deleteLocalCIs :: User -> NoteFolder -> [CChatItem 'CTLocal] -> Bool -> Bool -> CM ChatResponse
deleteLocalCIs user nf items byUser timed = do
let ciFilesInfo = mapMaybe (\(CChatItem _ ChatItem {file}) -> mkCIFileInfo <$> file) items
let ciFilesInfo = itemsFilesInfo items
deleteFilesLocally ciFilesInfo
(errs, deletions) <- lift $ partitionEithers <$> withStoreBatch' (\db -> map (deleteItem db) items)
unless (null errs) $ toView $ CEvtChatErrors errs
@@ -613,7 +647,7 @@ deleteCIFiles user filesInfo = do
markDirectCIsDeleted :: User -> Contact -> [CChatItem 'CTDirect] -> UTCTime -> CM [ChatItemDeletion]
markDirectCIsDeleted user ct items deletedTs = do
let ciFilesInfo = mapMaybe (\(CChatItem _ ChatItem {file}) -> mkCIFileInfo <$> file) items
let ciFilesInfo = itemsFilesInfo items
cancelFilesInProgress user ciFilesInfo
(errs, deletions) <- lift $ partitionEithers <$> withStoreBatch' (\db -> map (markDeleted db) items)
unless (null errs) $ toView $ CEvtChatErrors errs
@@ -625,7 +659,7 @@ markDirectCIsDeleted user ct items deletedTs = do
markGroupCIsDeleted :: User -> GroupInfo -> Maybe GroupChatScopeInfo -> [CChatItem 'CTGroup] -> Maybe GroupMember -> UTCTime -> CM [ChatItemDeletion]
markGroupCIsDeleted user gInfo chatScopeInfo items byGroupMember_ deletedTs = do
let ciFilesInfo = mapMaybe (\(CChatItem _ ChatItem {file}) -> mkCIFileInfo <$> file) items
let ciFilesInfo = itemsFilesInfo items
cancelFilesInProgress user ciFilesInfo
(errs, deletions) <- lift $ partitionEithers <$> withStoreBatch' (\db -> map (markDeleted db) items)
unless (null errs) $ toView $ CEvtChatErrors errs
@@ -2235,14 +2269,45 @@ 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 idsEvents = do
createSndMessages = createSndMessages_ Nothing
-- One message of a broadcast, linked to the feed item. The message of a new
-- broadcast takes the id of the feed item, so that the item of every recipient
-- has that id; the messages that follow take their own ids, as a group rejects
-- a repeated message id (createNewRcvMessage, Store/Messages.hs:324).
createFeedMessage :: Feed -> Maybe SharedMsgId -> ChatItemId -> ChatMsgEvent 'Json -> CM SndMessage
createFeedMessage feed sharedMsgId_ feedItemId event = do
msg <- liftEither . runIdentity =<< lift (createSndMessages_ sharedMsgId_ $ Identity (FeedId (feedId' feed), Nothing, event))
createdAt <- liftIO getCurrentTime
withStore' $ \db -> insertChatItemMessage_ db feedItemId (msgId' msg) createdAt
pure msg
createFeedMessages :: Feed -> ChatItemId -> NonEmpty (ChatMsgEvent 'Json) -> CM [SndMessage]
createFeedMessages feed feedItemId events = do
(errs, msgs) <- lift $ partitionEithers . L.toList <$> createSndMessages (L.map (\evt -> (FeedId (feedId' feed), Nothing, evt)) events)
unless (null errs) $ toView $ CEvtChatErrors errs
createdAt <- liftIO getCurrentTime
withStore' $ \db -> forM_ msgs $ \msg -> insertChatItemMessage_ db feedItemId (msgId' msg) createdAt
pure msgs
feedId' :: Feed -> FeedId
feedId' Feed {feedId} = feedId
msgId' :: SndMessage -> MessageId
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 evnt msgSigning_ encodeMessage
withExceptT ChatErrorStore $ createNewSndMessage db g connOrGroupId sharedMsgId_ evnt msgSigning_ encodeMessage
where
encodeMessage sharedMsgId =
encodeChatMessage maxEncodedMsgLength ChatMessage {chatVRange = vr, msgId = Just sharedMsgId, chatMsgEvent = evnt}
@@ -2574,27 +2639,10 @@ sendGroupSignedMessages_ gInfo@GroupInfo {groupId} recipientMembers signedEvents
let mode = if useRelays' gInfo then BMBinary else BMJson
batched_ = batchSndMessagesJSON mode msgs
case L.nonEmpty batched_ of
Just batched' -> foldMembers (length batched' + length msgs) msgBatchMBR batched' toSend
Just batched' ->
sharedBodyReqs msgFlags (length batched' + length msgs) msgBatchMBR batched' $
map (\(m, conn) -> (groupMemberId' m, conn)) toSend
Nothing -> ([], [])
where
foldMembers :: forall a. Int -> (Maybe Int -> Int -> a -> (ValueOrRef MsgBody, [MessageId])) -> NonEmpty (Either ChatError a) -> [(GroupMember, Connection)] -> ([GroupMemberId], [Either ChatError ChatMsgReq])
foldMembers lastRef mkMb mbs mems = snd $ foldr' foldMsgBodies (lastMemIdx_, ([], [])) mems
where
lastMemIdx_ = let len = length mems in if len > 1 then Just len else Nothing
foldMsgBodies :: (GroupMember, Connection) -> (Maybe Int, ([GroupMemberId], [Either ChatError ChatMsgReq])) -> (Maybe Int, ([GroupMemberId], [Either ChatError ChatMsgReq]))
foldMsgBodies (GroupMember {groupMemberId}, conn) (memIdx_, memIdsReqs) =
(subtract 1 <$> memIdx_,) $ snd $ foldr' addBody (lastRef, memIdsReqs) mbs
where
addBody :: Either ChatError a -> (Int, ([GroupMemberId], [Either ChatError ChatMsgReq])) -> (Int, ([GroupMemberId], [Either ChatError ChatMsgReq]))
addBody mb (i, (memIds, reqs)) =
let req = (conn,msgFlags,) . mkMb memIdx_ i <$> mb
in (i - 1, (groupMemberId : memIds, req : reqs))
msgBatchMBR :: Maybe Int -> Int -> MsgBatch -> (ValueOrRef MsgBody, [MessageId])
msgBatchMBR memIdx_ i (MsgBatch batchBody sndMsgs) = (vrValue_ memIdx_ i batchBody, map (\SndMessage {msgId} -> msgId) sndMsgs)
vrValue_ memIdx_ i v = case memIdx_ of
Nothing -> VRValue Nothing v -- sending to one member, do not reference bodies
Just 1 -> VRValue (Just i) v
Just _ -> VRRef i
preparePending :: NonEmpty (Either ChatError SndMessage) -> [GroupMember] -> ([GroupMemberId], [Either ChatError (GroupMemberId, MessageId)])
preparePending msgs_ =
foldr' foldMsgs ([], [])
@@ -2609,6 +2657,29 @@ sendGroupSignedMessages_ gInfo@GroupInfo {groupId} recipientMembers signedEvents
createPendingMsg db (groupMemberId, msgId) =
createPendingGroupMessage db groupMemberId msgId $> Right ()
-- The first recipient of a body sends it as a value, the rest reference it,
-- so one encoded body is delivered to all of them.
sharedBodyReqs :: forall r a. MsgFlags -> Int -> (Maybe Int -> Int -> a -> (ValueOrRef MsgBody, [MessageId])) -> NonEmpty (Either ChatError a) -> [(r, Connection)] -> ([r], [Either ChatError ChatMsgReq])
sharedBodyReqs msgFlags lastRef mkMb mbs recipients = snd $ foldr' foldMsgBodies (lastIdx_, ([], [])) recipients
where
lastIdx_ = let len = length recipients in if len > 1 then Just len else Nothing
foldMsgBodies :: (r, Connection) -> (Maybe Int, ([r], [Either ChatError ChatMsgReq])) -> (Maybe Int, ([r], [Either ChatError ChatMsgReq]))
foldMsgBodies (r, conn) (idx_, rsReqs) =
(subtract 1 <$> idx_,) $ snd $ foldr' addBody (lastRef, rsReqs) mbs
where
addBody :: Either ChatError a -> (Int, ([r], [Either ChatError ChatMsgReq])) -> (Int, ([r], [Either ChatError ChatMsgReq]))
addBody mb (i, (rs, reqs)) =
let req = (conn,msgFlags,) . mkMb idx_ i <$> mb
in (i - 1, (r : rs, req : reqs))
msgBatchMBR :: Maybe Int -> Int -> MsgBatch -> (ValueOrRef MsgBody, [MessageId])
msgBatchMBR idx_ i (MsgBatch batchBody sndMsgs) = (vrValue_ idx_ i batchBody, map (\SndMessage {msgId} -> msgId) sndMsgs)
where
vrValue_ memIdx_ i' v = case memIdx_ of
Nothing -> VRValue Nothing v -- sending to one recipient, do not reference bodies
Just 1 -> VRValue (Just i') v
Just _ -> VRRef i'
data MemberSendAction = MSASend Connection | MSAPending | MSAForwarded
memberSendAction :: GroupInfo -> NonEmpty (ChatMsgEvent e) -> [GroupMember] -> GroupMember -> Maybe MemberSendAction
@@ -2790,7 +2861,7 @@ saveSndChatItems user cd showGroupAsSender itemsData itemTimed live = do
let hasLink_ = ciContentHasLink content (snd itemTexts)
ciId <- createNewSndChatItem db user cd showGroupAsSender msg content quotedItem itemForwarded itemTimed live hasLink_ createdAt
forM_ ciFile $ \CIFile {fileId} -> updateFileTransferChatItemId db fileId ciId createdAt
let ci = mkChatItem_ cd showGroupAsSender ciId content itemTexts ciFile quotedItem (Just sharedMsgId) itemForwarded itemTimed live False hasLink_ createdAt Nothing (toMsgVerified (signMessagesRequired cd) (MSSVerified <$ signedMsg_)) createdAt
let ci = mkChatItem_ cd showGroupAsSender ciId content itemTexts ciFile quotedItem (Just sharedMsgId) itemForwarded itemTimed live False hasLink_ createdAt Nothing (toMsgVerified (signMessagesRequired cd) (MSSVerified <$ signedMsg_)) Nothing createdAt
Right <$> case cd of
CDGroupSnd g _scope | not (null itemMentions) -> createGroupCIMentions db g ci itemMentions
_ -> pure ci
@@ -2822,7 +2893,8 @@ saveRcvChatItem' user cd msg@RcvMessage {chatMsgEvent, msgSigned, forwardedByMem
itemForwarded <- rcvForwardedFrom db user cd msg
(ciId, quotedItem) <- createNewRcvChatItem db user cd msg sharedMsgId_ content itemForwarded itemTimed live userMention hasLink_ brokerTs createdAt
forM_ ciFile $ \CIFile {fileId} -> updateFileTransferChatItemId db fileId ciId createdAt
let ci = mkChatItem_ cd showAsGroup ciId content (t, ft_) ciFile quotedItem sharedMsgId_ itemForwarded itemTimed live userMention hasLink_ brokerTs forwardedByMember (toMsgVerified (signMessagesRequired cd) msgSigned) createdAt
let itemFeed = if cmFeed chatMsgEvent then Just CIFLinked else Nothing
ci = mkChatItem_ cd showAsGroup ciId content (t, ft_) ciFile quotedItem sharedMsgId_ itemForwarded itemTimed live userMention hasLink_ brokerTs forwardedByMember (toMsgVerified (signMessagesRequired cd) msgSigned) itemFeed createdAt
ci' <- case toChatInfo cd of
GroupChat g _ | not (null mentions') -> createGroupCIMentions db g ci mentions'
_ -> pure ci
@@ -2854,12 +2926,12 @@ mkChatItem :: (ChatTypeI c, MsgDirectionI d) => ChatDirection c d -> ShowGroupAs
mkChatItem cd showGroupAsSender ciId content file quotedItem sharedMsgId itemForwarded itemTimed live userMention itemTs forwardedByMember msgVerified currentTs =
let ts@(_, ft_) = ciContentTexts content
hasLink_ = ciContentHasLink content ft_
in mkChatItem_ cd showGroupAsSender ciId content ts file quotedItem sharedMsgId itemForwarded itemTimed live userMention hasLink_ itemTs forwardedByMember msgVerified currentTs
in mkChatItem_ cd showGroupAsSender ciId content ts file quotedItem sharedMsgId itemForwarded itemTimed live userMention hasLink_ itemTs forwardedByMember msgVerified Nothing currentTs
mkChatItem_ :: (ChatTypeI c, MsgDirectionI d) => ChatDirection c d -> ShowGroupAsSender -> ChatItemId -> CIContent d -> (Text, Maybe MarkdownList) -> Maybe (CIFile d) -> Maybe (CIQuote c) -> Maybe SharedMsgId -> Maybe CIForwardedFrom -> Maybe CITimed -> Bool -> Bool -> Bool -> ChatItemTs -> Maybe GroupMemberId -> Maybe MsgVerified -> UTCTime -> ChatItem c d
mkChatItem_ cd showGroupAsSender ciId content (itemText, formattedText) file quotedItem sharedMsgId itemForwarded itemTimed live userMention hasLink_ itemTs forwardedByMember msgVerified currentTs =
mkChatItem_ :: (ChatTypeI c, MsgDirectionI d) => ChatDirection c d -> ShowGroupAsSender -> ChatItemId -> CIContent d -> (Text, Maybe MarkdownList) -> Maybe (CIFile d) -> Maybe (CIQuote c) -> Maybe SharedMsgId -> Maybe CIForwardedFrom -> Maybe CITimed -> Bool -> Bool -> Bool -> ChatItemTs -> Maybe GroupMemberId -> Maybe MsgVerified -> Maybe CIFeed -> UTCTime -> ChatItem c d
mkChatItem_ cd showGroupAsSender ciId content (itemText, formattedText) file quotedItem sharedMsgId itemForwarded itemTimed live userMention hasLink_ itemTs forwardedByMember msgVerified itemFeed currentTs =
let itemStatus = ciCreateStatus content
meta = mkCIMeta ciId content itemText itemStatus Nothing sharedMsgId itemForwarded Nothing False itemTimed (justTrue live) userMention hasLink_ currentTs itemTs forwardedByMember showGroupAsSender msgVerified currentTs currentTs
meta = mkCIMeta ciId content itemText itemStatus Nothing sharedMsgId itemForwarded Nothing False itemTimed (justTrue live) userMention hasLink_ currentTs itemTs forwardedByMember showGroupAsSender msgVerified itemFeed currentTs currentTs
in ChatItem {chatDir = toCIDirection cd, meta, content, mentions = M.empty, formattedText, quotedItem, reactions = [], file}
ciContentHasLink :: CIContent d -> Maybe MarkdownList -> Bool
@@ -3182,9 +3254,9 @@ createLocalChatItems user cd itemsData createdAt = do
createItem :: DB.Connection -> (CIContent 'MDSnd, Maybe (CIFile 'MDSnd), Maybe CIForwardedFrom, (Text, Maybe MarkdownList)) -> IO (ChatItem 'CTLocal 'MDSnd)
createItem db (content, ciFile, itemForwarded, ts@(_, ft_)) = do
let hasLink_ = ciContentHasLink content ft_
ciId <- createNewChatItem_ db user cd False Nothing Nothing content (Nothing, Nothing, Nothing, Nothing, Nothing) itemForwarded Nothing False False hasLink_ createdAt Nothing Nothing Nothing Nothing createdAt
ciId <- createNewChatItem_ db user cd False Nothing Nothing content (Nothing, Nothing, Nothing, Nothing, Nothing) itemForwarded Nothing False False hasLink_ createdAt Nothing Nothing Nothing Nothing Nothing Nothing createdAt
forM_ ciFile $ \CIFile {fileId} -> updateFileTransferChatItemId db fileId ciId createdAt
pure $ mkChatItem_ cd False ciId content ts ciFile Nothing Nothing itemForwarded Nothing False False hasLink_ createdAt Nothing Nothing createdAt
pure $ mkChatItem_ cd False ciId content ts ciFile Nothing Nothing itemForwarded Nothing False False hasLink_ createdAt Nothing Nothing Nothing createdAt
withUser' :: (User -> CM ChatResponse) -> CM ChatResponse
withUser' action =
src/Simplex/Chat/Library/Subscriber.hs
+331 -45
View File
@@ -29,7 +29,7 @@ import Data.Either (lefts, partitionEithers, rights)
import Data.Foldable (foldr', foldrM)
import Data.Functor (($>))
import Data.Int (Int64)
import Data.List (find, foldl')
import Data.List (find, foldl', partition)
import Data.List.NonEmpty (NonEmpty (..))
import qualified Data.List.NonEmpty as L
import qualified Data.IntSet as IS
@@ -53,7 +53,7 @@ import Simplex.Chat.Files (getChatTempDirectory, safeFileNameStr)
import Simplex.Chat.Library.Internal
import Simplex.Chat.Web (channelContentChanged, channelProfileUpdated, channelRemoved)
import Simplex.Chat.Messages
import Simplex.Chat.Messages.Batch (batchDeliveryTasks1, batchProfiles, batchProfilesWithBody, encodeBinaryBatch, encodeFwdElement, maxBatchElementSize)
import Simplex.Chat.Messages.Batch (BatchMode (..), batchDeliveryTasks1, batchProfiles, batchProfilesWithBody, encodeBinaryBatch, encodeFwdElement, maxBatchElementSize)
import Simplex.Chat.Messages.CIContent
import Simplex.Chat.Messages.CIContent.Events
import Simplex.Chat.ProfileGenerator (generateRandomProfile)
@@ -63,6 +63,7 @@ import Simplex.Chat.Store.Connections
import Simplex.Chat.Store.ContactRequest
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
@@ -194,6 +195,7 @@ processAgentMsgSndFile _corrId aFileId msg = do
withEntityLock_ = \case
Just (ChatRef CTDirect contactId _) -> withContactLock "processAgentMsgSndFile" contactId
Just (ChatRef CTGroup groupId _scope) -> withGroupLock "processAgentMsgSndFile" groupId
Just (ChatRef CTFeed feedId _) -> withFeedLock "processAgentMsgSndFile" feedId
_ -> id
process :: User -> FileTransferId -> CM ()
process user fileId = do
@@ -224,7 +226,7 @@ processAgentMsgSndFile _corrId aFileId msg = do
-- we have 1 chunk - use it as URI whether it is redirect or not
ft' <- maybe (pure ft) (\fId -> withStore $ \db -> getFileTransferMeta db user fId) xftpRedirectFor
toView $ CEvtSndStandaloneFileComplete user ft' $ map (decodeLatin1 . strEncode . FD.fileDescriptionURI) rfds'
Just (AChatItem _ d cInfo _ci@ChatItem {meta = CIMeta {itemSharedMsgId = msgId_, itemDeleted}}) ->
Just (AChatItem _ d cInfo _ci@ChatItem {meta = CIMeta {itemId = fileItemId, itemSharedMsgId = msgId_, itemDeleted}}) ->
case (msgId_, itemDeleted) of
(Just sharedMsgId, Nothing) -> do
when (length rfds < length sfts) $ throwChatError $ CEInternalError "not enough XFTP file descriptions to send"
@@ -264,6 +266,21 @@ processAgentMsgSndFile _corrId aFileId msg = do
where
mConns' = mapMaybe readyMemberConn ms
sfts' = mapMaybe (\sft@SndFileTransfer {groupMemberId} -> (,sft) <$> groupMemberId) sfts
-- one description is sent to every feed recipient by the feed jobs
(rfd : _, _, SMDSnd, FeedChat feed@Feed {feedId}) -> do
let feedItemId = fileItemId
partSize <- asks $ xftpDescrPartSize . config
let parts = splitFileDescr partSize (fileDescrText rfd)
events = L.map (\fileDescr -> XMsgFileDescr {msgId = sharedMsgId, fileDescr, fileExpires}) parts
msgs <- createFeedMessages feed feedItemId events
forM_ (L.nonEmpty $ map msgId' msgs) $ \msgIds ->
withStore' $ \db -> createFeedJobs db feedId feedItemId (FJAFileDescr msgIds)
startFeedWorkers feedId
ci' <- withStore $ \db -> do
liftIO $ updateCIFileStatus db user fileId CIFSSndComplete
getChatItemByFileId db cxt user fileId
lift $ withAgent' (`xftpDeleteSndFileInternal` aFileId)
toView $ CEvtSndFileCompleteXFTP user ci' ft
_ -> pure ()
_ -> pure () -- TODO error?
SFWARN e -> do
@@ -551,7 +568,7 @@ processAgentMessageConn cxt user@User {userId} corrId agentConnId agentMessage =
case event of
XMsgNew mc -> newContentMessage ct'' mc msg msgMeta
XMsgFileDescr sharedMsgId fileDescr fileExpires -> messageFileDescription ct'' sharedMsgId fileDescr fileExpires
XMsgUpdate sharedMsgId mContent _ ttl live _msgScope _ -> messageUpdate ct'' sharedMsgId mContent msg msgMeta ttl live
XMsgUpdate sharedMsgId mContent _ ttl live _msgScope _ feed -> messageUpdate ct'' sharedMsgId mContent msg msgMeta ttl live feed
XMsgDel sharedMsgId _ _ _ -> messageDelete ct'' sharedMsgId msg msgMeta
XMsgReact sharedMsgId _ _ reaction add -> directMsgReaction ct'' sharedMsgId reaction add msg msgMeta
-- TODO discontinue XFile
@@ -727,7 +744,7 @@ processAgentMessageConn cxt user@User {userId} corrId agentConnId agentMessage =
where
sendAutoReply ct mc = \case
Just UserContactRequest {welcomeSharedMsgId = Just smId} ->
void $ sendDirectContactMessage user ct $ XMsgUpdate smId mc M.empty Nothing Nothing Nothing Nothing
void $ sendDirectContactMessage user ct $ XMsgUpdate smId mc M.empty Nothing Nothing Nothing Nothing Nothing
_ -> do
(msg, _) <- sendDirectContactMessage user ct $ XMsgNew $ mcSimple mc
ci <- saveSndChatItem user (CDDirectSnd ct) msg (CISndMsgContent mc)
@@ -1036,10 +1053,10 @@ processAgentMessageConn cxt user@User {userId} corrId agentConnId agentMessage =
MsgContainer {scope, asGroup} = mc
-- file description is always allowed, to allow sending files to support scope
XMsgFileDescr sharedMsgId fileDescr fileExpires -> groupMessageFileDescription gInfo' (Just m'') sharedMsgId fileDescr fileExpires
XMsgUpdate sharedMsgId mContent mentions ttl live msgScope asGroup_ ->
XMsgUpdate sharedMsgId mContent mentions ttl live msgScope asGroup_ feed ->
checkSendAsGroup asGroup_ $
memberCanSend (Just m'') msgScope $
groupMessageUpdate gInfo' (Just m'') sharedMsgId mContent mentions msgScope msg brokerTs ttl live asGroup_
groupMessageUpdate gInfo' (Just m'') sharedMsgId mContent mentions msgScope msg brokerTs ttl live asGroup_ feed
XMsgDel sharedMsgId memberId_ scope_ onlyHistory ->
groupMessageDelete gInfo' (Just m'') sharedMsgId memberId_ scope_ onlyHistory msg brokerTs
XMsgReact sharedMsgId memberId scope_ reaction add -> groupMsgReaction gInfo' m'' sharedMsgId memberId scope_ reaction add msg brokerTs
@@ -1283,7 +1300,7 @@ processAgentMessageConn cxt user@User {userId} corrId agentConnId agentMessage =
_ -> pure Nothing
sendGroupAutoReply mc = \case
Just UserContactRequest {welcomeSharedMsgId = Just smId} ->
void $ sendGroupMessage' user gInfo [m] $ XMsgUpdate smId mc M.empty Nothing Nothing Nothing Nothing
void $ sendGroupMessage' user gInfo [m] $ XMsgUpdate smId mc M.empty Nothing Nothing Nothing Nothing Nothing
_ -> do
msg <- sendGroupMessage' user gInfo [m] $ XMsgNew $ mcSimple mc
ci <- saveSndChatItem user (CDGroupSnd gInfo Nothing) msg (CISndMsgContent mc)
@@ -1867,7 +1884,10 @@ processAgentMessageConn cxt user@User {userId} corrId agentConnId agentMessage =
messageError = toView . CEvtMessageError user "error"
newContentMessage :: Contact -> MsgContainer -> RcvMessage -> MsgMeta -> CM ()
newContentMessage ct mc msg@RcvMessage {sharedMsgId_} msgMeta = do
newContentMessage ct@Contact {chatSettings} mc msg@RcvMessage {sharedMsgId_} msgMeta
-- a feed message for a chat with dropFeed set is acknowledged and discarded
| dropsFeedMsg chatSettings mc = pure ()
| otherwise = do
let MsgContainer {content = c, file = fInv_} = mc
content <- case c of
MCChat {text, chatLink, ownerSig = Just LinkOwnerSig {chatBinding = B64UrlByteString binding}} -> do
@@ -1888,8 +1908,10 @@ processAgentMessageConn cxt user@User {userId} corrId agentConnId agentMessage =
then do
void $ newChatItem (ciContentNoParse $ CIRcvChatFeatureRejected CFVoice) Nothing Nothing False
else do
let MsgContainer {ttl = itemTTL, live = live_} = mc
timed_ = rcvContactCITimed ct itemTTL
let MsgContainer {ttl = itemTTL, live = live_, feed = feed_} = mc
-- a feed message has no ttl in the body: the chat's own TTL applies
itemTTL' = if feed_ == Just True then join (contactTimedTTL ct) else itemTTL
timed_ = rcvContactCITimed ct itemTTL'
live = fromMaybe False live_
file_ <- processFileInvitation fInv_ content $ \db -> createRcvFileTransfer db userId ct
newChatItem (CIRcvMsgContent content, msgContentTexts content) (snd <$> file_) timed_ live
@@ -1975,9 +1997,11 @@ processAgentMessageConn cxt user@User {userId} corrId agentConnId agentMessage =
| fileSize > 0 = pure $ mkValidFileInvitation fInv
| otherwise = throwChatError $ CEFileSize fileName
messageUpdate :: Contact -> SharedMsgId -> MsgContent -> RcvMessage -> MsgMeta -> Maybe Int -> Maybe Bool -> CM ()
messageUpdate ct@Contact {contactId} sharedMsgId mc msg@RcvMessage {msgId} msgMeta ttl live_ = do
updateRcvChatItem `catchCINotFound` \_ -> do
messageUpdate :: Contact -> SharedMsgId -> MsgContent -> RcvMessage -> MsgMeta -> Maybe Int -> Maybe Bool -> Maybe Bool -> CM ()
messageUpdate ct@Contact {contactId, chatSettings} sharedMsgId mc msg@RcvMessage {msgId} msgMeta ttl live_ feed_ = do
updateRcvChatItem `catchCINotFound` \_ ->
-- an update of a dropped feed message creates nothing
unless (dropsFeed chatSettings feed_) $ do
-- This patches initial sharedMsgId into chat item when locally deleted chat item
-- received an update from the sender, so that it can be referenced later (e.g. by broadcast delete).
-- Chat item and update message which created it will have different sharedMsgId in this case...
@@ -1987,7 +2011,8 @@ processAgentMessageConn cxt user@User {userId} corrId agentConnId agentMessage =
(ci, cInfo) <- saveRcvChatItem' user (CDDirectRcv ct) msg (Just sharedMsgId) brokerTs ciContent Nothing Nothing False M.empty
toView $ CEvtChatItemUpdated user (AChatItem SCTDirect SMDRcv cInfo ci)
else do
let timed_ = rcvContactCITimed ct ttl
let itemTTL' = if feed_ == Just True then join (contactTimedTTL ct) else ttl
timed_ = rcvContactCITimed ct itemTTL'
ts = ciContentTexts content
(ci, cInfo) <- saveRcvChatItem' user (CDDirectRcv ct) msg (Just sharedMsgId) brokerTs (content, ts) Nothing timed_ live M.empty
ci' <- withStore' $ \db -> do
@@ -2118,7 +2143,10 @@ processAgentMessageConn cxt user@User {userId} corrId agentConnId agentMessage =
isChannelDir _ = False
newGroupContentMessage :: GroupInfo -> Maybe GroupMember -> MsgContainer -> RcvMessage -> UTCTime -> Bool -> CM (Maybe DeliveryTaskContext)
newGroupContentMessage gInfo m_ mc msg@RcvMessage {sharedMsgId_} brokerTs forwarded = case m_ of
newGroupContentMessage gInfo@GroupInfo {chatSettings} m_ mc msg@RcvMessage {sharedMsgId_} brokerTs forwarded
-- a feed message for a chat with dropFeed set is acknowledged and discarded
| dropsFeedMsg chatSettings mc = pure Nothing
| otherwise = case m_ of
Nothing -> do
createContentItem gInfo Nothing Nothing
-- no delivery task - message already forwarded by relay
@@ -2144,9 +2172,11 @@ processAgentMessageConn cxt user@User {userId} corrId agentConnId agentMessage =
pure $ Just $ infoToDeliveryContext gInfo' scopeInfo sentAsGroup
where
rejected gInfo' m' scopeInfo f = newChatItem gInfo' m' scopeInfo (ciContentNoParse $ CIRcvGroupFeatureRejected f) Nothing Nothing False
timed_ gInfo' = if forwarded then rcvCITimed_ (Just Nothing) itemTTL else rcvGroupCITimed gInfo' itemTTL
-- a feed message has no ttl in the body: the chat's own TTL applies
itemTTL' gInfo' = if feed_ == Just True then join (groupTimedTTL gInfo') else itemTTL
timed_ gInfo' = if forwarded then rcvCITimed_ (Just Nothing) (itemTTL' gInfo') else rcvGroupCITimed gInfo' (itemTTL' gInfo')
live' = fromMaybe False live_
MsgContainer {content = c, mentions = MsgMentions mentions, file = fInv_, ttl = itemTTL, live = live_, scope = msgScope_, asGroup = asGroup_} = mc
MsgContainer {content = c, mentions = MsgMentions mentions, file = fInv_, ttl = itemTTL, live = live_, scope = msgScope_, asGroup = asGroup_, feed = feed_} = mc
content = case c of
MCChat {text, chatLink, ownerSig = Just LinkOwnerSig {chatBinding = B64UrlByteString binding}} -> case publicGroup of
Just pgp | maybe False (binding ==) (expectedBinding pgp) -> c
@@ -2205,16 +2235,18 @@ processAgentMessageConn cxt user@User {userId} corrId agentConnId agentMessage =
reactions <- maybe (pure []) (\sharedMsgId -> withStore' $ \db -> getGroupCIReactions db gInfo' memberId_ sharedMsgId) sharedMsgId_
groupMsgToView cInfo ci' {reactions}
groupMessageUpdate :: GroupInfo -> Maybe GroupMember -> SharedMsgId -> MsgContent -> Map MemberName MsgMention -> Maybe MsgScope -> RcvMessage -> UTCTime -> Maybe Int -> Maybe Bool -> Maybe Bool -> CM (Maybe DeliveryTaskContext)
groupMessageUpdate gInfo@GroupInfo {groupId} m_ sharedMsgId mc mentions msgScope_ msg@RcvMessage {msgId, msgSigned, signedMsg_, signedByGMId_} brokerTs ttl_ live_ asGroup_
groupMessageUpdate :: GroupInfo -> Maybe GroupMember -> SharedMsgId -> MsgContent -> Map MemberName MsgMention -> Maybe MsgScope -> RcvMessage -> UTCTime -> Maybe Int -> Maybe Bool -> Maybe Bool -> Maybe Bool -> CM (Maybe DeliveryTaskContext)
groupMessageUpdate gInfo@GroupInfo {groupId, chatSettings} m_ sharedMsgId mc mentions msgScope_ msg@RcvMessage {msgId, msgSigned, signedMsg_, signedByGMId_} brokerTs ttl_ live_ asGroup_ feed_
| Just m <- m_, prohibitedSimplexLinks gInfo m mc ft_ =
messageWarning ("x.msg.update ignored: feature not allowed " <> groupFeatureNameText GFSimplexLinks) $> Nothing
| dropsFeed chatSettings feed_ = pure Nothing
| otherwise = do
updateRcvChatItem `catchCINotFound` \_ -> do
-- This patches initial sharedMsgId into chat item when locally deleted chat item
-- received an update from the sender, so that it can be referenced later (e.g. by broadcast delete).
-- Chat item and update message which created it will have different sharedMsgId in this case...
let timed_ = rcvGroupCITimed gInfo ttl_
let itemTTL' = if feed_ == Just True then join (groupTimedTTL gInfo) else ttl_
timed_ = rcvGroupCITimed gInfo itemTTL'
showGroupAsSender = fromMaybe (isNothing m_) asGroup_
if showGroupAsSender && maybe False (\m -> memberRole' m < GROwner) m_
then messageError "x.msg.update: member attempted to update as group" $> Nothing
@@ -3879,8 +3911,8 @@ processAgentMessageConn cxt user@User {userId} corrId agentConnId agentMessage =
MsgContainer {scope} = mc
-- file description is always allowed, to allow sending files to support scope
XMsgFileDescr sharedMsgId fileDescr fileExpires -> void $ groupMessageFileDescription gInfo author_ sharedMsgId fileDescr fileExpires
XMsgUpdate sharedMsgId mContent mentions ttl live msgScope asGroup_ ->
void $ memberCanSend author_ msgScope $ groupMessageUpdate gInfo author_ sharedMsgId mContent mentions msgScope rcvMsg msgTs ttl live asGroup_
XMsgUpdate sharedMsgId mContent mentions ttl live msgScope asGroup_ feed ->
void $ memberCanSend author_ msgScope $ groupMessageUpdate gInfo author_ sharedMsgId mContent mentions msgScope rcvMsg msgTs ttl live asGroup_ feed
XMsgDel sharedMsgId memId scope_ _ -> void $ groupMessageDelete gInfo author_ sharedMsgId memId scope_ False rcvMsg msgTs
XMsgReact sharedMsgId memId scope_ reaction add -> withAuthor XMsgReact_ $ \author -> void $ groupMsgReaction gInfo author sharedMsgId memId scope_ reaction add rcvMsg msgTs
XFileCancel sharedMsgId -> void $ xFileCancelGroup gInfo author_ sharedMsgId
@@ -4077,7 +4109,7 @@ runDeliveryTaskWorker a deliveryKey Worker {doWork} = do
forM_ body_ $ \body -> createMsgDeliveryJob db gInfo jobScope senderGMIds body
forM_ acceptedTasks $ \t -> updateDeliveryTaskStatus db (deliveryTaskId t) DTSProcessed
forM_ largeTasks $ \t -> setDeliveryTaskErrStatus db (deliveryTaskId t) "large"
when (isJust body_) . lift . void $ getDeliveryJobWorker True deliveryKey
when (isJust body_) . lift . void $ getDeliveryJobWorker True (uncurry DJKGroup deliveryKey)
-- DJRelayRemoved is allowed when RSInactive - it forwards XGrpMemDel about relay's own deletion
DJRelayRemoved
| workerScope /= DWSGroup ->
@@ -4089,23 +4121,28 @@ runDeliveryTaskWorker a deliveryKey Worker {doWork} = do
withStore' $ \db -> do
createMsgDeliveryJob db gInfo jobScope [senderGMId] body
updateDeliveryTaskStatus db (deliveryTaskId task) DTSProcessed
lift . void $ getDeliveryJobWorker True deliveryKey
lift . void $ getDeliveryJobWorker True (uncurry DJKGroup deliveryKey)
startDeliveryJobWorkers :: CM ()
startDeliveryJobWorkers = do
workerScopes <- withStore' $ \db -> getPendingDeliveryJobScopes db
lift $ forM_ workerScopes resumeDeliveryJobWork
resumeDeliveryJobWork :: DeliveryWorkerKey -> CM' ()
resumeDeliveryJobWork :: DeliveryJobKey -> CM' ()
resumeDeliveryJobWork = void . getDeliveryJobWorker False
getDeliveryJobWorker :: Bool -> DeliveryWorkerKey -> CM' Worker
getDeliveryJobWorker :: Bool -> DeliveryJobKey -> CM' Worker
getDeliveryJobWorker hasWork deliveryKey = do
ws <- asks deliveryJobWorkers
a <- asks smpAgent
getAgentWorker "delivery_job" hasWork a deliveryKey ws $
runDeliveryJobWorker a deliveryKey
-- both feed streams of the event are started: each has its own worker
startFeedWorkers :: FeedId -> CM ()
startFeedWorkers feedId =
lift $ mapM_ (\scope -> void $ getDeliveryJobWorker True (DJKFeed feedId scope)) feedWorkerScopes
-- TODO [relays] dissemination here is unsigned (relay-asserted profile).
-- Future: members sign an XMember on channel join, relay stores it per
-- member and forwards the signed XMember via this sidecar — enables
@@ -4127,30 +4164,40 @@ encodeMemberNew vr gInfo member = case encodeChatMessage maxBatchElementSize cha
chatMsgEvent = XGrpMemNew (memberInfo gInfo member) Nothing
}
runDeliveryJobWorker :: AgentClient -> DeliveryWorkerKey -> Worker -> CM ()
runDeliveryJobWorker :: AgentClient -> DeliveryJobKey -> Worker -> CM ()
runDeliveryJobWorker a deliveryKey Worker {doWork} = do
delay <- asks $ deliveryWorkerDelay . config
cxt <- chatStoreCxt
(user, gInfo) <- withStore $ \db -> do
user <- getUserByGroupId db groupId
gInfo <- getGroupInfo db cxt user groupId
pure (user, gInfo)
forever $ do
unless (delay == 0) $ liftIO $ threadDelay' delay
lift $ waitForWork doWork
runDeliveryJobOperation cxt user gInfo
case deliveryKey of
DJKGroup groupId workerScope -> do
(user, gInfo) <- withStore $ \db -> do
user <- getUserByGroupId db groupId
gInfo <- getGroupInfo db cxt user groupId
pure (user, gInfo)
jobLoop delay $
jobOperation (\db -> getNextDeliveryJob db (groupId, workerScope)) (processDeliveryJob cxt user gInfo workerScope)
DJKFeed feedId scope -> do
(user, feed) <- withStore $ \db -> do
user <- getUserByFeedId db feedId
feed <- getFeed db user feedId
pure (user, feed)
jobLoop delay $
jobOperation (\db -> getNextFeedDeliveryJob db feedId scope) (processFeedJob cxt user feed scope)
where
(groupId, workerScope) = deliveryKey
runDeliveryJobOperation :: StoreCxt -> User -> GroupInfo -> CM ()
runDeliveryJobOperation cxt user gInfo = do
withWork_ a doWork (withStore' $ \db -> getNextDeliveryJob db deliveryKey) $ \job ->
processDeliveryJob job
jobLoop :: Int64 -> CM () -> CM ()
jobLoop delay operation = forever $ do
unless (delay == 0) $ liftIO $ threadDelay' delay
lift $ waitForWork doWork
operation
jobOperation :: (DB.Connection -> IO (Either StoreError (Maybe (DeliveryJob c)))) -> (DeliveryJob c -> CM ()) -> CM ()
jobOperation getJob processJob =
withWork_ a doWork (withStore' getJob) $ \job ->
processJob job
`catchAllErrors` \e -> do
withStore' $ \db -> setDeliveryJobErrStatus db (deliveryJobId job) (tshow e)
eToView e
where
processDeliveryJob :: MessageDeliveryJob -> CM ()
processDeliveryJob job =
processDeliveryJob :: StoreCxt -> User -> GroupInfo -> DeliveryWorkerScope -> DeliveryJob 'CTGroup -> CM ()
processDeliveryJob cxt user gInfo workerScope job =
case jobScopeImpliedSpec jobScope of
DJDeliveryJob _includePending
| not (relayServesGroup gInfo) -> do
@@ -4168,7 +4215,7 @@ runDeliveryJobWorker a deliveryKey Worker {doWork} = do
deleteGroupConnections user gInfo True
withStore' $ \db -> updateDeliveryJobStatus db jobId DJSComplete
where
MessageDeliveryJob {jobId, jobScope, senderGMIds, body, cursorGMId_ = startingCursor} = job
DeliveryJob {jobId, cursorId_ = startingCursor, jobWork = DJWGroup {jobScope, senderGMIds, body}} = job
singleSenderGMId_ = case senderGMIds of
[s] -> Just s
_ -> Nothing
@@ -4325,6 +4372,245 @@ 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
processFeedJob :: StoreCxt -> User -> Feed -> FeedWorkerScope -> DeliveryJob 'CTFeed -> CM ()
processFeedJob cxt user feed scope job = do
bucketSize <- asks $ feedBucketSize . config
let msgIds = feedActionMsgIds feedAction
msgs <- withStore' $ \db -> getFeedJobMessages db msgIds
-- a job pending longer than the message retention loses its body: the local changes still apply
when (length msgs < length msgIds) $ logWarn "feed job: message not found"
bucketLoop bucketSize msgs startingCursor
where
DeliveryJob {jobId, cursorId_ = startingCursor, jobWork = DJWFeed {feedItemId, feedAction}} = job
Feed {feedId} = feed
-- the feed item is re-read for each bucket: a deletion issued while the job runs stops it
bucketLoop :: Int -> [SndMessage] -> Maybe Int64 -> CM ()
bucketLoop bucketSize msgs cursor_ =
withStore' (\db -> runExceptT $ getFeedChatItem db user feedId feedItemId) >>= \case
Right cci
| not (itemChanged cci),
Just item <- feedItemMsg cci ->
sendBucket bucketSize msgs item cursor_ >>= \case
Just cursor' -> bucketLoop bucketSize msgs (Just cursor')
Nothing -> completeJob
_ -> completeJob
itemChanged (CChatItem _ ChatItem {meta = CIMeta {itemDeleted}}) =
isJust itemDeleted && not (feedActionDeletes feedAction)
sendBucket bucketSize msgs item cursor_ = do
cursor' <- case scope of
FWSContacts -> feedContactsBucket cxt user feedItemId feedAction item bucketSize msgs cursor_
FWSGroups -> feedGroupsBucket cxt user feedItemId feedAction item bucketSize msgs cursor_
forM_ cursor' $ \c -> do
withStore' $ \db -> updateFeedDeliveryJobCursor db jobId c
when (feedActionCreates feedAction && isNothing cursor_) $
withStore' $ \db -> updateFeedChatItemStatus db user feedId feedItemId (CISSndSent SSPPartial)
pure cursor'
completeJob = do
lastOfEvent <-
withFeedLock "completeFeedJob" feedId $
withStore' $ \db -> completeFeedJob db jobId feedItemId (feedActionTag feedAction)
when lastOfEvent $ finishFeedEvent user feed feedItemId feedAction
-- a recipient with dropFeed set discards feed messages of the chat quietly
dropsFeed :: ChatSettings -> Maybe Bool -> Bool
dropsFeed ChatSettings {dropFeed} feed_ = feed_ == Just True && isTrue dropFeed
dropsFeedMsg :: ChatSettings -> MsgContainer -> Bool
dropsFeedMsg chatSettings MsgContainer {feed} = dropsFeed chatSettings feed
-- the delete time of a sent instance, from the chat's disappearing messages preference
sndFeedTimed :: Maybe (Maybe Int) -> UTCTime -> Maybe CITimed
sndFeedTimed chatTTL createdAt =
(\ttl -> CITimed ttl (Just $ addUTCTime (realToFrac ttl) createdAt)) <$> join chatTTL
-- One bucket of contacts: instances are created or changed, then the bodies are
-- delivered, then the caller writes the cursor. Nothing ends the stream.
feedContactsBucket :: StoreCxt -> User -> ChatItemId -> FeedJobAction -> FeedItemMsg -> Int -> [SndMessage] -> Maybe ContactId -> CM (Maybe ContactId)
feedContactsBucket cxt user feedItemId action item bucketSize msgs cursor_ = case action of
FJANew _ -> do
cts <- withStore' $ \db -> getFeedContactsByCursor db cxt user cursor_ bucketSize
let ctIds = map contactId' cts
forM_ (lastId ctIds) $ \lastCtId -> do
existing <- withStore' $ \db -> getFeedInstanceContactIdsByRange db user feedItemId fromId lastCtId
createdAt <- liftIO getCurrentTime
recipients <- withStore' $ \db ->
forM (mapMaybe feedRecipient cts) $ \(ct, conn) -> do
let timed_ = sndFeedTimed (contactTimedTTL ct) createdAt
case M.lookup (contactId' ct) existing of
Just itemId -> pure (contactId' ct, itemId, conn, Nothing)
Nothing -> do
itemId <- createFeedInstanceItem db user (CDDirectSnd ct) feedSharedMsgId feedContent feedItemId timed_ feedHasLink createdAt
pure (contactId' ct, itemId, conn, timed_)
forM_ recipients $ \(ctId, itemId, _, newTimed_) ->
forM_ (newTimed_ >>= timedDeleteAt') $
startProximateTimedItemThread user (ChatRef CTDirect ctId Nothing, itemId)
results <- deliverBucket lastCtId [(ctId, itemId, conn) | (ctId, itemId, conn, _) <- recipients]
withStore' $ \db -> updateFeedInstanceStatuses db (sendErrorStatuses results)
pure $ bucketCursor bucketSize ctIds
_ -> do
instances <- withStore' $ \db -> getFeedContactInstancesByCursor db cxt user feedItemId (feedActionInstances action) cursor_ bucketSize
let ctIds = map (contactId' . fst) instances
when (feedActionDelivers action) $
forM_ (lastId ctIds) $ \lastCtId ->
void $ deliverBucket lastCtId [(contactId' ct, itemId, conn) | (ct, itemId) <- instances, Just (_, conn) <- [feedRecipient ct]]
applyContactAction user feedItemId action item instances fromId (fromMaybe 0 $ lastId ctIds)
pure $ bucketCursor bucketSize ctIds
where
FeedItemMsg {feedSharedMsgId, feedContent, feedHasLink} = item
fromId = fromMaybe 0 cursor_
feedRecipient ct = case contactSendConn_ ct of
Right conn | directOrUsed ct && not (connIncognito conn) -> Just (ct, conn)
_ -> Nothing
-- a resumed job skips the connections the agent accepted the message for
deliverBucket lastCtId recipients = do
delivered <- withStore' $ \db -> getDeliveredContactIdsByRange db (firstMsgId msgs) fromId lastCtId
deliverFeedBucket msgs [(itemId, conn) | (ctId, itemId, conn) <- recipients, ctId `notElem` delivered]
-- instance changes of one contacts bucket, in one transaction
applyContactAction :: User -> ChatItemId -> FeedJobAction -> FeedItemMsg -> [(Contact, ChatItemId)] -> ContactId -> ContactId -> CM ()
applyContactAction user feedItemId action item instances fromId toId = case action of
FJAUpdate _ -> withStore' $ \db -> updateFeedContactInstances db user feedItemId fromId toId item
-- each contact's own full delete preference decides between deleting and marking
FJADeleteBroadcast _ -> do
let (toDelete, toMark) = partition (fullDelete . fst) instances
deleteItems toDelete
markDeleted toMark
FJADeleteInternal -> deleteItems instances
FJADeleteMark -> markDeleted instances
_ -> pure ()
where
FeedItemMsg {feedSharedMsgId} = item
fullDelete ct = featureAllowed SCFFullDelete forUser ct
deleteItems cts = withStore' $ \db -> do
deleteFeedContactReactions db feedSharedMsgId (map (contactId' . fst) cts)
deleteFeedInstances db (map snd cts)
markDeleted cts = do
deletedTs <- liftIO getCurrentTime
withStore' $ \db -> markFeedInstancesDeleted db (map snd cts) deletedTs
-- One bucket of customer groups.
feedGroupsBucket :: StoreCxt -> User -> ChatItemId -> FeedJobAction -> FeedItemMsg -> Int -> [SndMessage] -> Maybe GroupId -> CM (Maybe GroupId)
feedGroupsBucket cxt user feedItemId action item bucketSize msgs cursor_ = case action of
FJANew _ -> do
gs <- withStore' $ \db -> getFeedCustomerGroupsByCursor db cxt user cursor_ bucketSize
let gIds = map groupId' gs
forM_ (lastId gIds) $ \lastGId -> do
members <- withStore' $ \db -> getCustomerGroupsMembersByRange db cxt user fromId lastGId
existing <- withStore' $ \db -> getFeedInstanceGroupIdsByRange db user feedItemId fromId lastGId
createdAt <- liftIO getCurrentTime
recipients <- withStore' $ \db ->
forM (filter feedGroup gs) $ \g -> do
let ms = groupMembers members g
timed_ = sndFeedTimed (groupTimedTTL g) createdAt
case M.lookup (groupId' g) existing of
Just itemId -> pure (groupId' g, itemId, ms, Nothing)
Nothing -> do
itemId <- createFeedInstanceItem db user (CDGroupSnd g Nothing) feedSharedMsgId feedContent feedItemId timed_ feedHasLink createdAt
-- member statuses of a new instance, so that SENT and receipts of its members are recorded
forM_ ms $ \(m, _) -> createGroupSndStatus db itemId (groupMemberId' m) GSSNew
pure (groupId' g, itemId, ms, timed_)
forM_ recipients $ \(gId, itemId, _, newTimed_) ->
forM_ (newTimed_ >>= timedDeleteAt') $
startProximateTimedItemThread user (ChatRef CTGroup gId Nothing, itemId)
results <- deliverBucket lastGId [(itemId, ms) | (_, itemId, ms, _) <- recipients]
withStore' $ \db -> updateFeedInstanceStatuses db (sendErrorStatuses results)
pure $ bucketCursor bucketSize gIds
_ -> do
instances <- withStore' $ \db -> getFeedGroupInstancesByCursor db cxt user feedItemId (feedActionInstances action) cursor_ bucketSize
let gIds = map (groupId' . fst) instances
when (feedActionDelivers action) $
forM_ (lastId gIds) $ \lastGId -> do
members <- withStore' $ \db -> getCustomerGroupsMembersByRange db cxt user fromId lastGId
void $ deliverBucket lastGId [(itemId, groupMembers members g) | (g, itemId) <- instances]
applyGroupAction user feedItemId action item instances fromId (fromMaybe 0 $ lastId gIds)
pure $ bucketCursor bucketSize gIds
where
FeedItemMsg {feedSharedMsgId, feedContent, feedHasLink} = item
fromId = fromMaybe 0 cursor_
feedGroup g@GroupInfo {membership} =
not (incognitoMembership g) && memberCurrent membership && memberActive membership
groupMembers members g =
[(m, conn) | m <- filter memberCurrent (M.findWithDefault [] (groupId' g) members), Just (_, conn) <- [readyMemberConn m]]
-- a resumed job skips the connections the agent accepted the message for
deliverBucket lastGId recipients = do
delivered <- withStore' $ \db -> getDeliveredMemberIdsByRange db (firstMsgId msgs) fromId lastGId
deliverFeedBucket msgs [(itemId, conn) | (itemId, ms) <- recipients, (m, conn) <- ms, groupMemberId' m `notElem` delivered]
applyGroupAction :: User -> ChatItemId -> FeedJobAction -> FeedItemMsg -> [(GroupInfo, ChatItemId)] -> GroupId -> GroupId -> CM ()
applyGroupAction user feedItemId action item instances fromId toId = case action of
FJAUpdate _ -> withStore' $ \db -> updateFeedGroupInstances db user feedItemId fromId toId item
-- each group's own full delete preference decides between deleting and marking
FJADeleteBroadcast _ -> do
let (toDelete, toMark) = partition (groupFeatureUserAllowed SGFFullDelete . fst) instances
deleteItems toDelete
markDeleted toMark
FJADeleteInternal -> deleteItems instances
FJADeleteMark -> markDeleted instances
_ -> pure ()
where
FeedItemMsg {feedSharedMsgId} = item
deleteItems gs = withStore' $ \db -> do
deleteFeedGroupReactions db feedSharedMsgId (map (membershipId . fst) gs)
deleteFeedInstances db (map snd gs)
markDeleted gs = do
deletedTs <- liftIO getCurrentTime
withStore' $ \db -> markFeedInstancesDeleted db (map snd gs) deletedTs
membershipId GroupInfo {groupId, membership} = (groupId, memberId' membership)
-- one deliverMessagesB for the bucket: the first request of each body sends it, the rest reference it
deliverFeedBucket :: [SndMessage] -> [(ChatItemId, Connection)] -> CM [(ChatItemId, Either ChatError ([Int64], PQEncryption))]
deliverFeedBucket msgs recipients = case (L.nonEmpty msgs, recipients) of
(Just msgs', _ : _) -> do
let batched_ = batchSndMessagesJSON BMJson $ L.map Right msgs'
case L.nonEmpty batched_ of
Nothing -> pure []
Just batched' -> do
let msgFlags = MsgFlags {notification = hasNotification XMsgNew_}
(itemIds, msgReqs) = sharedBodyReqs msgFlags (length batched' + length msgs') msgBatchMBR batched' recipients
case L.nonEmpty msgReqs of
Nothing -> pure []
Just msgReqs' -> zip itemIds . L.toList <$> deliverMessagesB msgReqs'
_ -> pure []
sendErrorStatuses :: [(ChatItemId, Either ChatError a)] -> [(ChatItemId, CIStatus 'MDSnd)]
sendErrorStatuses = mapMaybe itemError
where
itemError (itemId, r) = case r of
Left e -> Just (itemId, CISSndError $ SndErrOther $ tshow e)
Right _ -> Nothing
firstMsgId :: [SndMessage] -> MessageId
firstMsgId = \case
SndMessage {msgId} : _ -> msgId
[] -> 0
lastId :: [Int64] -> Maybe Int64
lastId ids = case reverse ids of
i : _ -> Just i
[] -> Nothing
-- the stream continues while buckets are full
bucketCursor :: Int -> [Int64] -> Maybe Int64
bucketCursor bucketSize ids
| length ids < bucketSize = Nothing
| otherwise = lastId ids
-- the last job of the event reports its result on the feed item
finishFeedEvent :: User -> Feed -> ChatItemId -> FeedJobAction -> CM ()
finishFeedEvent user feed@Feed {feedId} feedItemId action
| feedActionCreates action = do
withStore' $ \db -> updateFeedChatItemStatus db user feedId feedItemId (CISSndSent SSPComplete)
withFeedItem $ \ci -> toView $ CEvtChatItemsStatusesUpdated user [aFeedItem feed ci]
| feedActionRemovesItem action = withFeedItem $ \cci -> do
deleteCIFiles user $ itemsFilesInfo [cci]
withStore' $ \db -> deleteFeedChatItem db user feedId feedItemId
toView $ CEvtChatItemsDeleted user [ChatItemDeletion (aFeedItem feed cci) Nothing] True False
| otherwise = pure ()
where
withFeedItem action' =
withStore' (\db -> runExceptT $ getFeedChatItem db user feedId feedItemId)
>>= either (const $ pure ()) action'
-- Single worker processes all relay requests (XGrpRelayInv).
-- We use map with a single key 1 to fit into existing worker management framework.
src/Simplex/Chat/Messages.hs
+2 -5
View File
@@ -568,6 +568,7 @@ deletable' itemContent itemDeleted itemTs allowedInterval currentTs =
CISndMsgContent _ ->
case chatTypeI @c of
SCTLocal -> isNothing itemDeleted
SCTFeed -> isNothing itemDeleted
_ -> diffUTCTime currentTs itemTs < allowedInterval && isNothing itemDeleted
_ -> False
@@ -667,7 +668,6 @@ data MemberReaction = MemberReaction
type family ChatTypeQuotable (a :: ChatType) :: Constraint where
ChatTypeQuotable 'CTDirect = ()
ChatTypeQuotable 'CTGroup = ()
ChatTypeQuotable 'CTFeed = ()
ChatTypeQuotable a =
(Int ~ Bool, TypeError ('Type.Text "ChatType " ':<>: 'ShowType a ':<>: 'Type.Text " cannot be quoted"))
@@ -676,7 +676,6 @@ data CIQDirection (c :: ChatType) where
CIQDirectRcv :: CIQDirection 'CTDirect
CIQGroupSnd :: CIQDirection 'CTGroup
CIQGroupRcv :: Maybe GroupMember -> CIQDirection 'CTGroup -- member can be Nothing in case MsgRef has memberId that the user is not notified about yet
CIQFeedSnd :: CIQDirection 'CTFeed
deriving instance Show (CIQDirection c)
@@ -689,7 +688,6 @@ jsonCIQDirection = \case
CIQGroupSnd -> JCIGroupSnd
CIQGroupRcv (Just m) -> JCIGroupRcv m
CIQGroupRcv Nothing -> JCIChannelRcv
CIQFeedSnd -> JCIFeedSnd
jsonACIQDirection :: JSONCIDirection -> Either String ACIQDirection
jsonACIQDirection = \case
@@ -700,7 +698,7 @@ jsonACIQDirection = \case
JCIChannelRcv -> Right $ ACIQDirection SCTGroup $ CIQGroupRcv Nothing
JCILocalSnd -> Left "unquotable"
JCILocalRcv -> Left "unquotable"
JCIFeedSnd -> Right $ ACIQDirection SCTFeed CIQFeedSnd
JCIFeedSnd -> Left "unquotable"
quoteMsgDirection :: CIQDirection c -> MsgDirection
quoteMsgDirection = \case
@@ -708,7 +706,6 @@ quoteMsgDirection = \case
CIQDirectRcv -> MDRcv
CIQGroupSnd -> MDSnd
CIQGroupRcv _ -> MDRcv
CIQFeedSnd -> MDSnd
data CIFile (d :: MsgDirection) = CIFile
{ fileId :: Int64,
src/Simplex/Chat/Protocol.hs
+5
View File
@@ -624,6 +624,11 @@ cmToQuotedMsg = \case
ACME _ (XMsgNew MsgContainer {quote = Just quotedMsg}) -> Just quotedMsg
_ -> Nothing
cmFeed :: AChatMsgEvent -> Bool
cmFeed = \case
ACME _ (XMsgNew MsgContainer {feed = Just True}) -> True
_ -> False
data MsgContentTag
= MCText_
| MCLink_
src/Simplex/Chat/Store/Connections.hs
+4 -4
View File
@@ -112,7 +112,7 @@ getConnectionEntity db cxt user@User {userId, userContactId} agentConnId = do
db
[sql|
SELECT
c.contact_profile_id, c.local_display_name, p.display_name, p.full_name, p.short_descr, p.description, p.image, p.contact_link, p.chat_peer_type, p.local_alias, c.contact_used, c.contact_status, c.enable_ntfs, c.send_rcpts, c.favorite,
c.contact_profile_id, c.local_display_name, p.display_name, p.full_name, p.short_descr, p.description, p.image, p.contact_link, p.chat_peer_type, p.local_alias, c.contact_used, c.contact_status, c.enable_ntfs, c.send_rcpts, c.favorite, c.drop_feed,
p.preferences, c.user_preferences, c.created_at, c.updated_at, c.chat_ts, c.conn_full_link_to_connect, c.conn_short_link_to_connect, c.welcome_shared_msg_id, c.request_shared_msg_id, c.contact_request_id, cr2.rejection_supported,
c.contact_group_member_id, c.contact_grp_inv_sent, c.grp_direct_inv_link, c.grp_direct_inv_from_group_id, c.grp_direct_inv_from_group_member_id, c.grp_direct_inv_from_member_conn_id, c.grp_direct_inv_started_connection,
c.ui_themes, c.chat_deleted, c.custom_data, c.chat_item_ttl,
@@ -125,9 +125,9 @@ getConnectionEntity db cxt user@User {userId, userContactId} agentConnId = do
|]
(userId, contactId, CSActive)
toContact' :: UTCTime -> Int64 -> Connection -> [ChatTagId] -> ContactRow' -> Contact
toContact' currentTs contactId conn chatTags ((profileId, localDisplayName, displayName, fullName, shortDescr, description, image, contactLink, peerType, localAlias, BI contactUsed, contactStatus) :. (enableNtfs_, sendRcpts, BI favorite, preferences, userPreferences, createdAt, updatedAt, chatTs) :. preparedContactRow :. (contactRequestId, rejectionSupported_, contactGroupMemberId, BI contactGrpInvSent) :. groupDirectInvRow :. (uiThemes, BI chatDeleted, customData, chatItemTTL) :. badgeRow :. domainRow) =
toContact' currentTs contactId conn chatTags ((profileId, localDisplayName, displayName, fullName, shortDescr, description, image, contactLink, peerType, localAlias, BI contactUsed, contactStatus) :. (enableNtfs_, sendRcpts, BI favorite, BI dropFeed_, preferences, userPreferences, createdAt, updatedAt, chatTs) :. preparedContactRow :. (contactRequestId, rejectionSupported_, contactGroupMemberId, BI contactGrpInvSent) :. groupDirectInvRow :. (uiThemes, BI chatDeleted, customData, chatItemTTL) :. badgeRow :. domainRow) =
let profile = LocalProfile {profileId, displayName, fullName, shortDescr, description, image, contactLink, contactDomain = rowToContactDomain domainRow, contactDomainVerified = rowToDomainVerified domainRow, peerType, localBadge = rowToBadge currentTs badgeRow, preferences, localAlias}
chatSettings = ChatSettings {enableNtfs = fromMaybe MFAll enableNtfs_, sendRcpts = unBI <$> sendRcpts, favorite}
chatSettings = ChatSettings {enableNtfs = fromMaybe MFAll enableNtfs_, sendRcpts = unBI <$> sendRcpts, favorite, dropFeed = BoolDef dropFeed_}
mergedPreferences = contactUserPreferences user userPreferences preferences $ connIncognito conn
activeConn = Just conn
preparedContact = toPreparedContact preparedContactRow
@@ -147,7 +147,7 @@ getConnectionEntity db cxt user@User {userId, userContactId} agentConnId = do
-- 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,
g.enable_ntfs, g.send_rcpts, g.favorite, gp.preferences, gp.member_admission,
g.enable_ntfs, g.send_rcpts, g.favorite, g.drop_feed, gp.preferences, gp.member_admission,
g.created_at, g.updated_at, g.chat_ts, g.user_member_profile_sent_at,
g.conn_full_link_to_connect, g.conn_short_link_to_connect, g.conn_link_prepared_connection, g.conn_link_started_connection, g.welcome_shared_msg_id, g.request_shared_msg_id,
g.business_chat, g.business_member_id, g.customer_member_id,
src/Simplex/Chat/Store/ContactRequest.hs
+1 -1
View File
@@ -114,7 +114,7 @@ createOrUpdateContactRequest
[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.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,
ct.contact_group_member_id, ct.contact_grp_inv_sent, ct.grp_direct_inv_link, ct.grp_direct_inv_from_group_id, ct.grp_direct_inv_from_group_member_id, ct.grp_direct_inv_from_member_conn_id, ct.grp_direct_inv_started_connection,
ct.ui_themes, ct.chat_deleted, ct.custom_data, ct.chat_item_ttl,
src/Simplex/Chat/Store/Delivery.hs
+146 -29
View File
@@ -26,6 +26,11 @@ module Simplex.Chat.Store.Delivery
getGroupMembersByCursor,
updateDeliveryJobCursor,
deleteDoneDeliveryJobs,
createFeedJobs,
getNextFeedDeliveryJob,
updateFeedDeliveryJobCursor,
completeFeedJob,
getFeedJobMessages,
)
where
@@ -33,11 +38,13 @@ import qualified Data.Aeson as J
import Data.ByteString.Char8 (ByteString)
import Data.Int (Int64)
import qualified Data.List.NonEmpty as L
import Data.Maybe (isNothing)
import Data.List.NonEmpty (NonEmpty (..))
import Data.Maybe (catMaybes, isNothing, mapMaybe)
import Data.Text (Text)
import qualified Data.Text as T
import Data.Time.Clock (UTCTime, getCurrentTime)
import Simplex.Chat.Delivery
import Simplex.Chat.Messages (ChatItemId, ChatType (..), MessageId, SndMessage (..))
import Simplex.Chat.Protocol hiding (Binary)
import Simplex.Chat.Store.Shared
import Simplex.Chat.Types
@@ -46,6 +53,7 @@ import Simplex.Messaging.Agent.Store.AgentStore (getWorkItem, getWorkItems, mayb
import Simplex.Messaging.Agent.Store.DB (Binary (..), BoolInt (..))
import qualified Simplex.Messaging.Agent.Store.DB as DB
import Simplex.Messaging.Encoding (smpDecode)
import Simplex.Messaging.Encoding.String (TextEncoding (..))
import Simplex.Messaging.Util (eitherToMaybe, firstRow')
import Text.Read (readMaybe)
#if defined(dbPostgres)
@@ -269,22 +277,29 @@ createMsgDeliveryJob db gInfo jobScope senderGMIds body = do
| null senderGMIds = Nothing
| otherwise = Just $ T.intercalate "," $ map (T.pack . show) senderGMIds
getPendingDeliveryJobScopes :: DB.Connection -> IO [DeliveryWorkerKey]
getPendingDeliveryJobScopes :: DB.Connection -> IO [DeliveryJobKey]
getPendingDeliveryJobScopes db =
DB.query
db
[sql|
SELECT DISTINCT group_id, worker_scope
FROM delivery_jobs
WHERE failed = 0 AND job_status = ?
|]
(Only DJSPending)
mapMaybe toJobKey
<$> DB.query
db
[sql|
SELECT DISTINCT group_id, feed_id, worker_scope
FROM delivery_jobs
WHERE failed = 0 AND job_status = ?
|]
(Only DJSPending)
where
toJobKey :: (Maybe GroupId, Maybe FeedId, Text) -> Maybe DeliveryJobKey
toJobKey = \case
(Just groupId, Nothing, scope) -> DJKGroup groupId <$> (textDecode scope :: Maybe DeliveryWorkerScope)
(Nothing, Just feedId, scope) -> DJKFeed feedId <$> (textDecode scope :: Maybe FeedWorkerScope)
_ -> Nothing
type MessageDeliveryJobRow = (Only Int64) :. DeliveryJobScopeRow :. (Maybe Text, Binary ByteString, Maybe GroupMemberId)
getNextDeliveryJob :: DB.Connection -> DeliveryWorkerKey -> IO (Either StoreError (Maybe MessageDeliveryJob))
getNextDeliveryJob :: DB.Connection -> DeliveryWorkerKey -> IO (Either StoreError (Maybe (DeliveryJob 'CTGroup)))
getNextDeliveryJob db deliveryKey = do
getWorkItem "delivery job" getJobId getJob markJobFailed
getWorkItem "delivery job" getJobId getJob (markJobFailed db)
where
(groupId, workerScope) = deliveryKey
getJobId :: IO (Maybe Int64)
@@ -301,7 +316,7 @@ getNextDeliveryJob db deliveryKey = do
LIMIT 1
|]
(groupId, workerScope, DJSPending)
getJob :: Int64 -> IO (Either StoreError MessageDeliveryJob)
getJob :: Int64 -> IO (Either StoreError (DeliveryJob 'CTGroup))
getJob jobId =
firstRow' toDeliveryJob (SEDeliveryJobNotFound jobId) $
DB.query
@@ -316,23 +331,125 @@ getNextDeliveryJob db deliveryKey = do
|]
(Only jobId)
where
toDeliveryJob :: MessageDeliveryJobRow -> Either StoreError MessageDeliveryJob
toDeliveryJob ((Only jobId') :. jobScopeRow :. (senderGMIdsText_, Binary body, cursorGMId_)) = do
toDeliveryJob :: MessageDeliveryJobRow -> Either StoreError (DeliveryJob 'CTGroup)
toDeliveryJob ((Only jobId') :. jobScopeRow :. (senderGMIdsText_, Binary body, cursorId_)) = do
jobScope <- maybe (Left $ SEInvalidDeliveryJob jobId') Right $ toJobScope_ jobScopeRow
-- NULL or empty string means []; otherwise the value must parse
-- as a comma-separated decimal Int64 list. An unparseable
-- segment surfaces as job error rather than silent degradation.
senderGMIds <- case senderGMIdsText_ of
Nothing -> Right []
Just t -> maybe (Left $ SEInvalidDeliveryJob jobId') Right $ parseSenderGMIds t
Right $ MessageDeliveryJob {jobId = jobId', jobScope, senderGMIds, body, cursorGMId_}
parseSenderGMIds :: Text -> Maybe [GroupMemberId]
parseSenderGMIds t
| T.null t = Just []
| otherwise = traverse (readMaybe . T.unpack) (T.splitOn "," t)
markJobFailed :: Int64 -> IO ()
markJobFailed jobId =
DB.execute db "UPDATE delivery_jobs SET failed = 1 where delivery_job_id = ?" (Only jobId)
senderGMIds <- parseIds jobId' senderGMIdsText_
Right DeliveryJob {jobId = jobId', cursorId_, jobWork = DJWGroup {jobScope, senderGMIds, body}}
-- NULL or empty string means []; otherwise the value must parse as a
-- comma-separated decimal Int64 list. An unparseable segment surfaces as
-- job error rather than silent degradation.
parseIds :: Int64 -> Maybe Text -> Either StoreError [Int64]
parseIds jobId = \case
Nothing -> Right []
Just t
| T.null t -> Right []
| otherwise -> maybe (Left $ SEInvalidDeliveryJob jobId) Right $ traverse (readMaybe . T.unpack) (T.splitOn "," t)
idsColumn :: [Int64] -> Maybe Text
idsColumn ids
| null ids = Nothing
| otherwise = Just $ T.intercalate "," $ map (T.pack . show) ids
markJobFailed :: DB.Connection -> Int64 -> IO ()
markJobFailed db jobId =
DB.execute db "UPDATE delivery_jobs SET failed = 1 where delivery_job_id = ?" (Only jobId)
createFeedDeliveryJob :: DB.Connection -> FeedId -> ChatItemId -> FeedWorkerScope -> FeedJobAction -> IO ()
createFeedDeliveryJob db feedId feedItemId scope action = do
currentTs <- getCurrentTime
DB.execute
db
[sql|
INSERT INTO delivery_jobs (
feed_id, chat_item_id, worker_scope, job_scope_spec_tag, message_ids,
job_status, created_at, updated_at
) VALUES (?,?,?,?,?,?,?,?)
|]
(feedId, feedItemId, scope, feedActionTag action, idsColumn (feedActionMsgIds action), DJSPending, currentTs, currentTs)
createFeedJobs :: DB.Connection -> FeedId -> ChatItemId -> FeedJobAction -> IO ()
createFeedJobs db feedId feedItemId action =
mapM_ (\scope -> createFeedDeliveryJob db feedId feedItemId scope action) feedWorkerScopes
type FeedDeliveryJobRow = (Int64, ChatItemId, FeedJobActionTag, Maybe Text, Maybe Int64)
getNextFeedDeliveryJob :: DB.Connection -> FeedId -> FeedWorkerScope -> IO (Either StoreError (Maybe (DeliveryJob 'CTFeed)))
getNextFeedDeliveryJob db feedId scope = do
getWorkItem "feed delivery job" getJobId getJob (markJobFailed db)
where
getJobId :: IO (Maybe Int64)
getJobId =
maybeFirstRow fromOnly $
DB.query
db
[sql|
SELECT delivery_job_id
FROM delivery_jobs
WHERE feed_id = ? AND worker_scope = ?
AND failed = 0 AND job_status = ?
ORDER BY delivery_job_id ASC
LIMIT 1
|]
(feedId, scope, DJSPending)
getJob :: Int64 -> IO (Either StoreError (DeliveryJob 'CTFeed))
getJob jobId =
firstRow' toFeedDeliveryJob (SEDeliveryJobNotFound jobId) $
DB.query
db
[sql|
SELECT delivery_job_id, chat_item_id, job_scope_spec_tag, message_ids, feed_cursor_id
FROM delivery_jobs
WHERE delivery_job_id = ?
|]
(Only jobId)
toFeedDeliveryJob :: FeedDeliveryJobRow -> Either StoreError (DeliveryJob 'CTFeed)
toFeedDeliveryJob (jobId, feedItemId, actionTag, msgIdsText_, cursorId_) = do
msgIds <- parseIds jobId msgIdsText_
feedAction <- case (actionTag, msgIds) of
(FJATNew, [msgId]) -> Right $ FJANew msgId
(FJATFileDescr, msgId : msgIds') -> Right $ FJAFileDescr (msgId :| msgIds')
(FJATUpdate, [msgId]) -> Right $ FJAUpdate msgId
(FJATDeleteBroadcast, [msgId]) -> Right $ FJADeleteBroadcast msgId
(FJATDeleteInternal, []) -> Right FJADeleteInternal
(FJATDeleteMark, []) -> Right FJADeleteMark
_ -> Left $ SEInvalidDeliveryJob jobId
Right DeliveryJob {jobId, cursorId_, jobWork = DJWFeed {feedItemId, feedAction}}
updateFeedDeliveryJobCursor :: DB.Connection -> Int64 -> Int64 -> IO ()
updateFeedDeliveryJobCursor db jobId cursorId = do
currentTs <- getCurrentTime
DB.execute
db
"UPDATE delivery_jobs SET feed_cursor_id = ?, updated_at = ? WHERE delivery_job_id = ?"
(cursorId, currentTs, jobId)
-- completes the job and reports whether it was the last job of its feed event
completeFeedJob :: DB.Connection -> Int64 -> ChatItemId -> FeedJobActionTag -> IO Bool
completeFeedJob db jobId feedItemId actionTag = do
updateDeliveryJobStatus db jobId DJSComplete
pending <-
maybeFirstRow fromOnly $
DB.query
db
[sql|
SELECT COUNT(1)
FROM delivery_jobs
WHERE chat_item_id = ? AND job_scope_spec_tag = ? AND job_status = ? AND failed = 0
|]
(feedItemId, actionTag, DJSPending)
pure $ pending == Just (0 :: Int)
-- the messages of a feed job action: one, or the parts of one file description
getFeedJobMessages :: DB.Connection -> [MessageId] -> IO [SndMessage]
getFeedJobMessages db = fmap catMaybes . mapM getMsg
where
getMsg msgId =
maybeFirstRow toSndMessage $
DB.query db "SELECT shared_msg_id, msg_body FROM messages WHERE message_id = ? AND shared_msg_id IS NOT NULL" (Only msgId)
where
toSndMessage (sharedMsgId, Binary msgBody) = SndMessage {msgId, sharedMsgId, msgBody, signedMsg_ = Nothing}
updateDeliveryJobStatus :: DB.Connection -> Int64 -> DeliveryJobStatus -> IO ()
updateDeliveryJobStatus db jobId status = updateDeliveryJobStatus_ db jobId status Nothing
src/Simplex/Chat/Store/Direct.hs
+16 -44
View File
@@ -318,28 +318,19 @@ getContactByConnReqHash db cxt user@User {userId} cReqHash1 cReqHash2 = do
maybeFirstRow (toContact currentTs cxt user []) $
DB.query
db
[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,
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,
ct.contact_group_member_id, ct.contact_grp_inv_sent, ct.grp_direct_inv_link, ct.grp_direct_inv_from_group_id, ct.grp_direct_inv_from_group_member_id, ct.grp_direct_inv_from_member_conn_id, ct.grp_direct_inv_started_connection,
ct.ui_themes, ct.chat_deleted, ct.custom_data, ct.chat_item_ttl,
cp.badge_proof, cp.badge_pres_header, cp.badge_expiry, cp.badge_type, cp.badge_verified, cp.badge_extra, cp.badge_master_key, cp.badge_signature, cp.badge_key_idx,
cp.contact_domain, cp.contact_domain_proof, cp.contact_domain_verified,
-- Connection
c.connection_id, c.agent_conn_id, c.conn_level, c.via_contact, c.via_user_contact_link, c.via_group_link, c.group_link_id, c.xcontact_id, c.custom_user_profile_id, c.conn_status, c.conn_type, c.contact_conn_initiated, c.local_alias,
c.contact_id, c.group_member_id, c.user_contact_link_id, c.created_at, c.security_code, c.security_code_verified_at, c.pq_support, c.pq_encryption, c.pq_snd_enabled, c.pq_rcv_enabled, c.auth_err_counter, c.quota_err_counter,
c.conn_chat_version, c.peer_chat_min_version, c.peer_chat_max_version
FROM contacts ct
JOIN contact_profiles cp ON ct.contact_profile_id = cp.contact_profile_id
JOIN connections c ON c.contact_id = ct.contact_id
LEFT JOIN contact_requests cr2 ON cr2.contact_request_id = ct.contact_request_id
WHERE
( (c.user_id = ? AND c.via_contact_uri_hash = ?) OR
(c.user_id = ? AND c.via_contact_uri_hash = ?)
) AND ct.contact_status = ? AND ct.deleted = 0
|]
( "SELECT "
<> contactQueryFields
<> [sql|
FROM contacts ct
JOIN contact_profiles cp ON ct.contact_profile_id = cp.contact_profile_id
JOIN connections c ON c.contact_id = ct.contact_id
LEFT JOIN contact_requests cr2 ON cr2.contact_request_id = ct.contact_request_id
WHERE
( (c.user_id = ? AND c.via_contact_uri_hash = ?) OR
(c.user_id = ? AND c.via_contact_uri_hash = ?)
) AND ct.contact_status = ? AND ct.deleted = 0
|]
)
(userId, cReqHash1, userId, cReqHash2, CSActive)
mapM (addDirectChatTags db) ct
@@ -969,26 +960,7 @@ getContact_ db cxt user@User {userId} contactId deleted = do
ExceptT . firstRow (toContact currentTs cxt user chatTags) (SEContactNotFound contactId) $
DB.query
db
[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,
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,
ct.contact_group_member_id, ct.contact_grp_inv_sent, ct.grp_direct_inv_link, ct.grp_direct_inv_from_group_id, ct.grp_direct_inv_from_group_member_id, ct.grp_direct_inv_from_member_conn_id, ct.grp_direct_inv_started_connection,
ct.ui_themes, ct.chat_deleted, ct.custom_data, ct.chat_item_ttl,
cp.badge_proof, cp.badge_pres_header, cp.badge_expiry, cp.badge_type, cp.badge_verified, cp.badge_extra, cp.badge_master_key, cp.badge_signature, cp.badge_key_idx,
cp.contact_domain, cp.contact_domain_proof, cp.contact_domain_verified,
-- Connection
c.connection_id, c.agent_conn_id, c.conn_level, c.via_contact, c.via_user_contact_link, c.via_group_link, c.group_link_id, c.xcontact_id, c.custom_user_profile_id, c.conn_status, c.conn_type, c.contact_conn_initiated, c.local_alias,
c.contact_id, c.group_member_id, c.user_contact_link_id, c.created_at, c.security_code, c.security_code_verified_at, c.pq_support, c.pq_encryption, c.pq_snd_enabled, c.pq_rcv_enabled, c.auth_err_counter, c.quota_err_counter,
c.conn_chat_version, c.peer_chat_min_version, c.peer_chat_max_version
FROM contacts ct
JOIN contact_profiles cp ON ct.contact_profile_id = cp.contact_profile_id
LEFT JOIN connections c ON c.contact_id = ct.contact_id
LEFT JOIN contact_requests cr2 ON cr2.contact_request_id = ct.contact_request_id
WHERE ct.user_id = ? AND ct.contact_id = ?
AND ct.deleted = ?
|]
(contactQuery <> " WHERE ct.user_id = ? AND ct.contact_id = ? AND ct.deleted = ?")
(userId, contactId, BI deleted)
getUserByContactRequestId :: DB.Connection -> Int64 -> ExceptT StoreError IO User
@@ -1078,8 +1050,8 @@ updateConnectionStatus_ db connId connStatus = do
else DB.execute db "UPDATE connections SET conn_status = ?, updated_at = ? WHERE connection_id = ?" (connStatus, currentTs, connId)
updateContactSettings :: DB.Connection -> User -> Int64 -> ChatSettings -> IO ()
updateContactSettings db User {userId} contactId ChatSettings {enableNtfs, sendRcpts, favorite} =
DB.execute db "UPDATE contacts SET enable_ntfs = ?, send_rcpts = ?, favorite = ? WHERE user_id = ? AND contact_id = ?" (enableNtfs, BI <$> sendRcpts, BI favorite, userId, contactId)
updateContactSettings db User {userId} contactId ChatSettings {enableNtfs, sendRcpts, favorite, dropFeed} =
DB.execute db "UPDATE contacts SET enable_ntfs = ?, send_rcpts = ?, favorite = ?, drop_feed = ? WHERE user_id = ? AND contact_id = ?" (enableNtfs, BI <$> sendRcpts, BI favorite, BI (isTrue dropFeed), userId, contactId)
setConnConnReqInv :: DB.Connection -> User -> Int64 -> ConnReqInvitation -> IO ()
setConnConnReqInv db User {userId} connId connReq = do
src/Simplex/Chat/Store/Feeds.hs
+301
View File
@@ -0,0 +1,301 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeOperators #-}
module Simplex.Chat.Store.Feeds
( createFeed,
getUserFeedId,
getFeed,
updateFeedUnreadChat,
deleteFeedCIs,
getFeedContactsByCursor,
getFeedCustomerGroupsByCursor,
getCustomerGroupsMembersByRange,
getFeedContactInstancesByCursor,
getFeedGroupInstancesByCursor,
getFeedInstanceContactIdsByRange,
getFeedInstanceGroupIdsByRange,
updateFeedInstanceStatuses,
getDeliveredContactIdsByRange,
getDeliveredMemberIdsByRange,
updateFeedContactInstances,
updateFeedGroupInstances,
deleteFeedInstances,
markFeedInstancesDeleted,
detachFeedInstances,
deleteFeedContactReactions,
deleteFeedGroupReactions,
feedItemMsg,
FeedItemMsg (..),
)
where
import Control.Monad.Except (ExceptT (..), throwError)
import Control.Monad.IO.Class (liftIO)
import Data.Int (Int64)
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as M
import Data.Maybe (fromMaybe)
import Data.Text (Text)
import Data.Time (UTCTime, getCurrentTime)
import Simplex.Chat.Delivery (FeedInstanceSpec (..))
import Simplex.Chat.Messages
import Simplex.Chat.Messages.CIContent
import Simplex.Chat.Store.Shared
import Simplex.Chat.Types
import Simplex.Messaging.Agent.Store.AgentStore (firstRow)
import Simplex.Messaging.Agent.Store.DB (BoolInt (..))
import qualified Simplex.Messaging.Agent.Store.DB as DB
#if defined(dbPostgres)
import Database.PostgreSQL.Simple (Only (..), Query, (:.) (..))
import Database.PostgreSQL.Simple.SqlQQ (sql)
#else
import Database.SQLite.Simple (Only (..), Query, (:.) (..))
import Database.SQLite.Simple.QQ (sql)
#endif
createFeed :: DB.Connection -> User -> ExceptT StoreError IO ()
createFeed db User {userId} =
liftIO (DB.query db "SELECT feed_id FROM feeds WHERE user_id = ? LIMIT 1" $ Only userId) >>= \case
[] -> liftIO $ DB.execute db "INSERT INTO feeds (user_id) VALUES (?)" (Only userId)
Only feedId : _ -> throwError $ SEFeedAlreadyExists feedId
getUserFeedId :: DB.Connection -> User -> ExceptT StoreError IO FeedId
getUserFeedId db User {userId} =
ExceptT . firstRow fromOnly SEUserFeedNotFound $
DB.query db "SELECT feed_id FROM feeds WHERE user_id = ?" (Only userId)
getFeed :: DB.Connection -> User -> FeedId -> ExceptT StoreError IO Feed
getFeed db User {userId} feedId =
ExceptT . firstRow toFeed (SEFeedNotFound feedId) $
DB.query
db
[sql|
SELECT created_at, updated_at, chat_ts, favorite, unread_chat
FROM feeds
WHERE user_id = ? AND feed_id = ?
|]
(userId, feedId)
where
toFeed (createdAt, updatedAt, chatTs, BI favorite, BI unread) =
Feed {feedId, userId, createdAt, updatedAt, chatTs, favorite, unread}
updateFeedUnreadChat :: DB.Connection -> User -> Feed -> Bool -> IO ()
updateFeedUnreadChat db User {userId} Feed {feedId} unreadChat = do
updatedAt <- getCurrentTime
DB.execute db "UPDATE feeds SET unread_chat = ?, updated_at = ? WHERE user_id = ? AND feed_id = ?" (BI unreadChat, updatedAt, userId, feedId)
-- messages are deleted first: chat_item_messages rows cascade with chat items
deleteFeedCIs :: DB.Connection -> User -> Feed -> IO ()
deleteFeedCIs db User {userId} Feed {feedId} = do
DB.execute db "DELETE FROM messages WHERE feed_id = ?" (Only feedId)
DB.execute db "DELETE FROM chat_items WHERE user_id = ? AND feed_id = ?" (userId, feedId)
-- the chats of a bucket are read without their chat tags, which a job does not use
getFeedContactsByCursor :: DB.Connection -> StoreCxt -> User -> Maybe ContactId -> Int -> IO [Contact]
getFeedContactsByCursor db cxt user@User {userId} cursorId_ count = do
currentTs <- getCurrentTime
map (toContact currentTs cxt user [])
<$> DB.query
db
(contactQuery <> " WHERE ct.user_id = ? AND ct.deleted = 0 AND ct.is_user = 0 AND ct.contact_id > ? ORDER BY ct.contact_id ASC LIMIT ?")
(userId, cursorId cursorId_, count)
getFeedCustomerGroupsByCursor :: DB.Connection -> StoreCxt -> User -> Maybe GroupId -> Int -> IO [GroupInfo]
getFeedCustomerGroupsByCursor db cxt User {userId, userContactId} cursorId_ count = do
currentTs <- getCurrentTime
map (toGroupInfo currentTs cxt userContactId [])
<$> DB.query
db
(groupInfoQuery <> " WHERE g.user_id = ? AND mu.contact_id = ? AND g.business_chat = ? AND g.group_id > ? ORDER BY g.group_id ASC LIMIT ?")
(userId, userContactId, BCCustomer, cursorId cursorId_, count)
-- members of the user's customer groups in the group id range, without the user's own membership
getCustomerGroupsMembersByRange :: DB.Connection -> StoreCxt -> User -> GroupId -> GroupId -> IO (Map GroupId [GroupMember])
getCustomerGroupsMembersByRange db cxt user@User {userId, userContactId} fromId toId = do
currentTs <- getCurrentTime
foldMembers . map (toContactMember currentTs cxt user)
<$> DB.query
db
( groupMemberQuery
<> [sql|
JOIN groups g ON g.group_id = m.group_id
WHERE m.user_id = ? AND g.business_chat = ?
AND m.group_id > ? AND m.group_id <= ?
AND (m.contact_id IS NULL OR m.contact_id != ?)
|]
)
(userId, BCCustomer, fromId, toId, userContactId)
where
foldMembers = foldr (\m -> M.insertWith (<>) (memberGroupId m) [m]) M.empty
memberGroupId GroupMember {groupId} = groupId
-- the part of a feed item that is repeated in its instances
data FeedItemMsg = FeedItemMsg
{ feedSharedMsgId :: SharedMsgId,
feedContent :: CIContent 'MDSnd,
feedItemText :: Text,
feedHasLink :: Bool
}
feedItemMsg :: CChatItem 'CTFeed -> Maybe FeedItemMsg
feedItemMsg (CChatItem _ ChatItem {content, meta = CIMeta {itemSharedMsgId, itemText, hasLink}}) = case content of
CISndMsgContent _ ->
(\smId -> FeedItemMsg {feedSharedMsgId = smId, feedContent = content, feedItemText = itemText, feedHasLink = isTrue hasLink})
<$> itemSharedMsgId
_ -> Nothing
instanceSpecCond :: FeedInstanceSpec -> Query
instanceSpecCond = \case
FISLinked -> " AND i.item_feed = 1"
FISAny -> " AND i.item_feed > 0"
FISUndeleted -> " AND i.item_deleted = 0"
getFeedContactInstancesByCursor :: DB.Connection -> StoreCxt -> User -> ChatItemId -> FeedInstanceSpec -> 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))
<$> DB.query
db
( "SELECT i.chat_item_id, "
<> contactQueryFields
<> " "
<> 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 > ?"
<> instanceSpecCond spec
<> " ORDER BY i.contact_id ASC LIMIT ?"
)
(userId, feedItemId, cursorId cursorId_, count)
getFeedGroupInstancesByCursor :: DB.Connection -> StoreCxt -> User -> ChatItemId -> FeedInstanceSpec -> 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))
<$> DB.query
db
( "SELECT i.chat_item_id, "
<> groupInfoQueryFields
<> " "
<> 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 > ?"
<> instanceSpecCond spec
<> " ORDER BY i.group_id ASC LIMIT ?"
)
(userId, userContactId, feedItemId, cursorId cursorId_, count)
-- instances created by an earlier run of the same bucket, by chat
getFeedInstanceContactIdsByRange :: DB.Connection -> User -> ChatItemId -> ContactId -> ContactId -> IO (Map ContactId ChatItemId)
getFeedInstanceContactIdsByRange db user feedItemId = getFeedInstanceIdsByRange_ db user feedItemId "contact_id"
getFeedInstanceGroupIdsByRange :: DB.Connection -> User -> ChatItemId -> GroupId -> GroupId -> IO (Map GroupId ChatItemId)
getFeedInstanceGroupIdsByRange db user feedItemId = getFeedInstanceIdsByRange_ db user feedItemId "group_id"
getFeedInstanceIdsByRange_ :: DB.Connection -> User -> ChatItemId -> Query -> Int64 -> Int64 -> IO (Map Int64 ChatItemId)
getFeedInstanceIdsByRange_ db User {userId} feedItemId chatIdColumn fromId toId =
M.fromList
<$> DB.query
db
( "SELECT " <> chatIdColumn <> ", chat_item_id FROM chat_items"
<> " WHERE user_id = ? AND feed_item_id = ?"
<> " AND " <> chatIdColumn <> " > ? AND " <> chatIdColumn <> " <= ?"
)
(userId, feedItemId, fromId, toId)
updateFeedInstanceStatuses :: DB.Connection -> [(ChatItemId, CIStatus 'MDSnd)] -> IO ()
updateFeedInstanceStatuses db statuses = do
currentTs <- getCurrentTime
DB.executeMany
db
"UPDATE chat_items SET item_status = ?, updated_at = ? WHERE chat_item_id = ?"
(map (\(itemId, status) -> (status, currentTs, itemId)) statuses)
-- a msg_deliveries row exists once the agent accepted the message for the connection
getDeliveredContactIdsByRange :: DB.Connection -> MessageId -> ContactId -> ContactId -> IO [ContactId]
getDeliveredContactIdsByRange db msgId fromId toId =
map fromOnly
<$> DB.query
db
[sql|
SELECT c.contact_id
FROM msg_deliveries d
JOIN connections c ON c.connection_id = d.connection_id
WHERE d.message_id = ? AND c.contact_id > ? AND c.contact_id <= ?
|]
(msgId, fromId, toId)
getDeliveredMemberIdsByRange :: DB.Connection -> MessageId -> GroupId -> GroupId -> IO [GroupMemberId]
getDeliveredMemberIdsByRange db msgId fromId toId =
map fromOnly
<$> DB.query
db
[sql|
SELECT gm.group_member_id
FROM msg_deliveries d
JOIN connections c ON c.connection_id = d.connection_id
JOIN group_members gm ON gm.group_member_id = c.group_member_id
WHERE d.message_id = ? AND gm.group_id > ? AND gm.group_id <= ?
|]
(msgId, fromId, toId)
updateFeedContactInstances :: DB.Connection -> User -> ChatItemId -> ContactId -> ContactId -> FeedItemMsg -> IO ()
updateFeedContactInstances db user feedItemId = updateFeedInstances_ db user feedItemId "contact_id"
updateFeedGroupInstances :: DB.Connection -> User -> ChatItemId -> GroupId -> GroupId -> FeedItemMsg -> IO ()
updateFeedGroupInstances db user feedItemId = updateFeedInstances_ db user feedItemId "group_id"
updateFeedInstances_ :: DB.Connection -> User -> ChatItemId -> Query -> Int64 -> Int64 -> FeedItemMsg -> IO ()
updateFeedInstances_ db User {userId} feedItemId chatIdColumn fromId toId FeedItemMsg {feedContent = content, feedItemText = itemText, feedHasLink = hasLink} = do
currentTs <- getCurrentTime
DB.execute
db
( "UPDATE chat_items SET item_content = ?, item_text = ?, item_edited = 1, has_link = ?, updated_at = ?"
<> " WHERE user_id = ? AND feed_item_id = ? AND item_feed = 1"
<> " AND " <> chatIdColumn <> " > ? AND " <> chatIdColumn <> " <= ?"
)
(content, itemText, BI hasLink, currentTs, userId, feedItemId, fromId, toId)
deleteFeedInstances :: DB.Connection -> [ChatItemId] -> IO ()
deleteFeedInstances db itemIds = do
DB.executeMany db "DELETE FROM chat_item_messages WHERE chat_item_id = ?" (map Only itemIds)
DB.executeMany db "DELETE FROM chat_item_versions WHERE chat_item_id = ?" (map Only itemIds)
DB.executeMany db "DELETE FROM chat_items WHERE chat_item_id = ?" (map Only itemIds)
markFeedInstancesDeleted :: DB.Connection -> [ChatItemId] -> UTCTime -> IO ()
markFeedInstancesDeleted db itemIds deletedTs = do
currentTs <- getCurrentTime
DB.executeMany
db
"UPDATE chat_items SET item_deleted = 1, item_deleted_ts = ?, updated_at = ? WHERE chat_item_id = ?"
(map (deletedTs,currentTs,) itemIds)
detachFeedInstances :: DB.Connection -> [ChatItemId] -> IO ()
detachFeedInstances db itemIds =
DB.executeMany db "UPDATE chat_items SET item_feed = 2 WHERE chat_item_id = ? AND item_feed = 1" (map Only itemIds)
deleteFeedContactReactions :: DB.Connection -> SharedMsgId -> [ContactId] -> IO ()
deleteFeedContactReactions db sharedMsgId contactIds =
DB.executeMany
db
"DELETE FROM chat_item_reactions WHERE contact_id = ? AND shared_msg_id = ?"
(map (,sharedMsgId) contactIds)
-- reactions to the user's own group items are stored with the membership member id
deleteFeedGroupReactions :: DB.Connection -> SharedMsgId -> [(GroupId, MemberId)] -> IO ()
deleteFeedGroupReactions db sharedMsgId groupMemberIds =
DB.executeMany
db
"DELETE FROM chat_item_reactions WHERE group_id = ? AND shared_msg_id = ? AND item_member_id = ?"
(map (\(gId, memId) -> (gId, sharedMsgId, memId)) groupMemberIds)
cursorId :: Maybe Int64 -> Int64
cursorId = fromMaybe 0
src/Simplex/Chat/Store/Files.hs
+30 -9
View File
@@ -73,6 +73,8 @@ module Simplex.Chat.Store.Files
getSndFileTransfer,
getContactFileInfo,
getNoteFolderFileInfo,
getFeedFileInfo,
deleteFeedFiles,
createLocalFile,
getLocalCryptoFile,
updateDirectCIFileStatus,
@@ -185,8 +187,8 @@ createSndFileTransferXFTP db User {userId} contactOrGroup_ (CryptoFile filePath
let xftpSndFile = Just XFTPSndFile {agentSndFileId, privateSndFileDescr = Nothing, agentSndFileDeleted = False, cryptoArgs}
DB.execute
db
"INSERT INTO files (contact_id, group_id, user_id, file_name, file_path, file_crypto_key, file_crypto_nonce, file_size, chunk_size, redirect_file_id, agent_snd_file_id, ci_file_status, protocol, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?)"
(maybe (Nothing, Nothing) contactAndGroupIds contactOrGroup_ :. (userId, fileName, filePath, CF.fileKey <$> cryptoArgs, CF.fileNonce <$> cryptoArgs, fileSize, chunkSize) :. (xftpRedirectFor, agentSndFileId, CIFSSndStored, FPXFTP, currentTs, currentTs))
"INSERT INTO files (contact_id, group_id, feed_id, user_id, file_name, file_path, file_crypto_key, file_crypto_nonce, file_size, chunk_size, redirect_file_id, agent_snd_file_id, ci_file_status, protocol, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?)"
(maybe (Nothing, Nothing, Nothing) contactAndGroupIds contactOrGroup_ :. (userId, fileName, filePath, CF.fileKey <$> cryptoArgs, CF.fileNonce <$> cryptoArgs, fileSize, chunkSize) :. (xftpRedirectFor, agentSndFileId, CIFSSndStored, FPXFTP, currentTs, currentTs))
fileId <- insertedRowId db
pure FileTransferMeta {fileId, xftpSndFile, xftpRedirectFor, fileName, filePath, fileSize, fileInline = Nothing, chunkSize, cancelled = False}
@@ -273,7 +275,7 @@ getXFTPSndFileDBIds db aSndFileId =
DB.query
db
[sql|
SELECT file_id, contact_id, group_id, note_folder_id
SELECT file_id, contact_id, group_id, note_folder_id, feed_id
FROM files
WHERE agent_snd_file_id = ?
|]
@@ -285,19 +287,20 @@ getXFTPRcvFileDBIds db aRcvFileId =
DB.query
db
[sql|
SELECT rf.file_id, f.contact_id, f.group_id, f.note_folder_id
SELECT rf.file_id, f.contact_id, f.group_id, f.note_folder_id, f.feed_id
FROM rcv_files rf
JOIN files f ON f.file_id = rf.file_id
WHERE rf.agent_rcv_file_id = ?
|]
(Only aRcvFileId)
toFileRef :: (FileTransferId, Maybe Int64, Maybe Int64, Maybe Int64) -> Either StoreError (Maybe ChatRef, FileTransferId)
toFileRef :: (FileTransferId, Maybe Int64, Maybe Int64, Maybe Int64, Maybe Int64) -> Either StoreError (Maybe ChatRef, FileTransferId)
toFileRef = \case
(fileId, Just contactId, Nothing, Nothing) -> Right (Just $ ChatRef CTDirect contactId Nothing, fileId)
(fileId, Nothing, Just groupId, Nothing) -> Right (Just $ ChatRef CTGroup groupId Nothing, fileId)
(fileId, Nothing, Nothing, Just folderId) -> Right (Just $ ChatRef CTLocal folderId Nothing, fileId)
(fileId, _, _, _) -> Right (Nothing, fileId)
(fileId, Just contactId, Nothing, Nothing, Nothing) -> Right (Just $ ChatRef CTDirect contactId Nothing, fileId)
(fileId, Nothing, Just groupId, Nothing, Nothing) -> Right (Just $ ChatRef CTGroup groupId Nothing, fileId)
(fileId, Nothing, Nothing, Just folderId, Nothing) -> Right (Just $ ChatRef CTLocal folderId Nothing, fileId)
(fileId, Nothing, Nothing, Nothing, Just feedId) -> Right (Just $ ChatRef CTFeed feedId Nothing, fileId)
(fileId, _, _, _, _) -> Right (Nothing, fileId)
updateFileCancelled :: MsgDirectionI d => DB.Connection -> User -> Int64 -> CIFileStatus d -> IO ()
updateFileCancelled db User {userId} fileId ciFileStatus = do
@@ -972,6 +975,24 @@ getNoteFolderFileInfo db User {userId} NoteFolder {noteFolderId} =
map toFileInfo
<$> DB.query db (fileInfoQuery <> " WHERE i.user_id = ? AND i.note_folder_id = ?") (userId, noteFolderId)
getFeedFileInfo :: DB.Connection -> User -> Feed -> IO [CIFileInfo]
getFeedFileInfo db User {userId} Feed {feedId} =
map toFileInfo
<$> DB.query db (fileInfoQuery <> " WHERE i.user_id = ? AND i.feed_id = ?") (userId, feedId)
deleteFeedFiles :: DB.Connection -> User -> Feed -> IO ()
deleteFeedFiles db User {userId} Feed {feedId} =
DB.execute
db
[sql|
DELETE FROM files
WHERE user_id = ?
AND chat_item_id IN (
SELECT chat_item_id FROM chat_items WHERE user_id = ? AND feed_id = ?
)
|]
(userId, userId, feedId)
getLocalCryptoFile :: DB.Connection -> UserId -> Int64 -> Bool -> ExceptT StoreError IO CryptoFile
getLocalCryptoFile db userId fileId sent =
liftIO (getFileTransferRow_ db userId fileId) >>= \case
src/Simplex/Chat/Store/Groups.hs
+4 -4
View File
@@ -421,7 +421,7 @@ createNewGroup db cxt user@User {userId} groupProfile incognitoProfile useRelays
insertedRowId db
let memberPubKey = C.publicKey . memberPrivKey <$> groupKeys
membership <- createContactMemberInv_ db user groupId Nothing user (MemberIdRole memberId GROwner) GCUserMember GSMemCreator IBUser customUserProfileId memberPubKey currentTs (vr cxt)
let chatSettings = ChatSettings {enableNtfs = MFAll, sendRcpts = Nothing, favorite = False}
let chatSettings = defaultChatSettings
pure
GroupInfo
{ groupId,
@@ -500,7 +500,7 @@ createGroupInvitation db cxt user@User {userId} contact@Contact {contactId, acti
let hostVRange = adjustedMemberVRange (vr cxt) peerChatVRange
GroupMember {groupMemberId} <- createContactMemberInv_ db user groupId Nothing contact fromMember GCHostMember GSMemInvited IBUnknown Nothing Nothing currentTs hostVRange
membership <- createContactMemberInv_ db user groupId (Just groupMemberId) user invitedMember GCUserMember GSMemInvited (IBContact contactId) incognitoProfileId Nothing currentTs (vr cxt)
let chatSettings = ChatSettings {enableNtfs = MFAll, sendRcpts = Nothing, favorite = False}
let chatSettings = defaultChatSettings
pure
( GroupInfo
{ groupId,
@@ -3167,8 +3167,8 @@ deleteOldProbes db createdAtCutoff = do
DB.execute db "DELETE FROM received_probes WHERE created_at <= ?" (Only createdAtCutoff)
updateGroupSettings :: DB.Connection -> User -> Int64 -> ChatSettings -> IO ()
updateGroupSettings db User {userId} groupId ChatSettings {enableNtfs, sendRcpts, favorite} =
DB.execute db "UPDATE groups SET enable_ntfs = ?, send_rcpts = ?, favorite = ? WHERE user_id = ? AND group_id = ?" (enableNtfs, BI <$> sendRcpts, BI favorite, userId, groupId)
updateGroupSettings db User {userId} groupId ChatSettings {enableNtfs, sendRcpts, favorite, dropFeed} =
DB.execute db "UPDATE groups SET enable_ntfs = ?, send_rcpts = ?, favorite = ?, drop_feed = ? WHERE user_id = ? AND group_id = ?" (enableNtfs, BI <$> sendRcpts, BI favorite, BI (isTrue dropFeed), userId, groupId)
updateGroupMemberSettings :: DB.Connection -> User -> GroupId -> GroupMemberId -> GroupMemberSettings -> IO ()
updateGroupMemberSettings db User {userId} gId gMemberId GroupMemberSettings {showMessages} = do
src/Simplex/Chat/Store/Messages.hs
+395 -54
View File
@@ -43,6 +43,16 @@ module Simplex.Chat.Store.Messages
createNewRcvChatItem,
createNewChatItemNoMsg,
createNewChatItem_,
createFeedInstanceItem,
insertChatItemMessage_,
getFeedChat,
getFeedChatItem,
getFeedCIReactions,
getFeedChatItemIdByText,
updateFeedChatItem',
updateFeedChatItemStatus,
markFeedChatItemDeleted,
deleteFeedChatItem,
getChatPreviews,
checkContactHasItems,
getChatContentTypes,
@@ -170,6 +180,7 @@ import Simplex.Chat.Messages
import Simplex.Chat.Messages.CIContent
import Simplex.Chat.Protocol
import Simplex.Chat.Store.Direct
import Simplex.Chat.Store.Feeds
import Simplex.Chat.Store.Groups
import Simplex.Chat.Store.NoteFolders
import Simplex.Chat.Store.Shared
@@ -234,10 +245,12 @@ deleteGroupChatItemsMessages db User {userId} GroupInfo {groupId} = do
DB.execute db "DELETE FROM chat_item_reactions WHERE group_id = ?" (Only groupId)
DB.execute db "DELETE FROM chat_items WHERE user_id = ? AND group_id = ? AND item_content_tag != 'chatBanner'" (userId, groupId)
createNewSndMessage :: MsgEncodingI e => DB.Connection -> TVar ChaChaDRG -> ConnOrGroupId -> ChatMsgEvent e -> Maybe MsgSigning -> (SharedMsgId -> EncodedChatMessage) -> ExceptT StoreError IO SndMessage
createNewSndMessage db gVar connOrGroupId chatMsgEvent msgSigning_ encodeMessage =
createWithRandomId' db gVar $ \sharedMsgId ->
case encodeMessage (SharedMsgId sharedMsgId) of
createNewSndMessage :: MsgEncodingI e => DB.Connection -> TVar ChaChaDRG -> ConnOrGroupId -> Maybe SharedMsgId -> ChatMsgEvent e -> Maybe MsgSigning -> (SharedMsgId -> EncodedChatMessage) -> ExceptT StoreError IO SndMessage
createNewSndMessage db gVar connOrGroupId sharedMsgId_ chatMsgEvent msgSigning_ encodeMessage = case sharedMsgId_ of
Just (SharedMsgId sharedMsgId) -> ExceptT $ insertMessage sharedMsgId
Nothing -> createWithRandomId' db gVar insertMessage
where
insertMessage sharedMsgId = case encodeMessage (SharedMsgId sharedMsgId) of
ECMLarge -> pure $ Left SELargeMsg
ECMEncoded msgBody -> do
let signedMsg_ = (`signChatMsgBody` msgBody) <$> msgSigning_
@@ -246,18 +259,18 @@ createNewSndMessage db gVar connOrGroupId chatMsgEvent msgSigning_ encodeMessage
db
[sql|
INSERT INTO messages (
msg_sent, chat_msg_event, msg_body, msg_chat_binding, msg_signatures, connection_id, group_id,
msg_sent, chat_msg_event, msg_body, msg_chat_binding, msg_signatures, connection_id, group_id, feed_id,
shared_msg_id, shared_msg_id_user, created_at, updated_at
) VALUES (?,?,?,?,?,?,?,?,?,?,?)
) VALUES (?,?,?,?,?,?,?,?,?,?,?,?)
|]
((MDSnd, toCMEventTag chatMsgEvent, DB.Binary msgBody, (\SignedMsg {chatBinding} -> chatBinding) <$> signedMsg_, DB.Binary . smpEncode . signatures <$> signedMsg_, connId_, groupId_)
((MDSnd, toCMEventTag chatMsgEvent, DB.Binary msgBody, (\SignedMsg {chatBinding} -> chatBinding) <$> signedMsg_, DB.Binary . smpEncode . signatures <$> signedMsg_, connId_, groupId_, feedId_)
:. (DB.Binary sharedMsgId, Just (BI True), createdAt, createdAt))
msgId <- insertedRowId db
pure $ Right SndMessage {msgId, sharedMsgId = SharedMsgId sharedMsgId, msgBody, signedMsg_}
where
(connId_, groupId_) = case connOrGroupId of
ConnectionId connId -> (Just connId, Nothing)
GroupId groupId -> (Nothing, Just groupId)
(connId_, groupId_, feedId_) = case connOrGroupId of
ConnectionId connId -> (Just connId, Nothing, Nothing)
GroupId groupId -> (Nothing, Just groupId, Nothing)
FeedId feedId -> (Nothing, Nothing, Just feedId)
createSndMsgDelivery :: DB.Connection -> SndMsgDelivery -> MessageId -> IO Int64
createSndMsgDelivery db SndMsgDelivery {connId, agentMsgId} messageId = do
@@ -315,6 +328,8 @@ createNewRcvMessage db connOrGroupId NewRcvMessage {chatMsgEvent, verifiedMsg, b
throwError $ SEDuplicateGroupMessage groupId sharedMsgId duplAuthorId duplFwdMemberId
Nothing -> liftIO $ insertRcvMsg Nothing $ Just groupId
Nothing -> liftIO $ insertRcvMsg Nothing $ Just groupId
-- received messages arrive on a connection, feed messages are only sent
FeedId _ -> throwError $ SEInternalError "received message with feed entity"
where
duplicateGroupMsgMemberIds :: Int64 -> SharedMsgId -> IO (Maybe (Maybe GroupMemberId, Maybe GroupMemberId))
duplicateGroupMsgMemberIds groupId sharedMsgId =
@@ -524,6 +539,12 @@ updateChatTsStats db cxt user@User {userId} chatDirection chatTs chatStats_ = ca
"UPDATE note_folders SET chat_ts = ? WHERE user_id = ? AND note_folder_id = ?"
(chatTs, userId, noteFolderId)
pure $ LocalChat nf {chatTs = chatTs}
FeedChat feed@Feed {feedId} -> do
DB.execute
db
"UPDATE feeds SET chat_ts = ? WHERE user_id = ? AND feed_id = ?"
(chatTs, userId, feedId)
pure $ FeedChat feed {chatTs = chatTs}
cInfo -> pure cInfo
setSupportChatTs :: DB.Connection -> GroupMemberId -> UTCTime -> IO ()
@@ -547,7 +568,7 @@ setSupportChatMemberAttention db cxt user g m memberAttention = do
createNewSndChatItem :: DB.Connection -> User -> ChatDirection c 'MDSnd -> ShowGroupAsSender -> SndMessage -> CIContent 'MDSnd -> Maybe (CIQuote c) -> Maybe CIForwardedFrom -> Maybe CITimed -> Bool -> Bool -> UTCTime -> IO ChatItemId
createNewSndChatItem db user chatDirection showGroupAsSender SndMessage {msgId, sharedMsgId, signedMsg_} ciContent quotedItem itemForwarded timed live hasLink createdAt =
createNewChatItem_ db user chatDirection showGroupAsSender createdByMsgId (Just sharedMsgId) ciContent quoteRow itemForwarded timed live False hasLink createdAt Nothing (toMsgVerified (signMessagesRequired chatDirection) (MSSVerified <$ signedMsg_)) signedMsg_ Nothing createdAt
createNewChatItem_ db user chatDirection showGroupAsSender createdByMsgId (Just sharedMsgId) ciContent quoteRow itemForwarded timed live False hasLink createdAt Nothing (toMsgVerified (signMessagesRequired chatDirection) (MSSVerified <$ signedMsg_)) signedMsg_ Nothing Nothing Nothing createdAt
where
createdByMsgId = if msgId == 0 then Nothing else Just msgId
quoteRow :: NewQuoteRow
@@ -564,10 +585,11 @@ createNewSndChatItem db user chatDirection showGroupAsSender SndMessage {msgId,
createNewRcvChatItem :: ChatTypeQuotable c => DB.Connection -> User -> ChatDirection c 'MDRcv -> RcvMessage -> Maybe SharedMsgId -> CIContent 'MDRcv -> Maybe CIForwardedFrom -> Maybe CITimed -> Bool -> Bool -> Bool -> UTCTime -> UTCTime -> IO (ChatItemId, Maybe (CIQuote c))
createNewRcvChatItem db user chatDirection RcvMessage {msgId, chatMsgEvent, msgSigned, signedMsg_, signedByGMId_, forwardedByMember} sharedMsgId_ ciContent itemForwarded timed live userMention hasLink itemTs createdAt = do
let showAsGroup = case chatDirection of CDChannelRcv {} -> True; _ -> False
ciId <- createNewChatItem_ db user chatDirection showAsGroup (Just msgId) sharedMsgId_ ciContent quoteRow itemForwarded timed live userMention hasLink itemTs forwardedByMember (toMsgVerified (signMessagesRequired chatDirection) msgSigned) signedMsg_ signedByGMId_ createdAt
ciId <- createNewChatItem_ db user chatDirection showAsGroup (Just msgId) sharedMsgId_ ciContent quoteRow itemForwarded timed live userMention hasLink itemTs forwardedByMember (toMsgVerified (signMessagesRequired chatDirection) msgSigned) signedMsg_ signedByGMId_ itemFeed Nothing createdAt
quotedItem <- mapM (getChatItemQuote_ db user chatDirection) quotedMsg
pure (ciId, quotedItem)
where
itemFeed = if cmFeed chatMsgEvent then Just CIFLinked else Nothing
quotedMsg = cmToQuotedMsg chatMsgEvent
quoteRow :: NewQuoteRow
quoteRow = case quotedMsg of
@@ -582,30 +604,40 @@ createNewRcvChatItem db user chatDirection RcvMessage {msgId, chatMsgEvent, msgS
createNewChatItemNoMsg :: forall c d. MsgDirectionI d => DB.Connection -> User -> ChatDirection c d -> ShowGroupAsSender -> CIContent d -> Maybe SharedMsgId -> Bool -> Maybe MsgVerified -> UTCTime -> UTCTime -> IO ChatItemId
createNewChatItemNoMsg db user chatDirection showGroupAsSender ciContent sharedMsgId_ hasLink msgVerified itemTs =
createNewChatItem_ db user chatDirection showGroupAsSender Nothing sharedMsgId_ ciContent quoteRow Nothing Nothing False False hasLink itemTs Nothing msgVerified Nothing Nothing
createNewChatItem_ db user chatDirection showGroupAsSender Nothing sharedMsgId_ ciContent quoteRow Nothing Nothing False False hasLink itemTs Nothing msgVerified Nothing Nothing Nothing Nothing
where
quoteRow :: NewQuoteRow
quoteRow = (Nothing, Nothing, Nothing, Nothing, Nothing)
createNewChatItem_ :: forall c d. MsgDirectionI d => DB.Connection -> User -> ChatDirection c d -> ShowGroupAsSender -> Maybe MessageId -> Maybe SharedMsgId -> CIContent d -> NewQuoteRow -> Maybe CIForwardedFrom -> Maybe CITimed -> Bool -> Bool -> Bool -> UTCTime -> Maybe GroupMemberId -> Maybe MsgVerified -> Maybe SignedMsg -> Maybe GroupMemberId -> UTCTime -> IO ChatItemId
createNewChatItem_ db User {userId} chatDirection showGroupAsSender msgId_ sharedMsgId ciContent quoteRow itemForwarded timed live userMention hasLink itemTs forwardedByMember msgVerified signedMsg_ signedByGMId_ createdAt = do
-- an instance of a feed item in a contact or group chat: no message id, the feed item's shared id
createFeedInstanceItem :: DB.Connection -> User -> ChatDirection c 'MDSnd -> SharedMsgId -> CIContent 'MDSnd -> ChatItemId -> Maybe CITimed -> Bool -> UTCTime -> IO ChatItemId
createFeedInstanceItem db user chatDirection sharedMsgId ciContent feedItemId timed hasLink createdAt =
createNewChatItem_ db user chatDirection False Nothing (Just sharedMsgId) ciContent quoteRow Nothing timed False False hasLink createdAt Nothing Nothing Nothing Nothing (Just CIFLinked) (Just feedItemId) createdAt
where
quoteRow :: NewQuoteRow
quoteRow = (Nothing, Nothing, Nothing, Nothing, Nothing)
createNewChatItem_ :: forall c d. MsgDirectionI d => DB.Connection -> User -> ChatDirection c d -> ShowGroupAsSender -> Maybe MessageId -> Maybe SharedMsgId -> CIContent d -> NewQuoteRow -> Maybe CIForwardedFrom -> Maybe CITimed -> Bool -> Bool -> Bool -> UTCTime -> Maybe GroupMemberId -> Maybe MsgVerified -> Maybe SignedMsg -> Maybe GroupMemberId -> Maybe CIFeed -> Maybe ChatItemId -> UTCTime -> IO ChatItemId
createNewChatItem_ db User {userId} chatDirection showGroupAsSender msgId_ sharedMsgId ciContent quoteRow itemForwarded timed live userMention hasLink itemTs forwardedByMember msgVerified signedMsg_ signedByGMId_ itemFeed feedItemId createdAt = do
DB.execute
db
[sql|
INSERT INTO chat_items (
-- user and IDs
user_id, created_by_msg_id, contact_id, group_id, group_member_id, note_folder_id, group_scope_tag, group_scope_group_member_id,
user_id, created_by_msg_id, contact_id, group_id, group_member_id, note_folder_id, feed_id, group_scope_tag, group_scope_group_member_id,
-- meta
item_sent, item_ts, item_content, item_content_tag, item_text, item_status, msg_content_tag, shared_msg_id,
forwarded_by_group_member_id, include_in_history, created_at, updated_at, item_live, user_mention, has_link, item_viewed, show_group_as_sender, msg_signed, item_msg_body, item_chat_binding, item_signatures, item_signed_by_group_member_id, timed_ttl, timed_delete_at,
-- feed
item_feed, feed_item_id,
-- quote
quoted_shared_msg_id, quoted_sent_at, quoted_content, quoted_sent, quoted_member_id,
-- forwarded from
fwd_from_tag, fwd_from_chat_name, fwd_from_msg_dir, fwd_from_contact_id, fwd_from_group_id, fwd_from_chat_item_id,
fwd_from_group_type, fwd_from_group_link, fwd_from_public_group_id, fwd_from_member_id, fwd_from_shared_msg_id
) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?)
) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?)
|]
((userId, msgId_) :. idsRow :. groupScopeRow :. itemRow :. quoteRow' :. forwardedFromRow)
((userId, msgId_) :. idsRow :. groupScopeRow :. itemRow :. (ciFeedInt itemFeed, feedItemId) :. quoteRow' :. forwardedFromRow)
ciId <- insertedRowId db
forM_ msgId_ $ \msgId -> insertChatItemMessage_ db ciId msgId createdAt
pure ciId
@@ -619,15 +651,16 @@ createNewChatItem_ db User {userId} chatDirection showGroupAsSender msgId_ share
(Just (DB.Binary signedBody), Just chatBinding, Just (DB.Binary (smpEncode signatures)), signedByGMId_)
_ -> (Nothing, Nothing, Nothing, Nothing)
quoteRow' = let (a, b, c, d, e) = quoteRow in (a, b, c, BI <$> d, e)
idsRow :: (Maybe ContactId, Maybe GroupId, Maybe GroupMemberId, Maybe NoteFolderId)
idsRow :: (Maybe ContactId, Maybe GroupId, Maybe GroupMemberId, Maybe NoteFolderId, Maybe FeedId)
idsRow = case chatDirection of
CDDirectRcv Contact {contactId} -> (Just contactId, Nothing, Nothing, Nothing)
CDDirectSnd Contact {contactId} -> (Just contactId, Nothing, Nothing, Nothing)
CDGroupRcv GroupInfo {groupId} _ GroupMember {groupMemberId} -> (Nothing, Just groupId, Just groupMemberId, Nothing)
CDGroupSnd GroupInfo {groupId} _ -> (Nothing, Just groupId, Nothing, Nothing)
CDChannelRcv GroupInfo {groupId} _ -> (Nothing, Just groupId, Nothing, Nothing)
CDLocalRcv NoteFolder {noteFolderId} -> (Nothing, Nothing, Nothing, Just noteFolderId)
CDLocalSnd NoteFolder {noteFolderId} -> (Nothing, Nothing, Nothing, Just noteFolderId)
CDDirectRcv Contact {contactId} -> (Just contactId, Nothing, Nothing, Nothing, Nothing)
CDDirectSnd Contact {contactId} -> (Just contactId, Nothing, Nothing, Nothing, Nothing)
CDGroupRcv GroupInfo {groupId} _ GroupMember {groupMemberId} -> (Nothing, Just groupId, Just groupMemberId, Nothing, Nothing)
CDGroupSnd GroupInfo {groupId} _ -> (Nothing, Just groupId, Nothing, Nothing, Nothing)
CDChannelRcv GroupInfo {groupId} _ -> (Nothing, Just groupId, Nothing, Nothing, Nothing)
CDLocalRcv NoteFolder {noteFolderId} -> (Nothing, Nothing, Nothing, Just noteFolderId, Nothing)
CDLocalSnd NoteFolder {noteFolderId} -> (Nothing, Nothing, Nothing, Just noteFolderId, Nothing)
CDFeedSnd Feed {feedId} -> (Nothing, Nothing, Nothing, Nothing, Just feedId)
groupScope :: Maybe (Maybe GroupChatScopeInfo)
groupScope = case chatDirection of
CDGroupRcv _ scope _ -> Just scope
@@ -748,9 +781,10 @@ getChatPreviews db cxt user withPCC pagination query = do
directChats <- findDirectChatPreviews_ db user pagination query
groupChats <- findGroupChatPreviews_ db user pagination query
localChats <- findLocalChatPreviews_ db user pagination query
feedChats <- findFeedChatPreviews_ db user pagination query
cReqChats <- getContactRequestChatPreviews_ db user pagination query
connChats <- if withPCC then getContactConnectionChatPreviews_ db user pagination query else pure []
let refs = sortTake $ concat [directChats, groupChats, localChats, cReqChats, connChats]
let refs = sortTake $ concat [directChats, groupChats, localChats, feedChats, cReqChats, connChats]
mapM (runExceptT <$> getChatPreview) refs
where
ts :: AChatPreviewData -> UTCTime
@@ -758,6 +792,7 @@ getChatPreviews db cxt user withPCC pagination query = do
(DirectChatPD t _ _ _) -> t
(GroupChatPD t _ _ _) -> t
(LocalChatPD t _ _ _) -> t
(FeedChatPD t _ _ _) -> t
(ContactRequestPD t _) -> t
(ContactConnectionPD t _) -> t
sortTake = case pagination of
@@ -769,6 +804,7 @@ getChatPreviews db cxt user withPCC pagination query = do
SCTDirect -> getDirectChatPreview_ db cxt user cpd
SCTGroup -> getGroupChatPreview_ db cxt user cpd
SCTLocal -> getLocalChatPreview_ db user cpd
SCTFeed -> getFeedChatPreview_ db user cpd
SCTContactRequest -> let (ContactRequestPD _ chat) = cpd in pure chat
SCTContactConnection -> let (ContactConnectionPD _ chat) = cpd in pure chat
@@ -776,6 +812,7 @@ data ChatPreviewData (c :: ChatType) where
DirectChatPD :: UTCTime -> ContactId -> Maybe ChatItemId -> ChatStats -> ChatPreviewData 'CTDirect
GroupChatPD :: UTCTime -> GroupId -> Maybe ChatItemId -> ChatStats -> ChatPreviewData 'CTGroup
LocalChatPD :: UTCTime -> NoteFolderId -> Maybe ChatItemId -> ChatStats -> ChatPreviewData 'CTLocal
FeedChatPD :: UTCTime -> FeedId -> Maybe ChatItemId -> ChatStats -> ChatPreviewData 'CTFeed
ContactRequestPD :: UTCTime -> AChat -> ChatPreviewData 'CTContactRequest
ContactConnectionPD :: UTCTime -> AChat -> ChatPreviewData 'CTContactConnection
@@ -1091,9 +1128,58 @@ getLocalChatPreview_ db user (LocalChatPD _ noteFolderId lastItemId_ stats) = do
Nothing -> pure []
pure $ AChat SCTLocal (Chat (LocalChat nf) lastItem stats)
findFeedChatPreviews_ :: DB.Connection -> User -> PaginationByTime -> ChatListQuery -> IO [AChatPreviewData]
findFeedChatPreviews_ db User {userId} pagination clq =
map toPreview <$> getPreviews
where
toPreview :: (FeedId, UTCTime, Maybe ChatItemId) :. ChatStatsRow -> AChatPreviewData
toPreview ((feedId, ts, lastItemId_) :. statsRow) =
ACPD SCTFeed $ FeedChatPD ts feedId lastItemId_ (toChatStats statsRow)
baseQuery =
[sql|
SELECT
f.feed_id,
f.chat_ts,
(
SELECT chat_item_id
FROM chat_items ci
WHERE ci.user_id = ? AND ci.feed_id = f.feed_id
ORDER BY ci.created_at DESC
LIMIT 1
) AS chat_item_id,
0, 0, f.unread_chat
FROM feeds f
|]
getPreviews = case clq of
CLQFilters {favorite = False, unread = False} ->
queryWithPagination (baseQuery <> " WHERE f.user_id = ?") (Only userId :. Only userId)
CLQFilters {favorite = True, unread = False} ->
queryWithPagination (baseQuery <> " WHERE f.user_id = ? AND f.favorite = 1") (Only userId :. Only userId)
CLQFilters {favorite = False, unread = True} ->
queryWithPagination (baseQuery <> " WHERE f.user_id = ? AND f.unread_chat = 1") (Only userId :. Only userId)
CLQFilters {favorite = True, unread = True} ->
queryWithPagination (baseQuery <> " WHERE f.user_id = ? AND (f.favorite = 1 OR f.unread_chat = 1)") (Only userId :. Only userId)
CLQSearch {} -> pure []
queryWithPagination :: ToRow p => Query -> p -> IO [(FeedId, UTCTime, Maybe ChatItemId) :. ChatStatsRow]
queryWithPagination query params = case pagination of
PTLast count -> DB.query db (query <> " ORDER BY f.chat_ts DESC LIMIT ?") (params :. Only count)
PTAfter ts count -> DB.query db (query <> " AND f.chat_ts > ? ORDER BY f.chat_ts ASC LIMIT ?") (params :. (ts, count))
PTBefore ts count -> DB.query db (query <> " AND f.chat_ts < ? ORDER BY f.chat_ts DESC LIMIT ?") (params :. (ts, count))
getFeedChatPreview_ :: DB.Connection -> User -> ChatPreviewData 'CTFeed -> ExceptT StoreError IO AChat
getFeedChatPreview_ db user (FeedChatPD _ feedId lastItemId_ stats) = do
feed <- getFeed db user feedId
ts <- liftIO getCurrentTime
lastItem <- case lastItemId_ of
Just lastItemId -> do
previewItem <- liftIO $ safeGetFeedItem db user feed ts lastItemId
pure [previewItem]
Nothing -> pure []
pure $ AChat SCTFeed (Chat (FeedChat feed) lastItem stats)
-- this function can be changed so it never fails, not only avoid failure on invalid json
toLocalChatItem :: UTCTime -> ChatItemRow -> Either StoreError (CChatItem 'CTLocal)
toLocalChatItem currentTs ((itemId, itemTs, AMsgDirection msgDir, itemContentText, itemText, itemStatus, sentViaProxy, sharedMsgId) :. (itemDeleted, deletedTs, itemEdited, createdAt, updatedAt) :. forwardedFromRow :. (timedTTL, timedDeleteAt, itemLive, BI userMention, BI hasLink, msgSigned) :. (fileId_, fileName_, fileSize_, filePath, fileKey, fileNonce, fileStatus_, fileProtocol_, fileExpires)) =
toLocalChatItem currentTs ((itemId, itemTs, AMsgDirection msgDir, itemContentText, itemText, itemStatus, sentViaProxy, sharedMsgId) :. (itemDeleted, deletedTs, itemEdited, createdAt, updatedAt) :. forwardedFromRow :. (timedTTL, timedDeleteAt, itemLive, BI userMention, BI hasLink, msgSigned, itemFeed) :. (fileId_, fileName_, fileSize_, filePath, fileKey, fileNonce, fileStatus_, fileProtocol_, fileExpires)) =
chatItem $ fromRight invalid $ dbParseACIContent itemContentText
where
invalid = ACIContent msgDir $ CIInvalidJSON itemContentText
@@ -1126,7 +1212,7 @@ toLocalChatItem currentTs ((itemId, itemTs, AMsgDirection msgDir, itemContentTex
_ -> Just (CIDeleted @'CTLocal deletedTs)
itemEdited' = maybe False unBI itemEdited
itemForwarded = toCIForwardedFrom forwardedFromRow
in mkCIMeta itemId content itemText status (unBI <$> sentViaProxy) sharedMsgId itemForwarded itemDeleted' itemEdited' ciTimed (unBI <$> itemLive) userMention hasLink currentTs itemTs Nothing False msgSigned createdAt updatedAt
in mkCIMeta itemId content itemText status (unBI <$> sentViaProxy) sharedMsgId itemForwarded itemDeleted' itemEdited' ciTimed (unBI <$> itemLive) userMention hasLink currentTs itemTs Nothing False msgSigned (toCIFeed itemFeed) createdAt updatedAt
ciTimed :: Maybe CITimed
ciTimed = timedTTL >>= \ttl -> Just CITimed {ttl, deleteAt = timedDeleteAt}
@@ -1571,6 +1657,12 @@ getChatItemIDs db User {userId} cInfo contentFilter range count search = case cI
Just mcTag -> idsQuery (nfCond <> " AND msg_content_tag = ? ") (userId, noteFolderId, mcTag) "created_at"
where
nfCond = " user_id = ? AND note_folder_id = ? "
FeedChat Feed {feedId} -> liftIO $ case contentFilter of
Nothing -> idsQuery feedCond (userId, feedId) "created_at"
Just MCLink_ -> idsQuery (feedCond <> " AND has_link = 1 ") (userId, feedId) "created_at"
Just mcTag -> idsQuery (feedCond <> " AND msg_content_tag = ? ") (userId, feedId, mcTag) "created_at"
where
feedCond = " user_id = ? AND feed_id = ? "
_ -> throwError $ SEInternalError "unsupported chat type"
where
baseQuery = " SELECT chat_item_id FROM chat_items WHERE "
@@ -2007,20 +2099,22 @@ getLocalNavInfo_ db User {userId} NoteFolder {noteFolderId} afterCI = do
)
toChatItemRef ::
(ChatItemId, Maybe ContactId, Maybe GroupId, Maybe GroupChatScopeTag, Maybe GroupMemberId, Maybe NoteFolderId) ->
(ChatItemId, Maybe ContactId, Maybe GroupId, Maybe GroupChatScopeTag, Maybe GroupMemberId, Maybe NoteFolderId, Maybe FeedId) ->
Either StoreError (ChatRef, ChatItemId)
toChatItemRef = \case
(itemId, Just contactId, Nothing, Nothing, Nothing, Nothing) ->
(itemId, Just contactId, Nothing, Nothing, Nothing, Nothing, Nothing) ->
Right (ChatRef CTDirect contactId Nothing, itemId)
(itemId, Nothing, Just groupId, Nothing, Nothing, Nothing) ->
(itemId, Nothing, Just groupId, Nothing, Nothing, Nothing, Nothing) ->
Right (ChatRef CTGroup groupId Nothing, itemId)
(itemId, Nothing, Just groupId, Just GCSTMemberSupport_, Nothing, Nothing) ->
(itemId, Nothing, Just groupId, Just GCSTMemberSupport_, Nothing, Nothing, Nothing) ->
Right (ChatRef CTGroup groupId (Just (GCSMemberSupport Nothing)), itemId)
(itemId, Nothing, Just groupId, Just GCSTMemberSupport_, Just scopeGMId, Nothing) ->
(itemId, Nothing, Just groupId, Just GCSTMemberSupport_, Just scopeGMId, Nothing, Nothing) ->
Right (ChatRef CTGroup groupId (Just (GCSMemberSupport $ Just scopeGMId)), itemId)
(itemId, Nothing, Nothing, Nothing, Nothing, Just folderId) ->
(itemId, Nothing, Nothing, Nothing, Nothing, Just folderId, Nothing) ->
Right (ChatRef CTLocal folderId Nothing, itemId)
(itemId, _, _, _, _, _) ->
(itemId, Nothing, Nothing, Nothing, Nothing, Nothing, Just feedId) ->
Right (ChatRef CTFeed feedId Nothing, itemId)
(itemId, _, _, _, _, _, _) ->
Left $ SEBadChatItem itemId Nothing
updateDirectChatItemsRead :: DB.Connection -> User -> ContactId -> IO ()
@@ -2278,7 +2372,7 @@ updateLocalChatItemsRead db User {userId} noteFolderId = do
type MaybeCIFIleRow = (Maybe Int64, Maybe String, Maybe Integer, Maybe FilePath, Maybe C.SbKey, Maybe C.CbNonce, Maybe ACIFileStatus, Maybe FileProtocol, Maybe UTCTime)
type ChatItemModeRow = (Maybe Int, Maybe UTCTime, Maybe BoolInt, BoolInt, BoolInt, Maybe MsgVerified)
type ChatItemModeRow = (Maybe Int, Maybe UTCTime, Maybe BoolInt, BoolInt, BoolInt, Maybe MsgVerified, Int)
type ChatItemForwardedFromRow = (Maybe CIForwardedFromTag, Maybe Text, Maybe MsgDirection, Maybe Int64, Maybe Int64, Maybe Int64) :. ChatItemForwardedLinkRow
@@ -2304,7 +2398,7 @@ toQuote (quotedItemId, quotedSharedMsgId, quotedSentAt, quotedMsgContent, _) dir
-- this function can be changed so it never fails, not only avoid failure on invalid json
toDirectChatItem :: UTCTime -> ChatItemRow :. QuoteRow -> Either StoreError (CChatItem 'CTDirect)
toDirectChatItem currentTs (((itemId, itemTs, AMsgDirection msgDir, itemContentText, itemText, itemStatus, sentViaProxy, sharedMsgId) :. (itemDeleted, deletedTs, itemEdited, createdAt, updatedAt) :. forwardedFromRow :. (timedTTL, timedDeleteAt, itemLive, BI userMention, BI hasLink, msgSigned) :. (fileId_, fileName_, fileSize_, filePath, fileKey, fileNonce, fileStatus_, fileProtocol_, fileExpires)) :. quoteRow) =
toDirectChatItem currentTs (((itemId, itemTs, AMsgDirection msgDir, itemContentText, itemText, itemStatus, sentViaProxy, sharedMsgId) :. (itemDeleted, deletedTs, itemEdited, createdAt, updatedAt) :. forwardedFromRow :. (timedTTL, timedDeleteAt, itemLive, BI userMention, BI hasLink, msgSigned, itemFeed) :. (fileId_, fileName_, fileSize_, filePath, fileKey, fileNonce, fileStatus_, fileProtocol_, fileExpires)) :. quoteRow) =
chatItem $ fromRight invalid $ dbParseACIContent itemContentText
where
invalid = ACIContent msgDir $ CIInvalidJSON itemContentText
@@ -2337,7 +2431,7 @@ toDirectChatItem currentTs (((itemId, itemTs, AMsgDirection msgDir, itemContentT
_ -> Just (CIDeleted @'CTDirect deletedTs)
itemEdited' = maybe False unBI itemEdited
itemForwarded = toCIForwardedFrom forwardedFromRow
in mkCIMeta itemId content itemText status (unBI <$> sentViaProxy) sharedMsgId itemForwarded itemDeleted' itemEdited' ciTimed (unBI <$> itemLive) userMention hasLink currentTs itemTs Nothing False msgSigned createdAt updatedAt
in mkCIMeta itemId content itemText status (unBI <$> sentViaProxy) sharedMsgId itemForwarded itemDeleted' itemEdited' ciTimed (unBI <$> itemLive) userMention hasLink currentTs itemTs Nothing False msgSigned (toCIFeed itemFeed) createdAt updatedAt
ciTimed :: Maybe CITimed
ciTimed = timedTTL >>= \ttl -> Just CITimed {ttl, deleteAt = timedDeleteAt}
@@ -2378,7 +2472,7 @@ toGroupChatItem
( ( (itemId, itemTs, AMsgDirection msgDir, itemContentText, itemText, itemStatus, sentViaProxy, sharedMsgId)
:. (itemDeleted, deletedTs, itemEdited, createdAt, updatedAt)
:. forwardedFromRow
:. (timedTTL, timedDeleteAt, itemLive, BI userMention, BI hasLink, msgSigned)
:. (timedTTL, timedDeleteAt, itemLive, BI userMention, BI hasLink, msgSigned, itemFeed)
:. (fileId_, fileName_, fileSize_, filePath, fileKey, fileNonce, fileStatus_, fileProtocol_, fileExpires)
)
:. (forwardedByMember, BI showGroupAsSender)
@@ -2429,7 +2523,7 @@ toGroupChatItem
_ -> Just (maybe (CIDeleted @'CTGroup deletedTs) (CIModerated deletedTs) deletedByGroupMember_)
itemEdited' = maybe False unBI itemEdited
itemForwarded = toCIForwardedFrom forwardedFromRow
in mkCIMeta itemId content itemText status (unBI <$> sentViaProxy) sharedMsgId itemForwarded itemDeleted' itemEdited' ciTimed (unBI <$> itemLive) userMention hasLink currentTs itemTs forwardedByMember showGroupAsSender msgSigned createdAt updatedAt
in mkCIMeta itemId content itemText status (unBI <$> sentViaProxy) sharedMsgId itemForwarded itemDeleted' itemEdited' ciTimed (unBI <$> itemLive) userMention hasLink currentTs itemTs forwardedByMember showGroupAsSender msgSigned (toCIFeed itemFeed) createdAt updatedAt
ciTimed :: Maybe CITimed
ciTimed = timedTTL >>= \ttl -> Just CITimed {ttl, deleteAt = timedDeleteAt}
@@ -2457,7 +2551,7 @@ getAllChatItems db cxt user@User {userId} pagination search_ = do
<$> DB.query
db
[sql|
SELECT chat_item_id, contact_id, group_id, group_scope_tag, group_scope_group_member_id, note_folder_id
SELECT chat_item_id, contact_id, group_id, group_scope_tag, group_scope_group_member_id, note_folder_id, feed_id
FROM chat_items
WHERE user_id = ? AND LOWER(item_text) LIKE '%' || LOWER(?) || '%'
ORDER BY item_ts DESC, chat_item_id DESC
@@ -2468,7 +2562,7 @@ getAllChatItems db cxt user@User {userId} pagination search_ = do
DB.query
db
[sql|
SELECT chat_item_id, contact_id, group_id, group_scope_tag, group_scope_group_member_id, note_folder_id
SELECT chat_item_id, contact_id, group_id, group_scope_tag, group_scope_group_member_id, note_folder_id, feed_id
FROM chat_items
WHERE user_id = ? AND LOWER(item_text) LIKE '%' || LOWER(?) || '%'
AND (item_ts > ? OR (item_ts = ? AND chat_item_id > ?))
@@ -2481,7 +2575,7 @@ getAllChatItems db cxt user@User {userId} pagination search_ = do
<$> DB.query
db
[sql|
SELECT chat_item_id, contact_id, group_id, group_scope_tag, group_scope_group_member_id, note_folder_id
SELECT chat_item_id, contact_id, group_id, group_scope_tag, group_scope_group_member_id, note_folder_id, feed_id
FROM chat_items
WHERE user_id = ? AND LOWER(item_text) LIKE '%' || LOWER(?) || '%'
AND (item_ts < ? OR (item_ts = ? AND chat_item_id < ?))
@@ -2493,7 +2587,7 @@ getAllChatItems db cxt user@User {userId} pagination search_ = do
DB.query
db
[sql|
SELECT chat_item_id, contact_id, group_id, group_scope_tag, group_scope_group_member_id, note_folder_id
SELECT chat_item_id, contact_id, group_id, group_scope_tag, group_scope_group_member_id, note_folder_id, feed_id
FROM chat_items
WHERE chat_item_id = ?
|]
@@ -2514,6 +2608,9 @@ getAllChatItems db cxt user@User {userId} pagination search_ = do
|]
(userId, CISRcvNew)
-- The second query resolves a feed message delivery to the instance of the
-- broadcast in the chat of the delivery's connection: a feed message is linked
-- to the feed item, not to the instances.
getChatItemIdsByAgentMsgId :: DB.Connection -> Int64 -> AgentMsgId -> IO [ChatItemId]
getChatItemIdsByAgentMsgId db connId msgId =
map fromOnly
@@ -2527,8 +2624,18 @@ getChatItemIdsByAgentMsgId db connId msgId =
FROM msg_deliveries
WHERE connection_id = ? AND agent_msg_id = ?
)
UNION
SELECT i.chat_item_id
FROM msg_deliveries d
JOIN chat_item_messages cim ON cim.message_id = d.message_id
JOIN connections c ON c.connection_id = d.connection_id
LEFT JOIN group_members gm ON gm.group_member_id = c.group_member_id
JOIN chat_items i ON i.feed_item_id = cim.chat_item_id
AND ((c.contact_id IS NOT NULL AND i.contact_id = c.contact_id)
OR (gm.group_id IS NOT NULL AND i.group_id = gm.group_id))
WHERE d.connection_id = ? AND d.agent_msg_id = ?
|]
(connId, msgId)
(connId, msgId, connId, msgId)
updateDirectChatItemStatus :: forall d. MsgDirectionI d => DB.Connection -> User -> Contact -> ChatItemId -> CIStatus d -> ExceptT StoreError IO (ChatItem 'CTDirect d)
updateDirectChatItemStatus db user@User {userId} ct@Contact {contactId} itemId itemStatus = do
@@ -2703,13 +2810,13 @@ getDirectChatItem db User {userId} contactId itemId = ExceptT $ do
i.item_deleted, i.item_deleted_ts, i.item_edited, i.created_at, i.updated_at,
i.fwd_from_tag, i.fwd_from_chat_name, i.fwd_from_msg_dir, i.fwd_from_contact_id, i.fwd_from_group_id, i.fwd_from_chat_item_id,
i.fwd_from_group_type, i.fwd_from_group_link, i.fwd_from_public_group_id, i.fwd_from_member_id, i.fwd_from_shared_msg_id,
i.timed_ttl, i.timed_delete_at, i.item_live, i.user_mention, i.has_link, i.msg_signed,
i.timed_ttl, i.timed_delete_at, i.item_live, i.user_mention, i.has_link, i.msg_signed, i.item_feed,
-- CIFile
f.file_id, f.file_name, f.file_size, f.file_path, f.file_crypto_key, f.file_crypto_nonce, f.ci_file_status, f.protocol, f.file_expires_at,
-- DirectQuote
ri.chat_item_id, i.quoted_shared_msg_id, i.quoted_sent_at, i.quoted_content, i.quoted_sent
FROM chat_items i
LEFT JOIN files f ON f.chat_item_id = i.chat_item_id
LEFT JOIN files f ON f.chat_item_id = COALESCE(i.feed_item_id, i.chat_item_id)
LEFT JOIN chat_items ri ON ri.user_id = i.user_id AND ri.contact_id = i.contact_id AND ri.shared_msg_id = i.quoted_shared_msg_id
WHERE i.user_id = ? AND i.contact_id = ? AND i.chat_item_id = ?
|]
@@ -2942,6 +3049,30 @@ pattern DBCIBlocked = 2
pattern DBCIBlockedByAdmin :: Int
pattern DBCIBlockedByAdmin = 3
pattern DBCIDeleting :: Int
pattern DBCIDeleting = 4
pattern DBCIFeedNone :: Int
pattern DBCIFeedNone = 0
pattern DBCIFeedLinked :: Int
pattern DBCIFeedLinked = 1
pattern DBCIFeedDetached :: Int
pattern DBCIFeedDetached = 2
toCIFeed :: Int -> Maybe CIFeed
toCIFeed = \case
DBCIFeedLinked -> Just CIFLinked
DBCIFeedDetached -> Just CIFDetached
_ -> Nothing
ciFeedInt :: Maybe CIFeed -> Int
ciFeedInt = \case
Just CIFLinked -> DBCIFeedLinked
Just CIFDetached -> DBCIFeedDetached
Nothing -> DBCIFeedNone
markGroupChatItemDeleted :: DB.Connection -> User -> GroupInfo -> ChatItem 'CTGroup d -> Maybe GroupMember -> UTCTime -> IO (ChatItem 'CTGroup d)
markGroupChatItemDeleted db User {userId} GroupInfo {groupId} ci@ChatItem {meta} byGroupMember_ deletedTs = do
currentTs <- liftIO getCurrentTime
@@ -3097,7 +3228,7 @@ getGroupChatItem db User {userId, userContactId} groupId itemId = ExceptT $ do
i.item_deleted, i.item_deleted_ts, i.item_edited, i.created_at, i.updated_at,
i.fwd_from_tag, i.fwd_from_chat_name, i.fwd_from_msg_dir, i.fwd_from_contact_id, i.fwd_from_group_id, i.fwd_from_chat_item_id,
i.fwd_from_group_type, i.fwd_from_group_link, i.fwd_from_public_group_id, i.fwd_from_member_id, i.fwd_from_shared_msg_id,
i.timed_ttl, i.timed_delete_at, i.item_live, i.user_mention, i.has_link, i.msg_signed,
i.timed_ttl, i.timed_delete_at, i.item_live, i.user_mention, i.has_link, i.msg_signed, i.item_feed,
-- CIFile
f.file_id, f.file_name, f.file_size, f.file_path, f.file_crypto_key, f.file_crypto_nonce, f.ci_file_status, f.protocol, f.file_expires_at,
-- CIMeta forwardedByMember, showGroupAsSender
@@ -3126,7 +3257,7 @@ getGroupChatItem db User {userId, userContactId} groupId itemId = ExceptT $ do
dbm.created_at, dbm.updated_at,
dbm.support_chat_ts, dbm.support_chat_items_unread, dbm.support_chat_items_member_attention, dbm.support_chat_items_mentions, dbm.support_chat_last_msg_from_member_ts, dbm.member_pub_key, dbm.relay_link, dbm.member_security_code, dbm.member_security_code_verified_at
FROM chat_items i
LEFT JOIN files f ON f.chat_item_id = i.chat_item_id
LEFT JOIN files f ON f.chat_item_id = COALESCE(i.feed_item_id, i.chat_item_id)
LEFT JOIN group_members m ON m.group_member_id = i.group_member_id
LEFT JOIN contact_profiles p ON p.contact_profile_id = COALESCE(m.member_profile_id, m.contact_profile_id)
LEFT JOIN chat_items ri ON ri.shared_msg_id = i.quoted_shared_msg_id AND ri.group_id = i.group_id
@@ -3210,7 +3341,7 @@ getLocalChatItem db User {userId} folderId itemId = ExceptT $ do
i.item_deleted, i.item_deleted_ts, i.item_edited, i.created_at, i.updated_at,
i.fwd_from_tag, i.fwd_from_chat_name, i.fwd_from_msg_dir, i.fwd_from_contact_id, i.fwd_from_group_id, i.fwd_from_chat_item_id,
i.fwd_from_group_type, i.fwd_from_group_link, i.fwd_from_public_group_id, i.fwd_from_member_id, i.fwd_from_shared_msg_id,
i.timed_ttl, i.timed_delete_at, i.item_live, i.user_mention, i.has_link, i.msg_signed,
i.timed_ttl, i.timed_delete_at, i.item_live, i.user_mention, i.has_link, i.msg_signed, i.item_feed,
-- CIFile
f.file_id, f.file_name, f.file_size, f.file_path, f.file_crypto_key, f.file_crypto_nonce, f.ci_file_status, f.protocol, f.file_expires_at
FROM chat_items i
@@ -3219,6 +3350,212 @@ getLocalChatItem db User {userId} folderId itemId = ExceptT $ do
|]
(userId, folderId, itemId)
-- a feed item is always sent; its reactions are aggregated from the instances
toFeedChatItem :: UTCTime -> [CIReactionCount] -> ChatItemRow -> Either StoreError (CChatItem 'CTFeed)
toFeedChatItem currentTs reactions ((itemId, itemTs, AMsgDirection msgDir, itemContentText, itemText, itemStatus, sentViaProxy, sharedMsgId) :. (itemDeleted, deletedTs, itemEdited, createdAt, updatedAt) :. forwardedFromRow :. (timedTTL, timedDeleteAt, itemLive, BI userMention, BI hasLink, msgSigned, itemFeed) :. (fileId_, fileName_, fileSize_, filePath, fileKey, fileNonce, fileStatus_, fileProtocol_, fileExpires)) =
chatItem $ fromRight invalid $ dbParseACIContent itemContentText
where
invalid = ACIContent msgDir $ CIInvalidJSON itemContentText
chatItem itemContent = case (itemContent, itemStatus, fileStatus_) of
(ACIContent SMDSnd ciContent, ACIStatus SMDSnd ciStatus, Just (AFS SMDSnd fileStatus)) ->
Right $ cItem ciStatus ciContent (maybeCIFile fileStatus)
(ACIContent SMDSnd ciContent, ACIStatus SMDSnd ciStatus, Nothing) ->
Right $ cItem ciStatus ciContent Nothing
_ -> badItem
maybeCIFile :: CIFileStatus 'MDSnd -> Maybe (CIFile 'MDSnd)
maybeCIFile fileStatus =
case (fileId_, fileName_, fileSize_, fileProtocol_) of
(Just fileId, Just fileName, Just fileSize, Just fileProtocol) ->
let cfArgs = CFArgs <$> fileKey <*> fileNonce
fileSource = (`CryptoFile` cfArgs) <$> filePath
in Just CIFile {fileId, fileName, fileSize, fileSource, fileStatus, fileProtocol, fileExpires}
_ -> Nothing
cItem :: CIStatus 'MDSnd -> CIContent 'MDSnd -> Maybe (CIFile 'MDSnd) -> CChatItem 'CTFeed
cItem ciStatus content file =
CChatItem SMDSnd ChatItem {chatDir = CIFeedSnd, meta = ciMeta content ciStatus, content, mentions = M.empty, formattedText = parseMaybeMarkdownList itemText, quotedItem = Nothing, reactions, file}
badItem = Left $ SEBadChatItem itemId (Just itemTs)
ciMeta :: CIContent 'MDSnd -> CIStatus 'MDSnd -> CIMeta 'CTFeed 'MDSnd
ciMeta content status =
let itemDeleted' = case itemDeleted of
DBCINotDeleted -> Nothing
DBCIDeleting -> Just (CIDeleting deletedTs)
_ -> Just (CIDeleted @'CTFeed deletedTs)
itemEdited' = maybe False unBI itemEdited
itemForwarded = toCIForwardedFrom forwardedFromRow
in mkCIMeta itemId content itemText status (unBI <$> sentViaProxy) sharedMsgId itemForwarded itemDeleted' itemEdited' ciTimed (unBI <$> itemLive) userMention hasLink currentTs itemTs Nothing False msgSigned (toCIFeed itemFeed) createdAt updatedAt
ciTimed :: Maybe CITimed
ciTimed = timedTTL >>= \ttl -> Just CITimed {ttl, deleteAt = timedDeleteAt}
getFeedChatItem :: DB.Connection -> User -> FeedId -> ChatItemId -> ExceptT StoreError IO (CChatItem 'CTFeed)
getFeedChatItem db user@User {userId} feedId itemId = ExceptT $ do
currentTs <- getCurrentTime
getItem >>= \case
[] -> pure $ Left $ SEChatItemNotFound itemId
row : _ -> do
reactions <- itemReactions row
pure $ toFeedChatItem currentTs reactions row
where
itemReactions ((_, _, _, _, _, _, _, sharedMsgId) :. _) =
maybe (pure []) (getFeedCIReactions db user) sharedMsgId
getItem =
DB.query
db
[sql|
SELECT
-- ChatItem
i.chat_item_id, i.item_ts, i.item_sent, i.item_content, i.item_text, i.item_status, i.via_proxy, i.shared_msg_id,
i.item_deleted, i.item_deleted_ts, i.item_edited, i.created_at, i.updated_at,
i.fwd_from_tag, i.fwd_from_chat_name, i.fwd_from_msg_dir, i.fwd_from_contact_id, i.fwd_from_group_id, i.fwd_from_chat_item_id,
i.fwd_from_group_type, i.fwd_from_group_link, i.fwd_from_public_group_id, i.fwd_from_member_id, i.fwd_from_shared_msg_id,
i.timed_ttl, i.timed_delete_at, i.item_live, i.user_mention, i.has_link, i.msg_signed, i.item_feed,
-- CIFile
f.file_id, f.file_name, f.file_size, f.file_path, f.file_crypto_key, f.file_crypto_nonce, f.ci_file_status, f.protocol, f.file_expires_at
FROM chat_items i
LEFT JOIN files f ON f.chat_item_id = i.chat_item_id
WHERE i.user_id = ? AND i.feed_id = ? AND i.chat_item_id = ?
|]
(userId, feedId, itemId)
-- reactions received on the instances of a broadcast, in every chat it was sent to
getFeedCIReactions :: DB.Connection -> User -> SharedMsgId -> IO [CIReactionCount]
getFeedCIReactions db User {userId} itemSharedMsgId =
map toFeedReaction
<$> DB.query
db
[sql|
SELECT r.reaction, COUNT(1)
FROM chat_item_reactions r
LEFT JOIN contacts ct ON ct.contact_id = r.contact_id
LEFT JOIN groups g ON g.group_id = r.group_id
LEFT JOIN group_members mu ON mu.group_id = r.group_id AND mu.member_category = ?
WHERE r.shared_msg_id = ? AND r.reaction_sent = 0
AND ((r.group_id IS NULL AND ct.user_id = ?) OR (g.user_id = ? AND r.item_member_id = mu.member_id))
GROUP BY r.reaction
|]
(GCUserMember, itemSharedMsgId, userId, userId)
where
toFeedReaction (reaction, totalReacted) = CIReactionCount {reaction, userReacted = False, totalReacted}
safeGetFeedItem :: DB.Connection -> User -> Feed -> UTCTime -> ChatItemId -> IO (CChatItem 'CTFeed)
safeGetFeedItem db user Feed {feedId} currentTs itemId =
runExceptT (getFeedChatItem db user feedId 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
feed <- getFeed db user feedId
let cInfo = FeedChat feed
search = fromMaybe "" search_
chatItems range count = do
ciIds <- getChatItemIDs db user cInfo contentFilter range count search
ts <- liftIO getCurrentTime
liftIO $ mapM (safeGetFeedItem db user feed ts) ciIds
itemRange itemId = do
ci <- getFeedChatItem db user feedId itemId
pure (ciCreatedAt ci, cChatItemId ci)
case pagination of
CPLast count -> (,Nothing) . chat cInfo . reverse <$> chatItems CRLast count
CPAfter afterId count -> do
(ts, ciId) <- itemRange afterId
(,Nothing) . chat cInfo <$> chatItems (CRAfter ts ciId) count
CPBefore beforeId count -> do
(ts, ciId) <- itemRange beforeId
(,Nothing) . chat cInfo . reverse <$> chatItems (CRBefore ts ciId) count
CPAround aroundId count -> do
aroundCI <- getFeedChatItem db user feedId aroundId
(ts, ciId) <- itemRange aroundId
beforeCIs <- chatItems (CRBefore ts ciId) count
afterCIs <- chatItems (CRAfter ts ciId) count
pure (chat cInfo (reverse beforeCIs <> [aroundCI] <> afterCIs), Just $ NavigationInfo 0 0)
CPInitial count -> do
unless (T.null search) $ throwError $ SEInternalError "initial chat pagination doesn't support search"
(,Just $ NavigationInfo 0 0) . chat cInfo . reverse <$> chatItems CRLast count
where
chat cInfo cis = Chat cInfo cis emptyChatStats
updateFeedChatItem' :: DB.Connection -> User -> FeedId -> ChatItem 'CTFeed 'MDSnd -> CIContent 'MDSnd -> Bool -> IO (ChatItem 'CTFeed 'MDSnd)
updateFeedChatItem' db User {userId} feedId ci newContent hasLink = do
currentTs <- getCurrentTime
let ci'@ChatItem {meta = CIMeta {itemId, itemText, itemStatus, itemDeleted, itemEdited}} = updatedChatItem ci newContent True False Nothing currentTs
DB.execute
db
[sql|
UPDATE chat_items
SET item_content = ?, item_text = ?, item_status = ?, item_deleted = ?, item_deleted_ts = ?, item_edited = ?, has_link = ?, updated_at = ?
WHERE user_id = ? AND feed_id = ? AND chat_item_id = ?
|]
((newContent, itemText, itemStatus, ciDeletedInt itemDeleted, itemDeletedTs =<< itemDeleted, BI itemEdited, BI hasLink, currentTs) :. (userId, feedId, itemId))
pure ci'
updateFeedChatItemStatus :: DB.Connection -> User -> FeedId -> ChatItemId -> CIStatus 'MDSnd -> IO ()
updateFeedChatItemStatus db User {userId} feedId itemId status = do
currentTs <- getCurrentTime
DB.execute
db
"UPDATE chat_items SET item_status = ?, updated_at = ? WHERE user_id = ? AND feed_id = ? AND chat_item_id = ?"
(status, currentTs, userId, feedId, itemId)
markFeedChatItemDeleted :: DB.Connection -> User -> FeedId -> ChatItem 'CTFeed 'MDSnd -> CIDeleted 'CTFeed -> UTCTime -> IO (ChatItem 'CTFeed 'MDSnd)
markFeedChatItemDeleted db User {userId} feedId ci@ChatItem {meta} itemDeleted deletedTs = do
currentTs <- getCurrentTime
DB.execute
db
[sql|
UPDATE chat_items
SET item_deleted = ?, item_deleted_ts = ?, updated_at = ?
WHERE user_id = ? AND feed_id = ? AND chat_item_id = ?
|]
(ciDeletedInt (Just itemDeleted), deletedTs, currentTs, userId, feedId, chatItemId' ci)
pure ci {meta = meta {itemDeleted = Just itemDeleted, editable = False, deletable = False}}
deleteFeedChatItem :: DB.Connection -> User -> FeedId -> ChatItemId -> IO ()
deleteFeedChatItem db User {userId} feedId itemId = do
deleteChatItemMessages_ db itemId
deleteChatItemVersions_ db itemId
DB.execute db "DELETE FROM chat_items WHERE user_id = ? AND feed_id = ? AND chat_item_id = ?" (userId, feedId, itemId)
getFeedChatItemIdByText :: DB.Connection -> User -> FeedId -> Text -> ExceptT StoreError IO ChatItemId
getFeedChatItemIdByText db User {userId} feedId msg =
ExceptT . firstRow fromOnly (SEChatItemNotFoundByText msg) $
DB.query
db
[sql|
SELECT chat_item_id
FROM chat_items
WHERE user_id = ? AND feed_id = ? AND item_text LIKE ?
ORDER BY chat_item_id DESC
LIMIT 1
|]
(userId, feedId, msg <> "%")
ciDeletedInt :: Maybe (CIDeleted 'CTFeed) -> Int
ciDeletedInt = \case
Nothing -> DBCINotDeleted
Just (CIDeleted _) -> DBCIDeleted
Just (CIDeleting _) -> DBCIDeleting
getLocalChatItemIdByText :: DB.Connection -> User -> NoteFolderId -> SMsgDirection d -> Text -> ExceptT StoreError IO ChatItemId
getLocalChatItemIdByText db User {userId} noteFolderId msgDir quotedMsg =
ExceptT . firstRow fromOnly (SEChatItemNotFoundByText quotedMsg) $
@@ -3289,7 +3626,7 @@ getChatItemByFileId db cxt user@User {userId} fileId = do
DB.query
db
[sql|
SELECT i.chat_item_id, i.contact_id, i.group_id, i.group_scope_tag, i.group_scope_group_member_id, i.note_folder_id
SELECT i.chat_item_id, i.contact_id, i.group_id, i.group_scope_tag, i.group_scope_group_member_id, i.note_folder_id, i.feed_id
FROM chat_items i
JOIN files f ON f.chat_item_id = i.chat_item_id
WHERE f.user_id = ? AND f.file_id = ?
@@ -3311,7 +3648,7 @@ getChatItemByGroupId db cxt user@User {userId} groupId = do
DB.query
db
[sql|
SELECT i.chat_item_id, i.contact_id, i.group_id, i.group_scope_tag, i.group_scope_group_member_id, i.note_folder_id
SELECT i.chat_item_id, i.contact_id, i.group_id, i.group_scope_tag, i.group_scope_group_member_id, i.note_folder_id, i.feed_id
FROM chat_items i
JOIN groups g ON g.chat_item_id = i.chat_item_id
WHERE g.user_id = ? AND g.group_id = ?
@@ -3347,6 +3684,10 @@ getAChatItem db cxt user (ChatRef cType chatId scope) itemId = do
nf <- getNoteFolder db user chatId
CChatItem msgDir ci <- getLocalChatItem db user chatId itemId
pure $ AChatItem SCTLocal msgDir (LocalChat nf) ci
CTFeed -> do
feed <- getFeed db user chatId
CChatItem msgDir ci <- getFeedChatItem db user chatId itemId
pure $ AChatItem SCTFeed msgDir (FeedChat feed) ci
_ -> throwError $ SEChatItemNotFound itemId
liftIO $ getACIReactions db aci
src/Simplex/Chat/Store/Profiles.hs
+7
View File
@@ -33,6 +33,7 @@ module Simplex.Chat.Store.Profiles
getUserByContactId,
getUserByGroupId,
getUserByNoteFolderId,
getUserByFeedId,
getUserByFileId,
getUserFileInfo,
deleteUserRecord,
@@ -272,6 +273,12 @@ getUserByNoteFolderId db contactId = do
ExceptT . firstRow (toUser now) (SEUserNotFoundByContactId contactId) $
DB.query db (userQuery <> " JOIN note_folders nf ON nf.user_id = u.user_id WHERE nf.note_folder_id = ?") (Only contactId)
getUserByFeedId :: DB.Connection -> FeedId -> ExceptT StoreError IO User
getUserByFeedId db feedId = do
now <- liftIO getCurrentTime
ExceptT . firstRow (toUser now) (SEFeedNotFound feedId) $
DB.query db (userQuery <> " JOIN feeds f ON f.user_id = u.user_id WHERE f.feed_id = ?") (Only feedId)
getUserByFileId :: DB.Connection -> FileTransferId -> ExceptT StoreError IO User
getUserByFileId db fileId = do
now <- liftIO getCurrentTime
src/Simplex/Chat/Store/SQLite/Migrations/M20260905_feeds.hs
+3
View File
@@ -79,12 +79,15 @@ DROP INDEX idx_contacts_user_id;
ALTER TABLE groups DROP COLUMN drop_feed;
ALTER TABLE contacts DROP COLUMN drop_feed;
DELETE FROM files WHERE feed_id IS NOT NULL;
DROP INDEX idx_files_feed_id;
ALTER TABLE files DROP COLUMN feed_id;
DELETE FROM messages WHERE feed_id IS NOT NULL;
DROP INDEX idx_messages_feed_id;
ALTER TABLE messages DROP COLUMN feed_id;
DELETE FROM chat_items WHERE feed_id IS NOT NULL;
DROP INDEX idx_chat_items_feed_item_group;
DROP INDEX idx_chat_items_feed_item_contact;
DROP INDEX idx_chat_items_feeds_created_at;
src/Simplex/Chat/Store/SQLite/Migrations/chat_schema.sql
+43 -49
View File
@@ -304,8 +304,7 @@ CREATE TABLE files(
file_type TEXT NOT NULL DEFAULT 'normal',
roster_transfer_id INTEGER,
file_digest BLOB,
file_expires_at TEXT
,
file_expires_at TEXT,
feed_id INTEGER DEFAULT NULL REFERENCES feeds ON DELETE CASCADE
) STRICT;
CREATE TABLE snd_files(
@@ -459,8 +458,7 @@ CREATE TABLE messages(
forwarded_by_group_member_id INTEGER REFERENCES group_members ON DELETE SET NULL,
broker_ts TEXT,
msg_chat_binding TEXT,
msg_signatures BLOB
,
msg_signatures BLOB,
feed_id INTEGER DEFAULT NULL REFERENCES feeds ON DELETE CASCADE
) STRICT;
CREATE TABLE pending_group_messages(
@@ -526,8 +524,7 @@ CREATE TABLE chat_items(
fwd_from_group_link BLOB,
fwd_from_public_group_id BLOB,
fwd_from_member_id BLOB,
fwd_from_shared_msg_id BLOB
,
fwd_from_shared_msg_id BLOB,
feed_id INTEGER DEFAULT NULL REFERENCES feeds ON DELETE CASCADE,
feed_item_id INTEGER DEFAULT NULL REFERENCES chat_items ON DELETE SET NULL,
item_feed INTEGER NOT NULL DEFAULT 0
@@ -808,14 +805,11 @@ CREATE TABLE delivery_jobs(
created_at TEXT NOT NULL DEFAULT(datetime('now')),
updated_at TEXT NOT NULL DEFAULT(datetime('now'))
,
sender_group_member_ids TEXT
,
sender_group_member_ids TEXT,
feed_id INTEGER REFERENCES feeds ON DELETE CASCADE,
chat_item_id INTEGER REFERENCES chat_items ON DELETE CASCADE,
delete_mode TEXT,
message_ids TEXT,
cursor_contact_id INTEGER,
cursor_group_id INTEGER
feed_cursor_id INTEGER
) STRICT;
CREATE TABLE group_member_status_predicates(
member_status TEXT NOT NULL PRIMARY KEY,
@@ -869,6 +863,15 @@ CREATE TABLE rcv_roster_transfers(
created_at TEXT NOT NULL DEFAULT(datetime('now')),
updated_at TEXT NOT NULL DEFAULT(datetime('now'))
) STRICT;
CREATE TABLE feeds(
feed_id INTEGER PRIMARY KEY AUTOINCREMENT,
user_id INTEGER NOT NULL REFERENCES users ON DELETE CASCADE,
created_at TEXT NOT NULL DEFAULT(datetime('now')),
updated_at TEXT NOT NULL DEFAULT(datetime('now')),
chat_ts TEXT NOT NULL DEFAULT(datetime('now')),
favorite INTEGER NOT NULL DEFAULT 0,
unread_chat INTEGER NOT NULL DEFAULT 0
) STRICT;
CREATE INDEX contact_profiles_index ON contact_profiles(
display_name,
full_name
@@ -1403,6 +1406,35 @@ CREATE INDEX idx_files_roster_transfer_id ON files(roster_transfer_id);
CREATE INDEX idx_chat_items_item_signed_by_group_member_id ON chat_items(
item_signed_by_group_member_id
);
CREATE INDEX idx_feeds_user_id ON feeds(user_id);
CREATE INDEX idx_chat_items_feed_id ON chat_items(feed_id);
CREATE INDEX idx_chat_items_feeds_created_at ON chat_items(
user_id,
feed_id,
created_at
);
CREATE INDEX idx_chat_items_feed_item_contact ON chat_items(
feed_item_id,
contact_id
);
CREATE INDEX idx_chat_items_feed_item_group ON chat_items(
feed_item_id,
group_id
);
CREATE INDEX idx_messages_feed_id ON messages(feed_id);
CREATE INDEX idx_files_feed_id ON files(feed_id);
CREATE INDEX idx_contacts_user_id ON contacts(user_id);
CREATE INDEX idx_groups_user_id_business_chat ON groups(
user_id,
business_chat
);
CREATE INDEX idx_delivery_jobs_feed_next ON delivery_jobs(
feed_id,
worker_scope,
failed,
job_status
);
CREATE INDEX idx_delivery_jobs_chat_item_id ON delivery_jobs(chat_item_id);
CREATE TRIGGER on_group_members_insert_update_summary
AFTER INSERT ON group_members
FOR EACH ROW
@@ -1435,41 +1467,3 @@ BEGIN
)
WHERE group_id = NEW.group_id;
END;
CREATE TABLE feeds(
feed_id INTEGER PRIMARY KEY AUTOINCREMENT,
user_id INTEGER NOT NULL REFERENCES users ON DELETE CASCADE,
created_at TEXT NOT NULL DEFAULT(datetime('now')),
updated_at TEXT NOT NULL DEFAULT(datetime('now')),
chat_ts TEXT NOT NULL DEFAULT(datetime('now')),
favorite INTEGER NOT NULL DEFAULT 0,
unread_chat INTEGER NOT NULL DEFAULT 0
) STRICT;
CREATE INDEX idx_feeds_user_id ON feeds(user_id);
CREATE INDEX idx_chat_items_feed_id ON chat_items(feed_id);
CREATE INDEX idx_chat_items_feeds_created_at ON chat_items(
user_id,
feed_id,
created_at
);
CREATE INDEX idx_chat_items_feed_item_contact ON chat_items(
feed_item_id,
contact_id
);
CREATE INDEX idx_chat_items_feed_item_group ON chat_items(
feed_item_id,
group_id
);
CREATE INDEX idx_messages_feed_id ON messages(feed_id);
CREATE INDEX idx_files_feed_id ON files(feed_id);
CREATE INDEX idx_contacts_user_id ON contacts(user_id);
CREATE INDEX idx_groups_user_id_business_chat ON groups(
user_id,
business_chat
);
CREATE INDEX idx_delivery_jobs_feed_next ON delivery_jobs(
feed_id,
worker_scope,
failed,
job_status
);
CREATE INDEX idx_delivery_jobs_chat_item_id ON delivery_jobs(chat_item_id);
src/Simplex/Chat/Store/Shared.hs
+36 -9
View File
@@ -492,17 +492,17 @@ type PreparedContactRow = (Maybe AConnectionRequestUri, Maybe AConnShortLink, Ma
type GroupDirectInvitationRow = (Maybe ConnReqInvitation, Maybe GroupId, Maybe GroupMemberId, Maybe Int64, BoolInt)
type ContactRow' = (ProfileId, ContactName, ContactName, Text, Maybe Text, Maybe Text, Maybe ImageData, Maybe ConnLinkContact, Maybe ChatPeerType, LocalAlias, BoolInt, ContactStatus) :. (Maybe MsgFilter, Maybe BoolInt, BoolInt, Maybe Preferences, Preferences, UTCTime, UTCTime, Maybe UTCTime) :. PreparedContactRow :. (Maybe Int64, Maybe BoolInt, Maybe GroupMemberId, BoolInt) :. GroupDirectInvitationRow :. (Maybe UIThemeEntityOverrides, BoolInt, Maybe CustomData, Maybe Int64) :. BadgeRow :. ContactDomainRow
type ContactRow' = (ProfileId, ContactName, ContactName, Text, Maybe Text, Maybe Text, Maybe ImageData, Maybe ConnLinkContact, Maybe ChatPeerType, LocalAlias, BoolInt, ContactStatus) :. (Maybe MsgFilter, Maybe BoolInt, BoolInt, BoolInt, Maybe Preferences, Preferences, UTCTime, UTCTime, Maybe UTCTime) :. PreparedContactRow :. (Maybe Int64, Maybe BoolInt, Maybe GroupMemberId, BoolInt) :. GroupDirectInvitationRow :. (Maybe UIThemeEntityOverrides, BoolInt, Maybe CustomData, Maybe Int64) :. BadgeRow :. ContactDomainRow
type ContactRow = Only ContactId :. ContactRow'
type ContactDomainRow = (Maybe SimplexDomain, Maybe SimplexDomainProof, Maybe BoolInt)
toContact :: UTCTime -> StoreCxt -> User -> [ChatTagId] -> ContactRow :. MaybeConnectionRow -> Contact
toContact now cxt user chatTags ((Only contactId :. (profileId, localDisplayName, displayName, fullName, shortDescr, description, image, contactLink, peerType, localAlias, BI contactUsed, contactStatus) :. (enableNtfs_, sendRcpts, BI favorite, preferences, userPreferences, createdAt, updatedAt, chatTs) :. preparedContactRow :. (contactRequestId, rejectionSupported_, contactGroupMemberId, BI contactGrpInvSent) :. groupDirectInvRow :. (uiThemes, BI chatDeleted, customData, chatItemTTL) :. badgeRow :. domainRow) :. connRow) =
toContact now cxt user chatTags ((Only contactId :. (profileId, localDisplayName, displayName, fullName, shortDescr, description, image, contactLink, peerType, localAlias, BI contactUsed, contactStatus) :. (enableNtfs_, sendRcpts, BI favorite, BI dropFeed_, preferences, userPreferences, createdAt, updatedAt, chatTs) :. preparedContactRow :. (contactRequestId, rejectionSupported_, contactGroupMemberId, BI contactGrpInvSent) :. groupDirectInvRow :. (uiThemes, BI chatDeleted, customData, chatItemTTL) :. badgeRow :. domainRow) :. connRow) =
let profile = LocalProfile {profileId, displayName, fullName, shortDescr, description, image, contactLink, contactDomain = rowToContactDomain domainRow, contactDomainVerified = rowToDomainVerified domainRow, peerType, localBadge = rowToBadge now badgeRow, preferences, localAlias}
activeConn = toMaybeConnection cxt connRow
chatSettings = ChatSettings {enableNtfs = fromMaybe MFAll enableNtfs_, sendRcpts = unBI <$> sendRcpts, favorite}
chatSettings = ChatSettings {enableNtfs = fromMaybe MFAll enableNtfs_, sendRcpts = unBI <$> sendRcpts, favorite, dropFeed = BoolDef dropFeed_}
incognito = maybe False connIncognito activeConn
mergedPreferences = contactUserPreferences user userPreferences preferences incognito
preparedContact = toPreparedContact preparedContactRow
@@ -689,7 +689,7 @@ type BusinessChatInfoRow = (Maybe BusinessChatType, Maybe MemberId, Maybe Member
type GroupKeysRow = (Maybe C.PrivateKeyEd25519, Maybe C.PublicKeyEd25519, Maybe C.PrivateKeyEd25519)
type GroupInfoRow = (Int64, GroupName, GroupName, Text, Maybe Text, Text, Maybe Text, Maybe ImageData, Maybe GroupType, Maybe ShortLinkContact, Maybe B64UrlByteString) :. PublicGroupAccessRow :. (Maybe MsgFilter, Maybe BoolInt, BoolInt, Maybe GroupPreferences, Maybe GroupMemberAdmission) :. (UTCTime, UTCTime, Maybe UTCTime, Maybe UTCTime) :. PreparedGroupRow :. BusinessChatInfoRow :. (BoolInt, Maybe RelayStatus, Maybe UIThemeEntityOverrides, Int64, Maybe Int64, Maybe VersionRoster, Maybe CustomData, Maybe Int64, Int, Maybe ConnReqContact, Maybe BoolInt) :. GroupKeysRow :. GroupMemberRow
type GroupInfoRow = (Int64, GroupName, GroupName, Text, Maybe Text, Text, Maybe Text, Maybe ImageData, Maybe GroupType, Maybe ShortLinkContact, Maybe B64UrlByteString) :. PublicGroupAccessRow :. (Maybe MsgFilter, Maybe BoolInt, BoolInt, BoolInt, Maybe GroupPreferences, Maybe GroupMemberAdmission) :. (UTCTime, UTCTime, Maybe UTCTime, Maybe UTCTime) :. PreparedGroupRow :. BusinessChatInfoRow :. (BoolInt, Maybe RelayStatus, Maybe UIThemeEntityOverrides, Int64, Maybe Int64, Maybe VersionRoster, Maybe CustomData, Maybe Int64, Int, Maybe ConnReqContact, Maybe BoolInt) :. GroupKeysRow :. GroupMemberRow
type PublicGroupAccessRow = (Maybe Text, Maybe SimplexDomain, Maybe BoolInt, Maybe BoolInt, Maybe SimplexDomainProof)
@@ -698,9 +698,9 @@ type GroupMemberRow = (GroupMemberId, GroupId, Int64, MemberId, VersionChat, Ver
type ProfileRow = (ProfileId, ContactName, Text, Maybe Text, Maybe Text, Maybe ImageData, Maybe ConnLinkContact, Maybe ChatPeerType, LocalAlias, Maybe Preferences) :. BadgeRow :. ContactDomainRow
toGroupInfo :: UTCTime -> StoreCxt -> Int64 -> [ChatTagId] -> GroupInfoRow -> GroupInfo
toGroupInfo now cxt userContactId chatTags ((groupId, localDisplayName, displayName, fullName, shortDescr, localAlias, description, image, groupType_, groupLink_, publicGroupId_) :. accessRow :. (enableNtfs_, sendRcpts, BI favorite, groupPreferences, memberAdmission) :. (createdAt, updatedAt, chatTs, userMemberProfileSentAt) :. preparedGroupRow :. businessRow :. (BI useRelays, relayOwnStatus, uiThemes, currentMembers, publicMemberCount, rosterVersion, customData, chatItemTTL, membersRequireAttention, viaGroupLinkUri, groupDomainVerified) :. groupKeysRow :. userMemberRow) =
toGroupInfo now cxt userContactId chatTags ((groupId, localDisplayName, displayName, fullName, shortDescr, localAlias, description, image, groupType_, groupLink_, publicGroupId_) :. accessRow :. (enableNtfs_, sendRcpts, BI favorite, BI dropFeed_, groupPreferences, memberAdmission) :. (createdAt, updatedAt, chatTs, userMemberProfileSentAt) :. preparedGroupRow :. businessRow :. (BI useRelays, relayOwnStatus, uiThemes, currentMembers, publicMemberCount, rosterVersion, customData, chatItemTTL, membersRequireAttention, viaGroupLinkUri, groupDomainVerified) :. groupKeysRow :. userMemberRow) =
let membership = (toGroupMember now userContactId userMemberRow) {memberChatVRange = vr cxt}
chatSettings = ChatSettings {enableNtfs = fromMaybe MFAll enableNtfs_, sendRcpts = unBI <$> sendRcpts, favorite}
chatSettings = ChatSettings {enableNtfs = fromMaybe MFAll enableNtfs_, sendRcpts = unBI <$> sendRcpts, favorite, dropFeed = BoolDef dropFeed_}
fullGroupPreferences = mergeGroupPreferences groupPreferences
publicGroup = toPublicGroupProfile groupType_ groupLink_ publicGroupId_ (toPublicGroupAccess accessRow)
groupKeys = toGroupKeys publicGroupId_ groupKeysRow
@@ -794,17 +794,44 @@ toBusinessChatInfo :: Maybe SimplexDomainClaim -> BusinessChatInfoRow -> Maybe B
toBusinessChatInfo businessDomain (Just chatType, Just businessId, Just customerId) = Just BusinessChatInfo {chatType, businessId, customerId, businessDomain}
toBusinessChatInfo _ _ = Nothing
contactQuery :: Query
contactQuery = "SELECT " <> contactQueryFields <> " " <> contactQueryFrom
contactQueryFields :: Query
contactQueryFields =
[sql|
-- 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,
ct.contact_group_member_id, ct.contact_grp_inv_sent, ct.grp_direct_inv_link, ct.grp_direct_inv_from_group_id, ct.grp_direct_inv_from_group_member_id, ct.grp_direct_inv_from_member_conn_id, ct.grp_direct_inv_started_connection,
ct.ui_themes, ct.chat_deleted, ct.custom_data, ct.chat_item_ttl,
cp.badge_proof, cp.badge_pres_header, cp.badge_expiry, cp.badge_type, cp.badge_verified, cp.badge_extra, cp.badge_master_key, cp.badge_signature, cp.badge_key_idx,
cp.contact_domain, cp.contact_domain_proof, cp.contact_domain_verified,
-- Connection
c.connection_id, c.agent_conn_id, c.conn_level, c.via_contact, c.via_user_contact_link, c.via_group_link, c.group_link_id, c.xcontact_id, c.custom_user_profile_id, c.conn_status, c.conn_type, c.contact_conn_initiated, c.local_alias,
c.contact_id, c.group_member_id, c.user_contact_link_id, c.created_at, c.security_code, c.security_code_verified_at, c.pq_support, c.pq_encryption, c.pq_snd_enabled, c.pq_rcv_enabled, c.auth_err_counter, c.quota_err_counter,
c.conn_chat_version, c.peer_chat_min_version, c.peer_chat_max_version
|]
contactQueryFrom :: Query
contactQueryFrom =
[sql|
FROM contacts ct
JOIN contact_profiles cp ON ct.contact_profile_id = cp.contact_profile_id
LEFT JOIN connections c ON c.contact_id = ct.contact_id
LEFT JOIN contact_requests cr2 ON cr2.contact_request_id = ct.contact_request_id
|]
groupInfoQuery :: Query
groupInfoQuery = groupInfoQueryFields <> " " <> groupInfoQueryFrom
groupInfoQuery = "SELECT " <> 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,
g.enable_ntfs, g.send_rcpts, g.favorite, gp.preferences, gp.member_admission,
g.enable_ntfs, g.send_rcpts, g.favorite, g.drop_feed, gp.preferences, gp.member_admission,
g.created_at, g.updated_at, g.chat_ts, g.user_member_profile_sent_at,
g.conn_full_link_to_connect, g.conn_short_link_to_connect, g.conn_link_prepared_connection, g.conn_link_started_connection, g.welcome_shared_msg_id, g.request_shared_msg_id,
g.business_chat, g.business_member_id, g.customer_member_id,
src/Simplex/Chat/View.hs
+20 -8
View File
@@ -167,7 +167,6 @@ chatResponseToView hu cfg@ChatConfig {logLevel, showReactions, showFullLinks, te
CRGroupChatItemsDeleted u g ciIds byUser member_ -> ttyUser u $ viewGroupChatItemsDeleted g ciIds byUser member_
CRChatItemReaction u added (ACIReaction _ _ chat reaction) -> ttyUser u $ unmutedReaction u chat reaction $ viewItemReaction showReactions chat reaction added ts tz
CRReactionMembers u memberReactions -> ttyUser u $ viewReactionMembers memberReactions
CRBroadcastSent u mc s f t -> ttyUser u $ viewSentBroadcast mc s f ts tz t
CRCmdOk u_ -> ttyUser' u_ ["ok"]
CRChatHelp section -> case section of
HSMain -> chatHelpInfo
@@ -360,6 +359,7 @@ chatResponseToView hu cfg@ChatConfig {logLevel, showReactions, showFullLinks, te
DirectChat Contact {localDisplayName, activeConn} -> ("@" <> localDisplayName, toCIPreview items Nothing, connStatus <$> activeConn)
GroupChat GroupInfo {membership, localDisplayName} _scopeInfo -> ("#" <> localDisplayName, toCIPreview items (Just membership), Nothing)
LocalChat _ -> ("*", toCIPreview items Nothing, Nothing)
FeedChat _ -> ("%", toCIPreview items Nothing, Nothing)
ContactRequest UserContactRequest {localDisplayName} -> ("<@" <> localDisplayName, toCIPreview items Nothing, Nothing)
ContactConnection PendingContactConnection {pccConnId, pccConnStatus} -> (":" <> T.pack (show pccConnId), toCIPreview items Nothing, Just pccConnStatus)
CInfoInvalidJSON {} -> ("invalid chat info", "", Nothing)
@@ -626,6 +626,7 @@ chatItemDeletedText ChatItem {meta = CIMeta {itemDeleted}, content} membership_
CIDeleted _ -> markedDeleted content
CIBlocked _ -> "blocked"
CIBlockedByAdmin _ -> "blocked by admin"
CIDeleting _ -> "being deleted"
markedDeleted = \case
CISndModerated -> "deleted"
CIRcvModerated -> "deleted"
@@ -762,6 +763,14 @@ viewChatItem chat ci@ChatItem {chatDir, meta = meta@CIMeta {itemForwarded, forwa
from = "* "
where
context = maybe [] forwardedFrom itemForwarded
FeedChat _ -> case chatDir of
CIFeedSnd -> case content of
CISndMsgContent mc -> withSndFile to $ sndMsg to context mc
_ -> showSndItem to
where
to = ttyTo "% "
where
context = maybe [] forwardedFrom itemForwarded
ContactRequest {} -> []
ContactConnection {} -> []
CInfoInvalidJSON {} -> ["invalid chat info"]
@@ -895,6 +904,14 @@ viewItemUpdate chat ChatItem {chatDir, meta = meta@CIMeta {itemForwarded, itemEd
(maybe [] forwardedFrom itemForwarded)
(groupQuote g)
quotedItem
FeedChat _ -> case chatDir of
CIFeedSnd -> case content of
CISndMsgContent mc -> viewSentMessage to context mc ts tz meta
_ -> []
where
to = if itemEdited then ttyTo "% [edited] " else ttyTo "% "
where
context = maybe [] forwardedFrom itemForwarded
_ -> []
hideLive :: CIMeta c d -> [StyledString] -> [StyledString]
@@ -964,6 +981,7 @@ viewItemReaction showReactions chat CIReaction {chatDir, chatItem = CChatItem md
(_, CIDirectSnd) -> [sentText]
(_, CIGroupSnd) -> [sentText]
(_, CILocalSnd) -> [sentText]
(_, CIFeedSnd) -> [sentText]
(CInfoInvalidJSON {}, _) -> []
where
groupReaction g scopeInfo m_ sentBy = case ciMsgContent content of
@@ -1089,6 +1107,7 @@ viewChatCleared (AChatInfo _ chatInfo) = case chatInfo of
DirectChat ct -> [ttyContact' ct <> ": all messages are removed locally ONLY"]
GroupChat gi _scopeInfo -> [ttyGroup' gi <> ": all messages are removed locally ONLY"]
LocalChat _ -> ["notes: all messages are removed"]
FeedChat _ -> ["feed: all messages are removed"]
ContactRequest _ -> []
ContactConnection _ -> []
CInfoInvalidJSON {} -> []
@@ -2356,13 +2375,6 @@ viewSentMessage to context mc ts tz meta@CIMeta {itemEdited, itemDeleted, itemLi
Just False -> ttyTo "[LIVE] "
_ -> ""
viewSentBroadcast :: MsgContent -> Int -> Int -> CurrentTime -> TimeZone -> UTCTime -> [StyledString]
viewSentBroadcast mc s f ts tz time = prependFirst (highlight' "/feed" <> " (" <> sShow s <> failures <> ") " <> ttyMsgTime ts tz time <> " ") (ttyMsgContent mc)
where
failures
| f > 0 = ", " <> sShow f <> " failures"
| otherwise = ""
viewSentFileInvitation :: StyledString -> CIFile d -> CurrentTime -> TimeZone -> CIMeta c d -> [StyledString]
viewSentFileInvitation to CIFile {fileId, fileSource, fileStatus} ts tz = case fileSource of
Just (CryptoFile fPath _) -> sentWithTime_ ts tz $ ttySentFile fPath
tests/Bots/BroadcastTests.hs
+7 -3
View File
@@ -63,6 +63,7 @@ testBroadcastMessages ps = do
botLink <-
withNewTestChat ps botDbPrefix broadcastBotProfile $ \bc_bot ->
withNewTestChat ps "alice" aliceProfile $ \alice -> do
createCCFeed bc_bot
connectUsers bc_bot alice
bc_bot ##> "/ad"
getContactLink bc_bot True
@@ -79,11 +80,14 @@ testBroadcastMessages ps = do
bob <## "I broadcast messages to all connected users from @alice."
cath `connectVia` botLink
alice #> "@broadcast_bot hello all!"
alice <# "broadcast_bot> hello all!" -- we broadcast to the sender too, /feed is used by bot
-- the bot replies as soon as the feed item is created; the broadcast is delivered by feed jobs
alice
<### [ WithTime "broadcast_bot> > hello all!",
ConsoleString " Message is being delivered to all contacts",
WithTime "broadcast_bot> hello all!" -- we broadcast to the sender too, /feed is used by bot
]
bob <# "broadcast_bot> hello all!"
cath <# "broadcast_bot> hello all!"
alice <# "broadcast_bot> > hello all!"
alice <## " Forwarded to 3 contact(s), 0 errors"
where
cc `connectVia` botLink = do
cc ##> ("/c " <> botLink)
tests/ChatTests.hs
+2
View File
@@ -4,6 +4,7 @@ import ChatTests.ChatList
import ChatTests.ChatRelays
import ChatTests.DBUtils
import ChatTests.Direct
import ChatTests.Feed
import ChatTests.Files
import ChatTests.Forward
import ChatTests.Groups
@@ -18,6 +19,7 @@ chatTests = do
describe "group tests" chatGroupTests
describe "chat relay tests" chatRelayTests
describe "local chats tests" chatLocalChatsTests
describe "feed tests" chatFeedTests
describe "file tests" chatFileTests
describe "profile tests" chatProfileTests
describe "chat list pagination tests" chatListTests
tests/ChatTests/Direct.hs
+2 -1
View File
@@ -992,8 +992,9 @@ testMultilineMessage = testChat3 aliceProfile bobProfile cathProfile $ \alice bo
alice <## "there"
bob <# "alice> hello"
bob <## "there"
createCCFeed alice
alice `send` "/feed \"hello\\nthere\"" -- /feed "hello\nthere"
alice <##. "/feed (2)"
alice <# "% hello"
alice <## "there"
bob <# "alice> hello"
bob <## "there"
tests/ChatTests/Feed.hs
+106
View File
@@ -0,0 +1,106 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PostfixOperators #-}
module ChatTests.Feed where
import ChatClient
import ChatTests.DBUtils
import ChatTests.Utils
import Simplex.Chat.Controller (ChatConfig (..))
import Test.Hspec hiding (it)
chatFeedTests :: SpecWith TestParams
chatFeedTests = do
describe "feed" $ do
it "broadcast to contacts and customer groups in several buckets" testFeedBuckets
it "edit and delete the broadcast in every chat" testFeedEditDelete
-- one recipient per bucket, so each stream runs three buckets for two recipients
feedTestCfg :: ChatConfig
feedTestCfg = testCfg {feedBucketSize = 1}
testFeedBuckets :: HasCallStack => TestParams -> IO ()
testFeedBuckets =
testChatCfg5 feedTestCfg businessProfile aliceProfile bobProfile cathProfile danProfile $
\biz alice bob cath dan -> do
createCCFeed biz
-- two contacts
connectUsers biz alice
connectUsers biz bob
-- two customer groups
biz ##> "/ad"
cLink <- getContactLink biz True
biz ##> "/auto_accept on business"
biz <## "auto_accept on, business"
connectToBusiness biz cath cLink "cath" "Catherine"
connectToBusiness biz dan cLink "dan" "Daniel"
biz `send` "/feed hello everyone"
biz <# "% hello everyone"
-- the contacts stream and the customer groups stream deliver concurrently
alice <# "biz> hello everyone"
bob <# "biz> hello everyone"
cath <# "#biz biz_1> hello everyone"
dan <# "#biz biz_1> hello everyone"
-- the broadcast is one item in the feed and the last item of every recipient chat
chatItems biz "%1" 10 `shouldReturn` [(1, "hello everyone")]
chatItems biz "@2" 1 `shouldReturn` [(1, "hello everyone")]
chatItems biz "@3" 1 `shouldReturn` [(1, "hello everyone")]
chatItems biz "#1" 1 `shouldReturn` [(1, "hello everyone")]
chatItems biz "#2" 1 `shouldReturn` [(1, "hello everyone")]
testFeedEditDelete :: HasCallStack => TestParams -> IO ()
testFeedEditDelete =
testChatCfg4 feedTestCfg businessProfile aliceProfile bobProfile cathProfile $
\biz alice bob cath -> do
createCCFeed biz
connectUsers biz alice
connectUsers biz bob
biz ##> "/ad"
cLink <- getContactLink biz True
biz ##> "/auto_accept on business"
biz <## "auto_accept on, business"
connectToBusiness biz cath cLink "cath" "Catherine"
biz `send` "/feed hello everyone"
biz <# "% hello everyone"
alice <# "biz> hello everyone"
bob <# "biz> hello everyone"
cath <# "#biz biz_1> hello everyone"
-- the edit applies to the instance of every chat
biz ##> "! % (hello everyone) hello again"
biz <# "% [edited] hello again"
alice <# "biz> [edited] hello again"
bob <# "biz> [edited] hello again"
cath <# "#biz biz_1> [edited] hello again"
chatItems biz "%1" 10 `shouldReturn` [(1, "hello again")]
chatItems biz "@2" 1 `shouldReturn` [(1, "hello again")]
chatItems biz "@3" 1 `shouldReturn` [(1, "hello again")]
chatItems biz "#1" 1 `shouldReturn` [(1, "hello again")]
-- the feed item is removed when every instance is marked deleted
biz ##> "\\ % hello again"
-- the response of the command and the event of the last job
biz <### [ConsoleString "message being deleted", ConsoleString "message deleted"]
alice <# "biz> [marked deleted] hello again"
bob <# "biz> [marked deleted] hello again"
cath <# "#biz biz_1> [marked deleted] hello again"
chatItems biz "%1" 10 `shouldReturn` []
chatItems biz "@2" 1 `shouldReturn` [(1, "hello again [marked deleted]")]
chatItems biz "#1" 1 `shouldReturn` [(1, "hello again [marked deleted]")]
chatItems :: HasCallStack => TestCC -> String -> Int -> IO [(Int, String)]
chatItems cc chatRef count = do
cc ##> ("/_get chat " <> chatRef <> " count=" <> show count)
chat <$> getTermLine cc
connectToBusiness :: HasCallStack => TestCC -> TestCC -> String -> String -> String -> IO ()
connectToBusiness biz cc cLink name fullName = do
cc ##> ("/c " <> cLink)
cc <## "connection request sent!"
biz <## ("#" <> name <> " (" <> fullName <> "): accepting business address request...")
cc <## "#biz: joining the group..."
biz <## ("#" <> name <> ": " <> name <> "_1 joined the group")
cc <## "#biz: you joined the group"
tests/ChatTests/Groups.hs
+3 -2
View File
@@ -6728,8 +6728,9 @@ testMembershipProfileUpdateContactDisabled =
bob `hasContactProfiles` ["alice", "bob"]
-- bob sends any message to alice, increases auth err counter
createCCFeed bob
bob `send` "/feed hi all"
bob <##. "/feed (1)"
bob <# "% hi all"
bob <## "[alice, contactId: 2, connId: 1] error: connection authorization failed - this could happen if connection was deleted, secured with different credentials, or due to a bug - please re-create the connection"
-- on next profile update from alice member, bob considers contact disabled for purposes of profile update
@@ -12403,7 +12404,7 @@ testChannelMemberUpdateEnforcement ps =
connId <- relayConnIdToMember bob "dan"
ts <- getCurrentTime
let ChatController {smpAgent = bobAgent} = chatController bob
chatMsg = ChatMessage chatInitialVRange Nothing (XMsgUpdate sharedId (MCText "forged") M.empty Nothing Nothing Nothing Nothing)
chatMsg = ChatMessage chatInitialVRange Nothing (XMsgUpdate sharedId (MCText "forged") M.empty Nothing Nothing Nothing Nothing Nothing)
fwd = GrpMsgForward (FwdMember cathMemId "cath") ts
body = encodeBinaryBatch [encodeFwdElement fwd (VMUnsigned chatMsg)]
sent <- runExceptT $ sendMessages bobAgent [(connId, PQEncOff, MsgFlags False, vrValue body)]
tests/ChatTests/Utils.hs
+7
View File
@@ -29,6 +29,7 @@ import Simplex.Chat.Markdown (viewName)
import Simplex.Chat.Messages.CIContent (e2eInfoNoPQText, e2eInfoPQText)
import Simplex.Chat.Protocol
import Simplex.Chat.Store.Direct (getContact)
import Simplex.Chat.Store.Feeds (createFeed)
import Simplex.Chat.Store.NoteFolders (createNoteFolder)
import Simplex.Chat.Store.Profiles (getUserContactProfiles)
import Simplex.Chat.Types
@@ -680,6 +681,12 @@ createCCNoteFolder cc =
withCCUser cc $ \user ->
runExceptT (createNoteFolder db user) >>= either (fail . show) pure
createCCFeed :: TestCC -> IO ()
createCCFeed cc =
withCCTransaction cc $ \db ->
withCCUser cc $ \user ->
runExceptT (createFeed db user) >>= either (fail . show) pure
getProfilePictureByName :: TestCC -> String -> IO (Maybe String)
getProfilePictureByName cc displayName =
withTransaction (chatStore $ chatController cc) $ \db ->
tests/ProtocolTests.hs
+1 -1
View File
@@ -249,7 +249,7 @@ decodeChatMessageTest = describe "Chat message encoding/decoding" $ do
##==## ChatMessage chatInitialVRange (Just $ SharedMsgId "\1\2\3\4") (XMsgNew $ (mcForward Nothing (MCText "hello")) {file = Just FileInvitation {fileName = "photo.jpg", fileSize = 12345, fileDigest = Nothing, fileConnReq = Nothing, fileInline = Nothing, fileDescr = Nothing}})
it "x.msg.update" $
"{\"v\":\"9\",\"event\":\"x.msg.update\",\"params\":{\"msgId\":\"AQIDBA==\", \"content\":{\"text\":\"hello\",\"type\":\"text\"}}}"
#==# XMsgUpdate (SharedMsgId "\1\2\3\4") (MCText "hello") [] Nothing Nothing Nothing Nothing
#==# XMsgUpdate (SharedMsgId "\1\2\3\4") (MCText "hello") [] Nothing Nothing Nothing Nothing Nothing
it "x.msg.del" $
"{\"v\":\"9\",\"event\":\"x.msg.del\",\"params\":{\"msgId\":\"AQIDBA==\"}}"
#==# XMsgDel (SharedMsgId "\1\2\3\4") Nothing Nothing False