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

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

Browse Source 
* core: member mentions, types and rfc

* update

* update rfc

* save/get mentions (WIP)

* markdown

* store received mentions and userMention flag

* sent mentions

* update message with mentions

* db queries

* CLI mentions, test passes

* use maps for mentions

* tests

* comment

* save mentions on sent messages

* postresql schema

* refactor

* M.empty

* include both displayName and localAlias into MentionedMemberInfo

* fix saving sent mentions

* include mentions in previews

* update plans
This commit is contained in:
Evgeny
2025-01-29 13:04:48 +00:00
committed by GitHub
parent c20e94f2fb
commit 621b291da1
31 changed files with 858 additions and 316 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Simplex/Chat/Bot.hs
+3 -3
View File
@@ -11,7 +11,7 @@ import Control.Concurrent.Async
import Control.Concurrent.STM
import Control.Monad
import qualified Data.ByteString.Char8 as B
import Data.List.NonEmpty (NonEmpty (..))
import qualified Data.Map.Strict as M
import Data.Text (Text)
import qualified Data.Text as T
import Simplex.Chat.Controller
@@ -69,8 +69,8 @@ sendComposedMessage cc = sendComposedMessage' cc . contactId'
sendComposedMessage' :: ChatController -> ContactId -> Maybe ChatItemId -> MsgContent -> IO ()
sendComposedMessage' cc ctId quotedItemId msgContent = do
let cm = ComposedMessage {fileSource = Nothing, quotedItemId, msgContent}
sendChatCmd cc (APISendMessages (ChatRef CTDirect ctId) False Nothing (cm :| [])) >>= \case
let cm = ComposedMessage {fileSource = Nothing, quotedItemId, msgContent, mentions = M.empty}
sendChatCmd cc (APISendMessages (ChatRef CTDirect ctId) False Nothing [cm]) >>= \case
CRNewChatItems {} -> printLog cc CLLInfo $ "sent message to contact ID " <> show ctId
r -> putStrLn $ "unexpected send message response: " <> show r
src/Simplex/Chat/Controller.hs
+24 -16
View File
@@ -39,6 +39,7 @@ import Data.Int (Int64)
import Data.List.NonEmpty (NonEmpty)
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as M
import Data.Maybe (fromMaybe)
import Data.String
import Data.Text (Text)
import Data.Text.Encoding (decodeLatin1)
@@ -313,7 +314,7 @@ data ChatCommand
| APICreateChatItems {noteFolderId :: NoteFolderId, composedMessages :: NonEmpty ComposedMessage}
| APIReportMessage {groupId :: GroupId, chatItemId :: ChatItemId, reportReason :: ReportReason, reportText :: Text}
| ReportMessage {groupName :: GroupName, contactName_ :: Maybe ContactName, reportReason :: ReportReason, reportedMessage :: Text}
| APIUpdateChatItem {chatRef :: ChatRef, chatItemId :: ChatItemId, liveMessage :: Bool, msgContent :: MsgContent}
| APIUpdateChatItem {chatRef :: ChatRef, chatItemId :: ChatItemId, liveMessage :: Bool, updatedMessage :: UpdatedMessage}
| APIDeleteChatItem ChatRef (NonEmpty ChatItemId) CIDeleteMode
| APIDeleteMemberChatItem GroupId (NonEmpty ChatItemId)
| APIChatItemReaction {chatRef :: ChatRef, chatItemId :: ChatItemId, add :: Bool, reaction :: MsgReaction}
@@ -346,7 +347,6 @@ data ChatCommand
| APISetConnectionAlias Int64 LocalAlias
| APISetUserUIThemes UserId (Maybe UIThemeEntityOverrides)
| APISetChatUIThemes ChatRef (Maybe UIThemeEntityOverrides)
| APIParseMarkdown Text
| APIGetNtfToken
| APIRegisterToken DeviceToken NotificationsMode
| APIVerifyToken DeviceToken C.CbNonce ByteString
@@ -1085,22 +1085,16 @@ data UserProfileUpdateSummary = UserProfileUpdateSummary
data ComposedMessage = ComposedMessage
{ fileSource :: Maybe CryptoFile,
quotedItemId :: Maybe ChatItemId,
msgContent :: MsgContent
msgContent :: MsgContent,
mentions :: Map MemberName GroupMemberId
}
deriving (Show)
-- This instance is needed for backward compatibility, can be removed in v6.0
instance FromJSON ComposedMessage where
parseJSON (J.Object v) = do
fileSource <-
(v .:? "fileSource") >>= \case
Nothing -> CF.plain <$$> (v .:? "filePath")
f -> pure f
quotedItemId <- v .:? "quotedItemId"
msgContent <- v .: "msgContent"
pure ComposedMessage {fileSource, quotedItemId, msgContent}
parseJSON invalid =
JT.prependFailure "bad ComposedMessage, " (JT.typeMismatch "Object" invalid)
data UpdatedMessage = UpdatedMessage
{ msgContent :: MsgContent,
mentions :: Map MemberName GroupMemberId
}
deriving (Show)
data ChatTagData = ChatTagData
{ emoji :: Maybe Text,
@@ -1273,7 +1267,6 @@ data ChatErrorType
| CEFileNotApproved {fileId :: FileTransferId, unknownServers :: [XFTPServer]}
| CEFallbackToSMPProhibited {fileId :: FileTransferId}
| CEInlineFileProhibited {fileId :: FileTransferId}
| CEInvalidQuote
| CEInvalidForward
| CEInvalidChatItemUpdate
| CEInvalidChatItemDelete
@@ -1635,4 +1628,19 @@ $(JQ.deriveFromJSON defaultJSON ''DBEncryptionConfig)
$(JQ.deriveToJSON defaultJSON ''ComposedMessage)
instance FromJSON ComposedMessage where
parseJSON (J.Object v) = do
fileSource <-
(v .:? "fileSource") >>= \case
Nothing -> CF.plain <$$> (v .:? "filePath")
f -> pure f
quotedItemId <- v .:? "quotedItemId"
msgContent <- v .: "msgContent"
mentions <- fromMaybe M.empty <$> v .:? "mentions"
pure ComposedMessage {fileSource, quotedItemId, msgContent, mentions}
parseJSON invalid =
JT.prependFailure "bad ComposedMessage, " (JT.typeMismatch "Object" invalid)
$(JQ.deriveJSON defaultJSON ''UpdatedMessage)
$(JQ.deriveToJSON defaultJSON ''ChatTagData)
src/Simplex/Chat/Library/Commands.hs
+123 -97
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, zipWith4)
import Data.List (find, foldl', isSuffixOf, partition, sortOn, zipWith5)
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)
import Simplex.Chat.Util (liftIOEither, neUnzip3)
import qualified Simplex.Chat.Util as U
import Simplex.FileTransfer.Description (FileDescriptionURI (..), maxFileSize, maxFileSizeHard)
import Simplex.Messaging.Agent as Agent
@@ -537,12 +537,13 @@ processChatCommand' vr = \case
Just <$> withFastStore (\db -> getAChatItem db vr user (ChatRef CTGroup gId) fwdItemId)
_ -> pure Nothing
APISendMessages (ChatRef cType chatId) live itemTTL cms -> withUser $ \user -> mapM_ assertAllowedContent' cms >> case cType of
CTDirect ->
CTDirect -> do
mapM_ assertNoMentions cms
withContactLock "sendMessage" chatId $
sendContactContentMessages user chatId live itemTTL (L.map (,Nothing) cms)
sendContactContentMessages user chatId live itemTTL (L.map composedMessageReq cms)
CTGroup ->
withGroupLock "sendMessage" chatId $
sendGroupContentMessages user chatId live itemTTL (L.map (,Nothing) cms)
sendGroupContentMessages user chatId live itemTTL (L.map composedMessageReq cms)
CTLocal -> pure $ chatCmdError (Just user) "not supported"
CTContactRequest -> pure $ chatCmdError (Just user) "not supported"
CTContactConnection -> pure $ chatCmdError (Just user) "not supported"
@@ -567,8 +568,8 @@ processChatCommand' vr = \case
withFastStore' $ \db -> reorderChatTags db user $ L.toList tagIds
ok user
APICreateChatItems folderId cms -> withUser $ \user -> do
mapM_ assertAllowedContent' cms
createNoteFolderContentItems user folderId (L.map (,Nothing) cms)
forM_ cms $ \cm -> assertAllowedContent' cm >> assertNoMentions cm
createNoteFolderContentItems user folderId (L.map composedMessageReq cms)
APIReportMessage gId reportedItemId reportReason reportText -> withUser $ \user ->
withGroupLock "reportMessage" gId $ do
(gInfo, ms) <-
@@ -577,9 +578,9 @@ processChatCommand' vr = \case
(gInfo,) <$> liftIO (getGroupModerators db vr user gInfo)
let ms' = filter compatibleModerator ms
mc = MCReport reportText reportReason
cm = ComposedMessage {fileSource = Nothing, quotedItemId = Just reportedItemId, msgContent = mc}
cm = ComposedMessage {fileSource = Nothing, quotedItemId = Just reportedItemId, msgContent = mc, mentions = M.empty}
when (null ms') $ throwChatError $ CECommandError "no moderators support receiving reports"
sendGroupContentMessages_ user gInfo ms' False Nothing [(cm, Nothing)]
sendGroupContentMessages_ user gInfo ms' False Nothing [composedMessageReq cm]
where
compatibleModerator GroupMember {activeConn, memberChatVRange} =
maxVersion (maybe memberChatVRange peerChatVRange activeConn) >= contentReportsVersion
@@ -587,8 +588,9 @@ processChatCommand' vr = \case
gId <- withFastStore $ \db -> getGroupIdByName db user groupName
reportedItemId <- withFastStore $ \db -> getGroupChatItemIdByText db user gId contactName_ reportedMessage
processChatCommand $ APIReportMessage gId reportedItemId reportReason ""
APIUpdateChatItem (ChatRef cType chatId) itemId live mc -> withUser $ \user -> assertAllowedContent mc >> case cType of
APIUpdateChatItem (ChatRef cType chatId) itemId live (UpdatedMessage mc mentions) -> withUser $ \user -> assertAllowedContent mc >> case cType of
CTDirect -> withContactLock "updateChatItem" chatId $ do
unless (null mentions) $ throwChatError $ CECommandError "mentions are not supported in this chat"
ct@Contact {contactId} <- withFastStore $ \db -> getContact db vr user chatId
assertDirectAllowed user MDSnd ct XMsgUpdate_
cci <- withFastStore $ \db -> getDirectCIWithReactions db user ct itemId
@@ -599,7 +601,7 @@ processChatCommand' vr = \case
let changed = mc /= oldMC
if changed || fromMaybe False itemLive
then do
(SndMessage {msgId}, _) <- sendDirectContactMessage user ct (XMsgUpdate itemSharedMId mc (ttl' <$> itemTimed) (justTrue . (live &&) =<< itemLive))
(SndMessage {msgId}, _) <- sendDirectContactMessage user ct (XMsgUpdate itemSharedMId mc M.empty (ttl' <$> itemTimed) (justTrue . (live &&) =<< itemLive))
ci' <- withFastStore' $ \db -> do
currentTs <- liftIO getCurrentTime
when changed $
@@ -614,7 +616,8 @@ processChatCommand' vr = \case
CTGroup -> withGroupLock "updateChatItem" chatId $ do
Group gInfo@GroupInfo {groupId, membership} ms <- withFastStore $ \db -> getGroup db vr user chatId
assertUserGroupRole gInfo GRAuthor
if prohibitedSimplexLinks gInfo membership mc
let (_, ft_) = msgContentTexts mc
if prohibitedSimplexLinks gInfo membership ft_
then pure $ chatCmdError (Just user) ("feature not allowed " <> T.unpack (groupFeatureNameText GFSimplexLinks))
else do
cci <- withFastStore $ \db -> getGroupCIWithReactions db user gInfo itemId
@@ -625,19 +628,22 @@ processChatCommand' vr = \case
let changed = mc /= oldMC
if changed || fromMaybe False itemLive
then do
SndMessage {msgId} <- sendGroupMessage user gInfo ms (XMsgUpdate itemSharedMId mc (ttl' <$> itemTimed) (justTrue . (live &&) =<< itemLive))
(mentionedMembers, mentions') <- withFastStore $ \db -> getMentionedMembers db user gInfo ft_ mentions
SndMessage {msgId} <- sendGroupMessage user gInfo ms (XMsgUpdate itemSharedMId mc mentions' (ttl' <$> itemTimed) (justTrue . (live &&) =<< itemLive))
ci' <- withFastStore' $ \db -> do
currentTs <- liftIO getCurrentTime
when changed $
addInitialAndNewCIVersions db itemId (chatItemTs' ci, oldMC) (currentTs, mc)
let edited = itemLive /= Just True
updateGroupChatItem db user groupId ci (CISndMsgContent mc) edited live $ Just msgId
ci' <- updateGroupChatItem db user groupId ci (CISndMsgContent mc) edited live $ Just msgId
updateGroupCIMentions db gInfo ci' mentionedMembers
startUpdatedTimedItemThread user (ChatRef CTGroup groupId) ci ci'
pure $ CRChatItemUpdated user (AChatItem SCTGroup SMDSnd (GroupChat gInfo) ci')
else pure $ CRChatItemNotChanged user (AChatItem SCTGroup SMDSnd (GroupChat gInfo) ci)
_ -> throwChatError CEInvalidChatItemUpdate
CChatItem SMDRcv _ -> throwChatError CEInvalidChatItemUpdate
CTLocal -> do
unless (null mentions) $ throwChatError $ CECommandError "mentions are not supported in this chat"
(nf@NoteFolder {noteFolderId}, cci) <- withFastStore $ \db -> (,) <$> getNoteFolder db user chatId <*> getLocalChatItem db user chatId itemId
case cci of
CChatItem SMDSnd ci@ChatItem {content = CISndMsgContent oldMC}
@@ -699,7 +705,7 @@ processChatCommand' vr = \case
itemsMsgIds :: [CChatItem c] -> [SharedMsgId]
itemsMsgIds = mapMaybe (\(CChatItem _ ChatItem {meta = CIMeta {itemSharedMsgId}}) -> itemSharedMsgId)
APIDeleteMemberChatItem gId itemIds -> withUser $ \user -> withGroupLock "deleteChatItem" gId $ do
(gInfo@GroupInfo {membership}, items) <- getCommandGroupChatItems user gId itemIds
(gInfo, items) <- getCommandGroupChatItems user gId itemIds
ms <- withFastStore' $ \db -> getGroupMembers db vr user gInfo
assertDeletable gInfo items
assertUserGroupRole gInfo GRAdmin -- TODO GRModerator when most users migrate
@@ -849,31 +855,33 @@ processChatCommand' vr = \case
CTContactRequest -> pure $ chatCmdError (Just user) "not supported"
CTContactConnection -> pure $ chatCmdError (Just user) "not supported"
where
prepareForward :: User -> CM [ComposeMessageReq]
prepareForward :: User -> CM [ComposedMessageReq]
prepareForward user = case fromCType of
CTDirect -> withContactLock "forwardChatItem, from contact" fromChatId $ do
(ct, items) <- getCommandDirectChatItems user fromChatId itemIds
catMaybes <$> mapM (\ci -> ciComposeMsgReq ct ci <$$> prepareMsgReq ci) items
where
ciComposeMsgReq :: Contact -> CChatItem 'CTDirect -> (MsgContent, Maybe CryptoFile) -> ComposeMessageReq
ciComposeMsgReq :: Contact -> CChatItem 'CTDirect -> (MsgContent, Maybe CryptoFile) -> ComposedMessageReq
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 Nothing mc', ciff)
in (composedMessage file mc', ciff, msgContentTexts mc')
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) -> ComposeMessageReq
ciComposeMsgReq :: GroupInfo -> CChatItem 'CTGroup -> (MsgContent, Maybe CryptoFile) -> ComposedMessageReq
ciComposeMsgReq gInfo (CChatItem md ci) (mc', file) = do
let itemId = chatItemId' ci
ciff = forwardCIFF ci $ Just (CIFFGroup (forwardName gInfo) (toMsgDirection md) (Just fromChatId) (Just itemId))
in (ComposedMessage file Nothing mc', ciff)
in (composedMessage file mc', ciff, msgContentTexts mc')
where
forwardName :: GroupInfo -> ContactName
forwardName GroupInfo {groupProfile = GroupProfile {displayName}} = displayName
@@ -881,10 +889,10 @@ processChatCommand' vr = \case
(_, items) <- getCommandLocalChatItems user fromChatId itemIds
catMaybes <$> mapM (\ci -> ciComposeMsgReq ci <$$> prepareMsgReq ci) items
where
ciComposeMsgReq :: CChatItem 'CTLocal -> (MsgContent, Maybe CryptoFile) -> ComposeMessageReq
ciComposeMsgReq :: CChatItem 'CTLocal -> (MsgContent, Maybe CryptoFile) -> ComposedMessageReq
ciComposeMsgReq (CChatItem _ ci) (mc', file) =
let ciff = forwardCIFF ci Nothing
in (ComposedMessage file Nothing mc', ciff)
in (composedMessage file mc', ciff, msgContentTexts mc')
CTContactRequest -> throwChatError $ CECommandError "not supported"
CTContactConnection -> throwChatError $ CECommandError "not supported"
where
@@ -1288,7 +1296,6 @@ processChatCommand' vr = \case
liftIO $ setGroupUIThemes db user g uiThemes
ok user
_ -> pure $ chatCmdError (Just user) "not supported"
APIParseMarkdown text -> pure . CRApiParsedMarkdown $ parseMaybeMarkdownList text
APIGetNtfToken -> withUser' $ \_ -> crNtfToken <$> withAgent getNtfToken
APIRegisterToken token mode -> withUser $ \_ ->
CRNtfTokenStatus <$> withAgent (\a -> registerNtfToken a token mode)
@@ -1844,7 +1851,7 @@ processChatCommand' vr = \case
withFastStore' (\db -> runExceptT $ getContactIdByName db user name) >>= \case
Right ctId -> do
let chatRef = ChatRef CTDirect ctId
processChatCommand $ APISendMessages chatRef False Nothing (ComposedMessage Nothing Nothing mc :| [])
processChatCommand $ APISendMessages chatRef False Nothing [composedMessage Nothing mc]
Left _ ->
withFastStore' (\db -> runExceptT $ getActiveMembersByName db vr user name) >>= \case
Right [(gInfo, member)] -> do
@@ -1856,13 +1863,15 @@ processChatCommand' vr = \case
_ ->
throwChatError $ CEContactNotFound name Nothing
CTGroup -> do
gId <- withFastStore $ \db -> getGroupIdByName db user name
(gId, mentions) <- withFastStore $ \db -> do
gId <- getGroupIdByName db user name
(gId,) <$> liftIO (getMessageMentions db user gId msg)
let chatRef = ChatRef CTGroup gId
processChatCommand $ APISendMessages chatRef False Nothing (ComposedMessage Nothing Nothing mc :| [])
processChatCommand $ APISendMessages chatRef False Nothing [ComposedMessage Nothing Nothing mc mentions]
CTLocal
| name == "" -> do
folderId <- withFastStore (`getUserNoteFolderId` user)
processChatCommand $ APICreateChatItems folderId (ComposedMessage Nothing Nothing mc :| [])
processChatCommand $ APICreateChatItems folderId [composedMessage Nothing mc]
| otherwise -> throwChatError $ CECommandError "not supported"
_ -> throwChatError $ CECommandError "not supported"
SendMemberContactMessage gName mName msg -> withUser $ \user -> do
@@ -1881,11 +1890,11 @@ processChatCommand' vr = \case
cr -> pure cr
Just ctId -> do
let chatRef = ChatRef CTDirect ctId
processChatCommand $ APISendMessages chatRef False Nothing (ComposedMessage Nothing Nothing mc :| [])
processChatCommand $ APISendMessages chatRef False Nothing [composedMessage Nothing mc]
SendLiveMessage chatName msg -> withUser $ \user -> do
chatRef <- getChatRef user chatName
(chatRef, mentions) <- getChatRefAndMentions user chatName msg
let mc = MCText msg
processChatCommand $ APISendMessages chatRef True Nothing (ComposedMessage Nothing Nothing mc :| [])
processChatCommand $ APISendMessages chatRef True Nothing [ComposedMessage Nothing Nothing mc mentions]
SendMessageBroadcast msg -> withUser $ \user -> do
contacts <- withFastStore' $ \db -> getUserContacts db vr user
withChatLock "sendMessageBroadcast" . procCmd $ do
@@ -1926,7 +1935,7 @@ processChatCommand' vr = \case
contactId <- withFastStore $ \db -> getContactIdByName db user cName
quotedItemId <- withFastStore $ \db -> getDirectChatItemIdByText db userId contactId msgDir quotedMsg
let mc = MCText msg
processChatCommand $ APISendMessages (ChatRef CTDirect contactId) False Nothing (ComposedMessage Nothing (Just quotedItemId) mc :| [])
processChatCommand $ APISendMessages (ChatRef CTDirect contactId) False Nothing [ComposedMessage Nothing (Just quotedItemId) mc M.empty]
DeleteMessage chatName deletedMsg -> withUser $ \user -> do
chatRef <- getChatRef user chatName
deletedItemId <- getSentChatItemIdByText user chatRef deletedMsg
@@ -1936,14 +1945,14 @@ processChatCommand' vr = \case
deletedItemId <- withFastStore $ \db -> getGroupChatItemIdByText db user gId (Just mName) deletedMsg
processChatCommand $ APIDeleteMemberChatItem gId (deletedItemId :| [])
EditMessage chatName editedMsg msg -> withUser $ \user -> do
chatRef <- getChatRef user chatName
(chatRef, mentions) <- getChatRefAndMentions user chatName msg
editedItemId <- getSentChatItemIdByText user chatRef editedMsg
let mc = MCText msg
processChatCommand $ APIUpdateChatItem chatRef editedItemId False mc
processChatCommand $ APIUpdateChatItem chatRef editedItemId False $ UpdatedMessage mc mentions
UpdateLiveMessage chatName chatItemId live msg -> withUser $ \user -> do
chatRef <- getChatRef user chatName
(chatRef, mentions) <- getChatRefAndMentions user chatName msg
let mc = MCText msg
processChatCommand $ APIUpdateChatItem chatRef chatItemId live mc
processChatCommand $ APIUpdateChatItem chatRef chatItemId live $ UpdatedMessage mc mentions
ReactToMessage add reaction chatName msg -> withUser $ \user -> do
chatRef <- getChatRef user chatName
chatItemId <- getChatItemIdByText user chatRef msg
@@ -2213,10 +2222,13 @@ processChatCommand' vr = \case
groupId <- withFastStore $ \db -> getGroupIdByName db user gName
processChatCommand $ APIGetGroupLink groupId
SendGroupMessageQuote gName cName quotedMsg msg -> withUser $ \user -> do
groupId <- withFastStore $ \db -> getGroupIdByName db user gName
quotedItemId <- withFastStore $ \db -> getGroupChatItemIdByText db user groupId cName quotedMsg
(groupId, quotedItemId, mentions) <-
withFastStore $ \db -> do
gId <- getGroupIdByName db user gName
qiId <- getGroupChatItemIdByText db user gId cName quotedMsg
(gId, qiId,) <$> liftIO (getMessageMentions db user gId msg)
let mc = MCText msg
processChatCommand $ APISendMessages (ChatRef CTGroup groupId) False Nothing (ComposedMessage Nothing (Just quotedItemId) mc :| [])
processChatCommand $ APISendMessages (ChatRef CTGroup groupId) False Nothing [ComposedMessage Nothing (Just quotedItemId) mc mentions]
ClearNoteFolder -> withUser $ \user -> do
folderId <- withFastStore (`getUserNoteFolderId` user)
processChatCommand $ APIClearChat (ChatRef CTLocal folderId)
@@ -2256,8 +2268,8 @@ processChatCommand' vr = \case
SendFile chatName f -> withUser $ \user -> do
chatRef <- getChatRef user chatName
case chatRef of
ChatRef CTLocal folderId -> processChatCommand $ APICreateChatItems folderId (ComposedMessage (Just f) Nothing (MCFile "") :| [])
_ -> processChatCommand $ APISendMessages chatRef False Nothing (ComposedMessage (Just f) Nothing (MCFile "") :| [])
ChatRef CTLocal folderId -> processChatCommand $ APICreateChatItems folderId [composedMessage (Just f) (MCFile "")]
_ -> processChatCommand $ APISendMessages chatRef False Nothing [composedMessage (Just f) (MCFile "")]
SendImage chatName f@(CryptoFile fPath _) -> withUser $ \user -> do
chatRef <- getChatRef user chatName
filePath <- lift $ toFSFilePath fPath
@@ -2265,7 +2277,7 @@ processChatCommand' vr = \case
fileSize <- getFileSize filePath
unless (fileSize <= maxImageSize) $ throwChatError CEFileImageSize {filePath}
-- TODO include file description for preview
processChatCommand $ APISendMessages chatRef False Nothing (ComposedMessage (Just f) Nothing (MCImage "" fixedImagePreview) :| [])
processChatCommand $ APISendMessages chatRef False Nothing [composedMessage (Just f) (MCImage "" fixedImagePreview)]
ForwardFile chatName fileId -> forwardFile chatName fileId SendFile
ForwardImage chatName fileId -> forwardFile chatName fileId SendImage
SendFileDescription _chatName _f -> pure $ chatCmdError Nothing "TODO"
@@ -2486,6 +2498,12 @@ processChatCommand' vr = \case
| name == "" -> withFastStore (`getUserNoteFolderId` user)
| otherwise -> throwChatError $ CECommandError "not supported"
_ -> throwChatError $ CECommandError "not supported"
getChatRefAndMentions :: User -> ChatName -> Text -> CM (ChatRef, Map MemberName GroupMemberId)
getChatRefAndMentions user cName msg = do
chatRef@(ChatRef cType chatId) <- getChatRef user cName
(chatRef,) <$> case cType of
CTGroup -> withFastStore' $ \db -> getMessageMentions db user chatId msg
_ -> pure []
#if !defined(dbPostgres)
checkChatStopped :: CM ChatResponse -> CM ChatResponse
checkChatStopped a = asks agentAsync >>= readTVarIO >>= maybe a (const $ throwChatError CEChatNotStopped)
@@ -2935,12 +2953,13 @@ processChatCommand' vr = \case
cReqHashes :: (ConnReqUriHash, ConnReqUriHash)
cReqHashes = bimap hash hash cReqSchemas
hash = ConnReqUriHash . C.sha256Hash . strEncode
updateCIGroupInvitationStatus :: User -> GroupInfo -> CIGroupInvitationStatus -> CM ()
updateCIGroupInvitationStatus user GroupInfo {groupId} newStatus = do
AChatItem _ _ cInfo ChatItem {content, meta = CIMeta {itemId}} <- withFastStore $ \db -> getChatItemByGroupId db vr user groupId
case (cInfo, content) of
(DirectChat ct@Contact {contactId}, CIRcvGroupInvitation ciGroupInv@CIGroupInvitation {status} memRole)
| status == CIGISPending -> do
let aciContent = ACIContent SMDRcv $ CIRcvGroupInvitation ciGroupInv {status = newStatus} memRole
let aciContent = ACIContent SMDRcv $ CIRcvGroupInvitation (ciGroupInv {status = newStatus} :: CIGroupInvitation) memRole
timed_ <- contactCITimed ct
updateDirectChatItemView user ct itemId aciContent False False timed_ Nothing
forM_ (timed_ >>= timedDeleteAt') $
@@ -2951,8 +2970,12 @@ processChatCommand' vr = \case
MCReport {} -> throwChatError $ CECommandError "sending reports via this API is not supported"
_ -> pure ()
assertAllowedContent' :: ComposedMessage -> CM ()
assertAllowedContent' ComposedMessage {msgContent} = assertAllowedContent msgContent
sendContactContentMessages :: User -> ContactId -> Bool -> Maybe Int -> NonEmpty ComposeMessageReq -> CM ChatResponse
assertAllowedContent' ComposedMessage {msgContent} = assertAllowedContent msgContent
assertNoMentions :: ComposedMessage -> CM ()
assertNoMentions ComposedMessage {mentions}
| null mentions = pure ()
| otherwise = throwChatError $ CECommandError "mentions are not supported in this chat"
sendContactContentMessages :: User -> ContactId -> Bool -> Maybe Int -> NonEmpty ComposedMessageReq -> CM ChatResponse
sendContactContentMessages user contactId live itemTTL cmrs = do
assertMultiSendable live cmrs
ct@Contact {contactUsed} <- withFastStore $ \db -> getContact db vr user contactId
@@ -2963,15 +2986,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_) <- L.unzip <$> prepareMsgs (L.zip cmrs fInvs_) timed_
(msgContainers, quotedItems_, mms) <- neUnzip3 <$> prepareMsgs (L.zip cmrs fInvs_) timed_
msgs_ <- sendDirectContactMessages user ct $ L.map XMsgNew msgContainers
let itemsData = prepareSndItemsData msgs_ cmrs ciFiles_ quotedItems_
let itemsData = prepareSndItemsData (L.toList cmrs) (L.toList mms) (L.toList ciFiles_) (L.toList quotedItems_) msgs_
when (length itemsData /= length cmrs) $ logError "sendContactContentMessages: cmrs and itemsData length mismatch"
r@(_, cis) <- partitionEithers <$> saveSndChatItems user (CDDirectSnd ct) itemsData timed_ live
processSendErrs user r
@@ -2982,39 +3005,40 @@ 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 (ComposeMessageReq, Maybe FileInvitation) -> Maybe CITimed -> CM (NonEmpty (MsgContainer, Maybe (CIQuote 'CTDirect)))
prepareMsgs cmsFileInvs timed_ =
forM cmsFileInvs $ \((ComposedMessage {quotedItemId, msgContent = mc}, itemForwarded), fInv_) ->
prepareMsgs :: NonEmpty (ComposedMessageReq, Maybe FileInvitation) -> Maybe CITimed -> CM (NonEmpty (MsgContainer, Maybe (CIQuote 'CTDirect), (Map MemberName MentionedMember, Map MemberName MemberMention)))
prepareMsgs cmsFileInvs timed_ = withFastStore $ \db ->
forM cmsFileInvs $ \((ComposedMessage {quotedItemId, msgContent = mc}, itemForwarded, _), fInv_) -> do
let mms = (M.empty, M.empty)
case (quotedItemId, itemForwarded) of
(Nothing, Nothing) -> pure (MCSimple (ExtMsgContent mc fInv_ (ttl' <$> timed_) (justTrue live)), Nothing)
(Nothing, Just _) -> pure (MCForward (ExtMsgContent mc fInv_ (ttl' <$> timed_) (justTrue live)), Nothing)
(Nothing, Nothing) -> pure (MCSimple (ExtMsgContent mc M.empty fInv_ (ttl' <$> timed_) (justTrue live)), Nothing, mms)
(Nothing, Just _) -> pure (MCForward (ExtMsgContent mc M.empty fInv_ (ttl' <$> timed_) (justTrue live)), Nothing, mms)
(Just qiId, Nothing) -> do
CChatItem _ qci@ChatItem {meta = CIMeta {itemTs, itemSharedMsgId}, formattedText, file} <-
withFastStore $ \db -> getDirectChatItem db user contactId qiId
getDirectChatItem db user contactId qiId
(origQmc, qd, sent) <- quoteData qci
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 fInv_ (ttl' <$> timed_) (justTrue live)), Just quotedItem)
(Just _, Just _) -> throwChatError CEInvalidQuote
pure (MCQuote QuotedMsg {msgRef, content = qmc} (ExtMsgContent mc M.empty fInv_ (ttl' <$> timed_) (justTrue live)), Just quotedItem, mms)
(Just _, Just _) -> throwError SEInvalidQuote
where
quoteData :: ChatItem c d -> CM (MsgContent, CIQDirection 'CTDirect, Bool)
quoteData ChatItem {meta = CIMeta {itemDeleted = Just _}} = throwChatError CEInvalidQuote
quoteData :: ChatItem c d -> ExceptT StoreError IO (MsgContent, CIQDirection 'CTDirect, Bool)
quoteData ChatItem {meta = CIMeta {itemDeleted = Just _}} = throwError SEInvalidQuote
quoteData ChatItem {content = CISndMsgContent qmc} = pure (qmc, CIQDirectSnd, True)
quoteData ChatItem {content = CIRcvMsgContent qmc} = pure (qmc, CIQDirectRcv, False)
quoteData _ = throwChatError CEInvalidQuote
sendGroupContentMessages :: User -> GroupId -> Bool -> Maybe Int -> NonEmpty ComposeMessageReq -> CM ChatResponse
quoteData _ = throwError SEInvalidQuote
sendGroupContentMessages :: User -> GroupId -> Bool -> Maybe Int -> NonEmpty ComposedMessageReq -> CM ChatResponse
sendGroupContentMessages user groupId live itemTTL cmrs = do
assertMultiSendable live cmrs
Group gInfo ms <- withFastStore $ \db -> getGroup db vr user groupId
sendGroupContentMessages_ user gInfo ms live itemTTL cmrs
sendGroupContentMessages_ :: User -> GroupInfo -> [GroupMember] -> Bool -> Maybe Int -> NonEmpty ComposeMessageReq -> CM ChatResponse
sendGroupContentMessages_ :: User -> GroupInfo -> [GroupMember] -> Bool -> Maybe Int -> NonEmpty ComposedMessageReq -> CM ChatResponse
sendGroupContentMessages_ user gInfo@GroupInfo {groupId, membership} ms live itemTTL cmrs = do
assertUserGroupRole gInfo GRAuthor
assertGroupContentAllowed
@@ -3026,18 +3050,18 @@ processChatCommand' vr = \case
Just f -> throwChatError (CECommandError $ "feature not allowed " <> T.unpack (groupFeatureNameText f))
Nothing -> pure ()
where
findProhibited :: [ComposeMessageReq] -> Maybe GroupFeature
findProhibited :: [ComposedMessageReq] -> Maybe GroupFeature
findProhibited =
foldr'
(\(ComposedMessage {fileSource, msgContent = mc}, _) acc -> prohibitedGroupContent gInfo membership mc fileSource <|> acc)
(\(ComposedMessage {fileSource, msgContent = mc}, _, (_, ft)) acc -> prohibitedGroupContent gInfo membership mc ft fileSource <|> acc)
Nothing
processComposedMessages :: CM ChatResponse
processComposedMessages = do
(fInvs_, ciFiles_) <- L.unzip <$> setupSndFileTransfers (length $ filter memberCurrent ms)
timed_ <- sndGroupCITimed live gInfo itemTTL
(msgContainers, quotedItems_) <- L.unzip <$> prepareMsgs (L.zip cmrs fInvs_) timed_
(msgContainers, quotedItems_, mms) <- neUnzip3 <$> prepareMsgs (L.zip cmrs fInvs_) timed_
(msgs_, gsr) <- sendGroupMessages user gInfo ms $ L.map XMsgNew msgContainers
let itemsData = prepareSndItemsData (L.toList msgs_) cmrs ciFiles_ quotedItems_
let itemsData = prepareSndItemsData (L.toList cmrs) (L.toList mms) (L.toList ciFiles_) (L.toList quotedItems_) (L.toList msgs_)
cis_ <- saveSndChatItems user (CDGroupSnd gInfo) itemsData timed_ live
when (length itemsData /= length cmrs) $ logError "sendGroupContentMessages: cmrs and cis_ length mismatch"
createMemberSndStatuses cis_ msgs_ gsr
@@ -3050,16 +3074,16 @@ 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 (ComposeMessageReq, Maybe FileInvitation) -> Maybe CITimed -> CM (NonEmpty (MsgContainer, Maybe (CIQuote 'CTGroup)))
prepareMsgs cmsFileInvs timed_ =
forM cmsFileInvs $ \((ComposedMessage {quotedItemId, msgContent = mc}, itemForwarded), fInv_) ->
prepareGroupMsg user gInfo mc quotedItemId itemForwarded fInv_ timed_ live
prepareMsgs :: NonEmpty (ComposedMessageReq, Maybe FileInvitation) -> Maybe CITimed -> CM (NonEmpty (MsgContainer, Maybe (CIQuote 'CTGroup), (Map MemberName MentionedMember, Map MemberName MemberMention)))
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
createMemberSndStatuses ::
[Either ChatError (ChatItem 'CTGroup 'MDSnd)] ->
NonEmpty (Either ChatError SndMessage) ->
@@ -3095,7 +3119,7 @@ processChatCommand' vr = \case
Right _ -> GSSInactive
Left e -> GSSError $ SndErrOther $ tshow e
forM_ ciId_ $ \ciId -> createGroupSndStatus db ciId mId status
assertMultiSendable :: Bool -> NonEmpty ComposeMessageReq -> CM ()
assertMultiSendable :: Bool -> NonEmpty ComposedMessageReq -> CM ()
assertMultiSendable live cmrs
| length cmrs == 1 = pure ()
| otherwise =
@@ -3103,7 +3127,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
@@ -3121,19 +3145,16 @@ processChatCommand' vr = \case
saveMemberFD _ = pure ()
pure (fInv, ciFile)
prepareSndItemsData ::
[ComposedMessageReq] ->
[(Map MemberName MentionedMember, Map MemberName MemberMention)] ->
[Maybe (CIFile 'MDSnd)] ->
[Maybe (CIQuote c)] ->
[Either ChatError SndMessage] ->
NonEmpty ComposeMessageReq ->
NonEmpty (Maybe (CIFile 'MDSnd)) ->
NonEmpty (Maybe (CIQuote c)) ->
[Either ChatError (NewSndChatItemData c)]
prepareSndItemsData msgs_ cmrs' ciFiles_ quotedItems_ =
[ ( case msg_ of
Right msg -> Right $ NewSndChatItemData msg (CISndMsgContent msgContent) f q itemForwarded
Left e -> Left e -- step over original error
)
| (msg_, (ComposedMessage {msgContent}, itemForwarded), f, q) <-
zipWith4 (,,,) msgs_ (L.toList cmrs') (L.toList ciFiles_) (L.toList quotedItems_)
]
prepareSndItemsData =
zipWith5 $ \(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 ()
processSendErrs user = \case
-- no errors
@@ -3178,7 +3199,7 @@ processChatCommand' vr = \case
forwardMsgContent ChatItem {content = CISndMsgContent fmc} = pure $ Just fmc
forwardMsgContent ChatItem {content = CIRcvMsgContent fmc} = pure $ Just fmc
forwardMsgContent _ = throwChatError CEInvalidForward
createNoteFolderContentItems :: User -> NoteFolderId -> NonEmpty ComposeMessageReq -> CM ChatResponse
createNoteFolderContentItems :: User -> NoteFolderId -> NonEmpty ComposedMessageReq -> CM ChatResponse
createNoteFolderContentItems user folderId cmrs = do
assertNoQuotes
nf <- withFastStore $ \db -> getNoteFolder db user folderId
@@ -3190,11 +3211,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
@@ -3203,13 +3224,12 @@ processChatCommand' vr = \case
fileId <- createLocalFile CIFSSndStored db user nf createdAt cf fileSize chunkSize
pure CIFile {fileId, fileName = takeFileName filePath, fileSize, fileSource = Just cf, fileStatus = CIFSSndStored, fileProtocol = FPLocal}
prepareLocalItemsData ::
NonEmpty ComposeMessageReq ->
NonEmpty ComposedMessageReq ->
NonEmpty (Maybe (CIFile 'MDSnd)) ->
[(CIContent 'MDSnd, Maybe (CIFile 'MDSnd), Maybe CIForwardedFrom)]
prepareLocalItemsData cmrs' ciFiles_ =
[ (CISndMsgContent mc, f, itemForwarded)
| ((ComposedMessage {msgContent = mc}, itemForwarded), f) <- zip (L.toList cmrs') (L.toList ciFiles_)
]
NonEmpty (CIContent 'MDSnd, Maybe (CIFile 'MDSnd), Maybe CIForwardedFrom, (Text, Maybe MarkdownList))
prepareLocalItemsData =
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)
CRQueueInfo user msgInfo <$> withAgent (`getConnectionQueueInfo` acId)
@@ -3231,7 +3251,13 @@ updatedServers p' srvs UserOperatorServers {operator, smpServers, xftpServers} =
disableSrv srv@UserServer {preset} =
AUS SDBStored $ if preset then srv {enabled = False} else srv {deleted = True}
type ComposeMessageReq = (ComposedMessage, Maybe CIForwardedFrom)
type ComposedMessageReq = (ComposedMessage, Maybe CIForwardedFrom, (Text, Maybe MarkdownList))
composedMessage :: Maybe CryptoFile -> MsgContent -> ComposedMessage
composedMessage f mc = ComposedMessage {fileSource = f, quotedItemId = Nothing, msgContent = mc, mentions = M.empty}
composedMessageReq :: ComposedMessage -> ComposedMessageReq
composedMessageReq cm@ComposedMessage {msgContent = mc} = (cm, Nothing, msgContentTexts mc)
data ChangedProfileContact = ChangedProfileContact
{ ct :: Contact,
@@ -3692,7 +3718,7 @@ chatCommandP =
"/_create *" *> (APICreateChatItems <$> A.decimal <*> (" json " *> jsonP <|> " text " *> composedMessagesTextP)),
"/_report #" *> (APIReportMessage <$> A.decimal <* A.space <*> A.decimal <*> (" reason=" *> strP) <*> (A.space *> textP <|> pure "")),
"/report #" *> (ReportMessage <$> displayNameP <*> optional (" @" *> displayNameP) <*> _strP <* A.space <*> msgTextP),
"/_update item " *> (APIUpdateChatItem <$> chatRefP <* A.space <*> A.decimal <*> liveMessageP <* A.space <*> msgContentP),
"/_update item " *> (APIUpdateChatItem <$> chatRefP <* A.space <*> A.decimal <*> liveMessageP <*> (" json" *> jsonP <|> " text " *> updatedMessagesTextP)),
"/_delete item " *> (APIDeleteChatItem <$> chatRefP <*> _strP <*> _strP),
"/_delete member item #" *> (APIDeleteMemberChatItem <$> A.decimal <*> _strP),
"/_reaction " *> (APIChatItemReaction <$> chatRefP <* A.space <*> A.decimal <* A.space <*> onOffP <* A.space <*> jsonP),
@@ -3725,7 +3751,6 @@ chatCommandP =
"/_set prefs @" *> (APISetContactPrefs <$> A.decimal <* A.space <*> jsonP),
"/_set theme user " *> (APISetUserUIThemes <$> A.decimal <*> optional (A.space *> jsonP)),
"/_set theme " *> (APISetChatUIThemes <$> chatRefP <*> optional (A.space *> jsonP)),
"/_parse " *> (APIParseMarkdown . safeDecodeUtf8 <$> A.takeByteString),
"/_ntf get" $> APIGetNtfToken,
"/_ntf register " *> (APIRegisterToken <$> strP_ <*> strP),
"/_ntf verify " *> (APIVerifyToken <$> strP <* A.space <*> strP <* A.space <*> strP),
@@ -4003,7 +4028,8 @@ chatCommandP =
c -> c
composedMessagesTextP = do
text <- mcTextP
pure $ (ComposedMessage Nothing Nothing text) :| []
pure [composedMessage Nothing text]
updatedMessagesTextP = (`UpdatedMessage` []) <$> mcTextP
liveMessageP = " live=" *> onOffP <|> pure False
sendMessageTTLP = " ttl=" *> ((Just <$> A.decimal) <|> ("default" $> Nothing)) <|> pure Nothing
receiptSettings = do
@@ -4123,7 +4149,7 @@ displayNameP = safeDecodeUtf8 <$> (quoted '\'' <|> takeNameTill (\c -> isSpace c
A.peekChar' >>= \c ->
if refChar c then A.takeTill p else fail "invalid first character in display name"
quoted c = A.char c *> takeNameTill (== c) <* A.char c
refChar c = c > ' ' && c /= '#' && c /= '@'
refChar c = c > ' ' && c /= '#' && c /= '@' && c /= '\''
mkValidName :: String -> String
mkValidName = reverse . dropWhile isSpace . fst3 . foldl' addChar ("", '\NUL', 0 :: Int)
src/Simplex/Chat/Library/Internal.hs
+130 -44
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.Containers.ListUtils (nubOrd)
import Data.Either (partitionEithers, rights)
import Data.Fixed (div')
import Data.Foldable (foldr')
@@ -102,6 +103,12 @@ import UnliftIO.STM
maxMsgReactions :: Int
maxMsgReactions = 3
maxRcvMentions :: Int
maxRcvMentions = 5
maxSndMentions :: Int
maxSndMentions = 3
withChatLock :: String -> CM a -> CM a
withChatLock name action = asks chatLock >>= \l -> withLock l name action
@@ -181,25 +188,76 @@ toggleNtf user m ntfOn =
forM_ (memberConnId m) $ \connId ->
withAgent (\a -> toggleConnectionNtfs a connId ntfOn) `catchChatError` (toView . CRChatError (Just user))
prepareGroupMsg :: User -> GroupInfo -> MsgContent -> Maybe ChatItemId -> Maybe CIForwardedFrom -> Maybe FileInvitation -> Maybe CITimed -> Bool -> CM (MsgContainer, Maybe (CIQuote 'CTGroup))
prepareGroupMsg user GroupInfo {groupId, membership} mc quotedItemId_ itemForwarded fInv_ timed_ live = case (quotedItemId_, itemForwarded) of
(Nothing, Nothing) -> pure (MCSimple (ExtMsgContent mc fInv_ (ttl' <$> timed_) (justTrue live)), Nothing)
(Nothing, Just _) -> pure (MCForward (ExtMsgContent mc fInv_ (ttl' <$> timed_) (justTrue live)), Nothing)
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)
(Nothing, Just _) ->
pure (MCForward (ExtMsgContent mc M.empty fInv_ (ttl' <$> timed_) (justTrue live)), Nothing, (M.empty, M.empty))
(Just quotedItemId, Nothing) -> do
mms@(_, mentions) <- getMentionedMembers db user g ft_ memberMentions
CChatItem _ qci@ChatItem {meta = CIMeta {itemTs, itemSharedMsgId}, formattedText, file} <-
withStore $ \db -> getGroupChatItem db user groupId quotedItemId
getGroupChatItem db user groupId quotedItemId
(origQmc, qd, sent, GroupMember {memberId}) <- quoteData qci membership
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 fInv_ (ttl' <$> timed_) (justTrue live)), Just quotedItem)
(Just _, Just _) -> throwChatError CEInvalidQuote
pure (MCQuote QuotedMsg {msgRef, content = qmc} (ExtMsgContent mc mentions fInv_ (ttl' <$> timed_) (justTrue live)), Just quotedItem, mms)
(Just _, Just _) -> throwError SEInvalidQuote
where
quoteData :: ChatItem c d -> GroupMember -> CM (MsgContent, CIQDirection 'CTGroup, Bool, GroupMember)
quoteData ChatItem {meta = CIMeta {itemDeleted = Just _}} _ = throwChatError CEInvalidQuote
quoteData :: ChatItem c d -> GroupMember -> ExceptT StoreError IO (MsgContent, CIQDirection 'CTGroup, Bool, GroupMember)
quoteData ChatItem {meta = CIMeta {itemDeleted = Just _}} _ = throwError SEInvalidQuote
quoteData ChatItem {chatDir = CIGroupSnd, content = CISndMsgContent qmc} membership' = pure (qmc, CIQGroupSnd, True, membership')
quoteData ChatItem {chatDir = CIGroupRcv m, content = CIRcvMsgContent qmc} _ = pure (qmc, CIQGroupRcv $ Just m, False, m)
quoteData _ _ = throwChatError CEInvalidQuote
quoteData _ _ = throwError SEInvalidQuote
getMentionedMembers :: DB.Connection -> User -> GroupInfo -> Maybe MarkdownList -> Map MemberName GroupMemberId -> ExceptT StoreError IO (Map MemberName MentionedMember, Map MemberName MemberMention)
getMentionedMembers db user GroupInfo {groupId} ft_ mentions = case ft_ of
Just ft | not (null mentions) -> do
let msgMentions = S.fromList $ mentionedNames ft
n = M.size mentions
-- prevent "invisible" and repeated-with-different-name mentions (when the same member is mentioned via another name)
unless (n <= maxSndMentions && all (`S.member` msgMentions) (M.keys mentions) && S.size (S.fromList $ M.elems mentions) == n) $
throwError SEInvalidMention
mentionedMembers <- mapM (getMentionedGroupMember db user groupId) mentions
let mentions' = M.map (\MentionedMember {memberId} -> MemberMention {memberId}) mentionedMembers
pure (mentionedMembers, mentions')
_ -> pure (M.empty, M.empty)
getRcvMentionedMembers :: DB.Connection -> User -> GroupInfo -> Maybe MarkdownList -> Map MemberName MemberMention -> IO (Map MemberName MentionedMember)
getRcvMentionedMembers db user GroupInfo {groupId} ft_ mentions = case ft_ of
Just ft | not (null mentions) ->
let mentions' = uniqueMsgMentions maxRcvMentions mentions $ mentionedNames ft
in mapM (getMentionedMemberByMemberId db user groupId) mentions'
_ -> pure M.empty
-- prevent "invisible" and repeated-with-different-name mentions
uniqueMsgMentions :: Int -> Map MemberName MemberMention -> [ContactName] -> Map MemberName MemberMention
uniqueMsgMentions maxMentions mentions = go M.empty S.empty 0
where
go acc _ _ [] = acc
go acc seen n (name : rest)
| n >= maxMentions = acc
| otherwise = case M.lookup name mentions of
Just mm@MemberMention {memberId} | S.notMember memberId seen ->
go (M.insert name mm acc) (S.insert memberId seen) (n + 1) rest
_ -> go acc seen n rest
getMessageMentions :: DB.Connection -> User -> GroupId -> Text -> IO (Map MemberName GroupMemberId)
getMessageMentions db user gId msg = case parseMaybeMarkdownList msg of
Just ft -> M.fromList . catMaybes <$> mapM get (nubOrd $ mentionedNames ft)
Nothing -> pure M.empty
where
get name =
fmap (name,) . eitherToMaybe
<$> runExceptT (getGroupMemberIdByName db user gId name)
msgContentTexts :: MsgContent -> (Text, Maybe MarkdownList)
msgContentTexts mc = let t = msgContentText mc in (t, parseMaybeMarkdownList t)
ciContentTexts :: CIContent d -> (Text, Maybe MarkdownList)
ciContentTexts content = let t = ciContentToText content in (t, parseMaybeMarkdownList t)
quoteContent :: forall d. MsgContent -> MsgContent -> Maybe (CIFile d) -> MsgContent
quoteContent mc qmc ciFile_
@@ -228,17 +286,17 @@ quoteContent mc qmc ciFile_
qFileName = maybe qText (T.pack . getFileName) ciFile_
qTextOrFile = if T.null qText then qFileName else qText
prohibitedGroupContent :: GroupInfo -> GroupMember -> MsgContent -> Maybe f -> Maybe GroupFeature
prohibitedGroupContent gInfo m mc file_
prohibitedGroupContent :: GroupInfo -> GroupMember -> MsgContent -> Maybe MarkdownList -> Maybe f -> Maybe GroupFeature
prohibitedGroupContent gInfo m mc ft file_
| isVoice mc && not (groupFeatureMemberAllowed SGFVoice m gInfo) = Just GFVoice
| not (isVoice mc) && isJust file_ && not (groupFeatureMemberAllowed SGFFiles m gInfo) = Just GFFiles
| prohibitedSimplexLinks gInfo m mc = Just GFSimplexLinks
| prohibitedSimplexLinks gInfo m ft = Just GFSimplexLinks
| otherwise = Nothing
prohibitedSimplexLinks :: GroupInfo -> GroupMember -> MsgContent -> Bool
prohibitedSimplexLinks gInfo m mc =
prohibitedSimplexLinks :: GroupInfo -> GroupMember -> Maybe MarkdownList -> Bool
prohibitedSimplexLinks gInfo m ft =
not (groupFeatureMemberAllowed SGFSimplexLinks m gInfo)
&& maybe False (any ftIsSimplexLink) (parseMaybeMarkdownList $ msgContentText mc)
&& maybe False (any ftIsSimplexLink) ft
where
ftIsSimplexLink :: FormattedText -> Bool
ftIsSimplexLink FormattedText {format} = maybe False isSimplexLink format
@@ -863,9 +921,6 @@ startUpdatedTimedItemThread user chatRef ci ci' =
metaBrokerTs :: MsgMeta -> UTCTime
metaBrokerTs MsgMeta {broker = (_, brokerTs)} = brokerTs
sameMemberId :: MemberId -> GroupMember -> Bool
sameMemberId memId GroupMember {memberId} = memId == memberId
createContactPQSndItem :: User -> Contact -> Connection -> PQEncryption -> CM (Contact, Connection)
createContactPQSndItem user ct conn@Connection {pqSndEnabled} pqSndEnabled' =
flip catchChatError (const $ pure (ct, conn)) $ case (pqSndEnabled, pqSndEnabled') of
@@ -1549,15 +1604,20 @@ saveGroupFwdRcvMsg user groupId forwardingMember refAuthorMember@GroupMember {me
saveSndChatItem :: ChatTypeI c => User -> ChatDirection c 'MDSnd -> SndMessage -> CIContent 'MDSnd -> CM (ChatItem c 'MDSnd)
saveSndChatItem user cd msg content = saveSndChatItem' user cd msg content Nothing Nothing Nothing Nothing False
-- TODO [mentions] optimize by avoiding unnecesary parsing of control messages
saveSndChatItem' :: ChatTypeI c => User -> ChatDirection c 'MDSnd -> SndMessage -> CIContent 'MDSnd -> Maybe (CIFile 'MDSnd) -> Maybe (CIQuote c) -> Maybe CIForwardedFrom -> Maybe CITimed -> Bool -> CM (ChatItem c 'MDSnd)
saveSndChatItem' user cd msg content ciFile quotedItem itemForwarded itemTimed live =
saveSndChatItems user cd [Right NewSndChatItemData {msg, content, ciFile, quotedItem, itemForwarded}] itemTimed live >>= \case
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
[Right ci] -> pure ci
_ -> throwChatError $ CEInternalError "saveSndChatItem': expected 1 item"
data NewSndChatItemData c = NewSndChatItemData
{ msg :: SndMessage,
content :: CIContent 'MDSnd,
itemTexts :: (Text, Maybe MarkdownList),
itemMentions :: (Map MemberName MentionedMember, Map MemberName MemberMention),
ciFile :: Maybe (CIFile 'MDSnd),
quotedItem :: Maybe (CIQuote c),
itemForwarded :: Maybe CIForwardedFrom
@@ -1579,31 +1639,57 @@ saveSndChatItems user cd itemsData itemTimed live = do
lift $ withStoreBatch (\db -> map (bindRight $ createItem db createdAt) itemsData)
where
createItem :: DB.Connection -> UTCTime -> NewSndChatItemData c -> IO (Either ChatError (ChatItem c 'MDSnd))
createItem db createdAt NewSndChatItemData {msg = msg@SndMessage {sharedMsgId}, content, ciFile, quotedItem, itemForwarded} = do
createItem db createdAt NewSndChatItemData {msg = msg@SndMessage {sharedMsgId}, content, itemTexts, itemMentions, ciFile, quotedItem, itemForwarded} = do
ciId <- createNewSndChatItem db user cd msg content quotedItem itemForwarded itemTimed live createdAt
forM_ ciFile $ \CIFile {fileId} -> updateFileTransferChatItemId db fileId ciId createdAt
pure $ Right $ mkChatItem cd ciId content ciFile quotedItem (Just sharedMsgId) itemForwarded itemTimed live createdAt Nothing createdAt
let ci = mkChatItem_ cd ciId content itemTexts ciFile quotedItem (Just sharedMsgId) itemForwarded itemTimed live False createdAt Nothing createdAt
mentions = fst itemMentions
Right <$> case cd of
CDGroupSnd g | not (null mentions) -> createGroupCIMentions db g ci mentions
_ -> pure ci
saveRcvChatItem :: (ChatTypeI c, ChatTypeQuotable c) => User -> ChatDirection c 'MDRcv -> RcvMessage -> UTCTime -> CIContent 'MDRcv -> CM (ChatItem c 'MDRcv)
saveRcvChatItemNoParse :: (ChatTypeI c, ChatTypeQuotable c) => User -> ChatDirection c 'MDRcv -> RcvMessage -> UTCTime -> CIContent 'MDRcv -> CM (ChatItem c 'MDRcv)
saveRcvChatItemNoParse user cd msg brokerTs = saveRcvChatItem user cd msg brokerTs . ciContentNoParse
saveRcvChatItem :: (ChatTypeI c, ChatTypeQuotable c) => User -> ChatDirection c 'MDRcv -> RcvMessage -> UTCTime -> (CIContent 'MDRcv, (Text, Maybe MarkdownList)) -> CM (ChatItem c 'MDRcv)
saveRcvChatItem user cd msg@RcvMessage {sharedMsgId_} brokerTs content =
saveRcvChatItem' user cd msg sharedMsgId_ brokerTs content Nothing Nothing False
saveRcvChatItem' user cd msg sharedMsgId_ brokerTs content Nothing Nothing False M.empty
saveRcvChatItem' :: (ChatTypeI c, ChatTypeQuotable c) => User -> ChatDirection c 'MDRcv -> RcvMessage -> Maybe SharedMsgId -> UTCTime -> CIContent 'MDRcv -> Maybe (CIFile 'MDRcv) -> Maybe CITimed -> Bool -> CM (ChatItem c 'MDRcv)
saveRcvChatItem' user cd msg@RcvMessage {forwardedByMember} sharedMsgId_ brokerTs content ciFile itemTimed live = do
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' user cd msg@RcvMessage {chatMsgEvent, forwardedByMember} sharedMsgId_ brokerTs (content, (t, ft_)) ciFile itemTimed live mentions = do
createdAt <- liftIO getCurrentTime
(ciId, quotedItem, itemForwarded) <- withStore' $ \db -> do
withStore' $ \db -> do
when (ciRequiresAttention content || contactChatDeleted cd) $ updateChatTs db user cd createdAt
r@(ciId, _, _) <- createNewRcvChatItem db user cd msg sharedMsgId_ content itemTimed live brokerTs createdAt
(mentions' :: Map MemberName MentionedMember, userMention) <- case cd of
CDGroupRcv g@GroupInfo {membership} _ -> do
mentions' <- getRcvMentionedMembers db user g ft_ mentions
let userReply = case cmToQuotedMsg chatMsgEvent of
Just QuotedMsg {msgRef = MsgRef {memberId = Just mId}} -> sameMemberId mId membership
_ -> False
userMention' = userReply || any (\MentionedMember {memberId} -> sameMemberId memberId membership) mentions'
in pure (mentions', userMention')
CDDirectRcv _ -> pure (M.empty, False)
(ciId, quotedItem, itemForwarded) <- createNewRcvChatItem db user cd msg sharedMsgId_ content itemTimed live userMention brokerTs createdAt
forM_ ciFile $ \CIFile {fileId} -> updateFileTransferChatItemId db fileId ciId createdAt
pure r
pure $ mkChatItem cd ciId content ciFile quotedItem sharedMsgId_ itemForwarded itemTimed live brokerTs forwardedByMember createdAt
let ci = mkChatItem_ cd ciId content (t, ft_) ciFile quotedItem sharedMsgId_ itemForwarded itemTimed live userMention brokerTs forwardedByMember createdAt
case cd of
CDGroupRcv g _ | not (null mentions') -> createGroupCIMentions db g ci mentions'
_ -> pure ci
mkChatItem :: (ChatTypeI c, MsgDirectionI d) => ChatDirection c d -> ChatItemId -> CIContent d -> Maybe (CIFile d) -> Maybe (CIQuote c) -> Maybe SharedMsgId -> Maybe CIForwardedFrom -> Maybe CITimed -> Bool -> ChatItemTs -> Maybe GroupMemberId -> UTCTime -> ChatItem c d
mkChatItem cd ciId content file quotedItem sharedMsgId itemForwarded itemTimed live itemTs forwardedByMember currentTs =
let itemText = ciContentToText content
itemStatus = ciCreateStatus content
meta = mkCIMeta ciId content itemText itemStatus Nothing sharedMsgId itemForwarded Nothing False itemTimed (justTrue live) currentTs itemTs forwardedByMember currentTs currentTs
in ChatItem {chatDir = toCIDirection cd, meta, content, formattedText = parseMaybeMarkdownList itemText, quotedItem, reactions = [], file}
-- TODO [mentions] optimize by avoiding unnecessary parsing
mkChatItem :: (ChatTypeI c, MsgDirectionI d) => ChatDirection c d -> ChatItemId -> CIContent d -> Maybe (CIFile d) -> Maybe (CIQuote c) -> Maybe SharedMsgId -> Maybe CIForwardedFrom -> Maybe CITimed -> Bool -> Bool -> ChatItemTs -> Maybe GroupMemberId -> UTCTime -> ChatItem c d
mkChatItem cd ciId content file quotedItem sharedMsgId itemForwarded itemTimed live userMention itemTs forwardedByMember currentTs =
let ts = ciContentTexts content
in mkChatItem_ cd ciId content ts file quotedItem sharedMsgId itemForwarded itemTimed live userMention itemTs forwardedByMember currentTs
mkChatItem_ :: (ChatTypeI c, MsgDirectionI d) => ChatDirection c d -> ChatItemId -> CIContent d -> (Text, Maybe MarkdownList) -> Maybe (CIFile d) -> Maybe (CIQuote c) -> Maybe SharedMsgId -> Maybe CIForwardedFrom -> Maybe CITimed -> Bool -> Bool -> ChatItemTs -> Maybe GroupMemberId -> UTCTime -> ChatItem c d
mkChatItem_ cd ciId content (itemText, formattedText) file quotedItem sharedMsgId itemForwarded itemTimed live userMention itemTs forwardedByMember currentTs =
let itemStatus = ciCreateStatus content
meta = mkCIMeta ciId content itemText itemStatus Nothing sharedMsgId itemForwarded Nothing False itemTimed (justTrue live) userMention currentTs itemTs forwardedByMember currentTs currentTs
in ChatItem {chatDir = toCIDirection cd, meta, content, mentions = M.empty, formattedText, quotedItem, reactions = [], file}
createAgentConnectionAsync :: ConnectionModeI c => User -> CommandFunction -> Bool -> SConnectionMode c -> SubscriptionMode -> CM (CommandId, ConnId)
createAgentConnectionAsync user cmdFunction enableNtfs cMode subMode = do
@@ -1815,26 +1901,26 @@ createInternalItemsForChats user itemTs_ dirsCIContents = do
createACIs :: DB.Connection -> UTCTime -> UTCTime -> ChatDirection c d -> [CIContent d] -> [IO AChatItem]
createACIs db itemTs createdAt cd = map $ \content -> do
ciId <- createNewChatItemNoMsg db user cd content itemTs createdAt
let ci = mkChatItem cd ciId content Nothing Nothing Nothing Nothing Nothing False itemTs Nothing createdAt
let ci = mkChatItem cd ciId content Nothing Nothing Nothing Nothing Nothing False False itemTs Nothing createdAt
pure $ AChatItem (chatTypeI @c) (msgDirection @d) (toChatInfo cd) ci
createLocalChatItems ::
User ->
ChatDirection 'CTLocal 'MDSnd ->
[(CIContent 'MDSnd, Maybe (CIFile 'MDSnd), Maybe CIForwardedFrom)] ->
NonEmpty (CIContent 'MDSnd, Maybe (CIFile 'MDSnd), Maybe CIForwardedFrom, (Text, Maybe MarkdownList)) ->
UTCTime ->
CM [ChatItem 'CTLocal 'MDSnd]
createLocalChatItems user cd itemsData createdAt = do
withStore' $ \db -> updateChatTs db user cd createdAt
(errs, items) <- lift $ partitionEithers <$> withStoreBatch' (\db -> map (createItem db) itemsData)
(errs, items) <- lift $ partitionEithers <$> withStoreBatch' (\db -> map (createItem db) $ L.toList itemsData)
unless (null errs) $ toView $ CRChatErrors (Just user) errs
pure items
where
createItem :: DB.Connection -> (CIContent 'MDSnd, Maybe (CIFile 'MDSnd), Maybe CIForwardedFrom) -> IO (ChatItem 'CTLocal 'MDSnd)
createItem db (content, ciFile, itemForwarded) = do
ciId <- createNewChatItem_ db user cd Nothing Nothing content (Nothing, Nothing, Nothing, Nothing, Nothing) itemForwarded Nothing False createdAt Nothing createdAt
createItem :: DB.Connection -> (CIContent 'MDSnd, Maybe (CIFile 'MDSnd), Maybe CIForwardedFrom, (Text, Maybe MarkdownList)) -> IO (ChatItem 'CTLocal 'MDSnd)
createItem db (content, ciFile, itemForwarded, ts) = do
ciId <- createNewChatItem_ db user cd Nothing Nothing content (Nothing, Nothing, Nothing, Nothing, Nothing) itemForwarded Nothing False False createdAt Nothing createdAt
forM_ ciFile $ \CIFile {fileId} -> updateFileTransferChatItemId db fileId ciId createdAt
pure $ mkChatItem cd ciId content ciFile Nothing Nothing itemForwarded Nothing False createdAt Nothing createdAt
pure $ mkChatItem_ cd ciId content ts ciFile Nothing Nothing itemForwarded Nothing False False createdAt Nothing createdAt
withUser' :: (User -> CM ChatResponse) -> CM ChatResponse
withUser' action =
src/Simplex/Chat/Library/Subscriber.hs
+51 -38
View File
@@ -31,6 +31,7 @@ import Data.Int (Int64)
import Data.List (foldl', partition)
import Data.List.NonEmpty (NonEmpty (..), (<|))
import qualified Data.List.NonEmpty as L
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as M
import Data.Maybe (catMaybes, fromMaybe, isJust, isNothing, mapMaybe)
import Data.Text (Text)
@@ -500,7 +501,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
case event of
XMsgNew mc -> newContentMessage ct'' mc msg msgMeta
XMsgFileDescr sharedMsgId fileDescr -> messageFileDescription ct'' sharedMsgId fileDescr
XMsgUpdate sharedMsgId mContent ttl live -> messageUpdate ct'' sharedMsgId mContent msg msgMeta ttl live
XMsgUpdate sharedMsgId mContent _ ttl live -> messageUpdate ct'' sharedMsgId mContent msg msgMeta ttl live
XMsgDel sharedMsgId _ -> messageDelete ct'' sharedMsgId msg msgMeta
XMsgReact sharedMsgId _ reaction add -> directMsgReaction ct'' sharedMsgId reaction add msg msgMeta
-- TODO discontinue XFile
@@ -900,7 +901,9 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
let CIMeta {itemTs, itemSharedMsgId, itemTimed} = meta
quotedItemId_ = quoteItemId =<< quotedItem
fInv_ = fst <$> fInvDescr_
(msgContainer, _) <- prepareGroupMsg user gInfo mc quotedItemId_ Nothing fInv_ itemTimed False
-- TODO [mentions] history?
let (_t, ft_) = msgContentTexts mc
(msgContainer, _, _) <- withStore $ \db -> prepareGroupMsg db user gInfo mc ft_ M.empty quotedItemId_ Nothing fInv_ itemTimed False
let senderVRange = memberChatVRange' sender
xMsgNewChatMsg = ChatMessage {chatVRange = senderVRange, msgId = itemSharedMsgId, chatMsgEvent = XMsgNew msgContainer}
fileDescrEvents <- case (snd <$> fInvDescr_, itemSharedMsgId) of
@@ -966,7 +969,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
case event of
XMsgNew mc -> memberCanSend m' $ newGroupContentMessage gInfo m' mc msg brokerTs False
XMsgFileDescr sharedMsgId fileDescr -> memberCanSend m' $ groupMessageFileDescription gInfo m' sharedMsgId fileDescr
XMsgUpdate sharedMsgId mContent ttl live -> memberCanSend m' $ groupMessageUpdate gInfo m' sharedMsgId mContent msg brokerTs ttl live
XMsgUpdate sharedMsgId mContent mentions ttl live -> memberCanSend m' $ groupMessageUpdate gInfo m' sharedMsgId mContent mentions msg brokerTs ttl live
XMsgDel sharedMsgId memberId -> groupMessageDelete gInfo m' sharedMsgId memberId msg brokerTs
XMsgReact sharedMsgId (Just memberId) reaction add -> groupMsgReaction gInfo m' sharedMsgId memberId reaction add msg brokerTs
-- TODO discontinue XFile
@@ -1539,7 +1542,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
newContentMessage :: Contact -> MsgContainer -> RcvMessage -> MsgMeta -> CM ()
newContentMessage ct@Contact {contactUsed} mc msg@RcvMessage {sharedMsgId_} msgMeta = do
unless contactUsed $ withStore' $ \db -> updateContactUsed db user ct
let ExtMsgContent content fInv_ _ _ = mcExtMsgContent mc
let ExtMsgContent content _ fInv_ _ _ = mcExtMsgContent mc
-- Uncomment to test stuck delivery on errors - see test testDirectMessageDelete
-- case content of
-- MCText "hello 111" ->
@@ -1548,18 +1551,18 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
-- _ -> pure ()
if isVoice content && not (featureAllowed SCFVoice forContact ct)
then do
void $ newChatItem (CIRcvChatFeatureRejected CFVoice) Nothing Nothing False
void $ newChatItem (ciContentNoParse $ CIRcvChatFeatureRejected CFVoice) Nothing Nothing False
else do
let ExtMsgContent _ _ itemTTL live_ = mcExtMsgContent mc
let ExtMsgContent _ _ _ itemTTL live_ = mcExtMsgContent mc
timed_ = rcvContactCITimed ct itemTTL
live = fromMaybe False live_
file_ <- processFileInvitation fInv_ content $ \db -> createRcvFileTransfer db userId ct
newChatItem (CIRcvMsgContent content) (snd <$> file_) timed_ live
newChatItem (CIRcvMsgContent content, msgContentTexts content) (snd <$> file_) timed_ live
autoAcceptFile file_
where
brokerTs = metaBrokerTs msgMeta
newChatItem ciContent ciFile_ timed_ live = do
ci <- saveRcvChatItem' user (CDDirectRcv ct) msg sharedMsgId_ brokerTs ciContent ciFile_ timed_ live
newChatItem content ciFile_ timed_ live = do
ci <- saveRcvChatItem' user (CDDirectRcv ct) msg sharedMsgId_ brokerTs content ciFile_ timed_ live M.empty
reactions <- maybe (pure []) (\sharedMsgId -> withStore' $ \db -> getDirectCIReactions db ct sharedMsgId) sharedMsgId_
toView $ CRNewChatItems user [AChatItem SCTDirect SMDRcv (DirectChat ct) ci {reactions}]
@@ -1625,7 +1628,8 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
-- received an update from the sender, so that it can be referenced later (e.g. by broadcast delete).
-- Chat item and update message which created it will have different sharedMsgId in this case...
let timed_ = rcvContactCITimed ct ttl
ci <- saveRcvChatItem' user (CDDirectRcv ct) msg (Just sharedMsgId) brokerTs content Nothing timed_ live
ts = ciContentTexts content
ci <- saveRcvChatItem' user (CDDirectRcv ct) msg (Just sharedMsgId) brokerTs (content, ts) Nothing timed_ live M.empty
ci' <- withStore' $ \db -> do
createChatItemVersion db (chatItemId' ci) brokerTs mc
updateDirectChatItem' db user contactId ci content True live Nothing Nothing
@@ -1728,7 +1732,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
newGroupContentMessage :: GroupInfo -> GroupMember -> MsgContainer -> RcvMessage -> UTCTime -> Bool -> CM ()
newGroupContentMessage gInfo m@GroupMember {memberId, memberRole} mc msg@RcvMessage {sharedMsgId_} brokerTs forwarded
| blockedByAdmin m = createBlockedByAdmin
| otherwise = case prohibitedGroupContent gInfo m content fInv_ of
| otherwise = case prohibitedGroupContent gInfo m content ft_ fInv_ of
Just f -> rejected f
Nothing ->
withStore' (\db -> getCIModeration db vr user gInfo memberId sharedMsgId_) >>= \case
@@ -1737,13 +1741,14 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
withStore' $ \db -> deleteCIModeration db gInfo memberId sharedMsgId_
Nothing -> createContentItem
where
rejected f = void $ newChatItem (CIRcvGroupFeatureRejected f) Nothing Nothing False
rejected f = void $ newChatItem (ciContentNoParse $ CIRcvGroupFeatureRejected f) Nothing Nothing False
timed' = if forwarded then rcvCITimed_ (Just Nothing) itemTTL else rcvGroupCITimed gInfo itemTTL
live' = fromMaybe False live_
ExtMsgContent content fInv_ itemTTL live_ = mcExtMsgContent mc
ExtMsgContent content mentions fInv_ itemTTL live_ = mcExtMsgContent mc
ts@(_, ft_) = msgContentTexts content
createBlockedByAdmin
| groupFeatureAllowed SGFFullDelete gInfo = do -- ignores member role when blocked by admin
ci <- saveRcvChatItem' user (CDGroupRcv gInfo m) msg sharedMsgId_ brokerTs CIRcvBlocked Nothing timed' False
ci <- saveRcvChatItem' user (CDGroupRcv gInfo m) msg sharedMsgId_ brokerTs (ciContentNoParse CIRcvBlocked) Nothing timed' False M.empty
ci' <- withStore' $ \db -> updateGroupCIBlockedByAdmin db user gInfo ci brokerTs
groupMsgToView gInfo ci'
| otherwise = do
@@ -1755,7 +1760,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
| moderatorRole < GRModerator || moderatorRole < memberRole =
createContentItem
| groupFeatureMemberAllowed SGFFullDelete moderator gInfo = do
ci <- saveRcvChatItem' user (CDGroupRcv gInfo m) msg sharedMsgId_ brokerTs CIRcvModerated Nothing timed' False
ci <- saveRcvChatItem' user (CDGroupRcv gInfo m) msg sharedMsgId_ brokerTs (ciContentNoParse CIRcvModerated) Nothing timed' False M.empty
ci' <- withStore' $ \db -> updateGroupChatItemModerated db user gInfo ci moderator moderatedAt
groupMsgToView gInfo ci'
| otherwise = do
@@ -1763,22 +1768,23 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
ci <- createNonLive file_
toView =<< markGroupCIsDeleted user gInfo [CChatItem SMDRcv ci] False (Just moderator) moderatedAt
createNonLive file_ =
saveRcvChatItem' user (CDGroupRcv gInfo m) msg sharedMsgId_ brokerTs (CIRcvMsgContent content) (snd <$> file_) timed' False
saveRcvChatItem' user (CDGroupRcv gInfo m) msg sharedMsgId_ brokerTs (CIRcvMsgContent content, ts) (snd <$> file_) timed' False mentions
createContentItem = do
file_ <- processFileInv
newChatItem (CIRcvMsgContent content) (snd <$> file_) timed' live'
newChatItem (CIRcvMsgContent content, ts) (snd <$> file_) timed' live'
when (showMessages $ memberSettings m) $ autoAcceptFile file_
processFileInv =
processFileInvitation fInv_ content $ \db -> createRcvGroupFileTransfer db userId m
newChatItem ciContent ciFile_ timed_ live = do
ci <- saveRcvChatItem' user (CDGroupRcv gInfo m) msg sharedMsgId_ brokerTs ciContent ciFile_ timed_ live
let mentions' = if showMessages (memberSettings m) then mentions else []
ci <- saveRcvChatItem' user (CDGroupRcv gInfo m) msg sharedMsgId_ brokerTs ciContent ciFile_ timed_ live mentions'
ci' <- blockedMember m ci $ withStore' $ \db -> markGroupChatItemBlocked db user gInfo ci
reactions <- maybe (pure []) (\sharedMsgId -> withStore' $ \db -> getGroupCIReactions db gInfo memberId sharedMsgId) sharedMsgId_
groupMsgToView gInfo ci' {reactions}
groupMessageUpdate :: GroupInfo -> GroupMember -> SharedMsgId -> MsgContent -> RcvMessage -> UTCTime -> Maybe Int -> Maybe Bool -> CM ()
groupMessageUpdate gInfo@GroupInfo {groupId} m@GroupMember {groupMemberId, memberId} sharedMsgId mc msg@RcvMessage {msgId} brokerTs ttl_ live_
| prohibitedSimplexLinks gInfo m mc =
groupMessageUpdate :: GroupInfo -> GroupMember -> SharedMsgId -> MsgContent -> Map MemberName MemberMention -> RcvMessage -> UTCTime -> Maybe Int -> Maybe Bool -> CM ()
groupMessageUpdate gInfo@GroupInfo {groupId} m@GroupMember {groupMemberId, memberId} sharedMsgId mc mentions msg@RcvMessage {msgId} brokerTs ttl_ live_
| prohibitedSimplexLinks gInfo m ft_ =
messageWarning $ "x.msg.update ignored: feature not allowed " <> groupFeatureNameText GFSimplexLinks
| otherwise = do
updateRcvChatItem `catchCINotFound` \_ -> do
@@ -1786,7 +1792,8 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
-- received an update from the sender, so that it can be referenced later (e.g. by broadcast delete).
-- Chat item and update message which created it will have different sharedMsgId in this case...
let timed_ = rcvGroupCITimed gInfo ttl_
ci <- saveRcvChatItem' user (CDGroupRcv gInfo m) msg (Just sharedMsgId) brokerTs content Nothing timed_ live
mentions' = if showMessages (memberSettings m) then mentions else []
ci <- saveRcvChatItem' user (CDGroupRcv gInfo m) msg (Just sharedMsgId) brokerTs (content, ts) Nothing timed_ live mentions'
ci' <- withStore' $ \db -> do
createChatItemVersion db (chatItemId' ci) brokerTs mc
ci' <- updateGroupChatItem db user groupId ci content True live Nothing
@@ -1794,6 +1801,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
toView $ CRChatItemUpdated user (AChatItem SCTGroup SMDRcv (GroupChat gInfo) ci')
where
content = CIRcvMsgContent mc
ts@(_, ft_) = msgContentTexts mc
live = fromMaybe False live_
updateRcvChatItem = do
cci <- withStore $ \db -> getGroupChatItemBySharedMsgId db user groupId groupMemberId sharedMsgId
@@ -1809,7 +1817,9 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
addInitialAndNewCIVersions db (chatItemId' ci) (chatItemTs' ci, oldMC) (brokerTs, mc)
reactions <- getGroupCIReactions db gInfo memberId sharedMsgId
let edited = itemLive /= Just True
updateGroupChatItem db user groupId ci {reactions} content edited live $ Just msgId
mentionedMembers <- getRcvMentionedMembers db user gInfo ft_ mentions
ci' <- updateGroupChatItem db user groupId ci {reactions} content edited live $ Just msgId
updateGroupCIMentions db gInfo ci' mentionedMembers
toView $ CRChatItemUpdated user (AChatItem SCTGroup SMDRcv (GroupChat gInfo) ci')
startUpdatedTimedItemThread user (ChatRef CTGroup groupId) ci ci'
else toView $ CRChatItemNotChanged user (AChatItem SCTGroup SMDRcv (GroupChat gInfo) ci)
@@ -1870,7 +1880,8 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
RcvFileTransfer {fileId, xftpRcvFile} <- withStore $ \db -> createRcvFileTransfer db userId ct fInv inline fileChunkSize
let fileProtocol = if isJust xftpRcvFile then FPXFTP else FPSMP
ciFile = Just $ CIFile {fileId, fileName, fileSize, fileSource = Nothing, fileStatus = CIFSRcvInvitation, fileProtocol}
ci <- saveRcvChatItem' user (CDDirectRcv ct) msg sharedMsgId_ brokerTs (CIRcvMsgContent $ MCFile "") ciFile Nothing False
content = ciContentNoParse $ CIRcvMsgContent $ MCFile ""
ci <- saveRcvChatItem' user (CDDirectRcv ct) msg sharedMsgId_ brokerTs content ciFile Nothing False M.empty
toView $ CRNewChatItems user [AChatItem SCTDirect SMDRcv (DirectChat ct) ci]
where
brokerTs = metaBrokerTs msgMeta
@@ -1883,7 +1894,8 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
RcvFileTransfer {fileId, xftpRcvFile} <- withStore $ \db -> createRcvGroupFileTransfer db userId m fInv inline fileChunkSize
let fileProtocol = if isJust xftpRcvFile then FPXFTP else FPSMP
ciFile = Just $ CIFile {fileId, fileName, fileSize, fileSource = Nothing, fileStatus = CIFSRcvInvitation, fileProtocol}
ci <- saveRcvChatItem' user (CDGroupRcv gInfo m) msg sharedMsgId_ brokerTs (CIRcvMsgContent $ MCFile "") ciFile Nothing False
content = ciContentNoParse $ CIRcvMsgContent $ MCFile ""
ci <- saveRcvChatItem' user (CDGroupRcv gInfo m) msg sharedMsgId_ brokerTs content ciFile Nothing False M.empty
ci' <- blockedMember m ci $ withStore' $ \db -> markGroupChatItemBlocked db user gInfo ci
groupMsgToView gInfo ci'
@@ -2063,7 +2075,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
toView $ CRUserAcceptedGroupSent user gInfo {membership = membership {memberStatus = GSMemAccepted}} (Just ct)
else do
let content = CIRcvGroupInvitation (CIGroupInvitation {groupId, groupMemberId, localDisplayName, groupProfile, status = CIGISPending}) memRole
ci <- saveRcvChatItem user (CDDirectRcv ct) msg brokerTs content
ci <- saveRcvChatItemNoParse user (CDDirectRcv ct) msg brokerTs content
withStore' $ \db -> setGroupInvitationChatItemId db user groupId (chatItemId' ci)
toView $ CRNewChatItems user [AChatItem SCTDirect SMDRcv (DirectChat ct) ci]
toView $ CRReceivedGroupInvitation {user, groupInfo = gInfo, contact = ct, fromMemberRole = fromRole, memberRole = memRole}
@@ -2091,7 +2103,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
forM_ contactConns $ \conn -> withStore' $ \db -> updateConnectionStatus db conn ConnDeleted
activeConn' <- forM (contactConn ct') $ \conn -> pure conn {connStatus = ConnDeleted}
let ct'' = ct' {activeConn = activeConn'} :: Contact
ci <- saveRcvChatItem user (CDDirectRcv ct'') msg brokerTs (CIRcvDirectEvent RDEContactDeleted)
ci <- saveRcvChatItemNoParse user (CDDirectRcv ct'') msg brokerTs (CIRcvDirectEvent RDEContactDeleted)
toView $ CRNewChatItems user [AChatItem SCTDirect SMDRcv (DirectChat ct'') ci]
toView $ CRContactDeletedByContact user ct''
else do
@@ -2300,9 +2312,10 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
else featureRejected CFCalls
where
brokerTs = metaBrokerTs msgMeta
saveCallItem status = saveRcvChatItem user (CDDirectRcv ct) msg brokerTs (CIRcvCall status 0)
saveCallItem status = saveRcvChatItemNoParse user (CDDirectRcv ct) msg brokerTs (CIRcvCall status 0)
featureRejected f = do
ci <- saveRcvChatItem' user (CDDirectRcv ct) msg sharedMsgId_ brokerTs (CIRcvChatFeatureRejected f) Nothing Nothing False
let content = ciContentNoParse $ CIRcvChatFeatureRejected f
ci <- saveRcvChatItem' user (CDDirectRcv ct) msg sharedMsgId_ brokerTs content Nothing Nothing False M.empty
toView $ CRNewChatItems user [AChatItem SCTDirect SMDRcv (DirectChat ct) ci]
-- to party initiating call
@@ -2480,7 +2493,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
where
memberAnnouncedToView announcedMember@GroupMember {groupMemberId, memberProfile} = do
let event = RGEMemberAdded groupMemberId (fromLocalProfile memberProfile)
ci <- saveRcvChatItem user (CDGroupRcv gInfo m) msg brokerTs (CIRcvGroupEvent event)
ci <- saveRcvChatItemNoParse user (CDGroupRcv gInfo m) msg brokerTs (CIRcvGroupEvent event)
groupMsgToView gInfo ci
toView $ CRJoinedGroupMemberConnecting user gInfo m announcedMember
@@ -2567,7 +2580,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
| senderRole < GRAdmin || senderRole < fromRole = messageError "x.grp.mem.role with insufficient member permissions"
| otherwise = do
withStore' $ \db -> updateGroupMemberRole db user member memRole
ci <- saveRcvChatItem user (CDGroupRcv gInfo m) msg brokerTs (CIRcvGroupEvent gEvent)
ci <- saveRcvChatItemNoParse user (CDGroupRcv gInfo m) msg brokerTs (CIRcvGroupEvent gEvent)
groupMsgToView gInfo ci
toView CRMemberRole {user, groupInfo = gInfo', byMember = m, member = member {memberRole = memRole}, fromRole, toRole = memRole}
@@ -2594,7 +2607,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
bm' <- setMemberBlocked bmId
toggleNtf user bm' (not blocked)
let ciContent = CIRcvGroupEvent $ RGEMemberBlocked bmId (fromLocalProfile bmp) blocked
ci <- saveRcvChatItem user (CDGroupRcv gInfo m) msg brokerTs ciContent
ci <- saveRcvChatItemNoParse user (CDGroupRcv gInfo m) msg brokerTs ciContent
groupMsgToView gInfo ci
toView CRMemberBlockedForAll {user, groupInfo = gInfo, byMember = m, member = bm, blocked}
Left (SEGroupMemberNotFoundByMemberId _) -> do
@@ -2679,7 +2692,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
messageError "x.grp.mem.del with insufficient member permissions"
| otherwise = a
deleteMemberItem gEvent = do
ci <- saveRcvChatItem user (CDGroupRcv gInfo m) msg brokerTs (CIRcvGroupEvent gEvent)
ci <- saveRcvChatItemNoParse user (CDGroupRcv gInfo m) msg brokerTs (CIRcvGroupEvent gEvent)
groupMsgToView gInfo ci
xGrpLeave :: GroupInfo -> GroupMember -> RcvMessage -> UTCTime -> CM ()
@@ -2687,7 +2700,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
deleteMemberConnection user m
-- member record is not deleted to allow creation of "member left" chat item
withStore' $ \db -> updateGroupMemberStatus db userId m GSMemLeft
ci <- saveRcvChatItem user (CDGroupRcv gInfo m) msg brokerTs (CIRcvGroupEvent RGEMemberLeft)
ci <- saveRcvChatItemNoParse user (CDGroupRcv gInfo m) msg brokerTs (CIRcvGroupEvent RGEMemberLeft)
groupMsgToView gInfo ci
toView $ CRLeftMember user gInfo m {memberStatus = GSMemLeft}
@@ -2700,7 +2713,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
pure members
-- member records are not deleted to keep history
deleteMembersConnections user ms
ci <- saveRcvChatItem user (CDGroupRcv gInfo m) msg brokerTs (CIRcvGroupEvent RGEGroupDeleted)
ci <- saveRcvChatItemNoParse user (CDGroupRcv gInfo m) msg brokerTs (CIRcvGroupEvent RGEGroupDeleted)
groupMsgToView gInfo ci
toView $ CRGroupDeleted user gInfo {membership = membership {memberStatus = GSMemGroupDeleted}} m
@@ -2713,7 +2726,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
toView $ CRGroupUpdated user g g' (Just m)
let cd = CDGroupRcv g' m
unless (sameGroupProfileInfo p p') $ do
ci <- saveRcvChatItem user cd msg brokerTs (CIRcvGroupEvent $ RGEGroupUpdated p')
ci <- saveRcvChatItemNoParse user cd msg brokerTs (CIRcvGroupEvent $ RGEGroupUpdated p')
groupMsgToView g' ci
createGroupFeatureChangedItems user cd CIRcvGroupFeature g g'
Just _ -> updateGroupPrefs_ g m $ fromMaybe defaultBusinessGroupPrefs $ groupPreferences p'
@@ -2772,7 +2785,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
createInternalChatItem user (CDGroupRcv g m') (CIRcvGroupEvent RGEMemberCreatedContact) Nothing
toView $ CRNewMemberContactReceivedInv user mCt' g m'
forM_ mContent_ $ \mc -> do
ci <- saveRcvChatItem user (CDDirectRcv mCt') msg brokerTs (CIRcvMsgContent mc)
ci <- saveRcvChatItem user (CDDirectRcv mCt') msg brokerTs (CIRcvMsgContent mc, msgContentTexts mc)
toView $ CRNewChatItems user [AChatItem SCTDirect SMDRcv (DirectChat mCt') ci]
securityCodeChanged :: Contact -> CM ()
@@ -2799,7 +2812,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
case event of
XMsgNew mc -> memberCanSend author $ newGroupContentMessage gInfo author mc rcvMsg msgTs True
XMsgFileDescr sharedMsgId fileDescr -> memberCanSend author $ groupMessageFileDescription gInfo author sharedMsgId fileDescr
XMsgUpdate sharedMsgId mContent ttl live -> memberCanSend author $ groupMessageUpdate gInfo author sharedMsgId mContent rcvMsg msgTs ttl live
XMsgUpdate sharedMsgId mContent mentions ttl live -> memberCanSend author $ groupMessageUpdate gInfo author sharedMsgId mContent mentions rcvMsg msgTs ttl live
XMsgDel sharedMsgId memId -> groupMessageDelete gInfo author sharedMsgId memId rcvMsg msgTs
XMsgReact sharedMsgId (Just memId) reaction add -> groupMsgReaction gInfo author sharedMsgId memId reaction add rcvMsg msgTs
XFileCancel sharedMsgId -> xFileCancelGroup gInfo author sharedMsgId
src/Simplex/Chat/Markdown.hs
+26 -1
View File
@@ -22,7 +22,7 @@ import Data.Functor (($>))
import Data.List (foldl', intercalate)
import Data.List.NonEmpty (NonEmpty)
import qualified Data.List.NonEmpty as L
import Data.Maybe (fromMaybe, isNothing)
import Data.Maybe (fromMaybe, isNothing, mapMaybe)
import Data.Semigroup (sconcat)
import Data.String
import Data.Text (Text)
@@ -50,18 +50,28 @@ data Format
| Colored {color :: FormatColor}
| Uri
| SimplexLink {linkType :: SimplexLinkType, simplexUri :: Text, smpHosts :: NonEmpty Text}
| Mention {memberName :: Text}
| Email
| Phone
deriving (Eq, Show)
mentionedNames :: MarkdownList -> [Text]
mentionedNames = mapMaybe (\(FormattedText f _) -> mentionedName =<< f)
where
mentionedName = \case
Mention name -> Just name
_ -> Nothing
data SimplexLinkType = XLContact | XLInvitation | XLGroup
deriving (Eq, Show)
colored :: Color -> Format
colored = Colored . FormatColor
{-# INLINE colored #-}
markdown :: Format -> Text -> Markdown
markdown = Markdown . Just
{-# INLINE markdown #-}
instance Semigroup Markdown where
m <> (Markdown _ "") = m
@@ -163,6 +173,7 @@ markdownP = mconcat <$> A.many' fragmentP
'`' -> formattedP '`' Snippet
'#' -> A.char '#' *> secretP
'!' -> coloredP <|> wordP
'@' -> mentionP
_
| isDigit c -> phoneP <|> wordP
| otherwise -> wordP
@@ -192,6 +203,11 @@ markdownP = mconcat <$> A.many' fragmentP
if T.null s || T.last s == ' '
then fail "not colored"
else pure $ markdown (colored clr) s
mentionP = do
c <- A.char '@' *> A.peekChar'
name <- displayNameTextP
let sName = if c == '\'' then '\'' `T.cons` name `T.snoc` '\'' else name
pure $ markdown (Mention name) ('@' `T.cons` sName)
colorP =
A.anyChar >>= \case
'r' -> "ed" $> Red <|> pure Red
@@ -251,6 +267,15 @@ markdownP = mconcat <$> A.many' fragmentP
Just (CRDataGroup _) -> XLGroup
Nothing -> XLContact
displayNameTextP :: Parser Text
displayNameTextP = quoted '\'' <|> takeNameTill (== ' ')
where
takeNameTill p =
A.peekChar' >>= \c ->
if refChar c then A.takeTill p else fail "invalid first character in display name"
quoted c = A.char c *> takeNameTill (== c) <* A.char c
refChar c = c > ' ' && c /= '#' && c /= '@' && c /= '\''
$(JQ.deriveJSON (enumJSON $ dropPrefix "XL") ''SimplexLinkType)
$(JQ.deriveJSON (sumTypeJSON fstToLower) ''Format)
src/Simplex/Chat/Messages.hs
+34 -17
View File
@@ -31,6 +31,7 @@ import Data.Char (isSpace)
import Data.Int (Int64)
import Data.Kind (Constraint)
import Data.List.NonEmpty (NonEmpty)
import Data.Map.Strict (Map)
import Data.Maybe (fromMaybe, isJust, isNothing)
import Data.Text (Text)
import qualified Data.Text as T
@@ -46,6 +47,7 @@ import Simplex.Chat.Options.DB (FromField (..), ToField (..))
import Simplex.Chat.Protocol
import Simplex.Chat.Types
import Simplex.Chat.Types.Preferences
import Simplex.Chat.Types.Shared
import Simplex.Chat.Types.Util (textParseJSON)
import Simplex.Messaging.Agent.Protocol (AgentMsgId, MsgMeta (..), MsgReceiptStatus (..))
import Simplex.Messaging.Crypto.File (CryptoFile (..))
@@ -150,6 +152,9 @@ data ChatItem (c :: ChatType) (d :: MsgDirection) = ChatItem
{ chatDir :: CIDirection c d,
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,
formattedText :: Maybe MarkdownList,
quotedItem :: Maybe (CIQuote c),
reactions :: [CIReactionCount],
@@ -157,18 +162,24 @@ data ChatItem (c :: ChatType) (d :: MsgDirection) = ChatItem
}
deriving (Show)
isMention :: ChatItem c d -> Bool
isMention ChatItem {chatDir, quotedItem} = case chatDir of
CIDirectRcv -> userItem quotedItem
CIGroupRcv _ -> userItem quotedItem
_ -> False
where
userItem = \case
Nothing -> False
Just CIQuote {chatDir = cd} -> case cd of
CIQDirectSnd -> True
CIQGroupSnd -> True
_ -> False
data MentionedMember = MentionedMember
{ 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
}
deriving (Eq, Show)
data MentionedMemberInfo = MentionedMemberInfo
{ groupMemberId :: GroupMemberId,
displayName :: Text, -- use `displayName` in copy/share actions
localAlias :: Maybe Text, -- use `fromMaybe displayName localAlias` in chat view
memberRole :: GroupMemberRole -- shown for admins/owners in the message
}
deriving (Eq, Show)
isUserMention :: ChatItem c d -> Bool
isUserMention ChatItem {meta = CIMeta {userMention}} = userMention
data CIDirection (c :: ChatType) (d :: MsgDirection) where
CIDirectSnd :: CIDirection 'CTDirect 'MDSnd
@@ -364,6 +375,7 @@ data CIMeta (c :: ChatType) (d :: MsgDirection) = CIMeta
itemEdited :: Bool,
itemTimed :: Maybe CITimed,
itemLive :: Maybe Bool,
userMention :: Bool, -- True for messages that mention user or reply to user messages
deletable :: Bool,
editable :: Bool,
forwardedByMember :: Maybe GroupMemberId,
@@ -372,11 +384,11 @@ data CIMeta (c :: ChatType) (d :: MsgDirection) = CIMeta
}
deriving (Show)
mkCIMeta :: forall c d. ChatTypeI c => ChatItemId -> CIContent d -> Text -> CIStatus d -> Maybe Bool -> Maybe SharedMsgId -> Maybe CIForwardedFrom -> Maybe (CIDeleted c) -> Bool -> Maybe CITimed -> Maybe Bool -> UTCTime -> ChatItemTs -> Maybe GroupMemberId -> UTCTime -> UTCTime -> CIMeta c d
mkCIMeta itemId itemContent itemText itemStatus sentViaProxy itemSharedMsgId itemForwarded itemDeleted itemEdited itemTimed itemLive currentTs itemTs forwardedByMember createdAt updatedAt =
mkCIMeta :: forall c d. ChatTypeI c => ChatItemId -> CIContent d -> Text -> CIStatus d -> Maybe Bool -> Maybe SharedMsgId -> Maybe CIForwardedFrom -> Maybe (CIDeleted c) -> Bool -> Maybe CITimed -> Maybe Bool -> Bool -> UTCTime -> ChatItemTs -> Maybe GroupMemberId -> UTCTime -> UTCTime -> CIMeta c d
mkCIMeta itemId itemContent itemText itemStatus sentViaProxy itemSharedMsgId itemForwarded itemDeleted itemEdited itemTimed itemLive userMention currentTs itemTs forwardedByMember createdAt updatedAt =
let deletable = deletable' itemContent itemDeleted itemTs nominalDay currentTs
editable = deletable && isNothing itemForwarded
in CIMeta {itemId, itemTs, itemText, itemStatus, sentViaProxy, itemSharedMsgId, itemForwarded, itemDeleted, itemEdited, itemTimed, itemLive, deletable, editable, forwardedByMember, createdAt, updatedAt}
in CIMeta {itemId, itemTs, itemText, itemStatus, sentViaProxy, itemSharedMsgId, itemForwarded, itemDeleted, itemEdited, itemTimed, itemLive, userMention, deletable, editable, forwardedByMember, createdAt, updatedAt}
deletable' :: forall c d. ChatTypeI c => CIContent d -> Maybe (CIDeleted c) -> UTCTime -> NominalDiffTime -> UTCTime -> Bool
deletable' itemContent itemDeleted itemTs allowedInterval currentTs =
@@ -401,6 +413,7 @@ dummyMeta itemId ts itemText =
itemEdited = False,
itemTimed = Nothing,
itemLive = Nothing,
userMention = False,
deletable = False,
editable = False,
forwardedByMember = Nothing,
@@ -1247,14 +1260,14 @@ data ChatItemVersion = ChatItemVersion
deriving (Eq, Show)
mkItemVersion :: ChatItem c d -> Maybe ChatItemVersion
mkItemVersion ChatItem {content, meta} = version <$> ciMsgContent content
mkItemVersion ChatItem {content, formattedText, meta} = version <$> ciMsgContent content
where
CIMeta {itemId, itemTs, createdAt} = meta
version mc =
ChatItemVersion
{ chatItemVersionId = itemId,
msgContent = mc,
formattedText = parseMaybeMarkdownList $ msgContentText mc,
formattedText,
itemVersionTs = itemTs,
createdAt = createdAt
}
@@ -1387,6 +1400,10 @@ $(JQ.deriveToJSON defaultJSON ''CIQuote)
$(JQ.deriveJSON defaultJSON ''CIReactionCount)
$(JQ.deriveJSON defaultJSON ''MentionedMemberInfo)
$(JQ.deriveJSON defaultJSON ''MentionedMember)
instance (ChatTypeI c, MsgDirectionI d) => FromJSON (ChatItem c d) where
parseJSON = $(JQ.mkParseJSON defaultJSON ''ChatItem)
src/Simplex/Chat/Protocol.hs
+39 -7
View File
@@ -35,6 +35,8 @@ import Data.ByteString.Internal (c2w, w2c)
import qualified Data.ByteString.Lazy.Char8 as LB
import Data.List.NonEmpty (NonEmpty (..))
import qualified Data.List.NonEmpty as L
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as M
import Data.Maybe (fromMaybe, mapMaybe)
import Data.String
import Data.Text (Text)
@@ -310,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, ttl :: Maybe Int, live :: Maybe Bool} -> ChatMsgEvent 'Json
XMsgUpdate :: {msgId :: SharedMsgId, content :: MsgContent, mentions :: Map MemberName MemberMention, ttl :: Maybe Int, live :: Maybe Bool} -> ChatMsgEvent 'Json
XMsgDel :: SharedMsgId -> Maybe MemberId -> ChatMsgEvent 'Json
XMsgDeleted :: ChatMsgEvent 'Json
XMsgReact :: {msgId :: SharedMsgId, memberId :: Maybe MemberId, reaction :: MsgReaction, add :: Bool} -> ChatMsgEvent 'Json
@@ -531,6 +533,11 @@ mcExtMsgContent = \case
MCComment _ c -> c
MCForward c -> c
isMCForward :: MsgContainer -> Bool
isMCForward = \case
MCForward _ -> True
_ -> False
data MsgContent
= MCText Text
| MCLink {text :: Text, preview :: LinkPreview}
@@ -589,9 +596,23 @@ msgContentTag = \case
MCReport {} -> MCReport_
MCUnknown {tag} -> MCUnknown_ tag
data ExtMsgContent = ExtMsgContent {content :: MsgContent, file :: Maybe FileInvitation, ttl :: Maybe Int, live :: Maybe Bool}
data ExtMsgContent = ExtMsgContent
{ content :: MsgContent,
-- the key used in mentions is a locally (per message) unique display name of member.
-- Suffixes _1, _2 should be appended to make names locally unique.
-- It should be done in the UI, as they will be part of the text, and validated in the API.
mentions :: Map MemberName MemberMention,
file :: Maybe FileInvitation,
ttl :: Maybe Int,
live :: Maybe Bool
}
deriving (Eq, Show)
data MemberMention = MemberMention {memberId :: MemberId}
deriving (Eq, Show)
$(JQ.deriveJSON defaultJSON ''MemberMention)
$(JQ.deriveJSON defaultJSON ''QuotedMsg)
-- this limit reserves space for metadata in forwarded messages
@@ -657,10 +678,16 @@ parseMsgContainer v =
<|> (MCForward <$> ((v .: "forward" :: JT.Parser J.Object) *> mc))
<|> MCSimple <$> mc
where
mc = ExtMsgContent <$> v .: "content" <*> v .:? "file" <*> v .:? "ttl" <*> v .:? "live"
mc = do
content <- v .: "content"
file <- v .:? "file"
ttl <- v .:? "ttl"
live <- v .:? "live"
mentions <- fromMaybe M.empty <$> (v .:? "mentions")
pure ExtMsgContent {content, mentions, file, ttl, live}
extMsgContent :: MsgContent -> Maybe FileInvitation -> ExtMsgContent
extMsgContent mc file = ExtMsgContent mc file Nothing Nothing
extMsgContent mc file = ExtMsgContent mc M.empty file Nothing Nothing
justTrue :: Bool -> Maybe Bool
justTrue True = Just True
@@ -709,7 +736,12 @@ msgContainerJSON = \case
MCSimple mc -> o $ msgContent mc
where
o = JM.fromList
msgContent (ExtMsgContent c file ttl live) = ("file" .=? file) $ ("ttl" .=? ttl) $ ("live" .=? live) ["content" .= c]
msgContent ExtMsgContent {content, mentions, file, ttl, live} =
("file" .=? file) $ ("ttl" .=? ttl) $ ("live" .=? live) $ ("mentions" .=? nonEmptyMap mentions) ["content" .= content]
nonEmptyMap :: Map k v -> Maybe (Map k v)
nonEmptyMap m = if M.null m then Nothing else Just m
{-# INLINE nonEmptyMap #-}
instance ToJSON MsgContent where
toJSON = \case
@@ -994,7 +1026,7 @@ appJsonToCM AppMessageJson {v, msgId, event, params} = do
msg = \case
XMsgNew_ -> XMsgNew <$> JT.parseEither parseMsgContainer params
XMsgFileDescr_ -> XMsgFileDescr <$> p "msgId" <*> p "fileDescr"
XMsgUpdate_ -> XMsgUpdate <$> p "msgId" <*> p "content" <*> opt "ttl" <*> opt "live"
XMsgUpdate_ -> XMsgUpdate <$> p "msgId" <*> p "content" <*> (fromMaybe M.empty <$> opt "mentions") <*> opt "ttl" <*> opt "live"
XMsgDel_ -> XMsgDel <$> p "msgId" <*> opt "memberId"
XMsgDeleted_ -> pure XMsgDeleted
XMsgReact_ -> XMsgReact <$> p "msgId" <*> opt "memberId" <*> p "reaction" <*> p "add"
@@ -1056,7 +1088,7 @@ chatToAppMessage ChatMessage {chatVRange, msgId, chatMsgEvent} = case encoding @
params = \case
XMsgNew container -> msgContainerJSON container
XMsgFileDescr msgId' fileDescr -> o ["msgId" .= msgId', "fileDescr" .= fileDescr]
XMsgUpdate msgId' content ttl live -> o $ ("ttl" .=? ttl) $ ("live" .=? live) ["msgId" .= msgId', "content" .= content]
XMsgUpdate msgId' content mentions ttl live -> o $ ("ttl" .=? ttl) $ ("live" .=? live) $ ("mentions" .=? nonEmptyMap mentions) ["msgId" .= msgId', "content" .= content]
XMsgDel msgId' memberId -> o $ ("memberId" .=? memberId) ["msgId" .= msgId']
XMsgDeleted -> JM.empty
XMsgReact msgId' memberId reaction add -> o $ ("memberId" .=? memberId) ["msgId" .= msgId', "reaction" .= reaction, "add" .= add]
src/Simplex/Chat/Store/Groups.hs
+34 -1
View File
@@ -47,6 +47,8 @@ module Simplex.Chat.Store.Groups
getActiveMembersByName,
getGroupInfoByName,
getGroupMember,
getMentionedGroupMember,
getMentionedMemberByMemberId,
getGroupMemberById,
getGroupMemberByMemberId,
getGroupMembers,
@@ -148,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 (groupForwardVersion)
import Simplex.Chat.Protocol (MemberMention (..), groupForwardVersion)
import Simplex.Chat.Store.Direct
import Simplex.Chat.Store.Shared
import Simplex.Chat.Types
@@ -798,6 +800,37 @@ getGroupMember db vr user@User {userId} groupId groupMemberId =
(groupMemberQuery <> " WHERE m.group_id = ? AND m.group_member_id = ? AND m.user_id = ?")
(userId, groupId, groupMemberId, userId)
getMentionedGroupMember :: DB.Connection -> User -> GroupId -> GroupMemberId -> ExceptT StoreError IO MentionedMember
getMentionedGroupMember db User {userId} groupId gmId =
ExceptT $ firstRow toMentionedMember (SEGroupMemberNotFound gmId) $
DB.query
db
(mentionedMemberQuery <> " WHERE m.group_id = ? AND m.group_member_id = ? AND m.user_id = ?")
(groupId, gmId, userId)
getMentionedMemberByMemberId :: DB.Connection -> User -> GroupId -> MemberMention -> IO MentionedMember
getMentionedMemberByMemberId db User {userId} groupId MemberMention {memberId} =
fmap (fromMaybe mentionedMember) $ maybeFirstRow toMentionedMember $
DB.query
db
(mentionedMemberQuery <> " WHERE m.group_id = ? AND m.member_id = ? AND m.user_id = ?")
(groupId, memberId, userId)
where
mentionedMember = MentionedMember {memberId, memberRef = Nothing}
mentionedMemberQuery :: Query
mentionedMemberQuery =
[sql|
SELECT m.group_member_id, m.member_id, m.member_role, p.display_name, p.local_alias
FROM group_members m
JOIN contact_profiles p ON p.contact_profile_id = COALESCE(m.member_profile_id, m.contact_profile_id)
|]
toMentionedMember :: (GroupMemberId, MemberId, GroupMemberRole, Text, Maybe Text) -> MentionedMember
toMentionedMember (groupMemberId, memberId, memberRole, displayName, localAlias) =
let memberRef = Just MentionedMemberInfo {groupMemberId, displayName, localAlias, memberRole}
in MentionedMember {memberId, memberRef}
getGroupMemberById :: DB.Connection -> VersionRangeChat -> User -> GroupMemberId -> ExceptT StoreError IO GroupMember
getGroupMemberById db vr user@User {userId} groupMemberId =
ExceptT . firstRow (toContactMember vr user) (SEGroupMemberNotFound groupMemberId) $
src/Simplex/Chat/Store/Messages.hs
+82 -31
View File
@@ -53,6 +53,8 @@ module Simplex.Chat.Store.Messages
markDirectChatItemDeleted,
updateGroupChatItemStatus,
updateGroupChatItem,
createGroupCIMentions,
updateGroupCIMentions,
deleteGroupChatItem,
updateGroupChatItemModerated,
updateGroupCIBlockedByAdmin,
@@ -136,6 +138,8 @@ import Data.Int (Int64)
import Data.List (sortBy)
import Data.List.NonEmpty (NonEmpty)
import qualified Data.List.NonEmpty as L
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as M
import Data.Maybe (catMaybes, fromMaybe, isJust, mapMaybe)
import Data.Ord (Down (..), comparing)
import Data.Text (Text)
@@ -152,6 +156,7 @@ import Simplex.Chat.Store.Groups
import Simplex.Chat.Store.NoteFolders
import Simplex.Chat.Store.Shared
import Simplex.Chat.Types
import Simplex.Chat.Types.Shared
import Simplex.Messaging.Agent.Protocol (AgentMsgId, ConnId, MsgMeta (..), UserId)
import Simplex.Messaging.Agent.Store.AgentStore (firstRow, firstRow', maybeFirstRow)
import Simplex.Messaging.Agent.Store.DB (BoolInt (..))
@@ -367,7 +372,7 @@ updateChatTs db User {userId} chatDirection chatTs = case toChatInfo chatDirecti
createNewSndChatItem :: DB.Connection -> User -> ChatDirection c 'MDSnd -> SndMessage -> CIContent 'MDSnd -> Maybe (CIQuote c) -> Maybe CIForwardedFrom -> Maybe CITimed -> Bool -> UTCTime -> IO ChatItemId
createNewSndChatItem db user chatDirection SndMessage {msgId, sharedMsgId} ciContent quotedItem itemForwarded timed live createdAt =
createNewChatItem_ db user chatDirection createdByMsgId (Just sharedMsgId) ciContent quoteRow itemForwarded timed live createdAt Nothing createdAt
createNewChatItem_ db user chatDirection createdByMsgId (Just sharedMsgId) ciContent quoteRow itemForwarded timed live False createdAt Nothing createdAt
where
createdByMsgId = if msgId == 0 then Nothing else Just msgId
quoteRow :: NewQuoteRow
@@ -381,9 +386,9 @@ createNewSndChatItem db user chatDirection SndMessage {msgId, sharedMsgId} ciCon
CIQGroupRcv (Just GroupMember {memberId}) -> (Just False, Just memberId)
CIQGroupRcv Nothing -> (Just False, Nothing)
createNewRcvChatItem :: ChatTypeQuotable c => DB.Connection -> User -> ChatDirection c 'MDRcv -> RcvMessage -> Maybe SharedMsgId -> CIContent 'MDRcv -> Maybe CITimed -> Bool -> UTCTime -> UTCTime -> IO (ChatItemId, Maybe (CIQuote c), Maybe CIForwardedFrom)
createNewRcvChatItem db user chatDirection RcvMessage {msgId, chatMsgEvent, forwardedByMember} sharedMsgId_ ciContent timed live itemTs createdAt = do
ciId <- createNewChatItem_ db user chatDirection (Just msgId) sharedMsgId_ ciContent quoteRow itemForwarded timed live itemTs forwardedByMember createdAt
createNewRcvChatItem :: ChatTypeQuotable c => DB.Connection -> User -> ChatDirection c 'MDRcv -> RcvMessage -> Maybe SharedMsgId -> CIContent 'MDRcv -> Maybe CITimed -> Bool -> Bool -> UTCTime -> UTCTime -> IO (ChatItemId, Maybe (CIQuote c), Maybe CIForwardedFrom)
createNewRcvChatItem db user chatDirection RcvMessage {msgId, chatMsgEvent, forwardedByMember} sharedMsgId_ ciContent timed live userMention itemTs createdAt = do
ciId <- createNewChatItem_ db user chatDirection (Just msgId) sharedMsgId_ ciContent quoteRow itemForwarded timed live userMention itemTs forwardedByMember createdAt
quotedItem <- mapM (getChatItemQuote_ db user chatDirection) quotedMsg
pure (ciId, quotedItem, itemForwarded)
where
@@ -400,13 +405,13 @@ createNewRcvChatItem db user chatDirection RcvMessage {msgId, chatMsgEvent, forw
createNewChatItemNoMsg :: forall c d. MsgDirectionI d => DB.Connection -> User -> ChatDirection c d -> CIContent d -> UTCTime -> UTCTime -> IO ChatItemId
createNewChatItemNoMsg db user chatDirection ciContent itemTs =
createNewChatItem_ db user chatDirection Nothing Nothing ciContent quoteRow Nothing Nothing False itemTs Nothing
createNewChatItem_ db user chatDirection Nothing Nothing ciContent quoteRow Nothing Nothing False False itemTs Nothing
where
quoteRow :: NewQuoteRow
quoteRow = (Nothing, Nothing, Nothing, Nothing, Nothing)
createNewChatItem_ :: forall c d. MsgDirectionI d => DB.Connection -> User -> ChatDirection c d -> Maybe MessageId -> Maybe SharedMsgId -> CIContent d -> NewQuoteRow -> Maybe CIForwardedFrom -> Maybe CITimed -> Bool -> UTCTime -> Maybe GroupMemberId -> UTCTime -> IO ChatItemId
createNewChatItem_ db User {userId} chatDirection msgId_ sharedMsgId ciContent quoteRow itemForwarded timed live itemTs forwardedByMember createdAt = do
createNewChatItem_ :: forall c d. MsgDirectionI d => DB.Connection -> User -> ChatDirection c d -> Maybe MessageId -> Maybe SharedMsgId -> CIContent d -> NewQuoteRow -> Maybe CIForwardedFrom -> Maybe CITimed -> Bool -> Bool -> UTCTime -> Maybe GroupMemberId -> UTCTime -> IO ChatItemId
createNewChatItem_ db User {userId} chatDirection msgId_ sharedMsgId ciContent quoteRow itemForwarded timed live userMention itemTs forwardedByMember createdAt = do
DB.execute
db
[sql|
@@ -415,20 +420,20 @@ createNewChatItem_ db User {userId} chatDirection msgId_ sharedMsgId ciContent q
user_id, created_by_msg_id, contact_id, group_id, group_member_id, note_folder_id,
-- meta
item_sent, item_ts, item_content, item_content_tag, item_text, item_status, msg_content_tag, shared_msg_id,
forwarded_by_group_member_id, include_in_history, created_at, updated_at, item_live, timed_ttl, timed_delete_at,
forwarded_by_group_member_id, include_in_history, created_at, updated_at, item_live, user_mention, timed_ttl, timed_delete_at,
-- quote
quoted_shared_msg_id, quoted_sent_at, quoted_content, quoted_sent, quoted_member_id,
-- forwarded from
fwd_from_tag, fwd_from_chat_name, fwd_from_msg_dir, fwd_from_contact_id, fwd_from_group_id, fwd_from_chat_item_id
) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?)
) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?)
|]
((userId, msgId_) :. idsRow :. itemRow :. quoteRow' :. forwardedFromRow)
ciId <- insertedRowId db
forM_ msgId_ $ \msgId -> insertChatItemMessage_ db ciId msgId createdAt
pure ciId
where
itemRow :: (SMsgDirection d, UTCTime, CIContent d, Text, Text, CIStatus d, Maybe MsgContentTag, Maybe SharedMsgId, Maybe GroupMemberId, BoolInt) :. (UTCTime, UTCTime, Maybe BoolInt) :. (Maybe Int, Maybe UTCTime)
itemRow = (msgDirection @d, itemTs, ciContent, toCIContentTag ciContent, ciContentToText ciContent, ciCreateStatus ciContent, msgContentTag <$> ciMsgContent ciContent, sharedMsgId, forwardedByMember, BI includeInHistory) :. (createdAt, createdAt, BI <$> (justTrue live)) :. ciTimedRow timed
itemRow :: (SMsgDirection d, UTCTime, CIContent d, Text, Text, CIStatus d, Maybe MsgContentTag, Maybe SharedMsgId, Maybe GroupMemberId, BoolInt) :. (UTCTime, UTCTime, Maybe BoolInt, BoolInt) :. (Maybe Int, Maybe UTCTime)
itemRow = (msgDirection @d, itemTs, ciContent, toCIContentTag ciContent, ciContentToText ciContent, ciCreateStatus ciContent, msgContentTag <$> ciMsgContent ciContent, sharedMsgId, forwardedByMember, BI includeInHistory) :. (createdAt, createdAt, BI <$> (justTrue live), BI userMention) :. ciTimedRow timed
quoteRow' = let (a, b, c, d, e) = quoteRow in (a, b, c, BI <$> d, e)
idsRow :: (Maybe Int64, Maybe Int64, Maybe Int64, Maybe Int64)
idsRow = case chatDirection of
@@ -766,7 +771,7 @@ getGroupChatPreview_ :: DB.Connection -> VersionRangeChat -> User -> ChatPreview
getGroupChatPreview_ db vr user (GroupChatPD _ groupId lastItemId_ stats) = do
groupInfo <- getGroupInfo db vr user groupId
lastItem <- case lastItemId_ of
Just lastItemId -> (: []) <$> getGroupChatItem db user groupId lastItemId
Just lastItemId -> (: []) <$> getGroupCIWithReactions db user groupInfo lastItemId
Nothing -> pure []
pure $ AChat SCTGroup (Chat (GroupChat groupInfo) lastItem stats)
@@ -855,7 +860,7 @@ getLocalChatPreview_ db user (LocalChatPD _ noteFolderId lastItemId_ stats) = do
-- this function can be changed so it never fails, not only avoid failure on invalid json
toLocalChatItem :: UTCTime -> ChatItemRow -> Either StoreError (CChatItem 'CTLocal)
toLocalChatItem currentTs ((itemId, itemTs, AMsgDirection msgDir, itemContentText, itemText, itemStatus, sentViaProxy, sharedMsgId) :. (itemDeleted, deletedTs, itemEdited, createdAt, updatedAt) :. forwardedFromRow :. (timedTTL, timedDeleteAt, itemLive) :. (fileId_, fileName_, fileSize_, filePath, fileKey, fileNonce, fileStatus_, fileProtocol_)) =
toLocalChatItem currentTs ((itemId, itemTs, AMsgDirection msgDir, itemContentText, itemText, itemStatus, sentViaProxy, sharedMsgId) :. (itemDeleted, deletedTs, itemEdited, createdAt, updatedAt) :. forwardedFromRow :. (timedTTL, timedDeleteAt, itemLive, BI userMention) :. (fileId_, fileName_, fileSize_, filePath, fileKey, fileNonce, fileStatus_, fileProtocol_)) =
chatItem $ fromRight invalid $ dbParseACIContent itemContentText
where
invalid = ACIContent msgDir $ CIInvalidJSON itemContentText
@@ -879,7 +884,7 @@ toLocalChatItem currentTs ((itemId, itemTs, AMsgDirection msgDir, itemContentTex
_ -> Nothing
cItem :: MsgDirectionI d => SMsgDirection d -> CIDirection 'CTLocal d -> CIStatus d -> CIContent d -> Maybe (CIFile d) -> CChatItem 'CTLocal
cItem d chatDir ciStatus content file =
CChatItem d ChatItem {chatDir, meta = ciMeta content ciStatus, content, formattedText = parseMaybeMarkdownList itemText, quotedItem = Nothing, reactions = [], file}
CChatItem d ChatItem {chatDir, meta = ciMeta content ciStatus, content, mentions = M.empty, formattedText = parseMaybeMarkdownList itemText, quotedItem = Nothing, reactions = [], file}
badItem = Left $ SEBadChatItem itemId (Just itemTs)
ciMeta :: CIContent d -> CIStatus d -> CIMeta 'CTLocal d
ciMeta content status =
@@ -888,7 +893,7 @@ toLocalChatItem currentTs ((itemId, itemTs, AMsgDirection msgDir, itemContentTex
_ -> Just (CIDeleted @'CTLocal deletedTs)
itemEdited' = maybe False unBI itemEdited
itemForwarded = toCIForwardedFrom forwardedFromRow
in mkCIMeta itemId content itemText status (unBI <$> sentViaProxy) sharedMsgId itemForwarded itemDeleted' itemEdited' ciTimed (unBI <$> itemLive) currentTs itemTs Nothing createdAt updatedAt
in mkCIMeta itemId content itemText status (unBI <$> sentViaProxy) sharedMsgId itemForwarded itemDeleted' itemEdited' ciTimed (unBI <$> itemLive) userMention currentTs itemTs Nothing createdAt updatedAt
ciTimed :: Maybe CITimed
ciTimed = timedTTL >>= \ttl -> Just CITimed {ttl, deleteAt = timedDeleteAt}
@@ -1021,6 +1026,7 @@ safeToDirectItem currentTs itemId = \case
{ chatDir = CIDirectSnd,
meta = dummyMeta itemId ts errorText,
content = CIInvalidJSON errorText,
mentions = M.empty,
formattedText = Nothing,
quotedItem = Nothing,
reactions = [],
@@ -1276,6 +1282,7 @@ safeToGroupItem currentTs itemId = \case
{ chatDir = CIGroupSnd,
meta = dummyMeta itemId ts errorText,
content = CIInvalidJSON errorText,
mentions = M.empty,
formattedText = Nothing,
quotedItem = Nothing,
reactions = [],
@@ -1501,6 +1508,7 @@ safeToLocalItem currentTs itemId = \case
{ chatDir = CILocalSnd,
meta = dummyMeta itemId ts errorText,
content = CIInvalidJSON errorText,
mentions = M.empty,
formattedText = Nothing,
quotedItem = Nothing,
reactions = [],
@@ -1810,7 +1818,7 @@ updateLocalChatItemsRead db User {userId} noteFolderId = do
type MaybeCIFIleRow = (Maybe Int64, Maybe String, Maybe Integer, Maybe FilePath, Maybe C.SbKey, Maybe C.CbNonce, Maybe ACIFileStatus, Maybe FileProtocol)
type ChatItemModeRow = (Maybe Int, Maybe UTCTime, Maybe BoolInt)
type ChatItemModeRow = (Maybe Int, Maybe UTCTime, Maybe BoolInt, BoolInt)
type ChatItemForwardedFromRow = (Maybe CIForwardedFromTag, Maybe Text, Maybe MsgDirection, Maybe Int64, Maybe Int64, Maybe Int64)
@@ -1834,7 +1842,7 @@ toQuote (quotedItemId, quotedSharedMsgId, quotedSentAt, quotedMsgContent, _) dir
-- this function can be changed so it never fails, not only avoid failure on invalid json
toDirectChatItem :: UTCTime -> ChatItemRow :. QuoteRow -> Either StoreError (CChatItem 'CTDirect)
toDirectChatItem currentTs (((itemId, itemTs, AMsgDirection msgDir, itemContentText, itemText, itemStatus, sentViaProxy, sharedMsgId) :. (itemDeleted, deletedTs, itemEdited, createdAt, updatedAt) :. forwardedFromRow :. (timedTTL, timedDeleteAt, itemLive) :. (fileId_, fileName_, fileSize_, filePath, fileKey, fileNonce, fileStatus_, fileProtocol_)) :. quoteRow) =
toDirectChatItem currentTs (((itemId, itemTs, AMsgDirection msgDir, itemContentText, itemText, itemStatus, sentViaProxy, sharedMsgId) :. (itemDeleted, deletedTs, itemEdited, createdAt, updatedAt) :. forwardedFromRow :. (timedTTL, timedDeleteAt, itemLive, BI userMention) :. (fileId_, fileName_, fileSize_, filePath, fileKey, fileNonce, fileStatus_, fileProtocol_)) :. quoteRow) =
chatItem $ fromRight invalid $ dbParseACIContent itemContentText
where
invalid = ACIContent msgDir $ CIInvalidJSON itemContentText
@@ -1858,7 +1866,7 @@ toDirectChatItem currentTs (((itemId, itemTs, AMsgDirection msgDir, itemContentT
_ -> Nothing
cItem :: MsgDirectionI d => SMsgDirection d -> CIDirection 'CTDirect d -> CIStatus d -> CIContent d -> Maybe (CIFile d) -> CChatItem 'CTDirect
cItem d chatDir ciStatus content file =
CChatItem d ChatItem {chatDir, meta = ciMeta content ciStatus, content, formattedText = parseMaybeMarkdownList itemText, quotedItem = toDirectQuote quoteRow, reactions = [], file}
CChatItem d ChatItem {chatDir, meta = ciMeta content ciStatus, content, mentions = M.empty, formattedText = parseMaybeMarkdownList itemText, quotedItem = toDirectQuote quoteRow, reactions = [], file}
badItem = Left $ SEBadChatItem itemId (Just itemTs)
ciMeta :: CIContent d -> CIStatus d -> CIMeta 'CTDirect d
ciMeta content status =
@@ -1867,7 +1875,7 @@ toDirectChatItem currentTs (((itemId, itemTs, AMsgDirection msgDir, itemContentT
_ -> Just (CIDeleted @'CTDirect deletedTs)
itemEdited' = maybe False unBI itemEdited
itemForwarded = toCIForwardedFrom forwardedFromRow
in mkCIMeta itemId content itemText status (unBI <$> sentViaProxy) sharedMsgId itemForwarded itemDeleted' itemEdited' ciTimed (unBI <$> itemLive) currentTs itemTs Nothing createdAt updatedAt
in mkCIMeta itemId content itemText status (unBI <$> sentViaProxy) sharedMsgId itemForwarded itemDeleted' itemEdited' ciTimed (unBI <$> itemLive) userMention currentTs itemTs Nothing createdAt updatedAt
ciTimed :: Maybe CITimed
ciTimed = timedTTL >>= \ttl -> Just CITimed {ttl, deleteAt = timedDeleteAt}
@@ -1891,7 +1899,7 @@ toGroupQuote qr@(_, _, _, _, quotedSent) quotedMember_ = toQuote qr $ direction
-- this function can be changed so it never fails, not only avoid failure on invalid json
toGroupChatItem :: UTCTime -> Int64 -> ChatItemRow :. Only (Maybe GroupMemberId) :. MaybeGroupMemberRow :. GroupQuoteRow :. MaybeGroupMemberRow -> Either StoreError (CChatItem 'CTGroup)
toGroupChatItem currentTs userContactId (((itemId, itemTs, AMsgDirection msgDir, itemContentText, itemText, itemStatus, sentViaProxy, sharedMsgId) :. (itemDeleted, deletedTs, itemEdited, createdAt, updatedAt) :. forwardedFromRow :. (timedTTL, timedDeleteAt, itemLive) :. (fileId_, fileName_, fileSize_, filePath, fileKey, fileNonce, fileStatus_, fileProtocol_)) :. Only forwardedByMember :. memberRow_ :. (quoteRow :. quotedMemberRow_) :. deletedByGroupMemberRow_) = do
toGroupChatItem currentTs userContactId (((itemId, itemTs, AMsgDirection msgDir, itemContentText, itemText, itemStatus, sentViaProxy, sharedMsgId) :. (itemDeleted, deletedTs, itemEdited, createdAt, updatedAt) :. forwardedFromRow :. (timedTTL, timedDeleteAt, itemLive, BI userMention) :. (fileId_, fileName_, fileSize_, filePath, fileKey, fileNonce, fileStatus_, fileProtocol_)) :. Only forwardedByMember :. memberRow_ :. (quoteRow :. quotedMemberRow_) :. deletedByGroupMemberRow_) = do
chatItem $ fromRight invalid $ dbParseACIContent itemContentText
where
member_ = toMaybeGroupMember userContactId memberRow_
@@ -1918,7 +1926,7 @@ toGroupChatItem currentTs userContactId (((itemId, itemTs, AMsgDirection msgDir,
_ -> Nothing
cItem :: MsgDirectionI d => SMsgDirection d -> CIDirection 'CTGroup d -> CIStatus d -> CIContent d -> Maybe (CIFile d) -> CChatItem 'CTGroup
cItem d chatDir ciStatus content file =
CChatItem d ChatItem {chatDir, meta = ciMeta content ciStatus, content, formattedText = parseMaybeMarkdownList itemText, quotedItem = toGroupQuote quoteRow quotedMember_, reactions = [], file}
CChatItem d ChatItem {chatDir, meta = ciMeta content ciStatus, content, mentions = M.empty, formattedText = parseMaybeMarkdownList itemText, quotedItem = toGroupQuote quoteRow quotedMember_, reactions = [], file}
badItem = Left $ SEBadChatItem itemId (Just itemTs)
ciMeta :: CIContent d -> CIStatus d -> CIMeta 'CTGroup d
ciMeta content status =
@@ -1929,7 +1937,7 @@ toGroupChatItem currentTs userContactId (((itemId, itemTs, AMsgDirection msgDir,
_ -> Just (maybe (CIDeleted @'CTGroup deletedTs) (CIModerated deletedTs) deletedByGroupMember_)
itemEdited' = maybe False unBI itemEdited
itemForwarded = toCIForwardedFrom forwardedFromRow
in mkCIMeta itemId content itemText status (unBI <$> sentViaProxy) sharedMsgId itemForwarded itemDeleted' itemEdited' ciTimed (unBI <$> itemLive) currentTs itemTs forwardedByMember createdAt updatedAt
in mkCIMeta itemId content itemText status (unBI <$> sentViaProxy) sharedMsgId itemForwarded itemDeleted' itemEdited' ciTimed (unBI <$> itemLive) userMention currentTs itemTs forwardedByMember createdAt updatedAt
ciTimed :: Maybe CITimed
ciTimed = timedTTL >>= \ttl -> Just CITimed {ttl, deleteAt = timedDeleteAt}
@@ -2202,7 +2210,7 @@ getDirectChatItem db User {userId} contactId itemId = ExceptT $ do
i.chat_item_id, i.item_ts, i.item_sent, i.item_content, i.item_text, i.item_status, i.via_proxy, i.shared_msg_id,
i.item_deleted, i.item_deleted_ts, i.item_edited, i.created_at, i.updated_at,
i.fwd_from_tag, i.fwd_from_chat_name, i.fwd_from_msg_dir, i.fwd_from_contact_id, i.fwd_from_group_id, i.fwd_from_chat_item_id,
i.timed_ttl, i.timed_delete_at, i.item_live,
i.timed_ttl, i.timed_delete_at, i.item_live, i.user_mention,
-- CIFile
f.file_id, f.file_name, f.file_size, f.file_path, f.file_crypto_key, f.file_crypto_nonce, f.ci_file_status, f.protocol,
-- DirectQuote
@@ -2254,12 +2262,14 @@ getGroupCIWithReactions db user g@GroupInfo {groupId} itemId = do
liftIO . groupCIWithReactions db g =<< getGroupChatItem db user groupId itemId
groupCIWithReactions :: DB.Connection -> GroupInfo -> CChatItem 'CTGroup -> IO (CChatItem 'CTGroup)
groupCIWithReactions db g cci@(CChatItem md ci@ChatItem {meta = CIMeta {itemSharedMsgId}}) = case itemSharedMsgId of
Just sharedMsgId -> do
let GroupMember {memberId} = chatItemMember g ci
reactions <- getGroupCIReactions db g memberId sharedMsgId
pure $ CChatItem md ci {reactions}
Nothing -> pure cci
groupCIWithReactions db g cci@(CChatItem md ci@ChatItem {meta = CIMeta {itemId, itemSharedMsgId}}) = do
mentions <- getGroupCIMentions db itemId
case itemSharedMsgId of
Just sharedMsgId -> do
let GroupMember {memberId} = chatItemMember g ci
reactions <- getGroupCIReactions db g memberId sharedMsgId
pure $ CChatItem md ci {reactions, mentions}
Nothing -> pure $ if null mentions then cci else CChatItem md ci {mentions}
updateGroupChatItem :: MsgDirectionI d => DB.Connection -> User -> Int64 -> ChatItem 'CTGroup d -> CIContent d -> Bool -> Bool -> Maybe MessageId -> IO (ChatItem 'CTGroup d)
updateGroupChatItem db user groupId ci newContent edited live msgId_ = do
@@ -2285,6 +2295,25 @@ updateGroupChatItem_ db User {userId} groupId ChatItem {content, meta} msgId_ =
((content, itemText, itemStatus, BI itemDeleted', itemDeletedTs', BI itemEdited, BI <$> itemLive, updatedAt) :. ciTimedRow itemTimed :. (userId, groupId, itemId))
forM_ msgId_ $ \msgId -> insertChatItemMessage_ db itemId msgId updatedAt
createGroupCIMentions :: forall d. DB.Connection -> GroupInfo -> ChatItem 'CTGroup d -> Map MemberName MentionedMember -> IO (ChatItem 'CTGroup d)
createGroupCIMentions db GroupInfo {groupId} ci mentions = do
DB.executeMany db "INSERT INTO chat_item_mentions (chat_item_id, group_id, member_id, display_name) VALUES (?, ?, ?, ?)" rows
pure (ci :: ChatItem 'CTGroup d) {mentions}
where
rows = map (\(name, MentionedMember {memberId}) -> (ciId, groupId, memberId, name)) $ M.assocs mentions
ciId = chatItemId' ci
updateGroupCIMentions :: DB.Connection -> GroupInfo -> ChatItem 'CTGroup d -> Map MemberName MentionedMember -> IO (ChatItem 'CTGroup d)
updateGroupCIMentions db g ci@ChatItem {mentions} mentions'
| mentions' == mentions = pure ci
| otherwise = do
unless (null mentions) $ deleteMentions
if null mentions'
then pure ci
else createGroupCIMentions db g ci mentions'
where
deleteMentions = DB.execute db "DELETE FROM chat_item_mentions WHERE chat_item_id = ?" (Only $ chatItemId' ci)
deleteGroupChatItem :: DB.Connection -> User -> GroupInfo -> ChatItem 'CTGroup d -> IO ()
deleteGroupChatItem db User {userId} g@GroupInfo {groupId} ci = do
let itemId = chatItemId' ci
@@ -2458,7 +2487,7 @@ getGroupChatItem db User {userId, userContactId} groupId itemId = ExceptT $ do
i.chat_item_id, i.item_ts, i.item_sent, i.item_content, i.item_text, i.item_status, i.via_proxy, i.shared_msg_id,
i.item_deleted, i.item_deleted_ts, i.item_edited, i.created_at, i.updated_at,
i.fwd_from_tag, i.fwd_from_chat_name, i.fwd_from_msg_dir, i.fwd_from_contact_id, i.fwd_from_group_id, i.fwd_from_chat_item_id,
i.timed_ttl, i.timed_delete_at, i.item_live,
i.timed_ttl, i.timed_delete_at, i.item_live, i.user_mention,
-- CIFile
f.file_id, f.file_name, f.file_size, f.file_path, f.file_crypto_key, f.file_crypto_nonce, f.ci_file_status, f.protocol,
-- CIMeta forwardedByMember
@@ -2562,7 +2591,7 @@ getLocalChatItem db User {userId} folderId itemId = ExceptT $ do
i.chat_item_id, i.item_ts, i.item_sent, i.item_content, i.item_text, i.item_status, i.via_proxy, i.shared_msg_id,
i.item_deleted, i.item_deleted_ts, i.item_edited, i.created_at, i.updated_at,
i.fwd_from_tag, i.fwd_from_chat_name, i.fwd_from_msg_dir, i.fwd_from_contact_id, i.fwd_from_group_id, i.fwd_from_chat_item_id,
i.timed_ttl, i.timed_delete_at, i.item_live,
i.timed_ttl, i.timed_delete_at, i.item_live, i.user_mention,
-- CIFile
f.file_id, f.file_name, f.file_size, f.file_path, f.file_crypto_key, f.file_crypto_nonce, f.ci_file_status, f.protocol
FROM chat_items i
@@ -2760,6 +2789,28 @@ getGroupCIReactions db GroupInfo {groupId} itemMemberId itemSharedMsgId =
|]
(groupId, itemMemberId, itemSharedMsgId)
getGroupCIMentions :: DB.Connection -> ChatItemId -> IO (Map MemberName MentionedMember)
getGroupCIMentions db ciId =
M.fromList . map mentionedMember
<$> DB.query
db
[sql|
SELECT r.display_name, r.member_id, m.group_member_id, m.member_role, p.display_name, p.local_alias
FROM chat_item_mentions r
LEFT JOIN group_members m ON r.group_id = m.group_id AND r.member_id = m.member_id
LEFT JOIN contact_profiles p ON p.contact_profile_id = COALESCE(m.member_profile_id, m.contact_profile_id)
WHERE r.chat_item_id = ?
|]
(Only ciId)
where
mentionedMember :: (ContactName, MemberId, Maybe GroupMemberId, Maybe GroupMemberRole, Maybe Text, Maybe Text) -> (ContactName, MentionedMember)
mentionedMember (name, memberId, gmId_, mRole_, displayName_, localAlias) =
let memberRef = case (gmId_, mRole_, displayName_) of
(Just groupMemberId, Just memberRole, Just displayName) ->
Just MentionedMemberInfo {groupMemberId, displayName, localAlias, memberRole}
_ -> Nothing
in (name, MentionedMember {memberId, memberRef})
getACIReactions :: DB.Connection -> AChatItem -> IO AChatItem
getACIReactions db aci@(AChatItem _ md chat ci@ChatItem {meta = CIMeta {itemSharedMsgId}}) = case itemSharedMsgId of
Just itemSharedMId -> case chat of
src/Simplex/Chat/Store/Postgres/Migrations/M20241220_initial.hs
+13 -1
View File
@@ -426,7 +426,8 @@ CREATE TABLE chat_items(
fwd_from_chat_item_id BIGINT REFERENCES chat_items ON DELETE SET NULL,
via_proxy SMALLINT,
msg_content_tag TEXT,
include_in_history SMALLINT NOT NULL DEFAULT 0
include_in_history SMALLINT NOT NULL DEFAULT 0,
user_mention SMALLINT NOT NULL DEFAULT 0
);
ALTER TABLE groups
ADD CONSTRAINT fk_groups_chat_items
@@ -676,6 +677,13 @@ CREATE TABLE chat_tags_chats(
group_id BIGINT REFERENCES groups ON DELETE CASCADE,
chat_tag_id BIGINT NOT NULL REFERENCES chat_tags ON DELETE CASCADE
);
CREATE TABLE chat_item_mentions (
chat_item_mention_id BIGINT PRIMARY KEY GENERATED ALWAYS AS IDENTITY,
chat_item_id BIGINT NOT NULL REFERENCES chat_items ON DELETE CASCADE,
group_id BIGINT NOT NULL REFERENCES groups ON DELETE CASCADE,
member_id BYTEA NOT NULL,
display_name TEXT NOT NULL
);
CREATE INDEX contact_profiles_index ON contact_profiles(
display_name,
full_name
@@ -1025,4 +1033,8 @@ CREATE INDEX idx_group_snd_item_statuses_chat_item_id_group_member_id ON group_s
chat_item_id,
group_member_id
);
CREATE INDEX idx_chat_item_mentions_group_id ON chat_item_mentions(group_id);
CREATE INDEX idx_chat_item_mentions_chat_item_id ON chat_item_mentions(chat_item_id);
CREATE UNIQUE INDEX idx_chat_item_mentions_display_name ON chat_item_mentions(chat_item_id, display_name);
CREATE UNIQUE INDEX idx_chat_item_mentions_member_id ON chat_item_mentions(chat_item_id, member_id);
|]
src/Simplex/Chat/Store/SQLite/Migrations.hs
+3 -1
View File
@@ -125,6 +125,7 @@ import Simplex.Chat.Store.SQLite.Migrations.M20241230_reports
import Simplex.Chat.Store.SQLite.Migrations.M20250105_indexes
import Simplex.Chat.Store.SQLite.Migrations.M20250115_chat_ttl
import Simplex.Chat.Store.SQLite.Migrations.M20250122_chat_items_include_in_history
import Simplex.Chat.Store.SQLite.Migrations.M20250126_mentions
import Simplex.Messaging.Agent.Store.Shared (Migration (..))
schemaMigrations :: [(String, Query, Maybe Query)]
@@ -249,7 +250,8 @@ schemaMigrations =
("20241230_reports", m20241230_reports, Just down_m20241230_reports),
("20250105_indexes", m20250105_indexes, Just down_m20250105_indexes),
("20250115_chat_ttl", m20250115_chat_ttl, Just down_m20250115_chat_ttl),
("20250122_chat_items_include_in_history", m20250122_chat_items_include_in_history, Just down_m20250122_chat_items_include_in_history)
("20250122_chat_items_include_in_history", m20250122_chat_items_include_in_history, Just down_m20250122_chat_items_include_in_history),
("20250126_mentions", m20250126_mentions, Just down_m20250126_mentions)
]
-- | The list of migrations in ascending order by date
src/Simplex/Chat/Store/SQLite/Migrations/M20250126_mentions.hs
+37
View File
@@ -0,0 +1,37 @@
{-# LANGUAGE QuasiQuotes #-}
module Simplex.Chat.Store.SQLite.Migrations.M20250126_mentions where
import Database.SQLite.Simple (Query)
import Database.SQLite.Simple.QQ (sql)
m20250126_mentions :: Query
m20250126_mentions =
[sql|
ALTER TABLE chat_items ADD COLUMN user_mention INTEGER NOT NULL DEFAULT 0;
CREATE TABLE chat_item_mentions (
chat_item_mention_id INTEGER PRIMARY KEY AUTOINCREMENT,
group_id INTEGER NOT NULL REFERENCES groups ON DELETE CASCADE,
member_id BLOB NOT NULL,
chat_item_id INTEGER NOT NULL REFERENCES chat_items ON DELETE CASCADE,
display_name TEXT NOT NULL
);
CREATE INDEX idx_chat_item_mentions_group_id ON chat_item_mentions(group_id);
CREATE INDEX idx_chat_item_mentions_chat_item_id ON chat_item_mentions(chat_item_id);
CREATE UNIQUE INDEX idx_chat_item_mentions_display_name ON chat_item_mentions(chat_item_id, display_name);
CREATE UNIQUE INDEX idx_chat_item_mentions_member_id ON chat_item_mentions(chat_item_id, member_id);
|]
down_m20250126_mentions :: Query
down_m20250126_mentions =
[sql|
DROP INDEX idx_chat_item_mentions_group_id;
DROP INDEX idx_chat_item_mentions_chat_item_id;
DROP INDEX idx_chat_item_mentions_display_name;
DROP INDEX idx_chat_item_mentions_member_id;
DROP TABLE chat_item_mentions;
ALTER TABLE chat_items DROP COLUMN user_mention;
|]
src/Simplex/Chat/Store/SQLite/Migrations/chat_query_plans.txt
+47 -5
View File
@@ -714,7 +714,7 @@ Query:
i.chat_item_id, i.item_ts, i.item_sent, i.item_content, i.item_text, i.item_status, i.via_proxy, i.shared_msg_id,
i.item_deleted, i.item_deleted_ts, i.item_edited, i.created_at, i.updated_at,
i.fwd_from_tag, i.fwd_from_chat_name, i.fwd_from_msg_dir, i.fwd_from_contact_id, i.fwd_from_group_id, i.fwd_from_chat_item_id,
i.timed_ttl, i.timed_delete_at, i.item_live,
i.timed_ttl, i.timed_delete_at, i.item_live, i.user_mention,
-- CIFile
f.file_id, f.file_name, f.file_size, f.file_path, f.file_crypto_key, f.file_crypto_nonce, f.ci_file_status, f.protocol
FROM chat_items i
@@ -731,7 +731,7 @@ Query:
i.chat_item_id, i.item_ts, i.item_sent, i.item_content, i.item_text, i.item_status, i.via_proxy, i.shared_msg_id,
i.item_deleted, i.item_deleted_ts, i.item_edited, i.created_at, i.updated_at,
i.fwd_from_tag, i.fwd_from_chat_name, i.fwd_from_msg_dir, i.fwd_from_contact_id, i.fwd_from_group_id, i.fwd_from_chat_item_id,
i.timed_ttl, i.timed_delete_at, i.item_live,
i.timed_ttl, i.timed_delete_at, i.item_live, i.user_mention,
-- CIFile
f.file_id, f.file_name, f.file_size, f.file_path, f.file_crypto_key, f.file_crypto_nonce, f.ci_file_status, f.protocol,
-- CIMeta forwardedByMember
@@ -778,7 +778,7 @@ Query:
i.chat_item_id, i.item_ts, i.item_sent, i.item_content, i.item_text, i.item_status, i.via_proxy, i.shared_msg_id,
i.item_deleted, i.item_deleted_ts, i.item_edited, i.created_at, i.updated_at,
i.fwd_from_tag, i.fwd_from_chat_name, i.fwd_from_msg_dir, i.fwd_from_contact_id, i.fwd_from_group_id, i.fwd_from_chat_item_id,
i.timed_ttl, i.timed_delete_at, i.item_live,
i.timed_ttl, i.timed_delete_at, i.item_live, i.user_mention,
-- CIFile
f.file_id, f.file_name, f.file_size, f.file_path, f.file_crypto_key, f.file_crypto_nonce, f.ci_file_status, f.protocol,
-- DirectQuote
@@ -3295,6 +3295,18 @@ SEARCH r USING INDEX idx_received_probes_user_id (user_id=?)
SEARCH m USING INTEGER PRIMARY KEY (rowid=?) LEFT-JOIN
SEARCH g USING INTEGER PRIMARY KEY (rowid=?) LEFT-JOIN
Query:
SELECT r.display_name, r.member_id, m.group_member_id, m.member_role, p.display_name, p.local_alias
FROM chat_item_mentions r
LEFT JOIN group_members m ON r.group_id = m.group_id AND r.member_id = m.member_id
LEFT JOIN contact_profiles p ON p.contact_profile_id = COALESCE(m.member_profile_id, m.contact_profile_id)
WHERE r.chat_item_id = ?
Plan:
SEARCH r USING INDEX idx_chat_item_mentions_chat_item_id (chat_item_id=?)
SEARCH m USING INDEX sqlite_autoindex_group_members_1 (group_id=? AND member_id=?) LEFT-JOIN
SEARCH p USING INTEGER PRIMARY KEY (rowid=?) LEFT-JOIN
Query:
SELECT re_group_member_id
FROM group_member_intros
@@ -3489,6 +3501,7 @@ Query:
Plan:
SEARCH chat_items USING INTEGER PRIMARY KEY (rowid=?)
SEARCH chat_item_mentions USING COVERING INDEX idx_chat_item_mentions_chat_item_id (chat_item_id=?)
SEARCH group_snd_item_statuses USING COVERING INDEX idx_group_snd_item_statuses_chat_item_id (chat_item_id=?)
SEARCH chat_item_versions USING COVERING INDEX idx_chat_item_versions_chat_item_id (chat_item_id=?)
SEARCH calls USING COVERING INDEX idx_calls_chat_item_id (chat_item_id=?)
@@ -3503,6 +3516,7 @@ Query:
Plan:
SEARCH chat_items USING INTEGER PRIMARY KEY (rowid=?)
SEARCH chat_item_mentions USING COVERING INDEX idx_chat_item_mentions_chat_item_id (chat_item_id=?)
SEARCH group_snd_item_statuses USING COVERING INDEX idx_group_snd_item_statuses_chat_item_id (chat_item_id=?)
SEARCH chat_item_versions USING COVERING INDEX idx_chat_item_versions_chat_item_id (chat_item_id=?)
SEARCH calls USING COVERING INDEX idx_calls_chat_item_id (chat_item_id=?)
@@ -3517,6 +3531,7 @@ Query:
Plan:
SEARCH chat_items USING INTEGER PRIMARY KEY (rowid=?)
SEARCH chat_item_mentions USING COVERING INDEX idx_chat_item_mentions_chat_item_id (chat_item_id=?)
SEARCH group_snd_item_statuses USING COVERING INDEX idx_group_snd_item_statuses_chat_item_id (chat_item_id=?)
SEARCH chat_item_versions USING COVERING INDEX idx_chat_item_versions_chat_item_id (chat_item_id=?)
SEARCH calls USING COVERING INDEX idx_calls_chat_item_id (chat_item_id=?)
@@ -3964,12 +3979,12 @@ Query:
user_id, created_by_msg_id, contact_id, group_id, group_member_id, note_folder_id,
-- meta
item_sent, item_ts, item_content, item_content_tag, item_text, item_status, msg_content_tag, shared_msg_id,
forwarded_by_group_member_id, include_in_history, created_at, updated_at, item_live, timed_ttl, timed_delete_at,
forwarded_by_group_member_id, include_in_history, created_at, updated_at, item_live, user_mention, timed_ttl, timed_delete_at,
-- quote
quoted_shared_msg_id, quoted_sent_at, quoted_content, quoted_sent, quoted_member_id,
-- forwarded from
fwd_from_tag, fwd_from_chat_name, fwd_from_msg_dir, fwd_from_contact_id, fwd_from_group_id, fwd_from_chat_item_id
) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?)
) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?)
Plan:
@@ -4690,6 +4705,24 @@ Plan:
SEARCH i USING COVERING INDEX idx_chat_items_notes_created_at (user_id=? AND note_folder_id=?)
SEARCH f USING INDEX idx_files_chat_item_id (chat_item_id=?)
Query:
SELECT m.group_member_id, m.member_id, m.member_role, p.display_name, p.local_alias
FROM group_members m
JOIN contact_profiles p ON p.contact_profile_id = COALESCE(m.member_profile_id, m.contact_profile_id)
WHERE m.group_id = ? AND m.group_member_id = ? AND m.user_id = ?
Plan:
SEARCH m USING INTEGER PRIMARY KEY (rowid=?)
SEARCH p USING INTEGER PRIMARY KEY (rowid=?)
Query:
SELECT m.group_member_id, m.member_id, m.member_role, p.display_name, p.local_alias
FROM group_members m
JOIN contact_profiles p ON p.contact_profile_id = COALESCE(m.member_profile_id, m.contact_profile_id)
WHERE m.group_id = ? AND m.member_id = ? AND m.user_id = ?
Plan:
SEARCH m USING INDEX sqlite_autoindex_group_members_1 (group_id=? AND member_id=?)
SEARCH p USING INTEGER PRIMARY KEY (rowid=?)
Query:
SELECT remote_ctrl_id, ctrl_device_name, ca_key, ca_cert, ctrl_fingerprint, id_pub, dh_priv_key, prev_dh_priv_key
FROM remote_controllers
@@ -4957,6 +4990,7 @@ SEARCH chat_item_versions USING COVERING INDEX idx_chat_item_versions_chat_item_
Query: DELETE FROM chat_items WHERE user_id = ? AND contact_id = ?
Plan:
SEARCH chat_items USING COVERING INDEX idx_chat_items_contacts_created_at (user_id=? AND contact_id=?)
SEARCH chat_item_mentions USING COVERING INDEX idx_chat_item_mentions_chat_item_id (chat_item_id=?)
SEARCH group_snd_item_statuses USING COVERING INDEX idx_group_snd_item_statuses_chat_item_id (chat_item_id=?)
SEARCH chat_item_versions USING COVERING INDEX idx_chat_item_versions_chat_item_id (chat_item_id=?)
SEARCH calls USING COVERING INDEX idx_calls_chat_item_id (chat_item_id=?)
@@ -4968,6 +5002,7 @@ SEARCH groups USING COVERING INDEX idx_groups_chat_item_id (chat_item_id=?)
Query: DELETE FROM chat_items WHERE user_id = ? AND contact_id = ? AND created_at <= ?
Plan:
SEARCH chat_items USING COVERING INDEX idx_chat_items_contacts_created_at (user_id=? AND contact_id=? AND created_at<?)
SEARCH chat_item_mentions USING COVERING INDEX idx_chat_item_mentions_chat_item_id (chat_item_id=?)
SEARCH group_snd_item_statuses USING COVERING INDEX idx_group_snd_item_statuses_chat_item_id (chat_item_id=?)
SEARCH chat_item_versions USING COVERING INDEX idx_chat_item_versions_chat_item_id (chat_item_id=?)
SEARCH calls USING COVERING INDEX idx_calls_chat_item_id (chat_item_id=?)
@@ -4979,6 +5014,7 @@ SEARCH groups USING COVERING INDEX idx_groups_chat_item_id (chat_item_id=?)
Query: DELETE FROM chat_items WHERE user_id = ? AND group_id = ?
Plan:
SEARCH chat_items USING COVERING INDEX idx_chat_items_groups_item_ts (user_id=? AND group_id=?)
SEARCH chat_item_mentions USING COVERING INDEX idx_chat_item_mentions_chat_item_id (chat_item_id=?)
SEARCH group_snd_item_statuses USING COVERING INDEX idx_group_snd_item_statuses_chat_item_id (chat_item_id=?)
SEARCH chat_item_versions USING COVERING INDEX idx_chat_item_versions_chat_item_id (chat_item_id=?)
SEARCH calls USING COVERING INDEX idx_calls_chat_item_id (chat_item_id=?)
@@ -4990,6 +5026,7 @@ SEARCH groups USING COVERING INDEX idx_groups_chat_item_id (chat_item_id=?)
Query: DELETE FROM chat_items WHERE user_id = ? AND group_id = ? AND group_member_id = ?
Plan:
SEARCH chat_items USING COVERING INDEX idx_chat_items_group_shared_msg_id (user_id=? AND group_id=? AND group_member_id=?)
SEARCH chat_item_mentions USING COVERING INDEX idx_chat_item_mentions_chat_item_id (chat_item_id=?)
SEARCH group_snd_item_statuses USING COVERING INDEX idx_group_snd_item_statuses_chat_item_id (chat_item_id=?)
SEARCH chat_item_versions USING COVERING INDEX idx_chat_item_versions_chat_item_id (chat_item_id=?)
SEARCH calls USING COVERING INDEX idx_calls_chat_item_id (chat_item_id=?)
@@ -5001,6 +5038,7 @@ SEARCH groups USING COVERING INDEX idx_groups_chat_item_id (chat_item_id=?)
Query: DELETE FROM chat_items WHERE user_id = ? AND note_folder_id = ?
Plan:
SEARCH chat_items USING COVERING INDEX idx_chat_items_notes_created_at (user_id=? AND note_folder_id=?)
SEARCH chat_item_mentions USING COVERING INDEX idx_chat_item_mentions_chat_item_id (chat_item_id=?)
SEARCH group_snd_item_statuses USING COVERING INDEX idx_group_snd_item_statuses_chat_item_id (chat_item_id=?)
SEARCH chat_item_versions USING COVERING INDEX idx_chat_item_versions_chat_item_id (chat_item_id=?)
SEARCH calls USING COVERING INDEX idx_calls_chat_item_id (chat_item_id=?)
@@ -5155,6 +5193,7 @@ SEARCH contacts USING COVERING INDEX idx_contacts_contact_group_member_id (conta
Query: DELETE FROM groups WHERE user_id = ? AND group_id = ?
Plan:
SEARCH groups USING INTEGER PRIMARY KEY (rowid=?)
SEARCH chat_item_mentions USING COVERING INDEX idx_chat_item_mentions_group_id (group_id=?)
SEARCH chat_tags_chats USING COVERING INDEX idx_chat_tags_chats_chat_tag_id_group_id (group_id=?)
SEARCH chat_item_moderations USING COVERING INDEX idx_chat_item_moderations_group_id (group_id=?)
SEARCH chat_item_reactions USING COVERING INDEX idx_chat_item_reactions_group_id (group_id=?)
@@ -5293,6 +5332,9 @@ Plan:
Query: INSERT INTO app_settings (app_settings) VALUES (?)
Plan:
Query: INSERT INTO chat_item_mentions (chat_item_id, group_id, member_id, display_name) VALUES (?, ?, ?, ?)
Plan:
Query: INSERT INTO chat_item_messages (chat_item_id, message_id, created_at, updated_at) VALUES (?,?,?,?)
Plan:
src/Simplex/Chat/Store/SQLite/Migrations/chat_schema.sql
+21 -1
View File
@@ -407,7 +407,8 @@ CREATE TABLE chat_items(
fwd_from_chat_item_id INTEGER REFERENCES chat_items ON DELETE SET NULL,
via_proxy INTEGER,
msg_content_tag TEXT,
include_in_history INTEGER NOT NULL DEFAULT 0
include_in_history INTEGER NOT NULL DEFAULT 0,
user_mention INTEGER NOT NULL DEFAULT 0
);
CREATE TABLE sqlite_sequence(name,seq);
CREATE TABLE chat_item_messages(
@@ -642,6 +643,13 @@ CREATE TABLE chat_tags_chats(
group_id INTEGER REFERENCES groups ON DELETE CASCADE,
chat_tag_id INTEGER NOT NULL REFERENCES chat_tags ON DELETE CASCADE
);
CREATE TABLE chat_item_mentions(
chat_item_mention_id INTEGER PRIMARY KEY AUTOINCREMENT,
group_id INTEGER NOT NULL REFERENCES groups ON DELETE CASCADE,
member_id BLOB NOT NULL,
chat_item_id INTEGER NOT NULL REFERENCES chat_items ON DELETE CASCADE,
display_name TEXT NOT NULL
);
CREATE INDEX contact_profiles_index ON contact_profiles(
display_name,
full_name
@@ -991,3 +999,15 @@ CREATE INDEX idx_group_snd_item_statuses_chat_item_id_group_member_id ON group_s
chat_item_id,
group_member_id
);
CREATE INDEX idx_chat_item_mentions_group_id ON chat_item_mentions(group_id);
CREATE INDEX idx_chat_item_mentions_chat_item_id ON chat_item_mentions(
chat_item_id
);
CREATE UNIQUE INDEX idx_chat_item_mentions_display_name ON chat_item_mentions(
chat_item_id,
display_name
);
CREATE UNIQUE INDEX idx_chat_item_mentions_member_id ON chat_item_mentions(
chat_item_id,
member_id
);
src/Simplex/Chat/Store/Shared.hs
+2
View File
@@ -140,6 +140,8 @@ data StoreError
| SEProhibitedDeleteUser {userId :: UserId, contactId :: ContactId}
| SEOperatorNotFound {serverOperatorId :: Int64}
| SEUsageConditionsNotFound
| SEInvalidQuote
| SEInvalidMention
deriving (Show, Exception)
$(J.deriveJSON (sumTypeJSON $ dropPrefix "SE") ''StoreError)
src/Simplex/Chat/Terminal/Output.hs
+3 -3
View File
@@ -161,7 +161,7 @@ runTerminalOutput ct cc@ChatController {outputQ, showLiveItems, logFilePath} Cha
responseNotification ct cc r
where
markChatItemRead u (AChatItem _ _ chat ci@ChatItem {chatDir, meta = CIMeta {itemStatus}}) =
case (chatDirNtf u chat chatDir (isMention ci), itemStatus) of
case (chatDirNtf u chat chatDir (isUserMention ci), itemStatus) of
(True, CISRcvNew) -> do
let itemId = chatItemId' ci
chatRef = chatInfoToRef chat
@@ -178,7 +178,7 @@ responseNotification :: ChatTerminal -> ChatController -> ChatResponse -> IO ()
responseNotification t@ChatTerminal {sendNotification} cc = \case
-- At the moment of writing received items are created one at a time
CRNewChatItems u ((AChatItem _ SMDRcv cInfo ci@ChatItem {chatDir, content = CIRcvMsgContent mc, formattedText}) : _) ->
when (chatDirNtf u cInfo chatDir $ isMention ci) $ do
when (chatDirNtf u cInfo chatDir $ isUserMention ci) $ do
whenCurrUser cc u $ setActiveChat t cInfo
case (cInfo, chatDir) of
(DirectChat ct, _) -> sendNtf (viewContactName ct <> "> ", text)
@@ -187,7 +187,7 @@ responseNotification t@ChatTerminal {sendNotification} cc = \case
where
text = msgText mc formattedText
CRChatItemUpdated u (AChatItem _ SMDRcv cInfo ci@ChatItem {chatDir, content = CIRcvMsgContent _}) ->
whenCurrUser cc u $ when (chatDirNtf u cInfo chatDir $ isMention ci) $ setActiveChat t cInfo
whenCurrUser cc u $ when (chatDirNtf u cInfo chatDir $ isUserMention ci) $ setActiveChat t cInfo
CRContactConnected u ct _ -> when (contactNtf u ct False) $ do
whenCurrUser cc u $ setActiveContact t ct
sendNtf (viewContactName ct <> "> ", "connected")
src/Simplex/Chat/Types.hs
+6 -1
View File
@@ -366,6 +366,8 @@ type UserName = Text
type ContactName = Text
type MemberName = Text
type GroupName = Text
optionalFullName :: ContactName -> Text -> Text
@@ -800,6 +802,9 @@ memberConn GroupMember {activeConn} = activeConn
memberConnId :: GroupMember -> Maybe ConnId
memberConnId GroupMember {activeConn} = aConnId <$> activeConn
sameMemberId :: MemberId -> GroupMember -> Bool
sameMemberId memId GroupMember {memberId} = memId == memberId
memberChatVRange' :: GroupMember -> VersionRangeChat
memberChatVRange' GroupMember {activeConn, memberChatVRange} = case activeConn of
Just Connection {peerChatVRange} -> peerChatVRange
@@ -839,7 +844,7 @@ data NewGroupMember = NewGroupMember
}
newtype MemberId = MemberId {unMemberId :: ByteString}
deriving (Eq, Show)
deriving (Eq, Ord, Show)
deriving newtype (FromField)
instance ToField MemberId where toField (MemberId m) = toField $ Binary m
src/Simplex/Chat/Util.hs
+7 -1
View File
@@ -4,7 +4,7 @@
{-# LANGUAGE TupleSections #-}
{-# OPTIONS_GHC -Wno-orphans #-}
module Simplex.Chat.Util (week, encryptFile, chunkSize, liftIOEither, shuffle) where
module Simplex.Chat.Util (week, encryptFile, chunkSize, liftIOEither, shuffle, neUnzip3) where
import Control.Exception (Exception)
import Control.Monad
@@ -15,6 +15,7 @@ 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)
@@ -56,6 +57,11 @@ 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
+13 -6
View File
@@ -499,7 +499,7 @@ responseToView hu@(currentRH, user_) ChatConfig {logLevel, showReactions, showRe
contactList :: [ContactRef] -> String
contactList cs = T.unpack . T.intercalate ", " $ map (\ContactRef {localDisplayName = n} -> "@" <> n) cs
unmuted :: User -> ChatInfo c -> ChatItem c d -> [StyledString] -> [StyledString]
unmuted u chat ci@ChatItem {chatDir} = unmuted' u chat chatDir $ isMention ci
unmuted u chat ci@ChatItem {chatDir} = unmuted' u chat chatDir $ isUserMention ci
unmutedReaction :: User -> ChatInfo c -> CIReaction c d -> [StyledString] -> [StyledString]
unmutedReaction u chat CIReaction {chatDir} = unmuted' u chat chatDir False
unmuted' :: User -> ChatInfo c -> CIDirection c d -> Bool -> [StyledString] -> [StyledString]
@@ -588,7 +588,7 @@ viewChats ts tz = concatMap chatPreview . reverse
_ -> []
viewChatItem :: forall c d. MsgDirectionI d => ChatInfo c -> ChatItem c d -> Bool -> CurrentTime -> TimeZone -> [StyledString]
viewChatItem chat ci@ChatItem {chatDir, meta = meta@CIMeta {itemForwarded, forwardedByMember}, content, quotedItem, file} doShow ts tz =
viewChatItem chat ci@ChatItem {chatDir, meta = meta@CIMeta {itemForwarded, forwardedByMember, userMention}, content, quotedItem, file} doShow ts tz =
withGroupMsgForwarded . withItemDeleted <$> viewCI
where
viewCI = case chat of
@@ -627,7 +627,7 @@ viewChatItem chat ci@ChatItem {chatDir, meta = meta@CIMeta {itemForwarded, forwa
CIRcvBlocked {} -> receivedWithTime_ ts tz (ttyFromGroup g m) context meta [plainContent content] False
_ -> showRcvItem from
where
from = ttyFromGroup g m
from = ttyFromGroupAttention g m userMention
where
context =
maybe
@@ -2178,7 +2178,6 @@ viewChatError isCmd logLevel testView = \case
CEFileNotApproved fileId unknownSrvs -> ["file " <> sShow fileId <> " aborted, unknwon XFTP servers:"] <> map (plain . show) unknownSrvs
CEFallbackToSMPProhibited fileId -> ["recipient tried to accept file " <> sShow fileId <> " via old protocol, prohibited"]
CEInlineFileProhibited _ -> ["A small file sent without acceptance - you can enable receiving such files with -f option."]
CEInvalidQuote -> ["cannot reply to this message"]
CEInvalidForward -> ["cannot forward message(s)"]
CEInvalidChatItemUpdate -> ["cannot update this item"]
CEInvalidChatItemDelete -> ["cannot delete this item"]
@@ -2373,7 +2372,10 @@ ttyFullGroup GroupInfo {localDisplayName = g, groupProfile = GroupProfile {fullN
ttyGroup g <> optFullName g fullName
ttyFromGroup :: GroupInfo -> GroupMember -> StyledString
ttyFromGroup g m = membershipIncognito g <> ttyFrom (fromGroup_ g m)
ttyFromGroup g m = ttyFromGroupAttention g m False
ttyFromGroupAttention :: GroupInfo -> GroupMember -> Bool -> StyledString
ttyFromGroupAttention g m attention = membershipIncognito g <> ttyFrom (fromGroupAttention_ g m attention)
ttyFromGroupEdited :: GroupInfo -> GroupMember -> StyledString
ttyFromGroupEdited g m = membershipIncognito g <> ttyFrom (fromGroup_ g m <> "[edited] ")
@@ -2383,7 +2385,12 @@ ttyFromGroupDeleted g m deletedText_ =
membershipIncognito g <> ttyFrom (fromGroup_ g m <> maybe "" (\t -> "[" <> t <> "] ") deletedText_)
fromGroup_ :: GroupInfo -> GroupMember -> Text
fromGroup_ g m = "#" <> viewGroupName g <> " " <> viewMemberName m <> "> "
fromGroup_ g m = fromGroupAttention_ g m False
fromGroupAttention_ :: GroupInfo -> GroupMember -> Bool -> Text
fromGroupAttention_ g m attention =
let attn = if attention then "!" else ""
in "#" <> viewGroupName g <> " " <> viewMemberName m <> attn <> "> "
ttyFrom :: Text -> StyledString
ttyFrom = styled $ colored Yellow