dandri/simplex-chat
1
0
Fork 0
mirror of https://github.com/simplex-chat/simplex-chat.git synced 2026-07-17 21:42:17 +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
apps/simplex-directory-service/src/Directory/Events.hs
+1 -1
View File
@@ -226,7 +226,7 @@ directoryCmdP =
gc f = f <$> (A.space *> A.decimal <* A.char ':') <*> displayNameTextP
viewName :: Text -> Text
viewName n = if any (== ' ') (T.unpack n) then "'" <> n <> "'" else n
viewName n = if T.any (== ' ') n then "'" <> n <> "'" else n
directoryCmdTag :: DirectoryCmd r -> Text
directoryCmdTag = \case
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
tests/ChatTests/Groups.hs
+99 -4
View File
@@ -21,10 +21,11 @@ import Data.List (intercalate, isInfixOf)
import qualified Data.Map.Strict as M
import qualified Data.Text as T
import Simplex.Chat.Controller (ChatConfig (..))
import Simplex.Chat.Library.Internal (uniqueMsgMentions)
import Simplex.Chat.Messages (ChatItemId)
import Simplex.Chat.Library.Internal (uniqueMsgMentions, updatedMentionNames)
import Simplex.Chat.Markdown (parseMaybeMarkdownList)
import Simplex.Chat.Messages (CIMention (..), CIMentionMember (..), ChatItemId)
import Simplex.Chat.Options
import Simplex.Chat.Protocol (MemberMention (..), supportedChatVRange)
import Simplex.Chat.Protocol (MsgMention (..), MsgContent (..), msgContentText, supportedChatVRange)
import Simplex.Chat.Types (MemberId (..), VersionRangeChat)
import Simplex.Chat.Types.Shared (GroupMemberRole (..))
import Simplex.Messaging.Agent.Env.SQLite
@@ -191,7 +192,9 @@ chatGroupTests = do
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
it "should forward and quote message updating mentioned member name" testForwardQuoteMention
describe "uniqueMsgMentions" testUniqueMsgMentions
describe "updatedMentionNames" testUpdatedMentionNames
where
_0 = supportedChatVRange -- don't create direct connections
_1 = groupCreateDirectVRange
@@ -6684,6 +6687,72 @@ testMemberMention =
bob <# "#team cath> hello @Alice"
]
testForwardQuoteMention :: HasCallStack => TestParams -> IO ()
testForwardQuoteMention =
testChat3 aliceProfile bobProfile cathProfile $
\alice bob cath -> do
createGroup3 "team" alice bob cath
bob #> "#team hello @alice @cath"
concurrentlyN_
[ alice <# "#team bob!> hello @alice @cath",
cath <# "#team bob!> hello @alice @cath"
]
-- quote mentions
alice `send` "> #team @bob (hello) hi there!"
alice <# "#team > bob hello @alice @cath"
alice <## " hi there!"
concurrently_
( do
bob <# "#team alice!> > bob hello @alice @cath"
bob <## " hi there!"
)
( do
cath <# "#team alice> > bob hello @alice @cath"
cath <## " hi there!"
)
-- forward mentions to the same group
alice `send` "#team <- #team hello"
alice <# "#team <- #team"
alice <## " hello @alice @cath"
concurrentlyN_
[ do
bob <# "#team alice> -> forwarded"
bob <## " hello @alice @cath",
do
cath <# "#team alice!> -> forwarded"
cath <## " hello @alice @cath"
]
-- forward mentions
alice `send` "@bob <- #team hello"
alice <# "@bob <- #team"
alice <## " hello @alice @cath"
bob <# "alice> -> forwarded"
bob <## " hello @alice @cath"
-- member renamed to duplicate name
cath ##> "/p alice_1"
cath <## "user profile is changed to alice_1 (your 1 contacts are notified)"
alice <## "contact cath changed to alice_1"
alice <## "use @alice_1 <message> to send messages"
-- mention changed in quoted mentions
alice `send` "> #team @bob (hello) hi there!"
alice <# "#team > bob hello @alice @alice_1"
alice <## " hi there!"
concurrently_
( do
bob <# "#team alice!> > bob hello @alice @alice_1"
bob <## " hi there!"
)
( do
cath <# "#team alice> > bob hello @alice @alice_1"
cath <## " hi there!"
)
-- mention changed in forwarded message
alice `send` "@bob <- #team hello"
alice <# "@bob <- #team"
alice <## " hello @alice @alice_1"
bob <# "alice> -> forwarded"
bob <## " hello @alice @alice_1"
testUniqueMsgMentions :: SpecWith TestParams
testUniqueMsgMentions = do
it "1 correct mention" $ \_ ->
@@ -6702,4 +6771,30 @@ testUniqueMsgMentions = do
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)
mm = M.fromList . map (second $ MsgMention . MemberId)
testUpdatedMentionNames :: SpecWith TestParams
testUpdatedMentionNames = do
it "keep mentions" $ \_ -> do
test (mm [("alice", Just "alice"), ("bob", Nothing)]) "hello @alice @bob"
`shouldBe` "hello @alice @bob"
test (mm [("alice_1", Just "alice"), ("alice", Just "alice")]) "hello @alice @alice_1"
`shouldBe` "hello @alice @alice_1"
it "keep non-mentions" $ \_ -> do
test (mm []) "hello @alice @bob"
`shouldBe` "hello @alice @bob"
test (mm [("alice", Just "alice")]) "hello @alice @bob"
`shouldBe` "hello @alice @bob"
it "replace changed names" $ \_ -> do
test (mm [("alice", Just "Alice Jones"), ("bob", Just "robert")]) "hello @alice @bob"
`shouldBe` "hello @'Alice Jones' @robert"
test (mm [("alice", Just "alice"), ("cath", Just "alice")]) "hello @alice @cath"
`shouldBe` "hello @alice @alice_1"
where
test mentions t =
let (mc', _, _) = updatedMentionNames (MCText t) (parseMaybeMarkdownList t) mentions
in msgContentText mc'
mm = M.fromList . map (second mentionedMember)
mentionedMember name_ = CIMention {memberId = MemberId "abcd", memberRef = memberInfo <$> name_}
where
memberInfo name = CIMentionMember {groupMemberId = 1, displayName = name, localAlias = Nothing, memberRole = GRMember}
tests/MarkdownTests.hs
+166 -143
View File
@@ -7,6 +7,7 @@ module MarkdownTests where
import Data.List.NonEmpty (NonEmpty)
import Data.Text (Text)
import qualified Data.Text as T
import Simplex.Chat.Markdown
import System.Console.ANSI.Types
import Test.Hspec
@@ -22,79 +23,99 @@ markdownTests = do
textWithMentions
multilineMarkdownList
infixr 1 ==>, <==, <==>, ==>>, <<==, <<==>>
(==>) :: Text -> Markdown -> Expectation
s ==> m = parseMarkdown s `shouldBe` m
(<==) :: Text -> Markdown -> Expectation
s <== m = s <<== markdownToList m
(<==>) :: Text -> Markdown -> Expectation
s <==> m = (s ==> m) >> (s <== m)
(==>>) :: Text -> MarkdownList -> Expectation
s ==>> ft = parseMaybeMarkdownList s `shouldBe` Just ft
(<<==) :: Text -> MarkdownList -> Expectation
s <<== ft = T.concat (map markdownText ft) `shouldBe` s
(<<==>>) :: Text -> MarkdownList -> Expectation
s <<==>> ft = (s ==>> ft) >> (s <<== ft)
textFormat :: Spec
textFormat = describe "text format (bold)" do
it "correct markdown" do
parseMarkdown "this is *bold formatted* text"
`shouldBe` "this is " <> markdown Bold "bold formatted" <> " text"
parseMarkdown "*bold formatted* text"
`shouldBe` markdown Bold "bold formatted" <> " text"
parseMarkdown "this is *bold*"
`shouldBe` "this is " <> markdown Bold "bold"
parseMarkdown " *bold* text"
`shouldBe` " " <> markdown Bold "bold" <> " text"
parseMarkdown " *bold* text"
`shouldBe` " " <> markdown Bold "bold" <> " text"
parseMarkdown "this is *bold* "
`shouldBe` "this is " <> markdown Bold "bold" <> " "
parseMarkdown "this is *bold* "
`shouldBe` "this is " <> markdown Bold "bold" <> " "
"this is *bold formatted* text"
<==> "this is " <> markdown Bold "bold formatted" <> " text"
"*bold formatted* text"
<==> markdown Bold "bold formatted" <> " text"
"this is *bold*"
<==> "this is " <> markdown Bold "bold"
" *bold* text"
<==> " " <> markdown Bold "bold" <> " text"
" *bold* text"
<==> " " <> markdown Bold "bold" <> " text"
"this is *bold* "
<==> "this is " <> markdown Bold "bold" <> " "
"this is *bold* "
<==> "this is " <> markdown Bold "bold" <> " "
it "ignored as markdown" do
parseMarkdown "this is * unformatted * text"
`shouldBe` "this is * unformatted * text"
parseMarkdown "this is *unformatted * text"
`shouldBe` "this is *unformatted * text"
parseMarkdown "this is * unformatted* text"
`shouldBe` "this is * unformatted* text"
parseMarkdown "this is **unformatted** text"
`shouldBe` "this is **unformatted** text"
parseMarkdown "this is*unformatted* text"
`shouldBe` "this is*unformatted* text"
parseMarkdown "this is *unformatted text"
`shouldBe` "this is *unformatted text"
"this is * unformatted * text"
<==> "this is * unformatted * text"
"this is *unformatted * text"
<==> "this is *unformatted * text"
"this is * unformatted* text"
<==> "this is * unformatted* text"
"this is **unformatted** text"
<==> "this is **unformatted** text"
"this is*unformatted* text"
<==> "this is*unformatted* text"
"this is *unformatted text"
<==> "this is *unformatted text"
it "ignored internal markdown" do
parseMarkdown "this is *long _bold_ (not italic)* text"
`shouldBe` "this is " <> markdown Bold "long _bold_ (not italic)" <> " text"
parseMarkdown "snippet: `this is *bold text*`"
`shouldBe` "snippet: " <> markdown Snippet "this is *bold text*"
"this is *long _bold_ (not italic)* text"
<==> "this is " <> markdown Bold "long _bold_ (not italic)" <> " text"
"snippet: `this is *bold text*`"
<==> "snippet: " <> markdown Snippet "this is *bold text*"
secretText :: Spec
secretText = describe "secret text" do
it "correct markdown" do
parseMarkdown "this is #black_secret# text"
`shouldBe` "this is " <> markdown Secret "black_secret" <> " text"
parseMarkdown "##black_secret### text"
`shouldBe` markdown Secret "#black_secret##" <> " text"
parseMarkdown "this is #black secret# text"
`shouldBe` "this is " <> markdown Secret "black secret" <> " text"
parseMarkdown "##black secret### text"
`shouldBe` markdown Secret "#black secret##" <> " text"
parseMarkdown "this is #secret#"
`shouldBe` "this is " <> markdown Secret "secret"
parseMarkdown " #secret# text"
`shouldBe` " " <> markdown Secret "secret" <> " text"
parseMarkdown " #secret# text"
`shouldBe` " " <> markdown Secret "secret" <> " text"
parseMarkdown "this is #secret# "
`shouldBe` "this is " <> markdown Secret "secret" <> " "
parseMarkdown "this is #secret# "
`shouldBe` "this is " <> markdown Secret "secret" <> " "
"this is #black_secret# text"
<==> "this is " <> markdown Secret "black_secret" <> " text"
"##black_secret### text"
<==> markdown Secret "#black_secret##" <> " text"
"this is #black secret# text"
<==> "this is " <> markdown Secret "black secret" <> " text"
"##black secret### text"
<==> markdown Secret "#black secret##" <> " text"
"this is #secret#"
<==> "this is " <> markdown Secret "secret"
" #secret# text"
<==> " " <> markdown Secret "secret" <> " text"
" #secret# text"
<==> " " <> markdown Secret "secret" <> " text"
"this is #secret# "
<==> "this is " <> markdown Secret "secret" <> " "
"this is #secret# "
<==> "this is " <> markdown Secret "secret" <> " "
it "ignored as markdown" do
parseMarkdown "this is # unformatted # text"
`shouldBe` "this is # unformatted # text"
parseMarkdown "this is #unformatted # text"
`shouldBe` "this is #unformatted # text"
parseMarkdown "this is # unformatted# text"
`shouldBe` "this is # unformatted# text"
parseMarkdown "this is ## unformatted ## text"
`shouldBe` "this is ## unformatted ## text"
parseMarkdown "this is#unformatted# text"
`shouldBe` "this is#unformatted# text"
parseMarkdown "this is #unformatted text"
`shouldBe` "this is #unformatted text"
"this is # unformatted # text"
<==> "this is # unformatted # text"
"this is #unformatted # text"
<==> "this is #unformatted # text"
"this is # unformatted# text"
<==> "this is # unformatted# text"
"this is ## unformatted ## text"
<==> "this is ## unformatted ## text"
"this is#unformatted# text"
<==> "this is#unformatted# text"
"this is #unformatted text"
<==> "this is #unformatted text"
it "ignored internal markdown" do
parseMarkdown "snippet: `this is #secret_text#`"
`shouldBe` "snippet: " <> markdown Snippet "this is #secret_text#"
"snippet: `this is #secret_text#`"
<==> "snippet: " <> markdown Snippet "this is #secret_text#"
red :: Text -> Markdown
red = markdown (colored Red)
@@ -102,38 +123,38 @@ red = markdown (colored Red)
textColor :: Spec
textColor = describe "text color (red)" do
it "correct markdown" do
parseMarkdown "this is !1 red color! text"
`shouldBe` "this is " <> red "red color" <> " text"
parseMarkdown "!1 red! text"
`shouldBe` red "red" <> " text"
parseMarkdown "this is !1 red!"
`shouldBe` "this is " <> red "red"
parseMarkdown " !1 red! text"
`shouldBe` " " <> red "red" <> " text"
parseMarkdown " !1 red! text"
`shouldBe` " " <> red "red" <> " text"
parseMarkdown "this is !1 red! "
`shouldBe` "this is " <> red "red" <> " "
parseMarkdown "this is !1 red! "
`shouldBe` "this is " <> red "red" <> " "
"this is !1 red color! text"
<==> "this is " <> red "red color" <> " text"
"!1 red! text"
<==> red "red" <> " text"
"this is !1 red!"
<==> "this is " <> red "red"
" !1 red! text"
<==> " " <> red "red" <> " text"
" !1 red! text"
<==> " " <> red "red" <> " text"
"this is !1 red! "
<==> "this is " <> red "red" <> " "
"this is !1 red! "
<==> "this is " <> red "red" <> " "
it "ignored as markdown" do
parseMarkdown "this is !1 unformatted ! text"
`shouldBe` "this is !1 unformatted ! text"
parseMarkdown "this is !1 unformatted ! text"
`shouldBe` "this is !1 unformatted ! text"
parseMarkdown "this is !1 unformatted! text"
`shouldBe` "this is !1 unformatted! text"
-- parseMarkdown "this is !!1 unformatted!! text"
-- `shouldBe` "this is " <> "!!1" <> "unformatted!! text"
parseMarkdown "this is!1 unformatted! text"
`shouldBe` "this is!1 unformatted! text"
parseMarkdown "this is !1 unformatted text"
`shouldBe` "this is !1 unformatted text"
"this is !1 unformatted ! text"
<==> "this is !1 unformatted ! text"
"this is !1 unformatted ! text"
<==> "this is !1 unformatted ! text"
"this is !1 unformatted! text"
<==> "this is !1 unformatted! text"
-- "this is !!1 unformatted!! text"
-- <==> "this is " <> "!!1" <> "unformatted!! text"
"this is!1 unformatted! text"
<==> "this is!1 unformatted! text"
"this is !1 unformatted text"
<==> "this is !1 unformatted text"
it "ignored internal markdown" do
parseMarkdown "this is !1 long *red* (not bold)! text"
`shouldBe` "this is " <> red "long *red* (not bold)" <> " text"
parseMarkdown "snippet: `this is !1 red text!`"
`shouldBe` "snippet: " <> markdown Snippet "this is !1 red text!"
"this is !1 long *red* (not bold)! text"
<==> "this is " <> red "long *red* (not bold)" <> " text"
"snippet: `this is !1 red text!`"
<==> "snippet: " <> markdown Snippet "this is !1 red text!"
uri :: Text -> Markdown
uri = Markdown $ Just Uri
@@ -144,29 +165,31 @@ simplexLink linkType simplexUri smpHosts = Markdown $ Just SimplexLink {linkType
textWithUri :: Spec
textWithUri = describe "text with Uri" do
it "correct markdown" do
parseMarkdown "https://simplex.chat" `shouldBe` uri "https://simplex.chat"
parseMarkdown "https://simplex.chat." `shouldBe` uri "https://simplex.chat" <> "."
parseMarkdown "https://simplex.chat, hello" `shouldBe` uri "https://simplex.chat" <> ", hello"
parseMarkdown "http://simplex.chat" `shouldBe` uri "http://simplex.chat"
parseMarkdown "this is https://simplex.chat" `shouldBe` "this is " <> uri "https://simplex.chat"
parseMarkdown "https://simplex.chat site" `shouldBe` uri "https://simplex.chat" <> " site"
parseMarkdown "SimpleX on GitHub: https://github.com/simplex-chat/" `shouldBe` "SimpleX on GitHub: " <> uri "https://github.com/simplex-chat/"
parseMarkdown "SimpleX on GitHub: https://github.com/simplex-chat." `shouldBe` "SimpleX on GitHub: " <> uri "https://github.com/simplex-chat" <> "."
parseMarkdown "https://github.com/simplex-chat/ - SimpleX on GitHub" `shouldBe` uri "https://github.com/simplex-chat/" <> " - SimpleX on GitHub"
-- parseMarkdown "SimpleX on GitHub (https://github.com/simplex-chat/)" `shouldBe` "SimpleX on GitHub (" <> uri "https://github.com/simplex-chat/" <> ")"
parseMarkdown "https://en.m.wikipedia.org/wiki/Servo_(software)" `shouldBe` uri "https://en.m.wikipedia.org/wiki/Servo_(software)"
"https://simplex.chat" <==> uri "https://simplex.chat"
"https://simplex.chat." <==> uri "https://simplex.chat" <> "."
"https://simplex.chat, hello" <==> uri "https://simplex.chat" <> ", hello"
"http://simplex.chat" <==> uri "http://simplex.chat"
"this is https://simplex.chat" <==> "this is " <> uri "https://simplex.chat"
"https://simplex.chat site" <==> uri "https://simplex.chat" <> " site"
"SimpleX on GitHub: https://github.com/simplex-chat/" <==> "SimpleX on GitHub: " <> uri "https://github.com/simplex-chat/"
"SimpleX on GitHub: https://github.com/simplex-chat." <==> "SimpleX on GitHub: " <> uri "https://github.com/simplex-chat" <> "."
"https://github.com/simplex-chat/ - SimpleX on GitHub" <==> uri "https://github.com/simplex-chat/" <> " - SimpleX on GitHub"
-- "SimpleX on GitHub (https://github.com/simplex-chat/)" <==> "SimpleX on GitHub (" <> uri "https://github.com/simplex-chat/" <> ")"
"https://en.m.wikipedia.org/wiki/Servo_(software)" <==> uri "https://en.m.wikipedia.org/wiki/Servo_(software)"
it "ignored as markdown" do
parseMarkdown "_https://simplex.chat" `shouldBe` "_https://simplex.chat"
parseMarkdown "this is _https://simplex.chat" `shouldBe` "this is _https://simplex.chat"
"_https://simplex.chat" <==> "_https://simplex.chat"
"this is _https://simplex.chat" <==> "this is _https://simplex.chat"
it "SimpleX links" do
let inv = "/invitation#/?v=1&smp=smp%3A%2F%2F1234-w%3D%3D%40smp.simplex.im%3A5223%2F3456-w%3D%3D%23%2F%3Fv%3D1-2%26dh%3DMCowBQYDK2VuAyEAjiswwI3O_NlS8Fk3HJUW870EY2bAwmttMBsvRB9eV3o%253D&e2e=v%3D2%26x3dh%3DMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D%2CMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D"
parseMarkdown ("https://simplex.chat" <> inv) `shouldBe` simplexLink XLInvitation ("simplex:" <> inv) ["smp.simplex.im"] ("https://simplex.chat" <> inv)
parseMarkdown ("simplex:" <> inv) `shouldBe` simplexLink XLInvitation ("simplex:" <> inv) ["smp.simplex.im"] ("simplex:" <> inv)
parseMarkdown ("https://example.com" <> inv) `shouldBe` simplexLink XLInvitation ("simplex:" <> inv) ["smp.simplex.im"] ("https://example.com" <> inv)
("https://simplex.chat" <> inv) <==> simplexLink XLInvitation ("simplex:" <> inv) ["smp.simplex.im"] ("https://simplex.chat" <> inv)
("simplex:" <> inv) <==> simplexLink XLInvitation ("simplex:" <> inv) ["smp.simplex.im"] ("simplex:" <> inv)
("https://example.com" <> inv) <==> simplexLink XLInvitation ("simplex:" <> inv) ["smp.simplex.im"] ("https://example.com" <> inv)
let ct = "/contact#/?v=2&smp=smp%3A%2F%2F1234-w%3D%3D%40smp.simplex.im%3A5223%2F3456-w%3D%3D%23%2F%3Fv%3D1-2%26dh%3DMCowBQYDK2VuAyEAjiswwI3O_NlS8Fk3HJUW870EY2bAwmttMBsvRB9eV3o%253D"
parseMarkdown ("https://simplex.chat" <> ct) `shouldBe` simplexLink XLContact ("simplex:" <> ct) ["smp.simplex.im"] ("https://simplex.chat" <> ct)
("https://simplex.chat" <> ct) <==> simplexLink XLContact ("simplex:" <> ct) ["smp.simplex.im"] ("https://simplex.chat" <> ct)
("simplex:" <> ct) <==> simplexLink XLContact ("simplex:" <> ct) ["smp.simplex.im"] ("simplex:" <> ct)
let gr = "/contact#/?v=2&smp=smp%3A%2F%2Fu2dS9sG8nMNURyZwqASV4yROM28Er0luVTx5X1CsMrU%3D%40smp4.simplex.im%2FWHV0YU1sYlU7NqiEHkHDB6gxO1ofTync%23%2F%3Fv%3D1-2%26dh%3DMCowBQYDK2VuAyEAWbebOqVYuBXaiqHcXYjEHCpYi6VzDlu6CVaijDTmsQU%253D%26srv%3Do5vmywmrnaxalvz6wi3zicyftgio6psuvyniis6gco6bp6ekl4cqj4id.onion&data=%7B%22type%22%3A%22group%22%2C%22groupLinkId%22%3A%22mL-7Divb94GGmGmRBef5Dg%3D%3D%22%7D"
parseMarkdown ("https://simplex.chat" <> gr) `shouldBe` simplexLink XLGroup ("simplex:" <> gr) ["smp4.simplex.im", "o5vmywmrnaxalvz6wi3zicyftgio6psuvyniis6gco6bp6ekl4cqj4id.onion"] ("https://simplex.chat" <> gr)
("https://simplex.chat" <> gr) <==> simplexLink XLGroup ("simplex:" <> gr) ["smp4.simplex.im", "o5vmywmrnaxalvz6wi3zicyftgio6psuvyniis6gco6bp6ekl4cqj4id.onion"] ("https://simplex.chat" <> gr)
("simplex:" <> gr) <==> simplexLink XLGroup ("simplex:" <> gr) ["smp4.simplex.im", "o5vmywmrnaxalvz6wi3zicyftgio6psuvyniis6gco6bp6ekl4cqj4id.onion"] ("simplex:" <> gr)
email :: Text -> Markdown
email = Markdown $ Just Email
@@ -174,17 +197,17 @@ email = Markdown $ Just Email
textWithEmail :: Spec
textWithEmail = describe "text with Email" do
it "correct markdown" do
parseMarkdown "chat@simplex.chat" `shouldBe` email "chat@simplex.chat"
parseMarkdown "test chat@simplex.chat" `shouldBe` "test " <> email "chat@simplex.chat"
parseMarkdown "test chat+123@simplex.chat" `shouldBe` "test " <> email "chat+123@simplex.chat"
parseMarkdown "test chat.chat+123@simplex.chat" `shouldBe` "test " <> email "chat.chat+123@simplex.chat"
parseMarkdown "chat@simplex.chat test" `shouldBe` email "chat@simplex.chat" <> " test"
parseMarkdown "test1 chat@simplex.chat test2" `shouldBe` "test1 " <> email "chat@simplex.chat" <> " test2"
"chat@simplex.chat" <==> email "chat@simplex.chat"
"test chat@simplex.chat" <==> "test " <> email "chat@simplex.chat"
"test chat+123@simplex.chat" <==> "test " <> email "chat+123@simplex.chat"
"test chat.chat+123@simplex.chat" <==> "test " <> email "chat.chat+123@simplex.chat"
"chat@simplex.chat test" <==> email "chat@simplex.chat" <> " test"
"test1 chat@simplex.chat test2" <==> "test1 " <> email "chat@simplex.chat" <> " test2"
it "ignored as markdown" do
parseMarkdown "chat @simplex.chat" `shouldBe` "chat " <> mention "simplex.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"
"chat @simplex.chat" <==> "chat " <> mention "simplex.chat" "@simplex.chat"
"this is chat @simplex.chat" <==> "this is chat " <> mention "simplex.chat" "@simplex.chat"
"this is chat@ simplex.chat" <==> "this is chat@ simplex.chat"
"this is chat @ simplex.chat" <==> "this is chat @ simplex.chat"
phone :: Text -> Markdown
phone = Markdown $ Just Phone
@@ -192,20 +215,20 @@ phone = Markdown $ Just Phone
textWithPhone :: Spec
textWithPhone = describe "text with Phone" do
it "correct markdown" do
parseMarkdown "07777777777" `shouldBe` phone "07777777777"
parseMarkdown "test 07777777777" `shouldBe` "test " <> phone "07777777777"
parseMarkdown "07777777777 test" `shouldBe` phone "07777777777" <> " test"
parseMarkdown "test1 07777777777 test2" `shouldBe` "test1 " <> phone "07777777777" <> " test2"
parseMarkdown "test 07777 777 777 test" `shouldBe` "test " <> phone "07777 777 777" <> " test"
parseMarkdown "test +447777777777 test" `shouldBe` "test " <> phone "+447777777777" <> " test"
parseMarkdown "test +44 (0) 7777 777 777 test" `shouldBe` "test " <> phone "+44 (0) 7777 777 777" <> " test"
parseMarkdown "test +44-7777-777-777 test" `shouldBe` "test " <> phone "+44-7777-777-777" <> " test"
parseMarkdown "test +44 (0) 7777.777.777 https://simplex.chat test"
`shouldBe` "test " <> phone "+44 (0) 7777.777.777" <> " " <> uri "https://simplex.chat" <> " test"
"07777777777" <==> phone "07777777777"
"test 07777777777" <==> "test " <> phone "07777777777"
"07777777777 test" <==> phone "07777777777" <> " test"
"test1 07777777777 test2" <==> "test1 " <> phone "07777777777" <> " test2"
"test 07777 777 777 test" <==> "test " <> phone "07777 777 777" <> " test"
"test +447777777777 test" <==> "test " <> phone "+447777777777" <> " test"
"test +44 (0) 7777 777 777 test" <==> "test " <> phone "+44 (0) 7777 777 777" <> " test"
"test +44-7777-777-777 test" <==> "test " <> phone "+44-7777-777-777" <> " test"
"test +44 (0) 7777.777.777 https://simplex.chat test"
<==> "test " <> phone "+44 (0) 7777.777.777" <> " " <> uri "https://simplex.chat" <> " test"
it "ignored as markdown (too short)" $
parseMarkdown "test 077777 test" `shouldBe` "test 077777 test"
"test 077777 test" <==> "test 077777 test"
it "ignored as markdown (double spaces)" $
parseMarkdown "test 07777 777 777 test" `shouldBe` "test 07777 777 777 test"
"test 07777 777 777 test" <==> "test 07777 777 777 test"
mention :: Text -> Text -> Markdown
mention = Markdown . Just . Mention
@@ -213,14 +236,14 @@ 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'" <> "!"
"@alice" <==> mention "alice" "@alice"
"hello @alice" <==> "hello " <> mention "alice" "@alice"
"hello @alice !" <==> "hello " <> mention "alice" "@alice" <> " !"
"@'alice jones'" <==> mention "alice jones" "@'alice jones'"
"hello @'alice jones'!" <==> "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!"
"hello @'alice jones!" <==> "hello @'alice jones!"
"hello @ alice!" <==> "hello @ alice!"
uri' :: Text -> FormattedText
uri' = FormattedText $ Just Uri
@@ -228,15 +251,15 @@ uri' = FormattedText $ Just Uri
multilineMarkdownList :: Spec
multilineMarkdownList = describe "multiline markdown" do
it "correct markdown" do
parseMaybeMarkdownList "http://simplex.chat\nhttp://app.simplex.chat" `shouldBe` Just [uri' "http://simplex.chat", "\n", uri' "http://app.simplex.chat"]
"http://simplex.chat\nhttp://app.simplex.chat" <<==>> [uri' "http://simplex.chat", "\n", uri' "http://app.simplex.chat"]
it "combines the same formats" do
parseMaybeMarkdownList "http://simplex.chat\ntext 1\ntext 2\nhttp://app.simplex.chat" `shouldBe` Just [uri' "http://simplex.chat", "\ntext 1\ntext 2\n", uri' "http://app.simplex.chat"]
"http://simplex.chat\ntext 1\ntext 2\nhttp://app.simplex.chat" <<==>> [uri' "http://simplex.chat", "\ntext 1\ntext 2\n", uri' "http://app.simplex.chat"]
it "no markdown" do
parseMaybeMarkdownList "not a\nmarkdown" `shouldBe` Nothing
let inv = "/invitation#/?v=1&smp=smp%3A%2F%2F1234-w%3D%3D%40smp.simplex.im%3A5223%2F3456-w%3D%3D%23%2F%3Fv%3D1-2%26dh%3DMCowBQYDK2VuAyEAjiswwI3O_NlS8Fk3HJUW870EY2bAwmttMBsvRB9eV3o%253D&e2e=v%3D2%26x3dh%3DMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D%2CMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D"
it "multiline with simplex link" do
parseMaybeMarkdownList ("https://simplex.chat" <> inv <> "\ntext")
`shouldBe` Just
("https://simplex.chat" <> inv <> "\ntext")
<<==>>
[ FormattedText (Just $ SimplexLink XLInvitation ("simplex:" <> inv) ["smp.simplex.im"]) ("https://simplex.chat" <> inv),
"\ntext"
]