dandri/simplex-chat
1
0
Fork 0
mirror of https://github.com/simplex-chat/simplex-chat.git synced 2026-05-25 20:44:38 +00:00
Code Issues Packages Projects Releases Wiki Activity

core: update message text when forwarding and quoting to reflect changes in mentioned member names (#5586)

Browse Source 
* update message text when forwarding and quoting to reflect changes in mentioned member names

* fix, test

* forward mentions to the same chat, refactor

* comment

* tests

* test markdown conversion to text

* simplify

* unused

* comments
This commit is contained in:
Evgeny
2025-01-30 10:06:26 +00:00
committed by GitHub
parent 621b291da1
commit 2d719273a8
13 changed files with 460 additions and 276 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Simplex/Chat/Library/Commands.hs
+59 -47
View File
@@ -37,7 +37,7 @@ import Data.Either (fromRight, partitionEithers, rights)
import Data.Foldable (foldr')
import Data.Functor (($>))
import Data.Int (Int64)
import Data.List (find, foldl', isSuffixOf, partition, sortOn, zipWith5)
import Data.List (find, foldl', isSuffixOf, partition, sortOn, zipWith4)
import Data.List.NonEmpty (NonEmpty (..))
import qualified Data.List.NonEmpty as L
import Data.Map.Strict (Map)
@@ -80,7 +80,7 @@ import Simplex.Chat.Store.Shared
import Simplex.Chat.Types
import Simplex.Chat.Types.Preferences
import Simplex.Chat.Types.Shared
import Simplex.Chat.Util (liftIOEither, neUnzip3)
import Simplex.Chat.Util (liftIOEither)
import qualified Simplex.Chat.Util as U
import Simplex.FileTransfer.Description (FileDescriptionURI (..), maxFileSize, maxFileSizeHard)
import Simplex.Messaging.Agent as Agent
@@ -542,8 +542,11 @@ processChatCommand' vr = \case
withContactLock "sendMessage" chatId $
sendContactContentMessages user chatId live itemTTL (L.map composedMessageReq cms)
CTGroup ->
withGroupLock "sendMessage" chatId $
sendGroupContentMessages user chatId live itemTTL (L.map composedMessageReq cms)
withGroupLock "sendMessage" chatId $ do
(gInfo, cmrs) <- withFastStore $ \db -> do
g <- getGroupInfo db vr user chatId
(g,) <$> mapM (composedMessageReqMentions db user g) cms
sendGroupContentMessages user gInfo live itemTTL cmrs
CTLocal -> pure $ chatCmdError (Just user) "not supported"
CTContactRequest -> pure $ chatCmdError (Just user) "not supported"
CTContactConnection -> pure $ chatCmdError (Just user) "not supported"
@@ -628,7 +631,8 @@ processChatCommand' vr = \case
let changed = mc /= oldMC
if changed || fromMaybe False itemLive
then do
(mentionedMembers, mentions') <- withFastStore $ \db -> getMentionedMembers db user gInfo ft_ mentions
ciMentions <- withFastStore $ \db -> getCIMentions db user gInfo ft_ mentions
let mentions' = M.map (\CIMention {memberId} -> MsgMention {memberId}) ciMentions
SndMessage {msgId} <- sendGroupMessage user gInfo ms (XMsgUpdate itemSharedMId mc mentions' (ttl' <$> itemTimed) (justTrue . (live &&) =<< itemLive))
ci' <- withFastStore' $ \db -> do
currentTs <- liftIO getCurrentTime
@@ -636,7 +640,7 @@ processChatCommand' vr = \case
addInitialAndNewCIVersions db itemId (chatItemTs' ci, oldMC) (currentTs, mc)
let edited = itemLive /= Just True
ci' <- updateGroupChatItem db user groupId ci (CISndMsgContent mc) edited live $ Just msgId
updateGroupCIMentions db gInfo ci' mentionedMembers
updateGroupCIMentions db gInfo ci' ciMentions
startUpdatedTimedItemThread user (ChatRef CTGroup groupId) ci ci'
pure $ CRChatItemUpdated user (AChatItem SCTGroup SMDSnd (GroupChat gInfo) ci')
else pure $ CRChatItemNotChanged user (AChatItem SCTGroup SMDSnd (GroupChat gInfo) ci)
@@ -831,7 +835,7 @@ processChatCommand' vr = \case
MCFile t -> t /= ""
MCReport {} -> True
MCUnknown {} -> True
APIForwardChatItems (ChatRef toCType toChatId) (ChatRef fromCType fromChatId) itemIds itemTTL -> withUser $ \user -> case toCType of
APIForwardChatItems toChat@(ChatRef toCType toChatId) fromChat@(ChatRef fromCType fromChatId) itemIds itemTTL -> withUser $ \user -> case toCType of
CTDirect -> do
cmrs <- prepareForward user
case L.nonEmpty cmrs of
@@ -843,8 +847,9 @@ processChatCommand' vr = \case
cmrs <- prepareForward user
case L.nonEmpty cmrs of
Just cmrs' ->
withGroupLock "forwardChatItem, to group" toChatId $
sendGroupContentMessages user toChatId False itemTTL cmrs'
withGroupLock "forwardChatItem, to group" toChatId $ do
gInfo <- withFastStore $ \db -> getGroupInfo db vr user toChatId
sendGroupContentMessages user gInfo False itemTTL cmrs'
Nothing -> pure $ CRNewChatItems user []
CTLocal -> do
cmrs <- prepareForward user
@@ -865,23 +870,26 @@ processChatCommand' vr = \case
ciComposeMsgReq ct (CChatItem md ci) (mc', file) =
let itemId = chatItemId' ci
ciff = forwardCIFF ci $ Just (CIFFContact (forwardName ct) (toMsgDirection md) (Just fromChatId) (Just itemId))
in (composedMessage file mc', ciff, msgContentTexts mc')
in (composedMessage file mc', ciff, msgContentTexts mc', M.empty)
where
forwardName :: Contact -> ContactName
forwardName Contact {profile = LocalProfile {displayName, localAlias}}
| localAlias /= "" = localAlias
| otherwise = displayName
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
catMaybes <$> mapM (\ci -> ciComposeMsgReq gInfo ci <$$> prepareMsgReq ci) items
where
ciComposeMsgReq :: GroupInfo -> CChatItem 'CTGroup -> (MsgContent, Maybe CryptoFile) -> ComposedMessageReq
ciComposeMsgReq gInfo (CChatItem md ci) (mc', file) = do
ciComposeMsgReq gInfo (CChatItem md ci@ChatItem {mentions, formattedText}) (mc, file) = do
let itemId = chatItemId' ci
ciff = forwardCIFF ci $ Just (CIFFGroup (forwardName gInfo) (toMsgDirection md) (Just fromChatId) (Just itemId))
in (composedMessage file mc', ciff, msgContentTexts mc')
-- updates text to reflect current mentioned member names
(mc', _, mentions') = updatedMentionNames mc formattedText mentions
-- only includes mentions when forwarding to the same group
ciMentions = if toChat == fromChat then mentions' else M.empty
-- no need to have mentions in ComposedMessage, they are in ciMentions
in (ComposedMessage file Nothing mc' M.empty, ciff, msgContentTexts mc', ciMentions)
where
forwardName :: GroupInfo -> ContactName
forwardName GroupInfo {groupProfile = GroupProfile {displayName}} = displayName
@@ -892,7 +900,7 @@ processChatCommand' vr = \case
ciComposeMsgReq :: CChatItem 'CTLocal -> (MsgContent, Maybe CryptoFile) -> ComposedMessageReq
ciComposeMsgReq (CChatItem _ ci) (mc', file) =
let ciff = forwardCIFF ci Nothing
in (composedMessage file mc', ciff, msgContentTexts mc')
in (composedMessage file mc', ciff, msgContentTexts mc', M.empty)
CTContactRequest -> throwChatError $ CECommandError "not supported"
CTContactConnection -> throwChatError $ CECommandError "not supported"
where
@@ -2986,15 +2994,15 @@ processChatCommand' vr = \case
where
assertVoiceAllowed :: Contact -> CM ()
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))
processComposedMessages :: Contact -> CM ChatResponse
processComposedMessages ct = do
(fInvs_, ciFiles_) <- L.unzip <$> setupSndFileTransfers
timed_ <- sndContactCITimed live ct itemTTL
(msgContainers, quotedItems_, mms) <- neUnzip3 <$> prepareMsgs (L.zip cmrs fInvs_) timed_
(msgContainers, quotedItems_) <- L.unzip <$> prepareMsgs (L.zip cmrs fInvs_) timed_
msgs_ <- sendDirectContactMessages user ct $ L.map XMsgNew msgContainers
let itemsData = prepareSndItemsData (L.toList cmrs) (L.toList mms) (L.toList ciFiles_) (L.toList quotedItems_) msgs_
let itemsData = prepareSndItemsData (L.toList cmrs) (L.toList ciFiles_) (L.toList quotedItems_) msgs_
when (length itemsData /= length cmrs) $ logError "sendContactContentMessages: cmrs and itemsData length mismatch"
r@(_, cis) <- partitionEithers <$> saveSndChatItems user (CDDirectSnd ct) itemsData timed_ live
processSendErrs user r
@@ -3005,19 +3013,18 @@ processChatCommand' vr = \case
where
setupSndFileTransfers :: CM (NonEmpty (Maybe FileInvitation, Maybe (CIFile 'MDSnd)))
setupSndFileTransfers =
forM cmrs $ \(ComposedMessage {fileSource = file_}, _, _) -> case file_ of
forM cmrs $ \(ComposedMessage {fileSource = file_}, _, _, _) -> case file_ of
Just file -> do
fileSize <- checkSndFile file
(fInv, ciFile) <- xftpSndFileTransfer user file fileSize 1 $ CGContact ct
pure (Just fInv, Just ciFile)
Nothing -> pure (Nothing, Nothing)
prepareMsgs :: NonEmpty (ComposedMessageReq, Maybe FileInvitation) -> Maybe CITimed -> CM (NonEmpty (MsgContainer, Maybe (CIQuote 'CTDirect), (Map MemberName MentionedMember, Map MemberName MemberMention)))
prepareMsgs :: NonEmpty (ComposedMessageReq, Maybe FileInvitation) -> Maybe CITimed -> CM (NonEmpty (MsgContainer, Maybe (CIQuote 'CTDirect)))
prepareMsgs cmsFileInvs timed_ = withFastStore $ \db ->
forM cmsFileInvs $ \((ComposedMessage {quotedItemId, msgContent = mc}, itemForwarded, _), fInv_) -> do
let mms = (M.empty, M.empty)
forM cmsFileInvs $ \((ComposedMessage {quotedItemId, msgContent = mc}, itemForwarded, _, _), fInv_) -> do
case (quotedItemId, itemForwarded) of
(Nothing, Nothing) -> pure (MCSimple (ExtMsgContent mc M.empty fInv_ (ttl' <$> timed_) (justTrue live)), Nothing, mms)
(Nothing, Just _) -> pure (MCForward (ExtMsgContent mc M.empty fInv_ (ttl' <$> timed_) (justTrue live)), Nothing, mms)
(Nothing, Nothing) -> pure (MCSimple (ExtMsgContent mc M.empty fInv_ (ttl' <$> timed_) (justTrue live)), Nothing)
(Nothing, Just _) -> pure (MCForward (ExtMsgContent mc M.empty fInv_ (ttl' <$> timed_) (justTrue live)), Nothing)
(Just qiId, Nothing) -> do
CChatItem _ qci@ChatItem {meta = CIMeta {itemTs, itemSharedMsgId}, formattedText, file} <-
getDirectChatItem db user contactId qiId
@@ -3025,7 +3032,7 @@ processChatCommand' vr = \case
let msgRef = MsgRef {msgId = itemSharedMsgId, sentAt = itemTs, sent, memberId = Nothing}
qmc = quoteContent mc origQmc file
quotedItem = CIQuote {chatDir = qd, itemId = Just qiId, sharedMsgId = itemSharedMsgId, sentAt = itemTs, content = qmc, formattedText}
pure (MCQuote QuotedMsg {msgRef, content = qmc} (ExtMsgContent mc M.empty fInv_ (ttl' <$> timed_) (justTrue live)), Just quotedItem, mms)
pure (MCQuote QuotedMsg {msgRef, content = qmc} (ExtMsgContent mc M.empty fInv_ (ttl' <$> timed_) (justTrue live)), Just quotedItem)
(Just _, Just _) -> throwError SEInvalidQuote
where
quoteData :: ChatItem c d -> ExceptT StoreError IO (MsgContent, CIQDirection 'CTDirect, Bool)
@@ -3033,10 +3040,10 @@ processChatCommand' vr = \case
quoteData ChatItem {content = CISndMsgContent qmc} = pure (qmc, CIQDirectSnd, True)
quoteData ChatItem {content = CIRcvMsgContent qmc} = pure (qmc, CIQDirectRcv, False)
quoteData _ = throwError SEInvalidQuote
sendGroupContentMessages :: User -> GroupId -> Bool -> Maybe Int -> NonEmpty ComposedMessageReq -> CM ChatResponse
sendGroupContentMessages user groupId live itemTTL cmrs = do
sendGroupContentMessages :: User -> GroupInfo -> Bool -> Maybe Int -> NonEmpty ComposedMessageReq -> CM ChatResponse
sendGroupContentMessages user gInfo live itemTTL cmrs = do
assertMultiSendable live cmrs
Group gInfo ms <- withFastStore $ \db -> getGroup db vr user groupId
ms <- withFastStore' $ \db -> getGroupMembers db vr user gInfo
sendGroupContentMessages_ user gInfo ms live itemTTL cmrs
sendGroupContentMessages_ :: User -> GroupInfo -> [GroupMember] -> Bool -> Maybe Int -> NonEmpty ComposedMessageReq -> CM ChatResponse
sendGroupContentMessages_ user gInfo@GroupInfo {groupId, membership} ms live itemTTL cmrs = do
@@ -3053,15 +3060,15 @@ processChatCommand' vr = \case
findProhibited :: [ComposedMessageReq] -> Maybe GroupFeature
findProhibited =
foldr'
(\(ComposedMessage {fileSource, msgContent = mc}, _, (_, ft)) acc -> prohibitedGroupContent gInfo membership mc ft fileSource <|> acc)
(\(ComposedMessage {fileSource, msgContent = mc}, _, (_, ft), _) acc -> prohibitedGroupContent gInfo membership mc ft fileSource <|> acc)
Nothing
processComposedMessages :: CM ChatResponse
processComposedMessages = do
(fInvs_, ciFiles_) <- L.unzip <$> setupSndFileTransfers (length $ filter memberCurrent ms)
timed_ <- sndGroupCITimed live gInfo itemTTL
(msgContainers, quotedItems_, mms) <- neUnzip3 <$> prepareMsgs (L.zip cmrs fInvs_) timed_
(msgs_, gsr) <- sendGroupMessages user gInfo ms $ L.map XMsgNew msgContainers
let itemsData = prepareSndItemsData (L.toList cmrs) (L.toList mms) (L.toList ciFiles_) (L.toList quotedItems_) (L.toList msgs_)
(chatMsgEvents, quotedItems_) <- L.unzip <$> prepareMsgs (L.zip cmrs fInvs_) timed_
(msgs_, gsr) <- sendGroupMessages user gInfo ms chatMsgEvents
let itemsData = prepareSndItemsData (L.toList cmrs) (L.toList ciFiles_) (L.toList quotedItems_) (L.toList msgs_)
cis_ <- saveSndChatItems user (CDGroupSnd gInfo) itemsData timed_ live
when (length itemsData /= length cmrs) $ logError "sendGroupContentMessages: cmrs and cis_ length mismatch"
createMemberSndStatuses cis_ msgs_ gsr
@@ -3074,16 +3081,17 @@ processChatCommand' vr = \case
where
setupSndFileTransfers :: Int -> CM (NonEmpty (Maybe FileInvitation, Maybe (CIFile 'MDSnd)))
setupSndFileTransfers n =
forM cmrs $ \(ComposedMessage {fileSource = file_}, _, _) -> case file_ of
forM cmrs $ \(ComposedMessage {fileSource = file_}, _, _, _) -> case file_ of
Just file -> do
fileSize <- checkSndFile file
(fInv, ciFile) <- xftpSndFileTransfer user file fileSize n $ CGGroup gInfo ms
pure (Just fInv, Just ciFile)
Nothing -> pure (Nothing, Nothing)
prepareMsgs :: NonEmpty (ComposedMessageReq, Maybe FileInvitation) -> Maybe CITimed -> CM (NonEmpty (MsgContainer, Maybe (CIQuote 'CTGroup), (Map MemberName MentionedMember, Map MemberName MemberMention)))
prepareMsgs :: NonEmpty (ComposedMessageReq, Maybe FileInvitation) -> Maybe CITimed -> CM (NonEmpty (ChatMsgEvent 'Json, Maybe (CIQuote 'CTGroup)))
prepareMsgs cmsFileInvs timed_ = withFastStore $ \db ->
forM cmsFileInvs $ \((ComposedMessage {quotedItemId, msgContent = mc, mentions}, itemForwarded, (_, ft_)), fInv_) ->
prepareGroupMsg db user gInfo mc ft_ mentions quotedItemId itemForwarded fInv_ timed_ live
forM cmsFileInvs $ \((ComposedMessage {quotedItemId, msgContent = mc}, itemForwarded, _, ciMentions), fInv_) ->
let mentions = M.map (\CIMention {memberId} -> MsgMention {memberId}) ciMentions
in prepareGroupMsg db user gInfo mc mentions quotedItemId itemForwarded fInv_ timed_ live
createMemberSndStatuses ::
[Either ChatError (ChatItem 'CTGroup 'MDSnd)] ->
NonEmpty (Either ChatError SndMessage) ->
@@ -3127,7 +3135,7 @@ processChatCommand' vr = \case
-- 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
-- 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")
xftpSndFileTransfer :: User -> CryptoFile -> Integer -> Int -> ContactOrGroup -> CM (FileInvitation, CIFile 'MDSnd)
xftpSndFileTransfer user file fileSize n contactOrGroup = do
@@ -3146,13 +3154,12 @@ processChatCommand' vr = \case
pure (fInv, ciFile)
prepareSndItemsData ::
[ComposedMessageReq] ->
[(Map MemberName MentionedMember, Map MemberName MemberMention)] ->
[Maybe (CIFile 'MDSnd)] ->
[Maybe (CIQuote c)] ->
[Either ChatError SndMessage] ->
[Either ChatError (NewSndChatItemData c)]
prepareSndItemsData =
zipWith5 $ \(ComposedMessage {msgContent}, itemForwarded, ts) mm f q -> \case
zipWith4 $ \(ComposedMessage {msgContent}, itemForwarded, ts, mm) f q -> \case
Right msg -> Right $ NewSndChatItemData msg (CISndMsgContent msgContent) ts mm f q itemForwarded
Left e -> Left e -- step over original error
processSendErrs :: User -> ([ChatError], [ChatItem c d]) -> CM ()
@@ -3179,12 +3186,12 @@ processChatCommand' vr = \case
getCommandGroupChatItems :: User -> Int64 -> NonEmpty ChatItemId -> CM (GroupInfo, [CChatItem 'CTGroup])
getCommandGroupChatItems user gId itemIds = do
gInfo <- withFastStore $ \db -> getGroupInfo db vr user gId
(errs, items) <- lift $ partitionEithers <$> withStoreBatch (\db -> map (getGroupCI db) (L.toList itemIds))
(errs, items) <- lift $ partitionEithers <$> withStoreBatch (\db -> map (getGroupCI db gInfo) (L.toList itemIds))
unless (null errs) $ toView $ CRChatErrors (Just user) errs
pure (gInfo, items)
where
getGroupCI :: DB.Connection -> ChatItemId -> IO (Either ChatError (CChatItem 'CTGroup))
getGroupCI db itemId = runExceptT . withExceptT ChatErrorStore $ getGroupChatItem db user gId itemId
getGroupCI :: DB.Connection -> GroupInfo -> ChatItemId -> IO (Either ChatError (CChatItem 'CTGroup))
getGroupCI db gInfo itemId = runExceptT . withExceptT ChatErrorStore $ getGroupCIWithReactions db user gInfo itemId
getCommandLocalChatItems :: User -> Int64 -> NonEmpty ChatItemId -> CM (NoteFolder, [CChatItem 'CTLocal])
getCommandLocalChatItems user nfId itemIds = do
nf <- withStore $ \db -> getNoteFolder db user nfId
@@ -3211,11 +3218,11 @@ processChatCommand' vr = \case
where
assertNoQuotes :: CM ()
assertNoQuotes =
when (any (\(ComposedMessage {quotedItemId}, _, _) -> isJust quotedItemId) cmrs) $
when (any (\(ComposedMessage {quotedItemId}, _, _, _) -> isJust quotedItemId) cmrs) $
throwChatError (CECommandError "createNoteFolderContentItems: quotes not supported")
createLocalFiles :: NoteFolder -> UTCTime -> CM (NonEmpty (Maybe (CIFile 'MDSnd)))
createLocalFiles nf createdAt =
forM cmrs $ \(ComposedMessage {fileSource = file_}, _, _) ->
forM cmrs $ \(ComposedMessage {fileSource = file_}, _, _, _) ->
forM file_ $ \cf@CryptoFile {filePath, cryptoArgs} -> do
fsFilePath <- lift $ toFSFilePath filePath
fileSize <- liftIO $ CF.getFileContentsSize $ CryptoFile fsFilePath cryptoArgs
@@ -3228,7 +3235,7 @@ processChatCommand' vr = \case
NonEmpty (Maybe (CIFile 'MDSnd)) ->
NonEmpty (CIContent 'MDSnd, Maybe (CIFile 'MDSnd), Maybe CIForwardedFrom, (Text, Maybe MarkdownList))
prepareLocalItemsData =
L.zipWith $ \(ComposedMessage {msgContent = mc}, itemForwarded, ts) f ->
L.zipWith $ \(ComposedMessage {msgContent = mc}, itemForwarded, ts, _) f ->
(CISndMsgContent mc, f, itemForwarded, ts)
getConnQueueInfo user Connection {connId, agentConnId = AgentConnId acId} = do
msgInfo <- withFastStore' (`getLastRcvMsgInfo` connId)
@@ -3251,13 +3258,18 @@ updatedServers p' srvs UserOperatorServers {operator, smpServers, xftpServers} =
disableSrv srv@UserServer {preset} =
AUS SDBStored $ if preset then srv {enabled = False} else srv {deleted = True}
type ComposedMessageReq = (ComposedMessage, Maybe CIForwardedFrom, (Text, Maybe MarkdownList))
type ComposedMessageReq = (ComposedMessage, Maybe CIForwardedFrom, (Text, Maybe MarkdownList), Map MemberName CIMention)
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)
composedMessageReq cm@ComposedMessage {msgContent = mc} = (cm, Nothing, msgContentTexts mc, M.empty)
composedMessageReqMentions :: DB.Connection -> User -> GroupInfo -> ComposedMessage -> ExceptT StoreError IO ComposedMessageReq
composedMessageReqMentions db user g cm@ComposedMessage {msgContent = mc, mentions} = do
let ts@(_, ft_) = msgContentTexts mc
(cm,Nothing,ts,) <$> getCIMentions db user g ft_ mentions
data ChangedProfileContact = ChangedProfileContact
{ ct :: Contact,
src/Simplex/Chat/Library/Internal.hs
+65 -34
View File
@@ -29,6 +29,7 @@ import Crypto.Random (ChaChaDRG)
import Data.Bifunctor (first)
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as B
import Data.Char (isDigit)
import Data.Containers.ListUtils (nubOrd)
import Data.Either (partitionEithers, rights)
import Data.Fixed (div')
@@ -188,22 +189,24 @@ toggleNtf user m ntfOn =
forM_ (memberConnId m) $ \connId ->
withAgent (\a -> toggleConnectionNtfs a connId ntfOn) `catchChatError` (toView . CRChatError (Just user))
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 db user g@GroupInfo {groupId, membership} mc ft_ memberMentions quotedItemId_ itemForwarded fInv_ timed_ live = case (quotedItemId_, itemForwarded) of
(Nothing, Nothing) -> do
mms@(_, mentions) <- getMentionedMembers db user g ft_ memberMentions
pure (MCSimple (ExtMsgContent mc mentions fInv_ (ttl' <$> timed_) (justTrue live)), Nothing, mms)
prepareGroupMsg :: DB.Connection -> User -> GroupInfo -> MsgContent -> Map MemberName MsgMention -> Maybe ChatItemId -> Maybe CIForwardedFrom -> Maybe FileInvitation -> Maybe CITimed -> Bool -> ExceptT StoreError IO (ChatMsgEvent 'Json, Maybe (CIQuote 'CTGroup))
prepareGroupMsg db user g@GroupInfo {membership} mc mentions quotedItemId_ itemForwarded fInv_ timed_ live = case (quotedItemId_, itemForwarded) of
(Nothing, Nothing) ->
let mc' = MCSimple $ ExtMsgContent mc mentions fInv_ (ttl' <$> timed_) (justTrue live)
in pure (XMsgNew mc', Nothing)
(Nothing, Just _) ->
pure (MCForward (ExtMsgContent mc M.empty fInv_ (ttl' <$> timed_) (justTrue live)), Nothing, (M.empty, M.empty))
let mc' = MCForward $ ExtMsgContent mc mentions fInv_ (ttl' <$> timed_) (justTrue live)
in pure (XMsgNew mc', Nothing)
(Just quotedItemId, Nothing) -> do
mms@(_, mentions) <- getMentionedMembers db user g ft_ memberMentions
CChatItem _ qci@ChatItem {meta = CIMeta {itemTs, itemSharedMsgId}, formattedText, file} <-
getGroupChatItem db user groupId quotedItemId
CChatItem _ qci@ChatItem {meta = CIMeta {itemTs, itemSharedMsgId}, formattedText, mentions = quoteMentions, file} <-
getGroupCIWithReactions db user g quotedItemId
(origQmc, qd, sent, GroupMember {memberId}) <- quoteData qci membership
let msgRef = MsgRef {msgId = itemSharedMsgId, sentAt = itemTs, sent, memberId = Just memberId}
qmc = quoteContent mc origQmc file
quotedItem = CIQuote {chatDir = qd, itemId = Just quotedItemId, sharedMsgId = itemSharedMsgId, sentAt = itemTs, content = qmc, formattedText}
pure (MCQuote QuotedMsg {msgRef, content = qmc} (ExtMsgContent mc mentions fInv_ (ttl' <$> timed_) (justTrue live)), Just quotedItem, mms)
(qmc', ft', _) = updatedMentionNames qmc formattedText quoteMentions
quotedItem = CIQuote {chatDir = qd, itemId = Just quotedItemId, sharedMsgId = itemSharedMsgId, sentAt = itemTs, content = qmc', formattedText = ft'}
mc' = MCQuote QuotedMsg {msgRef, content = qmc'} (ExtMsgContent mc mentions fInv_ (ttl' <$> timed_) (justTrue live))
pure (XMsgNew mc', Just quotedItem)
(Just _, Just _) -> throwError SEInvalidQuote
where
quoteData :: ChatItem c d -> GroupMember -> ExceptT StoreError IO (MsgContent, CIQDirection 'CTGroup, Bool, GroupMember)
@@ -212,42 +215,72 @@ prepareGroupMsg db user g@GroupInfo {groupId, membership} mc ft_ memberMentions
quoteData ChatItem {chatDir = CIGroupRcv m, content = CIRcvMsgContent qmc} _ = pure (qmc, CIQGroupRcv $ Just m, False, m)
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
updatedMentionNames :: MsgContent -> Maybe MarkdownList -> Map MemberName CIMention -> (MsgContent, Maybe MarkdownList, Map MemberName CIMention)
updatedMentionNames mc ft_ mentions = case ft_ of
Just ft | not (null ft) && not (null mentions) && not (all sameName $ M.assocs mentions) ->
let (mentions', ft') = mapAccumL update M.empty ft
text = T.concat $ map markdownText ft'
in (mc {text} :: MsgContent, Just ft', mentions')
_ -> (mc, ft_, mentions)
where
sameName (name, CIMention {memberRef}) = case memberRef of
Just CIMentionMember {displayName} -> case T.stripPrefix displayName name of
Just rest
| T.null rest -> True
| otherwise -> case T.uncons rest of
Just ('_', suffix) -> T.all isDigit suffix
_ -> False
Nothing -> False
Nothing -> True
update mentions' ft@(FormattedText f _) = case f of
Just (Mention name) -> case M.lookup name mentions of
Just mm@CIMention {memberRef} ->
let name' = uniqueMentionName 0 $ case memberRef of
Just CIMentionMember {displayName} -> displayName
Nothing -> name
in (M.insert name' mm mentions', FormattedText (Just $ Mention name') ('@' `T.cons` viewName name'))
Nothing -> (mentions', ft)
_ -> (mentions', ft)
where
uniqueMentionName :: Int -> Text -> Text
uniqueMentionName pfx name =
let prefixed = if pfx == 0 then name else (name `T.snoc` '_') <> tshow pfx
in if prefixed `M.member` mentions' then uniqueMentionName (pfx + 1) name else prefixed
getCIMentions :: DB.Connection -> User -> GroupInfo -> Maybe MarkdownList -> Map MemberName GroupMemberId -> ExceptT StoreError IO (Map MemberName CIMention)
getCIMentions db user GroupInfo {groupId} ft_ mentions = case ft_ of
Just ft | not (null 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)
mapM (getMentionedGroupMember db user groupId) mentions
_ -> pure 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) ->
getRcvCIMentions :: DB.Connection -> User -> GroupInfo -> Maybe MarkdownList -> Map MemberName MsgMention -> IO (Map MemberName CIMention)
getRcvCIMentions db user GroupInfo {groupId} ft_ mentions = case ft_ of
Just ft | not (null 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 :: Int -> Map MemberName MsgMention -> [ContactName] -> Map MemberName MsgMention
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 ->
Just mm@MsgMention {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
Just ft | not (null ft) -> M.fromList . catMaybes <$> mapM get (nubOrd $ mentionedNames ft)
_ -> pure M.empty
where
get name =
fmap (name,) . eitherToMaybe
@@ -1608,8 +1641,7 @@ saveSndChatItem user cd msg content = saveSndChatItem' user cd msg content Nothi
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 = do
let itemTexts = ciContentTexts content
itemMentions = (M.empty, M.empty)
saveSndChatItems user cd [Right NewSndChatItemData {msg, content, itemTexts, itemMentions, ciFile, quotedItem, itemForwarded}] itemTimed live >>= \case
saveSndChatItems user cd [Right NewSndChatItemData {msg, content, itemTexts, itemMentions = M.empty, ciFile, quotedItem, itemForwarded}] itemTimed live >>= \case
[Right ci] -> pure ci
_ -> throwChatError $ CEInternalError "saveSndChatItem': expected 1 item"
@@ -1617,7 +1649,7 @@ data NewSndChatItemData c = NewSndChatItemData
{ msg :: SndMessage,
content :: CIContent 'MDSnd,
itemTexts :: (Text, Maybe MarkdownList),
itemMentions :: (Map MemberName MentionedMember, Map MemberName MemberMention),
itemMentions :: Map MemberName CIMention,
ciFile :: Maybe (CIFile 'MDSnd),
quotedItem :: Maybe (CIQuote c),
itemForwarded :: Maybe CIForwardedFrom
@@ -1643,9 +1675,8 @@ saveSndChatItems user cd itemsData itemTimed live = do
ciId <- createNewSndChatItem db user cd msg content quotedItem itemForwarded itemTimed live createdAt
forM_ ciFile $ \CIFile {fileId} -> updateFileTransferChatItemId db fileId ciId 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
CDGroupSnd g | not (null itemMentions) -> createGroupCIMentions db g ci itemMentions
_ -> pure ci
saveRcvChatItemNoParse :: (ChatTypeI c, ChatTypeQuotable c) => User -> ChatDirection c 'MDRcv -> RcvMessage -> UTCTime -> CIContent 'MDRcv -> CM (ChatItem c 'MDRcv)
@@ -1658,18 +1689,18 @@ saveRcvChatItem user cd msg@RcvMessage {sharedMsgId_} brokerTs content =
ciContentNoParse :: CIContent 'MDRcv -> (CIContent 'MDRcv, (Text, Maybe MarkdownList))
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' :: (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 MsgMention -> CM (ChatItem c 'MDRcv)
saveRcvChatItem' user cd msg@RcvMessage {chatMsgEvent, forwardedByMember} sharedMsgId_ brokerTs (content, (t, ft_)) ciFile itemTimed live mentions = do
createdAt <- liftIO getCurrentTime
withStore' $ \db -> do
when (ciRequiresAttention content || contactChatDeleted cd) $ updateChatTs db user cd createdAt
(mentions' :: Map MemberName MentionedMember, userMention) <- case cd of
(mentions' :: Map MemberName CIMention, userMention) <- case cd of
CDGroupRcv g@GroupInfo {membership} _ -> do
mentions' <- getRcvMentionedMembers db user g ft_ mentions
mentions' <- getRcvCIMentions 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'
userMention' = userReply || any (\CIMention {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
src/Simplex/Chat/Library/Subscriber.hs
+6 -6
View File
@@ -902,10 +902,10 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
quotedItemId_ = quoteItemId =<< quotedItem
fInv_ = fst <$> fInvDescr_
-- 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 (_t, ft_) = msgContentTexts mc
(chatMsgEvent, _) <- withStore $ \db -> prepareGroupMsg db user gInfo mc M.empty quotedItemId_ Nothing fInv_ itemTimed False
let senderVRange = memberChatVRange' sender
xMsgNewChatMsg = ChatMessage {chatVRange = senderVRange, msgId = itemSharedMsgId, chatMsgEvent = XMsgNew msgContainer}
xMsgNewChatMsg = ChatMessage {chatVRange = senderVRange, msgId = itemSharedMsgId, chatMsgEvent}
fileDescrEvents <- case (snd <$> fInvDescr_, itemSharedMsgId) of
(Just fileDescrText, Just msgId) -> do
partSize <- asks $ xftpDescrPartSize . config
@@ -1782,7 +1782,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
reactions <- maybe (pure []) (\sharedMsgId -> withStore' $ \db -> getGroupCIReactions db gInfo memberId sharedMsgId) sharedMsgId_
groupMsgToView gInfo ci' {reactions}
groupMessageUpdate :: GroupInfo -> GroupMember -> SharedMsgId -> MsgContent -> Map MemberName MemberMention -> RcvMessage -> UTCTime -> Maybe Int -> Maybe Bool -> CM ()
groupMessageUpdate :: GroupInfo -> GroupMember -> SharedMsgId -> MsgContent -> Map MemberName MsgMention -> RcvMessage -> UTCTime -> Maybe Int -> Maybe Bool -> CM ()
groupMessageUpdate gInfo@GroupInfo {groupId} m@GroupMember {groupMemberId, memberId} sharedMsgId mc mentions msg@RcvMessage {msgId} brokerTs ttl_ live_
| prohibitedSimplexLinks gInfo m ft_ =
messageWarning $ "x.msg.update ignored: feature not allowed " <> groupFeatureNameText GFSimplexLinks
@@ -1817,9 +1817,9 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
addInitialAndNewCIVersions db (chatItemId' ci) (chatItemTs' ci, oldMC) (brokerTs, mc)
reactions <- getGroupCIReactions db gInfo memberId sharedMsgId
let edited = itemLive /= Just True
mentionedMembers <- getRcvMentionedMembers db user gInfo ft_ mentions
ciMentions <- getRcvCIMentions db user gInfo ft_ mentions
ci' <- updateGroupChatItem db user groupId ci {reactions} content edited live $ Just msgId
updateGroupCIMentions db gInfo ci' mentionedMembers
updateGroupCIMentions db gInfo ci' ciMentions
toView $ CRChatItemUpdated user (AChatItem SCTGroup SMDRcv (GroupChat gInfo) ci')
startUpdatedTimedItemThread user (ChatRef CTGroup groupId) ci ci'
else toView $ CRChatItemNotChanged user (AChatItem SCTGroup SMDRcv (GroupChat gInfo) ci)
src/Simplex/Chat/Markdown.hs
+34 -1
View File
@@ -16,7 +16,7 @@ import qualified Data.Aeson as J
import qualified Data.Aeson.TH as JQ
import Data.Attoparsec.Text (Parser)
import qualified Data.Attoparsec.Text as A
import Data.Char (isDigit, isPunctuation)
import Data.Char (isDigit, isPunctuation, isSpace)
import Data.Either (fromRight)
import Data.Functor (($>))
import Data.List (foldl', intercalate)
@@ -267,6 +267,36 @@ markdownP = mconcat <$> A.many' fragmentP
Just (CRDataGroup _) -> XLGroup
Nothing -> XLContact
markdownText :: FormattedText -> Text
markdownText (FormattedText f_ t) = case f_ of
Nothing -> t
Just f -> case f of
Bold -> around '*'
Italic -> around '_'
StrikeThrough -> around '~'
Snippet -> around '`'
Secret -> around '#'
Colored (FormatColor c) -> color c
Uri -> t
SimplexLink {} -> t
Mention _ -> t
Email -> t
Phone -> t
where
around c = c `T.cons` t `T.snoc` c
color c = case colorStr c of
Just cStr -> cStr <> t `T.snoc` '!'
Nothing -> t
colorStr = \case
Red -> Just "!1 "
Green -> Just "!2 "
Blue -> Just "!3 "
Yellow -> Just "!4 "
Cyan -> Just "!5 "
Magenta -> Just "!6 "
Black -> Nothing
White -> Nothing
displayNameTextP :: Parser Text
displayNameTextP = quoted '\'' <|> takeNameTill (== ' ')
where
@@ -276,6 +306,9 @@ displayNameTextP = quoted '\'' <|> takeNameTill (== ' ')
quoted c = A.char c *> takeNameTill (== c) <* A.char c
refChar c = c > ' ' && c /= '#' && c /= '@' && c /= '\''
viewName :: Text -> Text
viewName s = if T.any isSpace s then "'" <> s <> "'" else s
$(JQ.deriveJSON (enumJSON $ dropPrefix "XL") ''SimplexLinkType)
$(JQ.deriveJSON (sumTypeJSON fstToLower) ''Format)
src/Simplex/Chat/Messages.hs
+7 -8
View File
@@ -153,8 +153,8 @@ data ChatItem (c :: ChatType) (d :: MsgDirection) = ChatItem
meta :: CIMeta c 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,
-- The key is a name used in the message text, used to look up CIMention.
mentions :: Map MemberName CIMention,
formattedText :: Maybe MarkdownList,
quotedItem :: Maybe (CIQuote c),
reactions :: [CIReactionCount],
@@ -162,15 +162,14 @@ data ChatItem (c :: ChatType) (d :: MsgDirection) = ChatItem
}
deriving (Show)
data MentionedMember = MentionedMember
data CIMention = CIMention
{ memberId :: MemberId,
-- member record can be created later than the mention is received
-- TODO [mentions] should we create member record for "unknown member" in this case?
memberRef :: Maybe MentionedMemberInfo
memberRef :: Maybe CIMentionMember
}
deriving (Eq, Show)
data MentionedMemberInfo = MentionedMemberInfo
data CIMentionMember = CIMentionMember
{ groupMemberId :: GroupMemberId,
displayName :: Text, -- use `displayName` in copy/share actions
localAlias :: Maybe Text, -- use `fromMaybe displayName localAlias` in chat view
@@ -1400,9 +1399,9 @@ $(JQ.deriveToJSON defaultJSON ''CIQuote)
$(JQ.deriveJSON defaultJSON ''CIReactionCount)
$(JQ.deriveJSON defaultJSON ''MentionedMemberInfo)
$(JQ.deriveJSON defaultJSON ''CIMentionMember)
$(JQ.deriveJSON defaultJSON ''MentionedMember)
$(JQ.deriveJSON defaultJSON ''CIMention)
instance (ChatTypeI c, MsgDirectionI d) => FromJSON (ChatItem c d) where
parseJSON = $(JQ.mkParseJSON defaultJSON ''ChatItem)
src/Simplex/Chat/Protocol.hs
+6 -6
View File
@@ -312,7 +312,7 @@ data AChatMessage = forall e. MsgEncodingI e => ACMsg (SMsgEncoding e) (ChatMess
data ChatMsgEvent (e :: MsgEncoding) where
XMsgNew :: MsgContainer -> ChatMsgEvent 'Json
XMsgFileDescr :: {msgId :: SharedMsgId, fileDescr :: FileDescr} -> ChatMsgEvent 'Json
XMsgUpdate :: {msgId :: SharedMsgId, content :: MsgContent, mentions :: Map MemberName MemberMention, ttl :: Maybe Int, live :: Maybe Bool} -> ChatMsgEvent 'Json
XMsgUpdate :: {msgId :: SharedMsgId, content :: MsgContent, mentions :: Map MemberName MsgMention, ttl :: Maybe Int, live :: Maybe Bool} -> ChatMsgEvent 'Json
XMsgDel :: SharedMsgId -> Maybe MemberId -> ChatMsgEvent 'Json
XMsgDeleted :: ChatMsgEvent 'Json
XMsgReact :: {msgId :: SharedMsgId, memberId :: Maybe MemberId, reaction :: MsgReaction, add :: Bool} -> ChatMsgEvent 'Json
@@ -539,12 +539,12 @@ isMCForward = \case
_ -> False
data MsgContent
= MCText Text
= MCText {text :: Text}
| MCLink {text :: Text, preview :: LinkPreview}
| MCImage {text :: Text, image :: ImageData}
| MCVideo {text :: Text, image :: ImageData, duration :: Int}
| MCVoice {text :: Text, duration :: Int}
| MCFile Text
| MCFile {text :: Text}
| MCReport {text :: Text, reason :: ReportReason}
| MCUnknown {tag :: Text, text :: Text, json :: J.Object}
deriving (Eq, Show)
@@ -601,17 +601,17 @@ data ExtMsgContent = ExtMsgContent
-- 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,
mentions :: Map MemberName MsgMention,
file :: Maybe FileInvitation,
ttl :: Maybe Int,
live :: Maybe Bool
}
deriving (Eq, Show)
data MemberMention = MemberMention {memberId :: MemberId}
data MsgMention = MsgMention {memberId :: MemberId}
deriving (Eq, Show)
$(JQ.deriveJSON defaultJSON ''MemberMention)
$(JQ.deriveJSON defaultJSON ''MsgMention)
$(JQ.deriveJSON defaultJSON ''QuotedMsg)
src/Simplex/Chat/Store/Groups.hs
+8 -8
View File
@@ -150,7 +150,7 @@ import Data.Ord (Down (..))
import Data.Text (Text)
import Data.Time.Clock (UTCTime (..), getCurrentTime)
import Simplex.Chat.Messages
import Simplex.Chat.Protocol (MemberMention (..), groupForwardVersion)
import Simplex.Chat.Protocol (MsgMention (..), groupForwardVersion)
import Simplex.Chat.Store.Direct
import Simplex.Chat.Store.Shared
import Simplex.Chat.Types
@@ -800,7 +800,7 @@ getGroupMember db vr user@User {userId} groupId groupMemberId =
(groupMemberQuery <> " WHERE m.group_id = ? AND m.group_member_id = ? AND m.user_id = ?")
(userId, groupId, groupMemberId, userId)
getMentionedGroupMember :: DB.Connection -> User -> GroupId -> GroupMemberId -> ExceptT StoreError IO MentionedMember
getMentionedGroupMember :: DB.Connection -> User -> GroupId -> GroupMemberId -> ExceptT StoreError IO CIMention
getMentionedGroupMember db User {userId} groupId gmId =
ExceptT $ firstRow toMentionedMember (SEGroupMemberNotFound gmId) $
DB.query
@@ -808,15 +808,15 @@ getMentionedGroupMember db User {userId} groupId gmId =
(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} =
getMentionedMemberByMemberId :: DB.Connection -> User -> GroupId -> MsgMention -> IO CIMention
getMentionedMemberByMemberId db User {userId} groupId MsgMention {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}
mentionedMember = CIMention {memberId, memberRef = Nothing}
mentionedMemberQuery :: Query
mentionedMemberQuery =
@@ -826,10 +826,10 @@ mentionedMemberQuery =
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, GroupMemberRole, Text, Maybe Text) -> CIMention
toMentionedMember (groupMemberId, memberId, memberRole, displayName, localAlias) =
let memberRef = Just MentionedMemberInfo {groupMemberId, displayName, localAlias, memberRole}
in MentionedMember {memberId, memberRef}
let memberRef = Just CIMentionMember {groupMemberId, displayName, localAlias, memberRole}
in CIMention {memberId, memberRef}
getGroupMemberById :: DB.Connection -> VersionRangeChat -> User -> GroupMemberId -> ExceptT StoreError IO GroupMember
getGroupMemberById db vr user@User {userId} groupMemberId =
src/Simplex/Chat/Store/Messages.hs
+7 -7
View File
@@ -2295,15 +2295,15 @@ 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))
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 :: forall d. DB.Connection -> GroupInfo -> ChatItem 'CTGroup d -> Map MemberName CIMention -> 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
rows = map (\(name, CIMention {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.Connection -> GroupInfo -> ChatItem 'CTGroup d -> Map MemberName CIMention -> IO (ChatItem 'CTGroup d)
updateGroupCIMentions db g ci@ChatItem {mentions} mentions'
| mentions' == mentions = pure ci
| otherwise = do
@@ -2789,7 +2789,7 @@ getGroupCIReactions db GroupInfo {groupId} itemMemberId itemSharedMsgId =
|]
(groupId, itemMemberId, itemSharedMsgId)
getGroupCIMentions :: DB.Connection -> ChatItemId -> IO (Map MemberName MentionedMember)
getGroupCIMentions :: DB.Connection -> ChatItemId -> IO (Map MemberName CIMention)
getGroupCIMentions db ciId =
M.fromList . map mentionedMember
<$> DB.query
@@ -2803,13 +2803,13 @@ getGroupCIMentions db ciId =
|]
(Only ciId)
where
mentionedMember :: (ContactName, MemberId, Maybe GroupMemberId, Maybe GroupMemberRole, Maybe Text, Maybe Text) -> (ContactName, MentionedMember)
mentionedMember :: (ContactName, MemberId, Maybe GroupMemberId, Maybe GroupMemberRole, Maybe Text, Maybe Text) -> (ContactName, CIMention)
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}
Just CIMentionMember {groupMemberId, displayName, localAlias, memberRole}
_ -> Nothing
in (name, MentionedMember {memberId, memberRef})
in (name, CIMention {memberId, memberRef})
getACIReactions :: DB.Connection -> AChatItem -> IO AChatItem
getACIReactions db aci@(AChatItem _ md chat ci@ChatItem {meta = CIMeta {itemSharedMsgId}}) = case itemSharedMsgId of
src/Simplex/Chat/Util.hs
+1 -7
View File
@@ -4,7 +4,7 @@
{-# LANGUAGE TupleSections #-}
{-# OPTIONS_GHC -Wno-orphans #-}
module Simplex.Chat.Util (week, encryptFile, chunkSize, liftIOEither, shuffle, neUnzip3) where
module Simplex.Chat.Util (week, encryptFile, chunkSize, liftIOEither, shuffle) where
import Control.Exception (Exception)
import Control.Monad
@@ -15,7 +15,6 @@ import Control.Monad.Reader
import Data.Bifunctor (first)
import qualified Data.ByteString.Lazy as LB
import Data.List (sortBy)
import Data.List.NonEmpty (NonEmpty (..))
import Data.Ord (comparing)
import Data.Time (NominalDiffTime)
import Data.Word (Word16)
@@ -57,11 +56,6 @@ liftIOEither :: (MonadIO m, MonadError e m) => IO (Either e a) -> m a
liftIOEither a = liftIO a >>= liftEither
{-# 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}
deriving (Eq, Show)
src/Simplex/Chat/View.hs
+1 -4
View File
@@ -17,7 +17,7 @@ import qualified Data.Aeson as J
import qualified Data.Aeson.TH as JQ
import qualified Data.ByteString.Char8 as B
import qualified Data.ByteString.Lazy.Char8 as LB
import Data.Char (isSpace, toUpper)
import Data.Char (toUpper)
import Data.Function (on)
import Data.Int (Int64)
import Data.List (groupBy, intercalate, intersperse, partition, sortOn)
@@ -2404,9 +2404,6 @@ ttyToGroup g = membershipIncognito g <> ttyTo ("#" <> viewGroupName g <> " ")
ttyToGroupEdited :: GroupInfo -> StyledString
ttyToGroupEdited g = membershipIncognito g <> ttyTo ("#" <> viewGroupName g <> " [edited] ")
viewName :: Text -> Text
viewName s = if T.any isSpace s then "'" <> s <> "'" else s
ttyFilePath :: FilePath -> StyledString
ttyFilePath = plain