lovely-projects/simplex-chat
lovely-projects/simplex-chat
1
0
Fork 0
mirror of https://github.com/simplex-chat/simplex-chat.git synced 2025-03-14 09:45:42 +00:00
Code Issues Projects Releases Packages Wiki Activity Actions 1

core: member mentions, types and rfc (#5555)

Browse source 
* core: member mentions, types and rfc

* update

* update rfc

* save/get mentions (WIP)

* markdown

* store received mentions and userMention flag

* sent mentions

* update message with mentions

* db queries

* CLI mentions, test passes

* use maps for mentions

* tests

* comment

* save mentions on sent messages

* postresql schema

* refactor

* M.empty

* include both displayName and localAlias into MentionedMemberInfo

* fix saving sent mentions

* include mentions in previews

* update plans
This commit is contained in:
Evgeny 2025-01-29 13:04:48 +00:00 • committed by GitHub
parent c20e94f2fb
commit 621b291da1
No known key found for this signature in database
GPG key ID: B5690EEEBB952194
31 changed files with 858 additions and 316 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

9
apps/simplex-directory-service/src/Directory/Events.hs
View file

@ -30,6 +30,7 @@ import qualified Data.Text as T
import Data.Text.Encoding (encodeUtf8) import Data.Text.Encoding (encodeUtf8)
import Directory.Store import Directory.Store
import Simplex.Chat.Controller import Simplex.Chat.Controller
import Simplex.Chat.Markdown (displayNameTextP)
import Simplex.Chat.Messages import Simplex.Chat.Messages
import Simplex.Chat.Messages.CIContent import Simplex.Chat.Messages.CIContent
import Simplex.Chat.Protocol (MsgContent (..)) import Simplex.Chat.Protocol (MsgContent (..))
@ -222,13 +223,7 @@ directoryCmdP =
DCInviteOwnerToGroup_ -> gc DCInviteOwnerToGroup DCInviteOwnerToGroup_ -> gc DCInviteOwnerToGroup
DCExecuteCommand_ -> DCExecuteCommand . T.unpack <$> (A.space *> A.takeText) DCExecuteCommand_ -> DCExecuteCommand . T.unpack <$> (A.space *> A.takeText)
where where
gc f = f <$> (A.space *> A.decimal <* A.char ':') <*> displayNameP gc f = f <$> (A.space *> A.decimal <* A.char ':') <*> displayNameTextP
displayNameP = quoted '\'' <|> takeNameTill (== ' ')
takeNameTill p =
A.peekChar' >>= \c ->
if refChar c then A.takeTill p else fail "invalid first character in display name"
quoted c = A.char c *> takeNameTill (== c) <* A.char c
refChar c = c > ' ' && c /= '#' && c /= '@'
viewName :: Text -> Text viewName :: Text -> Text
viewName n = if any (== ' ') (T.unpack n) then "'" <> n <> "'" else n viewName n = if any (== ' ') (T.unpack n) then "'" <> n <> "'" else n

60
docs/rfcs/2025-01-20-member-mentions.md Normal file
View file

@ -0,0 +1,60 @@
# Member mentions
## Problem
Mention members in the messages.
There are several UX objectives that mentions must deliver:
- to notify the user about the messages that mention the user or to reply to user's messages - groups must have this notification mode (already present in the API),
- to allow the user to navigate to unread mentions and replies,
- to highlight mentions and allow all users to open mentioned member profile - this is the least important objective.
## Solution
Message text should include the reference to the shared member display name:
```
Hello @name
```
or
```
Hello @'member name'
```
This is the same format that people already use and that is currently supported in the API. The name in the message should use the display name at the time of mention, both for backwards compatibility and for better view in compose field, and the message should additionally include the mapping from used display names to shared group member IDs, and the UI would show the current display name (at the time of loading the message to the view).
For this mapping the message JSON will include the array of mentions, as objects with properties `displayName` and `memberId`. This is to ensure the intent and that the fragments of text are treated as mentions.
Using an immutable `memberId` would prevent any race conditions and duplicate display names. The receiving client would show a local view name (display name or an alias), and might open a correct member card when mention is tapped.
As display names are not unique in the group, we should convert them to locally-unique names (per message), by appending _1, _2, as necessary, and the same locally unique names should be used in the mapping to member IDs. These locally unique names must NOT use local user aliases, and must NOT use localDisplayName, as otherwise it may leak information that is known only to the user's client.
There should be a reasonable limit on the number of mentions per message, e.g. 3. This is to prevent abuse, expensive processing both in the client and in super-peers that would have to forward member profiles if they were not forwarded before. This limit has to be enforced both on sending and receiving ends.
## UX for sending mentions
When a member types '@' character in the entry field, the app would show the paginated list of most recently active members, with search. This requires a separate API, and the same API can be used to show a paginated member list - loading the full list is already quite expensive with groups over 1-2k members.
## UX for navigating to mentions
The current circles with unread messages should indicate the number of unread mentions (including replies) above and below the view. Tapping the circle should navigate to the next unread mention, and not to the bottom/top of the conversation. Long-pressing the circle should offer the option to navigate to the top/bottom. In the absense of mentions, tapping circles would navigate to top/bottom.
## Message UI
Item text will include markdown elements for mentioned members. This will be used when rendering to show member display names or local aliases.
Chat items data will include the list of members used in the chat item, including view names and member IDs.
## Forwarding and saving to local items
When forwarding to another conversation or saving to notes a message with mentions the app should use:
- current display names instead of display names used in the message.
- remove mentions mapping from the message data.
## Schema
Two new columns for chat_items table:
- user_mention - 0 or 1 to indicate whether a message is a reply to user's message or mentions user.
- member_mentions - the object mapping display names to member IDs, either as JSON, or in a more economical comma-separated list of "ID:name" strings (or "ID:'member name'). This field can be processed to load mention information, with the limit of 3 mentions per message it's sufficient.

9
packages/simplex-chat-client/typescript/src/command.ts
View file

@ -29,7 +29,6 @@ export type ChatCommand =
| APIRejectContact | APIRejectContact
| APIUpdateProfile | APIUpdateProfile
| APISetContactAlias | APISetContactAlias
| APIParseMarkdown
| NewGroup | NewGroup
| APIAddMember | APIAddMember
| APIJoinGroup | APIJoinGroup
@ -128,7 +127,6 @@ type ChatCommandTag =
| "apiRejectContact" | "apiRejectContact"
| "apiUpdateProfile" | "apiUpdateProfile"
| "apiSetContactAlias" | "apiSetContactAlias"
| "apiParseMarkdown"
| "newGroup" | "newGroup"
| "apiAddMember" | "apiAddMember"
| "apiJoinGroup" | "apiJoinGroup"
@ -355,11 +353,6 @@ export interface APISetContactAlias extends IChatCommand {
localAlias: string localAlias: string
} }
export interface APIParseMarkdown extends IChatCommand {
type: "apiParseMarkdown"
text: string
}
export interface NewGroup extends IChatCommand { export interface NewGroup extends IChatCommand {
type: "newGroup" type: "newGroup"
groupProfile: GroupProfile groupProfile: GroupProfile
@ -732,8 +725,6 @@ export function cmdString(cmd: ChatCommand): string {
return `/_profile ${cmd.userId} ${JSON.stringify(cmd.profile)}` return `/_profile ${cmd.userId} ${JSON.stringify(cmd.profile)}`
case "apiSetContactAlias": case "apiSetContactAlias":
return `/_set alias @${cmd.contactId} ${cmd.localAlias.trim()}` return `/_set alias @${cmd.contactId} ${cmd.localAlias.trim()}`
case "apiParseMarkdown":
return `/_parse ${cmd.text}`
case "newGroup": case "newGroup":
return `/_group ${JSON.stringify(cmd.groupProfile)}` return `/_group ${JSON.stringify(cmd.groupProfile)}`
case "apiAddMember": case "apiAddMember":

1
simplex-chat.cabal
View file

@ -221,6 +221,7 @@ library
Simplex.Chat.Store.SQLite.Migrations.M20250105_indexes Simplex.Chat.Store.SQLite.Migrations.M20250105_indexes
Simplex.Chat.Store.SQLite.Migrations.M20250115_chat_ttl Simplex.Chat.Store.SQLite.Migrations.M20250115_chat_ttl
Simplex.Chat.Store.SQLite.Migrations.M20250122_chat_items_include_in_history Simplex.Chat.Store.SQLite.Migrations.M20250122_chat_items_include_in_history
Simplex.Chat.Store.SQLite.Migrations.M20250126_mentions
other-modules: other-modules:
Paths_simplex_chat Paths_simplex_chat
hs-source-dirs: hs-source-dirs:

6
src/Simplex/Chat/Bot.hs
View file

@ -11,7 +11,7 @@ import Control.Concurrent.Async
import Control.Concurrent.STM import Control.Concurrent.STM
import Control.Monad import Control.Monad
import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Char8 as B
import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.Map.Strict as M
import Data.Text (Text) import Data.Text (Text)
import qualified Data.Text as T import qualified Data.Text as T
import Simplex.Chat.Controller import Simplex.Chat.Controller
@ -69,8 +69,8 @@ sendComposedMessage cc = sendComposedMessage' cc . contactId'
sendComposedMessage' :: ChatController -> ContactId -> Maybe ChatItemId -> MsgContent -> IO () sendComposedMessage' :: ChatController -> ContactId -> Maybe ChatItemId -> MsgContent -> IO ()
sendComposedMessage' cc ctId quotedItemId msgContent = do sendComposedMessage' cc ctId quotedItemId msgContent = do
let cm = ComposedMessage {fileSource = Nothing, quotedItemId, msgContent} let cm = ComposedMessage {fileSource = Nothing, quotedItemId, msgContent, mentions = M.empty}
sendChatCmd cc (APISendMessages (ChatRef CTDirect ctId) False Nothing (cm :| [])) >>= \case sendChatCmd cc (APISendMessages (ChatRef CTDirect ctId) False Nothing [cm]) >>= \case
CRNewChatItems {} -> printLog cc CLLInfo $ "sent message to contact ID " <> show ctId CRNewChatItems {} -> printLog cc CLLInfo $ "sent message to contact ID " <> show ctId
r -> putStrLn $ "unexpected send message response: " <> show r r -> putStrLn $ "unexpected send message response: " <> show r

40
src/Simplex/Chat/Controller.hs
View file

@ -39,6 +39,7 @@ import Data.Int (Int64)
import Data.List.NonEmpty (NonEmpty) import Data.List.NonEmpty (NonEmpty)
import Data.Map.Strict (Map) import Data.Map.Strict (Map)
import qualified Data.Map.Strict as M import qualified Data.Map.Strict as M
import Data.Maybe (fromMaybe)
import Data.String import Data.String
import Data.Text (Text) import Data.Text (Text)
import Data.Text.Encoding (decodeLatin1) import Data.Text.Encoding (decodeLatin1)
@ -313,7 +314,7 @@ data ChatCommand
| APICreateChatItems {noteFolderId :: NoteFolderId, composedMessages :: NonEmpty ComposedMessage} | APICreateChatItems {noteFolderId :: NoteFolderId, composedMessages :: NonEmpty ComposedMessage}
| APIReportMessage {groupId :: GroupId, chatItemId :: ChatItemId, reportReason :: ReportReason, reportText :: Text} | APIReportMessage {groupId :: GroupId, chatItemId :: ChatItemId, reportReason :: ReportReason, reportText :: Text}
| ReportMessage {groupName :: GroupName, contactName_ :: Maybe ContactName, reportReason :: ReportReason, reportedMessage :: Text} | ReportMessage {groupName :: GroupName, contactName_ :: Maybe ContactName, reportReason :: ReportReason, reportedMessage :: Text}
| APIUpdateChatItem {chatRef :: ChatRef, chatItemId :: ChatItemId, liveMessage :: Bool, msgContent :: MsgContent} | APIUpdateChatItem {chatRef :: ChatRef, chatItemId :: ChatItemId, liveMessage :: Bool, updatedMessage :: UpdatedMessage}
| APIDeleteChatItem ChatRef (NonEmpty ChatItemId) CIDeleteMode | APIDeleteChatItem ChatRef (NonEmpty ChatItemId) CIDeleteMode
| APIDeleteMemberChatItem GroupId (NonEmpty ChatItemId) | APIDeleteMemberChatItem GroupId (NonEmpty ChatItemId)
| APIChatItemReaction {chatRef :: ChatRef, chatItemId :: ChatItemId, add :: Bool, reaction :: MsgReaction} | APIChatItemReaction {chatRef :: ChatRef, chatItemId :: ChatItemId, add :: Bool, reaction :: MsgReaction}
@ -346,7 +347,6 @@ data ChatCommand
| APISetConnectionAlias Int64 LocalAlias | APISetConnectionAlias Int64 LocalAlias
| APISetUserUIThemes UserId (Maybe UIThemeEntityOverrides) | APISetUserUIThemes UserId (Maybe UIThemeEntityOverrides)
| APISetChatUIThemes ChatRef (Maybe UIThemeEntityOverrides) | APISetChatUIThemes ChatRef (Maybe UIThemeEntityOverrides)
| APIParseMarkdown Text
| APIGetNtfToken | APIGetNtfToken
| APIRegisterToken DeviceToken NotificationsMode | APIRegisterToken DeviceToken NotificationsMode
| APIVerifyToken DeviceToken C.CbNonce ByteString | APIVerifyToken DeviceToken C.CbNonce ByteString
@ -1085,22 +1085,16 @@ data UserProfileUpdateSummary = UserProfileUpdateSummary
data ComposedMessage = ComposedMessage data ComposedMessage = ComposedMessage
{ fileSource :: Maybe CryptoFile, { fileSource :: Maybe CryptoFile,
quotedItemId :: Maybe ChatItemId, quotedItemId :: Maybe ChatItemId,
msgContent :: MsgContent msgContent :: MsgContent,
mentions :: Map MemberName GroupMemberId
} }
deriving (Show) deriving (Show)
-- This instance is needed for backward compatibility, can be removed in v6.0 data UpdatedMessage = UpdatedMessage
instance FromJSON ComposedMessage where { msgContent :: MsgContent,
parseJSON (J.Object v) = do mentions :: Map MemberName GroupMemberId
fileSource <- }
(v .:? "fileSource") >>= \case deriving (Show)
Nothing -> CF.plain <$$> (v .:? "filePath")
f -> pure f
quotedItemId <- v .:? "quotedItemId"
msgContent <- v .: "msgContent"
pure ComposedMessage {fileSource, quotedItemId, msgContent}
parseJSON invalid =
JT.prependFailure "bad ComposedMessage, " (JT.typeMismatch "Object" invalid)
data ChatTagData = ChatTagData data ChatTagData = ChatTagData
{ emoji :: Maybe Text, { emoji :: Maybe Text,
@ -1273,7 +1267,6 @@ data ChatErrorType
| CEFileNotApproved {fileId :: FileTransferId, unknownServers :: [XFTPServer]} | CEFileNotApproved {fileId :: FileTransferId, unknownServers :: [XFTPServer]}
| CEFallbackToSMPProhibited {fileId :: FileTransferId} | CEFallbackToSMPProhibited {fileId :: FileTransferId}
| CEInlineFileProhibited {fileId :: FileTransferId} | CEInlineFileProhibited {fileId :: FileTransferId}
| CEInvalidQuote
| CEInvalidForward | CEInvalidForward
| CEInvalidChatItemUpdate | CEInvalidChatItemUpdate
| CEInvalidChatItemDelete | CEInvalidChatItemDelete
@ -1635,4 +1628,19 @@ $(JQ.deriveFromJSON defaultJSON ''DBEncryptionConfig)
$(JQ.deriveToJSON defaultJSON ''ComposedMessage) $(JQ.deriveToJSON defaultJSON ''ComposedMessage)
instance FromJSON ComposedMessage where
parseJSON (J.Object v) = do
fileSource <-
(v .:? "fileSource") >>= \case
Nothing -> CF.plain <$$> (v .:? "filePath")
f -> pure f
quotedItemId <- v .:? "quotedItemId"
msgContent <- v .: "msgContent"
mentions <- fromMaybe M.empty <$> v .:? "mentions"
pure ComposedMessage {fileSource, quotedItemId, msgContent, mentions}
parseJSON invalid =
JT.prependFailure "bad ComposedMessage, " (JT.typeMismatch "Object" invalid)
$(JQ.deriveJSON defaultJSON ''UpdatedMessage)
$(JQ.deriveToJSON defaultJSON ''ChatTagData) $(JQ.deriveToJSON defaultJSON ''ChatTagData)

220
src/Simplex/Chat/Library/Commands.hs
View file

@ -37,7 +37,7 @@ import Data.Either (fromRight, partitionEithers, rights)
import Data.Foldable (foldr') import Data.Foldable (foldr')
import Data.Functor (($>)) import Data.Functor (($>))
import Data.Int (Int64) import Data.Int (Int64)
import Data.List (find, foldl', isSuffixOf, partition, sortOn, zipWith4) import Data.List (find, foldl', isSuffixOf, partition, sortOn, zipWith5)
import Data.List.NonEmpty (NonEmpty (..)) import Data.List.NonEmpty (NonEmpty (..))
import qualified Data.List.NonEmpty as L import qualified Data.List.NonEmpty as L
import Data.Map.Strict (Map) import Data.Map.Strict (Map)
@ -80,7 +80,7 @@ import Simplex.Chat.Store.Shared
import Simplex.Chat.Types import Simplex.Chat.Types
import Simplex.Chat.Types.Preferences import Simplex.Chat.Types.Preferences
import Simplex.Chat.Types.Shared import Simplex.Chat.Types.Shared
import Simplex.Chat.Util (liftIOEither) import Simplex.Chat.Util (liftIOEither, neUnzip3)
import qualified Simplex.Chat.Util as U import qualified Simplex.Chat.Util as U
import Simplex.FileTransfer.Description (FileDescriptionURI (..), maxFileSize, maxFileSizeHard) import Simplex.FileTransfer.Description (FileDescriptionURI (..), maxFileSize, maxFileSizeHard)
import Simplex.Messaging.Agent as Agent import Simplex.Messaging.Agent as Agent
@ -537,12 +537,13 @@ processChatCommand' vr = \case
Just <$> withFastStore (\db -> getAChatItem db vr user (ChatRef CTGroup gId) fwdItemId) Just <$> withFastStore (\db -> getAChatItem db vr user (ChatRef CTGroup gId) fwdItemId)
_ -> pure Nothing _ -> pure Nothing
APISendMessages (ChatRef cType chatId) live itemTTL cms -> withUser $ \user -> mapM_ assertAllowedContent' cms >> case cType of APISendMessages (ChatRef cType chatId) live itemTTL cms -> withUser $ \user -> mapM_ assertAllowedContent' cms >> case cType of
CTDirect -> CTDirect -> do
mapM_ assertNoMentions cms
withContactLock "sendMessage" chatId $ withContactLock "sendMessage" chatId $
sendContactContentMessages user chatId live itemTTL (L.map (,Nothing) cms) sendContactContentMessages user chatId live itemTTL (L.map composedMessageReq cms)
CTGroup -> CTGroup ->
withGroupLock "sendMessage" chatId $ withGroupLock "sendMessage" chatId $
sendGroupContentMessages user chatId live itemTTL (L.map (,Nothing) cms) sendGroupContentMessages user chatId live itemTTL (L.map composedMessageReq cms)
CTLocal -> pure $ chatCmdError (Just user) "not supported" CTLocal -> pure $ chatCmdError (Just user) "not supported"
CTContactRequest -> pure $ chatCmdError (Just user) "not supported" CTContactRequest -> pure $ chatCmdError (Just user) "not supported"
CTContactConnection -> pure $ chatCmdError (Just user) "not supported" CTContactConnection -> pure $ chatCmdError (Just user) "not supported"
@ -567,8 +568,8 @@ processChatCommand' vr = \case
withFastStore' $ \db -> reorderChatTags db user $ L.toList tagIds withFastStore' $ \db -> reorderChatTags db user $ L.toList tagIds
ok user ok user
APICreateChatItems folderId cms -> withUser $ \user -> do APICreateChatItems folderId cms -> withUser $ \user -> do
mapM_ assertAllowedContent' cms forM_ cms $ \cm -> assertAllowedContent' cm >> assertNoMentions cm
createNoteFolderContentItems user folderId (L.map (,Nothing) cms) createNoteFolderContentItems user folderId (L.map composedMessageReq cms)
APIReportMessage gId reportedItemId reportReason reportText -> withUser $ \user -> APIReportMessage gId reportedItemId reportReason reportText -> withUser $ \user ->
withGroupLock "reportMessage" gId $ do withGroupLock "reportMessage" gId $ do
(gInfo, ms) <- (gInfo, ms) <-
@ -577,9 +578,9 @@ processChatCommand' vr = \case
(gInfo,) <$> liftIO (getGroupModerators db vr user gInfo) (gInfo,) <$> liftIO (getGroupModerators db vr user gInfo)
let ms' = filter compatibleModerator ms let ms' = filter compatibleModerator ms
mc = MCReport reportText reportReason mc = MCReport reportText reportReason
cm = ComposedMessage {fileSource = Nothing, quotedItemId = Just reportedItemId, msgContent = mc} cm = ComposedMessage {fileSource = Nothing, quotedItemId = Just reportedItemId, msgContent = mc, mentions = M.empty}
when (null ms') $ throwChatError $ CECommandError "no moderators support receiving reports" when (null ms') $ throwChatError $ CECommandError "no moderators support receiving reports"
sendGroupContentMessages_ user gInfo ms' False Nothing [(cm, Nothing)] sendGroupContentMessages_ user gInfo ms' False Nothing [composedMessageReq cm]
where where
compatibleModerator GroupMember {activeConn, memberChatVRange} = compatibleModerator GroupMember {activeConn, memberChatVRange} =
maxVersion (maybe memberChatVRange peerChatVRange activeConn) >= contentReportsVersion maxVersion (maybe memberChatVRange peerChatVRange activeConn) >= contentReportsVersion
@ -587,8 +588,9 @@ processChatCommand' vr = \case
gId <- withFastStore $ \db -> getGroupIdByName db user groupName gId <- withFastStore $ \db -> getGroupIdByName db user groupName
reportedItemId <- withFastStore $ \db -> getGroupChatItemIdByText db user gId contactName_ reportedMessage reportedItemId <- withFastStore $ \db -> getGroupChatItemIdByText db user gId contactName_ reportedMessage
processChatCommand $ APIReportMessage gId reportedItemId reportReason "" processChatCommand $ APIReportMessage gId reportedItemId reportReason ""
APIUpdateChatItem (ChatRef cType chatId) itemId live mc -> withUser $ \user -> assertAllowedContent mc >> case cType of APIUpdateChatItem (ChatRef cType chatId) itemId live (UpdatedMessage mc mentions) -> withUser $ \user -> assertAllowedContent mc >> case cType of
CTDirect -> withContactLock "updateChatItem" chatId $ do CTDirect -> withContactLock "updateChatItem" chatId $ do
unless (null mentions) $ throwChatError $ CECommandError "mentions are not supported in this chat"
ct@Contact {contactId} <- withFastStore $ \db -> getContact db vr user chatId ct@Contact {contactId} <- withFastStore $ \db -> getContact db vr user chatId
assertDirectAllowed user MDSnd ct XMsgUpdate_ assertDirectAllowed user MDSnd ct XMsgUpdate_
cci <- withFastStore $ \db -> getDirectCIWithReactions db user ct itemId cci <- withFastStore $ \db -> getDirectCIWithReactions db user ct itemId
@ -599,7 +601,7 @@ processChatCommand' vr = \case
let changed = mc /= oldMC let changed = mc /= oldMC
if changed || fromMaybe False itemLive if changed || fromMaybe False itemLive
then do then do
(SndMessage {msgId}, _) <- sendDirectContactMessage user ct (XMsgUpdate itemSharedMId mc (ttl' <$> itemTimed) (justTrue . (live &&) =<< itemLive)) (SndMessage {msgId}, _) <- sendDirectContactMessage user ct (XMsgUpdate itemSharedMId mc M.empty (ttl' <$> itemTimed) (justTrue . (live &&) =<< itemLive))
ci' <- withFastStore' $ \db -> do ci' <- withFastStore' $ \db -> do
currentTs <- liftIO getCurrentTime currentTs <- liftIO getCurrentTime
when changed $ when changed $
@ -614,7 +616,8 @@ processChatCommand' vr = \case
CTGroup -> withGroupLock "updateChatItem" chatId $ do CTGroup -> withGroupLock "updateChatItem" chatId $ do
Group gInfo@GroupInfo {groupId, membership} ms <- withFastStore $ \db -> getGroup db vr user chatId Group gInfo@GroupInfo {groupId, membership} ms <- withFastStore $ \db -> getGroup db vr user chatId
assertUserGroupRole gInfo GRAuthor assertUserGroupRole gInfo GRAuthor
if prohibitedSimplexLinks gInfo membership mc let (_, ft_) = msgContentTexts mc
if prohibitedSimplexLinks gInfo membership ft_
then pure $ chatCmdError (Just user) ("feature not allowed " <> T.unpack (groupFeatureNameText GFSimplexLinks)) then pure $ chatCmdError (Just user) ("feature not allowed " <> T.unpack (groupFeatureNameText GFSimplexLinks))
else do else do
cci <- withFastStore $ \db -> getGroupCIWithReactions db user gInfo itemId cci <- withFastStore $ \db -> getGroupCIWithReactions db user gInfo itemId
@ -625,19 +628,22 @@ processChatCommand' vr = \case
let changed = mc /= oldMC let changed = mc /= oldMC
if changed || fromMaybe False itemLive if changed || fromMaybe False itemLive
then do then do
SndMessage {msgId} <- sendGroupMessage user gInfo ms (XMsgUpdate itemSharedMId mc (ttl' <$> itemTimed) (justTrue . (live &&) =<< itemLive)) (mentionedMembers, mentions') <- withFastStore $ \db -> getMentionedMembers db user gInfo ft_ mentions
SndMessage {msgId} <- sendGroupMessage user gInfo ms (XMsgUpdate itemSharedMId mc mentions' (ttl' <$> itemTimed) (justTrue . (live &&) =<< itemLive))
ci' <- withFastStore' $ \db -> do ci' <- withFastStore' $ \db -> do
currentTs <- liftIO getCurrentTime currentTs <- liftIO getCurrentTime
when changed $ when changed $
addInitialAndNewCIVersions db itemId (chatItemTs' ci, oldMC) (currentTs, mc) addInitialAndNewCIVersions db itemId (chatItemTs' ci, oldMC) (currentTs, mc)
let edited = itemLive /= Just True let edited = itemLive /= Just True
updateGroupChatItem db user groupId ci (CISndMsgContent mc) edited live $ Just msgId ci' <- updateGroupChatItem db user groupId ci (CISndMsgContent mc) edited live $ Just msgId
updateGroupCIMentions db gInfo ci' mentionedMembers
startUpdatedTimedItemThread user (ChatRef CTGroup groupId) ci ci' startUpdatedTimedItemThread user (ChatRef CTGroup groupId) ci ci'
pure $ CRChatItemUpdated user (AChatItem SCTGroup SMDSnd (GroupChat gInfo) ci') pure $ CRChatItemUpdated user (AChatItem SCTGroup SMDSnd (GroupChat gInfo) ci')
else pure $ CRChatItemNotChanged user (AChatItem SCTGroup SMDSnd (GroupChat gInfo) ci) else pure $ CRChatItemNotChanged user (AChatItem SCTGroup SMDSnd (GroupChat gInfo) ci)
_ -> throwChatError CEInvalidChatItemUpdate _ -> throwChatError CEInvalidChatItemUpdate
CChatItem SMDRcv _ -> throwChatError CEInvalidChatItemUpdate CChatItem SMDRcv _ -> throwChatError CEInvalidChatItemUpdate
CTLocal -> do CTLocal -> do
unless (null mentions) $ throwChatError $ CECommandError "mentions are not supported in this chat"
(nf@NoteFolder {noteFolderId}, cci) <- withFastStore $ \db -> (,) <$> getNoteFolder db user chatId <*> getLocalChatItem db user chatId itemId (nf@NoteFolder {noteFolderId}, cci) <- withFastStore $ \db -> (,) <$> getNoteFolder db user chatId <*> getLocalChatItem db user chatId itemId
case cci of case cci of
CChatItem SMDSnd ci@ChatItem {content = CISndMsgContent oldMC} CChatItem SMDSnd ci@ChatItem {content = CISndMsgContent oldMC}
@ -699,7 +705,7 @@ processChatCommand' vr = \case
itemsMsgIds :: [CChatItem c] -> [SharedMsgId] itemsMsgIds :: [CChatItem c] -> [SharedMsgId]
itemsMsgIds = mapMaybe (\(CChatItem _ ChatItem {meta = CIMeta {itemSharedMsgId}}) -> itemSharedMsgId) itemsMsgIds = mapMaybe (\(CChatItem _ ChatItem {meta = CIMeta {itemSharedMsgId}}) -> itemSharedMsgId)
APIDeleteMemberChatItem gId itemIds -> withUser $ \user -> withGroupLock "deleteChatItem" gId $ do APIDeleteMemberChatItem gId itemIds -> withUser $ \user -> withGroupLock "deleteChatItem" gId $ do
(gInfo@GroupInfo {membership}, items) <- getCommandGroupChatItems user gId itemIds (gInfo, items) <- getCommandGroupChatItems user gId itemIds
ms <- withFastStore' $ \db -> getGroupMembers db vr user gInfo ms <- withFastStore' $ \db -> getGroupMembers db vr user gInfo
assertDeletable gInfo items assertDeletable gInfo items
assertUserGroupRole gInfo GRAdmin -- TODO GRModerator when most users migrate assertUserGroupRole gInfo GRAdmin -- TODO GRModerator when most users migrate
@ -849,31 +855,33 @@ processChatCommand' vr = \case
CTContactRequest -> pure $ chatCmdError (Just user) "not supported" CTContactRequest -> pure $ chatCmdError (Just user) "not supported"
CTContactConnection -> pure $ chatCmdError (Just user) "not supported" CTContactConnection -> pure $ chatCmdError (Just user) "not supported"
where where
prepareForward :: User -> CM [ComposeMessageReq] prepareForward :: User -> CM [ComposedMessageReq]
prepareForward user = case fromCType of prepareForward user = case fromCType of
CTDirect -> withContactLock "forwardChatItem, from contact" fromChatId $ do CTDirect -> withContactLock "forwardChatItem, from contact" fromChatId $ do
(ct, items) <- getCommandDirectChatItems user fromChatId itemIds (ct, items) <- getCommandDirectChatItems user fromChatId itemIds
catMaybes <$> mapM (\ci -> ciComposeMsgReq ct ci <$$> prepareMsgReq ci) items catMaybes <$> mapM (\ci -> ciComposeMsgReq ct ci <$$> prepareMsgReq ci) items
where where
ciComposeMsgReq :: Contact -> CChatItem 'CTDirect -> (MsgContent, Maybe CryptoFile) -> ComposeMessageReq ciComposeMsgReq :: Contact -> CChatItem 'CTDirect -> (MsgContent, Maybe CryptoFile) -> ComposedMessageReq
ciComposeMsgReq ct (CChatItem md ci) (mc', file) = ciComposeMsgReq ct (CChatItem md ci) (mc', file) =
let itemId = chatItemId' ci let itemId = chatItemId' ci
ciff = forwardCIFF ci $ Just (CIFFContact (forwardName ct) (toMsgDirection md) (Just fromChatId) (Just itemId)) ciff = forwardCIFF ci $ Just (CIFFContact (forwardName ct) (toMsgDirection md) (Just fromChatId) (Just itemId))
in (ComposedMessage file Nothing mc', ciff) in (composedMessage file mc', ciff, msgContentTexts mc')
where where
forwardName :: Contact -> ContactName forwardName :: Contact -> ContactName
forwardName Contact {profile = LocalProfile {displayName, localAlias}} forwardName Contact {profile = LocalProfile {displayName, localAlias}}
| localAlias /= "" = localAlias | localAlias /= "" = localAlias
| otherwise = displayName | otherwise = displayName
CTGroup -> withGroupLock "forwardChatItem, from group" fromChatId $ do CTGroup -> withGroupLock "forwardChatItem, from group" fromChatId $ do
-- TODO [mentions] forward to the same group should retain mentions, and shouldn't read them again
-- update names?
(gInfo, items) <- getCommandGroupChatItems user fromChatId itemIds (gInfo, items) <- getCommandGroupChatItems user fromChatId itemIds
catMaybes <$> mapM (\ci -> ciComposeMsgReq gInfo ci <$$> prepareMsgReq ci) items catMaybes <$> mapM (\ci -> ciComposeMsgReq gInfo ci <$$> prepareMsgReq ci) items
where where
ciComposeMsgReq :: GroupInfo -> CChatItem 'CTGroup -> (MsgContent, Maybe CryptoFile) -> ComposeMessageReq ciComposeMsgReq :: GroupInfo -> CChatItem 'CTGroup -> (MsgContent, Maybe CryptoFile) -> ComposedMessageReq
ciComposeMsgReq gInfo (CChatItem md ci) (mc', file) = do ciComposeMsgReq gInfo (CChatItem md ci) (mc', file) = do
let itemId = chatItemId' ci let itemId = chatItemId' ci
ciff = forwardCIFF ci $ Just (CIFFGroup (forwardName gInfo) (toMsgDirection md) (Just fromChatId) (Just itemId)) ciff = forwardCIFF ci $ Just (CIFFGroup (forwardName gInfo) (toMsgDirection md) (Just fromChatId) (Just itemId))
in (ComposedMessage file Nothing mc', ciff) in (composedMessage file mc', ciff, msgContentTexts mc')
where where
forwardName :: GroupInfo -> ContactName forwardName :: GroupInfo -> ContactName
forwardName GroupInfo {groupProfile = GroupProfile {displayName}} = displayName forwardName GroupInfo {groupProfile = GroupProfile {displayName}} = displayName
@ -881,10 +889,10 @@ processChatCommand' vr = \case
(_, items) <- getCommandLocalChatItems user fromChatId itemIds (_, items) <- getCommandLocalChatItems user fromChatId itemIds
catMaybes <$> mapM (\ci -> ciComposeMsgReq ci <$$> prepareMsgReq ci) items catMaybes <$> mapM (\ci -> ciComposeMsgReq ci <$$> prepareMsgReq ci) items
where where
ciComposeMsgReq :: CChatItem 'CTLocal -> (MsgContent, Maybe CryptoFile) -> ComposeMessageReq ciComposeMsgReq :: CChatItem 'CTLocal -> (MsgContent, Maybe CryptoFile) -> ComposedMessageReq
ciComposeMsgReq (CChatItem _ ci) (mc', file) = ciComposeMsgReq (CChatItem _ ci) (mc', file) =
let ciff = forwardCIFF ci Nothing let ciff = forwardCIFF ci Nothing
in (ComposedMessage file Nothing mc', ciff) in (composedMessage file mc', ciff, msgContentTexts mc')
CTContactRequest -> throwChatError $ CECommandError "not supported" CTContactRequest -> throwChatError $ CECommandError "not supported"
CTContactConnection -> throwChatError $ CECommandError "not supported" CTContactConnection -> throwChatError $ CECommandError "not supported"
where where
@ -1288,7 +1296,6 @@ processChatCommand' vr = \case
liftIO $ setGroupUIThemes db user g uiThemes liftIO $ setGroupUIThemes db user g uiThemes
ok user ok user
_ -> pure $ chatCmdError (Just user) "not supported" _ -> pure $ chatCmdError (Just user) "not supported"
APIParseMarkdown text -> pure . CRApiParsedMarkdown $ parseMaybeMarkdownList text
APIGetNtfToken -> withUser' $ \_ -> crNtfToken <$> withAgent getNtfToken APIGetNtfToken -> withUser' $ \_ -> crNtfToken <$> withAgent getNtfToken
APIRegisterToken token mode -> withUser $ \_ -> APIRegisterToken token mode -> withUser $ \_ ->
CRNtfTokenStatus <$> withAgent (\a -> registerNtfToken a token mode) CRNtfTokenStatus <$> withAgent (\a -> registerNtfToken a token mode)
@ -1844,7 +1851,7 @@ processChatCommand' vr = \case
withFastStore' (\db -> runExceptT $ getContactIdByName db user name) >>= \case withFastStore' (\db -> runExceptT $ getContactIdByName db user name) >>= \case
Right ctId -> do Right ctId -> do
let chatRef = ChatRef CTDirect ctId let chatRef = ChatRef CTDirect ctId
processChatCommand $ APISendMessages chatRef False Nothing (ComposedMessage Nothing Nothing mc :| []) processChatCommand $ APISendMessages chatRef False Nothing [composedMessage Nothing mc]
Left _ -> Left _ ->
withFastStore' (\db -> runExceptT $ getActiveMembersByName db vr user name) >>= \case withFastStore' (\db -> runExceptT $ getActiveMembersByName db vr user name) >>= \case
Right [(gInfo, member)] -> do Right [(gInfo, member)] -> do
@ -1856,13 +1863,15 @@ processChatCommand' vr = \case
_ -> _ ->
throwChatError $ CEContactNotFound name Nothing throwChatError $ CEContactNotFound name Nothing
CTGroup -> do CTGroup -> do
gId <- withFastStore $ \db -> getGroupIdByName db user name (gId, mentions) <- withFastStore $ \db -> do
gId <- getGroupIdByName db user name
(gId,) <$> liftIO (getMessageMentions db user gId msg)
let chatRef = ChatRef CTGroup gId let chatRef = ChatRef CTGroup gId
processChatCommand $ APISendMessages chatRef False Nothing (ComposedMessage Nothing Nothing mc :| []) processChatCommand $ APISendMessages chatRef False Nothing [ComposedMessage Nothing Nothing mc mentions]
CTLocal CTLocal
| name == "" -> do | name == "" -> do
folderId <- withFastStore (`getUserNoteFolderId` user) folderId <- withFastStore (`getUserNoteFolderId` user)
processChatCommand $ APICreateChatItems folderId (ComposedMessage Nothing Nothing mc :| []) processChatCommand $ APICreateChatItems folderId [composedMessage Nothing mc]
| otherwise -> throwChatError $ CECommandError "not supported" | otherwise -> throwChatError $ CECommandError "not supported"
_ -> throwChatError $ CECommandError "not supported" _ -> throwChatError $ CECommandError "not supported"
SendMemberContactMessage gName mName msg -> withUser $ \user -> do SendMemberContactMessage gName mName msg -> withUser $ \user -> do
@ -1881,11 +1890,11 @@ processChatCommand' vr = \case
cr -> pure cr cr -> pure cr
Just ctId -> do Just ctId -> do
let chatRef = ChatRef CTDirect ctId let chatRef = ChatRef CTDirect ctId
processChatCommand $ APISendMessages chatRef False Nothing (ComposedMessage Nothing Nothing mc :| []) processChatCommand $ APISendMessages chatRef False Nothing [composedMessage Nothing mc]
SendLiveMessage chatName msg -> withUser $ \user -> do SendLiveMessage chatName msg -> withUser $ \user -> do
chatRef <- getChatRef user chatName (chatRef, mentions) <- getChatRefAndMentions user chatName msg
let mc = MCText msg let mc = MCText msg
processChatCommand $ APISendMessages chatRef True Nothing (ComposedMessage Nothing Nothing mc :| []) processChatCommand $ APISendMessages chatRef True Nothing [ComposedMessage Nothing Nothing mc mentions]
SendMessageBroadcast msg -> withUser $ \user -> do SendMessageBroadcast msg -> withUser $ \user -> do
contacts <- withFastStore' $ \db -> getUserContacts db vr user contacts <- withFastStore' $ \db -> getUserContacts db vr user
withChatLock "sendMessageBroadcast" . procCmd $ do withChatLock "sendMessageBroadcast" . procCmd $ do
@ -1926,7 +1935,7 @@ processChatCommand' vr = \case
contactId <- withFastStore $ \db -> getContactIdByName db user cName contactId <- withFastStore $ \db -> getContactIdByName db user cName
quotedItemId <- withFastStore $ \db -> getDirectChatItemIdByText db userId contactId msgDir quotedMsg quotedItemId <- withFastStore $ \db -> getDirectChatItemIdByText db userId contactId msgDir quotedMsg
let mc = MCText msg let mc = MCText msg
processChatCommand $ APISendMessages (ChatRef CTDirect contactId) False Nothing (ComposedMessage Nothing (Just quotedItemId) mc :| []) processChatCommand $ APISendMessages (ChatRef CTDirect contactId) False Nothing [ComposedMessage Nothing (Just quotedItemId) mc M.empty]
DeleteMessage chatName deletedMsg -> withUser $ \user -> do DeleteMessage chatName deletedMsg -> withUser $ \user -> do
chatRef <- getChatRef user chatName chatRef <- getChatRef user chatName
deletedItemId <- getSentChatItemIdByText user chatRef deletedMsg deletedItemId <- getSentChatItemIdByText user chatRef deletedMsg
@ -1936,14 +1945,14 @@ processChatCommand' vr = \case
deletedItemId <- withFastStore $ \db -> getGroupChatItemIdByText db user gId (Just mName) deletedMsg deletedItemId <- withFastStore $ \db -> getGroupChatItemIdByText db user gId (Just mName) deletedMsg
processChatCommand $ APIDeleteMemberChatItem gId (deletedItemId :| []) processChatCommand $ APIDeleteMemberChatItem gId (deletedItemId :| [])
EditMessage chatName editedMsg msg -> withUser $ \user -> do EditMessage chatName editedMsg msg -> withUser $ \user -> do
chatRef <- getChatRef user chatName (chatRef, mentions) <- getChatRefAndMentions user chatName msg
editedItemId <- getSentChatItemIdByText user chatRef editedMsg editedItemId <- getSentChatItemIdByText user chatRef editedMsg
let mc = MCText msg let mc = MCText msg
processChatCommand $ APIUpdateChatItem chatRef editedItemId False mc processChatCommand $ APIUpdateChatItem chatRef editedItemId False $ UpdatedMessage mc mentions
UpdateLiveMessage chatName chatItemId live msg -> withUser $ \user -> do UpdateLiveMessage chatName chatItemId live msg -> withUser $ \user -> do
chatRef <- getChatRef user chatName (chatRef, mentions) <- getChatRefAndMentions user chatName msg
let mc = MCText msg let mc = MCText msg
processChatCommand $ APIUpdateChatItem chatRef chatItemId live mc processChatCommand $ APIUpdateChatItem chatRef chatItemId live $ UpdatedMessage mc mentions
ReactToMessage add reaction chatName msg -> withUser $ \user -> do ReactToMessage add reaction chatName msg -> withUser $ \user -> do
chatRef <- getChatRef user chatName chatRef <- getChatRef user chatName
chatItemId <- getChatItemIdByText user chatRef msg chatItemId <- getChatItemIdByText user chatRef msg
@ -2213,10 +2222,13 @@ processChatCommand' vr = \case
groupId <- withFastStore $ \db -> getGroupIdByName db user gName groupId <- withFastStore $ \db -> getGroupIdByName db user gName
processChatCommand $ APIGetGroupLink groupId processChatCommand $ APIGetGroupLink groupId
SendGroupMessageQuote gName cName quotedMsg msg -> withUser $ \user -> do SendGroupMessageQuote gName cName quotedMsg msg -> withUser $ \user -> do
groupId <- withFastStore $ \db -> getGroupIdByName db user gName (groupId, quotedItemId, mentions) <-
quotedItemId <- withFastStore $ \db -> getGroupChatItemIdByText db user groupId cName quotedMsg withFastStore $ \db -> do
gId <- getGroupIdByName db user gName
qiId <- getGroupChatItemIdByText db user gId cName quotedMsg
(gId, qiId,) <$> liftIO (getMessageMentions db user gId msg)
let mc = MCText msg let mc = MCText msg
processChatCommand $ APISendMessages (ChatRef CTGroup groupId) False Nothing (ComposedMessage Nothing (Just quotedItemId) mc :| []) processChatCommand $ APISendMessages (ChatRef CTGroup groupId) False Nothing [ComposedMessage Nothing (Just quotedItemId) mc mentions]
ClearNoteFolder -> withUser $ \user -> do ClearNoteFolder -> withUser $ \user -> do
folderId <- withFastStore (`getUserNoteFolderId` user) folderId <- withFastStore (`getUserNoteFolderId` user)
processChatCommand $ APIClearChat (ChatRef CTLocal folderId) processChatCommand $ APIClearChat (ChatRef CTLocal folderId)
@ -2256,8 +2268,8 @@ processChatCommand' vr = \case
SendFile chatName f -> withUser $ \user -> do SendFile chatName f -> withUser $ \user -> do
chatRef <- getChatRef user chatName chatRef <- getChatRef user chatName
case chatRef of case chatRef of
ChatRef CTLocal folderId -> processChatCommand $ APICreateChatItems folderId (ComposedMessage (Just f) Nothing (MCFile "") :| []) ChatRef CTLocal folderId -> processChatCommand $ APICreateChatItems folderId [composedMessage (Just f) (MCFile "")]
_ -> processChatCommand $ APISendMessages chatRef False Nothing (ComposedMessage (Just f) Nothing (MCFile "") :| []) _ -> processChatCommand $ APISendMessages chatRef False Nothing [composedMessage (Just f) (MCFile "")]
SendImage chatName f@(CryptoFile fPath _) -> withUser $ \user -> do SendImage chatName f@(CryptoFile fPath _) -> withUser $ \user -> do
chatRef <- getChatRef user chatName chatRef <- getChatRef user chatName
filePath <- lift $ toFSFilePath fPath filePath <- lift $ toFSFilePath fPath
@ -2265,7 +2277,7 @@ processChatCommand' vr = \case
fileSize <- getFileSize filePath fileSize <- getFileSize filePath
unless (fileSize <= maxImageSize) $ throwChatError CEFileImageSize {filePath} unless (fileSize <= maxImageSize) $ throwChatError CEFileImageSize {filePath}
-- TODO include file description for preview -- TODO include file description for preview
processChatCommand $ APISendMessages chatRef False Nothing (ComposedMessage (Just f) Nothing (MCImage "" fixedImagePreview) :| []) processChatCommand $ APISendMessages chatRef False Nothing [composedMessage (Just f) (MCImage "" fixedImagePreview)]
ForwardFile chatName fileId -> forwardFile chatName fileId SendFile ForwardFile chatName fileId -> forwardFile chatName fileId SendFile
ForwardImage chatName fileId -> forwardFile chatName fileId SendImage ForwardImage chatName fileId -> forwardFile chatName fileId SendImage
SendFileDescription _chatName _f -> pure $ chatCmdError Nothing "TODO" SendFileDescription _chatName _f -> pure $ chatCmdError Nothing "TODO"
@ -2486,6 +2498,12 @@ processChatCommand' vr = \case
| name == "" -> withFastStore (`getUserNoteFolderId` user) | name == "" -> withFastStore (`getUserNoteFolderId` user)
| otherwise -> throwChatError $ CECommandError "not supported" | otherwise -> throwChatError $ CECommandError "not supported"
_ -> throwChatError $ CECommandError "not supported" _ -> throwChatError $ CECommandError "not supported"
getChatRefAndMentions :: User -> ChatName -> Text -> CM (ChatRef, Map MemberName GroupMemberId)
getChatRefAndMentions user cName msg = do
chatRef@(ChatRef cType chatId) <- getChatRef user cName
(chatRef,) <$> case cType of
CTGroup -> withFastStore' $ \db -> getMessageMentions db user chatId msg
_ -> pure []
#if !defined(dbPostgres) #if !defined(dbPostgres)
checkChatStopped :: CM ChatResponse -> CM ChatResponse checkChatStopped :: CM ChatResponse -> CM ChatResponse
checkChatStopped a = asks agentAsync >>= readTVarIO >>= maybe a (const $ throwChatError CEChatNotStopped) checkChatStopped a = asks agentAsync >>= readTVarIO >>= maybe a (const $ throwChatError CEChatNotStopped)
@ -2935,12 +2953,13 @@ processChatCommand' vr = \case
cReqHashes :: (ConnReqUriHash, ConnReqUriHash) cReqHashes :: (ConnReqUriHash, ConnReqUriHash)
cReqHashes = bimap hash hash cReqSchemas cReqHashes = bimap hash hash cReqSchemas
hash = ConnReqUriHash . C.sha256Hash . strEncode hash = ConnReqUriHash . C.sha256Hash . strEncode
updateCIGroupInvitationStatus :: User -> GroupInfo -> CIGroupInvitationStatus -> CM ()
updateCIGroupInvitationStatus user GroupInfo {groupId} newStatus = do updateCIGroupInvitationStatus user GroupInfo {groupId} newStatus = do
AChatItem _ _ cInfo ChatItem {content, meta = CIMeta {itemId}} <- withFastStore $ \db -> getChatItemByGroupId db vr user groupId AChatItem _ _ cInfo ChatItem {content, meta = CIMeta {itemId}} <- withFastStore $ \db -> getChatItemByGroupId db vr user groupId
case (cInfo, content) of case (cInfo, content) of
(DirectChat ct@Contact {contactId}, CIRcvGroupInvitation ciGroupInv@CIGroupInvitation {status} memRole) (DirectChat ct@Contact {contactId}, CIRcvGroupInvitation ciGroupInv@CIGroupInvitation {status} memRole)
| status == CIGISPending -> do | status == CIGISPending -> do
let aciContent = ACIContent SMDRcv $ CIRcvGroupInvitation ciGroupInv {status = newStatus} memRole let aciContent = ACIContent SMDRcv $ CIRcvGroupInvitation (ciGroupInv {status = newStatus} :: CIGroupInvitation) memRole
timed_ <- contactCITimed ct timed_ <- contactCITimed ct
updateDirectChatItemView user ct itemId aciContent False False timed_ Nothing updateDirectChatItemView user ct itemId aciContent False False timed_ Nothing
forM_ (timed_ >>= timedDeleteAt') $ forM_ (timed_ >>= timedDeleteAt') $
@ -2951,8 +2970,12 @@ processChatCommand' vr = \case
MCReport {} -> throwChatError $ CECommandError "sending reports via this API is not supported" MCReport {} -> throwChatError $ CECommandError "sending reports via this API is not supported"
_ -> pure () _ -> pure ()
assertAllowedContent' :: ComposedMessage -> CM () assertAllowedContent' :: ComposedMessage -> CM ()
assertAllowedContent' ComposedMessage {msgContent} = assertAllowedContent msgContent assertAllowedContent' ComposedMessage {msgContent} = assertAllowedContent msgContent
sendContactContentMessages :: User -> ContactId -> Bool -> Maybe Int -> NonEmpty ComposeMessageReq -> CM ChatResponse assertNoMentions :: ComposedMessage -> CM ()
assertNoMentions ComposedMessage {mentions}
| null mentions = pure ()
| otherwise = throwChatError $ CECommandError "mentions are not supported in this chat"
sendContactContentMessages :: User -> ContactId -> Bool -> Maybe Int -> NonEmpty ComposedMessageReq -> CM ChatResponse
sendContactContentMessages user contactId live itemTTL cmrs = do sendContactContentMessages user contactId live itemTTL cmrs = do
assertMultiSendable live cmrs assertMultiSendable live cmrs
ct@Contact {contactUsed} <- withFastStore $ \db -> getContact db vr user contactId ct@Contact {contactUsed} <- withFastStore $ \db -> getContact db vr user contactId
@ -2963,15 +2986,15 @@ processChatCommand' vr = \case
where where
assertVoiceAllowed :: Contact -> CM () assertVoiceAllowed :: Contact -> CM ()
assertVoiceAllowed ct = assertVoiceAllowed ct =
when (not (featureAllowed SCFVoice forUser ct) && any (\(ComposedMessage {msgContent}, _) -> isVoice msgContent) cmrs) $ when (not (featureAllowed SCFVoice forUser ct) && any (\(ComposedMessage {msgContent}, _, _) -> isVoice msgContent) cmrs) $
throwChatError (CECommandError $ "feature not allowed " <> T.unpack (chatFeatureNameText CFVoice)) throwChatError (CECommandError $ "feature not allowed " <> T.unpack (chatFeatureNameText CFVoice))
processComposedMessages :: Contact -> CM ChatResponse processComposedMessages :: Contact -> CM ChatResponse
processComposedMessages ct = do processComposedMessages ct = do
(fInvs_, ciFiles_) <- L.unzip <$> setupSndFileTransfers (fInvs_, ciFiles_) <- L.unzip <$> setupSndFileTransfers
timed_ <- sndContactCITimed live ct itemTTL timed_ <- sndContactCITimed live ct itemTTL
(msgContainers, quotedItems_) <- L.unzip <$> prepareMsgs (L.zip cmrs fInvs_) timed_ (msgContainers, quotedItems_, mms) <- neUnzip3 <$> prepareMsgs (L.zip cmrs fInvs_) timed_
msgs_ <- sendDirectContactMessages user ct $ L.map XMsgNew msgContainers msgs_ <- sendDirectContactMessages user ct $ L.map XMsgNew msgContainers
let itemsData = prepareSndItemsData msgs_ cmrs ciFiles_ quotedItems_ let itemsData = prepareSndItemsData (L.toList cmrs) (L.toList mms) (L.toList ciFiles_) (L.toList quotedItems_) msgs_
when (length itemsData /= length cmrs) $ logError "sendContactContentMessages: cmrs and itemsData length mismatch" when (length itemsData /= length cmrs) $ logError "sendContactContentMessages: cmrs and itemsData length mismatch"
r@(_, cis) <- partitionEithers <$> saveSndChatItems user (CDDirectSnd ct) itemsData timed_ live r@(_, cis) <- partitionEithers <$> saveSndChatItems user (CDDirectSnd ct) itemsData timed_ live
processSendErrs user r processSendErrs user r
@ -2982,39 +3005,40 @@ processChatCommand' vr = \case
where where
setupSndFileTransfers :: CM (NonEmpty (Maybe FileInvitation, Maybe (CIFile 'MDSnd))) setupSndFileTransfers :: CM (NonEmpty (Maybe FileInvitation, Maybe (CIFile 'MDSnd)))
setupSndFileTransfers = setupSndFileTransfers =
forM cmrs $ \(ComposedMessage {fileSource = file_}, _) -> case file_ of forM cmrs $ \(ComposedMessage {fileSource = file_}, _, _) -> case file_ of
Just file -> do Just file -> do
fileSize <- checkSndFile file fileSize <- checkSndFile file
(fInv, ciFile) <- xftpSndFileTransfer user file fileSize 1 $ CGContact ct (fInv, ciFile) <- xftpSndFileTransfer user file fileSize 1 $ CGContact ct
pure (Just fInv, Just ciFile) pure (Just fInv, Just ciFile)
Nothing -> pure (Nothing, Nothing) Nothing -> pure (Nothing, Nothing)
prepareMsgs :: NonEmpty (ComposeMessageReq, Maybe FileInvitation) -> Maybe CITimed -> CM (NonEmpty (MsgContainer, Maybe (CIQuote 'CTDirect))) prepareMsgs :: NonEmpty (ComposedMessageReq, Maybe FileInvitation) -> Maybe CITimed -> CM (NonEmpty (MsgContainer, Maybe (CIQuote 'CTDirect), (Map MemberName MentionedMember, Map MemberName MemberMention)))
prepareMsgs cmsFileInvs timed_ = prepareMsgs cmsFileInvs timed_ = withFastStore $ \db ->
forM cmsFileInvs $ \((ComposedMessage {quotedItemId, msgContent = mc}, itemForwarded), fInv_) -> forM cmsFileInvs $ \((ComposedMessage {quotedItemId, msgContent = mc}, itemForwarded, _), fInv_) -> do
let mms = (M.empty, M.empty)
case (quotedItemId, itemForwarded) of case (quotedItemId, itemForwarded) of
(Nothing, Nothing) -> pure (MCSimple (ExtMsgContent mc fInv_ (ttl' <$> timed_) (justTrue live)), Nothing) (Nothing, Nothing) -> pure (MCSimple (ExtMsgContent mc M.empty fInv_ (ttl' <$> timed_) (justTrue live)), Nothing, mms)
(Nothing, Just _) -> pure (MCForward (ExtMsgContent mc fInv_ (ttl' <$> timed_) (justTrue live)), Nothing) (Nothing, Just _) -> pure (MCForward (ExtMsgContent mc M.empty fInv_ (ttl' <$> timed_) (justTrue live)), Nothing, mms)
(Just qiId, Nothing) -> do (Just qiId, Nothing) -> do
CChatItem _ qci@ChatItem {meta = CIMeta {itemTs, itemSharedMsgId}, formattedText, file} <- CChatItem _ qci@ChatItem {meta = CIMeta {itemTs, itemSharedMsgId}, formattedText, file} <-
withFastStore $ \db -> getDirectChatItem db user contactId qiId getDirectChatItem db user contactId qiId
(origQmc, qd, sent) <- quoteData qci (origQmc, qd, sent) <- quoteData qci
let msgRef = MsgRef {msgId = itemSharedMsgId, sentAt = itemTs, sent, memberId = Nothing} let msgRef = MsgRef {msgId = itemSharedMsgId, sentAt = itemTs, sent, memberId = Nothing}
qmc = quoteContent mc origQmc file qmc = quoteContent mc origQmc file
quotedItem = CIQuote {chatDir = qd, itemId = Just qiId, sharedMsgId = itemSharedMsgId, sentAt = itemTs, content = qmc, formattedText} quotedItem = CIQuote {chatDir = qd, itemId = Just qiId, sharedMsgId = itemSharedMsgId, sentAt = itemTs, content = qmc, formattedText}
pure (MCQuote QuotedMsg {msgRef, content = qmc} (ExtMsgContent mc fInv_ (ttl' <$> timed_) (justTrue live)), Just quotedItem) pure (MCQuote QuotedMsg {msgRef, content = qmc} (ExtMsgContent mc M.empty fInv_ (ttl' <$> timed_) (justTrue live)), Just quotedItem, mms)
(Just _, Just _) -> throwChatError CEInvalidQuote (Just _, Just _) -> throwError SEInvalidQuote
where where
quoteData :: ChatItem c d -> CM (MsgContent, CIQDirection 'CTDirect, Bool) quoteData :: ChatItem c d -> ExceptT StoreError IO (MsgContent, CIQDirection 'CTDirect, Bool)
quoteData ChatItem {meta = CIMeta {itemDeleted = Just _}} = throwChatError CEInvalidQuote quoteData ChatItem {meta = CIMeta {itemDeleted = Just _}} = throwError SEInvalidQuote
quoteData ChatItem {content = CISndMsgContent qmc} = pure (qmc, CIQDirectSnd, True) quoteData ChatItem {content = CISndMsgContent qmc} = pure (qmc, CIQDirectSnd, True)
quoteData ChatItem {content = CIRcvMsgContent qmc} = pure (qmc, CIQDirectRcv, False) quoteData ChatItem {content = CIRcvMsgContent qmc} = pure (qmc, CIQDirectRcv, False)
quoteData _ = throwChatError CEInvalidQuote quoteData _ = throwError SEInvalidQuote
sendGroupContentMessages :: User -> GroupId -> Bool -> Maybe Int -> NonEmpty ComposeMessageReq -> CM ChatResponse sendGroupContentMessages :: User -> GroupId -> Bool -> Maybe Int -> NonEmpty ComposedMessageReq -> CM ChatResponse
sendGroupContentMessages user groupId live itemTTL cmrs = do sendGroupContentMessages user groupId live itemTTL cmrs = do
assertMultiSendable live cmrs assertMultiSendable live cmrs
Group gInfo ms <- withFastStore $ \db -> getGroup db vr user groupId Group gInfo ms <- withFastStore $ \db -> getGroup db vr user groupId
sendGroupContentMessages_ user gInfo ms live itemTTL cmrs sendGroupContentMessages_ user gInfo ms live itemTTL cmrs
sendGroupContentMessages_ :: User -> GroupInfo -> [GroupMember] -> Bool -> Maybe Int -> NonEmpty ComposeMessageReq -> CM ChatResponse sendGroupContentMessages_ :: User -> GroupInfo -> [GroupMember] -> Bool -> Maybe Int -> NonEmpty ComposedMessageReq -> CM ChatResponse
sendGroupContentMessages_ user gInfo@GroupInfo {groupId, membership} ms live itemTTL cmrs = do sendGroupContentMessages_ user gInfo@GroupInfo {groupId, membership} ms live itemTTL cmrs = do
assertUserGroupRole gInfo GRAuthor assertUserGroupRole gInfo GRAuthor
assertGroupContentAllowed assertGroupContentAllowed
@ -3026,18 +3050,18 @@ processChatCommand' vr = \case
Just f -> throwChatError (CECommandError $ "feature not allowed " <> T.unpack (groupFeatureNameText f)) Just f -> throwChatError (CECommandError $ "feature not allowed " <> T.unpack (groupFeatureNameText f))
Nothing -> pure () Nothing -> pure ()
where where
findProhibited :: [ComposeMessageReq] -> Maybe GroupFeature findProhibited :: [ComposedMessageReq] -> Maybe GroupFeature
findProhibited = findProhibited =
foldr' foldr'
(\(ComposedMessage {fileSource, msgContent = mc}, _) acc -> prohibitedGroupContent gInfo membership mc fileSource <|> acc) (\(ComposedMessage {fileSource, msgContent = mc}, _, (_, ft)) acc -> prohibitedGroupContent gInfo membership mc ft fileSource <|> acc)
Nothing Nothing
processComposedMessages :: CM ChatResponse processComposedMessages :: CM ChatResponse
processComposedMessages = do processComposedMessages = do
(fInvs_, ciFiles_) <- L.unzip <$> setupSndFileTransfers (length $ filter memberCurrent ms) (fInvs_, ciFiles_) <- L.unzip <$> setupSndFileTransfers (length $ filter memberCurrent ms)
timed_ <- sndGroupCITimed live gInfo itemTTL timed_ <- sndGroupCITimed live gInfo itemTTL
(msgContainers, quotedItems_) <- L.unzip <$> prepareMsgs (L.zip cmrs fInvs_) timed_ (msgContainers, quotedItems_, mms) <- neUnzip3 <$> prepareMsgs (L.zip cmrs fInvs_) timed_
(msgs_, gsr) <- sendGroupMessages user gInfo ms $ L.map XMsgNew msgContainers (msgs_, gsr) <- sendGroupMessages user gInfo ms $ L.map XMsgNew msgContainers
let itemsData = prepareSndItemsData (L.toList msgs_) cmrs ciFiles_ quotedItems_ let itemsData = prepareSndItemsData (L.toList cmrs) (L.toList mms) (L.toList ciFiles_) (L.toList quotedItems_) (L.toList msgs_)
cis_ <- saveSndChatItems user (CDGroupSnd gInfo) itemsData timed_ live cis_ <- saveSndChatItems user (CDGroupSnd gInfo) itemsData timed_ live
when (length itemsData /= length cmrs) $ logError "sendGroupContentMessages: cmrs and cis_ length mismatch" when (length itemsData /= length cmrs) $ logError "sendGroupContentMessages: cmrs and cis_ length mismatch"
createMemberSndStatuses cis_ msgs_ gsr createMemberSndStatuses cis_ msgs_ gsr
@ -3050,16 +3074,16 @@ processChatCommand' vr = \case
where where
setupSndFileTransfers :: Int -> CM (NonEmpty (Maybe FileInvitation, Maybe (CIFile 'MDSnd))) setupSndFileTransfers :: Int -> CM (NonEmpty (Maybe FileInvitation, Maybe (CIFile 'MDSnd)))
setupSndFileTransfers n = setupSndFileTransfers n =
forM cmrs $ \(ComposedMessage {fileSource = file_}, _) -> case file_ of forM cmrs $ \(ComposedMessage {fileSource = file_}, _, _) -> case file_ of
Just file -> do Just file -> do
fileSize <- checkSndFile file fileSize <- checkSndFile file
(fInv, ciFile) <- xftpSndFileTransfer user file fileSize n $ CGGroup gInfo ms (fInv, ciFile) <- xftpSndFileTransfer user file fileSize n $ CGGroup gInfo ms
pure (Just fInv, Just ciFile) pure (Just fInv, Just ciFile)
Nothing -> pure (Nothing, Nothing) Nothing -> pure (Nothing, Nothing)
prepareMsgs :: NonEmpty (ComposeMessageReq, Maybe FileInvitation) -> Maybe CITimed -> CM (NonEmpty (MsgContainer, Maybe (CIQuote 'CTGroup))) prepareMsgs :: NonEmpty (ComposedMessageReq, Maybe FileInvitation) -> Maybe CITimed -> CM (NonEmpty (MsgContainer, Maybe (CIQuote 'CTGroup), (Map MemberName MentionedMember, Map MemberName MemberMention)))
prepareMsgs cmsFileInvs timed_ = prepareMsgs cmsFileInvs timed_ = withFastStore $ \db ->
forM cmsFileInvs $ \((ComposedMessage {quotedItemId, msgContent = mc}, itemForwarded), fInv_) -> forM cmsFileInvs $ \((ComposedMessage {quotedItemId, msgContent = mc, mentions}, itemForwarded, (_, ft_)), fInv_) ->
prepareGroupMsg user gInfo mc quotedItemId itemForwarded fInv_ timed_ live prepareGroupMsg db user gInfo mc ft_ mentions quotedItemId itemForwarded fInv_ timed_ live
createMemberSndStatuses :: createMemberSndStatuses ::
[Either ChatError (ChatItem 'CTGroup 'MDSnd)] -> [Either ChatError (ChatItem 'CTGroup 'MDSnd)] ->
NonEmpty (Either ChatError SndMessage) -> NonEmpty (Either ChatError SndMessage) ->
@ -3095,7 +3119,7 @@ processChatCommand' vr = \case
Right _ -> GSSInactive Right _ -> GSSInactive
Left e -> GSSError $ SndErrOther $ tshow e Left e -> GSSError $ SndErrOther $ tshow e
forM_ ciId_ $ \ciId -> createGroupSndStatus db ciId mId status forM_ ciId_ $ \ciId -> createGroupSndStatus db ciId mId status
assertMultiSendable :: Bool -> NonEmpty ComposeMessageReq -> CM () assertMultiSendable :: Bool -> NonEmpty ComposedMessageReq -> CM ()
assertMultiSendable live cmrs assertMultiSendable live cmrs
| length cmrs == 1 = pure () | length cmrs == 1 = pure ()
| otherwise = | otherwise =
@ -3103,7 +3127,7 @@ processChatCommand' vr = \case
-- This is to support case of sending multiple attachments while also quoting another message. -- This is to support case of sending multiple attachments while also quoting another message.
-- UI doesn't allow composing with multiple quotes, so api prohibits it as well, and doesn't bother -- UI doesn't allow composing with multiple quotes, so api prohibits it as well, and doesn't bother
-- batching retrieval of quoted messages (prepareMsgs). -- batching retrieval of quoted messages (prepareMsgs).
when (live || length (L.filter (\(ComposedMessage {quotedItemId}, _) -> isJust quotedItemId) cmrs) > 1) $ when (live || length (L.filter (\(ComposedMessage {quotedItemId}, _, _) -> isJust quotedItemId) cmrs) > 1) $
throwChatError (CECommandError "invalid multi send: live and more than one quote not supported") throwChatError (CECommandError "invalid multi send: live and more than one quote not supported")
xftpSndFileTransfer :: User -> CryptoFile -> Integer -> Int -> ContactOrGroup -> CM (FileInvitation, CIFile 'MDSnd) xftpSndFileTransfer :: User -> CryptoFile -> Integer -> Int -> ContactOrGroup -> CM (FileInvitation, CIFile 'MDSnd)
xftpSndFileTransfer user file fileSize n contactOrGroup = do xftpSndFileTransfer user file fileSize n contactOrGroup = do
@ -3121,19 +3145,16 @@ processChatCommand' vr = \case
saveMemberFD _ = pure () saveMemberFD _ = pure ()
pure (fInv, ciFile) pure (fInv, ciFile)
prepareSndItemsData :: prepareSndItemsData ::
[ComposedMessageReq] ->
[(Map MemberName MentionedMember, Map MemberName MemberMention)] ->
[Maybe (CIFile 'MDSnd)] ->
[Maybe (CIQuote c)] ->
[Either ChatError SndMessage] -> [Either ChatError SndMessage] ->
NonEmpty ComposeMessageReq ->
NonEmpty (Maybe (CIFile 'MDSnd)) ->
NonEmpty (Maybe (CIQuote c)) ->
[Either ChatError (NewSndChatItemData c)] [Either ChatError (NewSndChatItemData c)]
prepareSndItemsData msgs_ cmrs' ciFiles_ quotedItems_ = prepareSndItemsData =
[ ( case msg_ of zipWith5 $ \(ComposedMessage {msgContent}, itemForwarded, ts) mm f q -> \case
Right msg -> Right $ NewSndChatItemData msg (CISndMsgContent msgContent) f q itemForwarded Right msg -> Right $ NewSndChatItemData msg (CISndMsgContent msgContent) ts mm f q itemForwarded
Left e -> Left e -- step over original error Left e -> Left e -- step over original error
)
| (msg_, (ComposedMessage {msgContent}, itemForwarded), f, q) <-
zipWith4 (,,,) msgs_ (L.toList cmrs') (L.toList ciFiles_) (L.toList quotedItems_)
]
processSendErrs :: User -> ([ChatError], [ChatItem c d]) -> CM () processSendErrs :: User -> ([ChatError], [ChatItem c d]) -> CM ()
processSendErrs user = \case processSendErrs user = \case
-- no errors -- no errors
@ -3178,7 +3199,7 @@ processChatCommand' vr = \case
forwardMsgContent ChatItem {content = CISndMsgContent fmc} = pure $ Just fmc forwardMsgContent ChatItem {content = CISndMsgContent fmc} = pure $ Just fmc
forwardMsgContent ChatItem {content = CIRcvMsgContent fmc} = pure $ Just fmc forwardMsgContent ChatItem {content = CIRcvMsgContent fmc} = pure $ Just fmc
forwardMsgContent _ = throwChatError CEInvalidForward forwardMsgContent _ = throwChatError CEInvalidForward
createNoteFolderContentItems :: User -> NoteFolderId -> NonEmpty ComposeMessageReq -> CM ChatResponse createNoteFolderContentItems :: User -> NoteFolderId -> NonEmpty ComposedMessageReq -> CM ChatResponse
createNoteFolderContentItems user folderId cmrs = do createNoteFolderContentItems user folderId cmrs = do
assertNoQuotes assertNoQuotes
nf <- withFastStore $ \db -> getNoteFolder db user folderId nf <- withFastStore $ \db -> getNoteFolder db user folderId
@ -3190,11 +3211,11 @@ processChatCommand' vr = \case
where where
assertNoQuotes :: CM () assertNoQuotes :: CM ()
assertNoQuotes = assertNoQuotes =
when (any (\(ComposedMessage {quotedItemId}, _) -> isJust quotedItemId) cmrs) $ when (any (\(ComposedMessage {quotedItemId}, _, _) -> isJust quotedItemId) cmrs) $
throwChatError (CECommandError "createNoteFolderContentItems: quotes not supported") throwChatError (CECommandError "createNoteFolderContentItems: quotes not supported")
createLocalFiles :: NoteFolder -> UTCTime -> CM (NonEmpty (Maybe (CIFile 'MDSnd))) createLocalFiles :: NoteFolder -> UTCTime -> CM (NonEmpty (Maybe (CIFile 'MDSnd)))
createLocalFiles nf createdAt = createLocalFiles nf createdAt =
forM cmrs $ \(ComposedMessage {fileSource = file_}, _) -> forM cmrs $ \(ComposedMessage {fileSource = file_}, _, _) ->
forM file_ $ \cf@CryptoFile {filePath, cryptoArgs} -> do forM file_ $ \cf@CryptoFile {filePath, cryptoArgs} -> do
fsFilePath <- lift $ toFSFilePath filePath fsFilePath <- lift $ toFSFilePath filePath
fileSize <- liftIO $ CF.getFileContentsSize $ CryptoFile fsFilePath cryptoArgs fileSize <- liftIO $ CF.getFileContentsSize $ CryptoFile fsFilePath cryptoArgs
@ -3203,13 +3224,12 @@ processChatCommand' vr = \case
fileId <- createLocalFile CIFSSndStored db user nf createdAt cf fileSize chunkSize fileId <- createLocalFile CIFSSndStored db user nf createdAt cf fileSize chunkSize
pure CIFile {fileId, fileName = takeFileName filePath, fileSize, fileSource = Just cf, fileStatus = CIFSSndStored, fileProtocol = FPLocal} pure CIFile {fileId, fileName = takeFileName filePath, fileSize, fileSource = Just cf, fileStatus = CIFSSndStored, fileProtocol = FPLocal}
prepareLocalItemsData :: prepareLocalItemsData ::
NonEmpty ComposeMessageReq -> NonEmpty ComposedMessageReq ->
NonEmpty (Maybe (CIFile 'MDSnd)) -> NonEmpty (Maybe (CIFile 'MDSnd)) ->
[(CIContent 'MDSnd, Maybe (CIFile 'MDSnd), Maybe CIForwardedFrom)] NonEmpty (CIContent 'MDSnd, Maybe (CIFile 'MDSnd), Maybe CIForwardedFrom, (Text, Maybe MarkdownList))
prepareLocalItemsData cmrs' ciFiles_ = prepareLocalItemsData =
[ (CISndMsgContent mc, f, itemForwarded) L.zipWith $ \(ComposedMessage {msgContent = mc}, itemForwarded, ts) f ->
| ((ComposedMessage {msgContent = mc}, itemForwarded), f) <- zip (L.toList cmrs') (L.toList ciFiles_) (CISndMsgContent mc, f, itemForwarded, ts)
]
getConnQueueInfo user Connection {connId, agentConnId = AgentConnId acId} = do getConnQueueInfo user Connection {connId, agentConnId = AgentConnId acId} = do
msgInfo <- withFastStore' (`getLastRcvMsgInfo` connId) msgInfo <- withFastStore' (`getLastRcvMsgInfo` connId)
CRQueueInfo user msgInfo <$> withAgent (`getConnectionQueueInfo` acId) CRQueueInfo user msgInfo <$> withAgent (`getConnectionQueueInfo` acId)
@ -3231,7 +3251,13 @@ updatedServers p' srvs UserOperatorServers {operator, smpServers, xftpServers} =
disableSrv srv@UserServer {preset} = disableSrv srv@UserServer {preset} =
AUS SDBStored $ if preset then srv {enabled = False} else srv {deleted = True} AUS SDBStored $ if preset then srv {enabled = False} else srv {deleted = True}
type ComposeMessageReq = (ComposedMessage, Maybe CIForwardedFrom) type ComposedMessageReq = (ComposedMessage, Maybe CIForwardedFrom, (Text, Maybe MarkdownList))
composedMessage :: Maybe CryptoFile -> MsgContent -> ComposedMessage
composedMessage f mc = ComposedMessage {fileSource = f, quotedItemId = Nothing, msgContent = mc, mentions = M.empty}
composedMessageReq :: ComposedMessage -> ComposedMessageReq
composedMessageReq cm@ComposedMessage {msgContent = mc} = (cm, Nothing, msgContentTexts mc)
data ChangedProfileContact = ChangedProfileContact data ChangedProfileContact = ChangedProfileContact
{ ct :: Contact, { ct :: Contact,
@ -3692,7 +3718,7 @@ chatCommandP =
"/_create *" *> (APICreateChatItems <$> A.decimal <*> (" json " *> jsonP <|> " text " *> composedMessagesTextP)), "/_create *" *> (APICreateChatItems <$> A.decimal <*> (" json " *> jsonP <|> " text " *> composedMessagesTextP)),
"/_report #" *> (APIReportMessage <$> A.decimal <* A.space <*> A.decimal <*> (" reason=" *> strP) <*> (A.space *> textP <|> pure "")), "/_report #" *> (APIReportMessage <$> A.decimal <* A.space <*> A.decimal <*> (" reason=" *> strP) <*> (A.space *> textP <|> pure "")),
"/report #" *> (ReportMessage <$> displayNameP <*> optional (" @" *> displayNameP) <*> _strP <* A.space <*> msgTextP), "/report #" *> (ReportMessage <$> displayNameP <*> optional (" @" *> displayNameP) <*> _strP <* A.space <*> msgTextP),
"/_update item " *> (APIUpdateChatItem <$> chatRefP <* A.space <*> A.decimal <*> liveMessageP <* A.space <*> msgContentP), "/_update item " *> (APIUpdateChatItem <$> chatRefP <* A.space <*> A.decimal <*> liveMessageP <*> (" json" *> jsonP <|> " text " *> updatedMessagesTextP)),
"/_delete item " *> (APIDeleteChatItem <$> chatRefP <*> _strP <*> _strP), "/_delete item " *> (APIDeleteChatItem <$> chatRefP <*> _strP <*> _strP),
"/_delete member item #" *> (APIDeleteMemberChatItem <$> A.decimal <*> _strP), "/_delete member item #" *> (APIDeleteMemberChatItem <$> A.decimal <*> _strP),
"/_reaction " *> (APIChatItemReaction <$> chatRefP <* A.space <*> A.decimal <* A.space <*> onOffP <* A.space <*> jsonP), "/_reaction " *> (APIChatItemReaction <$> chatRefP <* A.space <*> A.decimal <* A.space <*> onOffP <* A.space <*> jsonP),
@ -3725,7 +3751,6 @@ chatCommandP =
"/_set prefs @" *> (APISetContactPrefs <$> A.decimal <* A.space <*> jsonP), "/_set prefs @" *> (APISetContactPrefs <$> A.decimal <* A.space <*> jsonP),
"/_set theme user " *> (APISetUserUIThemes <$> A.decimal <*> optional (A.space *> jsonP)), "/_set theme user " *> (APISetUserUIThemes <$> A.decimal <*> optional (A.space *> jsonP)),
"/_set theme " *> (APISetChatUIThemes <$> chatRefP <*> optional (A.space *> jsonP)), "/_set theme " *> (APISetChatUIThemes <$> chatRefP <*> optional (A.space *> jsonP)),
"/_parse " *> (APIParseMarkdown . safeDecodeUtf8 <$> A.takeByteString),
"/_ntf get" $> APIGetNtfToken, "/_ntf get" $> APIGetNtfToken,
"/_ntf register " *> (APIRegisterToken <$> strP_ <*> strP), "/_ntf register " *> (APIRegisterToken <$> strP_ <*> strP),
"/_ntf verify " *> (APIVerifyToken <$> strP <* A.space <*> strP <* A.space <*> strP), "/_ntf verify " *> (APIVerifyToken <$> strP <* A.space <*> strP <* A.space <*> strP),
@ -4003,7 +4028,8 @@ chatCommandP =
c -> c c -> c
composedMessagesTextP = do composedMessagesTextP = do
text <- mcTextP text <- mcTextP
pure $ (ComposedMessage Nothing Nothing text) :| [] pure [composedMessage Nothing text]
updatedMessagesTextP = (`UpdatedMessage` []) <$> mcTextP
liveMessageP = " live=" *> onOffP <|> pure False liveMessageP = " live=" *> onOffP <|> pure False
sendMessageTTLP = " ttl=" *> ((Just <$> A.decimal) <|> ("default" $> Nothing)) <|> pure Nothing sendMessageTTLP = " ttl=" *> ((Just <$> A.decimal) <|> ("default" $> Nothing)) <|> pure Nothing
receiptSettings = do receiptSettings = do
@ -4123,7 +4149,7 @@ displayNameP = safeDecodeUtf8 <$> (quoted '\'' <|> takeNameTill (\c -> isSpace c
A.peekChar' >>= \c -> A.peekChar' >>= \c ->
if refChar c then A.takeTill p else fail "invalid first character in display name" if refChar c then A.takeTill p else fail "invalid first character in display name"
quoted c = A.char c *> takeNameTill (== c) <* A.char c quoted c = A.char c *> takeNameTill (== c) <* A.char c
refChar c = c > ' ' && c /= '#' && c /= '@' refChar c = c > ' ' && c /= '#' && c /= '@' && c /= '\''
mkValidName :: String -> String mkValidName :: String -> String
mkValidName = reverse . dropWhile isSpace . fst3 . foldl' addChar ("", '\NUL', 0 :: Int) mkValidName = reverse . dropWhile isSpace . fst3 . foldl' addChar ("", '\NUL', 0 :: Int)

174
src/Simplex/Chat/Library/Internal.hs
View file

@ -29,6 +29,7 @@ import Crypto.Random (ChaChaDRG)
import Data.Bifunctor (first) import Data.Bifunctor (first)
import Data.ByteString.Char8 (ByteString) import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Char8 as B
import Data.Containers.ListUtils (nubOrd)
import Data.Either (partitionEithers, rights) import Data.Either (partitionEithers, rights)
import Data.Fixed (div') import Data.Fixed (div')
import Data.Foldable (foldr') import Data.Foldable (foldr')
@ -102,6 +103,12 @@ import UnliftIO.STM
maxMsgReactions :: Int maxMsgReactions :: Int
maxMsgReactions = 3 maxMsgReactions = 3
maxRcvMentions :: Int
maxRcvMentions = 5
maxSndMentions :: Int
maxSndMentions = 3
withChatLock :: String -> CM a -> CM a withChatLock :: String -> CM a -> CM a
withChatLock name action = asks chatLock >>= \l -> withLock l name action withChatLock name action = asks chatLock >>= \l -> withLock l name action
@ -181,25 +188,76 @@ toggleNtf user m ntfOn =
forM_ (memberConnId m) $ \connId -> forM_ (memberConnId m) $ \connId ->
withAgent (\a -> toggleConnectionNtfs a connId ntfOn) `catchChatError` (toView . CRChatError (Just user)) withAgent (\a -> toggleConnectionNtfs a connId ntfOn) `catchChatError` (toView . CRChatError (Just user))
prepareGroupMsg :: User -> GroupInfo -> MsgContent -> Maybe ChatItemId -> Maybe CIForwardedFrom -> Maybe FileInvitation -> Maybe CITimed -> Bool -> CM (MsgContainer, Maybe (CIQuote 'CTGroup)) prepareGroupMsg :: DB.Connection -> User -> GroupInfo -> MsgContent -> Maybe MarkdownList -> Map MemberName GroupMemberId -> Maybe ChatItemId -> Maybe CIForwardedFrom -> Maybe FileInvitation -> Maybe CITimed -> Bool -> ExceptT StoreError IO (MsgContainer, Maybe (CIQuote 'CTGroup), (Map MemberName MentionedMember, Map MemberName MemberMention))
prepareGroupMsg user GroupInfo {groupId, membership} mc quotedItemId_ itemForwarded fInv_ timed_ live = case (quotedItemId_, itemForwarded) of prepareGroupMsg db user g@GroupInfo {groupId, membership} mc ft_ memberMentions quotedItemId_ itemForwarded fInv_ timed_ live = case (quotedItemId_, itemForwarded) of
(Nothing, Nothing) -> pure (MCSimple (ExtMsgContent mc fInv_ (ttl' <$> timed_) (justTrue live)), Nothing) (Nothing, Nothing) -> do
(Nothing, Just _) -> pure (MCForward (ExtMsgContent mc fInv_ (ttl' <$> timed_) (justTrue live)), Nothing) mms@(_, mentions) <- getMentionedMembers db user g ft_ memberMentions
pure (MCSimple (ExtMsgContent mc mentions fInv_ (ttl' <$> timed_) (justTrue live)), Nothing, mms)
(Nothing, Just _) ->
pure (MCForward (ExtMsgContent mc M.empty fInv_ (ttl' <$> timed_) (justTrue live)), Nothing, (M.empty, M.empty))
(Just quotedItemId, Nothing) -> do (Just quotedItemId, Nothing) -> do
mms@(_, mentions) <- getMentionedMembers db user g ft_ memberMentions
CChatItem _ qci@ChatItem {meta = CIMeta {itemTs, itemSharedMsgId}, formattedText, file} <- CChatItem _ qci@ChatItem {meta = CIMeta {itemTs, itemSharedMsgId}, formattedText, file} <-
withStore $ \db -> getGroupChatItem db user groupId quotedItemId getGroupChatItem db user groupId quotedItemId
(origQmc, qd, sent, GroupMember {memberId}) <- quoteData qci membership (origQmc, qd, sent, GroupMember {memberId}) <- quoteData qci membership
let msgRef = MsgRef {msgId = itemSharedMsgId, sentAt = itemTs, sent, memberId = Just memberId} let msgRef = MsgRef {msgId = itemSharedMsgId, sentAt = itemTs, sent, memberId = Just memberId}
qmc = quoteContent mc origQmc file qmc = quoteContent mc origQmc file
quotedItem = CIQuote {chatDir = qd, itemId = Just quotedItemId, sharedMsgId = itemSharedMsgId, sentAt = itemTs, content = qmc, formattedText} quotedItem = CIQuote {chatDir = qd, itemId = Just quotedItemId, sharedMsgId = itemSharedMsgId, sentAt = itemTs, content = qmc, formattedText}
pure (MCQuote QuotedMsg {msgRef, content = qmc} (ExtMsgContent mc fInv_ (ttl' <$> timed_) (justTrue live)), Just quotedItem) pure (MCQuote QuotedMsg {msgRef, content = qmc} (ExtMsgContent mc mentions fInv_ (ttl' <$> timed_) (justTrue live)), Just quotedItem, mms)
(Just _, Just _) -> throwChatError CEInvalidQuote (Just _, Just _) -> throwError SEInvalidQuote
where where
quoteData :: ChatItem c d -> GroupMember -> CM (MsgContent, CIQDirection 'CTGroup, Bool, GroupMember) quoteData :: ChatItem c d -> GroupMember -> ExceptT StoreError IO (MsgContent, CIQDirection 'CTGroup, Bool, GroupMember)
quoteData ChatItem {meta = CIMeta {itemDeleted = Just _}} _ = throwChatError CEInvalidQuote quoteData ChatItem {meta = CIMeta {itemDeleted = Just _}} _ = throwError SEInvalidQuote
quoteData ChatItem {chatDir = CIGroupSnd, content = CISndMsgContent qmc} membership' = pure (qmc, CIQGroupSnd, True, membership') quoteData ChatItem {chatDir = CIGroupSnd, content = CISndMsgContent qmc} membership' = pure (qmc, CIQGroupSnd, True, membership')
quoteData ChatItem {chatDir = CIGroupRcv m, content = CIRcvMsgContent qmc} _ = pure (qmc, CIQGroupRcv $ Just m, False, m) quoteData ChatItem {chatDir = CIGroupRcv m, content = CIRcvMsgContent qmc} _ = pure (qmc, CIQGroupRcv $ Just m, False, m)
quoteData _ _ = throwChatError CEInvalidQuote quoteData _ _ = throwError SEInvalidQuote
getMentionedMembers :: DB.Connection -> User -> GroupInfo -> Maybe MarkdownList -> Map MemberName GroupMemberId -> ExceptT StoreError IO (Map MemberName MentionedMember, Map MemberName MemberMention)
getMentionedMembers db user GroupInfo {groupId} ft_ mentions = case ft_ of
Just ft | not (null mentions) -> do
let msgMentions = S.fromList $ mentionedNames ft
n = M.size mentions
-- prevent "invisible" and repeated-with-different-name mentions (when the same member is mentioned via another name)
unless (n <= maxSndMentions && all (`S.member` msgMentions) (M.keys mentions) && S.size (S.fromList $ M.elems mentions) == n) $
throwError SEInvalidMention
mentionedMembers <- mapM (getMentionedGroupMember db user groupId) mentions
let mentions' = M.map (\MentionedMember {memberId} -> MemberMention {memberId}) mentionedMembers
pure (mentionedMembers, mentions')
_ -> pure (M.empty, M.empty)
getRcvMentionedMembers :: DB.Connection -> User -> GroupInfo -> Maybe MarkdownList -> Map MemberName MemberMention -> IO (Map MemberName MentionedMember)
getRcvMentionedMembers db user GroupInfo {groupId} ft_ mentions = case ft_ of
Just ft | not (null mentions) ->
let mentions' = uniqueMsgMentions maxRcvMentions mentions $ mentionedNames ft
in mapM (getMentionedMemberByMemberId db user groupId) mentions'
_ -> pure M.empty
-- prevent "invisible" and repeated-with-different-name mentions
uniqueMsgMentions :: Int -> Map MemberName MemberMention -> [ContactName] -> Map MemberName MemberMention
uniqueMsgMentions maxMentions mentions = go M.empty S.empty 0
where
go acc _ _ [] = acc
go acc seen n (name : rest)
| n >= maxMentions = acc
| otherwise = case M.lookup name mentions of
Just mm@MemberMention {memberId} | S.notMember memberId seen ->
go (M.insert name mm acc) (S.insert memberId seen) (n + 1) rest
_ -> go acc seen n rest
getMessageMentions :: DB.Connection -> User -> GroupId -> Text -> IO (Map MemberName GroupMemberId)
getMessageMentions db user gId msg = case parseMaybeMarkdownList msg of
Just ft -> M.fromList . catMaybes <$> mapM get (nubOrd $ mentionedNames ft)
Nothing -> pure M.empty
where
get name =
fmap (name,) . eitherToMaybe
<$> runExceptT (getGroupMemberIdByName db user gId name)
msgContentTexts :: MsgContent -> (Text, Maybe MarkdownList)
msgContentTexts mc = let t = msgContentText mc in (t, parseMaybeMarkdownList t)
ciContentTexts :: CIContent d -> (Text, Maybe MarkdownList)
ciContentTexts content = let t = ciContentToText content in (t, parseMaybeMarkdownList t)
quoteContent :: forall d. MsgContent -> MsgContent -> Maybe (CIFile d) -> MsgContent quoteContent :: forall d. MsgContent -> MsgContent -> Maybe (CIFile d) -> MsgContent
quoteContent mc qmc ciFile_ quoteContent mc qmc ciFile_
@ -228,17 +286,17 @@ quoteContent mc qmc ciFile_
qFileName = maybe qText (T.pack . getFileName) ciFile_ qFileName = maybe qText (T.pack . getFileName) ciFile_
qTextOrFile = if T.null qText then qFileName else qText qTextOrFile = if T.null qText then qFileName else qText
prohibitedGroupContent :: GroupInfo -> GroupMember -> MsgContent -> Maybe f -> Maybe GroupFeature prohibitedGroupContent :: GroupInfo -> GroupMember -> MsgContent -> Maybe MarkdownList -> Maybe f -> Maybe GroupFeature
prohibitedGroupContent gInfo m mc file_ prohibitedGroupContent gInfo m mc ft file_
| isVoice mc && not (groupFeatureMemberAllowed SGFVoice m gInfo) = Just GFVoice | isVoice mc && not (groupFeatureMemberAllowed SGFVoice m gInfo) = Just GFVoice
| not (isVoice mc) && isJust file_ && not (groupFeatureMemberAllowed SGFFiles m gInfo) = Just GFFiles | not (isVoice mc) && isJust file_ && not (groupFeatureMemberAllowed SGFFiles m gInfo) = Just GFFiles
| prohibitedSimplexLinks gInfo m mc = Just GFSimplexLinks | prohibitedSimplexLinks gInfo m ft = Just GFSimplexLinks
| otherwise = Nothing | otherwise = Nothing
prohibitedSimplexLinks :: GroupInfo -> GroupMember -> MsgContent -> Bool prohibitedSimplexLinks :: GroupInfo -> GroupMember -> Maybe MarkdownList -> Bool
prohibitedSimplexLinks gInfo m mc = prohibitedSimplexLinks gInfo m ft =
not (groupFeatureMemberAllowed SGFSimplexLinks m gInfo) not (groupFeatureMemberAllowed SGFSimplexLinks m gInfo)
&& maybe False (any ftIsSimplexLink) (parseMaybeMarkdownList $ msgContentText mc) && maybe False (any ftIsSimplexLink) ft
where where
ftIsSimplexLink :: FormattedText -> Bool ftIsSimplexLink :: FormattedText -> Bool
ftIsSimplexLink FormattedText {format} = maybe False isSimplexLink format ftIsSimplexLink FormattedText {format} = maybe False isSimplexLink format
@ -863,9 +921,6 @@ startUpdatedTimedItemThread user chatRef ci ci' =
metaBrokerTs :: MsgMeta -> UTCTime metaBrokerTs :: MsgMeta -> UTCTime
metaBrokerTs MsgMeta {broker = (_, brokerTs)} = brokerTs metaBrokerTs MsgMeta {broker = (_, brokerTs)} = brokerTs
sameMemberId :: MemberId -> GroupMember -> Bool
sameMemberId memId GroupMember {memberId} = memId == memberId
createContactPQSndItem :: User -> Contact -> Connection -> PQEncryption -> CM (Contact, Connection) createContactPQSndItem :: User -> Contact -> Connection -> PQEncryption -> CM (Contact, Connection)
createContactPQSndItem user ct conn@Connection {pqSndEnabled} pqSndEnabled' = createContactPQSndItem user ct conn@Connection {pqSndEnabled} pqSndEnabled' =
flip catchChatError (const $ pure (ct, conn)) $ case (pqSndEnabled, pqSndEnabled') of flip catchChatError (const $ pure (ct, conn)) $ case (pqSndEnabled, pqSndEnabled') of
@ -1549,15 +1604,20 @@ saveGroupFwdRcvMsg user groupId forwardingMember refAuthorMember@GroupMember {me
saveSndChatItem :: ChatTypeI c => User -> ChatDirection c 'MDSnd -> SndMessage -> CIContent 'MDSnd -> CM (ChatItem c 'MDSnd) saveSndChatItem :: ChatTypeI c => User -> ChatDirection c 'MDSnd -> SndMessage -> CIContent 'MDSnd -> CM (ChatItem c 'MDSnd)
saveSndChatItem user cd msg content = saveSndChatItem' user cd msg content Nothing Nothing Nothing Nothing False saveSndChatItem user cd msg content = saveSndChatItem' user cd msg content Nothing Nothing Nothing Nothing False
-- TODO [mentions] optimize by avoiding unnecesary parsing of control messages
saveSndChatItem' :: ChatTypeI c => User -> ChatDirection c 'MDSnd -> SndMessage -> CIContent 'MDSnd -> Maybe (CIFile 'MDSnd) -> Maybe (CIQuote c) -> Maybe CIForwardedFrom -> Maybe CITimed -> Bool -> CM (ChatItem c 'MDSnd) saveSndChatItem' :: ChatTypeI c => User -> ChatDirection c 'MDSnd -> SndMessage -> CIContent 'MDSnd -> Maybe (CIFile 'MDSnd) -> Maybe (CIQuote c) -> Maybe CIForwardedFrom -> Maybe CITimed -> Bool -> CM (ChatItem c 'MDSnd)
saveSndChatItem' user cd msg content ciFile quotedItem itemForwarded itemTimed live = saveSndChatItem' user cd msg content ciFile quotedItem itemForwarded itemTimed live = do
saveSndChatItems user cd [Right NewSndChatItemData {msg, content, ciFile, quotedItem, itemForwarded}] itemTimed live >>= \case let itemTexts = ciContentTexts content
itemMentions = (M.empty, M.empty)
saveSndChatItems user cd [Right NewSndChatItemData {msg, content, itemTexts, itemMentions, ciFile, quotedItem, itemForwarded}] itemTimed live >>= \case
[Right ci] -> pure ci [Right ci] -> pure ci
_ -> throwChatError $ CEInternalError "saveSndChatItem': expected 1 item" _ -> throwChatError $ CEInternalError "saveSndChatItem': expected 1 item"
data NewSndChatItemData c = NewSndChatItemData data NewSndChatItemData c = NewSndChatItemData
{ msg :: SndMessage, { msg :: SndMessage,
content :: CIContent 'MDSnd, content :: CIContent 'MDSnd,
itemTexts :: (Text, Maybe MarkdownList),
itemMentions :: (Map MemberName MentionedMember, Map MemberName MemberMention),
ciFile :: Maybe (CIFile 'MDSnd), ciFile :: Maybe (CIFile 'MDSnd),
quotedItem :: Maybe (CIQuote c), quotedItem :: Maybe (CIQuote c),
itemForwarded :: Maybe CIForwardedFrom itemForwarded :: Maybe CIForwardedFrom
@ -1579,31 +1639,57 @@ saveSndChatItems user cd itemsData itemTimed live = do
lift $ withStoreBatch (\db -> map (bindRight $ createItem db createdAt) itemsData) lift $ withStoreBatch (\db -> map (bindRight $ createItem db createdAt) itemsData)
where where
createItem :: DB.Connection -> UTCTime -> NewSndChatItemData c -> IO (Either ChatError (ChatItem c 'MDSnd)) createItem :: DB.Connection -> UTCTime -> NewSndChatItemData c -> IO (Either ChatError (ChatItem c 'MDSnd))
createItem db createdAt NewSndChatItemData {msg = msg@SndMessage {sharedMsgId}, content, ciFile, quotedItem, itemForwarded} = do createItem db createdAt NewSndChatItemData {msg = msg@SndMessage {sharedMsgId}, content, itemTexts, itemMentions, ciFile, quotedItem, itemForwarded} = do
ciId <- createNewSndChatItem db user cd msg content quotedItem itemForwarded itemTimed live createdAt ciId <- createNewSndChatItem db user cd msg content quotedItem itemForwarded itemTimed live createdAt
forM_ ciFile $ \CIFile {fileId} -> updateFileTransferChatItemId db fileId ciId createdAt forM_ ciFile $ \CIFile {fileId} -> updateFileTransferChatItemId db fileId ciId createdAt
pure $ Right $ mkChatItem cd ciId content ciFile quotedItem (Just sharedMsgId) itemForwarded itemTimed live createdAt Nothing createdAt let ci = mkChatItem_ cd ciId content itemTexts ciFile quotedItem (Just sharedMsgId) itemForwarded itemTimed live False createdAt Nothing createdAt
mentions = fst itemMentions
Right <$> case cd of
CDGroupSnd g | not (null mentions) -> createGroupCIMentions db g ci mentions
_ -> pure ci
saveRcvChatItem :: (ChatTypeI c, ChatTypeQuotable c) => User -> ChatDirection c 'MDRcv -> RcvMessage -> UTCTime -> CIContent 'MDRcv -> CM (ChatItem c 'MDRcv) saveRcvChatItemNoParse :: (ChatTypeI c, ChatTypeQuotable c) => User -> ChatDirection c 'MDRcv -> RcvMessage -> UTCTime -> CIContent 'MDRcv -> CM (ChatItem c 'MDRcv)
saveRcvChatItemNoParse user cd msg brokerTs = saveRcvChatItem user cd msg brokerTs . ciContentNoParse
saveRcvChatItem :: (ChatTypeI c, ChatTypeQuotable c) => User -> ChatDirection c 'MDRcv -> RcvMessage -> UTCTime -> (CIContent 'MDRcv, (Text, Maybe MarkdownList)) -> CM (ChatItem c 'MDRcv)
saveRcvChatItem user cd msg@RcvMessage {sharedMsgId_} brokerTs content = saveRcvChatItem user cd msg@RcvMessage {sharedMsgId_} brokerTs content =
saveRcvChatItem' user cd msg sharedMsgId_ brokerTs content Nothing Nothing False saveRcvChatItem' user cd msg sharedMsgId_ brokerTs content Nothing Nothing False M.empty
saveRcvChatItem' :: (ChatTypeI c, ChatTypeQuotable c) => User -> ChatDirection c 'MDRcv -> RcvMessage -> Maybe SharedMsgId -> UTCTime -> CIContent 'MDRcv -> Maybe (CIFile 'MDRcv) -> Maybe CITimed -> Bool -> CM (ChatItem c 'MDRcv) ciContentNoParse :: CIContent 'MDRcv -> (CIContent 'MDRcv, (Text, Maybe MarkdownList))
saveRcvChatItem' user cd msg@RcvMessage {forwardedByMember} sharedMsgId_ brokerTs content ciFile itemTimed live = do ciContentNoParse content = (content, (ciContentToText content, Nothing))
saveRcvChatItem' :: (ChatTypeI c, ChatTypeQuotable c) => User -> ChatDirection c 'MDRcv -> RcvMessage -> Maybe SharedMsgId -> UTCTime -> (CIContent 'MDRcv, (Text, Maybe MarkdownList)) -> Maybe (CIFile 'MDRcv) -> Maybe CITimed -> Bool -> Map MemberName MemberMention -> CM (ChatItem c 'MDRcv)
saveRcvChatItem' user cd msg@RcvMessage {chatMsgEvent, forwardedByMember} sharedMsgId_ brokerTs (content, (t, ft_)) ciFile itemTimed live mentions = do
createdAt <- liftIO getCurrentTime createdAt <- liftIO getCurrentTime
(ciId, quotedItem, itemForwarded) <- withStore' $ \db -> do withStore' $ \db -> do
when (ciRequiresAttention content || contactChatDeleted cd) $ updateChatTs db user cd createdAt when (ciRequiresAttention content || contactChatDeleted cd) $ updateChatTs db user cd createdAt
r@(ciId, _, _) <- createNewRcvChatItem db user cd msg sharedMsgId_ content itemTimed live brokerTs createdAt (mentions' :: Map MemberName MentionedMember, userMention) <- case cd of
CDGroupRcv g@GroupInfo {membership} _ -> do
mentions' <- getRcvMentionedMembers db user g ft_ mentions
let userReply = case cmToQuotedMsg chatMsgEvent of
Just QuotedMsg {msgRef = MsgRef {memberId = Just mId}} -> sameMemberId mId membership
_ -> False
userMention' = userReply || any (\MentionedMember {memberId} -> sameMemberId memberId membership) mentions'
in pure (mentions', userMention')
CDDirectRcv _ -> pure (M.empty, False)
(ciId, quotedItem, itemForwarded) <- createNewRcvChatItem db user cd msg sharedMsgId_ content itemTimed live userMention brokerTs createdAt
forM_ ciFile $ \CIFile {fileId} -> updateFileTransferChatItemId db fileId ciId createdAt forM_ ciFile $ \CIFile {fileId} -> updateFileTransferChatItemId db fileId ciId createdAt
pure r let ci = mkChatItem_ cd ciId content (t, ft_) ciFile quotedItem sharedMsgId_ itemForwarded itemTimed live userMention brokerTs forwardedByMember createdAt
pure $ mkChatItem cd ciId content ciFile quotedItem sharedMsgId_ itemForwarded itemTimed live brokerTs forwardedByMember createdAt case cd of
CDGroupRcv g _ | not (null mentions') -> createGroupCIMentions db g ci mentions'
_ -> pure ci
mkChatItem :: (ChatTypeI c, MsgDirectionI d) => ChatDirection c d -> ChatItemId -> CIContent d -> Maybe (CIFile d) -> Maybe (CIQuote c) -> Maybe SharedMsgId -> Maybe CIForwardedFrom -> Maybe CITimed -> Bool -> ChatItemTs -> Maybe GroupMemberId -> UTCTime -> ChatItem c d -- TODO [mentions] optimize by avoiding unnecessary parsing
mkChatItem cd ciId content file quotedItem sharedMsgId itemForwarded itemTimed live itemTs forwardedByMember currentTs = mkChatItem :: (ChatTypeI c, MsgDirectionI d) => ChatDirection c d -> ChatItemId -> CIContent d -> Maybe (CIFile d) -> Maybe (CIQuote c) -> Maybe SharedMsgId -> Maybe CIForwardedFrom -> Maybe CITimed -> Bool -> Bool -> ChatItemTs -> Maybe GroupMemberId -> UTCTime -> ChatItem c d
let itemText = ciContentToText content mkChatItem cd ciId content file quotedItem sharedMsgId itemForwarded itemTimed live userMention itemTs forwardedByMember currentTs =
itemStatus = ciCreateStatus content let ts = ciContentTexts content
meta = mkCIMeta ciId content itemText itemStatus Nothing sharedMsgId itemForwarded Nothing False itemTimed (justTrue live) currentTs itemTs forwardedByMember currentTs currentTs in mkChatItem_ cd ciId content ts file quotedItem sharedMsgId itemForwarded itemTimed live userMention itemTs forwardedByMember currentTs
in ChatItem {chatDir = toCIDirection cd, meta, content, formattedText = parseMaybeMarkdownList itemText, quotedItem, reactions = [], file}
mkChatItem_ :: (ChatTypeI c, MsgDirectionI d) => ChatDirection c d -> ChatItemId -> CIContent d -> (Text, Maybe MarkdownList) -> Maybe (CIFile d) -> Maybe (CIQuote c) -> Maybe SharedMsgId -> Maybe CIForwardedFrom -> Maybe CITimed -> Bool -> Bool -> ChatItemTs -> Maybe GroupMemberId -> UTCTime -> ChatItem c d
mkChatItem_ cd ciId content (itemText, formattedText) file quotedItem sharedMsgId itemForwarded itemTimed live userMention itemTs forwardedByMember currentTs =
let itemStatus = ciCreateStatus content
meta = mkCIMeta ciId content itemText itemStatus Nothing sharedMsgId itemForwarded Nothing False itemTimed (justTrue live) userMention currentTs itemTs forwardedByMember currentTs currentTs
in ChatItem {chatDir = toCIDirection cd, meta, content, mentions = M.empty, formattedText, quotedItem, reactions = [], file}
createAgentConnectionAsync :: ConnectionModeI c => User -> CommandFunction -> Bool -> SConnectionMode c -> SubscriptionMode -> CM (CommandId, ConnId) createAgentConnectionAsync :: ConnectionModeI c => User -> CommandFunction -> Bool -> SConnectionMode c -> SubscriptionMode -> CM (CommandId, ConnId)
createAgentConnectionAsync user cmdFunction enableNtfs cMode subMode = do createAgentConnectionAsync user cmdFunction enableNtfs cMode subMode = do
@ -1815,26 +1901,26 @@ createInternalItemsForChats user itemTs_ dirsCIContents = do
createACIs :: DB.Connection -> UTCTime -> UTCTime -> ChatDirection c d -> [CIContent d] -> [IO AChatItem] createACIs :: DB.Connection -> UTCTime -> UTCTime -> ChatDirection c d -> [CIContent d] -> [IO AChatItem]
createACIs db itemTs createdAt cd = map $ \content -> do createACIs db itemTs createdAt cd = map $ \content -> do
ciId <- createNewChatItemNoMsg db user cd content itemTs createdAt ciId <- createNewChatItemNoMsg db user cd content itemTs createdAt
let ci = mkChatItem cd ciId content Nothing Nothing Nothing Nothing Nothing False itemTs Nothing createdAt let ci = mkChatItem cd ciId content Nothing Nothing Nothing Nothing Nothing False False itemTs Nothing createdAt
pure $ AChatItem (chatTypeI @c) (msgDirection @d) (toChatInfo cd) ci pure $ AChatItem (chatTypeI @c) (msgDirection @d) (toChatInfo cd) ci
createLocalChatItems :: createLocalChatItems ::
User -> User ->
ChatDirection 'CTLocal 'MDSnd -> ChatDirection 'CTLocal 'MDSnd ->
[(CIContent 'MDSnd, Maybe (CIFile 'MDSnd), Maybe CIForwardedFrom)] -> NonEmpty (CIContent 'MDSnd, Maybe (CIFile 'MDSnd), Maybe CIForwardedFrom, (Text, Maybe MarkdownList)) ->
UTCTime -> UTCTime ->
CM [ChatItem 'CTLocal 'MDSnd] CM [ChatItem 'CTLocal 'MDSnd]
createLocalChatItems user cd itemsData createdAt = do createLocalChatItems user cd itemsData createdAt = do
withStore' $ \db -> updateChatTs db user cd createdAt withStore' $ \db -> updateChatTs db user cd createdAt
(errs, items) <- lift $ partitionEithers <$> withStoreBatch' (\db -> map (createItem db) itemsData) (errs, items) <- lift $ partitionEithers <$> withStoreBatch' (\db -> map (createItem db) $ L.toList itemsData)
unless (null errs) $ toView $ CRChatErrors (Just user) errs unless (null errs) $ toView $ CRChatErrors (Just user) errs
pure items pure items
where where
createItem :: DB.Connection -> (CIContent 'MDSnd, Maybe (CIFile 'MDSnd), Maybe CIForwardedFrom) -> IO (ChatItem 'CTLocal 'MDSnd) createItem :: DB.Connection -> (CIContent 'MDSnd, Maybe (CIFile 'MDSnd), Maybe CIForwardedFrom, (Text, Maybe MarkdownList)) -> IO (ChatItem 'CTLocal 'MDSnd)
createItem db (content, ciFile, itemForwarded) = do createItem db (content, ciFile, itemForwarded, ts) = do
ciId <- createNewChatItem_ db user cd Nothing Nothing content (Nothing, Nothing, Nothing, Nothing, Nothing) itemForwarded Nothing False createdAt Nothing createdAt ciId <- createNewChatItem_ db user cd Nothing Nothing content (Nothing, Nothing, Nothing, Nothing, Nothing) itemForwarded Nothing False False createdAt Nothing createdAt
forM_ ciFile $ \CIFile {fileId} -> updateFileTransferChatItemId db fileId ciId createdAt forM_ ciFile $ \CIFile {fileId} -> updateFileTransferChatItemId db fileId ciId createdAt
pure $ mkChatItem cd ciId content ciFile Nothing Nothing itemForwarded Nothing False createdAt Nothing createdAt pure $ mkChatItem_ cd ciId content ts ciFile Nothing Nothing itemForwarded Nothing False False createdAt Nothing createdAt
withUser' :: (User -> CM ChatResponse) -> CM ChatResponse withUser' :: (User -> CM ChatResponse) -> CM ChatResponse
withUser' action = withUser' action =

89
src/Simplex/Chat/Library/Subscriber.hs
View file

@ -31,6 +31,7 @@ import Data.Int (Int64)
import Data.List (foldl', partition) import Data.List (foldl', partition)
import Data.List.NonEmpty (NonEmpty (..), (<|)) import Data.List.NonEmpty (NonEmpty (..), (<|))
import qualified Data.List.NonEmpty as L import qualified Data.List.NonEmpty as L
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as M import qualified Data.Map.Strict as M
import Data.Maybe (catMaybes, fromMaybe, isJust, isNothing, mapMaybe) import Data.Maybe (catMaybes, fromMaybe, isJust, isNothing, mapMaybe)
import Data.Text (Text) import Data.Text (Text)
@ -500,7 +501,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
case event of case event of
XMsgNew mc -> newContentMessage ct'' mc msg msgMeta XMsgNew mc -> newContentMessage ct'' mc msg msgMeta
XMsgFileDescr sharedMsgId fileDescr -> messageFileDescription ct'' sharedMsgId fileDescr XMsgFileDescr sharedMsgId fileDescr -> messageFileDescription ct'' sharedMsgId fileDescr
XMsgUpdate sharedMsgId mContent ttl live -> messageUpdate ct'' sharedMsgId mContent msg msgMeta ttl live XMsgUpdate sharedMsgId mContent _ ttl live -> messageUpdate ct'' sharedMsgId mContent msg msgMeta ttl live
XMsgDel sharedMsgId _ -> messageDelete ct'' sharedMsgId msg msgMeta XMsgDel sharedMsgId _ -> messageDelete ct'' sharedMsgId msg msgMeta
XMsgReact sharedMsgId _ reaction add -> directMsgReaction ct'' sharedMsgId reaction add msg msgMeta XMsgReact sharedMsgId _ reaction add -> directMsgReaction ct'' sharedMsgId reaction add msg msgMeta
-- TODO discontinue XFile -- TODO discontinue XFile
@ -900,7 +901,9 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
let CIMeta {itemTs, itemSharedMsgId, itemTimed} = meta let CIMeta {itemTs, itemSharedMsgId, itemTimed} = meta
quotedItemId_ = quoteItemId =<< quotedItem quotedItemId_ = quoteItemId =<< quotedItem
fInv_ = fst <$> fInvDescr_ fInv_ = fst <$> fInvDescr_
(msgContainer, _) <- prepareGroupMsg user gInfo mc quotedItemId_ Nothing fInv_ itemTimed False -- TODO [mentions] history?
let (_t, ft_) = msgContentTexts mc
(msgContainer, _, _) <- withStore $ \db -> prepareGroupMsg db user gInfo mc ft_ M.empty quotedItemId_ Nothing fInv_ itemTimed False
let senderVRange = memberChatVRange' sender let senderVRange = memberChatVRange' sender
xMsgNewChatMsg = ChatMessage {chatVRange = senderVRange, msgId = itemSharedMsgId, chatMsgEvent = XMsgNew msgContainer} xMsgNewChatMsg = ChatMessage {chatVRange = senderVRange, msgId = itemSharedMsgId, chatMsgEvent = XMsgNew msgContainer}
fileDescrEvents <- case (snd <$> fInvDescr_, itemSharedMsgId) of fileDescrEvents <- case (snd <$> fInvDescr_, itemSharedMsgId) of
@ -966,7 +969,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
case event of case event of
XMsgNew mc -> memberCanSend m' $ newGroupContentMessage gInfo m' mc msg brokerTs False XMsgNew mc -> memberCanSend m' $ newGroupContentMessage gInfo m' mc msg brokerTs False
XMsgFileDescr sharedMsgId fileDescr -> memberCanSend m' $ groupMessageFileDescription gInfo m' sharedMsgId fileDescr XMsgFileDescr sharedMsgId fileDescr -> memberCanSend m' $ groupMessageFileDescription gInfo m' sharedMsgId fileDescr
XMsgUpdate sharedMsgId mContent ttl live -> memberCanSend m' $ groupMessageUpdate gInfo m' sharedMsgId mContent msg brokerTs ttl live XMsgUpdate sharedMsgId mContent mentions ttl live -> memberCanSend m' $ groupMessageUpdate gInfo m' sharedMsgId mContent mentions msg brokerTs ttl live
XMsgDel sharedMsgId memberId -> groupMessageDelete gInfo m' sharedMsgId memberId msg brokerTs XMsgDel sharedMsgId memberId -> groupMessageDelete gInfo m' sharedMsgId memberId msg brokerTs
XMsgReact sharedMsgId (Just memberId) reaction add -> groupMsgReaction gInfo m' sharedMsgId memberId reaction add msg brokerTs XMsgReact sharedMsgId (Just memberId) reaction add -> groupMsgReaction gInfo m' sharedMsgId memberId reaction add msg brokerTs
-- TODO discontinue XFile -- TODO discontinue XFile
@ -1539,7 +1542,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
newContentMessage :: Contact -> MsgContainer -> RcvMessage -> MsgMeta -> CM () newContentMessage :: Contact -> MsgContainer -> RcvMessage -> MsgMeta -> CM ()
newContentMessage ct@Contact {contactUsed} mc msg@RcvMessage {sharedMsgId_} msgMeta = do newContentMessage ct@Contact {contactUsed} mc msg@RcvMessage {sharedMsgId_} msgMeta = do
unless contactUsed $ withStore' $ \db -> updateContactUsed db user ct unless contactUsed $ withStore' $ \db -> updateContactUsed db user ct
let ExtMsgContent content fInv_ _ _ = mcExtMsgContent mc let ExtMsgContent content _ fInv_ _ _ = mcExtMsgContent mc
-- Uncomment to test stuck delivery on errors - see test testDirectMessageDelete -- Uncomment to test stuck delivery on errors - see test testDirectMessageDelete
-- case content of -- case content of
-- MCText "hello 111" -> -- MCText "hello 111" ->
@ -1548,18 +1551,18 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
-- _ -> pure () -- _ -> pure ()
if isVoice content && not (featureAllowed SCFVoice forContact ct) if isVoice content && not (featureAllowed SCFVoice forContact ct)
then do then do
void $ newChatItem (CIRcvChatFeatureRejected CFVoice) Nothing Nothing False void $ newChatItem (ciContentNoParse $ CIRcvChatFeatureRejected CFVoice) Nothing Nothing False
else do else do
let ExtMsgContent _ _ itemTTL live_ = mcExtMsgContent mc let ExtMsgContent _ _ _ itemTTL live_ = mcExtMsgContent mc
timed_ = rcvContactCITimed ct itemTTL timed_ = rcvContactCITimed ct itemTTL
live = fromMaybe False live_ live = fromMaybe False live_
file_ <- processFileInvitation fInv_ content $ \db -> createRcvFileTransfer db userId ct file_ <- processFileInvitation fInv_ content $ \db -> createRcvFileTransfer db userId ct
newChatItem (CIRcvMsgContent content) (snd <$> file_) timed_ live newChatItem (CIRcvMsgContent content, msgContentTexts content) (snd <$> file_) timed_ live
autoAcceptFile file_ autoAcceptFile file_
where where
brokerTs = metaBrokerTs msgMeta brokerTs = metaBrokerTs msgMeta
newChatItem ciContent ciFile_ timed_ live = do newChatItem content ciFile_ timed_ live = do
ci <- saveRcvChatItem' user (CDDirectRcv ct) msg sharedMsgId_ brokerTs ciContent ciFile_ timed_ live ci <- saveRcvChatItem' user (CDDirectRcv ct) msg sharedMsgId_ brokerTs content ciFile_ timed_ live M.empty
reactions <- maybe (pure []) (\sharedMsgId -> withStore' $ \db -> getDirectCIReactions db ct sharedMsgId) sharedMsgId_ reactions <- maybe (pure []) (\sharedMsgId -> withStore' $ \db -> getDirectCIReactions db ct sharedMsgId) sharedMsgId_
toView $ CRNewChatItems user [AChatItem SCTDirect SMDRcv (DirectChat ct) ci {reactions}] toView $ CRNewChatItems user [AChatItem SCTDirect SMDRcv (DirectChat ct) ci {reactions}]
@ -1625,7 +1628,8 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
-- received an update from the sender, so that it can be referenced later (e.g. by broadcast delete). -- 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... -- Chat item and update message which created it will have different sharedMsgId in this case...
let timed_ = rcvContactCITimed ct ttl let timed_ = rcvContactCITimed ct ttl
ci <- saveRcvChatItem' user (CDDirectRcv ct) msg (Just sharedMsgId) brokerTs content Nothing timed_ live ts = ciContentTexts content
ci <- saveRcvChatItem' user (CDDirectRcv ct) msg (Just sharedMsgId) brokerTs (content, ts) Nothing timed_ live M.empty
ci' <- withStore' $ \db -> do ci' <- withStore' $ \db -> do
createChatItemVersion db (chatItemId' ci) brokerTs mc createChatItemVersion db (chatItemId' ci) brokerTs mc
updateDirectChatItem' db user contactId ci content True live Nothing Nothing updateDirectChatItem' db user contactId ci content True live Nothing Nothing
@ -1728,7 +1732,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
newGroupContentMessage :: GroupInfo -> GroupMember -> MsgContainer -> RcvMessage -> UTCTime -> Bool -> CM () newGroupContentMessage :: GroupInfo -> GroupMember -> MsgContainer -> RcvMessage -> UTCTime -> Bool -> CM ()
newGroupContentMessage gInfo m@GroupMember {memberId, memberRole} mc msg@RcvMessage {sharedMsgId_} brokerTs forwarded newGroupContentMessage gInfo m@GroupMember {memberId, memberRole} mc msg@RcvMessage {sharedMsgId_} brokerTs forwarded
| blockedByAdmin m = createBlockedByAdmin | blockedByAdmin m = createBlockedByAdmin
| otherwise = case prohibitedGroupContent gInfo m content fInv_ of | otherwise = case prohibitedGroupContent gInfo m content ft_ fInv_ of
Just f -> rejected f Just f -> rejected f
Nothing -> Nothing ->
withStore' (\db -> getCIModeration db vr user gInfo memberId sharedMsgId_) >>= \case withStore' (\db -> getCIModeration db vr user gInfo memberId sharedMsgId_) >>= \case
@ -1737,13 +1741,14 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
withStore' $ \db -> deleteCIModeration db gInfo memberId sharedMsgId_ withStore' $ \db -> deleteCIModeration db gInfo memberId sharedMsgId_
Nothing -> createContentItem Nothing -> createContentItem
where where
rejected f = void $ newChatItem (CIRcvGroupFeatureRejected f) Nothing Nothing False rejected f = void $ newChatItem (ciContentNoParse $ CIRcvGroupFeatureRejected f) Nothing Nothing False
timed' = if forwarded then rcvCITimed_ (Just Nothing) itemTTL else rcvGroupCITimed gInfo itemTTL timed' = if forwarded then rcvCITimed_ (Just Nothing) itemTTL else rcvGroupCITimed gInfo itemTTL
live' = fromMaybe False live_ live' = fromMaybe False live_
ExtMsgContent content fInv_ itemTTL live_ = mcExtMsgContent mc ExtMsgContent content mentions fInv_ itemTTL live_ = mcExtMsgContent mc
ts@(_, ft_) = msgContentTexts content
createBlockedByAdmin createBlockedByAdmin
| groupFeatureAllowed SGFFullDelete gInfo = do -- ignores member role when blocked by admin | groupFeatureAllowed SGFFullDelete gInfo = do -- ignores member role when blocked by admin
ci <- saveRcvChatItem' user (CDGroupRcv gInfo m) msg sharedMsgId_ brokerTs CIRcvBlocked Nothing timed' False ci <- saveRcvChatItem' user (CDGroupRcv gInfo m) msg sharedMsgId_ brokerTs (ciContentNoParse CIRcvBlocked) Nothing timed' False M.empty
ci' <- withStore' $ \db -> updateGroupCIBlockedByAdmin db user gInfo ci brokerTs ci' <- withStore' $ \db -> updateGroupCIBlockedByAdmin db user gInfo ci brokerTs
groupMsgToView gInfo ci' groupMsgToView gInfo ci'
| otherwise = do | otherwise = do
@ -1755,7 +1760,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
| moderatorRole < GRModerator || moderatorRole < memberRole = | moderatorRole < GRModerator || moderatorRole < memberRole =
createContentItem createContentItem
| groupFeatureMemberAllowed SGFFullDelete moderator gInfo = do | groupFeatureMemberAllowed SGFFullDelete moderator gInfo = do
ci <- saveRcvChatItem' user (CDGroupRcv gInfo m) msg sharedMsgId_ brokerTs CIRcvModerated Nothing timed' False ci <- saveRcvChatItem' user (CDGroupRcv gInfo m) msg sharedMsgId_ brokerTs (ciContentNoParse CIRcvModerated) Nothing timed' False M.empty
ci' <- withStore' $ \db -> updateGroupChatItemModerated db user gInfo ci moderator moderatedAt ci' <- withStore' $ \db -> updateGroupChatItemModerated db user gInfo ci moderator moderatedAt
groupMsgToView gInfo ci' groupMsgToView gInfo ci'
| otherwise = do | otherwise = do
@ -1763,22 +1768,23 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
ci <- createNonLive file_ ci <- createNonLive file_
toView =<< markGroupCIsDeleted user gInfo [CChatItem SMDRcv ci] False (Just moderator) moderatedAt toView =<< markGroupCIsDeleted user gInfo [CChatItem SMDRcv ci] False (Just moderator) moderatedAt
createNonLive file_ = createNonLive file_ =
saveRcvChatItem' user (CDGroupRcv gInfo m) msg sharedMsgId_ brokerTs (CIRcvMsgContent content) (snd <$> file_) timed' False saveRcvChatItem' user (CDGroupRcv gInfo m) msg sharedMsgId_ brokerTs (CIRcvMsgContent content, ts) (snd <$> file_) timed' False mentions
createContentItem = do createContentItem = do
file_ <- processFileInv file_ <- processFileInv
newChatItem (CIRcvMsgContent content) (snd <$> file_) timed' live' newChatItem (CIRcvMsgContent content, ts) (snd <$> file_) timed' live'
when (showMessages $ memberSettings m) $ autoAcceptFile file_ when (showMessages $ memberSettings m) $ autoAcceptFile file_
processFileInv = processFileInv =
processFileInvitation fInv_ content $ \db -> createRcvGroupFileTransfer db userId m processFileInvitation fInv_ content $ \db -> createRcvGroupFileTransfer db userId m
newChatItem ciContent ciFile_ timed_ live = do newChatItem ciContent ciFile_ timed_ live = do
ci <- saveRcvChatItem' user (CDGroupRcv gInfo m) msg sharedMsgId_ brokerTs ciContent ciFile_ timed_ live let mentions' = if showMessages (memberSettings m) then mentions else []
ci <- saveRcvChatItem' user (CDGroupRcv gInfo m) msg sharedMsgId_ brokerTs ciContent ciFile_ timed_ live mentions'
ci' <- blockedMember m ci $ withStore' $ \db -> markGroupChatItemBlocked db user gInfo ci ci' <- blockedMember m ci $ withStore' $ \db -> markGroupChatItemBlocked db user gInfo ci
reactions <- maybe (pure []) (\sharedMsgId -> withStore' $ \db -> getGroupCIReactions db gInfo memberId sharedMsgId) sharedMsgId_ reactions <- maybe (pure []) (\sharedMsgId -> withStore' $ \db -> getGroupCIReactions db gInfo memberId sharedMsgId) sharedMsgId_
groupMsgToView gInfo ci' {reactions} groupMsgToView gInfo ci' {reactions}
groupMessageUpdate :: GroupInfo -> GroupMember -> SharedMsgId -> MsgContent -> RcvMessage -> UTCTime -> Maybe Int -> Maybe Bool -> CM () groupMessageUpdate :: GroupInfo -> GroupMember -> SharedMsgId -> MsgContent -> Map MemberName MemberMention -> RcvMessage -> UTCTime -> Maybe Int -> Maybe Bool -> CM ()
groupMessageUpdate gInfo@GroupInfo {groupId} m@GroupMember {groupMemberId, memberId} sharedMsgId mc msg@RcvMessage {msgId} brokerTs ttl_ live_ groupMessageUpdate gInfo@GroupInfo {groupId} m@GroupMember {groupMemberId, memberId} sharedMsgId mc mentions msg@RcvMessage {msgId} brokerTs ttl_ live_
| prohibitedSimplexLinks gInfo m mc = | prohibitedSimplexLinks gInfo m ft_ =
messageWarning $ "x.msg.update ignored: feature not allowed " <> groupFeatureNameText GFSimplexLinks messageWarning $ "x.msg.update ignored: feature not allowed " <> groupFeatureNameText GFSimplexLinks
| otherwise = do | otherwise = do
updateRcvChatItem `catchCINotFound` \_ -> do updateRcvChatItem `catchCINotFound` \_ -> do
@ -1786,7 +1792,8 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
-- received an update from the sender, so that it can be referenced later (e.g. by broadcast delete). -- 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... -- Chat item and update message which created it will have different sharedMsgId in this case...
let timed_ = rcvGroupCITimed gInfo ttl_ let timed_ = rcvGroupCITimed gInfo ttl_
ci <- saveRcvChatItem' user (CDGroupRcv gInfo m) msg (Just sharedMsgId) brokerTs content Nothing timed_ live mentions' = if showMessages (memberSettings m) then mentions else []
ci <- saveRcvChatItem' user (CDGroupRcv gInfo m) msg (Just sharedMsgId) brokerTs (content, ts) Nothing timed_ live mentions'
ci' <- withStore' $ \db -> do ci' <- withStore' $ \db -> do
createChatItemVersion db (chatItemId' ci) brokerTs mc createChatItemVersion db (chatItemId' ci) brokerTs mc
ci' <- updateGroupChatItem db user groupId ci content True live Nothing ci' <- updateGroupChatItem db user groupId ci content True live Nothing
@ -1794,6 +1801,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
toView $ CRChatItemUpdated user (AChatItem SCTGroup SMDRcv (GroupChat gInfo) ci') toView $ CRChatItemUpdated user (AChatItem SCTGroup SMDRcv (GroupChat gInfo) ci')
where where
content = CIRcvMsgContent mc content = CIRcvMsgContent mc
ts@(_, ft_) = msgContentTexts mc
live = fromMaybe False live_ live = fromMaybe False live_
updateRcvChatItem = do updateRcvChatItem = do
cci <- withStore $ \db -> getGroupChatItemBySharedMsgId db user groupId groupMemberId sharedMsgId cci <- withStore $ \db -> getGroupChatItemBySharedMsgId db user groupId groupMemberId sharedMsgId
@ -1809,7 +1817,9 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
addInitialAndNewCIVersions db (chatItemId' ci) (chatItemTs' ci, oldMC) (brokerTs, mc) addInitialAndNewCIVersions db (chatItemId' ci) (chatItemTs' ci, oldMC) (brokerTs, mc)
reactions <- getGroupCIReactions db gInfo memberId sharedMsgId reactions <- getGroupCIReactions db gInfo memberId sharedMsgId
let edited = itemLive /= Just True let edited = itemLive /= Just True
updateGroupChatItem db user groupId ci {reactions} content edited live $ Just msgId mentionedMembers <- getRcvMentionedMembers db user gInfo ft_ mentions
ci' <- updateGroupChatItem db user groupId ci {reactions} content edited live $ Just msgId
updateGroupCIMentions db gInfo ci' mentionedMembers
toView $ CRChatItemUpdated user (AChatItem SCTGroup SMDRcv (GroupChat gInfo) ci') toView $ CRChatItemUpdated user (AChatItem SCTGroup SMDRcv (GroupChat gInfo) ci')
startUpdatedTimedItemThread user (ChatRef CTGroup groupId) ci ci' startUpdatedTimedItemThread user (ChatRef CTGroup groupId) ci ci'
else toView $ CRChatItemNotChanged user (AChatItem SCTGroup SMDRcv (GroupChat gInfo) ci) else toView $ CRChatItemNotChanged user (AChatItem SCTGroup SMDRcv (GroupChat gInfo) ci)
@ -1870,7 +1880,8 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
RcvFileTransfer {fileId, xftpRcvFile} <- withStore $ \db -> createRcvFileTransfer db userId ct fInv inline fileChunkSize RcvFileTransfer {fileId, xftpRcvFile} <- withStore $ \db -> createRcvFileTransfer db userId ct fInv inline fileChunkSize
let fileProtocol = if isJust xftpRcvFile then FPXFTP else FPSMP let fileProtocol = if isJust xftpRcvFile then FPXFTP else FPSMP
ciFile = Just $ CIFile {fileId, fileName, fileSize, fileSource = Nothing, fileStatus = CIFSRcvInvitation, fileProtocol} ciFile = Just $ CIFile {fileId, fileName, fileSize, fileSource = Nothing, fileStatus = CIFSRcvInvitation, fileProtocol}
ci <- saveRcvChatItem' user (CDDirectRcv ct) msg sharedMsgId_ brokerTs (CIRcvMsgContent $ MCFile "") ciFile Nothing False content = ciContentNoParse $ CIRcvMsgContent $ MCFile ""
ci <- saveRcvChatItem' user (CDDirectRcv ct) msg sharedMsgId_ brokerTs content ciFile Nothing False M.empty
toView $ CRNewChatItems user [AChatItem SCTDirect SMDRcv (DirectChat ct) ci] toView $ CRNewChatItems user [AChatItem SCTDirect SMDRcv (DirectChat ct) ci]
where where
brokerTs = metaBrokerTs msgMeta brokerTs = metaBrokerTs msgMeta
@ -1883,7 +1894,8 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
RcvFileTransfer {fileId, xftpRcvFile} <- withStore $ \db -> createRcvGroupFileTransfer db userId m fInv inline fileChunkSize RcvFileTransfer {fileId, xftpRcvFile} <- withStore $ \db -> createRcvGroupFileTransfer db userId m fInv inline fileChunkSize
let fileProtocol = if isJust xftpRcvFile then FPXFTP else FPSMP let fileProtocol = if isJust xftpRcvFile then FPXFTP else FPSMP
ciFile = Just $ CIFile {fileId, fileName, fileSize, fileSource = Nothing, fileStatus = CIFSRcvInvitation, fileProtocol} ciFile = Just $ CIFile {fileId, fileName, fileSize, fileSource = Nothing, fileStatus = CIFSRcvInvitation, fileProtocol}
ci <- saveRcvChatItem' user (CDGroupRcv gInfo m) msg sharedMsgId_ brokerTs (CIRcvMsgContent $ MCFile "") ciFile Nothing False content = ciContentNoParse $ CIRcvMsgContent $ MCFile ""
ci <- saveRcvChatItem' user (CDGroupRcv gInfo m) msg sharedMsgId_ brokerTs content ciFile Nothing False M.empty
ci' <- blockedMember m ci $ withStore' $ \db -> markGroupChatItemBlocked db user gInfo ci ci' <- blockedMember m ci $ withStore' $ \db -> markGroupChatItemBlocked db user gInfo ci
groupMsgToView gInfo ci' groupMsgToView gInfo ci'
@ -2063,7 +2075,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
toView $ CRUserAcceptedGroupSent user gInfo {membership = membership {memberStatus = GSMemAccepted}} (Just ct) toView $ CRUserAcceptedGroupSent user gInfo {membership = membership {memberStatus = GSMemAccepted}} (Just ct)
else do else do
let content = CIRcvGroupInvitation (CIGroupInvitation {groupId, groupMemberId, localDisplayName, groupProfile, status = CIGISPending}) memRole let content = CIRcvGroupInvitation (CIGroupInvitation {groupId, groupMemberId, localDisplayName, groupProfile, status = CIGISPending}) memRole
ci <- saveRcvChatItem user (CDDirectRcv ct) msg brokerTs content ci <- saveRcvChatItemNoParse user (CDDirectRcv ct) msg brokerTs content
withStore' $ \db -> setGroupInvitationChatItemId db user groupId (chatItemId' ci) withStore' $ \db -> setGroupInvitationChatItemId db user groupId (chatItemId' ci)
toView $ CRNewChatItems user [AChatItem SCTDirect SMDRcv (DirectChat ct) ci] toView $ CRNewChatItems user [AChatItem SCTDirect SMDRcv (DirectChat ct) ci]
toView $ CRReceivedGroupInvitation {user, groupInfo = gInfo, contact = ct, fromMemberRole = fromRole, memberRole = memRole} toView $ CRReceivedGroupInvitation {user, groupInfo = gInfo, contact = ct, fromMemberRole = fromRole, memberRole = memRole}
@ -2091,7 +2103,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
forM_ contactConns $ \conn -> withStore' $ \db -> updateConnectionStatus db conn ConnDeleted forM_ contactConns $ \conn -> withStore' $ \db -> updateConnectionStatus db conn ConnDeleted
activeConn' <- forM (contactConn ct') $ \conn -> pure conn {connStatus = ConnDeleted} activeConn' <- forM (contactConn ct') $ \conn -> pure conn {connStatus = ConnDeleted}
let ct'' = ct' {activeConn = activeConn'} :: Contact let ct'' = ct' {activeConn = activeConn'} :: Contact
ci <- saveRcvChatItem user (CDDirectRcv ct'') msg brokerTs (CIRcvDirectEvent RDEContactDeleted) ci <- saveRcvChatItemNoParse user (CDDirectRcv ct'') msg brokerTs (CIRcvDirectEvent RDEContactDeleted)
toView $ CRNewChatItems user [AChatItem SCTDirect SMDRcv (DirectChat ct'') ci] toView $ CRNewChatItems user [AChatItem SCTDirect SMDRcv (DirectChat ct'') ci]
toView $ CRContactDeletedByContact user ct'' toView $ CRContactDeletedByContact user ct''
else do else do
@ -2300,9 +2312,10 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
else featureRejected CFCalls else featureRejected CFCalls
where where
brokerTs = metaBrokerTs msgMeta brokerTs = metaBrokerTs msgMeta
saveCallItem status = saveRcvChatItem user (CDDirectRcv ct) msg brokerTs (CIRcvCall status 0) saveCallItem status = saveRcvChatItemNoParse user (CDDirectRcv ct) msg brokerTs (CIRcvCall status 0)
featureRejected f = do featureRejected f = do
ci <- saveRcvChatItem' user (CDDirectRcv ct) msg sharedMsgId_ brokerTs (CIRcvChatFeatureRejected f) Nothing Nothing False let content = ciContentNoParse $ CIRcvChatFeatureRejected f
ci <- saveRcvChatItem' user (CDDirectRcv ct) msg sharedMsgId_ brokerTs content Nothing Nothing False M.empty
toView $ CRNewChatItems user [AChatItem SCTDirect SMDRcv (DirectChat ct) ci] toView $ CRNewChatItems user [AChatItem SCTDirect SMDRcv (DirectChat ct) ci]
-- to party initiating call -- to party initiating call
@ -2480,7 +2493,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
where where
memberAnnouncedToView announcedMember@GroupMember {groupMemberId, memberProfile} = do memberAnnouncedToView announcedMember@GroupMember {groupMemberId, memberProfile} = do
let event = RGEMemberAdded groupMemberId (fromLocalProfile memberProfile) let event = RGEMemberAdded groupMemberId (fromLocalProfile memberProfile)
ci <- saveRcvChatItem user (CDGroupRcv gInfo m) msg brokerTs (CIRcvGroupEvent event) ci <- saveRcvChatItemNoParse user (CDGroupRcv gInfo m) msg brokerTs (CIRcvGroupEvent event)
groupMsgToView gInfo ci groupMsgToView gInfo ci
toView $ CRJoinedGroupMemberConnecting user gInfo m announcedMember toView $ CRJoinedGroupMemberConnecting user gInfo m announcedMember
@ -2567,7 +2580,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
| senderRole < GRAdmin || senderRole < fromRole = messageError "x.grp.mem.role with insufficient member permissions" | senderRole < GRAdmin || senderRole < fromRole = messageError "x.grp.mem.role with insufficient member permissions"
| otherwise = do | otherwise = do
withStore' $ \db -> updateGroupMemberRole db user member memRole withStore' $ \db -> updateGroupMemberRole db user member memRole
ci <- saveRcvChatItem user (CDGroupRcv gInfo m) msg brokerTs (CIRcvGroupEvent gEvent) ci <- saveRcvChatItemNoParse user (CDGroupRcv gInfo m) msg brokerTs (CIRcvGroupEvent gEvent)
groupMsgToView gInfo ci groupMsgToView gInfo ci
toView CRMemberRole {user, groupInfo = gInfo', byMember = m, member = member {memberRole = memRole}, fromRole, toRole = memRole} toView CRMemberRole {user, groupInfo = gInfo', byMember = m, member = member {memberRole = memRole}, fromRole, toRole = memRole}
@ -2594,7 +2607,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
bm' <- setMemberBlocked bmId bm' <- setMemberBlocked bmId
toggleNtf user bm' (not blocked) toggleNtf user bm' (not blocked)
let ciContent = CIRcvGroupEvent $ RGEMemberBlocked bmId (fromLocalProfile bmp) blocked let ciContent = CIRcvGroupEvent $ RGEMemberBlocked bmId (fromLocalProfile bmp) blocked
ci <- saveRcvChatItem user (CDGroupRcv gInfo m) msg brokerTs ciContent ci <- saveRcvChatItemNoParse user (CDGroupRcv gInfo m) msg brokerTs ciContent
groupMsgToView gInfo ci groupMsgToView gInfo ci
toView CRMemberBlockedForAll {user, groupInfo = gInfo, byMember = m, member = bm, blocked} toView CRMemberBlockedForAll {user, groupInfo = gInfo, byMember = m, member = bm, blocked}
Left (SEGroupMemberNotFoundByMemberId _) -> do Left (SEGroupMemberNotFoundByMemberId _) -> do
@ -2679,7 +2692,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
messageError "x.grp.mem.del with insufficient member permissions" messageError "x.grp.mem.del with insufficient member permissions"
| otherwise = a | otherwise = a
deleteMemberItem gEvent = do deleteMemberItem gEvent = do
ci <- saveRcvChatItem user (CDGroupRcv gInfo m) msg brokerTs (CIRcvGroupEvent gEvent) ci <- saveRcvChatItemNoParse user (CDGroupRcv gInfo m) msg brokerTs (CIRcvGroupEvent gEvent)
groupMsgToView gInfo ci groupMsgToView gInfo ci
xGrpLeave :: GroupInfo -> GroupMember -> RcvMessage -> UTCTime -> CM () xGrpLeave :: GroupInfo -> GroupMember -> RcvMessage -> UTCTime -> CM ()
@ -2687,7 +2700,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
deleteMemberConnection user m deleteMemberConnection user m
-- member record is not deleted to allow creation of "member left" chat item -- member record is not deleted to allow creation of "member left" chat item
withStore' $ \db -> updateGroupMemberStatus db userId m GSMemLeft withStore' $ \db -> updateGroupMemberStatus db userId m GSMemLeft
ci <- saveRcvChatItem user (CDGroupRcv gInfo m) msg brokerTs (CIRcvGroupEvent RGEMemberLeft) ci <- saveRcvChatItemNoParse user (CDGroupRcv gInfo m) msg brokerTs (CIRcvGroupEvent RGEMemberLeft)
groupMsgToView gInfo ci groupMsgToView gInfo ci
toView $ CRLeftMember user gInfo m {memberStatus = GSMemLeft} toView $ CRLeftMember user gInfo m {memberStatus = GSMemLeft}
@ -2700,7 +2713,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
pure members pure members
-- member records are not deleted to keep history -- member records are not deleted to keep history
deleteMembersConnections user ms deleteMembersConnections user ms
ci <- saveRcvChatItem user (CDGroupRcv gInfo m) msg brokerTs (CIRcvGroupEvent RGEGroupDeleted) ci <- saveRcvChatItemNoParse user (CDGroupRcv gInfo m) msg brokerTs (CIRcvGroupEvent RGEGroupDeleted)
groupMsgToView gInfo ci groupMsgToView gInfo ci
toView $ CRGroupDeleted user gInfo {membership = membership {memberStatus = GSMemGroupDeleted}} m toView $ CRGroupDeleted user gInfo {membership = membership {memberStatus = GSMemGroupDeleted}} m
@ -2713,7 +2726,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
toView $ CRGroupUpdated user g g' (Just m) toView $ CRGroupUpdated user g g' (Just m)
let cd = CDGroupRcv g' m let cd = CDGroupRcv g' m
unless (sameGroupProfileInfo p p') $ do unless (sameGroupProfileInfo p p') $ do
ci <- saveRcvChatItem user cd msg brokerTs (CIRcvGroupEvent $ RGEGroupUpdated p') ci <- saveRcvChatItemNoParse user cd msg brokerTs (CIRcvGroupEvent $ RGEGroupUpdated p')
groupMsgToView g' ci groupMsgToView g' ci
createGroupFeatureChangedItems user cd CIRcvGroupFeature g g' createGroupFeatureChangedItems user cd CIRcvGroupFeature g g'
Just _ -> updateGroupPrefs_ g m $ fromMaybe defaultBusinessGroupPrefs $ groupPreferences p' Just _ -> updateGroupPrefs_ g m $ fromMaybe defaultBusinessGroupPrefs $ groupPreferences p'
@ -2772,7 +2785,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
createInternalChatItem user (CDGroupRcv g m') (CIRcvGroupEvent RGEMemberCreatedContact) Nothing createInternalChatItem user (CDGroupRcv g m') (CIRcvGroupEvent RGEMemberCreatedContact) Nothing
toView $ CRNewMemberContactReceivedInv user mCt' g m' toView $ CRNewMemberContactReceivedInv user mCt' g m'
forM_ mContent_ $ \mc -> do forM_ mContent_ $ \mc -> do
ci <- saveRcvChatItem user (CDDirectRcv mCt') msg brokerTs (CIRcvMsgContent mc) ci <- saveRcvChatItem user (CDDirectRcv mCt') msg brokerTs (CIRcvMsgContent mc, msgContentTexts mc)
toView $ CRNewChatItems user [AChatItem SCTDirect SMDRcv (DirectChat mCt') ci] toView $ CRNewChatItems user [AChatItem SCTDirect SMDRcv (DirectChat mCt') ci]
securityCodeChanged :: Contact -> CM () securityCodeChanged :: Contact -> CM ()
@ -2799,7 +2812,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
case event of case event of
XMsgNew mc -> memberCanSend author $ newGroupContentMessage gInfo author mc rcvMsg msgTs True XMsgNew mc -> memberCanSend author $ newGroupContentMessage gInfo author mc rcvMsg msgTs True
XMsgFileDescr sharedMsgId fileDescr -> memberCanSend author $ groupMessageFileDescription gInfo author sharedMsgId fileDescr XMsgFileDescr sharedMsgId fileDescr -> memberCanSend author $ groupMessageFileDescription gInfo author sharedMsgId fileDescr
XMsgUpdate sharedMsgId mContent ttl live -> memberCanSend author $ groupMessageUpdate gInfo author sharedMsgId mContent rcvMsg msgTs ttl live XMsgUpdate sharedMsgId mContent mentions ttl live -> memberCanSend author $ groupMessageUpdate gInfo author sharedMsgId mContent mentions rcvMsg msgTs ttl live
XMsgDel sharedMsgId memId -> groupMessageDelete gInfo author sharedMsgId memId rcvMsg msgTs XMsgDel sharedMsgId memId -> groupMessageDelete gInfo author sharedMsgId memId rcvMsg msgTs
XMsgReact sharedMsgId (Just memId) reaction add -> groupMsgReaction gInfo author sharedMsgId memId reaction add rcvMsg msgTs XMsgReact sharedMsgId (Just memId) reaction add -> groupMsgReaction gInfo author sharedMsgId memId reaction add rcvMsg msgTs
XFileCancel sharedMsgId -> xFileCancelGroup gInfo author sharedMsgId XFileCancel sharedMsgId -> xFileCancelGroup gInfo author sharedMsgId

27
src/Simplex/Chat/Markdown.hs
View file

@ -22,7 +22,7 @@ import Data.Functor (($>))
import Data.List (foldl', intercalate) import Data.List (foldl', intercalate)
import Data.List.NonEmpty (NonEmpty) import Data.List.NonEmpty (NonEmpty)
import qualified Data.List.NonEmpty as L import qualified Data.List.NonEmpty as L
import Data.Maybe (fromMaybe, isNothing) import Data.Maybe (fromMaybe, isNothing, mapMaybe)
import Data.Semigroup (sconcat) import Data.Semigroup (sconcat)
import Data.String import Data.String
import Data.Text (Text) import Data.Text (Text)
@ -50,18 +50,28 @@ data Format
| Colored {color :: FormatColor} | Colored {color :: FormatColor}
| Uri | Uri
| SimplexLink {linkType :: SimplexLinkType, simplexUri :: Text, smpHosts :: NonEmpty Text} | SimplexLink {linkType :: SimplexLinkType, simplexUri :: Text, smpHosts :: NonEmpty Text}
| Mention {memberName :: Text}
| Email | Email
| Phone | Phone
deriving (Eq, Show) deriving (Eq, Show)
mentionedNames :: MarkdownList -> [Text]
mentionedNames = mapMaybe (\(FormattedText f _) -> mentionedName =<< f)
where
mentionedName = \case
Mention name -> Just name
_ -> Nothing
data SimplexLinkType = XLContact | XLInvitation | XLGroup data SimplexLinkType = XLContact | XLInvitation | XLGroup
deriving (Eq, Show) deriving (Eq, Show)
colored :: Color -> Format colored :: Color -> Format
colored = Colored . FormatColor colored = Colored . FormatColor
{-# INLINE colored #-}
markdown :: Format -> Text -> Markdown markdown :: Format -> Text -> Markdown
markdown = Markdown . Just markdown = Markdown . Just
{-# INLINE markdown #-}
instance Semigroup Markdown where instance Semigroup Markdown where
m <> (Markdown _ "") = m m <> (Markdown _ "") = m
@ -163,6 +173,7 @@ markdownP = mconcat <$> A.many' fragmentP
'`' -> formattedP '`' Snippet '`' -> formattedP '`' Snippet
'#' -> A.char '#' *> secretP '#' -> A.char '#' *> secretP
'!' -> coloredP <|> wordP '!' -> coloredP <|> wordP
'@' -> mentionP
_ _
| isDigit c -> phoneP <|> wordP | isDigit c -> phoneP <|> wordP
| otherwise -> wordP | otherwise -> wordP
@ -192,6 +203,11 @@ markdownP = mconcat <$> A.many' fragmentP
if T.null s || T.last s == ' ' if T.null s || T.last s == ' '
then fail "not colored" then fail "not colored"
else pure $ markdown (colored clr) s else pure $ markdown (colored clr) s
mentionP = do
c <- A.char '@' *> A.peekChar'
name <- displayNameTextP
let sName = if c == '\'' then '\'' `T.cons` name `T.snoc` '\'' else name
pure $ markdown (Mention name) ('@' `T.cons` sName)
colorP = colorP =
A.anyChar >>= \case A.anyChar >>= \case
'r' -> "ed" $> Red <|> pure Red 'r' -> "ed" $> Red <|> pure Red
@ -251,6 +267,15 @@ markdownP = mconcat <$> A.many' fragmentP
Just (CRDataGroup _) -> XLGroup Just (CRDataGroup _) -> XLGroup
Nothing -> XLContact Nothing -> XLContact
displayNameTextP :: Parser Text
displayNameTextP = quoted '\'' <|> takeNameTill (== ' ')
where
takeNameTill p =
A.peekChar' >>= \c ->
if refChar c then A.takeTill p else fail "invalid first character in display name"
quoted c = A.char c *> takeNameTill (== c) <* A.char c
refChar c = c > ' ' && c /= '#' && c /= '@' && c /= '\''
$(JQ.deriveJSON (enumJSON $ dropPrefix "XL") ''SimplexLinkType) $(JQ.deriveJSON (enumJSON $ dropPrefix "XL") ''SimplexLinkType)
$(JQ.deriveJSON (sumTypeJSON fstToLower) ''Format) $(JQ.deriveJSON (sumTypeJSON fstToLower) ''Format)

51
src/Simplex/Chat/Messages.hs
View file

@ -31,6 +31,7 @@ import Data.Char (isSpace)
import Data.Int (Int64) import Data.Int (Int64)
import Data.Kind (Constraint) import Data.Kind (Constraint)
import Data.List.NonEmpty (NonEmpty) import Data.List.NonEmpty (NonEmpty)
import Data.Map.Strict (Map)
import Data.Maybe (fromMaybe, isJust, isNothing) import Data.Maybe (fromMaybe, isJust, isNothing)
import Data.Text (Text) import Data.Text (Text)
import qualified Data.Text as T import qualified Data.Text as T
@ -46,6 +47,7 @@ import Simplex.Chat.Options.DB (FromField (..), ToField (..))
import Simplex.Chat.Protocol import Simplex.Chat.Protocol
import Simplex.Chat.Types import Simplex.Chat.Types
import Simplex.Chat.Types.Preferences import Simplex.Chat.Types.Preferences
import Simplex.Chat.Types.Shared
import Simplex.Chat.Types.Util (textParseJSON) import Simplex.Chat.Types.Util (textParseJSON)
import Simplex.Messaging.Agent.Protocol (AgentMsgId, MsgMeta (..), MsgReceiptStatus (..)) import Simplex.Messaging.Agent.Protocol (AgentMsgId, MsgMeta (..), MsgReceiptStatus (..))
import Simplex.Messaging.Crypto.File (CryptoFile (..)) import Simplex.Messaging.Crypto.File (CryptoFile (..))
@ -150,6 +152,9 @@ data ChatItem (c :: ChatType) (d :: MsgDirection) = ChatItem
{ chatDir :: CIDirection c d, { chatDir :: CIDirection c d,
meta :: CIMeta c d, meta :: CIMeta c d,
content :: CIContent d, content :: CIContent d,
-- The `mentions` map prevents loading all members from UI.
-- The key is a name used in the message text, used to look up MentionedMember.
mentions :: Map MemberName MentionedMember,
formattedText :: Maybe MarkdownList, formattedText :: Maybe MarkdownList,
quotedItem :: Maybe (CIQuote c), quotedItem :: Maybe (CIQuote c),
reactions :: [CIReactionCount], reactions :: [CIReactionCount],
@ -157,18 +162,24 @@ data ChatItem (c :: ChatType) (d :: MsgDirection) = ChatItem
} }
deriving (Show) deriving (Show)
isMention :: ChatItem c d -> Bool data MentionedMember = MentionedMember
isMention ChatItem {chatDir, quotedItem} = case chatDir of { memberId :: MemberId,
CIDirectRcv -> userItem quotedItem -- member record can be created later than the mention is received
CIGroupRcv _ -> userItem quotedItem -- TODO [mentions] should we create member record for "unknown member" in this case?
_ -> False memberRef :: Maybe MentionedMemberInfo
where }
userItem = \case deriving (Eq, Show)
Nothing -> False
Just CIQuote {chatDir = cd} -> case cd of data MentionedMemberInfo = MentionedMemberInfo
CIQDirectSnd -> True { groupMemberId :: GroupMemberId,
CIQGroupSnd -> True displayName :: Text, -- use `displayName` in copy/share actions
_ -> False localAlias :: Maybe Text, -- use `fromMaybe displayName localAlias` in chat view
memberRole :: GroupMemberRole -- shown for admins/owners in the message
}
deriving (Eq, Show)
isUserMention :: ChatItem c d -> Bool
isUserMention ChatItem {meta = CIMeta {userMention}} = userMention
data CIDirection (c :: ChatType) (d :: MsgDirection) where data CIDirection (c :: ChatType) (d :: MsgDirection) where
CIDirectSnd :: CIDirection 'CTDirect 'MDSnd CIDirectSnd :: CIDirection 'CTDirect 'MDSnd
@ -364,6 +375,7 @@ data CIMeta (c :: ChatType) (d :: MsgDirection) = CIMeta
itemEdited :: Bool, itemEdited :: Bool,
itemTimed :: Maybe CITimed, itemTimed :: Maybe CITimed,
itemLive :: Maybe Bool, itemLive :: Maybe Bool,
userMention :: Bool, -- True for messages that mention user or reply to user messages
deletable :: Bool, deletable :: Bool,
editable :: Bool, editable :: Bool,
forwardedByMember :: Maybe GroupMemberId, forwardedByMember :: Maybe GroupMemberId,
@ -372,11 +384,11 @@ data CIMeta (c :: ChatType) (d :: MsgDirection) = CIMeta
} }
deriving (Show) deriving (Show)
mkCIMeta :: forall c d. ChatTypeI c => ChatItemId -> CIContent d -> Text -> CIStatus d -> Maybe Bool -> Maybe SharedMsgId -> Maybe CIForwardedFrom -> Maybe (CIDeleted c) -> Bool -> Maybe CITimed -> Maybe Bool -> UTCTime -> ChatItemTs -> Maybe GroupMemberId -> UTCTime -> UTCTime -> CIMeta c d mkCIMeta :: forall c d. ChatTypeI c => ChatItemId -> CIContent d -> Text -> CIStatus d -> Maybe Bool -> Maybe SharedMsgId -> Maybe CIForwardedFrom -> Maybe (CIDeleted c) -> Bool -> Maybe CITimed -> Maybe Bool -> Bool -> UTCTime -> ChatItemTs -> Maybe GroupMemberId -> UTCTime -> UTCTime -> CIMeta c d
mkCIMeta itemId itemContent itemText itemStatus sentViaProxy itemSharedMsgId itemForwarded itemDeleted itemEdited itemTimed itemLive currentTs itemTs forwardedByMember createdAt updatedAt = mkCIMeta itemId itemContent itemText itemStatus sentViaProxy itemSharedMsgId itemForwarded itemDeleted itemEdited itemTimed itemLive userMention currentTs itemTs forwardedByMember createdAt updatedAt =
let deletable = deletable' itemContent itemDeleted itemTs nominalDay currentTs let deletable = deletable' itemContent itemDeleted itemTs nominalDay currentTs
editable = deletable && isNothing itemForwarded editable = deletable && isNothing itemForwarded
in CIMeta {itemId, itemTs, itemText, itemStatus, sentViaProxy, itemSharedMsgId, itemForwarded, itemDeleted, itemEdited, itemTimed, itemLive, deletable, editable, forwardedByMember, createdAt, updatedAt} in CIMeta {itemId, itemTs, itemText, itemStatus, sentViaProxy, itemSharedMsgId, itemForwarded, itemDeleted, itemEdited, itemTimed, itemLive, userMention, deletable, editable, forwardedByMember, createdAt, updatedAt}
deletable' :: forall c d. ChatTypeI c => CIContent d -> Maybe (CIDeleted c) -> UTCTime -> NominalDiffTime -> UTCTime -> Bool deletable' :: forall c d. ChatTypeI c => CIContent d -> Maybe (CIDeleted c) -> UTCTime -> NominalDiffTime -> UTCTime -> Bool
deletable' itemContent itemDeleted itemTs allowedInterval currentTs = deletable' itemContent itemDeleted itemTs allowedInterval currentTs =
@ -401,6 +413,7 @@ dummyMeta itemId ts itemText =
itemEdited = False, itemEdited = False,
itemTimed = Nothing, itemTimed = Nothing,
itemLive = Nothing, itemLive = Nothing,
userMention = False,
deletable = False, deletable = False,
editable = False, editable = False,
forwardedByMember = Nothing, forwardedByMember = Nothing,
@ -1247,14 +1260,14 @@ data ChatItemVersion = ChatItemVersion
deriving (Eq, Show) deriving (Eq, Show)
mkItemVersion :: ChatItem c d -> Maybe ChatItemVersion mkItemVersion :: ChatItem c d -> Maybe ChatItemVersion
mkItemVersion ChatItem {content, meta} = version <$> ciMsgContent content mkItemVersion ChatItem {content, formattedText, meta} = version <$> ciMsgContent content
where where
CIMeta {itemId, itemTs, createdAt} = meta CIMeta {itemId, itemTs, createdAt} = meta
version mc = version mc =
ChatItemVersion ChatItemVersion
{ chatItemVersionId = itemId, { chatItemVersionId = itemId,
msgContent = mc, msgContent = mc,
formattedText = parseMaybeMarkdownList $ msgContentText mc, formattedText,
itemVersionTs = itemTs, itemVersionTs = itemTs,
createdAt = createdAt createdAt = createdAt
} }
@ -1387,6 +1400,10 @@ $(JQ.deriveToJSON defaultJSON ''CIQuote)
$(JQ.deriveJSON defaultJSON ''CIReactionCount) $(JQ.deriveJSON defaultJSON ''CIReactionCount)
$(JQ.deriveJSON defaultJSON ''MentionedMemberInfo)
$(JQ.deriveJSON defaultJSON ''MentionedMember)
instance (ChatTypeI c, MsgDirectionI d) => FromJSON (ChatItem c d) where instance (ChatTypeI c, MsgDirectionI d) => FromJSON (ChatItem c d) where
parseJSON = $(JQ.mkParseJSON defaultJSON ''ChatItem) parseJSON = $(JQ.mkParseJSON defaultJSON ''ChatItem)

46
src/Simplex/Chat/Protocol.hs
View file

@ -35,6 +35,8 @@ import Data.ByteString.Internal (c2w, w2c)
import qualified Data.ByteString.Lazy.Char8 as LB import qualified Data.ByteString.Lazy.Char8 as LB
import Data.List.NonEmpty (NonEmpty (..)) import Data.List.NonEmpty (NonEmpty (..))
import qualified Data.List.NonEmpty as L import qualified Data.List.NonEmpty as L
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as M
import Data.Maybe (fromMaybe, mapMaybe) import Data.Maybe (fromMaybe, mapMaybe)
import Data.String import Data.String
import Data.Text (Text) import Data.Text (Text)
@ -310,7 +312,7 @@ data AChatMessage = forall e. MsgEncodingI e => ACMsg (SMsgEncoding e) (ChatMess
data ChatMsgEvent (e :: MsgEncoding) where data ChatMsgEvent (e :: MsgEncoding) where
XMsgNew :: MsgContainer -> ChatMsgEvent 'Json XMsgNew :: MsgContainer -> ChatMsgEvent 'Json
XMsgFileDescr :: {msgId :: SharedMsgId, fileDescr :: FileDescr} -> ChatMsgEvent 'Json XMsgFileDescr :: {msgId :: SharedMsgId, fileDescr :: FileDescr} -> ChatMsgEvent 'Json
XMsgUpdate :: {msgId :: SharedMsgId, content :: MsgContent, ttl :: Maybe Int, live :: Maybe Bool} -> ChatMsgEvent 'Json XMsgUpdate :: {msgId :: SharedMsgId, content :: MsgContent, mentions :: Map MemberName MemberMention, ttl :: Maybe Int, live :: Maybe Bool} -> ChatMsgEvent 'Json
XMsgDel :: SharedMsgId -> Maybe MemberId -> ChatMsgEvent 'Json XMsgDel :: SharedMsgId -> Maybe MemberId -> ChatMsgEvent 'Json
XMsgDeleted :: ChatMsgEvent 'Json XMsgDeleted :: ChatMsgEvent 'Json
XMsgReact :: {msgId :: SharedMsgId, memberId :: Maybe MemberId, reaction :: MsgReaction, add :: Bool} -> ChatMsgEvent 'Json XMsgReact :: {msgId :: SharedMsgId, memberId :: Maybe MemberId, reaction :: MsgReaction, add :: Bool} -> ChatMsgEvent 'Json
@ -531,6 +533,11 @@ mcExtMsgContent = \case
MCComment _ c -> c MCComment _ c -> c
MCForward c -> c MCForward c -> c
isMCForward :: MsgContainer -> Bool
isMCForward = \case
MCForward _ -> True
_ -> False
data MsgContent data MsgContent
= MCText Text = MCText Text
| MCLink {text :: Text, preview :: LinkPreview} | MCLink {text :: Text, preview :: LinkPreview}
@ -589,9 +596,23 @@ msgContentTag = \case
MCReport {} -> MCReport_ MCReport {} -> MCReport_
MCUnknown {tag} -> MCUnknown_ tag MCUnknown {tag} -> MCUnknown_ tag
data ExtMsgContent = ExtMsgContent {content :: MsgContent, file :: Maybe FileInvitation, ttl :: Maybe Int, live :: Maybe Bool} data ExtMsgContent = ExtMsgContent
{ content :: MsgContent,
-- the key used in mentions is a locally (per message) unique display name of member.
-- Suffixes _1, _2 should be appended to make names locally unique.
-- It should be done in the UI, as they will be part of the text, and validated in the API.
mentions :: Map MemberName MemberMention,
file :: Maybe FileInvitation,
ttl :: Maybe Int,
live :: Maybe Bool
}
deriving (Eq, Show) deriving (Eq, Show)
data MemberMention = MemberMention {memberId :: MemberId}
deriving (Eq, Show)
$(JQ.deriveJSON defaultJSON ''MemberMention)
$(JQ.deriveJSON defaultJSON ''QuotedMsg) $(JQ.deriveJSON defaultJSON ''QuotedMsg)
-- this limit reserves space for metadata in forwarded messages -- this limit reserves space for metadata in forwarded messages
@ -657,10 +678,16 @@ parseMsgContainer v =
<|> (MCForward <$> ((v .: "forward" :: JT.Parser J.Object) *> mc)) <|> (MCForward <$> ((v .: "forward" :: JT.Parser J.Object) *> mc))
<|> MCSimple <$> mc <|> MCSimple <$> mc
where where
mc = ExtMsgContent <$> v .: "content" <*> v .:? "file" <*> v .:? "ttl" <*> v .:? "live" mc = do
content <- v .: "content"
file <- v .:? "file"
ttl <- v .:? "ttl"
live <- v .:? "live"
mentions <- fromMaybe M.empty <$> (v .:? "mentions")
pure ExtMsgContent {content, mentions, file, ttl, live}
extMsgContent :: MsgContent -> Maybe FileInvitation -> ExtMsgContent extMsgContent :: MsgContent -> Maybe FileInvitation -> ExtMsgContent
extMsgContent mc file = ExtMsgContent mc file Nothing Nothing extMsgContent mc file = ExtMsgContent mc M.empty file Nothing Nothing
justTrue :: Bool -> Maybe Bool justTrue :: Bool -> Maybe Bool
justTrue True = Just True justTrue True = Just True
@ -709,7 +736,12 @@ msgContainerJSON = \case
MCSimple mc -> o $ msgContent mc MCSimple mc -> o $ msgContent mc
where where
o = JM.fromList o = JM.fromList
msgContent (ExtMsgContent c file ttl live) = ("file" .=? file) $ ("ttl" .=? ttl) $ ("live" .=? live) ["content" .= c] msgContent ExtMsgContent {content, mentions, file, ttl, live} =
("file" .=? file) $ ("ttl" .=? ttl) $ ("live" .=? live) $ ("mentions" .=? nonEmptyMap mentions) ["content" .= content]
nonEmptyMap :: Map k v -> Maybe (Map k v)
nonEmptyMap m = if M.null m then Nothing else Just m
{-# INLINE nonEmptyMap #-}
instance ToJSON MsgContent where instance ToJSON MsgContent where
toJSON = \case toJSON = \case
@ -994,7 +1026,7 @@ appJsonToCM AppMessageJson {v, msgId, event, params} = do
msg = \case msg = \case
XMsgNew_ -> XMsgNew <$> JT.parseEither parseMsgContainer params XMsgNew_ -> XMsgNew <$> JT.parseEither parseMsgContainer params
XMsgFileDescr_ -> XMsgFileDescr <$> p "msgId" <*> p "fileDescr" XMsgFileDescr_ -> XMsgFileDescr <$> p "msgId" <*> p "fileDescr"
XMsgUpdate_ -> XMsgUpdate <$> p "msgId" <*> p "content" <*> opt "ttl" <*> opt "live" XMsgUpdate_ -> XMsgUpdate <$> p "msgId" <*> p "content" <*> (fromMaybe M.empty <$> opt "mentions") <*> opt "ttl" <*> opt "live"
XMsgDel_ -> XMsgDel <$> p "msgId" <*> opt "memberId" XMsgDel_ -> XMsgDel <$> p "msgId" <*> opt "memberId"
XMsgDeleted_ -> pure XMsgDeleted XMsgDeleted_ -> pure XMsgDeleted
XMsgReact_ -> XMsgReact <$> p "msgId" <*> opt "memberId" <*> p "reaction" <*> p "add" XMsgReact_ -> XMsgReact <$> p "msgId" <*> opt "memberId" <*> p "reaction" <*> p "add"
@ -1056,7 +1088,7 @@ chatToAppMessage ChatMessage {chatVRange, msgId, chatMsgEvent} = case encoding @
params = \case params = \case
XMsgNew container -> msgContainerJSON container XMsgNew container -> msgContainerJSON container
XMsgFileDescr msgId' fileDescr -> o ["msgId" .= msgId', "fileDescr" .= fileDescr] XMsgFileDescr msgId' fileDescr -> o ["msgId" .= msgId', "fileDescr" .= fileDescr]
XMsgUpdate msgId' content ttl live -> o $ ("ttl" .=? ttl) $ ("live" .=? live) ["msgId" .= msgId', "content" .= content] XMsgUpdate msgId' content mentions ttl live -> o $ ("ttl" .=? ttl) $ ("live" .=? live) $ ("mentions" .=? nonEmptyMap mentions) ["msgId" .= msgId', "content" .= content]
XMsgDel msgId' memberId -> o $ ("memberId" .=? memberId) ["msgId" .= msgId'] XMsgDel msgId' memberId -> o $ ("memberId" .=? memberId) ["msgId" .= msgId']
XMsgDeleted -> JM.empty XMsgDeleted -> JM.empty
XMsgReact msgId' memberId reaction add -> o $ ("memberId" .=? memberId) ["msgId" .= msgId', "reaction" .= reaction, "add" .= add] XMsgReact msgId' memberId reaction add -> o $ ("memberId" .=? memberId) ["msgId" .= msgId', "reaction" .= reaction, "add" .= add]

35
src/Simplex/Chat/Store/Groups.hs
View file

@ -47,6 +47,8 @@ module Simplex.Chat.Store.Groups
getActiveMembersByName, getActiveMembersByName,
getGroupInfoByName, getGroupInfoByName,
getGroupMember, getGroupMember,
getMentionedGroupMember,
getMentionedMemberByMemberId,
getGroupMemberById, getGroupMemberById,
getGroupMemberByMemberId, getGroupMemberByMemberId,
getGroupMembers, getGroupMembers,
@ -148,7 +150,7 @@ import Data.Ord (Down (..))
import Data.Text (Text) import Data.Text (Text)
import Data.Time.Clock (UTCTime (..), getCurrentTime) import Data.Time.Clock (UTCTime (..), getCurrentTime)
import Simplex.Chat.Messages import Simplex.Chat.Messages
import Simplex.Chat.Protocol (groupForwardVersion) import Simplex.Chat.Protocol (MemberMention (..), groupForwardVersion)
import Simplex.Chat.Store.Direct import Simplex.Chat.Store.Direct
import Simplex.Chat.Store.Shared import Simplex.Chat.Store.Shared
import Simplex.Chat.Types import Simplex.Chat.Types
@ -798,6 +800,37 @@ getGroupMember db vr user@User {userId} groupId groupMemberId =
(groupMemberQuery <> " WHERE m.group_id = ? AND m.group_member_id = ? AND m.user_id = ?") (groupMemberQuery <> " WHERE m.group_id = ? AND m.group_member_id = ? AND m.user_id = ?")
(userId, groupId, groupMemberId, userId) (userId, groupId, groupMemberId, userId)
getMentionedGroupMember :: DB.Connection -> User -> GroupId -> GroupMemberId -> ExceptT StoreError IO MentionedMember
getMentionedGroupMember db User {userId} groupId gmId =
ExceptT $ firstRow toMentionedMember (SEGroupMemberNotFound gmId) $
DB.query
db
(mentionedMemberQuery <> " WHERE m.group_id = ? AND m.group_member_id = ? AND m.user_id = ?")
(groupId, gmId, userId)
getMentionedMemberByMemberId :: DB.Connection -> User -> GroupId -> MemberMention -> IO MentionedMember
getMentionedMemberByMemberId db User {userId} groupId MemberMention {memberId} =
fmap (fromMaybe mentionedMember) $ maybeFirstRow toMentionedMember $
DB.query
db
(mentionedMemberQuery <> " WHERE m.group_id = ? AND m.member_id = ? AND m.user_id = ?")
(groupId, memberId, userId)
where
mentionedMember = MentionedMember {memberId, memberRef = Nothing}
mentionedMemberQuery :: Query
mentionedMemberQuery =
[sql|
SELECT m.group_member_id, m.member_id, m.member_role, p.display_name, p.local_alias
FROM group_members m
JOIN contact_profiles p ON p.contact_profile_id = COALESCE(m.member_profile_id, m.contact_profile_id)
|]
toMentionedMember :: (GroupMemberId, MemberId, GroupMemberRole, Text, Maybe Text) -> MentionedMember
toMentionedMember (groupMemberId, memberId, memberRole, displayName, localAlias) =
let memberRef = Just MentionedMemberInfo {groupMemberId, displayName, localAlias, memberRole}
in MentionedMember {memberId, memberRef}
getGroupMemberById :: DB.Connection -> VersionRangeChat -> User -> GroupMemberId -> ExceptT StoreError IO GroupMember getGroupMemberById :: DB.Connection -> VersionRangeChat -> User -> GroupMemberId -> ExceptT StoreError IO GroupMember
getGroupMemberById db vr user@User {userId} groupMemberId = getGroupMemberById db vr user@User {userId} groupMemberId =
ExceptT . firstRow (toContactMember vr user) (SEGroupMemberNotFound groupMemberId) $ ExceptT . firstRow (toContactMember vr user) (SEGroupMemberNotFound groupMemberId) $

113
src/Simplex/Chat/Store/Messages.hs
View file

@ -53,6 +53,8 @@ module Simplex.Chat.Store.Messages
markDirectChatItemDeleted, markDirectChatItemDeleted,
updateGroupChatItemStatus, updateGroupChatItemStatus,
updateGroupChatItem, updateGroupChatItem,
createGroupCIMentions,
updateGroupCIMentions,
deleteGroupChatItem, deleteGroupChatItem,
updateGroupChatItemModerated, updateGroupChatItemModerated,
updateGroupCIBlockedByAdmin, updateGroupCIBlockedByAdmin,
@ -136,6 +138,8 @@ import Data.Int (Int64)
import Data.List (sortBy) import Data.List (sortBy)
import Data.List.NonEmpty (NonEmpty) import Data.List.NonEmpty (NonEmpty)
import qualified Data.List.NonEmpty as L import qualified Data.List.NonEmpty as L
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as M
import Data.Maybe (catMaybes, fromMaybe, isJust, mapMaybe) import Data.Maybe (catMaybes, fromMaybe, isJust, mapMaybe)
import Data.Ord (Down (..), comparing) import Data.Ord (Down (..), comparing)
import Data.Text (Text) import Data.Text (Text)
@ -152,6 +156,7 @@ import Simplex.Chat.Store.Groups
import Simplex.Chat.Store.NoteFolders import Simplex.Chat.Store.NoteFolders
import Simplex.Chat.Store.Shared import Simplex.Chat.Store.Shared
import Simplex.Chat.Types import Simplex.Chat.Types
import Simplex.Chat.Types.Shared
import Simplex.Messaging.Agent.Protocol (AgentMsgId, ConnId, MsgMeta (..), UserId) import Simplex.Messaging.Agent.Protocol (AgentMsgId, ConnId, MsgMeta (..), UserId)
import Simplex.Messaging.Agent.Store.AgentStore (firstRow, firstRow', maybeFirstRow) import Simplex.Messaging.Agent.Store.AgentStore (firstRow, firstRow', maybeFirstRow)
import Simplex.Messaging.Agent.Store.DB (BoolInt (..)) import Simplex.Messaging.Agent.Store.DB (BoolInt (..))
@ -367,7 +372,7 @@ updateChatTs db User {userId} chatDirection chatTs = case toChatInfo chatDirecti
createNewSndChatItem :: DB.Connection -> User -> ChatDirection c 'MDSnd -> SndMessage -> CIContent 'MDSnd -> Maybe (CIQuote c) -> Maybe CIForwardedFrom -> Maybe CITimed -> Bool -> UTCTime -> IO ChatItemId createNewSndChatItem :: DB.Connection -> User -> ChatDirection c 'MDSnd -> SndMessage -> CIContent 'MDSnd -> Maybe (CIQuote c) -> Maybe CIForwardedFrom -> Maybe CITimed -> Bool -> UTCTime -> IO ChatItemId
createNewSndChatItem db user chatDirection SndMessage {msgId, sharedMsgId} ciContent quotedItem itemForwarded timed live createdAt = createNewSndChatItem db user chatDirection SndMessage {msgId, sharedMsgId} ciContent quotedItem itemForwarded timed live createdAt =
createNewChatItem_ db user chatDirection createdByMsgId (Just sharedMsgId) ciContent quoteRow itemForwarded timed live createdAt Nothing createdAt createNewChatItem_ db user chatDirection createdByMsgId (Just sharedMsgId) ciContent quoteRow itemForwarded timed live False createdAt Nothing createdAt
where where
createdByMsgId = if msgId == 0 then Nothing else Just msgId createdByMsgId = if msgId == 0 then Nothing else Just msgId
quoteRow :: NewQuoteRow quoteRow :: NewQuoteRow
@ -381,9 +386,9 @@ createNewSndChatItem db user chatDirection SndMessage {msgId, sharedMsgId} ciCon
CIQGroupRcv (Just GroupMember {memberId}) -> (Just False, Just memberId) CIQGroupRcv (Just GroupMember {memberId}) -> (Just False, Just memberId)
CIQGroupRcv Nothing -> (Just False, Nothing) CIQGroupRcv Nothing -> (Just False, Nothing)
createNewRcvChatItem :: ChatTypeQuotable c => DB.Connection -> User -> ChatDirection c 'MDRcv -> RcvMessage -> Maybe SharedMsgId -> CIContent 'MDRcv -> Maybe CITimed -> Bool -> UTCTime -> UTCTime -> IO (ChatItemId, Maybe (CIQuote c), Maybe CIForwardedFrom) createNewRcvChatItem :: ChatTypeQuotable c => DB.Connection -> User -> ChatDirection c 'MDRcv -> RcvMessage -> Maybe SharedMsgId -> CIContent 'MDRcv -> Maybe CITimed -> Bool -> Bool -> UTCTime -> UTCTime -> IO (ChatItemId, Maybe (CIQuote c), Maybe CIForwardedFrom)
createNewRcvChatItem db user chatDirection RcvMessage {msgId, chatMsgEvent, forwardedByMember} sharedMsgId_ ciContent timed live itemTs createdAt = do createNewRcvChatItem db user chatDirection RcvMessage {msgId, chatMsgEvent, forwardedByMember} sharedMsgId_ ciContent timed live userMention itemTs createdAt = do
ciId <- createNewChatItem_ db user chatDirection (Just msgId) sharedMsgId_ ciContent quoteRow itemForwarded timed live itemTs forwardedByMember createdAt ciId <- createNewChatItem_ db user chatDirection (Just msgId) sharedMsgId_ ciContent quoteRow itemForwarded timed live userMention itemTs forwardedByMember createdAt
quotedItem <- mapM (getChatItemQuote_ db user chatDirection) quotedMsg quotedItem <- mapM (getChatItemQuote_ db user chatDirection) quotedMsg
pure (ciId, quotedItem, itemForwarded) pure (ciId, quotedItem, itemForwarded)
where where
@ -400,13 +405,13 @@ createNewRcvChatItem db user chatDirection RcvMessage {msgId, chatMsgEvent, forw
createNewChatItemNoMsg :: forall c d. MsgDirectionI d => DB.Connection -> User -> ChatDirection c d -> CIContent d -> UTCTime -> UTCTime -> IO ChatItemId createNewChatItemNoMsg :: forall c d. MsgDirectionI d => DB.Connection -> User -> ChatDirection c d -> CIContent d -> UTCTime -> UTCTime -> IO ChatItemId
createNewChatItemNoMsg db user chatDirection ciContent itemTs = createNewChatItemNoMsg db user chatDirection ciContent itemTs =
createNewChatItem_ db user chatDirection Nothing Nothing ciContent quoteRow Nothing Nothing False itemTs Nothing createNewChatItem_ db user chatDirection Nothing Nothing ciContent quoteRow Nothing Nothing False False itemTs Nothing
where where
quoteRow :: NewQuoteRow quoteRow :: NewQuoteRow
quoteRow = (Nothing, Nothing, Nothing, Nothing, Nothing) quoteRow = (Nothing, Nothing, Nothing, Nothing, Nothing)
createNewChatItem_ :: forall c d. MsgDirectionI d => DB.Connection -> User -> ChatDirection c d -> Maybe MessageId -> Maybe SharedMsgId -> CIContent d -> NewQuoteRow -> Maybe CIForwardedFrom -> Maybe CITimed -> Bool -> UTCTime -> Maybe GroupMemberId -> UTCTime -> IO ChatItemId createNewChatItem_ :: forall c d. MsgDirectionI d => DB.Connection -> User -> ChatDirection c d -> Maybe MessageId -> Maybe SharedMsgId -> CIContent d -> NewQuoteRow -> Maybe CIForwardedFrom -> Maybe CITimed -> Bool -> Bool -> UTCTime -> Maybe GroupMemberId -> UTCTime -> IO ChatItemId
createNewChatItem_ db User {userId} chatDirection msgId_ sharedMsgId ciContent quoteRow itemForwarded timed live itemTs forwardedByMember createdAt = do createNewChatItem_ db User {userId} chatDirection msgId_ sharedMsgId ciContent quoteRow itemForwarded timed live userMention itemTs forwardedByMember createdAt = do
DB.execute DB.execute
db db
[sql| [sql|
@ -415,20 +420,20 @@ createNewChatItem_ db User {userId} chatDirection msgId_ sharedMsgId ciContent q
user_id, created_by_msg_id, contact_id, group_id, group_member_id, note_folder_id, user_id, created_by_msg_id, contact_id, group_id, group_member_id, note_folder_id,
-- meta -- meta
item_sent, item_ts, item_content, item_content_tag, item_text, item_status, msg_content_tag, shared_msg_id, 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, timed_ttl, timed_delete_at, forwarded_by_group_member_id, include_in_history, created_at, updated_at, item_live, user_mention, timed_ttl, timed_delete_at,
-- quote -- quote
quoted_shared_msg_id, quoted_sent_at, quoted_content, quoted_sent, quoted_member_id, quoted_shared_msg_id, quoted_sent_at, quoted_content, quoted_sent, quoted_member_id,
-- forwarded from -- 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_tag, fwd_from_chat_name, fwd_from_msg_dir, fwd_from_contact_id, fwd_from_group_id, fwd_from_chat_item_id
) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?) ) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?)
|] |]
((userId, msgId_) :. idsRow :. itemRow :. quoteRow' :. forwardedFromRow) ((userId, msgId_) :. idsRow :. itemRow :. quoteRow' :. forwardedFromRow)
ciId <- insertedRowId db ciId <- insertedRowId db
forM_ msgId_ $ \msgId -> insertChatItemMessage_ db ciId msgId createdAt forM_ msgId_ $ \msgId -> insertChatItemMessage_ db ciId msgId createdAt
pure ciId pure ciId
where where
itemRow :: (SMsgDirection d, UTCTime, CIContent d, Text, Text, CIStatus d, Maybe MsgContentTag, Maybe SharedMsgId, Maybe GroupMemberId, BoolInt) :. (UTCTime, UTCTime, Maybe BoolInt) :. (Maybe Int, Maybe UTCTime) itemRow :: (SMsgDirection d, UTCTime, CIContent d, Text, Text, CIStatus d, Maybe MsgContentTag, Maybe SharedMsgId, Maybe GroupMemberId, BoolInt) :. (UTCTime, UTCTime, Maybe BoolInt, BoolInt) :. (Maybe Int, Maybe UTCTime)
itemRow = (msgDirection @d, itemTs, ciContent, toCIContentTag ciContent, ciContentToText ciContent, ciCreateStatus ciContent, msgContentTag <$> ciMsgContent ciContent, sharedMsgId, forwardedByMember, BI includeInHistory) :. (createdAt, createdAt, BI <$> (justTrue live)) :. ciTimedRow timed itemRow = (msgDirection @d, itemTs, ciContent, toCIContentTag ciContent, ciContentToText ciContent, ciCreateStatus ciContent, msgContentTag <$> ciMsgContent ciContent, sharedMsgId, forwardedByMember, BI includeInHistory) :. (createdAt, createdAt, BI <$> (justTrue live), BI userMention) :. ciTimedRow timed
quoteRow' = let (a, b, c, d, e) = quoteRow in (a, b, c, BI <$> d, e) quoteRow' = let (a, b, c, d, e) = quoteRow in (a, b, c, BI <$> d, e)
idsRow :: (Maybe Int64, Maybe Int64, Maybe Int64, Maybe Int64) idsRow :: (Maybe Int64, Maybe Int64, Maybe Int64, Maybe Int64)
idsRow = case chatDirection of idsRow = case chatDirection of
@ -766,7 +771,7 @@ getGroupChatPreview_ :: DB.Connection -> VersionRangeChat -> User -> ChatPreview
getGroupChatPreview_ db vr user (GroupChatPD _ groupId lastItemId_ stats) = do getGroupChatPreview_ db vr user (GroupChatPD _ groupId lastItemId_ stats) = do
groupInfo <- getGroupInfo db vr user groupId groupInfo <- getGroupInfo db vr user groupId
lastItem <- case lastItemId_ of lastItem <- case lastItemId_ of
Just lastItemId -> (: []) <$> getGroupChatItem db user groupId lastItemId Just lastItemId -> (: []) <$> getGroupCIWithReactions db user groupInfo lastItemId
Nothing -> pure [] Nothing -> pure []
pure $ AChat SCTGroup (Chat (GroupChat groupInfo) lastItem stats) pure $ AChat SCTGroup (Chat (GroupChat groupInfo) lastItem stats)
@ -855,7 +860,7 @@ getLocalChatPreview_ db user (LocalChatPD _ noteFolderId lastItemId_ stats) = do
-- this function can be changed so it never fails, not only avoid failure on invalid json -- this function can be changed so it never fails, not only avoid failure on invalid json
toLocalChatItem :: UTCTime -> ChatItemRow -> Either StoreError (CChatItem 'CTLocal) 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) :. (fileId_, fileName_, fileSize_, filePath, fileKey, fileNonce, fileStatus_, fileProtocol_)) = toLocalChatItem currentTs ((itemId, itemTs, AMsgDirection msgDir, itemContentText, itemText, itemStatus, sentViaProxy, sharedMsgId) :. (itemDeleted, deletedTs, itemEdited, createdAt, updatedAt) :. forwardedFromRow :. (timedTTL, timedDeleteAt, itemLive, BI userMention) :. (fileId_, fileName_, fileSize_, filePath, fileKey, fileNonce, fileStatus_, fileProtocol_)) =
chatItem $ fromRight invalid $ dbParseACIContent itemContentText chatItem $ fromRight invalid $ dbParseACIContent itemContentText
where where
invalid = ACIContent msgDir $ CIInvalidJSON itemContentText invalid = ACIContent msgDir $ CIInvalidJSON itemContentText
@ -879,7 +884,7 @@ toLocalChatItem currentTs ((itemId, itemTs, AMsgDirection msgDir, itemContentTex
_ -> Nothing _ -> Nothing
cItem :: MsgDirectionI d => SMsgDirection d -> CIDirection 'CTLocal d -> CIStatus d -> CIContent d -> Maybe (CIFile d) -> CChatItem 'CTLocal cItem :: MsgDirectionI d => SMsgDirection d -> CIDirection 'CTLocal d -> CIStatus d -> CIContent d -> Maybe (CIFile d) -> CChatItem 'CTLocal
cItem d chatDir ciStatus content file = cItem d chatDir ciStatus content file =
CChatItem d ChatItem {chatDir, meta = ciMeta content ciStatus, content, formattedText = parseMaybeMarkdownList itemText, quotedItem = Nothing, reactions = [], file} CChatItem d ChatItem {chatDir, meta = ciMeta content ciStatus, content, mentions = M.empty, formattedText = parseMaybeMarkdownList itemText, quotedItem = Nothing, reactions = [], file}
badItem = Left $ SEBadChatItem itemId (Just itemTs) badItem = Left $ SEBadChatItem itemId (Just itemTs)
ciMeta :: CIContent d -> CIStatus d -> CIMeta 'CTLocal d ciMeta :: CIContent d -> CIStatus d -> CIMeta 'CTLocal d
ciMeta content status = ciMeta content status =
@ -888,7 +893,7 @@ toLocalChatItem currentTs ((itemId, itemTs, AMsgDirection msgDir, itemContentTex
_ -> Just (CIDeleted @'CTLocal deletedTs) _ -> Just (CIDeleted @'CTLocal deletedTs)
itemEdited' = maybe False unBI itemEdited itemEdited' = maybe False unBI itemEdited
itemForwarded = toCIForwardedFrom forwardedFromRow itemForwarded = toCIForwardedFrom forwardedFromRow
in mkCIMeta itemId content itemText status (unBI <$> sentViaProxy) sharedMsgId itemForwarded itemDeleted' itemEdited' ciTimed (unBI <$> itemLive) currentTs itemTs Nothing createdAt updatedAt in mkCIMeta itemId content itemText status (unBI <$> sentViaProxy) sharedMsgId itemForwarded itemDeleted' itemEdited' ciTimed (unBI <$> itemLive) userMention currentTs itemTs Nothing createdAt updatedAt
ciTimed :: Maybe CITimed ciTimed :: Maybe CITimed
ciTimed = timedTTL >>= \ttl -> Just CITimed {ttl, deleteAt = timedDeleteAt} ciTimed = timedTTL >>= \ttl -> Just CITimed {ttl, deleteAt = timedDeleteAt}
@ -1021,6 +1026,7 @@ safeToDirectItem currentTs itemId = \case
{ chatDir = CIDirectSnd, { chatDir = CIDirectSnd,
meta = dummyMeta itemId ts errorText, meta = dummyMeta itemId ts errorText,
content = CIInvalidJSON errorText, content = CIInvalidJSON errorText,
mentions = M.empty,
formattedText = Nothing, formattedText = Nothing,
quotedItem = Nothing, quotedItem = Nothing,
reactions = [], reactions = [],
@ -1276,6 +1282,7 @@ safeToGroupItem currentTs itemId = \case
{ chatDir = CIGroupSnd, { chatDir = CIGroupSnd,
meta = dummyMeta itemId ts errorText, meta = dummyMeta itemId ts errorText,
content = CIInvalidJSON errorText, content = CIInvalidJSON errorText,
mentions = M.empty,
formattedText = Nothing, formattedText = Nothing,
quotedItem = Nothing, quotedItem = Nothing,
reactions = [], reactions = [],
@ -1501,6 +1508,7 @@ safeToLocalItem currentTs itemId = \case
{ chatDir = CILocalSnd, { chatDir = CILocalSnd,
meta = dummyMeta itemId ts errorText, meta = dummyMeta itemId ts errorText,
content = CIInvalidJSON errorText, content = CIInvalidJSON errorText,
mentions = M.empty,
formattedText = Nothing, formattedText = Nothing,
quotedItem = Nothing, quotedItem = Nothing,
reactions = [], reactions = [],
@ -1810,7 +1818,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) type MaybeCIFIleRow = (Maybe Int64, Maybe String, Maybe Integer, Maybe FilePath, Maybe C.SbKey, Maybe C.CbNonce, Maybe ACIFileStatus, Maybe FileProtocol)
type ChatItemModeRow = (Maybe Int, Maybe UTCTime, Maybe BoolInt) type ChatItemModeRow = (Maybe Int, Maybe UTCTime, Maybe BoolInt, BoolInt)
type ChatItemForwardedFromRow = (Maybe CIForwardedFromTag, Maybe Text, Maybe MsgDirection, Maybe Int64, Maybe Int64, Maybe Int64) type ChatItemForwardedFromRow = (Maybe CIForwardedFromTag, Maybe Text, Maybe MsgDirection, Maybe Int64, Maybe Int64, Maybe Int64)
@ -1834,7 +1842,7 @@ toQuote (quotedItemId, quotedSharedMsgId, quotedSentAt, quotedMsgContent, _) dir
-- this function can be changed so it never fails, not only avoid failure on invalid json -- 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 :: 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) :. (fileId_, fileName_, fileSize_, filePath, fileKey, fileNonce, fileStatus_, fileProtocol_)) :. quoteRow) = toDirectChatItem currentTs (((itemId, itemTs, AMsgDirection msgDir, itemContentText, itemText, itemStatus, sentViaProxy, sharedMsgId) :. (itemDeleted, deletedTs, itemEdited, createdAt, updatedAt) :. forwardedFromRow :. (timedTTL, timedDeleteAt, itemLive, BI userMention) :. (fileId_, fileName_, fileSize_, filePath, fileKey, fileNonce, fileStatus_, fileProtocol_)) :. quoteRow) =
chatItem $ fromRight invalid $ dbParseACIContent itemContentText chatItem $ fromRight invalid $ dbParseACIContent itemContentText
where where
invalid = ACIContent msgDir $ CIInvalidJSON itemContentText invalid = ACIContent msgDir $ CIInvalidJSON itemContentText
@ -1858,7 +1866,7 @@ toDirectChatItem currentTs (((itemId, itemTs, AMsgDirection msgDir, itemContentT
_ -> Nothing _ -> Nothing
cItem :: MsgDirectionI d => SMsgDirection d -> CIDirection 'CTDirect d -> CIStatus d -> CIContent d -> Maybe (CIFile d) -> CChatItem 'CTDirect cItem :: MsgDirectionI d => SMsgDirection d -> CIDirection 'CTDirect d -> CIStatus d -> CIContent d -> Maybe (CIFile d) -> CChatItem 'CTDirect
cItem d chatDir ciStatus content file = cItem d chatDir ciStatus content file =
CChatItem d ChatItem {chatDir, meta = ciMeta content ciStatus, content, formattedText = parseMaybeMarkdownList itemText, quotedItem = toDirectQuote quoteRow, reactions = [], file} CChatItem d ChatItem {chatDir, meta = ciMeta content ciStatus, content, mentions = M.empty, formattedText = parseMaybeMarkdownList itemText, quotedItem = toDirectQuote quoteRow, reactions = [], file}
badItem = Left $ SEBadChatItem itemId (Just itemTs) badItem = Left $ SEBadChatItem itemId (Just itemTs)
ciMeta :: CIContent d -> CIStatus d -> CIMeta 'CTDirect d ciMeta :: CIContent d -> CIStatus d -> CIMeta 'CTDirect d
ciMeta content status = ciMeta content status =
@ -1867,7 +1875,7 @@ toDirectChatItem currentTs (((itemId, itemTs, AMsgDirection msgDir, itemContentT
_ -> Just (CIDeleted @'CTDirect deletedTs) _ -> Just (CIDeleted @'CTDirect deletedTs)
itemEdited' = maybe False unBI itemEdited itemEdited' = maybe False unBI itemEdited
itemForwarded = toCIForwardedFrom forwardedFromRow itemForwarded = toCIForwardedFrom forwardedFromRow
in mkCIMeta itemId content itemText status (unBI <$> sentViaProxy) sharedMsgId itemForwarded itemDeleted' itemEdited' ciTimed (unBI <$> itemLive) currentTs itemTs Nothing createdAt updatedAt in mkCIMeta itemId content itemText status (unBI <$> sentViaProxy) sharedMsgId itemForwarded itemDeleted' itemEdited' ciTimed (unBI <$> itemLive) userMention currentTs itemTs Nothing createdAt updatedAt
ciTimed :: Maybe CITimed ciTimed :: Maybe CITimed
ciTimed = timedTTL >>= \ttl -> Just CITimed {ttl, deleteAt = timedDeleteAt} ciTimed = timedTTL >>= \ttl -> Just CITimed {ttl, deleteAt = timedDeleteAt}
@ -1891,7 +1899,7 @@ toGroupQuote qr@(_, _, _, _, quotedSent) quotedMember_ = toQuote qr $ direction
-- this function can be changed so it never fails, not only avoid failure on invalid json -- this function can be changed so it never fails, not only avoid failure on invalid json
toGroupChatItem :: UTCTime -> Int64 -> ChatItemRow :. Only (Maybe GroupMemberId) :. MaybeGroupMemberRow :. GroupQuoteRow :. MaybeGroupMemberRow -> Either StoreError (CChatItem 'CTGroup) toGroupChatItem :: UTCTime -> Int64 -> ChatItemRow :. Only (Maybe GroupMemberId) :. MaybeGroupMemberRow :. GroupQuoteRow :. MaybeGroupMemberRow -> Either StoreError (CChatItem 'CTGroup)
toGroupChatItem currentTs userContactId (((itemId, itemTs, AMsgDirection msgDir, itemContentText, itemText, itemStatus, sentViaProxy, sharedMsgId) :. (itemDeleted, deletedTs, itemEdited, createdAt, updatedAt) :. forwardedFromRow :. (timedTTL, timedDeleteAt, itemLive) :. (fileId_, fileName_, fileSize_, filePath, fileKey, fileNonce, fileStatus_, fileProtocol_)) :. Only forwardedByMember :. memberRow_ :. (quoteRow :. quotedMemberRow_) :. deletedByGroupMemberRow_) = do toGroupChatItem currentTs userContactId (((itemId, itemTs, AMsgDirection msgDir, itemContentText, itemText, itemStatus, sentViaProxy, sharedMsgId) :. (itemDeleted, deletedTs, itemEdited, createdAt, updatedAt) :. forwardedFromRow :. (timedTTL, timedDeleteAt, itemLive, BI userMention) :. (fileId_, fileName_, fileSize_, filePath, fileKey, fileNonce, fileStatus_, fileProtocol_)) :. Only forwardedByMember :. memberRow_ :. (quoteRow :. quotedMemberRow_) :. deletedByGroupMemberRow_) = do
chatItem $ fromRight invalid $ dbParseACIContent itemContentText chatItem $ fromRight invalid $ dbParseACIContent itemContentText
where where
member_ = toMaybeGroupMember userContactId memberRow_ member_ = toMaybeGroupMember userContactId memberRow_
@ -1918,7 +1926,7 @@ toGroupChatItem currentTs userContactId (((itemId, itemTs, AMsgDirection msgDir,
_ -> Nothing _ -> Nothing
cItem :: MsgDirectionI d => SMsgDirection d -> CIDirection 'CTGroup d -> CIStatus d -> CIContent d -> Maybe (CIFile d) -> CChatItem 'CTGroup cItem :: MsgDirectionI d => SMsgDirection d -> CIDirection 'CTGroup d -> CIStatus d -> CIContent d -> Maybe (CIFile d) -> CChatItem 'CTGroup
cItem d chatDir ciStatus content file = cItem d chatDir ciStatus content file =
CChatItem d ChatItem {chatDir, meta = ciMeta content ciStatus, content, formattedText = parseMaybeMarkdownList itemText, quotedItem = toGroupQuote quoteRow quotedMember_, reactions = [], file} CChatItem d ChatItem {chatDir, meta = ciMeta content ciStatus, content, mentions = M.empty, formattedText = parseMaybeMarkdownList itemText, quotedItem = toGroupQuote quoteRow quotedMember_, reactions = [], file}
badItem = Left $ SEBadChatItem itemId (Just itemTs) badItem = Left $ SEBadChatItem itemId (Just itemTs)
ciMeta :: CIContent d -> CIStatus d -> CIMeta 'CTGroup d ciMeta :: CIContent d -> CIStatus d -> CIMeta 'CTGroup d
ciMeta content status = ciMeta content status =
@ -1929,7 +1937,7 @@ toGroupChatItem currentTs userContactId (((itemId, itemTs, AMsgDirection msgDir,
_ -> Just (maybe (CIDeleted @'CTGroup deletedTs) (CIModerated deletedTs) deletedByGroupMember_) _ -> Just (maybe (CIDeleted @'CTGroup deletedTs) (CIModerated deletedTs) deletedByGroupMember_)
itemEdited' = maybe False unBI itemEdited itemEdited' = maybe False unBI itemEdited
itemForwarded = toCIForwardedFrom forwardedFromRow itemForwarded = toCIForwardedFrom forwardedFromRow
in mkCIMeta itemId content itemText status (unBI <$> sentViaProxy) sharedMsgId itemForwarded itemDeleted' itemEdited' ciTimed (unBI <$> itemLive) currentTs itemTs forwardedByMember createdAt updatedAt in mkCIMeta itemId content itemText status (unBI <$> sentViaProxy) sharedMsgId itemForwarded itemDeleted' itemEdited' ciTimed (unBI <$> itemLive) userMention currentTs itemTs forwardedByMember createdAt updatedAt
ciTimed :: Maybe CITimed ciTimed :: Maybe CITimed
ciTimed = timedTTL >>= \ttl -> Just CITimed {ttl, deleteAt = timedDeleteAt} ciTimed = timedTTL >>= \ttl -> Just CITimed {ttl, deleteAt = timedDeleteAt}
@ -2202,7 +2210,7 @@ getDirectChatItem db User {userId} contactId itemId = ExceptT $ do
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.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.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_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.timed_ttl, i.timed_delete_at, i.item_live, i.timed_ttl, i.timed_delete_at, i.item_live, i.user_mention,
-- CIFile -- 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_id, f.file_name, f.file_size, f.file_path, f.file_crypto_key, f.file_crypto_nonce, f.ci_file_status, f.protocol,
-- DirectQuote -- DirectQuote
@ -2254,12 +2262,14 @@ getGroupCIWithReactions db user g@GroupInfo {groupId} itemId = do
liftIO . groupCIWithReactions db g =<< getGroupChatItem db user groupId itemId liftIO . groupCIWithReactions db g =<< getGroupChatItem db user groupId itemId
groupCIWithReactions :: DB.Connection -> GroupInfo -> CChatItem 'CTGroup -> IO (CChatItem 'CTGroup) groupCIWithReactions :: DB.Connection -> GroupInfo -> CChatItem 'CTGroup -> IO (CChatItem 'CTGroup)
groupCIWithReactions db g cci@(CChatItem md ci@ChatItem {meta = CIMeta {itemSharedMsgId}}) = case itemSharedMsgId of groupCIWithReactions db g cci@(CChatItem md ci@ChatItem {meta = CIMeta {itemId, itemSharedMsgId}}) = do
Just sharedMsgId -> do mentions <- getGroupCIMentions db itemId
let GroupMember {memberId} = chatItemMember g ci case itemSharedMsgId of
reactions <- getGroupCIReactions db g memberId sharedMsgId Just sharedMsgId -> do
pure $ CChatItem md ci {reactions} let GroupMember {memberId} = chatItemMember g ci
Nothing -> pure cci reactions <- getGroupCIReactions db g memberId sharedMsgId
pure $ CChatItem md ci {reactions, mentions}
Nothing -> pure $ if null mentions then cci else CChatItem md ci {mentions}
updateGroupChatItem :: MsgDirectionI d => DB.Connection -> User -> Int64 -> ChatItem 'CTGroup d -> CIContent d -> Bool -> Bool -> Maybe MessageId -> IO (ChatItem 'CTGroup d) updateGroupChatItem :: MsgDirectionI d => DB.Connection -> User -> Int64 -> ChatItem 'CTGroup d -> CIContent d -> Bool -> Bool -> Maybe MessageId -> IO (ChatItem 'CTGroup d)
updateGroupChatItem db user groupId ci newContent edited live msgId_ = do updateGroupChatItem db user groupId ci newContent edited live msgId_ = do
@ -2285,6 +2295,25 @@ updateGroupChatItem_ db User {userId} groupId ChatItem {content, meta} msgId_ =
((content, itemText, itemStatus, BI itemDeleted', itemDeletedTs', BI itemEdited, BI <$> itemLive, updatedAt) :. ciTimedRow itemTimed :. (userId, groupId, itemId)) ((content, itemText, itemStatus, BI itemDeleted', itemDeletedTs', BI itemEdited, BI <$> itemLive, updatedAt) :. ciTimedRow itemTimed :. (userId, groupId, itemId))
forM_ msgId_ $ \msgId -> insertChatItemMessage_ db itemId msgId updatedAt forM_ msgId_ $ \msgId -> insertChatItemMessage_ db itemId msgId updatedAt
createGroupCIMentions :: forall d. DB.Connection -> GroupInfo -> ChatItem 'CTGroup d -> Map MemberName MentionedMember -> IO (ChatItem 'CTGroup d)
createGroupCIMentions db GroupInfo {groupId} ci mentions = do
DB.executeMany db "INSERT INTO chat_item_mentions (chat_item_id, group_id, member_id, display_name) VALUES (?, ?, ?, ?)" rows
pure (ci :: ChatItem 'CTGroup d) {mentions}
where
rows = map (\(name, MentionedMember {memberId}) -> (ciId, groupId, memberId, name)) $ M.assocs mentions
ciId = chatItemId' ci
updateGroupCIMentions :: DB.Connection -> GroupInfo -> ChatItem 'CTGroup d -> Map MemberName MentionedMember -> IO (ChatItem 'CTGroup d)
updateGroupCIMentions db g ci@ChatItem {mentions} mentions'
| mentions' == mentions = pure ci
| otherwise = do
unless (null mentions) $ deleteMentions
if null mentions'
then pure ci
else createGroupCIMentions db g ci mentions'
where
deleteMentions = DB.execute db "DELETE FROM chat_item_mentions WHERE chat_item_id = ?" (Only $ chatItemId' ci)
deleteGroupChatItem :: DB.Connection -> User -> GroupInfo -> ChatItem 'CTGroup d -> IO () deleteGroupChatItem :: DB.Connection -> User -> GroupInfo -> ChatItem 'CTGroup d -> IO ()
deleteGroupChatItem db User {userId} g@GroupInfo {groupId} ci = do deleteGroupChatItem db User {userId} g@GroupInfo {groupId} ci = do
let itemId = chatItemId' ci let itemId = chatItemId' ci
@ -2458,7 +2487,7 @@ getGroupChatItem db User {userId, userContactId} groupId itemId = ExceptT $ do
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.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.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_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.timed_ttl, i.timed_delete_at, i.item_live, i.timed_ttl, i.timed_delete_at, i.item_live, i.user_mention,
-- CIFile -- 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_id, f.file_name, f.file_size, f.file_path, f.file_crypto_key, f.file_crypto_nonce, f.ci_file_status, f.protocol,
-- CIMeta forwardedByMember -- CIMeta forwardedByMember
@ -2562,7 +2591,7 @@ getLocalChatItem db User {userId} folderId itemId = ExceptT $ do
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.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.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_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.timed_ttl, i.timed_delete_at, i.item_live, i.timed_ttl, i.timed_delete_at, i.item_live, i.user_mention,
-- CIFile -- 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_id, f.file_name, f.file_size, f.file_path, f.file_crypto_key, f.file_crypto_nonce, f.ci_file_status, f.protocol
FROM chat_items i FROM chat_items i
@ -2760,6 +2789,28 @@ getGroupCIReactions db GroupInfo {groupId} itemMemberId itemSharedMsgId =
|] |]
(groupId, itemMemberId, itemSharedMsgId) (groupId, itemMemberId, itemSharedMsgId)
getGroupCIMentions :: DB.Connection -> ChatItemId -> IO (Map MemberName MentionedMember)
getGroupCIMentions db ciId =
M.fromList . map mentionedMember
<$> DB.query
db
[sql|
SELECT r.display_name, r.member_id, m.group_member_id, m.member_role, p.display_name, p.local_alias
FROM chat_item_mentions r
LEFT JOIN group_members m ON r.group_id = m.group_id AND r.member_id = m.member_id
LEFT JOIN contact_profiles p ON p.contact_profile_id = COALESCE(m.member_profile_id, m.contact_profile_id)
WHERE r.chat_item_id = ?
|]
(Only ciId)
where
mentionedMember :: (ContactName, MemberId, Maybe GroupMemberId, Maybe GroupMemberRole, Maybe Text, Maybe Text) -> (ContactName, MentionedMember)
mentionedMember (name, memberId, gmId_, mRole_, displayName_, localAlias) =
let memberRef = case (gmId_, mRole_, displayName_) of
(Just groupMemberId, Just memberRole, Just displayName) ->
Just MentionedMemberInfo {groupMemberId, displayName, localAlias, memberRole}
_ -> Nothing
in (name, MentionedMember {memberId, memberRef})
getACIReactions :: DB.Connection -> AChatItem -> IO AChatItem getACIReactions :: DB.Connection -> AChatItem -> IO AChatItem
getACIReactions db aci@(AChatItem _ md chat ci@ChatItem {meta = CIMeta {itemSharedMsgId}}) = case itemSharedMsgId of getACIReactions db aci@(AChatItem _ md chat ci@ChatItem {meta = CIMeta {itemSharedMsgId}}) = case itemSharedMsgId of
Just itemSharedMId -> case chat of Just itemSharedMId -> case chat of

14
src/Simplex/Chat/Store/Postgres/Migrations/M20241220_initial.hs
View file

@ -426,7 +426,8 @@ CREATE TABLE chat_items(
fwd_from_chat_item_id BIGINT REFERENCES chat_items ON DELETE SET NULL, fwd_from_chat_item_id BIGINT REFERENCES chat_items ON DELETE SET NULL,
via_proxy SMALLINT, via_proxy SMALLINT,
msg_content_tag TEXT, msg_content_tag TEXT,
include_in_history SMALLINT NOT NULL DEFAULT 0 include_in_history SMALLINT NOT NULL DEFAULT 0,
user_mention SMALLINT NOT NULL DEFAULT 0
); );
ALTER TABLE groups ALTER TABLE groups
ADD CONSTRAINT fk_groups_chat_items ADD CONSTRAINT fk_groups_chat_items
@ -676,6 +677,13 @@ CREATE TABLE chat_tags_chats(
group_id BIGINT REFERENCES groups ON DELETE CASCADE, group_id BIGINT REFERENCES groups ON DELETE CASCADE,
chat_tag_id BIGINT NOT NULL REFERENCES chat_tags ON DELETE CASCADE chat_tag_id BIGINT NOT NULL REFERENCES chat_tags ON DELETE CASCADE
); );
CREATE TABLE chat_item_mentions (
chat_item_mention_id BIGINT PRIMARY KEY GENERATED ALWAYS AS IDENTITY,
chat_item_id BIGINT NOT NULL REFERENCES chat_items ON DELETE CASCADE,
group_id BIGINT NOT NULL REFERENCES groups ON DELETE CASCADE,
member_id BYTEA NOT NULL,
display_name TEXT NOT NULL
);
CREATE INDEX contact_profiles_index ON contact_profiles( CREATE INDEX contact_profiles_index ON contact_profiles(
display_name, display_name,
full_name full_name
@ -1025,4 +1033,8 @@ CREATE INDEX idx_group_snd_item_statuses_chat_item_id_group_member_id ON group_s
chat_item_id, chat_item_id,
group_member_id group_member_id
); );
CREATE INDEX idx_chat_item_mentions_group_id ON chat_item_mentions(group_id);
CREATE INDEX idx_chat_item_mentions_chat_item_id ON chat_item_mentions(chat_item_id);
CREATE UNIQUE INDEX idx_chat_item_mentions_display_name ON chat_item_mentions(chat_item_id, display_name);
CREATE UNIQUE INDEX idx_chat_item_mentions_member_id ON chat_item_mentions(chat_item_id, member_id);
|] |]

4
src/Simplex/Chat/Store/SQLite/Migrations.hs
View file

@ -125,6 +125,7 @@ import Simplex.Chat.Store.SQLite.Migrations.M20241230_reports
import Simplex.Chat.Store.SQLite.Migrations.M20250105_indexes import Simplex.Chat.Store.SQLite.Migrations.M20250105_indexes
import Simplex.Chat.Store.SQLite.Migrations.M20250115_chat_ttl import Simplex.Chat.Store.SQLite.Migrations.M20250115_chat_ttl
import Simplex.Chat.Store.SQLite.Migrations.M20250122_chat_items_include_in_history import Simplex.Chat.Store.SQLite.Migrations.M20250122_chat_items_include_in_history
import Simplex.Chat.Store.SQLite.Migrations.M20250126_mentions
import Simplex.Messaging.Agent.Store.Shared (Migration (..)) import Simplex.Messaging.Agent.Store.Shared (Migration (..))
schemaMigrations :: [(String, Query, Maybe Query)] schemaMigrations :: [(String, Query, Maybe Query)]
@ -249,7 +250,8 @@ schemaMigrations =
("20241230_reports", m20241230_reports, Just down_m20241230_reports), ("20241230_reports", m20241230_reports, Just down_m20241230_reports),
("20250105_indexes", m20250105_indexes, Just down_m20250105_indexes), ("20250105_indexes", m20250105_indexes, Just down_m20250105_indexes),
("20250115_chat_ttl", m20250115_chat_ttl, Just down_m20250115_chat_ttl), ("20250115_chat_ttl", m20250115_chat_ttl, Just down_m20250115_chat_ttl),
("20250122_chat_items_include_in_history", m20250122_chat_items_include_in_history, Just down_m20250122_chat_items_include_in_history) ("20250122_chat_items_include_in_history", m20250122_chat_items_include_in_history, Just down_m20250122_chat_items_include_in_history),
("20250126_mentions", m20250126_mentions, Just down_m20250126_mentions)
] ]
-- | The list of migrations in ascending order by date -- | The list of migrations in ascending order by date

37
src/Simplex/Chat/Store/SQLite/Migrations/M20250126_mentions.hs Normal file
View file

@ -0,0 +1,37 @@
{-# LANGUAGE QuasiQuotes #-}
module Simplex.Chat.Store.SQLite.Migrations.M20250126_mentions where
import Database.SQLite.Simple (Query)
import Database.SQLite.Simple.QQ (sql)
m20250126_mentions :: Query
m20250126_mentions =
[sql|
ALTER TABLE chat_items ADD COLUMN user_mention INTEGER NOT NULL DEFAULT 0;
CREATE TABLE chat_item_mentions (
chat_item_mention_id INTEGER PRIMARY KEY AUTOINCREMENT,
group_id INTEGER NOT NULL REFERENCES groups ON DELETE CASCADE,
member_id BLOB NOT NULL,
chat_item_id INTEGER NOT NULL REFERENCES chat_items ON DELETE CASCADE,
display_name TEXT NOT NULL
);
CREATE INDEX idx_chat_item_mentions_group_id ON chat_item_mentions(group_id);
CREATE INDEX idx_chat_item_mentions_chat_item_id ON chat_item_mentions(chat_item_id);
CREATE UNIQUE INDEX idx_chat_item_mentions_display_name ON chat_item_mentions(chat_item_id, display_name);
CREATE UNIQUE INDEX idx_chat_item_mentions_member_id ON chat_item_mentions(chat_item_id, member_id);
|]
down_m20250126_mentions :: Query
down_m20250126_mentions =
[sql|
DROP INDEX idx_chat_item_mentions_group_id;
DROP INDEX idx_chat_item_mentions_chat_item_id;
DROP INDEX idx_chat_item_mentions_display_name;
DROP INDEX idx_chat_item_mentions_member_id;
DROP TABLE chat_item_mentions;
ALTER TABLE chat_items DROP COLUMN user_mention;
|]

52
src/Simplex/Chat/Store/SQLite/Migrations/chat_query_plans.txt
View file

@ -714,7 +714,7 @@ Query:
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.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.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_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.timed_ttl, i.timed_delete_at, i.item_live, i.timed_ttl, i.timed_delete_at, i.item_live, i.user_mention,
-- CIFile -- 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_id, f.file_name, f.file_size, f.file_path, f.file_crypto_key, f.file_crypto_nonce, f.ci_file_status, f.protocol
FROM chat_items i FROM chat_items i
@ -731,7 +731,7 @@ Query:
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.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.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_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.timed_ttl, i.timed_delete_at, i.item_live, i.timed_ttl, i.timed_delete_at, i.item_live, i.user_mention,
-- CIFile -- 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_id, f.file_name, f.file_size, f.file_path, f.file_crypto_key, f.file_crypto_nonce, f.ci_file_status, f.protocol,
-- CIMeta forwardedByMember -- CIMeta forwardedByMember
@ -778,7 +778,7 @@ Query:
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.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.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_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.timed_ttl, i.timed_delete_at, i.item_live, i.timed_ttl, i.timed_delete_at, i.item_live, i.user_mention,
-- CIFile -- 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_id, f.file_name, f.file_size, f.file_path, f.file_crypto_key, f.file_crypto_nonce, f.ci_file_status, f.protocol,
-- DirectQuote -- DirectQuote
@ -3295,6 +3295,18 @@ SEARCH r USING INDEX idx_received_probes_user_id (user_id=?)
SEARCH m USING INTEGER PRIMARY KEY (rowid=?) LEFT-JOIN SEARCH m USING INTEGER PRIMARY KEY (rowid=?) LEFT-JOIN
SEARCH g USING INTEGER PRIMARY KEY (rowid=?) LEFT-JOIN SEARCH g USING INTEGER PRIMARY KEY (rowid=?) LEFT-JOIN
Query:
SELECT r.display_name, r.member_id, m.group_member_id, m.member_role, p.display_name, p.local_alias
FROM chat_item_mentions r
LEFT JOIN group_members m ON r.group_id = m.group_id AND r.member_id = m.member_id
LEFT JOIN contact_profiles p ON p.contact_profile_id = COALESCE(m.member_profile_id, m.contact_profile_id)
WHERE r.chat_item_id = ?
Plan:
SEARCH r USING INDEX idx_chat_item_mentions_chat_item_id (chat_item_id=?)
SEARCH m USING INDEX sqlite_autoindex_group_members_1 (group_id=? AND member_id=?) LEFT-JOIN
SEARCH p USING INTEGER PRIMARY KEY (rowid=?) LEFT-JOIN
Query: Query:
SELECT re_group_member_id SELECT re_group_member_id
FROM group_member_intros FROM group_member_intros
@ -3489,6 +3501,7 @@ Query:
Plan: Plan:
SEARCH chat_items USING INTEGER PRIMARY KEY (rowid=?) SEARCH chat_items USING INTEGER PRIMARY KEY (rowid=?)
SEARCH chat_item_mentions USING COVERING INDEX idx_chat_item_mentions_chat_item_id (chat_item_id=?)
SEARCH group_snd_item_statuses USING COVERING INDEX idx_group_snd_item_statuses_chat_item_id (chat_item_id=?) SEARCH group_snd_item_statuses USING COVERING INDEX idx_group_snd_item_statuses_chat_item_id (chat_item_id=?)
SEARCH chat_item_versions USING COVERING INDEX idx_chat_item_versions_chat_item_id (chat_item_id=?) SEARCH chat_item_versions USING COVERING INDEX idx_chat_item_versions_chat_item_id (chat_item_id=?)
SEARCH calls USING COVERING INDEX idx_calls_chat_item_id (chat_item_id=?) SEARCH calls USING COVERING INDEX idx_calls_chat_item_id (chat_item_id=?)
@ -3503,6 +3516,7 @@ Query:
Plan: Plan:
SEARCH chat_items USING INTEGER PRIMARY KEY (rowid=?) SEARCH chat_items USING INTEGER PRIMARY KEY (rowid=?)
SEARCH chat_item_mentions USING COVERING INDEX idx_chat_item_mentions_chat_item_id (chat_item_id=?)
SEARCH group_snd_item_statuses USING COVERING INDEX idx_group_snd_item_statuses_chat_item_id (chat_item_id=?) SEARCH group_snd_item_statuses USING COVERING INDEX idx_group_snd_item_statuses_chat_item_id (chat_item_id=?)
SEARCH chat_item_versions USING COVERING INDEX idx_chat_item_versions_chat_item_id (chat_item_id=?) SEARCH chat_item_versions USING COVERING INDEX idx_chat_item_versions_chat_item_id (chat_item_id=?)
SEARCH calls USING COVERING INDEX idx_calls_chat_item_id (chat_item_id=?) SEARCH calls USING COVERING INDEX idx_calls_chat_item_id (chat_item_id=?)
@ -3517,6 +3531,7 @@ Query:
Plan: Plan:
SEARCH chat_items USING INTEGER PRIMARY KEY (rowid=?) SEARCH chat_items USING INTEGER PRIMARY KEY (rowid=?)
SEARCH chat_item_mentions USING COVERING INDEX idx_chat_item_mentions_chat_item_id (chat_item_id=?)
SEARCH group_snd_item_statuses USING COVERING INDEX idx_group_snd_item_statuses_chat_item_id (chat_item_id=?) SEARCH group_snd_item_statuses USING COVERING INDEX idx_group_snd_item_statuses_chat_item_id (chat_item_id=?)
SEARCH chat_item_versions USING COVERING INDEX idx_chat_item_versions_chat_item_id (chat_item_id=?) SEARCH chat_item_versions USING COVERING INDEX idx_chat_item_versions_chat_item_id (chat_item_id=?)
SEARCH calls USING COVERING INDEX idx_calls_chat_item_id (chat_item_id=?) SEARCH calls USING COVERING INDEX idx_calls_chat_item_id (chat_item_id=?)
@ -3964,12 +3979,12 @@ Query:
user_id, created_by_msg_id, contact_id, group_id, group_member_id, note_folder_id, user_id, created_by_msg_id, contact_id, group_id, group_member_id, note_folder_id,
-- meta -- meta
item_sent, item_ts, item_content, item_content_tag, item_text, item_status, msg_content_tag, shared_msg_id, 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, timed_ttl, timed_delete_at, forwarded_by_group_member_id, include_in_history, created_at, updated_at, item_live, user_mention, timed_ttl, timed_delete_at,
-- quote -- quote
quoted_shared_msg_id, quoted_sent_at, quoted_content, quoted_sent, quoted_member_id, quoted_shared_msg_id, quoted_sent_at, quoted_content, quoted_sent, quoted_member_id,
-- forwarded from -- 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_tag, fwd_from_chat_name, fwd_from_msg_dir, fwd_from_contact_id, fwd_from_group_id, fwd_from_chat_item_id
) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?) ) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?)
Plan: Plan:
@ -4690,6 +4705,24 @@ Plan:
SEARCH i USING COVERING INDEX idx_chat_items_notes_created_at (user_id=? AND note_folder_id=?) SEARCH i USING COVERING INDEX idx_chat_items_notes_created_at (user_id=? AND note_folder_id=?)
SEARCH f USING INDEX idx_files_chat_item_id (chat_item_id=?) SEARCH f USING INDEX idx_files_chat_item_id (chat_item_id=?)
Query:
SELECT m.group_member_id, m.member_id, m.member_role, p.display_name, p.local_alias
FROM group_members m
JOIN contact_profiles p ON p.contact_profile_id = COALESCE(m.member_profile_id, m.contact_profile_id)
WHERE m.group_id = ? AND m.group_member_id = ? AND m.user_id = ?
Plan:
SEARCH m USING INTEGER PRIMARY KEY (rowid=?)
SEARCH p USING INTEGER PRIMARY KEY (rowid=?)
Query:
SELECT m.group_member_id, m.member_id, m.member_role, p.display_name, p.local_alias
FROM group_members m
JOIN contact_profiles p ON p.contact_profile_id = COALESCE(m.member_profile_id, m.contact_profile_id)
WHERE m.group_id = ? AND m.member_id = ? AND m.user_id = ?
Plan:
SEARCH m USING INDEX sqlite_autoindex_group_members_1 (group_id=? AND member_id=?)
SEARCH p USING INTEGER PRIMARY KEY (rowid=?)
Query: Query:
SELECT remote_ctrl_id, ctrl_device_name, ca_key, ca_cert, ctrl_fingerprint, id_pub, dh_priv_key, prev_dh_priv_key SELECT remote_ctrl_id, ctrl_device_name, ca_key, ca_cert, ctrl_fingerprint, id_pub, dh_priv_key, prev_dh_priv_key
FROM remote_controllers FROM remote_controllers
@ -4957,6 +4990,7 @@ SEARCH chat_item_versions USING COVERING INDEX idx_chat_item_versions_chat_item_
Query: DELETE FROM chat_items WHERE user_id = ? AND contact_id = ? Query: DELETE FROM chat_items WHERE user_id = ? AND contact_id = ?
Plan: Plan:
SEARCH chat_items USING COVERING INDEX idx_chat_items_contacts_created_at (user_id=? AND contact_id=?) SEARCH chat_items USING COVERING INDEX idx_chat_items_contacts_created_at (user_id=? AND contact_id=?)
SEARCH chat_item_mentions USING COVERING INDEX idx_chat_item_mentions_chat_item_id (chat_item_id=?)
SEARCH group_snd_item_statuses USING COVERING INDEX idx_group_snd_item_statuses_chat_item_id (chat_item_id=?) SEARCH group_snd_item_statuses USING COVERING INDEX idx_group_snd_item_statuses_chat_item_id (chat_item_id=?)
SEARCH chat_item_versions USING COVERING INDEX idx_chat_item_versions_chat_item_id (chat_item_id=?) SEARCH chat_item_versions USING COVERING INDEX idx_chat_item_versions_chat_item_id (chat_item_id=?)
SEARCH calls USING COVERING INDEX idx_calls_chat_item_id (chat_item_id=?) SEARCH calls USING COVERING INDEX idx_calls_chat_item_id (chat_item_id=?)
@ -4968,6 +5002,7 @@ SEARCH groups USING COVERING INDEX idx_groups_chat_item_id (chat_item_id=?)
Query: DELETE FROM chat_items WHERE user_id = ? AND contact_id = ? AND created_at <= ? Query: DELETE FROM chat_items WHERE user_id = ? AND contact_id = ? AND created_at <= ?
Plan: Plan:
SEARCH chat_items USING COVERING INDEX idx_chat_items_contacts_created_at (user_id=? AND contact_id=? AND created_at<?) SEARCH chat_items USING COVERING INDEX idx_chat_items_contacts_created_at (user_id=? AND contact_id=? AND created_at<?)
SEARCH chat_item_mentions USING COVERING INDEX idx_chat_item_mentions_chat_item_id (chat_item_id=?)
SEARCH group_snd_item_statuses USING COVERING INDEX idx_group_snd_item_statuses_chat_item_id (chat_item_id=?) SEARCH group_snd_item_statuses USING COVERING INDEX idx_group_snd_item_statuses_chat_item_id (chat_item_id=?)
SEARCH chat_item_versions USING COVERING INDEX idx_chat_item_versions_chat_item_id (chat_item_id=?) SEARCH chat_item_versions USING COVERING INDEX idx_chat_item_versions_chat_item_id (chat_item_id=?)
SEARCH calls USING COVERING INDEX idx_calls_chat_item_id (chat_item_id=?) SEARCH calls USING COVERING INDEX idx_calls_chat_item_id (chat_item_id=?)
@ -4979,6 +5014,7 @@ SEARCH groups USING COVERING INDEX idx_groups_chat_item_id (chat_item_id=?)
Query: DELETE FROM chat_items WHERE user_id = ? AND group_id = ? Query: DELETE FROM chat_items WHERE user_id = ? AND group_id = ?
Plan: Plan:
SEARCH chat_items USING COVERING INDEX idx_chat_items_groups_item_ts (user_id=? AND group_id=?) SEARCH chat_items USING COVERING INDEX idx_chat_items_groups_item_ts (user_id=? AND group_id=?)
SEARCH chat_item_mentions USING COVERING INDEX idx_chat_item_mentions_chat_item_id (chat_item_id=?)
SEARCH group_snd_item_statuses USING COVERING INDEX idx_group_snd_item_statuses_chat_item_id (chat_item_id=?) SEARCH group_snd_item_statuses USING COVERING INDEX idx_group_snd_item_statuses_chat_item_id (chat_item_id=?)
SEARCH chat_item_versions USING COVERING INDEX idx_chat_item_versions_chat_item_id (chat_item_id=?) SEARCH chat_item_versions USING COVERING INDEX idx_chat_item_versions_chat_item_id (chat_item_id=?)
SEARCH calls USING COVERING INDEX idx_calls_chat_item_id (chat_item_id=?) SEARCH calls USING COVERING INDEX idx_calls_chat_item_id (chat_item_id=?)
@ -4990,6 +5026,7 @@ SEARCH groups USING COVERING INDEX idx_groups_chat_item_id (chat_item_id=?)
Query: DELETE FROM chat_items WHERE user_id = ? AND group_id = ? AND group_member_id = ? Query: DELETE FROM chat_items WHERE user_id = ? AND group_id = ? AND group_member_id = ?
Plan: Plan:
SEARCH chat_items USING COVERING INDEX idx_chat_items_group_shared_msg_id (user_id=? AND group_id=? AND group_member_id=?) SEARCH chat_items USING COVERING INDEX idx_chat_items_group_shared_msg_id (user_id=? AND group_id=? AND group_member_id=?)
SEARCH chat_item_mentions USING COVERING INDEX idx_chat_item_mentions_chat_item_id (chat_item_id=?)
SEARCH group_snd_item_statuses USING COVERING INDEX idx_group_snd_item_statuses_chat_item_id (chat_item_id=?) SEARCH group_snd_item_statuses USING COVERING INDEX idx_group_snd_item_statuses_chat_item_id (chat_item_id=?)
SEARCH chat_item_versions USING COVERING INDEX idx_chat_item_versions_chat_item_id (chat_item_id=?) SEARCH chat_item_versions USING COVERING INDEX idx_chat_item_versions_chat_item_id (chat_item_id=?)
SEARCH calls USING COVERING INDEX idx_calls_chat_item_id (chat_item_id=?) SEARCH calls USING COVERING INDEX idx_calls_chat_item_id (chat_item_id=?)
@ -5001,6 +5038,7 @@ SEARCH groups USING COVERING INDEX idx_groups_chat_item_id (chat_item_id=?)
Query: DELETE FROM chat_items WHERE user_id = ? AND note_folder_id = ? Query: DELETE FROM chat_items WHERE user_id = ? AND note_folder_id = ?
Plan: Plan:
SEARCH chat_items USING COVERING INDEX idx_chat_items_notes_created_at (user_id=? AND note_folder_id=?) SEARCH chat_items USING COVERING INDEX idx_chat_items_notes_created_at (user_id=? AND note_folder_id=?)
SEARCH chat_item_mentions USING COVERING INDEX idx_chat_item_mentions_chat_item_id (chat_item_id=?)
SEARCH group_snd_item_statuses USING COVERING INDEX idx_group_snd_item_statuses_chat_item_id (chat_item_id=?) SEARCH group_snd_item_statuses USING COVERING INDEX idx_group_snd_item_statuses_chat_item_id (chat_item_id=?)
SEARCH chat_item_versions USING COVERING INDEX idx_chat_item_versions_chat_item_id (chat_item_id=?) SEARCH chat_item_versions USING COVERING INDEX idx_chat_item_versions_chat_item_id (chat_item_id=?)
SEARCH calls USING COVERING INDEX idx_calls_chat_item_id (chat_item_id=?) SEARCH calls USING COVERING INDEX idx_calls_chat_item_id (chat_item_id=?)
@ -5155,6 +5193,7 @@ SEARCH contacts USING COVERING INDEX idx_contacts_contact_group_member_id (conta
Query: DELETE FROM groups WHERE user_id = ? AND group_id = ? Query: DELETE FROM groups WHERE user_id = ? AND group_id = ?
Plan: Plan:
SEARCH groups USING INTEGER PRIMARY KEY (rowid=?) SEARCH groups USING INTEGER PRIMARY KEY (rowid=?)
SEARCH chat_item_mentions USING COVERING INDEX idx_chat_item_mentions_group_id (group_id=?)
SEARCH chat_tags_chats USING COVERING INDEX idx_chat_tags_chats_chat_tag_id_group_id (group_id=?) SEARCH chat_tags_chats USING COVERING INDEX idx_chat_tags_chats_chat_tag_id_group_id (group_id=?)
SEARCH chat_item_moderations USING COVERING INDEX idx_chat_item_moderations_group_id (group_id=?) SEARCH chat_item_moderations USING COVERING INDEX idx_chat_item_moderations_group_id (group_id=?)
SEARCH chat_item_reactions USING COVERING INDEX idx_chat_item_reactions_group_id (group_id=?) SEARCH chat_item_reactions USING COVERING INDEX idx_chat_item_reactions_group_id (group_id=?)
@ -5293,6 +5332,9 @@ Plan:
Query: INSERT INTO app_settings (app_settings) VALUES (?) Query: INSERT INTO app_settings (app_settings) VALUES (?)
Plan: Plan:
Query: INSERT INTO chat_item_mentions (chat_item_id, group_id, member_id, display_name) VALUES (?, ?, ?, ?)
Plan:
Query: INSERT INTO chat_item_messages (chat_item_id, message_id, created_at, updated_at) VALUES (?,?,?,?) Query: INSERT INTO chat_item_messages (chat_item_id, message_id, created_at, updated_at) VALUES (?,?,?,?)
Plan: Plan:

22
src/Simplex/Chat/Store/SQLite/Migrations/chat_schema.sql
View file

@ -407,7 +407,8 @@ CREATE TABLE chat_items(
fwd_from_chat_item_id INTEGER REFERENCES chat_items ON DELETE SET NULL, fwd_from_chat_item_id INTEGER REFERENCES chat_items ON DELETE SET NULL,
via_proxy INTEGER, via_proxy INTEGER,
msg_content_tag TEXT, msg_content_tag TEXT,
include_in_history INTEGER NOT NULL DEFAULT 0 include_in_history INTEGER NOT NULL DEFAULT 0,
user_mention INTEGER NOT NULL DEFAULT 0
); );
CREATE TABLE sqlite_sequence(name,seq); CREATE TABLE sqlite_sequence(name,seq);
CREATE TABLE chat_item_messages( CREATE TABLE chat_item_messages(
@ -642,6 +643,13 @@ CREATE TABLE chat_tags_chats(
group_id INTEGER REFERENCES groups ON DELETE CASCADE, group_id INTEGER REFERENCES groups ON DELETE CASCADE,
chat_tag_id INTEGER NOT NULL REFERENCES chat_tags ON DELETE CASCADE chat_tag_id INTEGER NOT NULL REFERENCES chat_tags ON DELETE CASCADE
); );
CREATE TABLE chat_item_mentions(
chat_item_mention_id INTEGER PRIMARY KEY AUTOINCREMENT,
group_id INTEGER NOT NULL REFERENCES groups ON DELETE CASCADE,
member_id BLOB NOT NULL,
chat_item_id INTEGER NOT NULL REFERENCES chat_items ON DELETE CASCADE,
display_name TEXT NOT NULL
);
CREATE INDEX contact_profiles_index ON contact_profiles( CREATE INDEX contact_profiles_index ON contact_profiles(
display_name, display_name,
full_name full_name
@ -991,3 +999,15 @@ CREATE INDEX idx_group_snd_item_statuses_chat_item_id_group_member_id ON group_s
chat_item_id, chat_item_id,
group_member_id group_member_id
); );
CREATE INDEX idx_chat_item_mentions_group_id ON chat_item_mentions(group_id);
CREATE INDEX idx_chat_item_mentions_chat_item_id ON chat_item_mentions(
chat_item_id
);
CREATE UNIQUE INDEX idx_chat_item_mentions_display_name ON chat_item_mentions(
chat_item_id,
display_name
);
CREATE UNIQUE INDEX idx_chat_item_mentions_member_id ON chat_item_mentions(
chat_item_id,
member_id
);

2
src/Simplex/Chat/Store/Shared.hs
View file

@ -140,6 +140,8 @@ data StoreError
| SEProhibitedDeleteUser {userId :: UserId, contactId :: ContactId} | SEProhibitedDeleteUser {userId :: UserId, contactId :: ContactId}
| SEOperatorNotFound {serverOperatorId :: Int64} | SEOperatorNotFound {serverOperatorId :: Int64}
| SEUsageConditionsNotFound | SEUsageConditionsNotFound
| SEInvalidQuote
| SEInvalidMention
deriving (Show, Exception) deriving (Show, Exception)
$(J.deriveJSON (sumTypeJSON $ dropPrefix "SE") ''StoreError) $(J.deriveJSON (sumTypeJSON $ dropPrefix "SE") ''StoreError)

6
src/Simplex/Chat/Terminal/Output.hs
View file

@ -161,7 +161,7 @@ runTerminalOutput ct cc@ChatController {outputQ, showLiveItems, logFilePath} Cha
responseNotification ct cc r responseNotification ct cc r
where where
markChatItemRead u (AChatItem _ _ chat ci@ChatItem {chatDir, meta = CIMeta {itemStatus}}) = markChatItemRead u (AChatItem _ _ chat ci@ChatItem {chatDir, meta = CIMeta {itemStatus}}) =
case (chatDirNtf u chat chatDir (isMention ci), itemStatus) of case (chatDirNtf u chat chatDir (isUserMention ci), itemStatus) of
(True, CISRcvNew) -> do (True, CISRcvNew) -> do
let itemId = chatItemId' ci let itemId = chatItemId' ci
chatRef = chatInfoToRef chat chatRef = chatInfoToRef chat
@ -178,7 +178,7 @@ responseNotification :: ChatTerminal -> ChatController -> ChatResponse -> IO ()
responseNotification t@ChatTerminal {sendNotification} cc = \case responseNotification t@ChatTerminal {sendNotification} cc = \case
-- At the moment of writing received items are created one at a time -- At the moment of writing received items are created one at a time
CRNewChatItems u ((AChatItem _ SMDRcv cInfo ci@ChatItem {chatDir, content = CIRcvMsgContent mc, formattedText}) : _) -> CRNewChatItems u ((AChatItem _ SMDRcv cInfo ci@ChatItem {chatDir, content = CIRcvMsgContent mc, formattedText}) : _) ->
when (chatDirNtf u cInfo chatDir $ isMention ci) $ do when (chatDirNtf u cInfo chatDir $ isUserMention ci) $ do
whenCurrUser cc u $ setActiveChat t cInfo whenCurrUser cc u $ setActiveChat t cInfo
case (cInfo, chatDir) of case (cInfo, chatDir) of
(DirectChat ct, _) -> sendNtf (viewContactName ct <> "> ", text) (DirectChat ct, _) -> sendNtf (viewContactName ct <> "> ", text)
@ -187,7 +187,7 @@ responseNotification t@ChatTerminal {sendNotification} cc = \case
where where
text = msgText mc formattedText text = msgText mc formattedText
CRChatItemUpdated u (AChatItem _ SMDRcv cInfo ci@ChatItem {chatDir, content = CIRcvMsgContent _}) -> CRChatItemUpdated u (AChatItem _ SMDRcv cInfo ci@ChatItem {chatDir, content = CIRcvMsgContent _}) ->
whenCurrUser cc u $ when (chatDirNtf u cInfo chatDir $ isMention ci) $ setActiveChat t cInfo whenCurrUser cc u $ when (chatDirNtf u cInfo chatDir $ isUserMention ci) $ setActiveChat t cInfo
CRContactConnected u ct _ -> when (contactNtf u ct False) $ do CRContactConnected u ct _ -> when (contactNtf u ct False) $ do
whenCurrUser cc u $ setActiveContact t ct whenCurrUser cc u $ setActiveContact t ct
sendNtf (viewContactName ct <> "> ", "connected") sendNtf (viewContactName ct <> "> ", "connected")

7
src/Simplex/Chat/Types.hs
View file

@ -366,6 +366,8 @@ type UserName = Text
type ContactName = Text type ContactName = Text
type MemberName = Text
type GroupName = Text type GroupName = Text
optionalFullName :: ContactName -> Text -> Text optionalFullName :: ContactName -> Text -> Text
@ -800,6 +802,9 @@ memberConn GroupMember {activeConn} = activeConn
memberConnId :: GroupMember -> Maybe ConnId memberConnId :: GroupMember -> Maybe ConnId
memberConnId GroupMember {activeConn} = aConnId <$> activeConn memberConnId GroupMember {activeConn} = aConnId <$> activeConn
sameMemberId :: MemberId -> GroupMember -> Bool
sameMemberId memId GroupMember {memberId} = memId == memberId
memberChatVRange' :: GroupMember -> VersionRangeChat memberChatVRange' :: GroupMember -> VersionRangeChat
memberChatVRange' GroupMember {activeConn, memberChatVRange} = case activeConn of memberChatVRange' GroupMember {activeConn, memberChatVRange} = case activeConn of
Just Connection {peerChatVRange} -> peerChatVRange Just Connection {peerChatVRange} -> peerChatVRange
@ -839,7 +844,7 @@ data NewGroupMember = NewGroupMember
} }
newtype MemberId = MemberId {unMemberId :: ByteString} newtype MemberId = MemberId {unMemberId :: ByteString}
deriving (Eq, Show) deriving (Eq, Ord, Show)
deriving newtype (FromField) deriving newtype (FromField)
instance ToField MemberId where toField (MemberId m) = toField $ Binary m instance ToField MemberId where toField (MemberId m) = toField $ Binary m

8
src/Simplex/Chat/Util.hs
View file

@ -4,7 +4,7 @@
{-# LANGUAGE TupleSections #-} {-# LANGUAGE TupleSections #-}
{-# OPTIONS_GHC -Wno-orphans #-} {-# OPTIONS_GHC -Wno-orphans #-}
module Simplex.Chat.Util (week, encryptFile, chunkSize, liftIOEither, shuffle) where module Simplex.Chat.Util (week, encryptFile, chunkSize, liftIOEither, shuffle, neUnzip3) where
import Control.Exception (Exception) import Control.Exception (Exception)
import Control.Monad import Control.Monad
@ -15,6 +15,7 @@ import Control.Monad.Reader
import Data.Bifunctor (first) import Data.Bifunctor (first)
import qualified Data.ByteString.Lazy as LB import qualified Data.ByteString.Lazy as LB
import Data.List (sortBy) import Data.List (sortBy)
import Data.List.NonEmpty (NonEmpty (..))
import Data.Ord (comparing) import Data.Ord (comparing)
import Data.Time (NominalDiffTime) import Data.Time (NominalDiffTime)
import Data.Word (Word16) import Data.Word (Word16)
@ -56,6 +57,11 @@ liftIOEither :: (MonadIO m, MonadError e m) => IO (Either e a) -> m a
liftIOEither a = liftIO a >>= liftEither liftIOEither a = liftIO a >>= liftEither
{-# INLINE liftIOEither #-} {-# INLINE liftIOEither #-}
neUnzip3 :: NonEmpty (a, b, c) -> (NonEmpty a, NonEmpty b, NonEmpty c)
neUnzip3 ((a, b, c) :| xs) =
let (as, bs, cs) = unzip3 xs
in (a :| as, b :| bs, c :| cs)
newtype InternalException e = InternalException {unInternalException :: e} newtype InternalException e = InternalException {unInternalException :: e}
deriving (Eq, Show) deriving (Eq, Show)

19
src/Simplex/Chat/View.hs
View file

@ -499,7 +499,7 @@ responseToView hu@(currentRH, user_) ChatConfig {logLevel, showReactions, showRe
contactList :: [ContactRef] -> String contactList :: [ContactRef] -> String
contactList cs = T.unpack . T.intercalate ", " $ map (\ContactRef {localDisplayName = n} -> "@" <> n) cs contactList cs = T.unpack . T.intercalate ", " $ map (\ContactRef {localDisplayName = n} -> "@" <> n) cs
unmuted :: User -> ChatInfo c -> ChatItem c d -> [StyledString] -> [StyledString] unmuted :: User -> ChatInfo c -> ChatItem c d -> [StyledString] -> [StyledString]
unmuted u chat ci@ChatItem {chatDir} = unmuted' u chat chatDir $ isMention ci unmuted u chat ci@ChatItem {chatDir} = unmuted' u chat chatDir $ isUserMention ci
unmutedReaction :: User -> ChatInfo c -> CIReaction c d -> [StyledString] -> [StyledString] unmutedReaction :: User -> ChatInfo c -> CIReaction c d -> [StyledString] -> [StyledString]
unmutedReaction u chat CIReaction {chatDir} = unmuted' u chat chatDir False unmutedReaction u chat CIReaction {chatDir} = unmuted' u chat chatDir False
unmuted' :: User -> ChatInfo c -> CIDirection c d -> Bool -> [StyledString] -> [StyledString] unmuted' :: User -> ChatInfo c -> CIDirection c d -> Bool -> [StyledString] -> [StyledString]
@ -588,7 +588,7 @@ viewChats ts tz = concatMap chatPreview . reverse
_ -> [] _ -> []
viewChatItem :: forall c d. MsgDirectionI d => ChatInfo c -> ChatItem c d -> Bool -> CurrentTime -> TimeZone -> [StyledString] viewChatItem :: forall c d. MsgDirectionI d => ChatInfo c -> ChatItem c d -> Bool -> CurrentTime -> TimeZone -> [StyledString]
viewChatItem chat ci@ChatItem {chatDir, meta = meta@CIMeta {itemForwarded, forwardedByMember}, content, quotedItem, file} doShow ts tz = viewChatItem chat ci@ChatItem {chatDir, meta = meta@CIMeta {itemForwarded, forwardedByMember, userMention}, content, quotedItem, file} doShow ts tz =
withGroupMsgForwarded . withItemDeleted <$> viewCI withGroupMsgForwarded . withItemDeleted <$> viewCI
where where
viewCI = case chat of viewCI = case chat of
@ -627,7 +627,7 @@ viewChatItem chat ci@ChatItem {chatDir, meta = meta@CIMeta {itemForwarded, forwa
CIRcvBlocked {} -> receivedWithTime_ ts tz (ttyFromGroup g m) context meta [plainContent content] False CIRcvBlocked {} -> receivedWithTime_ ts tz (ttyFromGroup g m) context meta [plainContent content] False
_ -> showRcvItem from _ -> showRcvItem from
where where
from = ttyFromGroup g m from = ttyFromGroupAttention g m userMention
where where
context = context =
maybe maybe
@ -2178,7 +2178,6 @@ viewChatError isCmd logLevel testView = \case
CEFileNotApproved fileId unknownSrvs -> ["file " <> sShow fileId <> " aborted, unknwon XFTP servers:"] <> map (plain . show) unknownSrvs CEFileNotApproved fileId unknownSrvs -> ["file " <> sShow fileId <> " aborted, unknwon XFTP servers:"] <> map (plain . show) unknownSrvs
CEFallbackToSMPProhibited fileId -> ["recipient tried to accept file " <> sShow fileId <> " via old protocol, prohibited"] CEFallbackToSMPProhibited fileId -> ["recipient tried to accept file " <> sShow fileId <> " via old protocol, prohibited"]
CEInlineFileProhibited _ -> ["A small file sent without acceptance - you can enable receiving such files with -f option."] CEInlineFileProhibited _ -> ["A small file sent without acceptance - you can enable receiving such files with -f option."]
CEInvalidQuote -> ["cannot reply to this message"]
CEInvalidForward -> ["cannot forward message(s)"] CEInvalidForward -> ["cannot forward message(s)"]
CEInvalidChatItemUpdate -> ["cannot update this item"] CEInvalidChatItemUpdate -> ["cannot update this item"]
CEInvalidChatItemDelete -> ["cannot delete this item"] CEInvalidChatItemDelete -> ["cannot delete this item"]
@ -2373,7 +2372,10 @@ ttyFullGroup GroupInfo {localDisplayName = g, groupProfile = GroupProfile {fullN
ttyGroup g <> optFullName g fullName ttyGroup g <> optFullName g fullName
ttyFromGroup :: GroupInfo -> GroupMember -> StyledString ttyFromGroup :: GroupInfo -> GroupMember -> StyledString
ttyFromGroup g m = membershipIncognito g <> ttyFrom (fromGroup_ g m) ttyFromGroup g m = ttyFromGroupAttention g m False
ttyFromGroupAttention :: GroupInfo -> GroupMember -> Bool -> StyledString
ttyFromGroupAttention g m attention = membershipIncognito g <> ttyFrom (fromGroupAttention_ g m attention)
ttyFromGroupEdited :: GroupInfo -> GroupMember -> StyledString ttyFromGroupEdited :: GroupInfo -> GroupMember -> StyledString
ttyFromGroupEdited g m = membershipIncognito g <> ttyFrom (fromGroup_ g m <> "[edited] ") ttyFromGroupEdited g m = membershipIncognito g <> ttyFrom (fromGroup_ g m <> "[edited] ")
@ -2383,7 +2385,12 @@ ttyFromGroupDeleted g m deletedText_ =
membershipIncognito g <> ttyFrom (fromGroup_ g m <> maybe "" (\t -> "[" <> t <> "] ") deletedText_) membershipIncognito g <> ttyFrom (fromGroup_ g m <> maybe "" (\t -> "[" <> t <> "] ") deletedText_)
fromGroup_ :: GroupInfo -> GroupMember -> Text fromGroup_ :: GroupInfo -> GroupMember -> Text
fromGroup_ g m = "#" <> viewGroupName g <> " " <> viewMemberName m <> "> " fromGroup_ g m = fromGroupAttention_ g m False
fromGroupAttention_ :: GroupInfo -> GroupMember -> Bool -> Text
fromGroupAttention_ g m attention =
let attn = if attention then "!" else ""
in "#" <> viewGroupName g <> " " <> viewMemberName m <> attn <> "> "
ttyFrom :: Text -> StyledString ttyFrom :: Text -> StyledString
ttyFrom = styled $ colored Yellow ttyFrom = styled $ colored Yellow

6
tests/ChatTests/Direct.hs
View file

@ -1620,7 +1620,7 @@ testMuteGroup =
cath <## " hello too!" cath <## " hello too!"
concurrentlyN_ concurrentlyN_
[ do [ do
bob <# "#team cath> > bob hello <muted>" bob <# "#team cath!> > bob hello <muted>"
bob <## " hello too! <muted>", bob <## " hello too! <muted>",
do do
alice <# "#team cath> > bob hello" alice <# "#team cath> > bob hello"
@ -1633,7 +1633,7 @@ testMuteGroup =
alice <## " hey bob!" alice <## " hey bob!"
concurrentlyN_ concurrentlyN_
[ do [ do
bob <# "#team alice> > bob hello" bob <# "#team alice!> > bob hello"
bob <## " hey bob!", bob <## " hey bob!",
do do
cath <# "#team alice> > bob hello" cath <# "#team alice> > bob hello"
@ -1647,7 +1647,7 @@ testMuteGroup =
bob <# "#team alice> > cath hello too! <muted>" bob <# "#team alice> > cath hello too! <muted>"
bob <## " hey cath! <muted>", bob <## " hey cath! <muted>",
do do
cath <# "#team alice> > cath hello too!" cath <# "#team alice!> > cath hello too!"
cath <## " hey cath!" cath <## " hey cath!"
] ]
bob ##> "/gs" bob ##> "/gs"

4
tests/ChatTests/Files.hs
View file

@ -372,9 +372,9 @@ testGroupSendImageWithTextAndQuote =
alice <## "use /fc 1 to cancel sending" alice <## "use /fc 1 to cancel sending"
concurrentlyN_ concurrentlyN_
[ do [ do
bob <# "#team alice> > bob hi team" bob <# "#team alice!> > bob hi team"
bob <## " hey bob" bob <## " hey bob"
bob <# "#team alice> sends file test.jpg (136.5 KiB / 139737 bytes)" bob <# "#team alice!> sends file test.jpg (136.5 KiB / 139737 bytes)"
bob <## "use /fr 1 [<dir>/ | <path>] to receive it", bob <## "use /fr 1 [<dir>/ | <path>] to receive it",
do do
cath <# "#team alice> > bob hi team" cath <# "#team alice> > bob hi team"

72
tests/ChatTests/Groups.hs
View file

@ -15,14 +15,17 @@ import ChatTests.Utils
import Control.Concurrent (threadDelay) import Control.Concurrent (threadDelay)
import Control.Concurrent.Async (concurrently_) import Control.Concurrent.Async (concurrently_)
import Control.Monad (forM_, void, when) import Control.Monad (forM_, void, when)
import Data.Bifunctor (second)
import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Char8 as B
import Data.List (intercalate, isInfixOf) import Data.List (intercalate, isInfixOf)
import qualified Data.Map.Strict as M
import qualified Data.Text as T import qualified Data.Text as T
import Simplex.Chat.Controller (ChatConfig (..)) import Simplex.Chat.Controller (ChatConfig (..))
import Simplex.Chat.Library.Internal (uniqueMsgMentions)
import Simplex.Chat.Messages (ChatItemId) import Simplex.Chat.Messages (ChatItemId)
import Simplex.Chat.Options import Simplex.Chat.Options
import Simplex.Chat.Protocol (supportedChatVRange) import Simplex.Chat.Protocol (MemberMention (..), supportedChatVRange)
import Simplex.Chat.Types (VersionRangeChat) import Simplex.Chat.Types (MemberId (..), VersionRangeChat)
import Simplex.Chat.Types.Shared (GroupMemberRole (..)) import Simplex.Chat.Types.Shared (GroupMemberRole (..))
import Simplex.Messaging.Agent.Env.SQLite import Simplex.Messaging.Agent.Env.SQLite
import Simplex.Messaging.Agent.RetryInterval import Simplex.Messaging.Agent.RetryInterval
@ -186,6 +189,9 @@ chatGroupTests = do
it "mark member inactive on reaching quota" testGroupMemberInactive it "mark member inactive on reaching quota" testGroupMemberInactive
describe "group member reports" $ do describe "group member reports" $ do
it "should send report to group owner, admins and moderators, but not other users" testGroupMemberReports it "should send report to group owner, admins and moderators, but not other users" testGroupMemberReports
describe "group member mentions" $ do
it "should send messages with member mentions" testMemberMention
describe "uniqueMsgMentions" testUniqueMsgMentions
where where
_0 = supportedChatVRange -- don't create direct connections _0 = supportedChatVRange -- don't create direct connections
_1 = groupCreateDirectVRange _1 = groupCreateDirectVRange
@ -1044,7 +1050,7 @@ testGroupMessageQuotedReply =
bob <## " hello, all good, you?" bob <## " hello, all good, you?"
concurrently_ concurrently_
( do ( do
alice <# "#team bob> > alice hello! how are you?" alice <# "#team bob!> > alice hello! how are you?"
alice <## " hello, all good, you?" alice <## " hello, all good, you?"
) )
( do ( do
@ -1079,7 +1085,7 @@ testGroupMessageQuotedReply =
alice <## " hi there!" alice <## " hi there!"
) )
( do ( do
bob <# "#team cath> > bob hello, all good, you?" bob <# "#team cath!> > bob hello, all good, you?"
bob <## " hi there!" bob <## " hi there!"
) )
cath #$> ("/_get chat #1 count=1", chat', [((1, "hi there!"), Just (0, "hello, all good, you?"))]) cath #$> ("/_get chat #1 count=1", chat', [((1, "hi there!"), Just (0, "hello, all good, you?"))])
@ -1090,7 +1096,7 @@ testGroupMessageQuotedReply =
alice <## " go on" alice <## " go on"
concurrently_ concurrently_
( do ( do
bob <# "#team alice> > bob will tell more" bob <# "#team alice!> > bob will tell more"
bob <## " go on" bob <## " go on"
) )
( do ( do
@ -1131,7 +1137,7 @@ testGroupMessageUpdate =
bob <## " hi alice" bob <## " hi alice"
concurrently_ concurrently_
( do ( do
alice <# "#team bob> > alice hey 👋" alice <# "#team bob!> > alice hey 👋"
alice <## " hi alice" alice <## " hi alice"
) )
( do ( do
@ -1158,7 +1164,7 @@ testGroupMessageUpdate =
cath <## " greetings!" cath <## " greetings!"
concurrently_ concurrently_
( do ( do
alice <# "#team cath> > alice greetings 🤝" alice <# "#team cath!> > alice greetings 🤝"
alice <## " greetings!" alice <## " greetings!"
) )
( do ( do
@ -1272,7 +1278,7 @@ testGroupMessageDelete =
bob <## " hi alic" bob <## " hi alic"
concurrently_ concurrently_
( do ( do
alice <# "#team bob> > alice hello!" alice <# "#team bob!> > alice hello!"
alice <## " hi alic" alice <## " hi alic"
) )
( do ( do
@ -5423,7 +5429,7 @@ testGroupHistoryQuotes =
alice `send` "> #team @bob (BOB) 2" alice `send` "> #team @bob (BOB) 2"
alice <# "#team > bob BOB" alice <# "#team > bob BOB"
alice <## " 2" alice <## " 2"
bob <# "#team alice> > bob BOB" bob <# "#team alice!> > bob BOB"
bob <## " 2" bob <## " 2"
threadDelay 1000000 threadDelay 1000000
@ -5431,7 +5437,7 @@ testGroupHistoryQuotes =
bob `send` "> #team @alice (ALICE) 3" bob `send` "> #team @alice (ALICE) 3"
bob <# "#team > alice ALICE" bob <# "#team > alice ALICE"
bob <## " 3" bob <## " 3"
alice <# "#team bob> > alice ALICE" alice <# "#team bob!> > alice ALICE"
alice <## " 3" alice <## " 3"
threadDelay 1000000 threadDelay 1000000
@ -6651,3 +6657,49 @@ testGroupMemberReports =
alice #$> ("/_get chat #1 content=report count=100", chat, [(0, "report content [marked deleted by you]")]) alice #$> ("/_get chat #1 content=report count=100", chat, [(0, "report content [marked deleted by you]")])
bob #$> ("/_get chat #1 content=report count=100", chat, [(0, "report content [marked deleted by alice]")]) bob #$> ("/_get chat #1 content=report count=100", chat, [(0, "report content [marked deleted by alice]")])
dan #$> ("/_get chat #1 content=report count=100", chat, [(1, "report content [marked deleted by alice]")]) dan #$> ("/_get chat #1 content=report count=100", chat, [(1, "report content [marked deleted by alice]")])
testMemberMention :: HasCallStack => TestParams -> IO ()
testMemberMention =
testChat3 aliceProfile bobProfile cathProfile $
\alice bob cath -> do
createGroup3 "team" alice bob cath
alice #> "#team hello!"
concurrentlyN_
[ bob <# "#team alice> hello!",
cath <# "#team alice> hello!"
]
bob #> "#team hello @alice"
concurrentlyN_
[ alice <# "#team bob!> hello @alice",
cath <# "#team bob> hello @alice"
]
alice #> "#team hello @bob @bob @cath"
concurrentlyN_
[ bob <# "#team alice!> hello @bob @bob @cath",
cath <# "#team alice!> hello @bob @bob @cath"
]
cath #> "#team hello @Alice" -- not a mention
concurrentlyN_
[ alice <# "#team cath> hello @Alice",
bob <# "#team cath> hello @Alice"
]
testUniqueMsgMentions :: SpecWith TestParams
testUniqueMsgMentions = do
it "1 correct mention" $ \_ ->
uniqueMsgMentions 2 (mm [("alice", "abcd")]) ["alice"]
`shouldBe` (mm [("alice", "abcd")])
it "2 correct mentions" $ \_ ->
uniqueMsgMentions 2 (mm [("alice", "abcd"), ("bob", "efgh")]) ["alice", "bob"]
`shouldBe` (mm [("alice", "abcd"), ("bob", "efgh")])
it "2 correct mentions with repetition" $ \_ ->
uniqueMsgMentions 2 (mm [("alice", "abcd"), ("bob", "efgh")]) ["alice", "alice", "alice", "bob", "bob", "bob"]
`shouldBe` (mm [("alice", "abcd"), ("bob", "efgh")])
it "too many mentions - drop extras" $ \_ ->
uniqueMsgMentions 3 (mm [("a", "abcd"), ("b", "efgh"), ("c", "1234"), ("d", "5678")]) ["a", "a", "a", "b", "b", "c", "d"]
`shouldBe` (mm [("a", "abcd"), ("b", "efgh"), ("c", "1234")])
it "repeated-with-different name - drop extras" $ \_ ->
uniqueMsgMentions 2 (mm [("alice", "abcd"), ("alice2", "abcd"), ("bob", "efgh"), ("bob2", "efgh")]) ["alice", "alice2", "bob", "bob2"]
`shouldBe` (mm [("alice", "abcd"), ("bob", "efgh")])
where
mm = M.fromList . map (second $ MemberMention . MemberId)

22
tests/MarkdownTests.hs
View file

@ -19,6 +19,7 @@ markdownTests = do
textWithUri textWithUri
textWithEmail textWithEmail
textWithPhone textWithPhone
textWithMentions
multilineMarkdownList multilineMarkdownList
textFormat :: Spec textFormat :: Spec
@ -180,8 +181,10 @@ textWithEmail = describe "text with Email" do
parseMarkdown "chat@simplex.chat test" `shouldBe` email "chat@simplex.chat" <> " test" parseMarkdown "chat@simplex.chat test" `shouldBe` email "chat@simplex.chat" <> " test"
parseMarkdown "test1 chat@simplex.chat test2" `shouldBe` "test1 " <> email "chat@simplex.chat" <> " test2" parseMarkdown "test1 chat@simplex.chat test2" `shouldBe` "test1 " <> email "chat@simplex.chat" <> " test2"
it "ignored as markdown" do it "ignored as markdown" do
parseMarkdown "chat @simplex.chat" `shouldBe` "chat @simplex.chat" parseMarkdown "chat @simplex.chat" `shouldBe` "chat " <> mention "simplex.chat" "@simplex.chat"
parseMarkdown "this is chat @simplex.chat" `shouldBe` "this is chat @simplex.chat" parseMarkdown "this is chat @simplex.chat" `shouldBe` "this is chat " <> mention "simplex.chat" "@simplex.chat"
parseMarkdown "this is chat@ simplex.chat" `shouldBe` "this is chat@ simplex.chat"
parseMarkdown "this is chat @ simplex.chat" `shouldBe` "this is chat @ simplex.chat"
phone :: Text -> Markdown phone :: Text -> Markdown
phone = Markdown $ Just Phone phone = Markdown $ Just Phone
@ -204,6 +207,21 @@ textWithPhone = describe "text with Phone" do
it "ignored as markdown (double spaces)" $ it "ignored as markdown (double spaces)" $
parseMarkdown "test 07777 777 777 test" `shouldBe` "test 07777 777 777 test" parseMarkdown "test 07777 777 777 test" `shouldBe` "test 07777 777 777 test"
mention :: Text -> Text -> Markdown
mention = Markdown . Just . Mention
textWithMentions :: Spec
textWithMentions = describe "text with mentions" do
it "correct markdown" do
parseMarkdown "@alice" `shouldBe` mention "alice" "@alice"
parseMarkdown "hello @alice" `shouldBe` "hello " <> mention "alice" "@alice"
parseMarkdown "hello @alice !" `shouldBe` "hello " <> mention "alice" "@alice" <> " !"
parseMarkdown "@'alice jones'" `shouldBe` mention "alice jones" "@'alice jones'"
parseMarkdown "hello @'alice jones'!" `shouldBe` "hello " <> mention "alice jones" "@'alice jones'" <> "!"
it "ignored as markdown" $ do
parseMarkdown "hello @'alice jones!" `shouldBe` "hello @'alice jones!"
parseMarkdown "hello @ alice!" `shouldBe` "hello @ alice!"
uri' :: Text -> FormattedText uri' :: Text -> FormattedText
uri' = FormattedText $ Just Uri uri' = FormattedText $ Just Uri

14
tests/ProtocolTests.hs
View file

@ -116,10 +116,10 @@ decodeChatMessageTest = describe "Chat message encoding/decoding" $ do
#==# XMsgNew (MCSimple (extMsgContent (MCText "hello") Nothing)) #==# XMsgNew (MCSimple (extMsgContent (MCText "hello") Nothing))
it "x.msg.new simple text - timed message TTL" $ it "x.msg.new simple text - timed message TTL" $
"{\"v\":\"1\",\"event\":\"x.msg.new\",\"params\":{\"content\":{\"text\":\"hello\",\"type\":\"text\"},\"ttl\":3600}}" "{\"v\":\"1\",\"event\":\"x.msg.new\",\"params\":{\"content\":{\"text\":\"hello\",\"type\":\"text\"},\"ttl\":3600}}"
#==# XMsgNew (MCSimple (ExtMsgContent (MCText "hello") Nothing (Just 3600) Nothing)) #==# XMsgNew (MCSimple (ExtMsgContent (MCText "hello") [] Nothing (Just 3600) Nothing))
it "x.msg.new simple text - live message" $ it "x.msg.new simple text - live message" $
"{\"v\":\"1\",\"event\":\"x.msg.new\",\"params\":{\"content\":{\"text\":\"hello\",\"type\":\"text\"},\"live\":true}}" "{\"v\":\"1\",\"event\":\"x.msg.new\",\"params\":{\"content\":{\"text\":\"hello\",\"type\":\"text\"},\"live\":true}}"
#==# XMsgNew (MCSimple (ExtMsgContent (MCText "hello") Nothing Nothing (Just True))) #==# XMsgNew (MCSimple (ExtMsgContent (MCText "hello") [] Nothing Nothing (Just True)))
it "x.msg.new simple link" $ it "x.msg.new simple link" $
"{\"v\":\"1\",\"event\":\"x.msg.new\",\"params\":{\"content\":{\"text\":\"https://simplex.chat\",\"type\":\"link\",\"preview\":{\"description\":\"SimpleX Chat\",\"image\":\"data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAgA\",\"title\":\"SimpleX Chat\",\"uri\":\"https://simplex.chat\"}}}}" "{\"v\":\"1\",\"event\":\"x.msg.new\",\"params\":{\"content\":{\"text\":\"https://simplex.chat\",\"type\":\"link\",\"preview\":{\"description\":\"SimpleX Chat\",\"image\":\"data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAgA\",\"title\":\"SimpleX Chat\",\"uri\":\"https://simplex.chat\"}}}}"
#==# XMsgNew (MCSimple (extMsgContent (MCLink "https://simplex.chat" $ LinkPreview {uri = "https://simplex.chat", title = "SimpleX Chat", description = "SimpleX Chat", image = ImageData "data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAgA", content = Nothing}) Nothing)) #==# XMsgNew (MCSimple (extMsgContent (MCLink "https://simplex.chat" $ LinkPreview {uri = "https://simplex.chat", title = "SimpleX Chat", description = "SimpleX Chat", image = ImageData "data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAgA", content = Nothing}) Nothing))
@ -146,22 +146,22 @@ decodeChatMessageTest = describe "Chat message encoding/decoding" $ do
##==## ChatMessage ##==## ChatMessage
chatInitialVRange chatInitialVRange
(Just $ SharedMsgId "\1\2\3\4") (Just $ SharedMsgId "\1\2\3\4")
(XMsgNew (MCQuote quotedMsg (ExtMsgContent (MCText "hello to you too") Nothing (Just 3600) Nothing))) (XMsgNew (MCQuote quotedMsg (ExtMsgContent (MCText "hello to you too") [] Nothing (Just 3600) Nothing)))
it "x.msg.new quote - live message" $ it "x.msg.new quote - live message" $
"{\"v\":\"1\",\"msgId\":\"AQIDBA==\",\"event\":\"x.msg.new\",\"params\":{\"content\":{\"text\":\"hello to you too\",\"type\":\"text\"},\"quote\":{\"content\":{\"text\":\"hello there!\",\"type\":\"text\"},\"msgRef\":{\"msgId\":\"BQYHCA==\",\"sent\":true,\"sentAt\":\"1970-01-01T00:00:01.000000001Z\"}},\"live\":true}}" "{\"v\":\"1\",\"msgId\":\"AQIDBA==\",\"event\":\"x.msg.new\",\"params\":{\"content\":{\"text\":\"hello to you too\",\"type\":\"text\"},\"quote\":{\"content\":{\"text\":\"hello there!\",\"type\":\"text\"},\"msgRef\":{\"msgId\":\"BQYHCA==\",\"sent\":true,\"sentAt\":\"1970-01-01T00:00:01.000000001Z\"}},\"live\":true}}"
##==## ChatMessage ##==## ChatMessage
chatInitialVRange chatInitialVRange
(Just $ SharedMsgId "\1\2\3\4") (Just $ SharedMsgId "\1\2\3\4")
(XMsgNew (MCQuote quotedMsg (ExtMsgContent (MCText "hello to you too") Nothing Nothing (Just True)))) (XMsgNew (MCQuote quotedMsg (ExtMsgContent (MCText "hello to you too") [] Nothing Nothing (Just True))))
it "x.msg.new forward" $ it "x.msg.new forward" $
"{\"v\":\"1\",\"msgId\":\"AQIDBA==\",\"event\":\"x.msg.new\",\"params\":{\"content\":{\"text\":\"hello\",\"type\":\"text\"},\"forward\":true}}" "{\"v\":\"1\",\"msgId\":\"AQIDBA==\",\"event\":\"x.msg.new\",\"params\":{\"content\":{\"text\":\"hello\",\"type\":\"text\"},\"forward\":true}}"
##==## ChatMessage chatInitialVRange (Just $ SharedMsgId "\1\2\3\4") (XMsgNew $ MCForward (extMsgContent (MCText "hello") Nothing)) ##==## ChatMessage chatInitialVRange (Just $ SharedMsgId "\1\2\3\4") (XMsgNew $ MCForward (extMsgContent (MCText "hello") Nothing))
it "x.msg.new forward - timed message TTL" $ it "x.msg.new forward - timed message TTL" $
"{\"v\":\"1\",\"msgId\":\"AQIDBA==\",\"event\":\"x.msg.new\",\"params\":{\"content\":{\"text\":\"hello\",\"type\":\"text\"},\"forward\":true,\"ttl\":3600}}" "{\"v\":\"1\",\"msgId\":\"AQIDBA==\",\"event\":\"x.msg.new\",\"params\":{\"content\":{\"text\":\"hello\",\"type\":\"text\"},\"forward\":true,\"ttl\":3600}}"
##==## ChatMessage chatInitialVRange (Just $ SharedMsgId "\1\2\3\4") (XMsgNew $ MCForward (ExtMsgContent (MCText "hello") Nothing (Just 3600) Nothing)) ##==## ChatMessage chatInitialVRange (Just $ SharedMsgId "\1\2\3\4") (XMsgNew $ MCForward (ExtMsgContent (MCText "hello") [] Nothing (Just 3600) Nothing))
it "x.msg.new forward - live message" $ it "x.msg.new forward - live message" $
"{\"v\":\"1\",\"msgId\":\"AQIDBA==\",\"event\":\"x.msg.new\",\"params\":{\"content\":{\"text\":\"hello\",\"type\":\"text\"},\"forward\":true,\"live\":true}}" "{\"v\":\"1\",\"msgId\":\"AQIDBA==\",\"event\":\"x.msg.new\",\"params\":{\"content\":{\"text\":\"hello\",\"type\":\"text\"},\"forward\":true,\"live\":true}}"
##==## ChatMessage chatInitialVRange (Just $ SharedMsgId "\1\2\3\4") (XMsgNew $ MCForward (ExtMsgContent (MCText "hello") Nothing Nothing (Just True))) ##==## ChatMessage chatInitialVRange (Just $ SharedMsgId "\1\2\3\4") (XMsgNew $ MCForward (ExtMsgContent (MCText "hello") [] Nothing Nothing (Just True)))
it "x.msg.new simple text with file" $ it "x.msg.new simple text with file" $
"{\"v\":\"1\",\"event\":\"x.msg.new\",\"params\":{\"content\":{\"text\":\"hello\",\"type\":\"text\"},\"file\":{\"fileSize\":12345,\"fileName\":\"photo.jpg\"}}}" "{\"v\":\"1\",\"event\":\"x.msg.new\",\"params\":{\"content\":{\"text\":\"hello\",\"type\":\"text\"},\"file\":{\"fileSize\":12345,\"fileName\":\"photo.jpg\"}}}"
#==# XMsgNew (MCSimple (extMsgContent (MCText "hello") (Just FileInvitation {fileName = "photo.jpg", fileSize = 12345, fileDigest = Nothing, fileConnReq = Nothing, fileInline = Nothing, fileDescr = Nothing}))) #==# XMsgNew (MCSimple (extMsgContent (MCText "hello") (Just FileInvitation {fileName = "photo.jpg", fileSize = 12345, fileDigest = Nothing, fileConnReq = Nothing, fileInline = Nothing, fileDescr = Nothing})))
@ -193,7 +193,7 @@ decodeChatMessageTest = describe "Chat message encoding/decoding" $ do
##==## ChatMessage chatInitialVRange (Just $ SharedMsgId "\1\2\3\4") (XMsgNew $ MCForward (extMsgContent (MCText "hello") (Just FileInvitation {fileName = "photo.jpg", fileSize = 12345, fileDigest = Nothing, fileConnReq = Nothing, fileInline = Nothing, fileDescr = Nothing}))) ##==## ChatMessage chatInitialVRange (Just $ SharedMsgId "\1\2\3\4") (XMsgNew $ MCForward (extMsgContent (MCText "hello") (Just FileInvitation {fileName = "photo.jpg", fileSize = 12345, fileDigest = Nothing, fileConnReq = Nothing, fileInline = Nothing, fileDescr = Nothing})))
it "x.msg.update" $ it "x.msg.update" $
"{\"v\":\"1\",\"event\":\"x.msg.update\",\"params\":{\"msgId\":\"AQIDBA==\", \"content\":{\"text\":\"hello\",\"type\":\"text\"}}}" "{\"v\":\"1\",\"event\":\"x.msg.update\",\"params\":{\"msgId\":\"AQIDBA==\", \"content\":{\"text\":\"hello\",\"type\":\"text\"}}}"
#==# XMsgUpdate (SharedMsgId "\1\2\3\4") (MCText "hello") Nothing Nothing #==# XMsgUpdate (SharedMsgId "\1\2\3\4") (MCText "hello") [] Nothing Nothing
it "x.msg.del" $ it "x.msg.del" $
"{\"v\":\"1\",\"event\":\"x.msg.del\",\"params\":{\"msgId\":\"AQIDBA==\"}}" "{\"v\":\"1\",\"event\":\"x.msg.del\",\"params\":{\"msgId\":\"AQIDBA==\"}}"
#==# XMsgDel (SharedMsgId "\1\2\3\4") Nothing #==# XMsgDel (SharedMsgId "\1\2\3\4") Nothing

4
tests/SchemaDump.hs
View file

@ -158,8 +158,8 @@ saveQueryPlans = it "verify and overwrite query plans" $ \TestParams {chatQueryS
agentQueryStats agentQueryStats
(createAgentStore (DBOpts testAgentDB "" False True TQOff) MCError) (createAgentStore (DBOpts testAgentDB "" False True TQOff) MCError)
(const $ pure ()) (const $ pure ())
chatSavedPlans' `shouldBe` chatSavedPlans chatSavedPlans' == chatSavedPlans `shouldBe` True
agentSavedPlans' `shouldBe` agentSavedPlans agentSavedPlans' == agentSavedPlans `shouldBe` True
removeFile testDB removeFile testDB
removeFile testAgentDB removeFile testAgentDB
where where

1
tests/ValidNames.hs
View file

@ -21,6 +21,7 @@ testMkValidName = do
mkValidName "J . . Doe" `shouldBe` "J . Doe" mkValidName "J . . Doe" `shouldBe` "J . Doe"
mkValidName "@alice" `shouldBe` "alice" mkValidName "@alice" `shouldBe` "alice"
mkValidName "#alice" `shouldBe` "alice" mkValidName "#alice" `shouldBe` "alice"
mkValidName "'alice" `shouldBe` "alice"
mkValidName " alice" `shouldBe` "alice" mkValidName " alice" `shouldBe` "alice"
mkValidName "alice " `shouldBe` "alice" mkValidName "alice " `shouldBe` "alice"
mkValidName "John Doe" `shouldBe` "John Doe" mkValidName "John Doe" `shouldBe` "John Doe"