diff --git a/src/Simplex/Chat.hs b/src/Simplex/Chat.hs index 110b4a8bfb..b758b7901b 100644 --- a/src/Simplex/Chat.hs +++ b/src/Simplex/Chat.hs @@ -5659,7 +5659,7 @@ batchChatMessages = mkBatch [] let (batch, msgs_) = encodeBatch mempty 0 0 [] msgs batches' = batch : batches in maybe batches' (mkBatch batches') msgs_ - encodeBatch :: Builder.Builder -> Int -> Int -> [SndMessage] -> NonEmpty SndMessage -> (ChatMessageBatch, Maybe (NonEmpty SndMessage)) + encodeBatch :: Builder.Builder -> Int64 -> Int -> [SndMessage] -> NonEmpty SndMessage -> (ChatMessageBatch, Maybe (NonEmpty SndMessage)) encodeBatch builder len cnt batchedMsgs remainingMsgs@(msg :| msgs_) | len' <= maxSize' = case L.nonEmpty msgs_ of @@ -5671,13 +5671,13 @@ batchChatMessages = mkBatch [] SndMessage {msgBody} = msg cnt' = cnt + 1 len' - | cnt' == 1 = B.length msgBody -- initially len = 0 - | cnt' == 2 = len + B.length msgBody + 2 -- for opening bracket "[" and comma "," - | otherwise = len + B.length msgBody + 1 -- for comma "," + | cnt' == 1 = LB.length msgBody -- initially len = 0 + | cnt' == 2 = len + LB.length msgBody + 2 -- for opening bracket "[" and comma "," + | otherwise = len + LB.length msgBody + 1 -- for comma "," builder' - | cnt' == 1 = Builder.byteString msgBody - | cnt' == 2 = "[" <> builder <> "," <> Builder.byteString msgBody - | otherwise = builder <> "," <> Builder.byteString msgBody + | cnt' == 1 = Builder.lazyByteString msgBody + | cnt' == 2 = "[" <> builder <> "," <> Builder.lazyByteString msgBody + | otherwise = builder <> "," <> Builder.lazyByteString msgBody completeBuilder bldr | cnt' == 1 = bldr | otherwise = bldr <> "]" @@ -5692,27 +5692,27 @@ directMessage chatMsgEvent = do let r = encodeChatMessage ChatMessage {chatVRange, msgId = Nothing, chatMsgEvent} case r of Left e -> throwChatError $ CEException e - Right encodedBody -> pure encodedBody + Right encodedBody -> pure . LB.toStrict $ encodedBody -deliverMessage :: ChatMonad m => Connection -> CMEventTag e -> MsgBody -> MessageId -> m Int64 +deliverMessage :: ChatMonad m => Connection -> CMEventTag e -> LazyMsgBody -> MessageId -> m Int64 deliverMessage conn cmEventTag msgBody msgId = do let msgFlags = MsgFlags {notification = hasNotification cmEventTag} deliverMessage' conn msgFlags msgBody msgId -deliverMessage' :: ChatMonad m => Connection -> MsgFlags -> MsgBody -> MessageId -> m Int64 +deliverMessage' :: ChatMonad m => Connection -> MsgFlags -> LazyMsgBody -> MessageId -> m Int64 deliverMessage' conn msgFlags msgBody msgId = deliverMessages [(conn, msgFlags, msgBody, msgId)] >>= \case [r] -> liftEither r rs -> throwChatError $ CEInternalError $ "deliverMessage: expected 1 result, got " <> show (length rs) -deliverMessages :: ChatMonad' m => [(Connection, MsgFlags, MsgBody, MessageId)] -> m [Either ChatError Int64] +deliverMessages :: ChatMonad' m => [(Connection, MsgFlags, LazyMsgBody, MessageId)] -> m [Either ChatError Int64] deliverMessages msgReqs = do sent <- zipWith prepareBatch msgReqs <$> withAgent' (`sendMessages` aReqs) withStoreBatch $ \db -> map (bindRight $ createDelivery db) sent where - aReqs = map (\(conn, msgFlags, msgBody, _msgId) -> (aConnId conn, msgFlags, msgBody)) msgReqs + aReqs = map (\(conn, msgFlags, msgBody, _msgId) -> (aConnId conn, msgFlags, LB.toStrict msgBody)) msgReqs prepareBatch req = bimap (`ChatErrorAgent` Nothing) (req,) - createDelivery :: DB.Connection -> ((Connection, MsgFlags, MsgBody, MessageId), AgentMsgId) -> IO (Either ChatError Int64) + createDelivery :: DB.Connection -> ((Connection, MsgFlags, LazyMsgBody, MessageId), AgentMsgId) -> IO (Either ChatError Int64) createDelivery db ((Connection {connId}, _, _, msgId), agentMsgId) = Right <$> createSndMsgDelivery db (SndMsgDelivery {connId, agentMsgId}) msgId @@ -5807,7 +5807,7 @@ saveDirectRcvMSG conn@Connection {connId} agentMsgMeta agentAckCmdId msgBody = [Right (ACMsg _ ChatMessage {chatVRange, msgId = sharedMsgId_, chatMsgEvent})] -> do conn' <- updatePeerChatVRange conn chatVRange let agentMsgId = fst $ recipient agentMsgMeta - newMsg = NewMessage {chatMsgEvent, msgBody} + newMsg = NewRcvMessage {chatMsgEvent, msgBody} rcvMsgDelivery = RcvMsgDelivery {connId, agentMsgId, agentMsgMeta, agentAckCmdId} msg <- withStore $ \db -> createNewMessageAndRcvMsgDelivery db (ConnectionId connId) newMsg sharedMsgId_ rcvMsgDelivery Nothing pure (conn', msg) @@ -5818,7 +5818,7 @@ saveGroupRcvMsg :: (MsgEncodingI e, ChatMonad m) => User -> GroupId -> GroupMemb saveGroupRcvMsg user groupId authorMember conn@Connection {connId} agentMsgMeta agentAckCmdId msgBody ChatMessage {chatVRange, msgId = sharedMsgId_, chatMsgEvent} = do (am', conn') <- updateMemberChatVRange authorMember conn chatVRange let agentMsgId = fst $ recipient agentMsgMeta - newMsg = NewMessage {chatMsgEvent, msgBody} + newMsg = NewRcvMessage {chatMsgEvent, msgBody} rcvMsgDelivery = RcvMsgDelivery {connId, agentMsgId, agentMsgMeta, agentAckCmdId} amId = Just am'.groupMemberId msg <- @@ -5834,7 +5834,7 @@ saveGroupRcvMsg user groupId authorMember conn@Connection {connId} agentMsgMeta saveGroupFwdRcvMsg :: (MsgEncodingI e, ChatMonad m) => User -> GroupId -> GroupMember -> GroupMember -> MsgBody -> ChatMessage e -> m RcvMessage saveGroupFwdRcvMsg user groupId forwardingMember refAuthorMember msgBody ChatMessage {msgId = sharedMsgId_, chatMsgEvent} = do - let newMsg = NewMessage {chatMsgEvent, msgBody} + let newMsg = NewRcvMessage {chatMsgEvent, msgBody} fwdMemberId = Just $ groupMemberId' forwardingMember refAuthorId = Just $ groupMemberId' refAuthorMember withStore (\db -> createNewRcvMessage db (GroupId groupId) newMsg sharedMsgId_ refAuthorId fwdMemberId) diff --git a/src/Simplex/Chat/Messages.hs b/src/Simplex/Chat/Messages.hs index 08a7807dd1..cc269be2c9 100644 --- a/src/Simplex/Chat/Messages.hs +++ b/src/Simplex/Chat/Messages.hs @@ -22,6 +22,7 @@ import qualified Data.Aeson.Encoding as JE import qualified Data.Aeson.TH as JQ import qualified Data.Attoparsec.ByteString.Char8 as A import qualified Data.ByteString.Base64 as B64 +import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Lazy.Char8 as LB import Data.Char (isSpace) import Data.Int (Int64) @@ -763,17 +764,25 @@ checkChatType x = case testEquality (chatTypeI @c) (chatTypeI @c') of Just Refl -> Right x Nothing -> Left "bad chat type" -data NewMessage e = NewMessage +type LazyMsgBody = L.ByteString + +data NewSndMessage e = NewMessage { chatMsgEvent :: ChatMsgEvent e, - msgBody :: MsgBody + msgBody :: LazyMsgBody } deriving (Show) data SndMessage = SndMessage { msgId :: MessageId, sharedMsgId :: SharedMsgId, + msgBody :: LazyMsgBody + } + +data NewRcvMessage e = NewRcvMessage + { chatMsgEvent :: ChatMsgEvent e, msgBody :: MsgBody } + deriving (Show) data RcvMessage = RcvMessage { msgId :: MessageId, @@ -787,7 +796,7 @@ data RcvMessage = RcvMessage data PendingGroupMessage = PendingGroupMessage { msgId :: MessageId, cmEventTag :: ACMEventTag, - msgBody :: MsgBody, + msgBody :: LazyMsgBody, introId_ :: Maybe Int64 } diff --git a/src/Simplex/Chat/Protocol.hs b/src/Simplex/Chat/Protocol.hs index 863d45ce5a..c2dfd2e418 100644 --- a/src/Simplex/Chat/Protocol.hs +++ b/src/Simplex/Chat/Protocol.hs @@ -29,7 +29,9 @@ import qualified Data.Attoparsec.ByteString.Char8 as A import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B import Data.ByteString.Internal (c2w, w2c) +import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Lazy.Char8 as LB +import Data.Int (Int64) import Data.Maybe (fromMaybe) import Data.String import Data.Text (Text) @@ -485,18 +487,18 @@ $(JQ.deriveJSON defaultJSON ''QuotedMsg) -- this limit reserves space for metadata in forwarded messages -- 15780 (limit used for fileChunkSize) - 161 (x.grp.msg.forward overhead) = 15619, round to 15610 -maxChatMsgSize :: Int +maxChatMsgSize :: Int64 maxChatMsgSize = 15610 -encodeChatMessage :: MsgEncodingI e => ChatMessage e -> Either String ByteString +encodeChatMessage :: MsgEncodingI e => ChatMessage e -> Either String L.ByteString encodeChatMessage msg = do case chatToAppMessage msg of AMJson m -> do - let body = LB.toStrict $ J.encode m - if B.length body > maxChatMsgSize + let body = J.encode m + if LB.length body > maxChatMsgSize then Left "large message" else Right body - AMBinary m -> Right $ strEncode m + AMBinary m -> Right . LB.fromStrict $ strEncode m parseChatMessages :: ByteString -> [Either String AChatMessage] parseChatMessages "" = [Left "empty string"] diff --git a/src/Simplex/Chat/Store/Messages.hs b/src/Simplex/Chat/Store/Messages.hs index 2bae6cd28e..3e1159735e 100644 --- a/src/Simplex/Chat/Store/Messages.hs +++ b/src/Simplex/Chat/Store/Messages.hs @@ -160,7 +160,7 @@ deleteGroupCIs db User {userId} GroupInfo {groupId} = do DB.execute db "DELETE FROM chat_item_reactions WHERE group_id = ?" (Only groupId) DB.execute db "DELETE FROM chat_items WHERE user_id = ? AND group_id = ?" (userId, groupId) -createNewSndMessage :: MsgEncodingI e => DB.Connection -> TVar ChaChaDRG -> ConnOrGroupId -> (SharedMsgId -> Either String (NewMessage e)) -> ExceptT StoreError IO SndMessage +createNewSndMessage :: MsgEncodingI e => DB.Connection -> TVar ChaChaDRG -> ConnOrGroupId -> (SharedMsgId -> Either String (NewSndMessage e)) -> ExceptT StoreError IO SndMessage createNewSndMessage db gVar connOrGroupId mkMessage = createWithRandomId' gVar $ \sharedMsgId -> case mkMessage (SharedMsgId sharedMsgId) of @@ -196,7 +196,7 @@ createSndMsgDelivery db SndMsgDelivery {connId, agentMsgId} messageId = do (messageId, connId, agentMsgId, currentTs, currentTs, currentTs, MDSSndAgent) insertedRowId db -createNewMessageAndRcvMsgDelivery :: forall e. MsgEncodingI e => DB.Connection -> ConnOrGroupId -> NewMessage e -> Maybe SharedMsgId -> RcvMsgDelivery -> Maybe GroupMemberId -> ExceptT StoreError IO RcvMessage +createNewMessageAndRcvMsgDelivery :: forall e. MsgEncodingI e => DB.Connection -> ConnOrGroupId -> NewRcvMessage e -> Maybe SharedMsgId -> RcvMsgDelivery -> Maybe GroupMemberId -> ExceptT StoreError IO RcvMessage createNewMessageAndRcvMsgDelivery db connOrGroupId newMessage sharedMsgId_ RcvMsgDelivery {connId, agentMsgId, agentMsgMeta, agentAckCmdId} authorGroupMemberId_ = do msg@RcvMessage {msgId} <- createNewRcvMessage db connOrGroupId newMessage sharedMsgId_ authorGroupMemberId_ Nothing liftIO $ do @@ -211,8 +211,8 @@ createNewMessageAndRcvMsgDelivery db connOrGroupId newMessage sharedMsgId_ RcvMs (msgId, connId, agentMsgId, msgMetaJson agentMsgMeta, agentAckCmdId, snd $ broker agentMsgMeta, currentTs, currentTs, MDSRcvAgent) pure msg -createNewRcvMessage :: forall e. MsgEncodingI e => DB.Connection -> ConnOrGroupId -> NewMessage e -> Maybe SharedMsgId -> Maybe GroupMemberId -> Maybe GroupMemberId -> ExceptT StoreError IO RcvMessage -createNewRcvMessage db connOrGroupId NewMessage {chatMsgEvent, msgBody} sharedMsgId_ authorMember forwardedByMember = +createNewRcvMessage :: forall e. MsgEncodingI e => DB.Connection -> ConnOrGroupId -> NewRcvMessage e -> Maybe SharedMsgId -> Maybe GroupMemberId -> Maybe GroupMemberId -> ExceptT StoreError IO RcvMessage +createNewRcvMessage db connOrGroupId NewRcvMessage {chatMsgEvent, msgBody} sharedMsgId_ authorMember forwardedByMember = case connOrGroupId of ConnectionId connId -> liftIO $ insertRcvMsg (Just connId) Nothing GroupId groupId -> case sharedMsgId_ of diff --git a/tests/ProtocolTests.hs b/tests/ProtocolTests.hs index 5c6b51d3dc..925f5e6a7d 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 qualified Data.ByteString.Lazy.Char8 as LB import Data.Time.Clock.System (SystemTime (..), systemToUTCTime) import Simplex.Chat.Protocol import Simplex.Chat.Types @@ -74,7 +75,7 @@ s ##== msg = do case r of Left e -> expectationFailure $ "encode error: " <> show e Right encodedBody -> - J.eitherDecodeStrict' encodedBody + J.eitherDecodeStrict' (LB.toStrict encodedBody) `shouldBe` (J.eitherDecodeStrict' s :: Either String J.Value) (##==##) :: MsgEncodingI e => ByteString -> ChatMessage e -> Expectation