From 806f417e991df23b9f229a1f1c6056b528d31eb3 Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com> Date: Sun, 13 Mar 2022 19:34:03 +0000 Subject: [PATCH] message replies and chat item references (#394) * rfc for message replies and chat item references * update replies rfc * save received/sent shared message ids, migration and types for replies * include reply/forward into MsgContent type * add sharedMsgId to CIMeta * save/get shared_msg_id to/from chat items table * parameterize CIRef by chat type * add CIRef to ChatItem when it is read from the db * terminal command to send message replies * include quoted content into chat items * quoted message direction in direct chats (TODO test) * test for replies with quotes to group messages - own and others * split MsgContainer from MsgContent * make quoting usable in the terminal * add formattedText to quotes * rename migration * update JSON encoding for MsgContainer * allow quoted replies to messages from clients not supporting it/not sending msg IDs * update rfc * fix group replies * add APISendMessageQuote and use it for terminal commands * change how quoted messages are shown in groups --- rfcs/2022-03-02-number-chat-items.md | 61 +++ simplex-chat.cabal | 1 + src/Simplex/Chat.hs | 218 +++++--- src/Simplex/Chat/Controller.hs | 4 + src/Simplex/Chat/Messages.hs | 83 ++- .../Chat/Migrations/M20220304_msg_quotes.hs | 24 + src/Simplex/Chat/Protocol.hs | 162 +++++- src/Simplex/Chat/Store.hs | 488 +++++++++++++----- src/Simplex/Chat/Terminal/Input.hs | 6 +- src/Simplex/Chat/View.hs | 122 +++-- tests/ChatClient.hs | 12 +- tests/ChatTests.hs | 171 ++++-- tests/ProtocolTests.hs | 43 +- 13 files changed, 1044 insertions(+), 351 deletions(-) create mode 100644 rfcs/2022-03-02-number-chat-items.md create mode 100644 src/Simplex/Chat/Migrations/M20220304_msg_quotes.hs diff --git a/rfcs/2022-03-02-number-chat-items.md b/rfcs/2022-03-02-number-chat-items.md new file mode 100644 index 0000000000..9f78c53e93 --- /dev/null +++ b/rfcs/2022-03-02-number-chat-items.md @@ -0,0 +1,61 @@ +# Message replies and chat item sequential numbers + +## Problem + +Many chat features require referring to the previous chat items in the same conversation: + +- item editing +- item deletion +- item reply (with quoting) +- delivery/read receipts +- any interactive features mutating chat item state +- group message integrity via DAG + +The most in-demand feature is replies. + +## Proposed solution + +As group message integrity is needed not for chat items, but for messages, the updated proposal is to introduce a random, non-sequential message id, unique per conversation and per sender. + +All above features would rely on this ID, e.g. reply would use the ID of the message that created the item. + +We will add an optional property `msgId` into all chat messages (not only visible to the users) and `msgRef` into messages that need to reference other messages. + +`msgId` property is a base64 encoded 12 byte binary + +JTD for quoting messages: + +```yaml +definitions: + msgRef: + discriminator: type + mapping: + direct: + properties: + msgId: type: string + sentAt: type: datetime + sent: type: boolean # true if it is in reference to the item that the sender of the message originally sent, false for references to received items + group: + properties: + msgId: type: string + sentAt: type: datetime + memberId: type: string # base64 member ID of the sender known to all group members for group chats + content: + properties: + type: type: string + text: type: string +properties: + msgId: string + event: enum: ["x.msg.new"] + params: + properties: + content: ref: content + quote: + properties: + content: ref: content + msgRef: ref: msgRef +``` + +This format ensures that replies with quoting show as normal messages on the clients that do not support showing quotes (`quote` property will be ignored). + +The only feature that would not work in case chatItem/chatItemRef is missing is navigating to the message to which the message is in reply to. diff --git a/simplex-chat.cabal b/simplex-chat.cabal index 0c89160605..0dba2634a4 100644 --- a/simplex-chat.cabal +++ b/simplex-chat.cabal @@ -31,6 +31,7 @@ library Simplex.Chat.Migrations.M20220224_messages_fks Simplex.Chat.Migrations.M20220301_smp_servers Simplex.Chat.Migrations.M20220302_profile_images + Simplex.Chat.Migrations.M20220304_msg_quotes Simplex.Chat.Mobile Simplex.Chat.Options Simplex.Chat.Protocol diff --git a/src/Simplex/Chat.hs b/src/Simplex/Chat.hs index 07ed69e933..c633f23d60 100644 --- a/src/Simplex/Chat.hs +++ b/src/Simplex/Chat.hs @@ -19,6 +19,7 @@ import Control.Monad.Except import Control.Monad.IO.Unlift import Control.Monad.Reader import Crypto.Random (drgNew) +import qualified Data.Aeson as J import Data.Attoparsec.ByteString.Char8 (Parser) import qualified Data.Attoparsec.ByteString.Char8 as A import Data.Bifunctor (first) @@ -56,7 +57,7 @@ import Simplex.Messaging.Encoding.String import Simplex.Messaging.Parsers (base64P, parseAll) import Simplex.Messaging.Protocol (ErrorType (..), MsgBody) import qualified Simplex.Messaging.Protocol as SMP -import Simplex.Messaging.Util (tryError) +import Simplex.Messaging.Util (tryError, (<$?>)) import System.Exit (exitFailure, exitSuccess) import System.FilePath (combine, splitExtensions, takeFileName) import System.IO (Handle, IOMode (..), SeekMode (..), hFlush, openFile, stdout) @@ -175,16 +176,37 @@ processChatCommand = \case APIGetChatItems _pagination -> pure $ chatCmdError "not implemented" APISendMessage cType chatId mc -> withUser $ \user@User {userId} -> withChatLock $ case cType of CTDirect -> do - ct@Contact {localDisplayName = c} <- withStore $ \st -> getContact st userId chatId - ci <- sendDirectChatItem userId ct (XMsgNew mc) (CISndMsgContent mc) - setActive $ ActiveC c - pure . CRNewChatItem $ AChatItem SCTDirect SMDSnd (DirectChat ct) ci + ct <- withStore $ \st -> getContact st userId chatId + sendNewMsg user ct (MCSimple mc) mc CTGroup -> do - group@(Group gInfo@GroupInfo {localDisplayName = gName, membership} _) <- withStore $ \st -> getGroup st user chatId + group@(Group GroupInfo {membership} _) <- withStore $ \st -> getGroup st user chatId unless (memberActive membership) $ throwChatError CEGroupMemberUserRemoved - ci <- sendGroupChatItem userId group (XMsgNew mc) (CISndMsgContent mc) - setActive $ ActiveG gName - pure . CRNewChatItem $ AChatItem SCTGroup SMDSnd (GroupChat gInfo) ci + sendNewGroupMsg user group (MCSimple mc) mc + CTContactRequest -> pure $ chatCmdError "not supported" + APISendMessageQuote cType chatId quotedItemId mc -> withUser $ \user@User {userId} -> withChatLock $ case cType of + CTDirect -> do + (ct, ci) <- withStore $ \st -> (,) <$> getContact st userId chatId <*> getDirectChatItem st userId chatId quotedItemId + case ci of + CChatItem _ (ChatItem {meta, content}) -> do + let CIMeta {itemTs, itemSharedMsgId} = meta + (qmc, sent) <- case content of + CISndMsgContent qmc -> pure (qmc, True) + CIRcvMsgContent qmc -> pure (qmc, False) + _ -> throwChatError CEInvalidQuote + let msgRef = MsgRefDirect {msgId = itemSharedMsgId, sentAt = itemTs, sent} + sendNewMsg user ct (MCQuote QuotedMsg {msgRef, content = qmc} mc) mc + CTGroup -> do + group@(Group GroupInfo {membership} _) <- withStore $ \st -> getGroup st user chatId + unless (memberActive membership) $ throwChatError CEGroupMemberUserRemoved + withStore (\st -> getGroupChatItem st user chatId quotedItemId) >>= \case + CChatItem _ (ChatItem {chatDir, meta, content}) -> do + let CIMeta {itemTs, itemSharedMsgId} = meta + (qmc, GroupMember {memberId}) <- case (content, chatDir) of + (CISndMsgContent qmc, _) -> pure (qmc, membership) + (CIRcvMsgContent qmc, CIGroupRcv m) -> pure (qmc, m) + _ -> throwChatError CEInvalidQuote + let msgRef = MsgRefGroup {msgId = itemSharedMsgId, sentAt = itemTs, memberId} + sendNewGroupMsg user group (MCQuote QuotedMsg {msgRef, content = qmc} mc) mc CTContactRequest -> pure $ chatCmdError "not supported" APIChatRead cType chatId fromToIds -> withChatLock $ case cType of CTDirect -> withStore (\st -> updateDirectChatItemsRead st chatId fromToIds) $> CRCmdOk @@ -264,6 +286,11 @@ processChatCommand = \case contactId <- withStore $ \st -> getContactIdByName st userId cName let mc = MCText $ safeDecodeUtf8 msg processChatCommand $ APISendMessage CTDirect contactId mc + SendMessageQuote cName (AMsgDirection msgDir) quotedMsg msg -> withUser $ \User {userId} -> do + contactId <- withStore $ \st -> getContactIdByName st userId cName + quotedItemId <- withStore $ \st -> getDirectChatItemIdByText st userId contactId msgDir (safeDecodeUtf8 quotedMsg) + let mc = MCText $ safeDecodeUtf8 msg + processChatCommand $ APISendMessageQuote CTDirect contactId quotedItemId mc NewGroup gProfile -> withUser $ \user -> do gVar <- asks idsDrg CRGroupCreated <$> withStore (\st -> createNewGroup st gVar user gProfile) @@ -339,14 +366,19 @@ processChatCommand = \case groupId <- withStore $ \st -> getGroupIdByName st user gName let mc = MCText $ safeDecodeUtf8 msg processChatCommand $ APISendMessage CTGroup groupId mc - SendFile cName f -> withUser $ \User {userId} -> withChatLock $ do + SendGroupMessageQuote gName cName quotedMsg msg -> withUser $ \user -> do + groupId <- withStore $ \st -> getGroupIdByName st user gName + quotedItemId <- withStore $ \st -> getGroupChatItemIdByText st user groupId cName (safeDecodeUtf8 quotedMsg) + let mc = MCText $ safeDecodeUtf8 msg + processChatCommand $ APISendMessageQuote CTGroup groupId quotedItemId mc + SendFile cName f -> withUser $ \user@User {userId} -> withChatLock $ do (fileSize, chSize) <- checkSndFile f contact <- withStore $ \st -> getContactByName st userId cName (agentConnId, fileConnReq) <- withAgent (`createConnection` SCMInvitation) let fileInv = FileInvitation {fileName = takeFileName f, fileSize, fileConnReq} SndFileTransfer {fileId} <- withStore $ \st -> createSndFileTransfer st userId contact f fileInv agentConnId chSize - ci <- sendDirectChatItem userId contact (XFile fileInv) (CISndFileInvitation fileId f) + ci <- sendDirectChatItem user contact (XFile fileInv) (CISndFileInvitation fileId f) withStore $ \st -> updateFileTransferChatItemId st fileId $ chatItemId' ci setActive $ ActiveC cName pure . CRNewChatItem $ AChatItem SCTDirect SMDSnd (DirectChat contact) ci @@ -363,11 +395,12 @@ processChatCommand = \case forM_ ms $ \(m, _, fileInv) -> traverse (\conn -> sendDirectMessage conn (XFile fileInv) (GroupId groupId)) $ memberConn m setActive $ ActiveG gName - -- this is a hack as we have multiple direct messages instead of one per group - let ciContent = CISndFileInvitation fileId f createdAt <- liftIO getCurrentTime - let ci = mkNewChatItem ciContent 0 createdAt createdAt - cItem@ChatItem {meta = CIMeta {itemId}} <- saveChatItem userId (CDGroupSnd gInfo) ci + -- this is a hack as we have multiple direct messages instead of one per group + let msg = Message {msgId = 0, direction = MDSnd, chatMsgEvent = XOk, sharedMsgId_ = Nothing, msgBody = ""} + ciContent = CISndFileInvitation fileId f + ci = mkNewChatItem ciContent msg createdAt createdAt + cItem@ChatItem {meta = CIMeta {itemId}} <- saveChatItem user (CDGroupSnd gInfo) ci withStore $ \st -> updateFileTransferChatItemId st fileId itemId pure . CRNewChatItem $ AChatItem SCTGroup SMDSnd (GroupChat gInfo) cItem ReceiveFile fileId filePath_ -> withUser $ \User {userId} -> do @@ -430,6 +463,15 @@ processChatCommand = \case connId <- withAgent $ \a -> joinConnection a cReq $ directMessage (XContact profile $ Just xContactId) withStore $ \st -> createConnReqConnection st userId connId cReqHash xContactId pure CRSentInvitation + sendNewMsg user ct@Contact {localDisplayName = c} msgContainer mc = do + ci <- sendDirectChatItem user ct (XMsgNew msgContainer) (CISndMsgContent mc) + setActive $ ActiveC c + pure . CRNewChatItem $ AChatItem SCTDirect SMDSnd (DirectChat ct) ci + sendNewGroupMsg user g@(Group gInfo@GroupInfo {localDisplayName = gName} _) msgContainer mc = do + ci <- sendGroupChatItem user g (XMsgNew msgContainer) (CISndMsgContent mc) + setActive $ ActiveG gName + pure . CRNewChatItem $ AChatItem SCTGroup SMDSnd (GroupChat gInfo) ci + contactMember :: Contact -> [GroupMember] -> Maybe GroupMember contactMember Contact {contactId} = find $ \GroupMember {memberContactId = cId, memberStatus = s} -> @@ -620,7 +662,7 @@ processAgentMessage (Just user@User {userId, profile}) agentConnId agentMessage INFO connInfo -> saveConnInfo conn connInfo MSG meta msgBody -> do - _ <- saveRcvMSG conn meta msgBody (ConnectionId connId) + _ <- saveRcvMSG conn (ConnectionId connId) meta msgBody withAckMessage agentConnId meta $ pure () ackMsgDeliveryEvent conn meta SENT msgId -> @@ -631,13 +673,13 @@ processAgentMessage (Just user@User {userId, profile}) agentConnId agentMessage ERR _ -> pure () -- TODO add debugging output _ -> pure () - Just ct@Contact {localDisplayName = c} -> case agentMsg of + Just ct@Contact {localDisplayName = c, contactId} -> case agentMsg of MSG msgMeta msgBody -> do - (msgId, chatMsgEvent) <- saveRcvMSG conn msgMeta msgBody (ConnectionId connId) + msg@Message {chatMsgEvent} <- saveRcvMSG conn (ConnectionId connId) msgMeta msgBody withAckMessage agentConnId msgMeta $ case chatMsgEvent of - XMsgNew mc -> newContentMessage ct mc msgId msgMeta - XFile fInv -> processFileInvitation ct fInv msgId msgMeta + XMsgNew mc -> newContentMessage ct mc msg msgMeta + XFile fInv -> processFileInvitation ct fInv msg msgMeta XInfo p -> xInfo ct p XGrpInv gInv -> processGroupInvitation ct gInv XInfoProbe probe -> xInfoProbe ct probe @@ -682,7 +724,7 @@ processAgentMessage (Just user@User {userId, profile}) agentConnId agentMessage case chatItemId_ of Nothing -> pure () Just chatItemId -> do - chatItem <- withStore $ \st -> updateDirectChatItem st chatItemId CISSndSent + chatItem <- withStore $ \st -> updateDirectChatItem st userId contactId chatItemId CISSndSent toView $ CRChatItemUpdated (AChatItem SCTDirect SMDSnd (DirectChat ct) chatItem) END -> do toView $ CRContactAnotherClient ct @@ -701,7 +743,7 @@ processAgentMessage (Just user@User {userId, profile}) agentConnId agentMessage case chatItemId_ of Nothing -> pure () Just chatItemId -> do - chatItem <- withStore $ \st -> updateDirectChatItem st chatItemId (agentErrToItemStatus err) + chatItem <- withStore $ \st -> updateDirectChatItem st userId contactId chatItemId (agentErrToItemStatus err) toView $ CRChatItemUpdated (AChatItem SCTDirect SMDSnd (DirectChat ct) chatItem) ERR _ -> pure () -- TODO add debugging output @@ -772,11 +814,11 @@ processAgentMessage (Just user@User {userId, profile}) agentConnId agentMessage notifyMemberConnected gInfo m when (memberCategory m == GCPreMember) $ probeMatchingContacts ct MSG msgMeta msgBody -> do - (msgId, chatMsgEvent) <- saveRcvMSG conn msgMeta msgBody (GroupId groupId) + msg@Message {chatMsgEvent} <- saveRcvMSG conn (GroupId groupId) msgMeta msgBody withAckMessage agentConnId msgMeta $ case chatMsgEvent of - XMsgNew mc -> newGroupContentMessage gInfo m mc msgId msgMeta - XFile fInv -> processGroupFileInvitation gInfo m fInv msgId msgMeta + XMsgNew mc -> newGroupContentMessage gInfo m mc msg msgMeta + XFile fInv -> processGroupFileInvitation gInfo m fInv msg msgMeta XGrpMemNew memInfo -> xGrpMemNew gInfo m memInfo XGrpMemIntro memInfo -> xGrpMemIntro conn gInfo m memInfo XGrpMemInv memId introInv -> xGrpMemInv gInfo m memId introInv @@ -945,39 +987,41 @@ processAgentMessage (Just user@User {userId, profile}) agentConnId agentMessage messageError :: Text -> m () messageError = toView . CRMessageError "error" - newContentMessage :: Contact -> MsgContent -> MessageId -> MsgMeta -> m () - newContentMessage ct@Contact {localDisplayName = c} mc msgId msgMeta = do - ci <- saveRcvChatItem userId (CDDirectRcv ct) msgId msgMeta (CIRcvMsgContent mc) + newContentMessage :: Contact -> MsgContainer -> Message -> MsgMeta -> m () + newContentMessage ct@Contact {localDisplayName = c} mc msg msgMeta = do + let content = mcContent mc + ci <- saveRcvChatItem user (CDDirectRcv ct) msg msgMeta (CIRcvMsgContent content) toView . CRNewChatItem $ AChatItem SCTDirect SMDRcv (DirectChat ct) ci checkIntegrity msgMeta $ toView . CRMsgIntegrityError - showToast (c <> "> ") $ msgContentText mc + showToast (c <> "> ") $ msgContentText content setActive $ ActiveC c - newGroupContentMessage :: GroupInfo -> GroupMember -> MsgContent -> MessageId -> MsgMeta -> m () - newGroupContentMessage gInfo m@GroupMember {localDisplayName = c} mc msgId msgMeta = do - ci <- saveRcvChatItem userId (CDGroupRcv gInfo m) msgId msgMeta (CIRcvMsgContent mc) + newGroupContentMessage :: GroupInfo -> GroupMember -> MsgContainer -> Message -> MsgMeta -> m () + newGroupContentMessage gInfo m@GroupMember {localDisplayName = c} mc msg msgMeta = do + let content = mcContent mc + ci <- saveRcvChatItem user (CDGroupRcv gInfo m) msg msgMeta (CIRcvMsgContent content) groupMsgToView gInfo ci msgMeta let g = groupName' gInfo - showToast ("#" <> g <> " " <> c <> "> ") $ msgContentText mc + showToast ("#" <> g <> " " <> c <> "> ") $ msgContentText content setActive $ ActiveG g - processFileInvitation :: Contact -> FileInvitation -> MessageId -> MsgMeta -> m () - processFileInvitation ct@Contact {localDisplayName = c} fInv msgId msgMeta = do + processFileInvitation :: Contact -> FileInvitation -> Message -> MsgMeta -> m () + processFileInvitation ct@Contact {localDisplayName = c} fInv msg msgMeta = do -- TODO chunk size has to be sent as part of invitation chSize <- asks $ fileChunkSize . config ft@RcvFileTransfer {fileId} <- withStore $ \st -> createRcvFileTransfer st userId ct fInv chSize - ci <- saveRcvChatItem userId (CDDirectRcv ct) msgId msgMeta (CIRcvFileInvitation ft) + ci <- saveRcvChatItem user (CDDirectRcv ct) msg msgMeta (CIRcvFileInvitation ft) withStore $ \st -> updateFileTransferChatItemId st fileId $ chatItemId' ci toView . CRNewChatItem $ AChatItem SCTDirect SMDRcv (DirectChat ct) ci checkIntegrity msgMeta $ toView . CRMsgIntegrityError showToast (c <> "> ") "wants to send a file" setActive $ ActiveC c - processGroupFileInvitation :: GroupInfo -> GroupMember -> FileInvitation -> MessageId -> MsgMeta -> m () - processGroupFileInvitation gInfo m@GroupMember {localDisplayName = c} fInv msgId msgMeta = do + processGroupFileInvitation :: GroupInfo -> GroupMember -> FileInvitation -> Message -> MsgMeta -> m () + processGroupFileInvitation gInfo m@GroupMember {localDisplayName = c} fInv msg msgMeta = do chSize <- asks $ fileChunkSize . config ft@RcvFileTransfer {fileId} <- withStore $ \st -> createRcvGroupFileTransfer st userId m fInv chSize - ci <- saveRcvChatItem userId (CDGroupRcv gInfo m) msgId msgMeta (CIRcvFileInvitation ft) + ci <- saveRcvChatItem user (CDGroupRcv gInfo m) msg msgMeta (CIRcvFileInvitation ft) withStore $ \st -> updateFileTransferChatItemId st fileId $ chatItemId' ci groupMsgToView gInfo ci msgMeta let g = groupName' gInfo @@ -1254,27 +1298,27 @@ deleteMemberConnection m@GroupMember {activeConn} = do -- withStore $ \st -> deleteGroupMemberConnection st userId m forM_ activeConn $ \conn -> withStore $ \st -> updateConnectionStatus st conn ConnDeleted -sendDirectContactMessage :: ChatMonad m => Contact -> ChatMsgEvent -> m MessageId +sendDirectContactMessage :: ChatMonad m => Contact -> ChatMsgEvent -> m SndMessage sendDirectContactMessage ct@Contact {activeConn = conn@Connection {connId, connStatus}} chatMsgEvent = do if connStatus == ConnReady || connStatus == ConnSndReady then sendDirectMessage conn chatMsgEvent (ConnectionId connId) else throwChatError $ CEContactNotReady ct -sendDirectMessage :: ChatMonad m => Connection -> ChatMsgEvent -> ConnOrGroupId -> m MessageId +sendDirectMessage :: ChatMonad m => Connection -> ChatMsgEvent -> ConnOrGroupId -> m SndMessage sendDirectMessage conn chatMsgEvent connOrGroupId = do - (msgId, msgBody) <- createSndMessage chatMsgEvent connOrGroupId + msg@SndMessage {msgId, msgBody} <- createSndMessage chatMsgEvent connOrGroupId deliverMessage conn msgBody msgId - pure msgId + pure msg -createSndMessage :: ChatMonad m => ChatMsgEvent -> ConnOrGroupId -> m (MessageId, MsgBody) +createSndMessage :: ChatMonad m => ChatMsgEvent -> ConnOrGroupId -> m SndMessage createSndMessage chatMsgEvent connOrGroupId = do - let msgBody = directMessage chatMsgEvent - newMsg = NewMessage {direction = MDSnd, cmEventTag = toCMEventTag chatMsgEvent, msgBody} - msgId <- withStore $ \st -> createNewMessage st newMsg connOrGroupId - pure (msgId, msgBody) + gVar <- asks idsDrg + withStore $ \st -> createNewSndMessage st gVar connOrGroupId $ \sharedMsgId -> + let msgBody = strEncode ChatMessage {msgId = Just sharedMsgId, chatMsgEvent} + in NewMessage {direction = MDSnd, chatMsgEvent, msgBody} directMessage :: ChatMsgEvent -> ByteString -directMessage chatMsgEvent = strEncode ChatMessage {chatMsgEvent} +directMessage chatMsgEvent = strEncode ChatMessage {msgId = Nothing, chatMsgEvent} deliverMessage :: ChatMonad m => Connection -> MsgBody -> MessageId -> m () deliverMessage conn@Connection {connId} msgBody msgId = do @@ -1282,18 +1326,18 @@ deliverMessage conn@Connection {connId} msgBody msgId = do let sndMsgDelivery = SndMsgDelivery {connId, agentMsgId} withStore $ \st -> createSndMsgDelivery st sndMsgDelivery msgId -sendGroupMessage :: ChatMonad m => GroupInfo -> [GroupMember] -> ChatMsgEvent -> m MessageId +sendGroupMessage :: ChatMonad m => GroupInfo -> [GroupMember] -> ChatMsgEvent -> m SndMessage sendGroupMessage GroupInfo {groupId} members chatMsgEvent = sendGroupMessage' members chatMsgEvent groupId Nothing $ pure () -sendXGrpMemInv :: ChatMonad m => GroupInfo -> GroupMember -> ChatMsgEvent -> Int64 -> m MessageId +sendXGrpMemInv :: ChatMonad m => GroupInfo -> GroupMember -> ChatMsgEvent -> Int64 -> m SndMessage sendXGrpMemInv GroupInfo {groupId} reMember chatMsgEvent introId = sendGroupMessage' [reMember] chatMsgEvent groupId (Just introId) $ withStore (\st -> updateIntroStatus st introId GMIntroInvForwarded) -sendGroupMessage' :: ChatMonad m => [GroupMember] -> ChatMsgEvent -> Int64 -> Maybe Int64 -> m () -> m MessageId +sendGroupMessage' :: ChatMonad m => [GroupMember] -> ChatMsgEvent -> Int64 -> Maybe Int64 -> m () -> m SndMessage sendGroupMessage' members chatMsgEvent groupId introId_ postDeliver = do - (msgId, msgBody) <- createSndMessage chatMsgEvent (GroupId groupId) + msg@SndMessage {msgId, msgBody} <- createSndMessage chatMsgEvent (GroupId groupId) -- TODO collect failed deliveries into a single error forM_ (filter memberCurrent members) $ \m@GroupMember {groupMemberId} -> case memberConn m of @@ -1302,7 +1346,7 @@ sendGroupMessage' members chatMsgEvent groupId introId_ postDeliver = do if not (connStatus == ConnSndReady || connStatus == ConnReady) then unless (connStatus == ConnDeleted) $ withStore (\st -> createPendingGroupMessage st groupMemberId msgId introId_) else (deliverMessage conn msgBody msgId >> postDeliver) `catchError` const (pure ()) - pure msgId + pure msg sendPendingGroupMessages :: ChatMonad m => GroupMember -> Connection -> m () sendPendingGroupMessages GroupMember {groupMemberId, localDisplayName} conn = do @@ -1315,45 +1359,43 @@ sendPendingGroupMessages GroupMember {groupMemberId, localDisplayName} conn = do Nothing -> throwChatError $ CEGroupMemberIntroNotFound localDisplayName Just introId -> withStore (\st -> updateIntroStatus st introId GMIntroInvForwarded) -saveRcvMSG :: ChatMonad m => Connection -> MsgMeta -> MsgBody -> ConnOrGroupId -> m (MessageId, ChatMsgEvent) -saveRcvMSG Connection {connId} agentMsgMeta msgBody connOrGroupId = do - ChatMessage {chatMsgEvent} <- liftEither $ parseChatMessage msgBody +saveRcvMSG :: ChatMonad m => Connection -> ConnOrGroupId -> MsgMeta -> MsgBody -> m Message +saveRcvMSG Connection {connId} connOrGroupId agentMsgMeta msgBody = do + ChatMessage {msgId = sharedMsgId_, chatMsgEvent} <- liftEither $ parseChatMessage msgBody let agentMsgId = fst $ recipient agentMsgMeta - cmEventTag = toCMEventTag chatMsgEvent - newMsg = NewMessage {direction = MDRcv, cmEventTag, msgBody} + newMsg = NewMessage {direction = MDRcv, chatMsgEvent, msgBody} rcvMsgDelivery = RcvMsgDelivery {connId, agentMsgId, agentMsgMeta} - msgId <- withStore $ \st -> createNewMessageAndRcvMsgDelivery st newMsg connOrGroupId rcvMsgDelivery - pure (msgId, chatMsgEvent) + withStore $ \st -> createNewMessageAndRcvMsgDelivery st connOrGroupId newMsg sharedMsgId_ rcvMsgDelivery -sendDirectChatItem :: ChatMonad m => UserId -> Contact -> ChatMsgEvent -> CIContent 'MDSnd -> m (ChatItem 'CTDirect 'MDSnd) -sendDirectChatItem userId ct chatMsgEvent ciContent = do - msgId <- sendDirectContactMessage ct chatMsgEvent - saveSndChatItem userId (CDDirectSnd ct) msgId ciContent +sendDirectChatItem :: ChatMonad m => User -> Contact -> ChatMsgEvent -> CIContent 'MDSnd -> m (ChatItem 'CTDirect 'MDSnd) +sendDirectChatItem user ct chatMsgEvent ciContent = do + msg <- sendDirectContactMessage ct chatMsgEvent + saveSndChatItem user (CDDirectSnd ct) msg ciContent -sendGroupChatItem :: ChatMonad m => UserId -> Group -> ChatMsgEvent -> CIContent 'MDSnd -> m (ChatItem 'CTGroup 'MDSnd) -sendGroupChatItem userId (Group g ms) chatMsgEvent ciContent = do - msgId <- sendGroupMessage g ms chatMsgEvent - saveSndChatItem userId (CDGroupSnd g) msgId ciContent +sendGroupChatItem :: ChatMonad m => User -> Group -> ChatMsgEvent -> CIContent 'MDSnd -> m (ChatItem 'CTGroup 'MDSnd) +sendGroupChatItem user (Group g ms) chatMsgEvent ciContent = do + msg <- sendGroupMessage g ms chatMsgEvent + saveSndChatItem user (CDGroupSnd g) msg ciContent -saveSndChatItem :: ChatMonad m => UserId -> ChatDirection c 'MDSnd -> MessageId -> CIContent 'MDSnd -> m (ChatItem c 'MDSnd) -saveSndChatItem userId cd msgId ciContent = do +saveSndChatItem :: ChatMonad m => User -> ChatDirection c 'MDSnd -> SndMessage -> CIContent 'MDSnd -> m (ChatItem c 'MDSnd) +saveSndChatItem user cd msg ciContent = do createdAt <- liftIO getCurrentTime - saveChatItem userId cd $ mkNewChatItem ciContent msgId createdAt createdAt + saveChatItem user cd $ mkNewChatItem ciContent (anyMessage msg) createdAt createdAt -saveRcvChatItem :: ChatMonad m => UserId -> ChatDirection c 'MDRcv -> MessageId -> MsgMeta -> CIContent 'MDRcv -> m (ChatItem c 'MDRcv) -saveRcvChatItem userId cd msgId MsgMeta {broker = (_, brokerTs)} ciContent = do +saveRcvChatItem :: ChatMonad m => User -> ChatDirection c 'MDRcv -> Message -> MsgMeta -> CIContent 'MDRcv -> m (ChatItem c 'MDRcv) +saveRcvChatItem user cd msg MsgMeta {broker = (_, brokerTs)} ciContent = do createdAt <- liftIO getCurrentTime - saveChatItem userId cd $ mkNewChatItem ciContent msgId brokerTs createdAt + saveChatItem user cd $ mkNewChatItem ciContent msg brokerTs createdAt -saveChatItem :: (ChatMonad m, MsgDirectionI d) => UserId -> ChatDirection c d -> NewChatItem d -> m (ChatItem c d) -saveChatItem userId cd ci@NewChatItem {itemContent, itemTs, itemText, createdAt} = do +saveChatItem :: (ChatMonad m, MsgDirectionI d) => User -> ChatDirection c d -> NewChatItem d -> m (ChatItem c d) +saveChatItem user cd ci@NewChatItem {itemContent = content, itemTs, itemText, itemSharedMsgId, createdAt} = do tz <- liftIO getCurrentTimeZone - ciId <- withStore $ \st -> createNewChatItem st userId cd ci - let ciMeta = mkCIMeta ciId itemText ciStatusNew tz itemTs createdAt - pure $ ChatItem (toCIDirection cd) ciMeta itemContent $ parseMaybeMarkdownList itemText + (ciId, quotedItem) <- withStore $ \st -> createNewChatItem st user cd ci + let meta = mkCIMeta ciId itemText ciStatusNew itemSharedMsgId tz itemTs createdAt + pure $ ChatItem {chatDir = toCIDirection cd, meta, content, formattedText = parseMaybeMarkdownList itemText, quotedItem} -mkNewChatItem :: forall d. MsgDirectionI d => CIContent d -> MessageId -> UTCTime -> UTCTime -> NewChatItem d -mkNewChatItem itemContent msgId itemTs createdAt = +mkNewChatItem :: forall d. MsgDirectionI d => CIContent d -> Message -> UTCTime -> UTCTime -> NewChatItem d +mkNewChatItem itemContent Message {msgId, chatMsgEvent, sharedMsgId_ = itemSharedMsgId} itemTs createdAt = NewChatItem { createdByMsgId = if msgId == 0 then Nothing else Just msgId, itemSent = msgDirection @d, @@ -1361,6 +1403,8 @@ mkNewChatItem itemContent msgId itemTs createdAt = itemContent, itemText = ciContentToText itemContent, itemStatus = ciStatusNew, + itemSharedMsgId, + itemQuotedMsg = cmToQuotedMsg chatMsgEvent, createdAt } @@ -1473,6 +1517,7 @@ chatCommandP = <|> "/_get chat " *> (APIGetChat <$> chatTypeP <*> A.decimal <* A.space <*> chatPaginationP) <|> "/_get items count=" *> (APIGetChatItems <$> A.decimal) <|> "/_send " *> (APISendMessage <$> chatTypeP <*> A.decimal <* A.space <*> msgContentP) + <|> "/_send_quote" *> (APISendMessageQuote <$> chatTypeP <*> A.decimal <* A.space <*> A.decimal <* A.space <*> msgContentP) <|> "/_read chat " *> (APIChatRead <$> chatTypeP <*> A.decimal <* A.space <*> ((,) <$> ("from=" *> A.decimal) <* A.space <*> ("to=" *> A.decimal))) <|> "/_delete " *> (APIDeleteChat <$> chatTypeP <*> A.decimal) <|> "/_accept " *> (APIAcceptContact <$> A.decimal) @@ -1493,11 +1538,14 @@ chatCommandP = <|> ("/members #" <|> "/members " <|> "/ms #" <|> "/ms ") *> (ListMembers <$> displayName) <|> ("/groups" <|> "/gs") $> ListGroups <|> A.char '#' *> (SendGroupMessage <$> displayName <* A.space <*> A.takeByteString) + <|> (">#" <|> "> #") *> (SendGroupMessageQuote <$> displayName <* (" @" <|> " ") <*> displayName <* A.space <*> quotedMsg <*> A.takeByteString) <|> ("/contacts" <|> "/cs") $> ListContacts <|> ("/connect " <|> "/c ") *> (Connect <$> ((Just <$> strP) <|> A.takeByteString $> Nothing)) <|> ("/connect" <|> "/c") $> AddContact <|> ("/delete @" <|> "/delete " <|> "/d @" <|> "/d ") *> (DeleteContact <$> displayName) <|> A.char '@' *> (SendMessage <$> displayName <* A.space <*> A.takeByteString) + <|> (">@" <|> "> @") *> sendMsgQuote (AMsgDirection SMDRcv) + <|> (">>@" <|> ">> @") *> sendMsgQuote (AMsgDirection SMDSnd) <|> ("/file #" <|> "/f #") *> (SendGroupFile <$> displayName <* A.space <*> filePath) <|> ("/file @" <|> "/file " <|> "/f @" <|> "/f ") *> (SendFile <$> displayName <* A.space <*> filePath) <|> ("/freceive " <|> "/fr ") *> (ReceiveFile <$> A.decimal <*> optional (A.space *> filePath)) @@ -1525,8 +1573,12 @@ chatCommandP = (CPLast <$ "count=" <*> A.decimal) <|> (CPAfter <$ "after=" <*> A.decimal <* A.space <* "count=" <*> A.decimal) <|> (CPBefore <$ "before=" <*> A.decimal <* A.space <* "count=" <*> A.decimal) - msgContentP = "text " *> (MCText . safeDecodeUtf8 <$> A.takeByteString) + msgContentP = + "text " *> (MCText . safeDecodeUtf8 <$> A.takeByteString) + <|> "json " *> (J.eitherDecodeStrict' <$?> A.takeByteString) displayName = safeDecodeUtf8 <$> (B.cons <$> A.satisfy refChar <*> A.takeTill (== ' ')) + sendMsgQuote msgDir = (SendMessageQuote <$> displayName <* A.space <*> pure msgDir <*> quotedMsg <*> A.takeByteString) + quotedMsg = A.char '(' *> A.takeTill (== ')') <* A.char ')' <* optional A.space refChar c = c > ' ' && c /= '#' && c /= '@' onOffP = ("on" $> True) <|> ("off" $> False) userNames = do diff --git a/src/Simplex/Chat/Controller.hs b/src/Simplex/Chat/Controller.hs index a9d04f87bd..9d6c82d2e7 100644 --- a/src/Simplex/Chat/Controller.hs +++ b/src/Simplex/Chat/Controller.hs @@ -91,6 +91,7 @@ data ChatCommand | APIGetChat ChatType Int64 ChatPagination | APIGetChatItems Int | APISendMessage ChatType Int64 MsgContent + | APISendMessageQuote ChatType Int64 ChatItemId MsgContent | APIChatRead ChatType Int64 (ChatItemId, ChatItemId) | APIDeleteChat ChatType Int64 | APIAcceptContact Int64 @@ -111,6 +112,7 @@ data ChatCommand | AcceptContact ContactName | RejectContact ContactName | SendMessage ContactName ByteString + | SendMessageQuote {contactName :: ContactName, msgDir :: AMsgDirection, quotedMsg :: ByteString, message :: ByteString} | NewGroup GroupProfile | AddMember GroupName ContactName GroupMemberRole | JoinGroup GroupName @@ -121,6 +123,7 @@ data ChatCommand | ListMembers GroupName | ListGroups | SendGroupMessage GroupName ByteString + | SendGroupMessageQuote {groupName :: GroupName, contactName :: ContactName, quotedMsg :: ByteString, message :: ByteString} | SendFile ContactName FilePath | SendGroupFile GroupName FilePath | ReceiveFile FileTransferId (Maybe FilePath) @@ -289,6 +292,7 @@ data ChatErrorType | CEFileSend {fileId :: FileTransferId, agentError :: AgentErrorType} | CEFileRcvChunk {message :: String} | CEFileInternal {message :: String} + | CEInvalidQuote | CEAgentVersion | CECommandError {message :: String} deriving (Show, Exception, Generic) diff --git a/src/Simplex/Chat/Messages.hs b/src/Simplex/Chat/Messages.hs index 1a136d5efb..e093648615 100644 --- a/src/Simplex/Chat/Messages.hs +++ b/src/Simplex/Chat/Messages.hs @@ -7,6 +7,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeApplications #-} @@ -78,7 +79,8 @@ data ChatItem (c :: ChatType) (d :: MsgDirection) = ChatItem { chatDir :: CIDirection c d, meta :: CIMeta d, content :: CIContent d, - formattedText :: Maybe [FormattedText] + formattedText :: Maybe MarkdownList, + quotedItem :: Maybe (CIQuote c) } deriving (Show, Generic) @@ -150,6 +152,8 @@ data NewChatItem d = NewChatItem itemContent :: CIContent d, itemText :: Text, itemStatus :: CIStatus d, + itemSharedMsgId :: Maybe SharedMsgId, + itemQuotedMsg :: Maybe QuotedMsg, createdAt :: UTCTime } deriving (Show) @@ -205,18 +209,55 @@ data CIMeta (d :: MsgDirection) = CIMeta itemTs :: ChatItemTs, itemText :: Text, itemStatus :: CIStatus d, + itemSharedMsgId :: Maybe SharedMsgId, localItemTs :: ZonedTime, createdAt :: UTCTime } deriving (Show, Generic) -mkCIMeta :: ChatItemId -> Text -> CIStatus d -> TimeZone -> ChatItemTs -> UTCTime -> CIMeta d -mkCIMeta itemId itemText itemStatus tz itemTs createdAt = +mkCIMeta :: ChatItemId -> Text -> CIStatus d -> Maybe SharedMsgId -> TimeZone -> ChatItemTs -> UTCTime -> CIMeta d +mkCIMeta itemId itemText itemStatus itemSharedMsgId tz itemTs createdAt = let localItemTs = utcToZonedTime tz itemTs - in CIMeta {itemId, itemTs, itemText, itemStatus, localItemTs, createdAt} + in CIMeta {itemId, itemTs, itemText, itemStatus, itemSharedMsgId, localItemTs, createdAt} instance ToJSON (CIMeta d) where toEncoding = J.genericToEncoding J.defaultOptions +data CIQuoteData = CIQuoteData + { itemId :: Maybe ChatItemId, + sentAt :: UTCTime, + content :: MsgContent, + formattedText :: Maybe MarkdownList + } + deriving (Show, Generic) + +instance ToJSON CIQuoteData where + toJSON = J.genericToJSON J.defaultOptions {J.omitNothingFields = True} + toEncoding = J.genericToEncoding J.defaultOptions {J.omitNothingFields = True} + +data CIQuote (c :: ChatType) where + CIQuoteDirect :: CIQuoteData -> Bool -> CIQuote 'CTDirect + CIQuoteGroup :: CIQuoteData -> GroupMember -> CIQuote 'CTGroup + +deriving instance Show (CIQuote c) + +instance ToJSON (CIQuote c) where + toJSON = J.toJSON . jsonCIQuote + toEncoding = J.toEncoding . jsonCIQuote + +data JSONCIQuote + = JCIQuoteDirect {quote :: CIQuoteData, sent :: Bool} + | JCIQuoteGroup {quote :: CIQuoteData, member :: GroupMember} + deriving (Show, Generic) + +instance ToJSON JSONCIQuote where + toJSON = J.genericToJSON . sumTypeJSON $ dropPrefix "JCIQuote" + toEncoding = J.genericToEncoding . sumTypeJSON $ dropPrefix "JCIQuote" + +jsonCIQuote :: CIQuote c -> JSONCIQuote +jsonCIQuote = \case + CIQuoteDirect quote sent -> JCIQuoteDirect {quote, sent} + CIQuoteGroup quote member -> JCIQuoteGroup {quote, member} + data CIStatus (d :: MsgDirection) where CISSndNew :: CIStatus 'MDSnd CISSndSent :: CIStatus 'MDSnd @@ -242,6 +283,8 @@ instance FromField ACIStatus where fromField = fromTextField_ $ eitherToMaybe . data ACIStatus = forall d. MsgDirectionI d => ACIStatus (SMsgDirection d) (CIStatus d) +deriving instance Show ACIStatus + instance MsgDirectionI d => StrEncoding (CIStatus d) where strEncode = \case CISSndNew -> "snd_new" @@ -322,6 +365,8 @@ instance ToJSON (CIContent d) where data ACIContent = forall d. ACIContent (SMsgDirection d) (CIContent d) +deriving instance Show ACIContent + -- platform specific instance FromJSON ACIContent where parseJSON = fmap aciContentJSON . J.parseJSON @@ -408,11 +453,30 @@ instance ChatTypeI 'CTGroup where chatType = SCTGroup data NewMessage = NewMessage { direction :: MsgDirection, - cmEventTag :: CMEventTag, + chatMsgEvent :: ChatMsgEvent, msgBody :: MsgBody } deriving (Show) +data SndMessage = SndMessage + { msgId :: MessageId, + direction :: MsgDirection, + chatMsgEvent :: ChatMsgEvent, + sharedMsgId :: SharedMsgId, + msgBody :: MsgBody + } + +data Message = Message + { msgId :: MessageId, + direction :: MsgDirection, + chatMsgEvent :: ChatMsgEvent, + sharedMsgId_ :: Maybe SharedMsgId, + msgBody :: MsgBody + } + +anyMessage :: SndMessage -> Message +anyMessage SndMessage {..} = Message {msgId, direction, chatMsgEvent, sharedMsgId_ = Just sharedMsgId, msgBody} + data PendingGroupMessage = PendingGroupMessage { msgId :: MessageId, cmEventTag :: CMEventTag, @@ -449,11 +513,20 @@ instance TestEquality SMsgDirection where instance ToField (SMsgDirection d) where toField = toField . msgDirectionInt . toMsgDirection +data AMsgDirection = forall d. MsgDirectionI d => AMsgDirection (SMsgDirection d) + +deriving instance Show AMsgDirection + toMsgDirection :: SMsgDirection d -> MsgDirection toMsgDirection = \case SMDRcv -> MDRcv SMDSnd -> MDSnd +fromMsgDirection :: MsgDirection -> AMsgDirection +fromMsgDirection = \case + MDRcv -> AMsgDirection SMDRcv + MDSnd -> AMsgDirection SMDSnd + class MsgDirectionI (d :: MsgDirection) where msgDirection :: SMsgDirection d diff --git a/src/Simplex/Chat/Migrations/M20220304_msg_quotes.hs b/src/Simplex/Chat/Migrations/M20220304_msg_quotes.hs new file mode 100644 index 0000000000..897f6554ab --- /dev/null +++ b/src/Simplex/Chat/Migrations/M20220304_msg_quotes.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE QuasiQuotes #-} + +module Simplex.Chat.Migrations.M20220304_msg_quotes where + +import Database.SQLite.Simple (Query) +import Database.SQLite.Simple.QQ (sql) + +m20220304_msg_quotes :: Query +m20220304_msg_quotes = + [sql| + ALTER TABLE messages ADD COLUMN shared_msg_id BLOB; + ALTER TABLE messages ADD COLUMN shared_msg_id_user INTEGER; -- 1 for user messages, NULL for received messages + CREATE INDEX idx_messages_shared_msg_id ON messages (shared_msg_id); + CREATE UNIQUE INDEX idx_messages_direct_shared_msg_id ON messages (connection_id, shared_msg_id_user, shared_msg_id); + CREATE UNIQUE INDEX idx_messages_group_shared_msg_id ON messages (group_id, shared_msg_id_user, shared_msg_id); + + ALTER TABLE chat_items ADD COLUMN shared_msg_id BLOB; + ALTER TABLE chat_items ADD COLUMN quoted_shared_msg_id BLOB; -- from MessageRef in QuotedMsg + ALTER TABLE chat_items ADD COLUMN quoted_sent_at TEXT; -- from MessageRef in QuotedMsg + ALTER TABLE chat_items ADD COLUMN quoted_content TEXT; -- from MsgContent in QuotedMsg (JSON) + ALTER TABLE chat_items ADD COLUMN quoted_sent INTEGER; -- from MessageRef, 1 for sent, 0 for received, NULL for group items (or not reply messages) + ALTER TABLE chat_items ADD COLUMN quoted_member_id BLOB; -- from MessageRef + CREATE INDEX idx_chat_items_shared_msg_id ON chat_items (shared_msg_id); +|] diff --git a/src/Simplex/Chat/Protocol.hs b/src/Simplex/Chat/Protocol.hs index ace8eeb06c..bd308ec0f2 100644 --- a/src/Simplex/Chat/Protocol.hs +++ b/src/Simplex/Chat/Protocol.hs @@ -12,6 +12,7 @@ module Simplex.Chat.Protocol where +import Control.Applicative ((<|>)) import Control.Monad ((<=<)) import Data.Aeson (FromJSON, ToJSON, (.:), (.:?), (.=)) import qualified Data.Aeson as J @@ -19,17 +20,20 @@ import qualified Data.Aeson.Encoding as JE import qualified Data.Aeson.KeyMap as JM import qualified Data.Aeson.Types as JT import qualified Data.Attoparsec.ByteString.Char8 as A +import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Lazy.Char8 as LB import Data.Maybe (fromMaybe) import Data.Text (Text) import Data.Text.Encoding (decodeLatin1, encodeUtf8) +import Data.Time.Clock (UTCTime) import Database.SQLite.Simple.FromField (FromField (..)) import Database.SQLite.Simple.ToField (ToField (..)) import GHC.Generics (Generic) import Simplex.Chat.Types -import Simplex.Chat.Util (eitherToMaybe) +import Simplex.Chat.Util (eitherToMaybe, safeDecodeUtf8) import Simplex.Messaging.Agent.Store.SQLite (fromTextField_) import Simplex.Messaging.Encoding.String +import Simplex.Messaging.Parsers (dropPrefix, taggedObjectJSON) import Simplex.Messaging.Util ((<$?>)) data ConnectionEntity @@ -52,14 +56,59 @@ updateEntityConnStatus connEntity connStatus = case connEntity of -- chat message is sent as JSON with these properties data AppMessage = AppMessage - { event :: Text, + { msgId :: Maybe SharedMsgId, + event :: Text, params :: J.Object } deriving (Generic, FromJSON) -instance ToJSON AppMessage where toEncoding = J.genericToEncoding J.defaultOptions {J.omitNothingFields = True} +instance ToJSON AppMessage where + toEncoding = J.genericToEncoding J.defaultOptions {J.omitNothingFields = True} + toJSON = J.genericToJSON J.defaultOptions {J.omitNothingFields = True} -newtype ChatMessage = ChatMessage {chatMsgEvent :: ChatMsgEvent} +newtype SharedMsgId = SharedMsgId ByteString + deriving (Eq, Show) + +instance FromField SharedMsgId where fromField f = SharedMsgId <$> fromField f + +instance ToField SharedMsgId where toField (SharedMsgId m) = toField m + +instance StrEncoding SharedMsgId where + strEncode (SharedMsgId m) = strEncode m + strDecode s = SharedMsgId <$> strDecode s + strP = SharedMsgId <$> strP + +instance FromJSON SharedMsgId where + parseJSON = strParseJSON "SharedMsgId" + +instance ToJSON SharedMsgId where + toJSON = strToJSON + toEncoding = strToJEncoding + +data MessageRef + = MsgRefDirect + { msgId :: Maybe SharedMsgId, + sentAt :: UTCTime, + sent :: Bool + } + | MsgRefGroup + { msgId :: Maybe SharedMsgId, + sentAt :: UTCTime, + memberId :: MemberId + } + deriving (Eq, Show, Generic) + +msgRefJSONOpts :: J.Options +msgRefJSONOpts = taggedObjectJSON $ dropPrefix "MsgRef" + +instance FromJSON MessageRef where + parseJSON = J.genericParseJSON msgRefJSONOpts + +instance ToJSON MessageRef where + toJSON = J.genericToJSON msgRefJSONOpts + toEncoding = J.genericToEncoding msgRefJSONOpts + +data ChatMessage = ChatMessage {msgId :: Maybe SharedMsgId, chatMsgEvent :: ChatMsgEvent} deriving (Eq, Show) instance StrEncoding ChatMessage where @@ -68,7 +117,7 @@ instance StrEncoding ChatMessage where strP = strDecode <$?> A.takeByteString data ChatMsgEvent - = XMsgNew MsgContent + = XMsgNew MsgContainer | XFile FileInvitation | XFileAcpt String | XInfo Profile @@ -89,58 +138,107 @@ data ChatMsgEvent | XInfoProbeCheck ProbeHash | XInfoProbeOk Probe | XOk + | XUnknown {event :: Text, params :: J.Object} deriving (Eq, Show) -data MsgContentType = MCText_ | MCUnknown_ +data QuotedMsg = QuotedMsg {msgRef :: MessageRef, content :: MsgContent} + deriving (Eq, Show, Generic, FromJSON) -instance StrEncoding MsgContentType where +instance ToJSON QuotedMsg where + toEncoding = J.genericToEncoding J.defaultOptions + toJSON = J.genericToJSON J.defaultOptions + +cmToQuotedMsg :: ChatMsgEvent -> Maybe QuotedMsg +cmToQuotedMsg = \case + XMsgNew (MCQuote quotedMsg _) -> Just quotedMsg + _ -> Nothing + +data MsgContentTag = MCText_ | MCUnknown_ Text + +instance StrEncoding MsgContentTag where strEncode = \case MCText_ -> "text" - MCUnknown_ -> "text" + MCUnknown_ t -> encodeUtf8 t strDecode = \case "text" -> Right MCText_ - _ -> Right MCUnknown_ + t -> Right . MCUnknown_ $ safeDecodeUtf8 t strP = strDecode <$?> A.takeTill (== ' ') -instance FromJSON MsgContentType where +instance FromJSON MsgContentTag where parseJSON = strParseJSON "MsgContentType" -instance ToJSON MsgContentType where +instance ToJSON MsgContentTag where toJSON = strToJSON toEncoding = strToJEncoding -data MsgContent = MCText Text | MCUnknown J.Value Text +data MsgContainer + = MCSimple MsgContent + | MCQuote QuotedMsg MsgContent + | MCForward MsgContent + deriving (Eq, Show) + +mcContent :: MsgContainer -> MsgContent +mcContent = \case + MCSimple c -> c + MCQuote _ c -> c + MCForward c -> c + +data MsgContent + = MCText Text + | MCUnknown {tag :: Text, text :: Text, json :: J.Object} deriving (Eq, Show) msgContentText :: MsgContent -> Text msgContentText = \case MCText t -> t - MCUnknown _ t -> t + MCUnknown {text} -> text -toMsgContentType :: MsgContent -> MsgContentType -toMsgContentType = \case +msgContentTag :: MsgContent -> MsgContentTag +msgContentTag = \case MCText _ -> MCText_ - MCUnknown {} -> MCUnknown_ + MCUnknown {tag} -> MCUnknown_ tag + +parseMsgContainer :: J.Object -> JT.Parser MsgContainer +parseMsgContainer v = + MCQuote <$> v .: "quote" <*> mc + <|> (v .: "forward" >>= \f -> (if f then MCForward else MCSimple) <$> mc) + <|> MCSimple <$> mc + where + mc = v .: "content" instance FromJSON MsgContent where - parseJSON jv@(J.Object v) = do + parseJSON (J.Object v) = v .: "type" >>= \case MCText_ -> MCText <$> v .: "text" - MCUnknown_ -> MCUnknown jv . fromMaybe unknownMsgType <$> v .:? "text" + MCUnknown_ tag -> do + text <- fromMaybe unknownMsgType <$> v .:? "text" + pure MCUnknown {tag, text, json = v} parseJSON invalid = JT.prependFailure "bad MsgContent, " (JT.typeMismatch "Object" invalid) unknownMsgType :: Text unknownMsgType = "unknown message type" +msgContainerJSON :: MsgContainer -> J.Object +msgContainerJSON = \case + MCQuote qm c -> JM.fromList ["quote" .= qm, "content" .= c] + MCForward c -> JM.fromList ["forward" .= True, "content" .= c] + MCSimple c -> JM.fromList ["content" .= c] + instance ToJSON MsgContent where toJSON = \case - MCUnknown v _ -> v + MCUnknown {json} -> J.Object json MCText t -> J.object ["type" .= MCText_, "text" .= t] toEncoding = \case - MCUnknown v _ -> JE.value v + MCUnknown {json} -> JE.value $ J.Object json MCText t -> J.pairs $ "type" .= MCText_ <> "text" .= t +instance ToField (MsgContent) where + toField = toField . safeDecodeUtf8 . LB.toStrict . J.encode + +instance FromField MsgContent where + fromField = fromTextField_ $ J.decode . LB.fromStrict . encodeUtf8 + data CMEventTag = XMsgNew_ | XFile_ @@ -163,6 +261,7 @@ data CMEventTag | XInfoProbeCheck_ | XInfoProbeOk_ | XOk_ + | XUnknown_ Text deriving (Eq, Show) instance StrEncoding CMEventTag where @@ -188,6 +287,7 @@ instance StrEncoding CMEventTag where XInfoProbeCheck_ -> "x.info.probe.check" XInfoProbeOk_ -> "x.info.probe.ok" XOk_ -> "x.ok" + XUnknown_ t -> encodeUtf8 t strDecode = \case "x.msg.new" -> Right XMsgNew_ "x.file" -> Right XFile_ @@ -210,7 +310,7 @@ instance StrEncoding CMEventTag where "x.info.probe.check" -> Right XInfoProbeCheck_ "x.info.probe.ok" -> Right XInfoProbeOk_ "x.ok" -> Right XOk_ - _ -> Left "bad CMEventTag" + t -> Right . XUnknown_ $ safeDecodeUtf8 t strP = strDecode <$?> A.takeTill (== ' ') toCMEventTag :: ChatMsgEvent -> CMEventTag @@ -236,6 +336,7 @@ toCMEventTag = \case XInfoProbeCheck _ -> XInfoProbeCheck_ XInfoProbeOk _ -> XInfoProbeOk_ XOk -> XOk_ + XUnknown t _ -> XUnknown_ t cmEventTagT :: Text -> Maybe CMEventTag cmEventTagT = eitherToMaybe . strDecode . encodeUtf8 @@ -248,19 +349,21 @@ instance FromField CMEventTag where fromField = fromTextField_ cmEventTagT instance ToField CMEventTag where toField = toField . serializeCMEventTag appToChatMessage :: AppMessage -> Either String ChatMessage -appToChatMessage AppMessage {event, params} = do +appToChatMessage AppMessage {msgId, event, params} = do eventTag <- strDecode $ encodeUtf8 event chatMsgEvent <- msg eventTag - pure ChatMessage {chatMsgEvent} + pure ChatMessage {msgId, chatMsgEvent} where p :: FromJSON a => J.Key -> Either String a p key = JT.parseEither (.: key) params + opt :: FromJSON a => J.Key -> Either String (Maybe a) + opt key = JT.parseEither (.:? key) params msg = \case - XMsgNew_ -> XMsgNew <$> p "content" + XMsgNew_ -> XMsgNew <$> JT.parseEither parseMsgContainer params XFile_ -> XFile <$> p "file" XFileAcpt_ -> XFileAcpt <$> p "fileName" XInfo_ -> XInfo <$> p "profile" - XContact_ -> XContact <$> p "profile" <*> JT.parseEither (.:? "contactReqId") params + XContact_ -> XContact <$> p "profile" <*> opt "contactReqId" XGrpInv_ -> XGrpInv <$> p "groupInvitation" XGrpAcpt_ -> XGrpAcpt <$> p "memberId" XGrpMemNew_ -> XGrpMemNew <$> p "memberInfo" @@ -277,19 +380,21 @@ appToChatMessage AppMessage {event, params} = do XInfoProbeCheck_ -> XInfoProbeCheck <$> p "probeHash" XInfoProbeOk_ -> XInfoProbeOk <$> p "probe" XOk_ -> pure XOk + XUnknown_ t -> pure $ XUnknown t params chatToAppMessage :: ChatMessage -> AppMessage -chatToAppMessage ChatMessage {chatMsgEvent} = AppMessage {event, params} +chatToAppMessage ChatMessage {msgId, chatMsgEvent} = AppMessage {msgId, event, params} where event = serializeCMEventTag . toCMEventTag $ chatMsgEvent o :: [(J.Key, J.Value)] -> J.Object o = JM.fromList + key .=? value = maybe id ((:) . (key .=)) value params = case chatMsgEvent of - XMsgNew content -> o ["content" .= content] + XMsgNew container -> msgContainerJSON container XFile fileInv -> o ["file" .= fileInv] XFileAcpt fileName -> o ["fileName" .= fileName] XInfo profile -> o $ ["profile" .= profile] - XContact profile xContactId -> o $ maybe id ((:) . ("contactReqId" .=)) xContactId ["profile" .= profile] + XContact profile xContactId -> o $ ("contactReqId" .=? xContactId) ["profile" .= profile] XGrpInv groupInv -> o ["groupInvitation" .= groupInv] XGrpAcpt memId -> o ["memberId" .= memId] XGrpMemNew memInfo -> o ["memberInfo" .= memInfo] @@ -306,3 +411,4 @@ chatToAppMessage ChatMessage {chatMsgEvent} = AppMessage {event, params} XInfoProbeCheck probeHash -> o ["probeHash" .= probeHash] XInfoProbeOk probe -> o ["probe" .= probe] XOk -> JM.empty + XUnknown _ ps -> ps diff --git a/src/Simplex/Chat/Store.hs b/src/Simplex/Chat/Store.hs index 784418eaac..6b44f71a67 100644 --- a/src/Simplex/Chat/Store.hs +++ b/src/Simplex/Chat/Store.hs @@ -105,7 +105,7 @@ module Simplex.Chat.Store updateFileTransferChatItemId, getFileTransfer, getFileTransferProgress, - createNewMessage, + createNewSndMessage, createSndMsgDelivery, createNewMessageAndRcvMsgDelivery, createSndMsgDeliveryEvent, @@ -118,6 +118,10 @@ module Simplex.Chat.Store getDirectChat, getGroupChat, getChatItemIdByAgentMsgId, + getDirectChatItem, + getGroupChatItem, + getDirectChatItemIdByText, + getGroupChatItemIdByText, updateDirectChatItem, updateDirectChatItemsRead, updateGroupChatItemsRead, @@ -162,6 +166,7 @@ import Simplex.Chat.Migrations.M20220210_deduplicate_contact_requests import Simplex.Chat.Migrations.M20220224_messages_fks import Simplex.Chat.Migrations.M20220301_smp_servers import Simplex.Chat.Migrations.M20220302_profile_images +import Simplex.Chat.Migrations.M20220304_msg_quotes import Simplex.Chat.Protocol import Simplex.Chat.Types import Simplex.Chat.Util (eitherToMaybe) @@ -170,6 +175,7 @@ import Simplex.Messaging.Agent.Store.SQLite (SQLiteStore (..), createSQLiteStore import Simplex.Messaging.Agent.Store.SQLite.Migrations (Migration (..)) import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Parsers (dropPrefix, sumTypeJSON) +import Simplex.Messaging.Protocol (MsgBody) import Simplex.Messaging.Util (liftIOEither, (<$$>)) import System.FilePath (takeFileName) import UnliftIO.STM @@ -182,7 +188,8 @@ schemaMigrations = ("20220210_deduplicate_contact_requests", m20220210_deduplicate_contact_requests), ("20220224_messages_fks", m20220224_messages_fks), ("20220301_smp_servers", m20220301_smp_servers), - ("20220302_profile_images", m20220302_profile_images) + ("20220302_profile_images", m20220302_profile_images), + ("20220304_msg_quotes", m20220304_msg_quotes) ] -- | The list of migrations in ascending order by date @@ -2023,11 +2030,30 @@ getSndFileTransfers_ db userId fileId = Just recipientDisplayName -> Right SndFileTransfer {fileId, fileStatus, fileName, fileSize, chunkSize, filePath, recipientDisplayName, connId, agentConnId} Nothing -> Left $ SESndFileInvalid fileId -createNewMessage :: MonadUnliftIO m => SQLiteStore -> NewMessage -> ConnOrGroupId -> m MessageId -createNewMessage st newMsg connOrGroupId = - liftIO . withTransaction st $ \db -> do - currentTs <- getCurrentTime - createNewMessage_ db newMsg connOrGroupId currentTs +createNewSndMessage :: StoreMonad m => SQLiteStore -> TVar ChaChaDRG -> ConnOrGroupId -> (SharedMsgId -> NewMessage) -> m SndMessage +createNewSndMessage st gVar connOrGroupId mkMessage = + liftIOEither . withTransaction st $ \db -> + createWithRandomId gVar $ \sharedMsgId -> do + createdAt <- getCurrentTime + DB.execute + db + "INSERT INTO messages (msg_sent, chat_msg_event, msg_body, shared_msg_id, shared_msg_id_user, created_at, updated_at) VALUES (?,?,?,?,?,?,?)" + (MDSnd, XUnknown_ "", "" :: MsgBody, sharedMsgId, Just True, createdAt, createdAt) + msgId <- insertedRowId db + let NewMessage {direction, chatMsgEvent, msgBody} = mkMessage $ SharedMsgId sharedMsgId + DB.execute + db + [sql| + UPDATE messages + SET msg_sent = ?, chat_msg_event = ?, msg_body = ?, connection_id = ?, group_id = ? + WHERE message_id = ? + |] + (direction, toCMEventTag chatMsgEvent, msgBody, connId_, groupId_, msgId) + pure SndMessage {msgId, direction, chatMsgEvent, sharedMsgId = SharedMsgId sharedMsgId, msgBody} + where + (connId_, groupId_) = case connOrGroupId of + ConnectionId connId -> (Just connId, Nothing) + GroupId groupId -> (Nothing, Just groupId) createSndMsgDelivery :: MonadUnliftIO m => SQLiteStore -> SndMsgDelivery -> MessageId -> m () createSndMsgDelivery st sndMsgDelivery messageId = @@ -2036,14 +2062,26 @@ createSndMsgDelivery st sndMsgDelivery messageId = msgDeliveryId <- createSndMsgDelivery_ db sndMsgDelivery messageId currentTs createMsgDeliveryEvent_ db msgDeliveryId MDSSndAgent currentTs -createNewMessageAndRcvMsgDelivery :: MonadUnliftIO m => SQLiteStore -> NewMessage -> ConnOrGroupId -> RcvMsgDelivery -> m MessageId -createNewMessageAndRcvMsgDelivery st newMsg connOrGroupId rcvMsgDelivery = +createNewMessageAndRcvMsgDelivery :: MonadUnliftIO m => SQLiteStore -> ConnOrGroupId -> NewMessage -> Maybe SharedMsgId -> RcvMsgDelivery -> m Message +createNewMessageAndRcvMsgDelivery st connOrGroupId NewMessage {direction, chatMsgEvent, msgBody} sharedMsgId_ RcvMsgDelivery {connId, agentMsgId, agentMsgMeta} = liftIO . withTransaction st $ \db -> do currentTs <- getCurrentTime - messageId <- createNewMessage_ db newMsg connOrGroupId currentTs - msgDeliveryId <- createRcvMsgDelivery_ db rcvMsgDelivery messageId currentTs + DB.execute + db + "INSERT INTO messages (msg_sent, chat_msg_event, msg_body, created_at, updated_at, connection_id, group_id, shared_msg_id) VALUES (?,?,?,?,?,?,?,?)" + (direction, toCMEventTag chatMsgEvent, msgBody, currentTs, currentTs, connId_, groupId_, sharedMsgId_) + msgId <- insertedRowId db + DB.execute + db + "INSERT INTO msg_deliveries (message_id, connection_id, agent_msg_id, agent_msg_meta, chat_ts, created_at, updated_at) VALUES (?,?,?,?,?,?,?)" + (msgId, connId, agentMsgId, msgMetaJson agentMsgMeta, snd $ broker agentMsgMeta, currentTs, currentTs) + msgDeliveryId <- insertedRowId db createMsgDeliveryEvent_ db msgDeliveryId MDSRcvAgent currentTs - pure messageId + pure Message {msgId, direction, chatMsgEvent, sharedMsgId_, msgBody} + where + (connId_, groupId_) = case connOrGroupId of + ConnectionId connId' -> (Just connId', Nothing) + GroupId groupId -> (Nothing, Just groupId) createSndMsgDeliveryEvent :: StoreMonad m => SQLiteStore -> Int64 -> AgentMsgId -> MsgDeliveryStatus 'MDSnd -> m () createSndMsgDeliveryEvent st connId agentMsgId sndMsgDeliveryStatus = @@ -2061,22 +2099,6 @@ createRcvMsgDeliveryEvent st connId agentMsgId rcvMsgDeliveryStatus = currentTs <- getCurrentTime createMsgDeliveryEvent_ db msgDeliveryId rcvMsgDeliveryStatus currentTs -createNewMessage_ :: DB.Connection -> NewMessage -> ConnOrGroupId -> UTCTime -> IO MessageId -createNewMessage_ db NewMessage {direction, cmEventTag, msgBody} connOrGroupId createdAt = do - DB.execute - db - [sql| - INSERT INTO messages - (msg_sent, chat_msg_event, msg_body, created_at, updated_at, connection_id, group_id) - VALUES (?,?,?,?,?,?,?) - |] - (direction, cmEventTag, msgBody, createdAt, createdAt, connId_, groupId_) - insertedRowId db - where - (connId_, groupId_) = case connOrGroupId of - ConnectionId connId -> (Just connId, Nothing) - GroupId groupId -> (Nothing, Just groupId) - createSndMsgDelivery_ :: DB.Connection -> SndMsgDelivery -> MessageId -> UTCTime -> IO Int64 createSndMsgDelivery_ db SndMsgDelivery {connId, agentMsgId} messageId createdAt = do DB.execute @@ -2089,18 +2111,6 @@ createSndMsgDelivery_ db SndMsgDelivery {connId, agentMsgId} messageId createdAt (messageId, connId, agentMsgId, createdAt, createdAt, createdAt) insertedRowId db -createRcvMsgDelivery_ :: DB.Connection -> RcvMsgDelivery -> MessageId -> UTCTime -> IO Int64 -createRcvMsgDelivery_ db RcvMsgDelivery {connId, agentMsgId, agentMsgMeta} messageId createdAt = do - DB.execute - db - [sql| - INSERT INTO msg_deliveries - (message_id, connection_id, agent_msg_id, agent_msg_meta, chat_ts, created_at, updated_at) - VALUES (?,?,?,?,?,?,?) - |] - (messageId, connId, agentMsgId, msgMetaJson agentMsgMeta, snd $ broker agentMsgMeta, createdAt, createdAt) - insertedRowId db - createMsgDeliveryEvent_ :: DB.Connection -> Int64 -> MsgDeliveryStatus d -> UTCTime -> IO () createMsgDeliveryEvent_ db msgDeliveryId msgDeliveryStatus createdAt = do DB.execute @@ -2160,21 +2170,23 @@ deletePendingGroupMessage st groupMemberId messageId = liftIO . withTransaction st $ \db -> DB.execute db "DELETE FROM pending_group_messages WHERE group_member_id = ? AND message_id = ?" (groupMemberId, messageId) -createNewChatItem :: (MonadUnliftIO m, MsgDirectionI d) => SQLiteStore -> UserId -> ChatDirection c d -> NewChatItem d -> m ChatItemId -createNewChatItem st userId chatDirection NewChatItem {createdByMsgId, itemSent, itemTs, itemContent, itemText, itemStatus, createdAt} = +createNewChatItem :: (MonadUnliftIO m, MsgDirectionI d) => SQLiteStore -> User -> ChatDirection c d -> NewChatItem d -> m (ChatItemId, Maybe (CIQuote c)) +createNewChatItem st user@User {userId} chatDirection NewChatItem {createdByMsgId, itemSent, itemTs, itemContent, itemText, itemStatus, itemSharedMsgId, itemQuotedMsg, createdAt} = liftIO . withTransaction st $ \db -> do - let (contactId_, groupId_, groupMemberId_) = ids + let itemMeta = (itemSent, itemTs, itemContent, itemText, itemStatus, itemSharedMsgId, createdAt, createdAt) DB.execute db [sql| INSERT INTO chat_items ( - user_id, contact_id, group_id, group_member_id, created_by_msg_id, - item_sent, item_ts, item_content, item_text, item_status, created_at, updated_at - ) VALUES (?,?,?,?,?,?,?,?,?,?,?,?) + -- user and IDs + user_id, created_by_msg_id, contact_id, group_id, group_member_id, + -- meta + item_sent, item_ts, item_content, item_text, item_status, shared_msg_id, created_at, updated_at, + -- quote + quoted_shared_msg_id, quoted_sent_at, quoted_content, quoted_sent, quoted_member_id + ) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?) |] - ( (userId, contactId_, groupId_, groupMemberId_, createdByMsgId) - :. (itemSent, itemTs, itemContent, itemText, itemStatus, createdAt, createdAt) - ) + ((userId, createdByMsgId) :. ids :. itemMeta :. quote) ciId <- insertedRowId db case createdByMsgId of Nothing -> pure () @@ -2183,7 +2195,8 @@ createNewChatItem st userId chatDirection NewChatItem {createdByMsgId, itemSent, db "INSERT INTO chat_item_messages (chat_item_id, message_id, created_at, updated_at) VALUES (?,?,?,?)" (ciId, msgId, createdAt, createdAt) - pure ciId + ciRef <- getChatItemRef_ db user chatDirection itemQuotedMsg + pure (ciId, ciRef) where ids :: (Maybe Int64, Maybe Int64, Maybe Int64) ids = case chatDirection of @@ -2191,6 +2204,62 @@ createNewChatItem st userId chatDirection NewChatItem {createdByMsgId, itemSent, CDDirectRcv Contact {contactId} -> (Just contactId, Nothing, Nothing) CDGroupSnd GroupInfo {groupId} -> (Nothing, Just groupId, Nothing) CDGroupRcv GroupInfo {groupId} GroupMember {groupMemberId} -> (Nothing, Just groupId, Just groupMemberId) + quote :: (Maybe SharedMsgId, Maybe UTCTime, Maybe MsgContent, Maybe Bool, Maybe MemberId) + quote = case itemQuotedMsg of + Nothing -> (Nothing, Nothing, Nothing, Nothing, Nothing) + Just QuotedMsg {msgRef = MsgRefDirect {msgId, sentAt, sent}, content} -> (msgId, Just sentAt, Just content, Just sent, Nothing) + Just QuotedMsg {msgRef = MsgRefGroup {msgId, sentAt, memberId}, content} -> (msgId, Just sentAt, Just content, Nothing, Just memberId) + +getChatItemRef_ :: DB.Connection -> User -> ChatDirection c d -> Maybe QuotedMsg -> IO (Maybe (CIQuote c)) +getChatItemRef_ db User {userId, userContactId} chatDirection = \case + Just QuotedMsg {msgRef = MsgRefDirect {msgId, sentAt, sent}, content} -> case chatDirection of + CDDirectSnd Contact {contactId} -> Just <$> getDirectChatItemRef_ sentAt content contactId msgId sent + CDDirectRcv Contact {contactId} -> Just <$> getDirectChatItemRef_ sentAt content contactId msgId (not sent) + _ -> pure Nothing + Just QuotedMsg {msgRef = MsgRefGroup {msgId, sentAt, memberId}, content} -> case chatDirection of + CDGroupSnd GroupInfo {groupId} -> getGroupChatItemRef_ sentAt content groupId msgId memberId + CDGroupRcv GroupInfo {groupId} _ -> getGroupChatItemRef_ sentAt content groupId msgId memberId + _ -> pure Nothing + _ -> pure Nothing + where + getDirectChatItemRef_ :: UTCTime -> MsgContent -> Int64 -> Maybe SharedMsgId -> Bool -> IO (CIQuote 'CTDirect) + getDirectChatItemRef_ sentAt content contactId msgId sent = do + ciRefDirect . listToMaybe . map fromOnly + <$> DB.query + db + "SELECT chat_item_id FROM chat_items WHERE user_id = ? AND contact_id = ? AND shared_msg_id = ? AND item_sent = ?" + (userId, contactId, msgId, sent) + where + ciRefDirect :: Maybe ChatItemId -> CIQuote 'CTDirect + ciRefDirect chatItemId = + let quote = CIQuoteData chatItemId sentAt content . parseMaybeMarkdownList $ msgContentText content + in CIQuoteDirect quote sent + getGroupChatItemRef_ :: UTCTime -> MsgContent -> Int64 -> Maybe SharedMsgId -> MemberId -> IO (Maybe (CIQuote 'CTGroup)) + getGroupChatItemRef_ sentAt content groupId msgId memberId = do + ciRefGroup + <$> DB.query + db + [sql| + SELECT i.chat_item_id, + -- GroupMember + m.group_member_id, m.group_id, m.member_id, m.member_role, m.member_category, + m.member_status, m.invited_by, m.local_display_name, m.contact_id, + p.display_name, p.full_name, p.image + FROM group_members m + JOIN contact_profiles p USING (contact_profile_id) + LEFT JOIN chat_items i ON i.group_id = m.group_id + AND (m.group_member_id = i.group_member_id OR i.group_member_id IS NULL) + WHERE (i.shared_msg_id = ? OR i.shared_msg_id IS NULL) + AND m.user_id = ? AND m.group_id = ? AND m.member_id = ? + |] + (msgId, userId, groupId, memberId) + where + ciRefGroup :: [Only (Maybe ChatItemId) :. GroupMemberRow] -> Maybe (CIQuote 'CTGroup) + ciRefGroup [] = Nothing + ciRefGroup ((Only chatItemId :. memberRow) : _) = + let member = toGroupMember userContactId memberRow + quote = CIQuoteData chatItemId sentAt content . parseMaybeMarkdownList $ msgContentText content + in Just $ CIQuoteGroup quote member getChatPreviews :: MonadUnliftIO m => SQLiteStore -> User -> m [AChat] getChatPreviews st user = @@ -2226,7 +2295,9 @@ getDirectChatPreviews_ db User {userId} = do -- ChatStats COALESCE(ChatStats.UnreadCount, 0), COALESCE(ChatStats.MinUnread, 0), -- ChatItem - ci.chat_item_id, ci.item_ts, ci.item_content, ci.item_text, ci.item_status, ci.created_at + i.chat_item_id, i.item_ts, i.item_content, i.item_text, i.item_status, i.shared_msg_id, i.created_at, + -- DirectQuote + ri.chat_item_id, i.quoted_sent_at, i.quoted_content, i.quoted_sent FROM contacts ct JOIN contact_profiles cp ON ct.contact_profile_id = cp.contact_profile_id JOIN connections c ON c.contact_id = ct.contact_id @@ -2236,14 +2307,15 @@ getDirectChatPreviews_ db User {userId} = do WHERE item_deleted != 1 GROUP BY contact_id ) MaxIds ON MaxIds.contact_id = ct.contact_id - LEFT JOIN chat_items ci ON ci.contact_id = MaxIds.contact_id - AND ci.chat_item_id = MaxIds.MaxId + LEFT JOIN chat_items i ON i.contact_id = MaxIds.contact_id + AND i.chat_item_id = MaxIds.MaxId LEFT JOIN ( SELECT contact_id, COUNT(1) AS UnreadCount, MIN(chat_item_id) AS MinUnread FROM chat_items WHERE item_status = ? GROUP BY contact_id ) ChatStats ON ChatStats.contact_id = ct.contact_id + LEFT JOIN chat_items ri ON i.quoted_shared_msg_id = ri.shared_msg_id WHERE ct.user_id = ? AND c.connection_id = ( SELECT cc_connection_id FROM ( @@ -2256,11 +2328,11 @@ getDirectChatPreviews_ db User {userId} = do LIMIT 1 ) ) - ORDER BY ci.item_ts DESC + ORDER BY i.item_ts DESC |] (CISRcvNew, userId, ConnReady, ConnSndReady) where - toDirectChatPreview :: TimeZone -> ContactRow :. ConnectionRow :. ChatStatsRow :. MaybeChatItemRow -> AChat + toDirectChatPreview :: TimeZone -> ContactRow :. ConnectionRow :. ChatStatsRow :. MaybeDirectChatItemRow -> AChat toDirectChatPreview tz (contactRow :. connRow :. statsRow :. ciRow_) = let contact = toContact $ contactRow :. connRow ci_ = toDirectChatItemList tz ciRow_ @@ -2284,11 +2356,17 @@ getGroupChatPreviews_ db User {userId, userContactId} = do -- ChatStats COALESCE(ChatStats.UnreadCount, 0), COALESCE(ChatStats.MinUnread, 0), -- ChatItem - ci.chat_item_id, ci.item_ts, ci.item_content, ci.item_text, ci.item_status, ci.created_at, + i.chat_item_id, i.item_ts, i.item_content, i.item_text, i.item_status, i.shared_msg_id, i.created_at, -- Maybe GroupMember - sender m.group_member_id, m.group_id, m.member_id, m.member_role, m.member_category, m.member_status, m.invited_by, m.local_display_name, m.contact_id, - p.display_name, p.full_name, p.image + p.display_name, p.full_name, p.image, + -- quoted ChatItem + ri.chat_item_id, i.quoted_sent_at, i.quoted_content, + -- quoted GroupMember + rm.group_member_id, rm.group_id, rm.member_id, rm.member_role, rm.member_category, + rm.member_status, rm.invited_by, rm.local_display_name, rm.contact_id, + rp.display_name, rp.full_name, rp.image FROM groups g JOIN group_profiles gp ON gp.group_profile_id = g.group_profile_id JOIN group_members mu ON mu.group_id = g.group_id @@ -2299,18 +2377,21 @@ getGroupChatPreviews_ db User {userId, userContactId} = do WHERE item_deleted != 1 GROUP BY group_id ) MaxIds ON MaxIds.group_id = g.group_id - LEFT JOIN chat_items ci ON ci.group_id = MaxIds.group_id - AND ci.chat_item_id = MaxIds.MaxId + LEFT JOIN chat_items i ON i.group_id = MaxIds.group_id + AND i.chat_item_id = MaxIds.MaxId LEFT JOIN ( SELECT group_id, COUNT(1) AS UnreadCount, MIN(chat_item_id) AS MinUnread FROM chat_items WHERE item_status = ? GROUP BY group_id ) ChatStats ON ChatStats.group_id = g.group_id - LEFT JOIN group_members m ON m.group_member_id = ci.group_member_id + LEFT JOIN group_members m ON m.group_member_id = i.group_member_id LEFT JOIN contact_profiles p ON p.contact_profile_id = m.contact_profile_id + LEFT JOIN chat_items ri ON i.quoted_shared_msg_id = ri.shared_msg_id + LEFT JOIN group_members rm ON rm.group_member_id = ri.group_member_id + LEFT JOIN contact_profiles rp ON rp.contact_profile_id = rm.contact_profile_id WHERE g.user_id = ? AND mu.contact_id = ? - ORDER BY ci.item_ts DESC + ORDER BY i.item_ts DESC |] (CISRcvNew, userId, userContactId) where @@ -2367,10 +2448,13 @@ getDirectChatLast_ db User {userId} contactId count = do [sql| SELECT -- ChatItem - ci.chat_item_id, ci.item_ts, ci.item_content, ci.item_text, ci.item_status, ci.created_at - FROM chat_items ci - WHERE ci.user_id = ? AND ci.contact_id = ? - ORDER BY ci.chat_item_id DESC + i.chat_item_id, i.item_ts, i.item_content, i.item_text, i.item_status, i.shared_msg_id, i.created_at, + -- DirectQuote + ri.chat_item_id, i.quoted_sent_at, i.quoted_content, i.quoted_sent + FROM chat_items i + LEFT JOIN chat_items ri ON i.quoted_shared_msg_id = ri.shared_msg_id + WHERE i.user_id = ? AND i.contact_id = ? + ORDER BY i.chat_item_id DESC LIMIT ? |] (userId, contactId, count) @@ -2391,10 +2475,13 @@ getDirectChatAfter_ db User {userId} contactId afterChatItemId count = do [sql| SELECT -- ChatItem - ci.chat_item_id, ci.item_ts, ci.item_content, ci.item_text, ci.item_status, ci.created_at - FROM chat_items ci - WHERE ci.user_id = ? AND ci.contact_id = ? AND ci.chat_item_id > ? - ORDER BY ci.chat_item_id ASC + i.chat_item_id, i.item_ts, i.item_content, i.item_text, i.item_status, i.shared_msg_id, i.created_at, + -- DirectQuote + ri.chat_item_id, i.quoted_sent_at, i.quoted_content, i.quoted_sent + FROM chat_items i + LEFT JOIN chat_items ri ON i.quoted_shared_msg_id = ri.shared_msg_id + WHERE i.user_id = ? AND i.contact_id = ? AND i.chat_item_id > ? + ORDER BY i.chat_item_id ASC LIMIT ? |] (userId, contactId, afterChatItemId, count) @@ -2415,10 +2502,13 @@ getDirectChatBefore_ db User {userId} contactId beforeChatItemId count = do [sql| SELECT -- ChatItem - ci.chat_item_id, ci.item_ts, ci.item_content, ci.item_text, ci.item_status, ci.created_at - FROM chat_items ci - WHERE ci.user_id = ? AND ci.contact_id = ? AND ci.chat_item_id < ? - ORDER BY ci.chat_item_id DESC + i.chat_item_id, i.item_ts, i.item_content, i.item_text, i.item_status, i.shared_msg_id, i.created_at, + -- DirectQuote + ri.chat_item_id, i.quoted_sent_at, i.quoted_content, i.quoted_sent + FROM chat_items i + LEFT JOIN chat_items ri ON i.quoted_shared_msg_id = ri.shared_msg_id + WHERE i.user_id = ? AND i.contact_id = ? AND i.chat_item_id < ? + ORDER BY i.chat_item_id DESC LIMIT ? |] (userId, contactId, beforeChatItemId, count) @@ -2511,16 +2601,25 @@ getGroupChatLast_ db user@User {userId, userContactId} groupId count = do [sql| SELECT -- ChatItem - ci.chat_item_id, ci.item_ts, ci.item_content, ci.item_text, ci.item_status, ci.created_at, + i.chat_item_id, i.item_ts, i.item_content, i.item_text, i.item_status, i.shared_msg_id, i.created_at, -- GroupMember m.group_member_id, m.group_id, m.member_id, m.member_role, m.member_category, m.member_status, m.invited_by, m.local_display_name, m.contact_id, - p.display_name, p.full_name, p.image - FROM chat_items ci - LEFT JOIN group_members m ON m.group_member_id = ci.group_member_id + p.display_name, p.full_name, p.image, + -- quoted ChatItem + ri.chat_item_id, i.quoted_sent_at, i.quoted_content, + -- quoted GroupMember + rm.group_member_id, rm.group_id, rm.member_id, rm.member_role, rm.member_category, + rm.member_status, rm.invited_by, rm.local_display_name, rm.contact_id, + rp.display_name, rp.full_name, rp.image + FROM chat_items i + LEFT JOIN group_members m ON m.group_member_id = i.group_member_id LEFT JOIN contact_profiles p ON p.contact_profile_id = m.contact_profile_id - WHERE ci.user_id = ? AND ci.group_id = ? - ORDER BY ci.item_ts DESC, ci.chat_item_id DESC + LEFT JOIN chat_items ri ON i.quoted_shared_msg_id = ri.shared_msg_id + LEFT JOIN group_members rm ON rm.group_member_id = ri.group_member_id + LEFT JOIN contact_profiles rp ON rp.contact_profile_id = rm.contact_profile_id + WHERE i.user_id = ? AND i.group_id = ? + ORDER BY i.item_ts DESC, i.chat_item_id DESC LIMIT ? |] (userId, groupId, count) @@ -2541,16 +2640,25 @@ getGroupChatAfter_ db user@User {userId, userContactId} groupId afterChatItemId [sql| SELECT -- ChatItem - ci.chat_item_id, ci.item_ts, ci.item_content, ci.item_text, ci.item_status, ci.created_at, + i.chat_item_id, i.item_ts, i.item_content, i.item_text, i.item_status, i.shared_msg_id, i.created_at, -- GroupMember m.group_member_id, m.group_id, m.member_id, m.member_role, m.member_category, m.member_status, m.invited_by, m.local_display_name, m.contact_id, - p.display_name, p.full_name, p.image - FROM chat_items ci - LEFT JOIN group_members m ON m.group_member_id = ci.group_member_id + p.display_name, p.full_name, p.image, + -- quoted ChatItem + ri.chat_item_id, i.quoted_sent_at, i.quoted_content, + -- quoted GroupMember + rm.group_member_id, rm.group_id, rm.member_id, rm.member_role, rm.member_category, + rm.member_status, rm.invited_by, rm.local_display_name, rm.contact_id, + rp.display_name, rp.full_name, rp.image + FROM chat_items i + LEFT JOIN group_members m ON m.group_member_id = i.group_member_id LEFT JOIN contact_profiles p ON p.contact_profile_id = m.contact_profile_id - WHERE ci.user_id = ? AND ci.group_id = ? AND ci.chat_item_id > ? - ORDER BY ci.item_ts ASC, ci.chat_item_id ASC + LEFT JOIN chat_items ri ON i.quoted_shared_msg_id = ri.shared_msg_id + LEFT JOIN group_members rm ON rm.group_member_id = ri.group_member_id + LEFT JOIN contact_profiles rp ON rp.contact_profile_id = rm.contact_profile_id + WHERE i.user_id = ? AND i.group_id = ? AND i.chat_item_id > ? + ORDER BY i.item_ts ASC, i.chat_item_id ASC LIMIT ? |] (userId, groupId, afterChatItemId, count) @@ -2571,16 +2679,25 @@ getGroupChatBefore_ db user@User {userId, userContactId} groupId beforeChatItemI [sql| SELECT -- ChatItem - ci.chat_item_id, ci.item_ts, ci.item_content, ci.item_text, ci.item_status, ci.created_at, + i.chat_item_id, i.item_ts, i.item_content, i.item_text, i.item_status, i.shared_msg_id, i.created_at, -- GroupMember m.group_member_id, m.group_id, m.member_id, m.member_role, m.member_category, m.member_status, m.invited_by, m.local_display_name, m.contact_id, - p.display_name, p.full_name, p.image - FROM chat_items ci - LEFT JOIN group_members m ON m.group_member_id = ci.group_member_id + p.display_name, p.full_name, p.image, + -- quoted ChatItem + ri.chat_item_id, i.quoted_sent_at, i.quoted_content, + -- quoted GroupMember + rm.group_member_id, rm.group_id, rm.member_id, rm.member_role, rm.member_category, + rm.member_status, rm.invited_by, rm.local_display_name, rm.contact_id, + rp.display_name, rp.full_name, rp.image + FROM chat_items i + LEFT JOIN group_members m ON m.group_member_id = i.group_member_id LEFT JOIN contact_profiles p ON p.contact_profile_id = m.contact_profile_id - WHERE ci.user_id = ? AND ci.group_id = ? AND ci.chat_item_id < ? - ORDER BY ci.item_ts DESC, ci.chat_item_id DESC + LEFT JOIN chat_items ri ON i.quoted_shared_msg_id = ri.shared_msg_id + LEFT JOIN group_members rm ON rm.group_member_id = ri.group_member_id + LEFT JOIN contact_profiles rp ON rp.contact_profile_id = rm.contact_profile_id + WHERE i.user_id = ? AND i.group_id = ? AND i.chat_item_id < ? + ORDER BY i.item_ts DESC, i.chat_item_id DESC LIMIT ? |] (userId, groupId, beforeChatItemId, count) @@ -2655,36 +2772,119 @@ getChatItemIdByAgentMsgId st connId msgId = |] (connId, msgId) -updateDirectChatItem :: (StoreMonad m, MsgDirectionI d) => SQLiteStore -> ChatItemId -> CIStatus d -> m (ChatItem 'CTDirect d) -updateDirectChatItem st itemId itemStatus = +updateDirectChatItem :: forall m d. (StoreMonad m, MsgDirectionI d) => SQLiteStore -> UserId -> Int64 -> ChatItemId -> CIStatus d -> m (ChatItem 'CTDirect d) +updateDirectChatItem st userId contactId itemId itemStatus = liftIOEither . withTransaction st $ \db -> runExceptT $ do - ci <- ExceptT $ getDirectChatItem_ db itemId + ci <- ExceptT $ (correctDir =<<) <$> getDirectChatItem_ db userId contactId itemId currentTs <- liftIO getCurrentTime - liftIO $ DB.execute db "UPDATE chat_items SET item_status = ?, updated_at = ? WHERE chat_item_id = ?" (itemStatus, currentTs, itemId) + liftIO $ DB.execute db "UPDATE chat_items SET item_status = ?, updated_at = ? WHERE user_id = ? AND contact_id = ? AND chat_item_id = ?" (itemStatus, currentTs, userId, contactId, itemId) pure ci {meta = (meta ci) {itemStatus}} - -getDirectChatItem_ :: forall d. MsgDirectionI d => DB.Connection -> ChatItemId -> IO (Either StoreError (ChatItem 'CTDirect d)) -getDirectChatItem_ db itemId = do - tz <- getCurrentTimeZone - join - <$> firstRow - (correctDir <=< toDirectChatItem tz) - (SEChatItemNotFound itemId) - ( DB.query - db - [sql| - SELECT - -- ChatItem - ci.chat_item_id, ci.item_ts, ci.item_content, ci.item_text, ci.item_status, ci.created_at - FROM chat_items ci - WHERE ci.chat_item_id = ? - |] - (Only itemId) - ) where correctDir :: CChatItem c -> Either StoreError (ChatItem c d) correctDir (CChatItem _ ci) = first SEInternalError $ checkDirection ci +getDirectChatItem :: StoreMonad m => SQLiteStore -> UserId -> Int64 -> ChatItemId -> m (CChatItem 'CTDirect) +getDirectChatItem st userId contactId itemId = + liftIOEither . withTransaction st $ \db -> getDirectChatItem_ db userId contactId itemId + +getDirectChatItem_ :: DB.Connection -> UserId -> Int64 -> ChatItemId -> IO (Either StoreError (CChatItem 'CTDirect)) +getDirectChatItem_ db userId contactId itemId = do + tz <- getCurrentTimeZone + join <$> firstRow (toDirectChatItem tz) (SEChatItemNotFound itemId) getItem + where + getItem = + DB.query + db + [sql| + SELECT + -- ChatItem + i.chat_item_id, i.item_ts, i.item_content, i.item_text, i.item_status, i.shared_msg_id, i.created_at, + -- DirectQuote + ri.chat_item_id, i.quoted_sent_at, i.quoted_content, i.quoted_sent + FROM chat_items i + LEFT JOIN chat_items ri ON i.quoted_shared_msg_id = ri.shared_msg_id + WHERE i.user_id = ? AND i.contact_id = ? AND i.chat_item_id = ? + |] + (userId, contactId, itemId) + +getDirectChatItemIdByText :: StoreMonad m => SQLiteStore -> UserId -> Int64 -> SMsgDirection d -> Text -> m ChatItemId +getDirectChatItemIdByText st userId contactId msgDir quotedMsg = + liftIOEither . withTransaction st $ \db -> + firstRow fromOnly SEQuotedChatItemNotFound $ + DB.query + db + [sql| + SELECT chat_item_id + FROM chat_items + WHERE user_id = ? AND contact_id = ? AND item_sent = ? AND item_text like ? + ORDER BY chat_item_id DESC + LIMIT 1 + |] + (userId, contactId, msgDir, quotedMsg <> "%") + +getGroupChatItem :: StoreMonad m => SQLiteStore -> User -> Int64 -> ChatItemId -> m (CChatItem 'CTGroup) +getGroupChatItem st User {userId, userContactId} groupId itemId = + liftIOEither . withTransaction st $ \db -> do + tz <- getCurrentTimeZone + join <$> firstRow (toGroupChatItem tz userContactId) (SEChatItemNotFound itemId) (getItem db) + where + getItem db = + DB.query + db + [sql| + SELECT + -- ChatItem + i.chat_item_id, i.item_ts, i.item_content, i.item_text, i.item_status, i.shared_msg_id, i.created_at, + -- GroupMember + m.group_member_id, m.group_id, m.member_id, m.member_role, m.member_category, + m.member_status, m.invited_by, m.local_display_name, m.contact_id, + p.display_name, p.full_name, p.image, + -- quoted ChatItem + ri.chat_item_id, i.quoted_sent_at, i.quoted_content, + -- quoted GroupMember + rm.group_member_id, rm.group_id, rm.member_id, rm.member_role, rm.member_category, + rm.member_status, rm.invited_by, rm.local_display_name, rm.contact_id, + rp.display_name, rp.full_name, rp.image + FROM chat_items i + LEFT JOIN group_members m ON m.group_member_id = i.group_member_id + LEFT JOIN contact_profiles p ON p.contact_profile_id = m.contact_profile_id + LEFT JOIN chat_items ri ON i.quoted_shared_msg_id = ri.shared_msg_id + LEFT JOIN group_members rm ON rm.group_member_id = ri.group_member_id + LEFT JOIN contact_profiles rp ON rp.contact_profile_id = rm.contact_profile_id + WHERE i.user_id = ? AND i.group_id = ? AND i.chat_item_id = ? + |] + (userId, groupId, itemId) + +getGroupChatItemIdByText :: StoreMonad m => SQLiteStore -> User -> Int64 -> ContactName -> Text -> m ChatItemId +getGroupChatItemIdByText st User {userId, localDisplayName = userName} groupId cName quotedMsg = + liftIOEither . withTransaction st $ \db -> + firstRow fromOnly SEQuotedChatItemNotFound $ + if userName == cName + then + DB.query + db + [sql| + SELECT chat_item_id + FROM chat_items + WHERE user_id = ? AND group_id = ? AND group_member_id IS NULL AND item_text like ? + ORDER BY chat_item_id DESC + LIMIT 1 + |] + (userId, groupId, quotedMsg <> "%") + else + DB.query + db + [sql| + SELECT i.chat_item_id + FROM chat_items i + JOIN group_members m ON m.group_member_id = i.group_member_id + JOIN contacts c ON c.contact_id = m.contact_id + WHERE i.user_id = ? AND i.group_id = ? AND c.local_display_name = ? AND i.item_text like ? + ORDER BY i.chat_item_id DESC + LIMIT 1 + |] + (userId, groupId, cName, quotedMsg <> "%") + updateDirectChatItemsRead :: (StoreMonad m) => SQLiteStore -> Int64 -> (ChatItemId, ChatItemId) -> m () updateDirectChatItemsRead st contactId (fromItemId, toItemId) = do currentTs <- liftIO getCurrentTime @@ -2714,49 +2914,68 @@ type ChatStatsRow = (Int, ChatItemId) toChatStats :: ChatStatsRow -> ChatStats toChatStats (unreadCount, minUnreadItemId) = ChatStats {unreadCount, minUnreadItemId} -type ChatItemRow = (Int64, ChatItemTs, ACIContent, Text, ACIStatus, UTCTime) +type ChatItemRow = (Int64, ChatItemTs, ACIContent, Text, ACIStatus, Maybe SharedMsgId, UTCTime) -type MaybeChatItemRow = (Maybe Int64, Maybe ChatItemTs, Maybe ACIContent, Maybe Text, Maybe ACIStatus, Maybe UTCTime) +type MaybeChatItemRow = (Maybe Int64, Maybe ChatItemTs, Maybe ACIContent, Maybe Text, Maybe ACIStatus, Maybe SharedMsgId, Maybe UTCTime) -toDirectChatItem :: TimeZone -> ChatItemRow -> Either StoreError (CChatItem 'CTDirect) -toDirectChatItem tz (itemId, itemTs, itemContent, itemText, itemStatus, createdAt) = +type QuoteDataRow = (Maybe ChatItemId, Maybe UTCTime, Maybe MsgContent) + +type DirectQuote = QuoteDataRow :. Only (Maybe Bool) + +type DirectChatItemRow = ChatItemRow :. DirectQuote + +type MaybeDirectChatItemRow = MaybeChatItemRow :. DirectQuote + +toQuoteData :: QuoteDataRow -> Maybe CIQuoteData +toQuoteData (quotedItemId, quotedSentAt, quotedMsgContent) = + CIQuoteData quotedItemId <$> quotedSentAt <*> quotedMsgContent <*> (parseMaybeMarkdownList . msgContentText <$> quotedMsgContent) + +toDirectChatItem :: TimeZone -> DirectChatItemRow -> Either StoreError (CChatItem 'CTDirect) +toDirectChatItem tz ((itemId, itemTs, itemContent, itemText, itemStatus, sharedMsgId, createdAt) :. quoteRow :. Only quotedSent) = case (itemContent, itemStatus) of (ACIContent SMDSnd ciContent, ACIStatus SMDSnd ciStatus) -> Right $ cItem SMDSnd CIDirectSnd ciStatus ciContent (ACIContent SMDRcv ciContent, ACIStatus SMDRcv ciStatus) -> Right $ cItem SMDRcv CIDirectRcv ciStatus ciContent _ -> badItem where - cItem :: MsgDirectionI d => SMsgDirection d -> CIDirection c d -> CIStatus d -> CIContent d -> CChatItem c - cItem d cid ciStatus ciContent = CChatItem d (ChatItem cid (ciMeta ciStatus) ciContent $ parseMaybeMarkdownList itemText) + cItem :: MsgDirectionI d => SMsgDirection d -> CIDirection 'CTDirect d -> CIStatus d -> CIContent d -> CChatItem 'CTDirect + cItem d chatDir ciStatus content = + let quotedItem = CIQuoteDirect <$> toQuoteData quoteRow <*> quotedSent + in CChatItem d ChatItem {chatDir, meta = ciMeta ciStatus, content, formattedText = parseMaybeMarkdownList itemText, quotedItem} badItem = Left $ SEBadChatItem itemId ciMeta :: CIStatus d -> CIMeta d - ciMeta status = mkCIMeta itemId itemText status tz itemTs createdAt + ciMeta status = mkCIMeta itemId itemText status sharedMsgId tz itemTs createdAt -toDirectChatItemList :: TimeZone -> MaybeChatItemRow -> [CChatItem 'CTDirect] -toDirectChatItemList tz (Just itemId, Just itemTs, Just itemContent, Just itemText, Just itemStatus, Just createdAt) = - either (const []) (: []) $ toDirectChatItem tz (itemId, itemTs, itemContent, itemText, itemStatus, createdAt) +toDirectChatItemList :: TimeZone -> MaybeDirectChatItemRow -> [CChatItem 'CTDirect] +toDirectChatItemList tz ((Just itemId, Just itemTs, Just itemContent, Just itemText, Just itemStatus, sharedMsgId, Just createdAt) :. quoteRow :. Only quotedSent) = + either (const []) (: []) $ toDirectChatItem tz ((itemId, itemTs, itemContent, itemText, itemStatus, sharedMsgId, createdAt) :. quoteRow :. Only quotedSent) toDirectChatItemList _ _ = [] -type GroupChatItemRow = ChatItemRow :. MaybeGroupMemberRow +type GroupQuote = QuoteDataRow :. MaybeGroupMemberRow -type MaybeGroupChatItemRow = MaybeChatItemRow :. MaybeGroupMemberRow +type GroupChatItemRow = ChatItemRow :. MaybeGroupMemberRow :. GroupQuote + +type MaybeGroupChatItemRow = MaybeChatItemRow :. MaybeGroupMemberRow :. GroupQuote toGroupChatItem :: TimeZone -> Int64 -> GroupChatItemRow -> Either StoreError (CChatItem 'CTGroup) -toGroupChatItem tz userContactId ((itemId, itemTs, itemContent, itemText, itemStatus, createdAt) :. memberRow_) = do +toGroupChatItem tz userContactId ((itemId, itemTs, itemContent, itemText, itemStatus, sharedMsgId, createdAt) :. memberRow_ :. quoteRow :. quotedMemberRow_) = do let member_ = toMaybeGroupMember userContactId memberRow_ + let quotedMember_ = toMaybeGroupMember userContactId quotedMemberRow_ case (itemContent, itemStatus, member_) of - (ACIContent SMDSnd ciContent, ACIStatus SMDSnd ciStatus, Nothing) -> Right $ cItem SMDSnd CIGroupSnd ciStatus ciContent - (ACIContent SMDRcv ciContent, ACIStatus SMDRcv ciStatus, Just member) -> Right $ cItem SMDRcv (CIGroupRcv member) ciStatus ciContent + (ACIContent SMDSnd ciContent, ACIStatus SMDSnd ciStatus, _) -> Right $ cItem SMDSnd CIGroupSnd ciStatus ciContent quotedMember_ + (ACIContent SMDRcv ciContent, ACIStatus SMDRcv ciStatus, Just member) -> Right $ cItem SMDRcv (CIGroupRcv member) ciStatus ciContent quotedMember_ _ -> badItem where - cItem :: MsgDirectionI d => SMsgDirection d -> CIDirection c d -> CIStatus d -> CIContent d -> CChatItem c - cItem d cid ciStatus ciContent = CChatItem d (ChatItem cid (ciMeta ciStatus) ciContent $ parseMaybeMarkdownList itemText) + cItem :: MsgDirectionI d => SMsgDirection d -> CIDirection 'CTGroup d -> CIStatus d -> CIContent d -> Maybe GroupMember -> CChatItem 'CTGroup + cItem d chatDir ciStatus content quotedMember_ = + let quotedItem = CIQuoteGroup <$> toQuoteData quoteRow <*> quotedMember_ + in CChatItem d ChatItem {chatDir, meta = ciMeta ciStatus, content, formattedText = parseMaybeMarkdownList itemText, quotedItem} badItem = Left $ SEBadChatItem itemId ciMeta :: CIStatus d -> CIMeta d - ciMeta status = mkCIMeta itemId itemText status tz itemTs createdAt + ciMeta status = mkCIMeta itemId itemText status sharedMsgId tz itemTs createdAt toGroupChatItemList :: TimeZone -> Int64 -> MaybeGroupChatItemRow -> [CChatItem 'CTGroup] -toGroupChatItemList tz userContactId ((Just itemId, Just itemTs, Just itemContent, Just itemText, Just itemStatus, Just createdAt) :. memberRow_) = - either (const []) (: []) $ toGroupChatItem tz userContactId ((itemId, itemTs, itemContent, itemText, itemStatus, createdAt) :. memberRow_) +toGroupChatItemList tz userContactId ((Just itemId, Just itemTs, Just itemContent, Just itemText, Just itemStatus, sharedMsgId, Just createdAt) :. memberRow_ :. quoteRow :. quotedMemberRow_) = + either (const []) (: []) $ toGroupChatItem tz userContactId ((itemId, itemTs, itemContent, itemText, itemStatus, sharedMsgId, createdAt) :. memberRow_ :. quoteRow :. quotedMemberRow_) toGroupChatItemList _ _ _ = [] getSMPServers :: MonadUnliftIO m => SQLiteStore -> User -> m [SMPServer] @@ -2876,6 +3095,7 @@ data StoreError | SENoMsgDelivery {connId :: Int64, agentMsgId :: AgentMsgId} | SEBadChatItem {itemId :: ChatItemId} | SEChatItemNotFound {itemId :: ChatItemId} + | SEQuotedChatItemNotFound deriving (Show, Exception, Generic) instance ToJSON StoreError where diff --git a/src/Simplex/Chat/Terminal/Input.hs b/src/Simplex/Chat/Terminal/Input.hs index 833911acd9..7a1a3017d4 100644 --- a/src/Simplex/Chat/Terminal/Input.hs +++ b/src/Simplex/Chat/Terminal/Input.hs @@ -48,6 +48,8 @@ runInputLoop ct cc = forever $ do Right SendGroupMessage {} -> True Right SendFile {} -> True Right SendGroupFile {} -> True + Right SendMessageQuote {} -> True + Right SendGroupMessageQuote {} -> True _ -> False runTerminalInput :: ChatTerminal -> ChatController -> IO () @@ -98,8 +100,10 @@ updateTermState ac tw (key, ms) ts@TerminalState {inputString = s, inputPosition _ -> ts where insertCharsWithContact cs - | null s && cs /= "@" && cs /= "#" && cs /= "/" = + | null s && cs /= "@" && cs /= "#" && cs /= "/" && cs /= ">" = insertChars $ contactPrefix <> cs + | s == ">" && cs == " " = + insertChars $ cs <> contactPrefix | otherwise = insertChars cs insertChars = ts' . if p >= length s then append else insert append cs = let s' = s <> cs in (s', length s') diff --git a/src/Simplex/Chat/View.hs b/src/Simplex/Chat/View.hs index af40b1a5a0..bd64208119 100644 --- a/src/Simplex/Chat/View.hs +++ b/src/Simplex/Chat/View.hs @@ -151,34 +151,49 @@ responseToView testView = \case toChatView :: CChatItem c -> (Int, Text) toChatView (CChatItem dir ChatItem {meta}) = (msgDirectionInt $ toMsgDirection dir, itemText meta) viewErrorsSummary :: [a] -> StyledString -> [StyledString] - viewErrorsSummary summary s = if null summary then [] else [styled (colored Red) (T.pack . show $ length summary) <> s <> " (run with -c option to show each error)"] + viewErrorsSummary summary s = if null summary then [] else [ttyError (T.pack . show $ length summary) <> s <> " (run with -c option to show each error)"] viewChatItem :: ChatInfo c -> ChatItem c d -> [StyledString] -viewChatItem chat (ChatItem cd meta content _) = case (chat, cd) of - (DirectChat c, CIDirectSnd) -> case content of - CISndMsgContent mc -> viewSentMessage to mc meta - CISndFileInvitation fId fPath -> viewSentFileInvitation to fId fPath meta +viewChatItem chat (ChatItem {chatDir, meta, content, quotedItem}) = case chat of + DirectChat c -> case chatDir of + CIDirectSnd -> case content of + CISndMsgContent mc -> viewSentMessage to quote mc meta + CISndFileInvitation fId fPath -> viewSentFileInvitation to fId fPath meta + where + to = ttyToContact' c + quote = maybe [] (directQuote True) quotedItem + CIDirectRcv -> case content of + CIRcvMsgContent mc -> viewReceivedMessage from quote meta mc + CIRcvFileInvitation ft -> viewReceivedFileInvitation from meta ft + where + from = ttyFromContact' c + quote = maybe [] (directQuote False) quotedItem + GroupChat g -> case chatDir of + CIGroupSnd -> case content of + CISndMsgContent mc -> viewSentMessage to quote mc meta + CISndFileInvitation fId fPath -> viewSentFileInvitation to fId fPath meta + where + to = ttyToGroup g + CIGroupRcv m -> case content of + CIRcvMsgContent mc -> viewReceivedMessage from quote meta mc + CIRcvFileInvitation ft -> viewReceivedFileInvitation from meta ft + where + from = ttyFromGroup' g m where - to = ttyToContact' c - (DirectChat c, CIDirectRcv) -> case content of - CIRcvMsgContent mc -> viewReceivedMessage from meta mc -- mOk - CIRcvFileInvitation ft -> viewReceivedFileInvitation from meta ft -- mOk - where - from = ttyFromContact' c - (GroupChat g, CIGroupSnd) -> case content of - CISndMsgContent mc -> viewSentMessage to mc meta - CISndFileInvitation fId fPath -> viewSentFileInvitation to fId fPath meta - where - to = ttyToGroup g - (GroupChat g, CIGroupRcv m) -> case content of - CIRcvMsgContent mc -> viewReceivedMessage from meta mc -- mOk - CIRcvFileInvitation ft -> viewReceivedFileInvitation from meta ft -- mOk - where - from = ttyFromGroup' g m + quote = maybe [] groupQuote quotedItem + _ -> [] where - ttyToContact' Contact {localDisplayName = c} = ttyToContact c - ttyFromContact' Contact {localDisplayName = c} = ttyFromContact c - ttyFromGroup' g GroupMember {localDisplayName = m} = ttyFromGroup g m + directQuote :: Bool -> CIQuote 'CTDirect -> [StyledString] + directQuote msgSent (CIQuoteDirect CIQuoteData {content = qmc} qouteSent) = + quoteText qmc $ if msgSent == qouteSent then ">>" else ">" + groupQuote :: CIQuote 'CTGroup -> [StyledString] + groupQuote (CIQuoteGroup CIQuoteData {content = qmc} m) = quoteText qmc $ ttyQuotedMember m + quoteText qmc sentBy = prependFirst (sentBy <> " ") $ msgPreview qmc + msgPreview = msgPlain . preview . msgContentText + where + preview t + | T.length t <= 60 = t + | otherwise = t <> "..." viewMsgIntegrityError :: MsgErrorType -> [StyledString] viewMsgIntegrityError err = msgError $ case err of @@ -190,7 +205,7 @@ viewMsgIntegrityError err = msgError $ case err of MsgDuplicate -> "duplicate message ID" where msgError :: String -> [StyledString] - msgError s = [styled (colored Red) s] + msgError s = [ttyError s] viewInvalidConnReq :: [StyledString] viewInvalidConnReq = @@ -357,13 +372,14 @@ viewContactUpdated where fullNameUpdate = if T.null fullName' || fullName' == n' then " removed full name" else " updated full name: " <> plain fullName' -viewReceivedMessage :: StyledString -> CIMeta d -> MsgContent -> [StyledString] -viewReceivedMessage from meta mc = receivedWithTime_ from meta (ttyMsgContent mc) +viewReceivedMessage :: StyledString -> [StyledString] -> CIMeta d -> MsgContent -> [StyledString] +viewReceivedMessage from quote meta = receivedWithTime_ from quote meta . ttyMsgContent -receivedWithTime_ :: StyledString -> CIMeta d -> [StyledString] -> [StyledString] -receivedWithTime_ from CIMeta {localItemTs, createdAt} styledMsg = do - prependFirst (formattedTime <> " " <> from) styledMsg -- ++ showIntegrity mOk +receivedWithTime_ :: StyledString -> [StyledString] -> CIMeta d -> [StyledString] -> [StyledString] +receivedWithTime_ from quote CIMeta {localItemTs, createdAt} styledMsg = do + prependFirst (formattedTime <> " " <> from) (quote <> prependFirst indent styledMsg) where + indent = if null quote then "" else " " formattedTime :: StyledString formattedTime = let localTime = zonedTimeToLocalTime localItemTs @@ -375,8 +391,10 @@ receivedWithTime_ from CIMeta {localItemTs, createdAt} styledMsg = do else "%H:%M" in styleTime $ formatTime defaultTimeLocale format localTime -viewSentMessage :: StyledString -> MsgContent -> CIMeta d -> [StyledString] -viewSentMessage to = sentWithTime_ . prependFirst to . ttyMsgContent +viewSentMessage :: StyledString -> [StyledString] -> MsgContent -> CIMeta d -> [StyledString] +viewSentMessage to quote mc = sentWithTime_ . prependFirst to $ quote <> prependFirst indent (ttyMsgContent mc) + where + indent = if null quote then "" else " " viewSentFileInvitation :: StyledString -> FileTransferId -> FilePath -> CIMeta d -> [StyledString] viewSentFileInvitation to fId fPath = sentWithTime_ $ ttySentFile to fId fPath @@ -389,9 +407,7 @@ ttyMsgTime :: ZonedTime -> StyledString ttyMsgTime = styleTime . formatTime defaultTimeLocale "%H:%M" ttyMsgContent :: MsgContent -> [StyledString] -ttyMsgContent = \case - MCText t -> msgPlain t - MCUnknown _ t -> msgPlain t +ttyMsgContent = msgPlain . msgContentText ttySentFile :: StyledString -> FileTransferId -> FilePath -> [StyledString] ttySentFile to fId fPath = ["/f " <> to <> ttyFilePath fPath, "use " <> highlight ("/fc " <> show fId) <> " to cancel sending"] @@ -421,7 +437,7 @@ sndFile :: SndFileTransfer -> StyledString sndFile SndFileTransfer {fileId, fileName} = fileTransferStr fileId fileName viewReceivedFileInvitation :: StyledString -> CIMeta d -> RcvFileTransfer -> [StyledString] -viewReceivedFileInvitation from meta ft = receivedWithTime_ from meta (receivedFileInvitation_ ft) +viewReceivedFileInvitation from meta ft = receivedWithTime_ from [] meta (receivedFileInvitation_ ft) receivedFileInvitation_ :: RcvFileTransfer -> [StyledString] receivedFileInvitation_ RcvFileTransfer {fileId, fileInvitation = FileInvitation {fileName, fileSize}} = @@ -523,6 +539,7 @@ viewChatError = \case CEFileSend fileId e -> ["error sending file " <> sShow fileId <> ": " <> sShow e] CEFileRcvChunk e -> ["error receiving file: " <> plain e] CEFileInternal e -> ["file error: " <> plain e] + CEInvalidQuote -> ["cannot reply to this message"] CEAgentVersion -> ["unsupported agent version"] CECommandError e -> ["bad chat command: " <> plain e] -- e -> ["chat error: " <> sShow e] @@ -539,6 +556,7 @@ viewChatError = \case SEUserContactLinkNotFound -> ["no chat address, to create: " <> highlight' "/ad"] SEContactRequestNotFoundByName c -> ["no contact request from " <> ttyContact c] SEConnectionNotFound _ -> [] -- TODO mutes delete group error, but also mutes any error from getConnectionEntity + SEQuotedChatItemNotFound -> ["message not found - reply is not sent"] e -> ["chat db error: " <> sShow e] ChatErrorAgent err -> case err of SMP SMP.AUTH -> ["error: this connection is deleted"] @@ -547,7 +565,7 @@ viewChatError = \case fileNotFound fileId = ["file " <> sShow fileId <> " not found"] ttyContact :: ContactName -> StyledString -ttyContact = styled (colored Green) +ttyContact = styled $ colored Green ttyContact' :: Contact -> StyledString ttyContact' Contact {localDisplayName = c} = ttyContact c @@ -570,7 +588,19 @@ ttyToContact :: ContactName -> StyledString ttyToContact c = styled (colored Cyan) $ "@" <> c <> " " ttyFromContact :: ContactName -> StyledString -ttyFromContact c = styled (colored Yellow) $ c <> "> " +ttyFromContact c = ttyFrom $ c <> "> " + +ttyToContact' :: Contact -> StyledString +ttyToContact' Contact {localDisplayName = c} = ttyToContact c + +ttyQuotedContact :: Contact -> StyledString +ttyQuotedContact Contact {localDisplayName = c} = ttyFrom $ c <> ">" + +ttyQuotedMember :: GroupMember -> StyledString +ttyQuotedMember GroupMember {localDisplayName = c} = "> " <> ttyFrom c + +ttyFromContact' :: Contact -> StyledString +ttyFromContact' Contact {localDisplayName = c} = ttyFromContact c ttyGroup :: GroupName -> StyledString ttyGroup g = styled (colored Blue) $ "#" <> g @@ -588,7 +618,13 @@ ttyFullGroup GroupInfo {localDisplayName = g, groupProfile = GroupProfile {fullN ttyGroup g <> optFullName g fullName ttyFromGroup :: GroupInfo -> ContactName -> StyledString -ttyFromGroup GroupInfo {localDisplayName = g} c = styled (colored Yellow) $ "#" <> g <> " " <> c <> "> " +ttyFromGroup GroupInfo {localDisplayName = g} c = ttyFrom $ "#" <> g <> " " <> c <> "> " + +ttyFrom :: Text -> StyledString +ttyFrom = styled $ colored Yellow + +ttyFromGroup' :: GroupInfo -> GroupMember -> StyledString +ttyFromGroup' g GroupMember {localDisplayName = m} = ttyFromGroup g m ttyToGroup :: GroupInfo -> StyledString ttyToGroup GroupInfo {localDisplayName = g} = styled (colored Cyan) $ "#" <> g <> " " @@ -602,10 +638,16 @@ optFullName localDisplayName fullName | otherwise = plain (" (" <> fullName <> ")") highlight :: StyledFormat a => a -> StyledString -highlight = styled (colored Cyan) +highlight = styled $ colored Cyan highlight' :: String -> StyledString highlight' = highlight styleTime :: String -> StyledString styleTime = Styled [SetColor Foreground Vivid Black] + +ttyError :: StyledFormat a => a -> StyledString +ttyError = styled $ colored Red + +ttyError' :: String -> StyledString +ttyError' = ttyError diff --git a/tests/ChatClient.hs b/tests/ChatClient.hs index dd996011cb..b27780430d 100644 --- a/tests/ChatClient.hs +++ b/tests/ChatClient.hs @@ -13,6 +13,8 @@ import Control.Concurrent.STM import Control.Exception (bracket, bracket_) import Control.Monad.Except import Data.List (dropWhileEnd) +import Data.Maybe (fromJust) +import qualified Data.Text as T import Network.Socket import Simplex.Chat import Simplex.Chat.Controller (ChatConfig (..), ChatController (..)) @@ -20,7 +22,7 @@ import Simplex.Chat.Options import Simplex.Chat.Store import Simplex.Chat.Terminal import Simplex.Chat.Terminal.Output (newChatTerminal) -import Simplex.Chat.Types (Profile) +import Simplex.Chat.Types (Profile, User (..)) import Simplex.Messaging.Agent.Env.SQLite import Simplex.Messaging.Agent.RetryInterval import Simplex.Messaging.Server (runSMPServerBlocking) @@ -132,12 +134,16 @@ testChatN ps test = withTmpFiles $ do getTermLine :: TestCC -> IO String getTermLine = atomically . readTQueue . termQ --- Use below to echo virtual terminal +-- Use code below to echo virtual terminal -- getTermLine cc = do -- s <- atomically . readTQueue $ termQ cc --- putStrLn s +-- name <- userName cc +-- putStrLn $ name <> ": " <> s -- pure s +userName :: TestCC -> IO [Char] +userName (TestCC ChatController {currentUser} _ _ _ _) = T.unpack . localDisplayName . fromJust <$> readTVarIO currentUser + testChat2 :: Profile -> Profile -> (TestCC -> TestCC -> IO ()) -> IO () testChat2 p1 p2 test = testChatN [p1, p2] test_ where diff --git a/tests/ChatTests.hs b/tests/ChatTests.hs index dcce728279..c847071858 100644 --- a/tests/ChatTests.hs +++ b/tests/ChatTests.hs @@ -11,7 +11,6 @@ import Control.Concurrent.Async (concurrently_) import Control.Concurrent.STM import qualified Data.ByteString as B import Data.Char (isDigit) -import Data.Maybe (fromJust) import qualified Data.Text as T import Simplex.Chat.Controller (ChatController (..)) import Simplex.Chat.Types (Profile (..), ProfileImage (..), User (..)) @@ -33,10 +32,9 @@ danProfile = Profile {displayName = "dan", fullName = "Daniel", image = Nothing} chatTests :: Spec chatTests = do - describe "direct messages" $ + describe "direct messages" $ do it "add contact and send/receive message" testAddContact - describe "SMP servers" $ - it "get and set SMP servers" testGetSetSMPServers + it "direct message quoted replies" testDirectMessageQuotedReply describe "chat groups" $ do it "add contacts, create group and send/receive messages" testGroup it "create and join group with 4 members" testGroup2 @@ -45,6 +43,7 @@ chatTests = do it "re-add member in status invited" testGroupReAddInvited it "remove contact from group and add again" testGroupRemoveAdd it "list groups containing group invitations" testGroupList + it "group message quoted replies" testGroupMessageQuotedReply describe "user profiles" $ do it "update user profiles and notify contacts" testUpdateProfile it "update user profile with image" testUpdateProfileImage @@ -61,6 +60,8 @@ chatTests = do it "deduplicate contact requests with profile change" testDeduplicateContactRequestsProfileChange it "reject contact and delete contact link" testRejectContactAndDeleteUserContact it "delete connection requests when contact link deleted" testDeleteConnectionRequests + describe "SMP servers" $ + it "get and set SMP servers" testGetSetSMPServers testAddContact :: IO () testAddContact = @@ -73,31 +74,13 @@ testAddContact = concurrently_ (bob <## "alice (Alice): contact is connected") (alice <## "bob (Bob): contact is connected") - -- empty chats - alice #$$> ("/_get chats", [("@bob", "")]) - alice #$> ("/_get chat @2 count=100", chat, []) - bob #$$> ("/_get chats", [("@alice", "")]) - bob #$> ("/_get chat @2 count=100", chat, []) - -- one message + chatsEmpty alice bob alice #> "@bob hello 🙂" bob <# "alice> hello 🙂" - alice #$$> ("/_get chats", [("@bob", "hello 🙂")]) - alice #$> ("/_get chat @2 count=100", chat, [(1, "hello 🙂")]) - bob #$$> ("/_get chats", [("@alice", "hello 🙂")]) - bob #$> ("/_get chat @2 count=100", chat, [(0, "hello 🙂")]) - -- many messages + chatsOneMessage alice bob bob #> "@alice hi" alice <# "bob> hi" - alice #$$> ("/_get chats", [("@bob", "hi")]) - alice #$> ("/_get chat @2 count=100", chat, [(1, "hello 🙂"), (0, "hi")]) - bob #$$> ("/_get chats", [("@alice", "hi")]) - bob #$> ("/_get chat @2 count=100", chat, [(0, "hello 🙂"), (1, "hi")]) - -- pagination - alice #$> ("/_get chat @2 after=1 count=100", chat, [(0, "hi")]) - alice #$> ("/_get chat @2 before=2 count=100", chat, [(1, "hello 🙂")]) - -- read messages - alice #$> ("/_read chat @2 from=1 to=100", id, "ok") - bob #$> ("/_read chat @2 from=1 to=100", id, "ok") + chatsManyMessages alice bob -- test adding the same contact one more time - local name will be different alice ##> "/c" inv' <- getInvitation alice @@ -119,18 +102,49 @@ testAddContact = alice <## "no contact bob_1" alice #$$> ("/_get chats", [("@bob", "hi")]) bob #$$> ("/_get chats", [("@alice_1", "hi"), ("@alice", "hi")]) + where + chatsEmpty alice bob = do + alice #$$> ("/_get chats", [("@bob", "")]) + alice #$> ("/_get chat @2 count=100", chat, []) + bob #$$> ("/_get chats", [("@alice", "")]) + bob #$> ("/_get chat @2 count=100", chat, []) + chatsOneMessage alice bob = do + alice #$$> ("/_get chats", [("@bob", "hello 🙂")]) + alice #$> ("/_get chat @2 count=100", chat, [(1, "hello 🙂")]) + bob #$$> ("/_get chats", [("@alice", "hello 🙂")]) + bob #$> ("/_get chat @2 count=100", chat, [(0, "hello 🙂")]) + chatsManyMessages alice bob = do + alice #$$> ("/_get chats", [("@bob", "hi")]) + alice #$> ("/_get chat @2 count=100", chat, [(1, "hello 🙂"), (0, "hi")]) + bob #$$> ("/_get chats", [("@alice", "hi")]) + bob #$> ("/_get chat @2 count=100", chat, [(0, "hello 🙂"), (1, "hi")]) + -- pagination + alice #$> ("/_get chat @2 after=1 count=100", chat, [(0, "hi")]) + alice #$> ("/_get chat @2 before=2 count=100", chat, [(1, "hello 🙂")]) + -- read messages + alice #$> ("/_read chat @2 from=1 to=100", id, "ok") + bob #$> ("/_read chat @2 from=1 to=100", id, "ok") -testGetSetSMPServers :: IO () -testGetSetSMPServers = +testDirectMessageQuotedReply :: IO () +testDirectMessageQuotedReply = do testChat2 aliceProfile bobProfile $ - \alice _ -> do - alice #$> ("/smp_servers", id, "no custom SMP servers saved") - alice #$> ("/smp_servers smp://1234-w==@smp1.example.im", id, "ok") - alice #$> ("/smp_servers", id, "smp://1234-w==@smp1.example.im") - alice #$> ("/smp_servers smp://2345-w==@smp2.example.im,smp://3456-w==@smp3.example.im:5224", id, "ok") - alice #$> ("/smp_servers", id, "smp://2345-w==@smp2.example.im, smp://3456-w==@smp3.example.im:5224") - alice #$> ("/smp_servers default", id, "ok") - alice #$> ("/smp_servers", id, "no custom SMP servers saved") + \alice bob -> do + connectUsers alice bob + alice ##> "/_send @2 json {\"type\": \"text\", \"text\": \"hello! how are you?\"}" + alice <# "@bob hello! how are you?" + bob <# "alice> hello! how are you?" + bob #> "@alice hi!" + alice <# "bob> hi!" + bob `send` "> @alice (hello) all good - you?" + bob <# "@alice > hello! how are you?" + bob <## " all good - you?" + alice <# "bob> > hello! how are you?" + alice <## " all good - you?" + bob `send` ">> @alice (all good) will tell more" + bob <# "@alice >> all good - you?" + bob <## " will tell more" + alice <# "bob> >> all good - you?" + alice <## " will tell more" testGroup :: IO () testGroup = @@ -184,18 +198,7 @@ testGroup = (alice <# "#team cath> hey team") (bob <# "#team cath> hey team") bob <##> cath - -- get and read chats - alice #$$> ("/_get chats", [("#team", "hey team"), ("@cath", ""), ("@bob", "")]) - alice #$> ("/_get chat #1 count=100", chat, [(1, "hello"), (0, "hi there"), (0, "hey team")]) - alice #$> ("/_get chat #1 after=1 count=100", chat, [(0, "hi there"), (0, "hey team")]) - alice #$> ("/_get chat #1 before=3 count=100", chat, [(1, "hello"), (0, "hi there")]) - bob #$$> ("/_get chats", [("@cath", "hey"), ("#team", "hey team"), ("@alice", "")]) - bob #$> ("/_get chat #1 count=100", chat, [(0, "hello"), (1, "hi there"), (0, "hey team")]) - cath #$$> ("/_get chats", [("@bob", "hey"), ("#team", "hey team"), ("@alice", "")]) - cath #$> ("/_get chat #1 count=100", chat, [(0, "hello"), (0, "hi there"), (1, "hey team")]) - alice #$> ("/_read chat #1 from=1 to=100", id, "ok") - bob #$> ("/_read chat #1 from=1 to=100", id, "ok") - cath #$> ("/_read chat #1 from=1 to=100", id, "ok") + getReadChats alice bob cath -- list groups alice ##> "/gs" alice <## "#team" @@ -230,6 +233,19 @@ testGroup = cath ##> "#team hello" cath <## "you are no longer a member of the group" bob <##> cath + where + getReadChats alice bob cath = do + alice #$$> ("/_get chats", [("#team", "hey team"), ("@cath", ""), ("@bob", "")]) + alice #$> ("/_get chat #1 count=100", chat, [(1, "hello"), (0, "hi there"), (0, "hey team")]) + alice #$> ("/_get chat #1 after=1 count=100", chat, [(0, "hi there"), (0, "hey team")]) + alice #$> ("/_get chat #1 before=3 count=100", chat, [(1, "hello"), (0, "hi there")]) + bob #$$> ("/_get chats", [("@cath", "hey"), ("#team", "hey team"), ("@alice", "")]) + bob #$> ("/_get chat #1 count=100", chat, [(0, "hello"), (1, "hi there"), (0, "hey team")]) + cath #$$> ("/_get chats", [("@bob", "hey"), ("#team", "hey team"), ("@alice", "")]) + cath #$> ("/_get chat #1 count=100", chat, [(0, "hello"), (0, "hi there"), (1, "hey team")]) + alice #$> ("/_read chat #1 from=1 to=100", id, "ok") + bob #$> ("/_read chat #1 from=1 to=100", id, "ok") + cath #$> ("/_read chat #1 from=1 to=100", id, "ok") testGroup2 :: IO () testGroup2 = @@ -543,6 +559,52 @@ testGroupList = bob ##> "/gs" bob <## "#team" +testGroupMessageQuotedReply :: IO () +testGroupMessageQuotedReply = + testChat3 aliceProfile bobProfile cathProfile $ + \alice bob cath -> do + createGroup3 "team" alice bob cath + alice #> "#team hello! how are you?" + concurrently_ + (bob <# "#team alice> hello! how are you?") + (cath <# "#team alice> hello! how are you?") + bob `send` "> #team @alice (hello) hello, all good, you?" + bob <# "#team > alice hello! how are you?" + bob <## " hello, all good, you?" + concurrently_ + ( do + alice <# "#team bob> > alice hello! how are you?" + alice <## " hello, all good, you?" + ) + ( do + cath <# "#team bob> > alice hello! how are you?" + cath <## " hello, all good, you?" + ) + bob `send` "> #team bob (hello, all good) will tell more" + bob <# "#team > bob hello, all good, you?" + bob <## " will tell more" + concurrently_ + ( do + alice <# "#team bob> > bob hello, all good, you?" + alice <## " will tell more" + ) + ( do + cath <# "#team bob> > bob hello, all good, you?" + cath <## " will tell more" + ) + cath `send` "> #team bob (hello) hi there!" + cath <# "#team > bob hello, all good, you?" + cath <## " hi there!" + concurrently_ + ( do + alice <# "#team cath> > bob hello, all good, you?" + alice <## " hi there!" + ) + ( do + bob <# "#team cath> > bob hello, all good, you?" + bob <## " hi there!" + ) + testUpdateProfile :: IO () testUpdateProfile = testChat3 aliceProfile bobProfile cathProfile $ @@ -952,6 +1014,18 @@ testDeleteConnectionRequests = testChat3 aliceProfile bobProfile cathProfile $ cath ##> ("/c " <> cLink') alice <#? cath +testGetSetSMPServers :: IO () +testGetSetSMPServers = + testChat2 aliceProfile bobProfile $ + \alice _ -> do + alice #$> ("/smp_servers", id, "no custom SMP servers saved") + alice #$> ("/smp_servers smp://1234-w==@smp1.example.im", id, "ok") + alice #$> ("/smp_servers", id, "smp://1234-w==@smp1.example.im") + alice #$> ("/smp_servers smp://2345-w==@smp2.example.im,smp://3456-w==@smp3.example.im:5224", id, "ok") + alice #$> ("/smp_servers", id, "smp://2345-w==@smp2.example.im, smp://3456-w==@smp3.example.im:5224") + alice #$> ("/smp_servers default", id, "ok") + alice #$> ("/smp_servers", id, "no custom SMP servers saved") + startFileTransfer :: TestCC -> TestCC -> IO () startFileTransfer alice bob = do alice #> "/f @bob ./tests/fixtures/test.jpg" @@ -1042,9 +1116,6 @@ cc1 <##> cc2 = do cc2 #> ("@" <> name1 <> " hey") cc1 <# (name2 <> "> hey") -userName :: TestCC -> IO [Char] -userName (TestCC ChatController {currentUser} _ _ _ _) = T.unpack . localDisplayName . fromJust <$> readTVarIO currentUser - (##>) :: TestCC -> String -> IO () cc ##> cmd = do cc `send` cmd diff --git a/tests/ProtocolTests.hs b/tests/ProtocolTests.hs index a94f0d66b9..43affb8216 100644 --- a/tests/ProtocolTests.hs +++ b/tests/ProtocolTests.hs @@ -7,6 +7,7 @@ module ProtocolTests where import qualified Data.Aeson as J import Data.ByteString.Char8 (ByteString) +import Data.Time.Clock.System (SystemTime (..), systemToUTCTime) import Simplex.Chat.Protocol import Simplex.Chat.Types import Simplex.Messaging.Agent.Protocol @@ -54,15 +55,26 @@ testE2ERatchetParams = E2ERatchetParamsUri e2eEncryptVRange testDhPubKey testDhP testConnReq :: ConnectionRequestUri 'CMInvitation testConnReq = CRInvitationUri connReqData testE2ERatchetParams +(==##) :: ByteString -> ChatMessage -> Expectation +s ==## msg = do + strDecode s `shouldBe` Right msg + parseAll strP s `shouldBe` Right msg + +(##==) :: ByteString -> ChatMessage -> Expectation +s ##== msg = + J.eitherDecodeStrict' (strEncode msg) + `shouldBe` (J.eitherDecodeStrict' s :: Either String J.Value) + +(##==##) :: ByteString -> ChatMessage -> Expectation +s ##==## msg = do + s ##== msg + s ==## msg + (==#) :: ByteString -> ChatMsgEvent -> Expectation -s ==# msg = do - strDecode s `shouldBe` Right (ChatMessage msg) - parseAll strP s `shouldBe` Right (ChatMessage msg) +s ==# msg = s ==## (ChatMessage Nothing msg) (#==) :: ByteString -> ChatMsgEvent -> Expectation -s #== msg = - J.eitherDecodeStrict' (strEncode $ ChatMessage msg) - `shouldBe` (J.eitherDecodeStrict' s :: Either String J.Value) +s #== msg = s ##== (ChatMessage Nothing msg) (#==#) :: ByteString -> ChatMsgEvent -> Expectation s #==# msg = do @@ -77,7 +89,24 @@ testGroupProfile = GroupProfile {displayName = "team", fullName = "Team", image decodeChatMessageTest :: Spec decodeChatMessageTest = describe "Chat message encoding/decoding" $ do - it "x.msg.new" $ "{\"event\":\"x.msg.new\",\"params\":{\"content\":{\"text\":\"hello\",\"type\":\"text\"}}}" #==# XMsgNew (MCText "hello") + it "x.msg.new" $ "{\"event\":\"x.msg.new\",\"params\":{\"content\":{\"text\":\"hello\",\"type\":\"text\"}}}" #==# XMsgNew (MCSimple $ MCText "hello") + it "x.msg.new" $ "{\"msgId\":\"AQIDBA==\",\"event\":\"x.msg.new\",\"params\":{\"content\":{\"text\":\"hello\",\"type\":\"text\"}}}" ##==## (ChatMessage (Just $ SharedMsgId "\1\2\3\4") (XMsgNew . MCSimple $ MCText "hello")) + it "x.msg.new" $ + "{\"msgId\":\"AQIDBA==\",\"event\":\"x.msg.new\",\"params\":{\"content\":{\"text\":\"hello to you too\",\"type\":\"text\"},\"quote\":{\"content\":{\"text\":\"hello there!\",\"type\":\"text\"},\"msgRef\":{\"msgId\":\"BQYHCA==\",\"sent\":true,\"sentAt\":\"1970-01-01T00:00:01.000000001Z\",\"type\":\"direct\"}}}}" + ##==## ( ChatMessage + (Just $ SharedMsgId "\1\2\3\4") + ( XMsgNew $ + MCQuote + ( QuotedMsg + (MsgRefDirect (Just $ SharedMsgId "\5\6\7\8") (systemToUTCTime $ MkSystemTime 1 1) True) + $ MCText "hello there!" + ) + (MCText "hello to you too") + ) + ) + it "x.msg.new" $ + "{\"msgId\":\"AQIDBA==\",\"event\":\"x.msg.new\",\"params\":{\"content\":{\"text\":\"hello\",\"type\":\"text\"},\"forward\":true}}" + ##==## (ChatMessage (Just $ SharedMsgId "\1\2\3\4") (XMsgNew . MCForward $ MCText "hello")) it "x.file" $ "{\"event\":\"x.file\",\"params\":{\"file\":{\"fileConnReq\":\"https://simplex.chat/invitation#/?v=1&smp=smp%3A%2F%2F1234-w%3D%3D%40smp.simplex.im%3A5223%2F3456-w%3D%3D%23MCowBQYDK2VuAyEAjiswwI3O_NlS8Fk3HJUW870EY2bAwmttMBsvRB9eV3o%3D&e2e=v%3D1%26x3dh%3DMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D%2CMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D\",\"fileSize\":12345,\"fileName\":\"photo.jpg\"}}}" #==# XFile FileInvitation {fileName = "photo.jpg", fileSize = 12345, fileConnReq = testConnReq}