dandri/simplex-chat
1
0
Fork 0
mirror of https://github.com/simplex-chat/simplex-chat.git synced 2026-07-18 11:47:05 +00:00
Code Issues Packages Projects Releases Wiki Activity

core: fix delivery batching (#7065)

Browse Source
This commit is contained in:
spaced4ndy
2026-06-09 16:58:17 +00:00
committed by GitHub
parent 931881c860
commit b9d1f0c0a3
3 changed files with 62 additions and 12 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Simplex/Chat/Library/Subscriber.hs
+3 -3
View File
@@ -3635,13 +3635,13 @@ runDeliveryTaskWorker a deliveryKey Worker {doWork} = do
withStore' $ \db -> setDeliveryTaskErrStatus db (deliveryTaskId task) "relay inactive"
| otherwise ->
withWorkItems a doWork (withStore' $ \db -> getNextDeliveryTasks db gInfo task) $ \nextTasks -> do
let (body, acceptedTasks, largeTasks) = batchDeliveryTasks1 (vr cxt) maxEncodedMsgLength nextTasks
let (body_, acceptedTasks, largeTasks) = batchDeliveryTasks1 (vr cxt) maxEncodedMsgLength nextTasks
senderGMIds = S.toList . S.fromList $ map (\MessageDeliveryTask {senderGMId} -> senderGMId) acceptedTasks
withStore' $ \db -> do
createMsgDeliveryJob db gInfo jobScope senderGMIds body
forM_ body_ $ \body -> createMsgDeliveryJob db gInfo jobScope senderGMIds body
forM_ acceptedTasks $ \t -> updateDeliveryTaskStatus db (deliveryTaskId t) DTSProcessed
forM_ largeTasks $ \t -> setDeliveryTaskErrStatus db (deliveryTaskId t) "large"
lift . void $ getDeliveryJobWorker True deliveryKey
when (isJust body_) . lift . void $ getDeliveryJobWorker True deliveryKey
-- DJRelayRemoved is allowed when RSInactive - it forwards XGrpMemDel about relay's own deletion
DJRelayRemoved
| workerScope /= DWSGroup ->
src/Simplex/Chat/Messages/Batch.hs
+7 -7
View File
@@ -24,7 +24,6 @@ import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as B
import Data.Char (ord)
import Data.Function (on)
import Data.Foldable (foldr')
import Data.List (foldl', sortBy)
import Data.List.NonEmpty (NonEmpty (..))
import qualified Data.List.NonEmpty as L
@@ -79,15 +78,15 @@ batchMessages mode maxLen = addBatch . foldr addToBatch ([], [], [], 0, 0)
let encoded = encodeBatch mode bodies
in Right (MsgBatch encoded msgs) : batches
-- | Batches delivery tasks into (batch, accepted, large).
-- | 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 -> (ByteString, [MessageDeliveryTask], [MessageDeliveryTask])
batchDeliveryTasks1 :: VersionRangeChat -> Int -> NonEmpty MessageDeliveryTask -> (Maybe ByteString, [MessageDeliveryTask], [MessageDeliveryTask])
batchDeliveryTasks1 _vr maxLen = toResult . foldl' 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
-- too large: skip, record in large
| msgLen > maxLen = (msgBodies, accepted, task : large, len, n)
-- element can't fit even a singleton batch (4-byte binary-batch framing)
| msgLen + 4 > maxLen = (msgBodies, accepted, task : large, len, n)
-- fits: include in batch
-- batch overhead: '=' + count (2) + 2-byte length prefix per element
| len' + (n + 1) * 2 + 2 <= maxLen = (msgBody : msgBodies, task : accepted, large, len', n + 1)
@@ -98,10 +97,11 @@ batchDeliveryTasks1 _vr maxLen = toResult . foldl' addToBatch ([], [], [], 0, 0)
msgBody = encodeFwdElement GrpMsgForward {fwdSender, fwdBrokerTs} verifiedMsg
msgLen = B.length msgBody
len' = len + msgLen
toResult :: ([ByteString], [MessageDeliveryTask], [MessageDeliveryTask], Int, Int) -> (ByteString, [MessageDeliveryTask], [MessageDeliveryTask])
toResult :: ([ByteString], [MessageDeliveryTask], [MessageDeliveryTask], Int, Int) -> (Maybe ByteString, [MessageDeliveryTask], [MessageDeliveryTask])
toResult (msgBodies, accepted, large, _, _) =
let encoded = encodeBinaryBatch (reverse msgBodies)
in (encoded, reverse accepted, reverse large)
body = if null accepted then Nothing else Just encoded
in (body, reverse accepted, reverse large)
-- | Encode a batch element for relay groups: ><GrpMsgForward>[/<sigs>]<body>.
encodeFwdElement :: GrpMsgForward -> VerifiedMsg 'Json -> ByteString