diff --git a/src/Simplex/Chat.hs b/src/Simplex/Chat.hs index 2f6b792901..a3ae7b23cb 100644 --- a/src/Simplex/Chat.hs +++ b/src/Simplex/Chat.hs @@ -686,7 +686,7 @@ processChatCommand = \case withStore $ \db -> getDirectChatItem db user chatId quotedItemId (origQmc, qd, sent) <- quoteData qci let msgRef = MsgRef {msgId = itemSharedMsgId, sentAt = itemTs, sent, memberId = Nothing} - qmc = quoteContent origQmc file + qmc = quoteContent mc origQmc file quotedItem = CIQuote {chatDir = qd, itemId = Just quotedItemId, sharedMsgId = itemSharedMsgId, sentAt = itemTs, content = qmc, formattedText} pure (MCQuote QuotedMsg {msgRef, content = qmc} (ExtMsgContent mc fInv_ (ttl' <$> timed_) (justTrue live)), Just quotedItem) where @@ -700,13 +700,13 @@ processChatCommand = \case assertUserGroupRole gInfo GRAuthor send g where - send g@(Group gInfo@GroupInfo {groupId, membership} ms) + send g@(Group gInfo@GroupInfo {groupId} ms) | isVoice mc && not (groupFeatureAllowed SGFVoice gInfo) = notAllowedError GFVoice | not (isVoice mc) && isJust file_ && not (groupFeatureAllowed SGFFiles gInfo) = notAllowedError GFFiles | otherwise = do (fInv_, ciFile_, ft_) <- unzipMaybe3 <$> setupSndFileTransfer g (length $ filter memberCurrent ms) timed_ <- sndGroupCITimed live gInfo itemTTL - (msgContainer, quotedItem_) <- prepareMsg fInv_ timed_ membership + (msgContainer, quotedItem_) <- prepareGroupMsg user gInfo mc quotedItemId_ fInv_ timed_ live (msg@SndMessage {sharedMsgId}, sentToMembers) <- sendGroupMessage user gInfo ms (XMsgNew msgContainer) ci <- saveSndChatItem' user (CDGroupSnd gInfo) msg (CISndMsgContent mc) ciFile_ quotedItem_ timed_ live withStore' $ \db -> @@ -746,51 +746,9 @@ processChatCommand = \case void . withStore' $ \db -> createSndGroupInlineFT db m conn ft sendMemberFileInline m conn ft sharedMsgId processMember _ = pure () - prepareMsg :: Maybe FileInvitation -> Maybe CITimed -> GroupMember -> m (MsgContainer, Maybe (CIQuote 'CTGroup)) - prepareMsg fInv_ timed_ membership = case quotedItemId_ of - Nothing -> pure (MCSimple (ExtMsgContent mc fInv_ (ttl' <$> timed_) (justTrue live)), Nothing) - Just quotedItemId -> do - CChatItem _ qci@ChatItem {meta = CIMeta {itemTs, itemSharedMsgId}, formattedText, file} <- - withStore $ \db -> getGroupChatItem db user chatId quotedItemId - (origQmc, qd, sent, GroupMember {memberId}) <- quoteData qci membership - let msgRef = MsgRef {msgId = itemSharedMsgId, sentAt = itemTs, sent, memberId = Just memberId} - qmc = quoteContent origQmc file - quotedItem = CIQuote {chatDir = qd, itemId = Just quotedItemId, sharedMsgId = itemSharedMsgId, sentAt = itemTs, content = qmc, formattedText} - pure (MCQuote QuotedMsg {msgRef, content = qmc} (ExtMsgContent mc fInv_ (ttl' <$> timed_) (justTrue live)), Just quotedItem) - where - quoteData :: ChatItem c d -> GroupMember -> m (MsgContent, CIQDirection 'CTGroup, Bool, GroupMember) - quoteData ChatItem {meta = CIMeta {itemDeleted = Just _}} _ = throwChatError CEInvalidQuote - quoteData ChatItem {chatDir = CIGroupSnd, content = CISndMsgContent qmc} membership' = pure (qmc, CIQGroupSnd, True, membership') - quoteData ChatItem {chatDir = CIGroupRcv m, content = CIRcvMsgContent qmc} _ = pure (qmc, CIQGroupRcv $ Just m, False, m) - quoteData _ _ = throwChatError CEInvalidQuote CTContactRequest -> pure $ chatCmdError (Just user) "not supported" CTContactConnection -> pure $ chatCmdError (Just user) "not supported" where - quoteContent :: forall d. MsgContent -> Maybe (CIFile d) -> MsgContent - quoteContent qmc ciFile_ - | replaceContent = MCText qTextOrFile - | otherwise = case qmc of - MCImage _ image -> MCImage qTextOrFile image - MCFile _ -> MCFile qTextOrFile - -- consider same for voice messages - -- MCVoice _ voice -> MCVoice qTextOrFile voice - _ -> qmc - where - -- if the message we're quoting with is one of the "large" MsgContents - -- we replace the quote's content with MCText - replaceContent = case mc of - MCText _ -> False - MCFile _ -> False - MCLink {} -> True - MCImage {} -> True - MCVideo {} -> True - MCVoice {} -> False - MCUnknown {} -> True - qText = msgContentText qmc - getFileName :: CIFile d -> String - getFileName CIFile {fileName} = fileName - qFileName = maybe qText (T.pack . getFileName) ciFile_ - qTextOrFile = if T.null qText then qFileName else qText xftpSndFileTransfer :: User -> CryptoFile -> Integer -> Int -> ContactOrGroup -> m (FileInvitation, CIFile 'MDSnd, FileTransferMeta) xftpSndFileTransfer user file@(CryptoFile filePath cfArgs) fileSize n contactOrGroup = do let fileName = takeFileName filePath @@ -2427,6 +2385,50 @@ processChatCommand = \case cReqHashes = bimap hash hash cReqSchemas hash = ConnReqUriHash . C.sha256Hash . strEncode +prepareGroupMsg :: forall m. ChatMonad m => User -> GroupInfo -> MsgContent -> Maybe ChatItemId -> Maybe FileInvitation -> Maybe CITimed -> Bool -> m (MsgContainer, Maybe (CIQuote 'CTGroup)) +prepareGroupMsg user GroupInfo {groupId, membership} mc quotedItemId_ fInv_ timed_ live = case quotedItemId_ of + Nothing -> pure (MCSimple (ExtMsgContent mc fInv_ (ttl' <$> timed_) (justTrue live)), Nothing) + Just quotedItemId -> do + CChatItem _ qci@ChatItem {meta = CIMeta {itemTs, itemSharedMsgId}, formattedText, file} <- + withStore $ \db -> getGroupChatItem db user groupId quotedItemId + (origQmc, qd, sent, GroupMember {memberId}) <- quoteData qci membership + let msgRef = MsgRef {msgId = itemSharedMsgId, sentAt = itemTs, sent, memberId = Just memberId} + qmc = quoteContent mc origQmc file + quotedItem = CIQuote {chatDir = qd, itemId = Just quotedItemId, sharedMsgId = itemSharedMsgId, sentAt = itemTs, content = qmc, formattedText} + pure (MCQuote QuotedMsg {msgRef, content = qmc} (ExtMsgContent mc fInv_ (ttl' <$> timed_) (justTrue live)), Just quotedItem) + where + quoteData :: ChatItem c d -> GroupMember -> m (MsgContent, CIQDirection 'CTGroup, Bool, GroupMember) + quoteData ChatItem {meta = CIMeta {itemDeleted = Just _}} _ = throwChatError CEInvalidQuote + quoteData ChatItem {chatDir = CIGroupSnd, content = CISndMsgContent qmc} membership' = pure (qmc, CIQGroupSnd, True, membership') + quoteData ChatItem {chatDir = CIGroupRcv m, content = CIRcvMsgContent qmc} _ = pure (qmc, CIQGroupRcv $ Just m, False, m) + quoteData _ _ = throwChatError CEInvalidQuote + +quoteContent :: forall d. MsgContent -> MsgContent -> Maybe (CIFile d) -> MsgContent +quoteContent mc qmc ciFile_ + | replaceContent = MCText qTextOrFile + | otherwise = case qmc of + MCImage _ image -> MCImage qTextOrFile image + MCFile _ -> MCFile qTextOrFile + -- consider same for voice messages + -- MCVoice _ voice -> MCVoice qTextOrFile voice + _ -> qmc + where + -- if the message we're quoting with is one of the "large" MsgContents + -- we replace the quote's content with MCText + replaceContent = case mc of + MCText _ -> False + MCFile _ -> False + MCLink {} -> True + MCImage {} -> True + MCVideo {} -> True + MCVoice {} -> False + MCUnknown {} -> True + qText = msgContentText qmc + getFileName :: CIFile d -> String + getFileName CIFile {fileName} = fileName + qFileName = maybe qText (T.pack . getFileName) ciFile_ + qTextOrFile = if T.null qText then qFileName else qText + assertDirectAllowed :: ChatMonad m => User -> MsgDirection -> Contact -> CMEventTag e -> m () assertDirectAllowed user dir ct event = unless (allowedChatEvent || anyDirectOrUsed ct) . unlessM directMessagesAllowed $ @@ -2604,7 +2606,7 @@ acceptFileReceive user@User {userId} RcvFileTransfer {fileId, xftpRcvFile, fileI -- marking file as accepted and reading description in the same transaction -- to prevent race condition with appending description ci <- xftpAcceptRcvFT db user fileId filePath - rfd <- getRcvFileDescrByFileId db fileId + rfd <- getRcvFileDescrByRcvFileId db fileId pure (ci, rfd) receiveViaCompleteFD user fileId rfd cryptoArgs pure ci @@ -3581,9 +3583,8 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do let events = map (XGrpMemIntro . memberInfo . reMember) shuffledIntros forM_ (L.nonEmpty events) $ \events' -> sendBatchedDirectMessages conn events' (GroupId groupId) - else - forM_ shuffledIntros $ \intro -> - processIntro intro `catchChatError` (toView . CRChatError (Just user)) + else forM_ shuffledIntros $ \intro -> + processIntro intro `catchChatError` (toView . CRChatError (Just user)) shuffleIntros :: [GroupMemberIntro] -> IO [GroupMemberIntro] shuffleIntros intros = do let (admins, others) = partition isAdmin intros @@ -3602,10 +3603,92 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do withStore' $ \db -> updateIntroStatus db introId GMIntroSent sendHistory = when (isCompatibleRange (memberChatVRange' m) batchSendVRange) $ do - (errs, events) <- withStore' $ \db -> getGroupMsgsHistory db user gInfo 300 - toView $ CRChatErrors (Just user) (map ChatErrorStore errs) + (errs, items) <- withStore' $ \db -> getGroupHistoryLastItems db user gInfo 100 + (errs', events) <- collectForwardEvents items [] [] + toView $ CRChatErrors (Just user) (map ChatErrorStore errs <> errs' ) forM_ (L.nonEmpty events) $ \events' -> sendBatchedDirectMessages conn events' (GroupId groupId) + collectForwardEvents :: [CChatItem 'CTGroup] -> [ChatError] -> [ChatMsgEvent 'Json] -> m ([ChatError], [ChatMsgEvent 'Json]) + collectForwardEvents [] errs evts = pure (errs, evts) + collectForwardEvents (ci : items) errs evts = + flip catchChatError (\e -> collectForwardEvents items (e : errs) evts) $ case ci of + (CChatItem SMDRcv ChatItem {chatDir = CIGroupRcv sender, meta, content = CIRcvMsgContent mc, quotedItem, file}) -> do + fInvDescr_ <- join <$> forM file getRcvFileInvDescr + if isNothing fInvDescr_ && not (msgContentHasText mc) + then collectForwardEvents items errs evts + else do + let CIMeta {itemTs, itemSharedMsgId, itemTimed} = meta + quotedItemId_ = quoteItemId =<< quotedItem + fInv_ = fst <$> fInvDescr_ + (msgContainer, _) <- prepareGroupMsg user gInfo mc quotedItemId_ fInv_ itemTimed False + let senderVRange = memberChatVRange' sender + xMsgNewChatMsg = ChatMessage {chatVRange = senderVRange, msgId = itemSharedMsgId, chatMsgEvent = XMsgNew msgContainer} + fileDescrEvents <- case (snd <$> fInvDescr_, itemSharedMsgId) of + (Just fileDescrText, Just msgId) -> prepareFileDescrEvents fileDescrText msgId + _ -> pure [] + let fileDescrChatMsgs = map (ChatMessage senderVRange Nothing) fileDescrEvents + GroupMember {memberId} = sender + msgForwardEvents = map (\cm -> XGrpMsgForward memberId cm itemTs) (xMsgNewChatMsg : fileDescrChatMsgs) + collectForwardEvents items errs (msgForwardEvents <> evts) + where + getRcvFileInvDescr :: CIFile 'MDRcv -> m (Maybe (FileInvitation, RcvFileDescrText)) + getRcvFileInvDescr CIFile {fileId, fileName, fileSize, fileProtocol, fileStatus} + | fileProtocol /= FPXFTP || fileStatus == CIFSRcvCancelled = pure Nothing + | otherwise = do + RcvFileDescr {fileDescrText, fileDescrComplete} <- withStore $ \db -> getRcvFileDescrByRcvFileId db fileId + if fileDescrComplete + then do + let fInvDescr = FileDescr {fileDescrText = "", fileDescrPartNo = 0, fileDescrComplete = False} + fInv = xftpFileInvitation fileName fileSize fInvDescr + pure $ Just (fInv, fileDescrText) + else pure Nothing + (CChatItem SMDSnd ChatItem {chatDir = CIGroupSnd, meta, content = CISndMsgContent mc, quotedItem, file}) -> do + fInvDescr_ <- join <$> forM file getSndFileInvDescr + if isNothing fInvDescr_ && not (msgContentHasText mc) + then collectForwardEvents items errs evts + else do + let CIMeta {itemTs, itemSharedMsgId, itemTimed} = meta + quotedItemId_ = quoteItemId =<< quotedItem + fInv_ = fst <$> fInvDescr_ + (msgContainer, _) <- prepareGroupMsg user gInfo mc quotedItemId_ fInv_ itemTimed False + let senderVRange = memberChatVRange' membership + xMsgNewChatMsg = ChatMessage {chatVRange = senderVRange, msgId = itemSharedMsgId, chatMsgEvent = XMsgNew msgContainer} + fileDescrEvents <- case (snd <$> fInvDescr_, itemSharedMsgId) of + (Just fileDescrText, Just msgId) -> prepareFileDescrEvents fileDescrText msgId + _ -> pure [] + let fileDescrChatMsgs = map (ChatMessage senderVRange Nothing) fileDescrEvents + GroupMember {memberId} = membership + msgForwardEvents = map (\cm -> XGrpMsgForward memberId cm itemTs) (xMsgNewChatMsg : fileDescrChatMsgs) + collectForwardEvents items errs (msgForwardEvents <> evts) + where + getSndFileInvDescr :: CIFile 'MDSnd -> m (Maybe (FileInvitation, RcvFileDescrText)) + getSndFileInvDescr CIFile {fileId, fileName, fileSize, fileProtocol, fileStatus} + | fileProtocol /= FPXFTP || fileStatus == CIFSSndCancelled = pure Nothing + | otherwise = do + -- can also lookup in extra_xftp_file_descriptions, though it can be empty; + -- would be best if snd file had a single rcv description for all members saved in files table + RcvFileDescr {fileDescrText, fileDescrComplete} <- withStore $ \db -> getRcvFileDescrBySndFileId db fileId + if fileDescrComplete + then do + let fInvDescr = FileDescr {fileDescrText = "", fileDescrPartNo = 0, fileDescrComplete = False} + fInv = xftpFileInvitation fileName fileSize fInvDescr + pure $ Just (fInv, fileDescrText) + else pure Nothing + _ -> collectForwardEvents items errs evts + where + prepareFileDescrEvents :: RcvFileDescrText -> SharedMsgId -> m [ChatMsgEvent 'Json] + prepareFileDescrEvents fileDescrText msgId = do + partSize <- asks $ xftpDescrPartSize . config + pure $ prepareParts 1 partSize fileDescrText [] + where + prepareParts partNo partSize rfdText events = do + let (part, rest) = T.splitAt partSize rfdText + complete = T.null rest + fileDescr = FileDescr {fileDescrText = part, fileDescrPartNo = partNo, fileDescrComplete = complete} + events' = XMsgFileDescr {msgId, fileDescr} : events + if complete + then reverse events' + else prepareParts (partNo + 1) partSize rest events' _ -> do let memCategory = memberCategory m withStore' (\db -> getViaGroupContact db user m) >>= \case @@ -5226,10 +5309,6 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do processForwardedMsg :: GroupMember -> ChatMessage 'Json -> m () processForwardedMsg author chatMsg = do let body = LB.toStrict $ J.encode msg - -- TODO [batch send] save broker ts (here - msgTs) on messages received via forward to include in history - -- consider adding chat_ts to messages table: as of now, messages received via forward - -- wouldn't have a record in msg_deliveries to retrieve it from; - -- practically it's not a problem if members join via a single same admin (e.g. directory bot) rcvMsg@RcvMessage {chatMsgEvent = ACME _ event} <- saveGroupFwdRcvMsg user groupId m author body chatMsg case event of XMsgNew mc -> memberCanSend author $ newGroupContentMessage gInfo author mc rcvMsg msgTs @@ -5556,21 +5635,21 @@ sendBatchedDirectMessages conn@Connection {connId} events connOrGroupId = do withStore' $ \db -> forM_ sndMsgs $ \SndMessage {msgId} -> createSndMsgDelivery db sndMsgDelivery msgId where - createSndMessages :: m [Either StoreError SndMessage] - createSndMessages = do - gVar <- asks idsDrg - ChatConfig {chatVRange} <- asks config - withStore' $ \db -> forM (toList events) $ \event -> - runExceptT $ createNewSndMessage db gVar connOrGroupId (newMsg chatVRange event) - newMsg chatVRange chatMsgEvent sharedMsgId = - let msgBody = encodeChatMessage ChatMessage {chatVRange, msgId = Just sharedMsgId, chatMsgEvent} - in NewMessage {chatMsgEvent, msgBody} - partitionBatches :: [ChatMessageBatch] -> ([SndMessage], [MessagesBatch]) - partitionBatches = foldr partition' ([], []) - where - partition' :: ChatMessageBatch -> ([SndMessage], [MessagesBatch]) -> ([SndMessage], [MessagesBatch]) - partition' (CMBMessages msgBatch) (largeMsgs, msgBatches) = (largeMsgs, msgBatch : msgBatches) - partition' (CMBLargeMessage largeMsg) (largeMsgs, msgBatches) = (largeMsg : largeMsgs, msgBatches) + createSndMessages :: m [Either StoreError SndMessage] + createSndMessages = do + gVar <- asks idsDrg + ChatConfig {chatVRange} <- asks config + withStore' $ \db -> forM (toList events) $ \event -> + runExceptT $ createNewSndMessage db gVar connOrGroupId (newMsg chatVRange event) + newMsg chatVRange chatMsgEvent sharedMsgId = + let msgBody = encodeChatMessage ChatMessage {chatVRange, msgId = Just sharedMsgId, chatMsgEvent} + in NewMessage {chatMsgEvent, msgBody} + partitionBatches :: [ChatMessageBatch] -> ([SndMessage], [MessagesBatch]) + partitionBatches = foldr partition' ([], []) + where + partition' :: ChatMessageBatch -> ([SndMessage], [MessagesBatch]) -> ([SndMessage], [MessagesBatch]) + partition' (CMBMessages msgBatch) (largeMsgs, msgBatches) = (largeMsgs, msgBatch : msgBatches) + partition' (CMBLargeMessage largeMsg) (largeMsgs, msgBatches) = (largeMsg : largeMsgs, msgBatches) data MessagesBatch = MessagesBatch ByteString [SndMessage] diff --git a/src/Simplex/Chat/Messages.hs b/src/Simplex/Chat/Messages.hs index 9604b71838..08a7807dd1 100644 --- a/src/Simplex/Chat/Messages.hs +++ b/src/Simplex/Chat/Messages.hs @@ -370,6 +370,9 @@ data CIQuote (c :: ChatType) = CIQuote } deriving (Show) +quoteItemId :: CIQuote c -> Maybe ChatItemId +quoteItemId CIQuote {itemId} = itemId + data CIReaction (c :: ChatType) (d :: MsgDirection) = CIReaction { chatDir :: CIDirection c d, chatItem :: CChatItem c, diff --git a/src/Simplex/Chat/Messages/CIContent.hs b/src/Simplex/Chat/Messages/CIContent.hs index a987603bb6..b878949cab 100644 --- a/src/Simplex/Chat/Messages/CIContent.hs +++ b/src/Simplex/Chat/Messages/CIContent.hs @@ -575,10 +575,16 @@ dbParseACIContent = fmap aciContentDBJSON . J.eitherDecodeStrict' . encodeUtf8 instance FromJSON ACIContent where parseJSON = fmap aciContentJSON . J.parseJSON +sndMsgContentTag :: Text +sndMsgContentTag = "sndMsgContent" + +rcvMsgContentTag :: Text +rcvMsgContentTag = "rcvMsgContent" + toCIContentTag :: CIContent e -> Text toCIContentTag ciContent = case ciContent of - CISndMsgContent _ -> "sndMsgContent" - CIRcvMsgContent _ -> "rcvMsgContent" + CISndMsgContent _ -> sndMsgContentTag + CIRcvMsgContent _ -> rcvMsgContentTag CISndDeleted _ -> "sndDeleted" CIRcvDeleted _ -> "rcvDeleted" CISndCall {} -> "sndCall" diff --git a/src/Simplex/Chat/Migrations/M20231215_recreate_msg_deliveries.hs b/src/Simplex/Chat/Migrations/M20231215_recreate_msg_deliveries.hs index 428e5479fb..dff8d4665e 100644 --- a/src/Simplex/Chat/Migrations/M20231215_recreate_msg_deliveries.hs +++ b/src/Simplex/Chat/Migrations/M20231215_recreate_msg_deliveries.hs @@ -39,16 +39,11 @@ ALTER TABLE new_msg_deliveries RENAME TO msg_deliveries; CREATE INDEX idx_msg_deliveries_message_id ON "msg_deliveries"(message_id); CREATE INDEX idx_msg_deliveries_agent_ack_cmd_id ON "msg_deliveries"(connection_id, agent_ack_cmd_id); CREATE INDEX idx_msg_deliveries_agent_msg_id ON "msg_deliveries"(connection_id, agent_msg_id); - --- for message history retrieval -CREATE INDEX idx_messages_group_id_created_at ON messages(group_id, created_at); |] down_m20231215_recreate_msg_deliveries :: Query down_m20231215_recreate_msg_deliveries = [sql| -DROP INDEX idx_messages_group_id_created_at; - DROP INDEX idx_msg_deliveries_message_id; DROP INDEX idx_msg_deliveries_agent_ack_cmd_id; DROP INDEX idx_msg_deliveries_agent_msg_id; diff --git a/src/Simplex/Chat/Migrations/chat_schema.sql b/src/Simplex/Chat/Migrations/chat_schema.sql index 1d890b97d8..7a3be6e3ae 100644 --- a/src/Simplex/Chat/Migrations/chat_schema.sql +++ b/src/Simplex/Chat/Migrations/chat_schema.sql @@ -812,7 +812,3 @@ CREATE INDEX idx_msg_deliveries_agent_msg_id ON "msg_deliveries"( connection_id, agent_msg_id ); -CREATE INDEX idx_messages_group_id_created_at ON messages( - group_id, - created_at -); diff --git a/src/Simplex/Chat/Protocol.hs b/src/Simplex/Chat/Protocol.hs index 47acd15a96..8d6c85ef6c 100644 --- a/src/Simplex/Chat/Protocol.hs +++ b/src/Simplex/Chat/Protocol.hs @@ -31,7 +31,6 @@ import qualified Data.ByteString.Char8 as B import Data.ByteString.Internal (c2w, w2c) import qualified Data.ByteString.Lazy.Char8 as LB import Data.Maybe (fromMaybe) -import Data.Set (Set) import Data.String import Data.Text (Text) import qualified Data.Text as T @@ -150,7 +149,7 @@ instance StrEncoding AppMessageBinary where pure AppMessageBinary {tag, msgId, body} newtype SharedMsgId = SharedMsgId ByteString - deriving (Eq, Ord, Show) + deriving (Eq, Show) instance FromField SharedMsgId where fromField f = SharedMsgId <$> fromField f @@ -290,24 +289,6 @@ forwardedGroupMsg msg@ChatMessage {chatMsgEvent} = case encoding @e of SJson | isForwardedGroupMsg chatMsgEvent -> Just msg _ -> Nothing -msgIncludedInHistory :: forall e. MsgEncodingI e => ChatMessage e -> Set SharedMsgId -> Maybe (ChatMessage 'Json) -msgIncludedInHistory msg@ChatMessage {chatMsgEvent} refMsgIds = case encoding @e of - SJson -> case chatMsgEvent of - XMsgNew mc -> case mcExtMsgContent mc of - ExtMsgContent {file = Just FileInvitation {fileInline = Just _}} -> Nothing - _ -> Just msg - XMsgFileDescr msgId _ -> refIncluded msgId - XMsgUpdate {msgId} -> refIncluded msgId - XMsgDel msgId _ -> refIncluded msgId - XMsgReact {msgId} -> refIncluded msgId - XFileCancel msgId -> refIncluded msgId - _ -> Nothing - where - refIncluded msgId - | msgId `elem` refMsgIds = Just msg - | otherwise = Nothing - _ -> Nothing - data MsgReaction = MREmoji {emoji :: MREmojiChar} | MRUnknown {tag :: Text, json :: J.Object} deriving (Eq, Show) @@ -470,6 +451,18 @@ durationText duration = | n <= 9 = '0' : show n | otherwise = show n +msgContentHasText :: MsgContent -> Bool +msgContentHasText = \case + MCText t -> hasText t + MCLink {text} -> hasText text + MCImage {text} -> hasText text + MCVideo {text} -> hasText text + MCVoice {text} -> hasText text + MCFile t -> hasText t + MCUnknown {text} -> hasText text + where + hasText = not . T.null + isVoice :: MsgContent -> Bool isVoice = \case MCVoice {} -> True diff --git a/src/Simplex/Chat/Store/Files.hs b/src/Simplex/Chat/Store/Files.hs index 8fe97896c8..b92dbc3e34 100644 --- a/src/Simplex/Chat/Store/Files.hs +++ b/src/Simplex/Chat/Store/Files.hs @@ -47,7 +47,8 @@ module Simplex.Chat.Store.Files createRcvFileTransfer, createRcvGroupFileTransfer, appendRcvFD, - getRcvFileDescrByFileId, + getRcvFileDescrByRcvFileId, + getRcvFileDescrBySndFileId, updateRcvFileAgentId, getRcvFileTransferById, getRcvFileTransfer, @@ -543,7 +544,7 @@ createRcvFD_ db userId currentTs FileDescr {fileDescrText, fileDescrPartNo, file appendRcvFD :: DB.Connection -> UserId -> FileTransferId -> FileDescr -> ExceptT StoreError IO RcvFileDescr appendRcvFD db userId fileId fd@FileDescr {fileDescrText, fileDescrPartNo, fileDescrComplete} = do currentTs <- liftIO getCurrentTime - liftIO (getRcvFileDescrByFileId_ db fileId) >>= \case + liftIO (getRcvFileDescrByRcvFileId_ db fileId) >>= \case Nothing -> do rfd@RcvFileDescr {fileDescrId} <- createRcvFD_ db userId currentTs fd liftIO $ @@ -572,14 +573,14 @@ appendRcvFD db userId fileId fd@FileDescr {fileDescrText, fileDescrPartNo, fileD (fileDescrText', fileDescrPartNo, fileDescrComplete, fileDescrId) pure RcvFileDescr {fileDescrId, fileDescrText = fileDescrText', fileDescrPartNo, fileDescrComplete} -getRcvFileDescrByFileId :: DB.Connection -> FileTransferId -> ExceptT StoreError IO RcvFileDescr -getRcvFileDescrByFileId db fileId = do - liftIO (getRcvFileDescrByFileId_ db fileId) >>= \case +getRcvFileDescrByRcvFileId :: DB.Connection -> FileTransferId -> ExceptT StoreError IO RcvFileDescr +getRcvFileDescrByRcvFileId db fileId = do + liftIO (getRcvFileDescrByRcvFileId_ db fileId) >>= \case Nothing -> throwError $ SERcvFileDescrNotFound fileId Just rfd -> pure rfd -getRcvFileDescrByFileId_ :: DB.Connection -> FileTransferId -> IO (Maybe RcvFileDescr) -getRcvFileDescrByFileId_ db fileId = +getRcvFileDescrByRcvFileId_ :: DB.Connection -> FileTransferId -> IO (Maybe RcvFileDescr) +getRcvFileDescrByRcvFileId_ db fileId = maybeFirstRow toRcvFileDescr $ DB.query db @@ -591,10 +592,30 @@ getRcvFileDescrByFileId_ db fileId = LIMIT 1 |] (Only fileId) - where - toRcvFileDescr :: (Int64, Text, Int, Bool) -> RcvFileDescr - toRcvFileDescr (fileDescrId, fileDescrText, fileDescrPartNo, fileDescrComplete) = - RcvFileDescr {fileDescrId, fileDescrText, fileDescrPartNo, fileDescrComplete} + +getRcvFileDescrBySndFileId :: DB.Connection -> FileTransferId -> ExceptT StoreError IO RcvFileDescr +getRcvFileDescrBySndFileId db fileId = do + liftIO (getRcvFileDescrBySndFileId_ db fileId) >>= \case + Nothing -> throwError $ SERcvFileDescrNotFound fileId + Just rfd -> pure rfd + +getRcvFileDescrBySndFileId_ :: DB.Connection -> FileTransferId -> IO (Maybe RcvFileDescr) +getRcvFileDescrBySndFileId_ db fileId = + maybeFirstRow toRcvFileDescr $ + DB.query + db + [sql| + SELECT d.file_descr_id, d.file_descr_text, d.file_descr_part_no, d.file_descr_complete + FROM xftp_file_descriptions d + JOIN snd_files f ON f.file_descr_id = d.file_descr_id + WHERE f.file_id = ? + LIMIT 1 + |] + (Only fileId) + +toRcvFileDescr :: (Int64, Text, Int, Bool) -> RcvFileDescr +toRcvFileDescr (fileDescrId, fileDescrText, fileDescrPartNo, fileDescrComplete) = + RcvFileDescr {fileDescrId, fileDescrText, fileDescrPartNo, fileDescrComplete} updateRcvFileAgentId :: DB.Connection -> FileTransferId -> Maybe AgentRcvFileId -> IO () updateRcvFileAgentId db fileId aFileId = do @@ -627,7 +648,7 @@ getRcvFileTransfer_ db userId fileId = do WHERE f.user_id = ? AND f.file_id = ? |] (userId, fileId) - rfd_ <- liftIO $ getRcvFileDescrByFileId_ db fileId + rfd_ <- liftIO $ getRcvFileDescrByRcvFileId_ db fileId rcvFileTransfer rfd_ rftRow where rcvFileTransfer :: diff --git a/src/Simplex/Chat/Store/Messages.hs b/src/Simplex/Chat/Store/Messages.hs index 955417522b..3429a24aaf 100644 --- a/src/Simplex/Chat/Store/Messages.hs +++ b/src/Simplex/Chat/Store/Messages.hs @@ -7,7 +7,6 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} @@ -100,7 +99,7 @@ module Simplex.Chat.Store.Messages updateGroupSndStatus, getGroupSndStatuses, getGroupSndStatusCounts, - getGroupMsgsHistory, + getGroupHistoryLastItems, ) where @@ -115,8 +114,6 @@ import Data.Int (Int64) import Data.List (sortBy) import Data.Maybe (fromMaybe, isJust, mapMaybe) import Data.Ord (Down (..), comparing) -import Data.Set (Set) -import qualified Data.Set as S import Data.Text (Text) import Data.Time (addUTCTime) import Data.Time.Clock (UTCTime (..), getCurrentTime) @@ -2081,87 +2078,22 @@ getGroupSndStatusCounts db itemId = |] (Only itemId) -data JsonMessageRecord = JsonMessageRecord - { messageId :: Int64, - msgSent :: Bool, - chatMsgEvent :: CMEventTag 'Json, - chatMsg :: ChatMessage 'Json, - createdAt :: UTCTime, - updatedAt :: UTCTime, - connectionId :: Maybe Int64, - groupId :: Maybe Int64, - sharedMsgId :: Maybe SharedMsgId, - sharedMsgIdUser :: Maybe Bool, - authorGroupMemberId :: Maybe GroupMemberId, - forwardedByGroupMemberId :: Maybe GroupMemberId - } - -type JsonMessageRow = (Int64, Bool, CMEventTag 'Json, ByteString, UTCTime, UTCTime, Maybe Int64, Maybe Int64, Maybe SharedMsgId, Maybe Bool, Maybe GroupMemberId, Maybe GroupMemberId) - -toJsonMessageRecord :: JsonMessageRow -> Either StoreError JsonMessageRecord -toJsonMessageRecord (messageId, msgSent, chatMsgEvent, msgBody, createdAt, updatedAt, connectionId, groupId, sharedMsgId, sharedMsgIdUser, authorGroupMemberId, forwardedByGroupMemberId) = - case parseChatMessages msgBody of - [Right (ACMsg SJson chatMsg)] -> Right JsonMessageRecord {..} - _ -> Left $ SEParseJsonMessageError messageId - -getGroupMsgsHistory :: DB.Connection -> User -> GroupInfo -> Int64 -> IO ([StoreError], [ChatMsgEvent 'Json]) -getGroupMsgsHistory db user GroupInfo {groupId, membership} numMsgsToSearch = do - (errs, msgRecs) <- partitionEithers <$> retrieveMessages - (errs', evts) <- collectForwardEvents msgRecs S.empty errs [] - pure (errs <> errs', evts) +getGroupHistoryLastItems :: DB.Connection -> User -> GroupInfo -> Int -> IO ([StoreError], [CChatItem 'CTGroup]) +getGroupHistoryLastItems db user@User {userId} GroupInfo {groupId} count = do + chatItemIds <- getLastItemIds_ + -- use getGroupCIWithReactions to read reactions data + partitionEithers <$> mapM (runExceptT <$> getGroupChatItem db user groupId) chatItemIds where - retrieveMessages :: IO [Either StoreError JsonMessageRecord] - retrieveMessages = - map toJsonMessageRecord + getLastItemIds_ :: IO [ChatItemId] + getLastItemIds_ = + map fromOnly <$> DB.query db [sql| - SELECT - message_id, msg_sent, chat_msg_event, msg_body, created_at, updated_at, connection_id, group_id, - shared_msg_id, shared_msg_id_user, author_group_member_id, forwarded_by_group_member_id - FROM messages - WHERE group_id = ? - AND chat_msg_event IN (?,?,?,?,?,?) - ORDER BY created_at DESC + SELECT chat_item_id + FROM chat_items + WHERE user_id = ? AND group_id = ? AND item_content_tag IN (?,?) + ORDER BY item_ts DESC, chat_item_id DESC LIMIT ? |] - -- see msgIncludedInHistory in Protocol - (groupId, XMsgNew_, XMsgFileDescr_, XMsgUpdate_, XMsgDel_, XMsgReact_, XFileCancel_, numMsgsToSearch) - collectForwardEvents :: - [JsonMessageRecord] -> - Set SharedMsgId -> - [StoreError] -> - [ChatMsgEvent 'Json] -> - IO ([StoreError], [ChatMsgEvent 'Json]) - collectForwardEvents [] _ errs evts = pure (errs, evts) - collectForwardEvents (mrec : mrecs) msgIds errs evts = do - let JsonMessageRecord {messageId, msgSent, chatMsg, createdAt, sharedMsgId, authorGroupMemberId} = mrec - case msgIncludedInHistory chatMsg msgIds of - Nothing -> collectForwardEvents mrecs msgIds errs evts - Just chatMsg' - | msgSent -> do - let GroupMember {memberId} = membership - evt = XGrpMsgForward memberId chatMsg' createdAt -- TODO round to seconds - msgIds' = maybe msgIds (`S.insert` msgIds) sharedMsgId - collectForwardEvents mrecs msgIds' errs (evt : evts) - | otherwise -> - case authorGroupMemberId of - Just amId -> do - runExceptT (getGroupMember db user groupId amId) >>= \case - Right _author@GroupMember {memberId} -> do - brokerTs <- getDeliveryTs messageId - -- message received via forward wouldn't have delivery record to retrieve chat_ts from, - -- see comment in processForwardedMsg in Chat - let msgTs = fromMaybe createdAt brokerTs - evt = XGrpMsgForward memberId chatMsg' msgTs - msgIds' = maybe msgIds (`S.insert` msgIds) sharedMsgId - collectForwardEvents mrecs msgIds' errs (evt : evts) - Left err -> - collectForwardEvents mrecs msgIds (err : errs) evts - _ -> do - let err = SEInternalError $ "message " <> show messageId <> " has no author group member id (can be due to older app version)" - collectForwardEvents mrecs msgIds (err : errs) evts - getDeliveryTs :: Int64 -> IO (Maybe UTCTime) - getDeliveryTs messageId = - maybeFirstRow fromOnly $ - DB.query db "SELECT chat_ts FROM msg_deliveries WHERE message_id = ? LIMIT 1" (Only messageId) + (userId, groupId, rcvMsgContentTag, sndMsgContentTag, count) diff --git a/src/Simplex/Chat/Store/Shared.hs b/src/Simplex/Chat/Store/Shared.hs index 68152dc087..6fb77b5484 100644 --- a/src/Simplex/Chat/Store/Shared.hs +++ b/src/Simplex/Chat/Store/Shared.hs @@ -99,7 +99,6 @@ data StoreError | SEContactNotFoundByFileId {fileId :: FileTransferId} | SENoGroupSndStatus {itemId :: ChatItemId, groupMemberId :: GroupMemberId} | SEDuplicateGroupMessage {groupId :: Int64, sharedMsgId :: SharedMsgId, authorGroupMemberId :: Maybe GroupMemberId, forwardedByGroupMemberId :: Maybe GroupMemberId} - | SEParseJsonMessageError {messageId :: Int64} | SERemoteHostNotFound {remoteHostId :: RemoteHostId} | SERemoteHostUnknown -- attempting to store KnownHost without a known fingerprint | SERemoteHostDuplicateCA diff --git a/src/Simplex/Chat/Types.hs b/src/Simplex/Chat/Types.hs index d5a1300911..4157c85c34 100644 --- a/src/Simplex/Chat/Types.hs +++ b/src/Simplex/Chat/Types.hs @@ -1012,9 +1012,11 @@ data XFTPRcvFile = XFTPRcvFile } deriving (Eq, Show) +type RcvFileDescrText = Text + data RcvFileDescr = RcvFileDescr { fileDescrId :: Int64, - fileDescrText :: Text, + fileDescrText :: RcvFileDescrText, fileDescrPartNo :: Int, fileDescrComplete :: Bool } diff --git a/tests/ChatTests/Groups.hs b/tests/ChatTests/Groups.hs index a650b62aba..86298b7758 100644 --- a/tests/ChatTests/Groups.hs +++ b/tests/ChatTests/Groups.hs @@ -116,7 +116,7 @@ chatGroupTests = do it "forward role change (x.grp.mem.role)" testGroupMsgForwardChangeRole it "forward new member announcement (x.grp.mem.new)" testGroupMsgForwardNewMember describe "group history" $ do - it "send recent history to invitee - text messages" testGroupHistory + fit "send recent history to invitee - text messages" testGroupHistory where _0 = supportedChatVRange -- don't create direct connections _1 = groupCreateDirectVRange