From 76cc59eb7a2aa0ea426bed64edb66123d531f007 Mon Sep 17 00:00:00 2001
From: "Evgeny @ SimpleX Chat"
 <259188159+evgeny-simplex@users.noreply.github.com>
Date: Fri, 6 Nov 2026 22:10:35 +0000
Subject: [PATCH] core: keep forwarded messages in order when a batch is full
 (#8058)

* tests: order of forwarded messages when a batch is full

* core: keep forwarded messages in order when a batch is full
---
 src/Simplex/Chat/Messages/Batch.hs | 13 +++++++------
 tests/MessageBatching.hs           | 17 ++++++++++++++++-
 2 files changed, 23 insertions(+), 7 deletions(-)

diff --git a/src/Simplex/Chat/Messages/Batch.hs b/src/Simplex/Chat/Messages/Batch.hs
index 0aa177cf27..7750fea8d4 100644
--- a/src/Simplex/Chat/Messages/Batch.hs
+++ b/src/Simplex/Chat/Messages/Batch.hs
@@ -82,17 +82,18 @@ batchMessages mode maxLen = addBatch . foldr addToBatch ([], [], [], 0, 0)
 -- | Batches delivery tasks into (batch if any task was accepted, accepted, large).
 -- Always uses binary batch format for relay groups.
 batchDeliveryTasks1 :: VersionRangeChat -> Int -> NonEmpty MessageDeliveryTask -> (Maybe ByteString, [MessageDeliveryTask], [MessageDeliveryTask])
-batchDeliveryTasks1 _vr maxLen = toResult . foldl' addToBatch ([], [], [], 0, 0) . L.toList
+batchDeliveryTasks1 _vr maxLen = toResult . addToBatch ([], [], [], 0, 0) . L.toList
   where
-    addToBatch :: ([ByteString], [MessageDeliveryTask], [MessageDeliveryTask], Int, Int) -> MessageDeliveryTask -> ([ByteString], [MessageDeliveryTask], [MessageDeliveryTask], Int, Int)
-    addToBatch (msgBodies, accepted, large, len, n) task
+    addToBatch :: ([ByteString], [MessageDeliveryTask], [MessageDeliveryTask], Int, Int) -> [MessageDeliveryTask] -> ([ByteString], [MessageDeliveryTask], [MessageDeliveryTask], Int, Int)
+    addToBatch acc [] = acc
+    addToBatch acc@(msgBodies, accepted, large, len, n) (task : tasks)
       -- element can't fit even a singleton batch (4-byte binary-batch framing)
-      | msgLen + 4 > maxLen = (msgBodies, accepted, task : large, len, n)
+      | msgLen + 4 > maxLen = addToBatch (msgBodies, accepted, task : large, len, n) tasks
       -- fits: include in batch
       -- batch overhead: '=' + count (2) + 2-byte length prefix per element
-      | n + 1 <= maxBatchElementCount && len' + (n + 1) * 2 + 2 <= maxLen = (msgBody : msgBodies, task : accepted, large, len', n + 1)
+      | n + 1 <= maxBatchElementCount && len' + (n + 1) * 2 + 2 <= maxLen = addToBatch (msgBody : msgBodies, task : accepted, large, len', n + 1) tasks
       -- doesn't fit: stop adding further messages
-      | otherwise = (msgBodies, accepted, large, len, n)
+      | otherwise = acc
       where
         MessageDeliveryTask {fwdSender, brokerTs = fwdBrokerTs, verifiedMsg} = task
         msgBody = encodeFwdElement GrpMsgForward {fwdSender, fwdBrokerTs} verifiedMsg
diff --git a/tests/MessageBatching.hs b/tests/MessageBatching.hs
index 71cf2d5f49..96e78e3d8d 100644
--- a/tests/MessageBatching.hs
+++ b/tests/MessageBatching.hs
@@ -50,6 +50,7 @@ batchingTests = describe "message batching tests" $ do
   it "splits a batch that exceeds the element count limit" testBatchElementCountLimit
   it "does not create a relay delivery body when every task is oversized" testRelayBatchAllLarge
   it "classifies a task that fits raw but not as a framed singleton as large" testRelayBatchSingletonOverflow
+  it "stops a relay delivery batch at the first task that does not fit" testRelayBatchKeepsOrder
   it "shortens forwarded member names" testFwdMemberName
 
 instance IsString SndMessage where
@@ -186,12 +187,26 @@ deliveryTask taskId text =
 testRelayBatchSingletonOverflow :: IO ()
 testRelayBatchSingletonOverflow = do
   let task = deliveryTask 1 "overflow"
-      elemLen = B.length $ encodeFwdElement (GrpMsgForward (fwdSender task) (brokerTs task)) (verifiedMsg task)
+      elemLen = B.length $ fwdElement task
       (body_, accepted, large) = batchDeliveryTasks1 chatInitialVRange (elemLen + 2) (task :| [])
   body_ `shouldBe` Nothing
   map deliveryTaskId accepted `shouldBe` []
   map deliveryTaskId large `shouldBe` [1]
 
+testRelayBatchKeepsOrder :: IO ()
+testRelayBatchKeepsOrder = do
+  let task1 = deliveryTask 1 "one"
+      task2 = deliveryTask 2 "two is longer"
+      task3 = deliveryTask 3 "three"
+      maxLen = B.length $ encodeBinaryBatch [fwdElement task1, fwdElement task3]
+      (body_, accepted, large) = batchDeliveryTasks1 chatInitialVRange maxLen (task1 :| [task2, task3])
+  map deliveryTaskId accepted `shouldBe` [1]
+  map deliveryTaskId large `shouldBe` []
+  body_ `shouldBe` Just (encodeBinaryBatch [fwdElement task1])
+
+fwdElement :: MessageDeliveryTask -> ByteString
+fwdElement MessageDeliveryTask {fwdSender, brokerTs, verifiedMsg} = encodeFwdElement (GrpMsgForward fwdSender brokerTs) verifiedMsg
+
 testFwdMemberName :: IO ()
 testFwdMemberName = do
   fwdMemberName "sixteen_chars_ab" `shouldBe` "sixteen_chars_ab"