Merge branch 'stable'

src/Simplex/Chat.hs

@@ -28,7 +28,6 @@ import Data.Bifunctor (bimap, first, second)
 import Data.ByteArray (ScrubbedBytes)
 import qualified Data.ByteArray as BA
 import qualified Data.ByteString.Base64 as B64
-import Data.ByteString.Builder (toLazyByteString)
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
 import qualified Data.ByteString.Lazy.Char8 as LB
@@ -5791,8 +5790,7 @@ sendGroupMemberMessages user conn@Connection {connId} events groupId = do
       processBatch batch `catchChatError` (toView . CRChatError (Just user))
   where
     processBatch :: MsgBatch -> m ()
-    processBatch (MsgBatch builder sndMsgs) = do
-      let batchBody = LB.toStrict $ toLazyByteString builder
+    processBatch (MsgBatch batchBody sndMsgs) = do
       agentMsgId <- withAgent $ \a -> sendMessage a (aConnId conn) MsgFlags {notification = True} batchBody
       let sndMsgDelivery = SndMsgDelivery {connId, agentMsgId}
       void . withStoreBatch' $ \db -> map (\SndMessage {msgId} -> createSndMsgDelivery db sndMsgDelivery msgId) sndMsgs
@@ -5802,21 +5800,21 @@ directMessage chatMsgEvent = do
   chatVRange <- chatVersionRange
   let r = encodeChatMessage ChatMessage {chatVRange, msgId = Nothing, chatMsgEvent}
   case r of
-    ECMEncoded encodedBody -> pure . LB.toStrict $ encodedBody
+    ECMEncoded encodedBody -> pure encodedBody
     ECMLarge -> throwChatError $ CEException "large message"
 
-deliverMessage :: ChatMonad m => Connection -> CMEventTag e -> LazyMsgBody -> MessageId -> m Int64
+deliverMessage :: ChatMonad m => Connection -> CMEventTag e -> MsgBody -> 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 -> LazyMsgBody -> MessageId -> m Int64
+deliverMessage' :: ChatMonad m => Connection -> MsgFlags -> MsgBody -> 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)
 
-type MsgReq = (Connection, MsgFlags, LazyMsgBody, MessageId)
+type MsgReq = (Connection, MsgFlags, MsgBody, MessageId)
 
 deliverMessages :: ChatMonad' m => [MsgReq] -> m [Either ChatError Int64]
 deliverMessages = deliverMessagesB . map Right
@@ -5827,7 +5825,7 @@ deliverMessagesB msgReqs = do
   withStoreBatch $ \db -> map (bindRight $ createDelivery db) sent
   where
     toAgent = \case
-      Right (conn, msgFlags, msgBody, _msgId) -> Right (aConnId conn, msgFlags, LB.toStrict msgBody)
+      Right (conn, msgFlags, msgBody, _msgId) -> Right (aConnId conn, msgFlags, msgBody)
       Left _ce -> Left (AP.INTERNAL "ChatError, skip") -- as long as it is Left, the agent batchers should just step over it
     prepareBatch (Right req) (Right ar) = Right (req, ar)
     prepareBatch (Left ce) _ = Left ce -- restore original ChatError

src/Simplex/Chat/Messages.hs

@@ -25,7 +25,6 @@ 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)
@@ -812,12 +811,10 @@ checkChatType x = case testEquality (chatTypeI @c) (chatTypeI @c') of
   Just Refl -> Right x
   Nothing -> Left "bad chat type"
 
-type LazyMsgBody = L.ByteString
-
 data SndMessage = SndMessage
   { msgId :: MessageId,
     sharedMsgId :: SharedMsgId,
-    msgBody :: LazyMsgBody
+    msgBody :: MsgBody
   }
   deriving (Show)
 
@@ -839,7 +836,7 @@ data RcvMessage = RcvMessage
 data PendingGroupMessage = PendingGroupMessage
   { msgId :: MessageId,
     cmEventTag :: ACMEventTag,
-    msgBody :: LazyMsgBody,
+    msgBody :: MsgBody,
     introId_ :: Maybe Int64
   }
 

src/Simplex/Chat/Messages/Batch.hs

@@ -1,6 +1,7 @@
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 
 module Simplex.Chat.Messages.Batch
@@ -9,32 +10,28 @@ module Simplex.Chat.Messages.Batch
   )
 where
 
-import Data.ByteString.Builder (Builder, charUtf8, lazyByteString)
-import qualified Data.ByteString.Lazy as LB
-import Data.Int (Int64)
+import Data.ByteString.Char8 (ByteString)
+import qualified Data.ByteString.Char8 as B
 import Simplex.Chat.Controller (ChatError (..), ChatErrorType (..))
 import Simplex.Chat.Messages
 
-data MsgBatch = MsgBatch Builder [SndMessage]
+data MsgBatch = MsgBatch ByteString [SndMessage]
 
--- | Batches [SndMessage] into batches of ByteString builders in form of JSON arrays.
+-- | Batches [SndMessage] into batches of ByteStrings in form of JSON arrays.
 -- Does not check if the resulting batch is a valid JSON.
 -- If a single element is passed, it is returned as is (a JSON string).
 -- If an element exceeds maxLen, it is returned as ChatError.
-batchMessages :: Int64 -> [SndMessage] -> [Either ChatError MsgBatch]
-batchMessages maxLen msgs =
-  let (batches, batch, _, n) = foldr addToBatch ([], [], 0, 0) msgs
-   in if n == 0 then batches else msgBatch batch : batches
+batchMessages :: Int -> [SndMessage] -> [Either ChatError MsgBatch]
+batchMessages maxLen = addBatch . foldr addToBatch ([], [], 0, 0)
   where
     msgBatch batch = Right (MsgBatch (encodeMessages batch) batch)
-    addToBatch :: SndMessage -> ([Either ChatError MsgBatch], [SndMessage], Int64, Int) -> ([Either ChatError MsgBatch], [SndMessage], Int64, Int)
-    addToBatch msg@SndMessage {msgBody} (batches, batch, len, n)
+    addToBatch :: SndMessage -> ([Either ChatError MsgBatch], [SndMessage], Int, Int) -> ([Either ChatError MsgBatch], [SndMessage], Int, Int)
+    addToBatch msg@SndMessage {msgBody} acc@(batches, batch, len, n)
       | batchLen <= maxLen = (batches, msg : batch, len', n + 1)
-      | msgLen <= maxLen = (batches', [msg], msgLen, 1)
-      | otherwise = (errLarge msg : (if n == 0 then batches else batches'), [], 0, 0)
+      | msgLen <= maxLen = (addBatch acc, [msg], msgLen, 1)
+      | otherwise = (errLarge msg : addBatch acc, [], 0, 0)
       where
-        msgLen = LB.length msgBody
-        batches' = msgBatch batch : batches
+        msgLen = B.length msgBody
         len'
           | n == 0 = msgLen
           | otherwise = msgLen + len + 1 -- 1 accounts for comma
@@ -42,11 +39,11 @@ batchMessages maxLen msgs =
           | n == 0 = len'
           | otherwise = len' + 2 -- 2 accounts for opening and closing brackets
         errLarge SndMessage {msgId} = Left $ ChatError $ CEInternalError ("large message " <> show msgId)
-
-encodeMessages :: [SndMessage] -> Builder
-encodeMessages = \case
-  [] -> mempty
-  [msg] -> encodeMsg msg
-  (msg : msgs) -> charUtf8 '[' <> encodeMsg msg <> mconcat [charUtf8 ',' <> encodeMsg msg' | msg' <- msgs] <> charUtf8 ']'
-  where
-    encodeMsg SndMessage {msgBody} = lazyByteString msgBody
+    addBatch :: ([Either ChatError MsgBatch], [SndMessage], Int, Int) -> [Either ChatError MsgBatch]
+    addBatch (batches, batch, _, n) = if n == 0 then batches else msgBatch batch : batches
+    encodeMessages :: [SndMessage] -> ByteString
+    encodeMessages = \case
+      [] -> mempty
+      [msg] -> body msg
+      msgs -> B.concat ["[", B.intercalate "," (map body msgs), "]"]
+    body SndMessage {msgBody} = msgBody

src/Simplex/Chat/Protocol.hs

@@ -29,9 +29,7 @@ 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)
@@ -495,20 +493,20 @@ $(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 :: Int64
+maxChatMsgSize :: Int
 maxChatMsgSize = 15610
 
-data EncodedChatMessage = ECMEncoded L.ByteString | ECMLarge
+data EncodedChatMessage = ECMEncoded ByteString | ECMLarge
 
 encodeChatMessage :: MsgEncodingI e => ChatMessage e -> EncodedChatMessage
 encodeChatMessage msg = do
   case chatToAppMessage msg of
     AMJson m -> do
-      let body = J.encode m
-      if LB.length body > maxChatMsgSize
+      let body = LB.toStrict $ J.encode m
+      if B.length body > maxChatMsgSize
         then ECMLarge
         else ECMEncoded body
-    AMBinary m -> ECMEncoded . LB.fromStrict $ strEncode m
+    AMBinary m -> ECMEncoded $ strEncode m
 
 parseChatMessages :: ByteString -> [Either String AChatMessage]
 parseChatMessages "" = [Left "empty string"]