core: size payloads by agent capacity

docs/protocol/simplex-chat.md

@@ -90,7 +90,7 @@ The syntax of compressed message is defined by the following ABNF notation:
 compressedMessage = %s"X" 1*15780 OCTET; compressed message data
 ```
 
-Compressed message is required to fit into 13388 bytes, accounting for agent overhead (see Protocol's maxCompressedMsgLength).
+A message over the connection limit is compressed, and the compressed message is required to fit into it: 15795 bytes, or 13573 bytes when the connection supports post-quantum encryption (see maxPayloadLength).
 
 The actual JSON message is required to fit into 15610 bytes, accounting for group message forwarding (x.grp.msg.forward) overhead (see Protocol's maxEncodedMsgLength).
 

src/Simplex/Chat/Library/Commands.hs

@@ -35,7 +35,7 @@ import qualified Data.ByteString.Char8 as B
 import qualified Data.ByteString.Lazy.Char8 as LB
 import Data.Char
 import Data.Constraint (Dict (..))
-import Data.Either (fromRight, partitionEithers, rights)
+import Data.Either (fromRight, isRight, partitionEithers, rights)
 import Data.Foldable (foldr')
 import Data.Functor (($>))
 import Data.Functor.Identity (Identity (..), runIdentity)
@@ -172,6 +172,9 @@ maxProfileImageSize = 12500
 maxConnInfoOverhead :: Int
 maxConnInfoOverhead = 800
 
+maxProfileInfoLength :: PQSupport -> Int
+maxProfileInfoLength pqSup = maxPayloadLength APConnInfo pqSup - maxConnInfoOverhead
+
 checkProfileImageSize :: Maybe ImageData -> CM ()
 checkProfileImageSize = mapM_ $ \(ImageData t) ->
   let size = T.length t
@@ -180,6 +183,10 @@ checkProfileImageSize = mapM_ $ \(ImageData t) ->
 checkProfileSize :: Profile -> CM ()
 checkProfileSize p = checkInfoSize "Profile" (XInfo p Nothing)
 
+-- a profile saved under an earlier size limit can still be updated if it does not grow
+encodesLarger :: J.ToJSON a => a -> a -> Bool
+encodesLarger p p' = LB.length (J.encode p') > LB.length (J.encode p)
+
 checkGroupProfileSize :: GroupProfile -> CM ()
 checkGroupProfileSize p = checkInfoSize "Group profile" (XGrpInfo p)
 
@@ -188,9 +195,11 @@ checkInfoSize :: String -> ChatMsgEvent 'Json -> CM ()
 checkInfoSize what event = do
   vr <- chatVersionRange
   let info = ChatMessage {chatVRange = vr, msgId = Nothing, chatMsgEvent = event}
-  case encodeChatMessage (maxEncodedInfoLength - maxConnInfoOverhead) info of
-    ECMEncoded s | isJust $ compressToLimit (maxEncodedInfoLengthPQ - maxConnInfoOverhead) s -> pure ()
-    _ -> throwCmdError $ what <> " is too large"
+  case encodeChatMessage (maxProfileInfoLength PQSupportOff) info of
+    ECMEncoded s -> unless (isRight $ compressToLimit @(Either ChatError) (maxProfileInfoLength PQSupportOn) s) tooLarge
+    ECMLarge -> tooLarge
+  where
+    tooLarge = throwCmdError $ what <> " is too large"
 
 imageExtensions :: [String]
 imageExtensions = [".jpg", ".jpeg", ".png", ".gif"]
@@ -4014,7 +4023,7 @@ processChatCommand cxt nm = \case
       | otherwise = do
           when (n /= n') $ checkValidName n'
           checkProfileImageSize img'
-          checkProfileSize p'
+          when (encodesLarger (fromLocalProfile p) p') $ checkProfileSize p'
           -- read contacts before user update to correctly merge preferences
           contacts <- withFastStore' $ \db -> getUserContacts db cxt user
           user' <- updateUser
@@ -4107,7 +4116,7 @@ processChatCommand cxt nm = \case
       assertUserGroupRole gInfo GROwner
       when (n /= n') $ checkValidName n'
       checkProfileImageSize img'
-      checkGroupProfileSize p'
+      when (encodesLarger p p') $ checkGroupProfileSize p'
       when (useRelays' gInfo && isJust (ma' >>= review)) $ throwCmdError "Admission review is not supported in channels"
       -- updateGroupProfile clears domain verification; re-set it when the caller already re-resolved the name
       gInfo' <- withStore $ \db -> do

src/Simplex/Chat/Library/Internal.hs

@@ -34,7 +34,7 @@ import qualified Data.ByteString.Char8 as B
 import qualified Data.ByteString.Lazy.Char8 as LB
 import Data.Char (isDigit)
 import Data.Containers.ListUtils (nubOrd)
-import Data.Either (partitionEithers, rights)
+import Data.Either (isRight, partitionEithers, rights)
 import Data.Fixed (div')
 import Data.Foldable (foldr')
 import Data.Functor (($>))
@@ -1406,8 +1406,9 @@ sendHistory user gInfo@GroupInfo {membership} m@GroupMember {activeConn = Just c
   welcomeEl <- welcomeElement
   let (batches, dropped) = batchElements maxEncodedMsgLength (fwdEls <> maybe [] (: []) welcomeEl)
   when (dropped > 0) $ toView $ CEvtChatErrors [ChatError $ CEInternalError ("sendHistory: dropped " <> show dropped <> " oversized history messages")]
-  forM_ batches $ \body ->
-    void $ withAgent $ \a -> sendMessages a [(aConnId conn, PQEncOff, MsgFlags False, VRValue Nothing body)]
+  forM_ batches $ \body -> case compressPayload APMessage (connPQSupport conn) body of
+    Left e -> toView $ CEvtChatErrors [e]
+    Right body' -> void $ withAgent $ \a -> sendMessages a [(aConnId conn, PQEncOff, MsgFlags False, VRValue Nothing body')]
   where
     welcomeElement :: CM (Maybe ByteString)
     welcomeElement = case descrEvent_ of
@@ -2309,8 +2310,13 @@ createSndMessages idsEvents = do
     createMsg db g vr (connOrGroupId, msgSigning_, evnt) = runExceptT $ do
       withExceptT ChatErrorStore $ createNewSndMessage db g connOrGroupId evnt msgSigning_ encodeMessage
       where
-        encodeMessage sharedMsgId =
-          encodeChatMessage maxEncodedMsgLength ChatMessage {chatVRange = vr, msgId = Just sharedMsgId, chatMsgEvent = evnt}
+        encodeMessage sharedMsgId = case encodeChatMessage maxEncodedMsgLength ChatMessage {chatVRange = vr, msgId = Just sharedMsgId, chatMsgEvent = evnt} of
+          ECMEncoded body | SJson <- encoding @e, not (fitsPQ body) -> ECMLarge
+          r -> r
+        -- rejected before it is saved, as it could not be sent to connections with PQ support
+        fitsPQ body =
+          let element = encodeBatchElement ((`signChatMsgBody` body) <$> msgSigning_) body
+           in isRight $ compressPayload @(Either ChatError) APMessage PQSupportOn element
 
 groupMsgSigning :: Bool -> GroupInfoKeys -> ChatMsgEvent e -> Maybe MsgSigning
 groupMsgSigning sign (GIK gInfo@GroupInfo {membership = GroupMember {memberId}} gks) evt
@@ -2414,7 +2420,7 @@ batchSendConnMessages gInfo user conn msgFlags msgs =
 
 batchSendConnMessagesB :: BatchMode -> User -> Connection -> MsgFlags -> NonEmpty (Either ChatError SndMessage) -> CM ([Either ChatError SndMessage], Maybe PQEncryption)
 batchSendConnMessagesB mode _user conn msgFlags msgs_ = do
-  let batched_ = batchSndMessagesJSON mode msgs_
+  let batched_ = batchSndMessagesJSON mode (connPQSupport conn) msgs_
   case L.nonEmpty batched_ of
     Just batched' -> do
       let msgReqs = L.map (fmap msgBatchReq_) batched'
@@ -2435,8 +2441,8 @@ batchSendConnMessagesB mode _user conn msgFlags msgs_ = do
     findLastPQEnc :: NonEmpty (Either ChatError ([Int64], PQEncryption)) -> Maybe PQEncryption
     findLastPQEnc = foldr' (\x acc -> case x of Right (_, pqEnc) -> Just pqEnc; Left _ -> acc) Nothing
 
-batchSndMessagesJSON :: BatchMode -> NonEmpty (Either ChatError SndMessage) -> [Either ChatError MsgBatch]
-batchSndMessagesJSON mode = batchMessages mode maxEncodedMsgLength . L.toList
+batchSndMessagesJSON :: BatchMode -> PQSupport -> NonEmpty (Either ChatError SndMessage) -> [Either ChatError MsgBatch]
+batchSndMessagesJSON mode pqSup = batchMessages mode (maxPayloadLength APMessage pqSup) . L.toList
 
 encodeConnInfo :: MsgEncodingI e => ChatMsgEvent e -> CM ByteString
 encodeConnInfo = encodeConnInfoPQ PQSupportOff
@@ -2445,8 +2451,8 @@ encodeConnInfoPQ :: MsgEncodingI e => PQSupport -> ChatMsgEvent e -> CM ByteStri
 encodeConnInfoPQ pqSup chatMsgEvent = do
   cxt <- chatStoreCxt
   let info = ChatMessage {chatVRange = vr cxt, msgId = Nothing, chatMsgEvent}
-  case encodeChatMessage maxDecompressedMsgLength info of
-    ECMEncoded connInfo -> compressConnInfo pqSup connInfo
+  case encodeChatMessage maxEncodedMsgLength info of
+    ECMEncoded connInfo -> compressPayload APConnInfo pqSup connInfo
     ECMLarge -> throwChatError $ CEException "large info"
 
 -- conn-info wrapped as a signed element, so the receiver can verify the signature over the body
@@ -2454,18 +2460,44 @@ encodeSignedConnInfo :: MsgEncodingI e => PQSupport -> MsgSigning -> ChatMsgEven
 encodeSignedConnInfo pqSup signing chatMsgEvent = do
   vr <- chatVersionRange
   let info = ChatMessage {chatVRange = vr, msgId = Nothing, chatMsgEvent}
-  case encodeChatMessage maxDecompressedMsgLength info of
-    ECMEncoded body -> compressConnInfo pqSup $ encodeBatchElement (Just $ signChatMsgBody signing body) body
+  case encodeChatMessage maxEncodedMsgLength info of
+    ECMEncoded body -> compressPayload APConnInfo pqSup $ encodeBatchElement (Just $ signChatMsgBody signing body) body
     ECMLarge -> throwChatError $ CEException "large signed info"
 
-compressConnInfo :: PQSupport -> ByteString -> CM ByteString
-compressConnInfo pqSup connInfo =
-  maybe (throwChatError $ CEException "large compressed info") pure $ compressToLimit (maxConnInfoLength pqSup) connInfo
+-- the agent pads connection info and messages to fixed sizes, smaller when the connection supports PQ
+data AgentPayload = APConnInfo | APMessage
 
-maxConnInfoLength :: PQSupport -> Int
-maxConnInfoLength = \case
-  PQSupportOn -> maxEncodedInfoLengthPQ
-  PQSupportOff -> maxEncodedInfoLength
+maxPayloadLength :: AgentPayload -> PQSupport -> Int
+maxPayloadLength = \case
+  APConnInfo -> subtract connInfoEnvelopeLength . e2eEncConnInfoLength
+  APMessage -> subtract msgEnvelopeLength . e2eEncAgentMsgLength
+
+-- confirmation header with one reply queue (189 bytes for a preset server with an onion host) and padding length
+connInfoEnvelopeLength :: Int
+connInfoEnvelopeLength = 300
+
+-- message header (tag, message ID, previous message hash, tag) and padding length
+msgEnvelopeLength :: Int
+msgEnvelopeLength = 45
+
+compressPayload :: MonadError ChatError m => AgentPayload -> PQSupport -> MsgBody -> m MsgBody
+compressPayload payload = compressToLimit . maxPayloadLength payload
+
+-- compresses only a body over the limit
+compressToLimit :: MonadError ChatError m => Int -> MsgBody -> m MsgBody
+compressToLimit maxLen s
+  | B.length s <= maxLen = pure s
+  | B.length s' <= maxLen = pure s'
+  | otherwise = throwError $ ChatError $ CEException $ "large compressed payload: " <> show (B.length s') <> " > " <> show maxLen
+  where
+    s' = compressedBatchMsgBody_ s
+
+connPQSupport :: Connection -> PQSupport
+connPQSupport Connection {pqSupport} = pqSupport
+
+-- connections sharing message bodies via VRRef need the limit of any of them with PQ support
+connsPQSupport :: [Connection] -> PQSupport
+connsPQSupport = PQSupport . any (supportPQ . connPQSupport)
 
 -- signed XMember for a relay-group join: proves the joiner holds the member key it asserts, and carries
 -- viaRelay = the target relay's memberId inside the signed body so a sibling relay can't accept a replay
@@ -2499,19 +2531,16 @@ deliverMessages msgs = deliverMessagesB $ L.map Right msgs
 
 deliverMessagesB :: NonEmpty (Either ChatError ChatMsgReq) -> CM (NonEmpty (Either ChatError ([Int64], PQEncryption)))
 deliverMessagesB msgReqs = do
-  msgReqs' <- liftIO $ compressBodies $ if any connSupportsPQ msgReqs then maxEncodedMsgLengthPQ else maxEncodedMsgLength
+  msgReqs' <- liftIO compressBodies
   sent <- L.zipWith prepareBatch msgReqs' <$> withAgent (`sendMessagesB` snd (mapAccumL toAgent Nothing msgReqs'))
   lift . void $ withStoreBatch' $ \db -> map (updatePQSndEnabled db) (rights . L.toList $ sent)
   lift . withStoreBatch $ \db -> L.map (bindRight $ createDelivery db) sent
   where
-    connSupportsPQ = \case
-      Right (Connection {pqSupport = PQSupportOn}, _, _) -> True
-      _ -> False
-    -- one limit for the batch: connections share message bodies via VRRef
-    compressBodies maxLen =
+    pqSup = connsPQSupport [conn | Right (conn, _, _) <- L.toList msgReqs]
+    compressBodies =
       forME msgReqs $ \(conn, msgFlags, (mbr, msgIds)) -> runExceptT $ do
         mbr' <- case mbr of
-          VRValue i msgBody -> maybe (throwError $ ChatError $ CEException "large compressed message") (pure . VRValue i) $ compressToLimit maxLen msgBody
+          VRValue i msgBody -> VRValue i <$> compressPayload APMessage pqSup msgBody
           v -> pure v
         pure (conn, msgFlags, (mbr', msgIds))
     toAgent prev = \case
@@ -2720,8 +2749,10 @@ sendGroupSignedMessages_ gInfo@GroupInfo {groupId} recipientMembers signedEvents
     prepareMsgReqs msgFlags msgs (toSendBin, toSendJson) =
       batchReqs 1 BMBinary toSendBin <> batchReqs 2 BMJson toSendJson
       where
+        -- deliverMessagesB compresses the batches with the same limit
+        pqSup = connsPQSupport $ map snd $ toSendBin <> toSendJson
         batchReqs _ _ [] = ([], [])
-        batchReqs n mode toSend' = case L.nonEmpty (batchSndMessagesJSON mode msgs) of
+        batchReqs n mode toSend' = case L.nonEmpty (batchSndMessagesJSON mode pqSup msgs) of
           Just batched -> foldMembers (n * (length batched + length msgs)) msgBatchMBR batched toSend'
           Nothing -> ([], [])
         foldMembers :: forall a. Int -> (Maybe Int -> Int -> a -> (ValueOrRef MsgBody, [MessageId])) -> NonEmpty (Either ChatError a) -> [(GroupMember, Connection)] -> ([GroupMemberId], [Either ChatError ChatMsgReq])
@@ -2827,9 +2858,10 @@ sendGroupMemberMessage gInfo@GroupInfo {groupId} m@GroupMember {groupMemberId} c
 -- Send pre-encoded forwarded message preserving original signature
 sendFwdMemberMessage :: GroupMember -> GrpMsgForward -> VerifiedMsg 'Json -> CM ()
 sendFwdMemberMessage member fwd verifiedMsg =
-  forM_ (readyMemberConn member) $ \(_, conn) -> do
-    let body = encodeBinaryBatch [encodeFwdElement fwd verifiedMsg]
-    void $ withAgent $ \a -> sendMessages a [(aConnId conn, PQEncOff, MsgFlags False, VRValue Nothing body)]
+  forM_ (readyMemberConn member) $ \(_, conn) ->
+    case compressPayload APMessage (connPQSupport conn) $ encodeBinaryBatch [encodeFwdElement fwd verifiedMsg] of
+      Left e -> toView $ CEvtChatErrors [e]
+      Right body -> void $ withAgent $ \a -> sendMessages a [(aConnId conn, PQEncOff, MsgFlags False, VRValue Nothing body)]
 
 -- TODO ensure order - pending messages interleave with user input messages
 sendPendingGroupMessages :: User -> GroupInfo -> GroupMember -> Connection -> CM ()

src/Simplex/Chat/Library/Subscriber.hs

@@ -29,7 +29,7 @@ import Data.Either (lefts, partitionEithers, rights)
 import Data.Foldable (foldr', foldrM)
 import Data.Functor (($>))
 import Data.Int (Int64)
-import Data.List (find, foldl')
+import Data.List (find)
 import Data.List.NonEmpty (NonEmpty (..))
 import qualified Data.List.NonEmpty as L
 import qualified Data.IntSet as IS
@@ -4299,7 +4299,7 @@ runDeliveryJobWorker a deliveryKey Worker {doWork} = do
                       sendLoop bucketSize cursorGMId_ senderVec overflowWithIds inBodySenders extBody activeSenders = do
                         mems <- withStore' $ \db -> getGroupMembersByCursor db cxt user gInfo cursorGMId_ singleSenderGMId_ bucketSize
                         unless (null mems) $ do
-                          let msgReqs = buildMsgReqs mems
+                          msgReqs <- liftEither $ buildMsgReqs mems
                           unless (null msgReqs) $ void $ withAgent (`sendMessages` msgReqs)
                           -- Mark only (sender, recipient) pairs where the bit was MRNew —
                           -- skip recipients already MRIntroduced (steady-case savings).
@@ -4320,19 +4320,21 @@ runDeliveryJobWorker a deliveryKey Worker {doWork} = do
                         where
                           -- First recipient needing body i carries VRValue (Just i); rest use VRRef i.
                           -- First piece per connection: aConnId; rest: empty (agent convention).
-                          buildMsgReqs :: [GroupMember] -> [MsgReq]
-                          buildMsgReqs mems = reverse . snd $ foldl' addRecipient (IS.empty, []) mems
+                          buildMsgReqs :: [GroupMember] -> Either ChatError [MsgReq]
+                          buildMsgReqs mems = reverse . snd <$> foldM addRecipient (IS.empty, []) mems
                             where
+                              pqSup = connsPQSupport $ mapMaybe (fmap snd . readyMemberConn) mems
                               addRecipient acc r = case readyMemberConn r of
-                                Just (_, conn) -> snd $ foldl' (addPiece conn) (0 :: Int, acc) (recipientBodyPieces r)
-                                Nothing -> acc
-                              addPiece conn (k, (issued, reqs)) (bid, msgBody) =
-                                let vor
-                                      | IS.member bid issued = VRRef bid
-                                      | otherwise = VRValue (Just bid) msgBody
-                                    issued' = IS.insert bid issued
+                                Just (_, conn) -> snd <$> foldM (addPiece conn) (0 :: Int, acc) (recipientBodyPieces r)
+                                Nothing -> pure acc
+                              addPiece conn (k, (issued, reqs)) (bid, msgBody) = do
+                                vor <-
+                                  if IS.member bid issued
+                                    then pure $ VRRef bid
+                                    else VRValue (Just bid) <$> compressPayload APMessage pqSup msgBody
+                                let issued' = IS.insert bid issued
                                     connId = if k == 0 then aConnId conn else B.empty
-                                 in (k + 1, (issued', (connId, PQEncOff, MsgFlags False, vor) : reqs))
+                                pure (k + 1, (issued', (connId, PQEncOff, MsgFlags False, vor) : reqs))
                               recipientBodyPieces r =
                                 [(i, b) | (i, (b, ss)) <- overflowWithIds, any missing ss]
                                   <> [if any missing inBodySenders then (1, extBody) else (0, body)]
@@ -4386,13 +4388,14 @@ runDeliveryJobWorker a deliveryKey Worker {doWork} = do
                                   && maxVersion (memberChatVRange m) >= groupKnockingVersion
               where
                 deliver :: ByteString -> [GroupMember] -> CM ()
-                deliver msgBody mems =
+                deliver msgBody mems = do
                   let mConns = mapMaybe (fmap snd . readyMemberConn) mems
-                      msgReqs = foldMemConns mConns
-                   in void $ withAgent (`sendMessages` msgReqs)
+                  case compressPayload APMessage (connsPQSupport mConns) msgBody of
+                    Left e -> toView $ CEvtChatErrors [e]
+                    Right msgBody' -> void $ withAgent (`sendMessages` foldMemConns msgBody' mConns)
                   where
-                    foldMemConns :: [Connection] -> [MsgReq]
-                    foldMemConns mConns = snd $ foldr' addReq (lastMemIdx_, []) mConns
+                    foldMemConns :: ByteString -> [Connection] -> [MsgReq]
+                    foldMemConns sentBody mConns = snd $ foldr' addReq (lastMemIdx_, []) mConns
                       where
                         lastMemIdx_ = let len = length mConns in if len > 1 then Just len else Nothing
                         addReq :: Connection -> (Maybe Int, [MsgReq]) -> (Maybe Int, [MsgReq])
@@ -4401,8 +4404,8 @@ runDeliveryJobWorker a deliveryKey Worker {doWork} = do
                           where
                             req = (aConnId conn, PQEncOff, MsgFlags False, vrValue_)
                             vrValue_ = case memIdx_ of
-                              Nothing -> VRValue Nothing msgBody -- sending to one member, do not reference body
-                              Just 1 -> VRValue (Just 1) msgBody
+                              Nothing -> VRValue Nothing sentBody -- sending to one member, do not reference body
+                              Just 1 -> VRValue (Just 1) sentBody
                               Just _ -> VRRef 1
 
 -- Single worker processes all relay requests (XGrpRelayInv).

src/Simplex/Chat/Messages/Batch.hs

@@ -30,7 +30,7 @@ import Data.List.NonEmpty (NonEmpty (..))
 import qualified Data.List.NonEmpty as L
 import Data.Ord (Down (..))
 import Data.Word (Word8)
-import Simplex.Chat.Controller (ChatError (..), ChatErrorType (..))
+import Simplex.Chat.Controller (ChatError)
 import Simplex.Chat.Delivery
 import Simplex.Chat.Messages
 import Simplex.Chat.Protocol
@@ -55,7 +55,7 @@ data MsgBatch = MsgBatch ByteString [SndMessage]
 -- BMBinary mode: Binary format =<count>(<len:2><body>)*
 -- Preserves original errors in the list.
 -- If a single element is passed, it is returned as is.
--- If an element exceeds maxLen, it is returned as ChatError.
+-- An element over maxLen is sent alone, to be compressed or rejected by the sender.
 -- Elements are encoded with signature prefix via encodeBatchElement.
 batchMessages :: BatchMode -> Int -> [Either ChatError SndMessage] -> [Either ChatError MsgBatch]
 batchMessages mode maxLen = addBatch . foldr addToBatch ([], [], [], 0, 0)
@@ -64,14 +64,12 @@ batchMessages mode maxLen = addBatch . foldr addToBatch ([], [], [], 0, 0)
     addToBatch (Left err) acc = (Left err : addBatch acc, [], [], 0, 0) -- step over original error
     addToBatch (Right msg@SndMessage {msgBody, signedMsg_}) acc@(batches, bodies, msgs, len, n)
       | n' <= maxBatchElementCount && batchLen mode len' n' <= maxLen = (batches, body : bodies, msg : msgs, len', n')
-      | msgLen <= maxLen = (addBatch acc, [body], [msg], msgLen, 1)
-      | otherwise = (errLarge msg : addBatch acc, [], [], 0, 0)
+      | otherwise = (addBatch acc, [body], [msg], msgLen, 1)
       where
         body = encodeBatchElement (if mode == BMBinary then signedMsg_ else Nothing) msgBody
         msgLen = B.length body
         len' = len + msgLen
         n' = n + 1
-        errLarge SndMessage {msgId} = Left $ ChatError $ CEInternalError ("large message " <> show msgId)
     addBatch :: ([Either ChatError MsgBatch], [ByteString], [SndMessage], Int, Int) -> [Either ChatError MsgBatch]
     addBatch (batches, bodies, msgs, _, n)
       | n == 0 = batches

src/Simplex/Chat/Protocol.hs

@@ -924,10 +924,6 @@ $(JQ.deriveJSON defaultJSON ''MsgContainer)
 maxEncodedMsgLength :: Int
 maxEncodedMsgLength = 15602
 
--- maxEncodedMsgLength - 2222, see e2eEncUserMsgLength in agent
-maxEncodedMsgLengthPQ :: Int
-maxEncodedMsgLengthPQ = 13380
-
 maxDecompressedMsgLength :: Int
 maxDecompressedMsgLength = 65536
 
@@ -960,14 +956,6 @@ rosterBlobP = do
   when (n > maxGroupRosterSize) $ fail "roster: too many entries"
   A.count n smpP
 
--- maxEncodedMsgLength - delta between MSG and INFO + 100 (returned for forward overhead)
--- delta between MSG and INFO = e2eEncUserMsgLength (no PQ) - e2eEncConnInfoLength (no PQ) = 1008
-maxEncodedInfoLength :: Int
-maxEncodedInfoLength = 14694
-
-maxEncodedInfoLengthPQ :: Int
-maxEncodedInfoLengthPQ = 10968 -- maxEncodedInfoLength - 3726, see e2eEncConnInfoLength in agent
-
 data EncodedChatMessage = ECMEncoded ByteString | ECMLarge
 
 encodeChatMessage :: MsgEncodingI e => Int -> ChatMessage e -> EncodedChatMessage
@@ -1041,15 +1029,6 @@ parseChatMessages msg = checkBatchLimit $ case B.head msg of
 compressedBatchMsgBody_ :: MsgBody -> ByteString
 compressedBatchMsgBody_ = markCompressedBatch . smpEncode . (L.:| []) . compress1
 
--- Nothing when the body is over the limit even after compression
-compressToLimit :: Int -> MsgBody -> Maybe ByteString
-compressToLimit maxLen s
-  | B.length s <= maxLen = Just s
-  | B.length s' <= maxLen = Just s'
-  | otherwise = Nothing
-  where
-    s' = compressedBatchMsgBody_ s
-
 markCompressedBatch :: ByteString -> ByteString
 markCompressedBatch = B.cons 'X'
 {-# INLINE markCompressedBatch #-}

tests/ChatTests/Direct.hs

@@ -43,7 +43,7 @@ import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Encoding.String (strEncode)
 import Simplex.Messaging.Server.Env.STM hiding (subscriptions)
 import Simplex.Messaging.Transport
-import Simplex.Messaging.Util (safeDecodeUtf8)
+import Simplex.Messaging.Util (encodeJSON, safeDecodeUtf8)
 import Simplex.Messaging.Version
 import System.Directory (copyFile, doesDirectoryExist, doesFileExist)
 import System.Mem.Weak (deRefWeak)
@@ -78,6 +78,8 @@ chatDirectTests = do
     it "repeat AUTH errors disable contact" testRepeatAuthErrorsDisableContact
     it "should send multiline message" testMultilineMessage
     it "send large message" testLargeMessage
+    it "reject message that cannot be sent with PQ" testRejectIncompressibleMessage
+    it "send messages that cannot be batched with PQ" testIncompressibleMessagesBatch
     it "initial chat pagination" testChatPaginationInitial
   describe "batch send messages" $ do
     it "send multiple messages api" testSendMulti
@@ -1020,6 +1022,35 @@ testLargeMessage =
       bob <## "contact alice changed to alice2"
       bob <## "use @alice2 <message> to send messages"
 
+-- fits the message size limit, but not the PQ limit after compression
+testRejectIncompressibleMessage :: HasCallStack => TestParams -> IO ()
+testRejectIncompressibleMessage =
+  testChat2 aliceProfile bobProfile $
+    \alice bob -> do
+      connectUsers alice bob
+      text <- incompressibleText 15400
+      alice `send` ("@bob " <> T.unpack text)
+      _trimmedCmd <- getTermLine alice
+      alice <## "chat db error: SELargeMsg"
+      alice #> "@bob hi"
+      bob <# "alice> hi"
+
+-- in one batch the two messages would be over the PQ limit after compression
+testIncompressibleMessagesBatch :: HasCallStack => TestParams -> IO ()
+testIncompressibleMessagesBatch =
+  testChat2 aliceProfile bobProfile $
+    \alice bob -> do
+      connectUsers alice bob
+      text1 <- incompressibleText 7500
+      text2 <- incompressibleText 7500
+      let composed t = J.object ["msgContent" J..= J.object ["type" J..= ("text" :: T.Text), "text" J..= t]]
+      alice `send` ("/_send @2 json " <> T.unpack (encodeJSON [composed text1, composed text2]))
+      _trimmedCmd <- getTermLine alice
+      alice <# ("@bob " <> T.unpack text1)
+      alice <# ("@bob " <> T.unpack text2)
+      bob <# ("alice> " <> T.unpack text1)
+      bob <# ("alice> " <> T.unpack text2)
+
 testSendMulti :: HasCallStack => TestParams -> IO ()
 testSendMulti =
   testChat2 aliceProfile bobProfile $

tests/ChatTests/Profiles.hs

@@ -2,8 +2,8 @@
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE PostfixOperators #-}
 {-# LANGUAGE TypeApplications #-}
 {-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}
@@ -15,7 +15,6 @@ import ChatTests.DBUtils
 import ChatTests.Utils
 import Control.Concurrent (threadDelay)
 import Control.Concurrent.Async (concurrently_)
-import Control.Concurrent.STM (atomically)
 import Control.Monad
 import Control.Monad.Except
 import qualified Data.Attoparsec.ByteString.Char8 as A
@@ -28,18 +27,19 @@ import qualified Data.Map.Strict as M
 import Simplex.Chat.Badges (BadgeCredential, BadgeInfo (..), BadgePurchase (..), BadgeRequest (..), BadgeType (..), generateMasterKey, issueBadge, verifyPayment)
 import Simplex.Chat.Controller (ChatConfig (..), ChatHooks (..), defaultChatHooks, storeCxt)
 import Simplex.Chat.Options (ChatOpts (..), CoreChatOpts (..))
-import Simplex.Chat.Library.Commands (maxConnInfoOverhead)
-import Simplex.Chat.Protocol (ChatMessage (..), ChatMsgEvent (XGrpInfo, XInfo), EncodedChatMessage (..), LinkOwnerSig, MsgChatLink (..), MsgContent (..), MsgEncoding (..), encodeChatMessage, maxEncodedInfoLength)
+import Simplex.Chat.Library.Commands (maxProfileInfoLength)
+import Simplex.Chat.Protocol (ChatMessage (..), ChatMsgEvent (XGrpInfo, XInfo), LinkOwnerSig, MsgChatLink (..), MsgContent (..), MsgEncoding (..), chatMsgToBody)
 import Simplex.Chat.Store.Shared (createContact)
 import Simplex.Chat.Types (ConnStatus (..), GroupProfile, GroupRejectionReason (..), ImageData (..), Profile (..), profileFromName)
 import qualified Simplex.Chat.Types as Types
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Crypto.BBS (BBSPublicKey, BBSSecretKey, bbsKeyGen)
-import Simplex.Messaging.Crypto.Ratchet (pattern PQSupportOn)
+import Simplex.Messaging.Crypto.Ratchet (pattern PQSupportOff, pattern PQSupportOn)
 import Simplex.Chat.Types.Shared (GroupMemberRole (..))
 import Simplex.Chat.Types.UITheme
 import Simplex.Messaging.Agent.Env.SQLite
 import Simplex.Messaging.Agent.RetryInterval
+import qualified Simplex.Messaging.Agent.Store.DB as DB
 import Simplex.Messaging.Encoding.String (StrEncoding (..))
 import Simplex.Messaging.Server.Env.STM hiding (subscriptions)
 import Simplex.Messaging.Transport
@@ -55,6 +55,10 @@ chatProfileTests = do
     it "member profile description is redacted for members without a direct contact" testMemberDescriptionRedacted
     it "update user profile with image" testUpdateProfileImage
     it "reject profile image that is too large" testSetProfileImageTooLarge
+    it "reject profiles over connection info size limit" testConnInfoSizeChecks
+    it "update profile saved under a larger size limit" testProfileSavedUnderLargerLimit
+    it "send profile update at size limit to PQ contact" testProfileUpdateSizeLimit
+    it "join group via link with group profile at size limit" testGroupLinkProfileSizeLimit
     it "set profile image from file" testSetProfileImageFromFile
     it "use multiword profile names" testMultiWordProfileNames
     it "auto-accept group invitations" testAutoAcceptGroupInvitations
@@ -85,9 +89,6 @@ chatProfileTests = do
       it "create and connect via business address" testBusinessAddress
       it "update profiles with business address" testBusinessUpdateProfiles
       it "connect via business address with profiles at size limit" testBusinessAddressProfileSizeLimit
-      it "reject profiles over connection info size limit" testConnInfoSizeChecks
-      it "join group via link with group profile at size limit" testGroupLinkProfileSizeLimit
-      it "send profile update at size limit to PQ contact" testProfileUpdateSizeLimit
   describe "contact address connection plan" $ do
     it "contact address ok to connect; known contact" testPlanAddressOkKnown
     it "own contact address" testPlanAddressOwn
@@ -532,6 +533,127 @@ testSetProfileImageTooLarge =
       expectError
       (bob </)
 
+testConnInfoSizeChecks :: HasCallStack => TestParams -> IO ()
+testConnInfoSizeChecks =
+  testChat aliceProfile $ \alice -> do
+    rejected alice "Profile" . ("/_profile 1 " <>) . encodeJSON =<< profileOfSize compressibleText (maxProfileSize + 1) aliceProfile
+    rejected alice "Profile" . ("/_profile 1 " <>) . encodeJSON =<< profileOfSize incompressibleText belowMaxProfileSize aliceProfile
+    alice ##> "/g team"
+    alice <## "group #team is created"
+    alice <## "to add members use /a team <name> or /create link #team"
+    rejected alice "Group profile" . ("/_group_profile #1 " <>) . encodeJSON =<< teamProfileOfSize compressibleText (maxProfileSize + 1)
+    rejected alice "Group profile" . ("/_group_profile #1 " <>) . encodeJSON =<< teamProfileOfSize incompressibleText belowMaxProfileSize
+  where
+    -- fits the size limit without compression, but not the PQ limit after compression
+    belowMaxProfileSize = maxProfileSize - 100
+    rejected cc what cmd = do
+      sendLong cc $ T.unpack cmd
+      cc <## ("bad chat command: " <> what <> " is too large")
+
+testProfileSavedUnderLargerLimit :: HasCallStack => TestParams -> IO ()
+testProfileSavedUnderLargerLimit ps = do
+  withNewTestChat ps "alice" aliceProfile $ \alice -> do
+    alice ##> "/ad"
+    _ <- getContactLink alice True
+    descr <- compressibleText maxProfileSize
+    withCCTransaction alice $ \db ->
+      DB.execute db "UPDATE contact_profiles SET description = ? WHERE display_name = ?" (descr, "alice" :: T.Text)
+  withTestChat ps "alice" $ \alice -> do
+    alice <## "subscribed 1 connections on server localhost"
+    alice ##> "/da"
+    alice <## "Your chat address is deleted - accepted contacts will remain connected."
+    alice <## "To create a new chat address use /ad"
+    alice ##> "/p alice Alice Smith"
+    alice <## "bad chat command: Profile is too large"
+
+-- with the badge, the profile update is over the PQ message limit, so it has to be compressed
+testProfileUpdateSizeLimit :: HasCallStack => TestParams -> IO ()
+testProfileUpdateSizeLimit ps = do
+  Right (pk, sk) <- bbsKeyGen
+  testChatCfg2 (testCfg {badgePublicKeys = testBadgeKeys pk}) aliceProfile bobProfile (test sk) ps
+  where
+    test sk alice bob = do
+      connectUsers alice bob
+      alice `pqSupportForCt` 2 `shouldReturn` PQSupportOn
+      addTestBadge alice =<< issueTestBadge sk futureDate
+      p@Profile {description = Just descr} <- profileOfSize compressibleText maxProfileSize aliceProfile
+      sendLong alice $ "/_profile 1 " <> T.unpack (encodeJSON p)
+      alice <## ("user description changed to " <> T.unpack descr <> " (your 1 contacts are notified)")
+      bob <## ("contact alice updated description: " <> T.unpack descr)
+      -- the badge is kept, so the update carried the badge proof
+      alice #> "@bob hi"
+      bob <# "alice *> hi"
+
+testGroupLinkProfileSizeLimit :: HasCallStack => TestParams -> IO ()
+testGroupLinkProfileSizeLimit =
+  testChat2 aliceProfile {displayName = T.pack hostName} bobProfile $ \alice bob -> do
+    gp@Types.GroupProfile {Types.description = Just welcomeMsg} <- teamProfileOfSize compressibleText maxProfileSize
+    sendLong alice $ "/_group 1 " <> T.unpack (encodeJSON gp)
+    alice <## "group #team is created"
+    alice <## "to add members use /a team <name> or /create link #team"
+    alice ##> "/create link #team"
+    gLink <- getGroupLink alice "team" GRMember True
+    bob ##> ("/c " <> gLink)
+    bob <## "connection request sent!"
+    alice <## "bob (Bob): accepting request to join group #team..."
+    concurrentlyN_
+      [ alice <## "#team: bob joined the group",
+        do
+          bob <## "#team: joining the group..."
+          bob <## "#team: you joined the group"
+          bob <# ("#team " <> hostName <> "> " <> T.unpack welcomeMsg)
+      ]
+    alice #> "#team hello"
+    bob <# ("#team " <> hostName <> "> hello")
+  where
+    -- XGrpLinkInv adds the host name, taking it over the limit without PQ, so it has to be compressed
+    hostName = replicate 1000 'a'
+
+maxProfileSize :: Int
+maxProfileSize = maxProfileInfoLength PQSupportOff
+
+-- the virtual terminal echoes a long command as one wrapped line
+sendLong :: TestCC -> String -> IO ()
+sendLong cc cmd = do
+  cc `send` cmd
+  void $ getTermLine cc
+
+-- the description fills the profile with a large image, so that the encoded XInfo is exactly n bytes
+profileOfSize :: (Int -> IO T.Text) -> Int -> Profile -> IO Profile
+profileOfSize genText n p = do
+  img <- largeProfileImage
+  let p' = (p :: Profile) {image = Just img, description = Just ""}
+  text <- genText $ n - infoSize (XInfo p' Nothing)
+  pure (p' :: Profile) {description = Just text}
+
+teamProfileOfSize :: (Int -> IO T.Text) -> Int -> IO GroupProfile
+teamProfileOfSize genText n = do
+  img <- largeProfileImage
+  let withDescr descr =
+        Types.GroupProfile
+          { Types.displayName = "team",
+            Types.fullName = "",
+            Types.shortDescr = Nothing,
+            Types.description = Just descr,
+            Types.image = Just img,
+            Types.publicGroup = Nothing,
+            Types.groupPreferences = Nothing,
+            Types.memberAdmission = Nothing
+          }
+  withDescr <$> genText (n - infoSize (XGrpInfo $ withDescr ""))
+
+largeProfileImage :: IO ImageData
+largeProfileImage = ImageData . ("data:image/png;base64," <>) . safeDecodeUtf8 <$> genProfileImg
+
+infoSize :: ChatMsgEvent 'Json -> Int
+infoSize = B.length . chatMsgToBody . ChatMessage vr Nothing
+  where
+    ChatConfig {chatVRange = vr} = testCfg
+
+-- ends with "." as terminal output drops trailing spaces
+compressibleText :: Int -> IO T.Text
+compressibleText n = pure $ T.take (n - 1) (T.replicate n "calculator ") <> "."
+
 testSetProfileImageFromFile :: HasCallStack => TestParams -> IO ()
 testSetProfileImageFromFile ps = testChat aliceProfile test ps
   where
@@ -1334,9 +1456,8 @@ testBusinessAddress = testChat3 businessProfile aliceProfile {fullName = "Alice
 testBusinessAddressProfileSizeLimit :: HasCallStack => TestParams -> IO ()
 testBusinessAddressProfileSizeLimit ps = do
   Right (pk, sk) <- bbsKeyGen
-  img <- largeProfileImage
-  bizProfile <- profileOfSize textOfSize maxCheckedInfoSize (businessProfile :: Profile) {image = Just img}
-  bobProfile'@Profile {description = Just bobDescr} <- profileOfSize textOfSize maxCheckedInfoSize (bobProfile :: Profile) {image = Just img}
+  bizProfile <- profileOfSize compressibleText maxProfileSize businessProfile
+  bobProfile'@Profile {description = Just bobDescr} <- profileOfSize compressibleText maxProfileSize bobProfile
   testChatCfg2 (testCfg {badgePublicKeys = testBadgeKeys pk}) bizProfile bobProfile' (test sk bobDescr) ps
   where
     test sk bobDescr biz bob = do
@@ -1367,130 +1488,7 @@ testBusinessAddressProfileSizeLimit ps = do
       biz <## "receiving messages via: localhost"
       biz <## "sending messages via: localhost"
       biz <## "connection not verified, use /code command to see security code"
-      biz <##. "peer chat protocol version range: "
-
-testConnInfoSizeChecks :: HasCallStack => TestParams -> IO ()
-testConnInfoSizeChecks =
-  testChat aliceProfile $ \alice -> do
-    img <- largeProfileImage
-    p <- profileOfSize textOfSize (maxCheckedInfoSize + 1) (aliceProfile :: Profile) {image = Just img}
-    alice `send` ("/_profile 1 " <> T.unpack (encodeJSON p))
-    _trimmedCmd1 <- getTermLine alice
-    alice <## "bad chat command: Profile is too large"
-    -- within the raw limit, but over the PQ limit after compression
-    pRandom <- profileOfSize randomTextOfSize (maxCheckedInfoSize - 100) (aliceProfile :: Profile) {image = Just img}
-    alice `send` ("/_profile 1 " <> T.unpack (encodeJSON pRandom))
-    _trimmedCmd2 <- getTermLine alice
-    alice <## "bad chat command: Profile is too large"
-    alice ##> "/g team"
-    alice <## "group #team is created"
-    alice <## "to add members use /a team <name> or /create link #team"
-    gp <- groupProfileOfSize textOfSize (maxCheckedInfoSize + 1) (teamProfile img)
-    alice `send` ("/_group_profile #1 " <> T.unpack (encodeJSON gp))
-    _trimmedCmd3 <- getTermLine alice
-    alice <## "bad chat command: Group profile is too large"
-    gpRandom <- groupProfileOfSize randomTextOfSize (maxCheckedInfoSize - 100) (teamProfile img)
-    alice `send` ("/_group_profile #1 " <> T.unpack (encodeJSON gpRandom))
-    _trimmedCmd4 <- getTermLine alice
-    alice <## "bad chat command: Group profile is too large"
-
--- the host name is repeated in XGrpLinkInv, so it has to be compressed to fit without PQ
-testGroupLinkProfileSizeLimit :: HasCallStack => TestParams -> IO ()
-testGroupLinkProfileSizeLimit =
-  testChat2 (aliceProfile :: Profile) {displayName = T.pack hostName} bobProfile $ \alice bob -> do
-    img <- largeProfileImage
-    gp@Types.GroupProfile {Types.description = Just welcomeMsg} <- groupProfileOfSize textOfSize maxCheckedInfoSize (teamProfile img)
-    alice `send` ("/_group 1 " <> T.unpack (encodeJSON gp))
-    _trimmedCmd <- getTermLine alice
-    alice <## "group #team is created"
-    alice <## "to add members use /a team <name> or /create link #team"
-    alice ##> "/create link #team"
-    gLink <- getGroupLink alice "team" GRMember True
-    bob ##> ("/c " <> gLink)
-    bob <## "connection request sent!"
-    alice <## "bob (Bob): accepting request to join group #team..."
-    concurrentlyN_
-      [ alice <## "#team: bob joined the group",
-        do
-          bob <## "#team: joining the group..."
-          bob <## "#team: you joined the group"
-          bob <# ("#team " <> hostName <> "> " <> T.unpack welcomeMsg)
-      ]
-    alice #> "#team hello"
-    bob <# ("#team " <> hostName <> "> hello")
-  where
-    hostName = concat $ replicate 200 "alice"
-
--- with the badge, the profile update is over the PQ message limit, so it has to be compressed
-testProfileUpdateSizeLimit :: HasCallStack => TestParams -> IO ()
-testProfileUpdateSizeLimit ps = do
-  Right (pk, sk) <- bbsKeyGen
-  testChatCfg2 (testCfg {badgePublicKeys = testBadgeKeys pk}) aliceProfile bobProfile (test sk) ps
-  where
-    test sk alice bob = do
-      connectUsers alice bob
-      alice `pqSupportForCt` 2 `shouldReturn` PQSupportOn
-      addTestBadge alice =<< issueTestBadge sk futureDate
-      img <- largeProfileImage
-      p@Profile {description = Just descr} <- profileOfSize textOfSize maxCheckedInfoSize (aliceProfile :: Profile) {image = Just img}
-      alice `send` ("/_profile 1 " <> T.unpack (encodeJSON p))
-      _trimmedCmd <- getTermLine alice
-      alice <## ("user description changed to " <> T.unpack descr <> " (your 1 contacts are notified)")
-      bob <## ("contact alice updated description: " <> T.unpack descr)
-      -- the badge is kept, so the update carried the badge proof
-      alice #> "@bob hi"
-      bob <# "alice *> hi"
-
--- the largest profile and group profile XInfo and XGrpInfo that pass checkInfoSize
-maxCheckedInfoSize :: Int
-maxCheckedInfoSize = maxEncodedInfoLength - maxConnInfoOverhead
-
-largeProfileImage :: IO ImageData
-largeProfileImage = ImageData . ("data:image/png;base64," <>) . safeDecodeUtf8 <$> genProfileImg
-
-teamProfile :: ImageData -> T.Text -> GroupProfile
-teamProfile img descr =
-  Types.GroupProfile
-    { Types.displayName = "team",
-      Types.fullName = "",
-      Types.shortDescr = Nothing,
-      Types.description = Just descr,
-      Types.image = Just img,
-      Types.publicGroup = Nothing,
-      Types.groupPreferences = Nothing,
-      Types.memberAdmission = Nothing
-    }
-
--- description is filled with generated text, so that the encoded XInfo is exactly n bytes
-profileOfSize :: (Int -> IO T.Text) -> Int -> Profile -> IO Profile
-profileOfSize genText n p = do
-  let p' = (p :: Profile) {description = Just ""} :: Profile
-  text <- genText $ n - infoSize (XInfo p' Nothing)
-  pure (p' :: Profile) {description = Just text}
-
-groupProfileOfSize :: (Int -> IO T.Text) -> Int -> (T.Text -> GroupProfile) -> IO GroupProfile
-groupProfileOfSize genText n withDescr = withDescr <$> genText (n - infoSize (XGrpInfo $ withDescr ""))
-
-infoSize :: ChatMsgEvent 'Json -> Int
-infoSize event = case encodeChatMessage maxBound ChatMessage {chatVRange = vr, msgId = Nothing, chatMsgEvent = event} of
-  ECMEncoded s -> B.length s
-  ECMLarge -> error "infoSize: unexpected ECMLarge"
-  where
-    ChatConfig {chatVRange = vr} = testCfg
-
-textOfSize :: Int -> IO T.Text
-textOfSize n = do
-  g <- C.newRandom
-  wordIdxs <- atomically $ B.unpack <$> C.randomBytes n g
-  -- ends with "." as terminal output drops trailing spaces
-  pure $ (<> ".") $ T.take (n - 1) $ T.unwords $ map ((textWords !!) . (`mod` length textWords) . fromEnum) wordIdxs
-  where
-    textWords = ["the", "calculator", "bot", "replies", "with", "results", "of", "each", "operation", "and", "keeps", "history"]
-
-randomTextOfSize :: Int -> IO T.Text
-randomTextOfSize n = do
-  g <- C.newRandom
-  T.pack . take n . B.unpack . strEncode <$> atomically (C.randomBytes n g)
+      biz <## currentChatVRangeInfo
 
 testBusinessUpdateProfiles :: HasCallStack => TestParams -> IO ()
 testBusinessUpdateProfiles = testChat4 businessProfile aliceProfile bobProfile cathProfile $

tests/ChatTests/Utils.hs

@@ -246,6 +246,19 @@ genProfileImg = do
     lrgLen = (maxProfileImageSize - imagePrefixLen) * 3 `div` 4 - 1
     imagePrefixLen = 22
 
+-- the least compressible JSON text, n bytes in UTF-8: random ASCII without markdown and 2-byte characters in equal shares
+incompressibleText :: Int -> IO T.Text
+incompressibleText n = do
+  g <- C.newRandom
+  rnd <- atomically $ C.randomBytes (3 * n) g
+  pure $ T.pack $ chars n $ map fromEnum $ B.unpack rnd
+  where
+    chars k (r1 : r2 : r3 : rest)
+      | k >= 2 && even r1 = toEnum (0xA0 + (r2 * 256 + r3) `mod` 0x760) : chars (k - 2) rest
+      | k >= 1 = asciiChars !! (r2 `mod` length asciiChars) : chars (k - 1) rest
+    chars _ _ = []
+    asciiChars = ['0' .. '9'] <> ['A' .. 'Z'] <> ['a' .. 'z'] <> ",.;-+=%&()'?<>{}|"
+
 -- PQ combinators /
 
 chat :: String -> [(Int, String)]

tests/MessageBatching.hs

@@ -1,4 +1,3 @@
-{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE StandaloneDeriving #-}
@@ -24,7 +23,6 @@ import Simplex.Chat.Delivery
     deliveryTaskId,
   )
 import Simplex.Chat.Messages.Batch
-import Simplex.Chat.Controller (ChatError (..), ChatErrorType (..))
 import Simplex.Chat.Messages (SndMessage (..))
 import Simplex.Chat.Protocol
   ( ChatMessage (ChatMessage),
@@ -57,57 +55,51 @@ instance IsString SndMessage where
       msgId = fromInteger $ os2ip s'
 
 
-instance IsString ChatError where
-  fromString s = ChatError $ CEInternalError ("large message " <> show msgId)
-    where
-      s' = encodeUtf8 $ T.pack s
-      msgId = fromInteger (os2ip s') :: Int64
-
 testBatchingCorrectness :: Spec
 testBatchingCorrectness = describe "JSON batching correctness tests" $ do
-  runBatcherTest BMJson 8 ["a"] [] ["a"]
-  runBatcherTest BMJson 8 ["a", "b"] [] ["[a,b]"]
-  runBatcherTest BMJson 8 ["a", "b", "c"] [] ["[a,b,c]"]
-  runBatcherTest BMJson 8 ["a", "bb", "c"] [] ["[a,bb,c]"]
-  runBatcherTest BMJson 8 ["a", "b", "c", "d"] [] ["a", "[b,c,d]"]
-  runBatcherTest BMJson 8 ["a", "bb", "c", "d"] [] ["a", "[bb,c,d]"]
-  runBatcherTest BMJson 8 ["a", "bb", "c", "de"] [] ["[a,bb]", "[c,de]"]
-  runBatcherTest BMJson 8 ["a", "b", "c", "d", "e"] [] ["[a,b]", "[c,d,e]"]
-  runBatcherTest BMJson 8 ["a", "b", "c", "d", "e", "f", "g", "h", "i", "j"] [] ["a", "[b,c,d]", "[e,f,g]", "[h,i,j]"]
-  runBatcherTest BMJson 8 ["aaaaa"] [] ["aaaaa"]
-  runBatcherTest BMJson 8 ["8aaaaaaa"] [] ["8aaaaaaa"]
-  runBatcherTest BMJson 8 ["aaaa", "bbbb"] [] ["aaaa", "bbbb"]
-  runBatcherTest BMJson 8 ["aa", "bbb", "cc", "dd"] [] ["[aa,bbb]", "[cc,dd]"]
-  runBatcherTest BMJson 8 ["aa", "bbb", "cc", "dd", "eee", "fff", "gg", "hh"] [] ["aa", "[bbb,cc]", "[dd,eee]", "fff", "[gg,hh]"]
-  runBatcherTest BMJson 8 ["9aaaaaaaa"] ["9aaaaaaaa"] []
-  runBatcherTest BMJson 8 ["aaaaa", "bbb", "cc"] [] ["aaaaa", "[bbb,cc]"]
-  runBatcherTest BMJson 8 ["8aaaaaaa", "bbb", "cc"] [] ["8aaaaaaa", "[bbb,cc]"]
-  runBatcherTest BMJson 8 ["9aaaaaaaa", "bbb", "cc"] ["9aaaaaaaa"] ["[bbb,cc]"]
-  runBatcherTest BMJson 8 ["9aaaaaaaa", "bbb", "cc", "dd"] ["9aaaaaaaa"] ["bbb", "[cc,dd]"]
-  runBatcherTest BMJson 8 ["9aaaaaaaa", "bbb", "cc", "dd", "e"] ["9aaaaaaaa"] ["[bbb,cc]", "[dd,e]"]
-  runBatcherTest BMJson 8 ["bbb", "cc", "aaaaa"] [] ["[bbb,cc]", "aaaaa"]
-  runBatcherTest BMJson 8 ["bbb", "cc", "8aaaaaaa"] [] ["[bbb,cc]", "8aaaaaaa"]
-  runBatcherTest BMJson 8 ["bbb", "cc", "9aaaaaaaa"] ["9aaaaaaaa"] ["[bbb,cc]"]
-  runBatcherTest BMJson 8 ["bbb", "cc", "dd", "9aaaaaaaa"] ["9aaaaaaaa"] ["bbb", "[cc,dd]"]
-  runBatcherTest BMJson 8 ["bbb", "cc", "dd", "e", "9aaaaaaaa"] ["9aaaaaaaa"] ["[bbb,cc]", "[dd,e]"]
-  runBatcherTest BMJson 8 ["bbb", "cc", "aaaaa", "dd"] [] ["[bbb,cc]", "aaaaa", "dd"]
-  runBatcherTest BMJson 8 ["bbb", "cc", "aaaaa", "dd", "e"] [] ["[bbb,cc]", "aaaaa", "[dd,e]"]
-  runBatcherTest BMJson 8 ["bbb", "cc", "8aaaaaaa", "dd"] [] ["[bbb,cc]", "8aaaaaaa", "dd"]
-  runBatcherTest BMJson 8 ["bbb", "cc", "8aaaaaaa", "dd", "e"] [] ["[bbb,cc]", "8aaaaaaa", "[dd,e]"]
-  runBatcherTest BMJson 8 ["bbb", "cc", "9aaaaaaaa"] ["9aaaaaaaa"] ["[bbb,cc]"]
-  runBatcherTest BMJson 8 ["bbb", "cc", "9aaaaaaaa", "dd"] ["9aaaaaaaa"] ["[bbb,cc]", "dd"]
-  runBatcherTest BMJson 8 ["bbb", "cc", "9aaaaaaaa", "dd", "e"] ["9aaaaaaaa"] ["[bbb,cc]", "[dd,e]"]
-  runBatcherTest BMJson 8 ["9aaaaaaaa", "10aaaaaaaa"] ["9aaaaaaaa", "10aaaaaaaa"] []
-  runBatcherTest BMJson 8 ["8aaaaaaa", "9aaaaaaaa", "10aaaaaaaa"] ["9aaaaaaaa", "10aaaaaaaa"] ["8aaaaaaa"]
-  runBatcherTest BMJson 8 ["9aaaaaaaa", "8aaaaaaa", "10aaaaaaaa"] ["9aaaaaaaa", "10aaaaaaaa"] ["8aaaaaaa"]
-  runBatcherTest BMJson 8 ["9aaaaaaaa", "10aaaaaaaa", "8aaaaaaa"] ["9aaaaaaaa", "10aaaaaaaa"] ["8aaaaaaa"]
-  runBatcherTest BMJson 8 ["bb", "cc", "dd", "9aaaaaaaa", "10aaaaaaaa"] ["9aaaaaaaa", "10aaaaaaaa"] ["bb", "[cc,dd]"]
-  runBatcherTest BMJson 8 ["bb", "cc", "9aaaaaaaa", "dd", "10aaaaaaaa"] ["9aaaaaaaa", "10aaaaaaaa"] ["[bb,cc]", "dd"]
-  runBatcherTest BMJson 8 ["bb", "9aaaaaaaa", "cc", "dd", "10aaaaaaaa"] ["9aaaaaaaa", "10aaaaaaaa"] ["bb", "[cc,dd]"]
-  runBatcherTest BMJson 8 ["bb", "9aaaaaaaa", "cc", "10aaaaaaaa", "dd"] ["9aaaaaaaa", "10aaaaaaaa"] ["bb", "cc", "dd"]
-  runBatcherTest BMJson 8 ["9aaaaaaaa", "bb", "cc", "dd", "10aaaaaaaa"] ["9aaaaaaaa", "10aaaaaaaa"] ["bb", "[cc,dd]"]
-  runBatcherTest BMJson 8 ["9aaaaaaaa", "bb", "10aaaaaaaa", "cc", "dd"] ["9aaaaaaaa", "10aaaaaaaa"] ["bb", "[cc,dd]"]
-  runBatcherTest BMJson 8 ["9aaaaaaaa", "10aaaaaaaa", "bb", "cc", "dd"] ["9aaaaaaaa", "10aaaaaaaa"] ["bb", "[cc,dd]"]
+  runBatcherTest BMJson 8 ["a"] ["a"]
+  runBatcherTest BMJson 8 ["a", "b"] ["[a,b]"]
+  runBatcherTest BMJson 8 ["a", "b", "c"] ["[a,b,c]"]
+  runBatcherTest BMJson 8 ["a", "bb", "c"] ["[a,bb,c]"]
+  runBatcherTest BMJson 8 ["a", "b", "c", "d"] ["a", "[b,c,d]"]
+  runBatcherTest BMJson 8 ["a", "bb", "c", "d"] ["a", "[bb,c,d]"]
+  runBatcherTest BMJson 8 ["a", "bb", "c", "de"] ["[a,bb]", "[c,de]"]
+  runBatcherTest BMJson 8 ["a", "b", "c", "d", "e"] ["[a,b]", "[c,d,e]"]
+  runBatcherTest BMJson 8 ["a", "b", "c", "d", "e", "f", "g", "h", "i", "j"] ["a", "[b,c,d]", "[e,f,g]", "[h,i,j]"]
+  runBatcherTest BMJson 8 ["aaaaa"] ["aaaaa"]
+  runBatcherTest BMJson 8 ["8aaaaaaa"] ["8aaaaaaa"]
+  runBatcherTest BMJson 8 ["aaaa", "bbbb"] ["aaaa", "bbbb"]
+  runBatcherTest BMJson 8 ["aa", "bbb", "cc", "dd"] ["[aa,bbb]", "[cc,dd]"]
+  runBatcherTest BMJson 8 ["aa", "bbb", "cc", "dd", "eee", "fff", "gg", "hh"] ["aa", "[bbb,cc]", "[dd,eee]", "fff", "[gg,hh]"]
+  runBatcherTest BMJson 8 ["9aaaaaaaa"] ["9aaaaaaaa"]
+  runBatcherTest BMJson 8 ["aaaaa", "bbb", "cc"] ["aaaaa", "[bbb,cc]"]
+  runBatcherTest BMJson 8 ["8aaaaaaa", "bbb", "cc"] ["8aaaaaaa", "[bbb,cc]"]
+  runBatcherTest BMJson 8 ["9aaaaaaaa", "bbb", "cc"] ["9aaaaaaaa", "[bbb,cc]"]
+  runBatcherTest BMJson 8 ["9aaaaaaaa", "bbb", "cc", "dd"] ["9aaaaaaaa", "bbb", "[cc,dd]"]
+  runBatcherTest BMJson 8 ["9aaaaaaaa", "bbb", "cc", "dd", "e"] ["9aaaaaaaa", "[bbb,cc]", "[dd,e]"]
+  runBatcherTest BMJson 8 ["bbb", "cc", "aaaaa"] ["[bbb,cc]", "aaaaa"]
+  runBatcherTest BMJson 8 ["bbb", "cc", "8aaaaaaa"] ["[bbb,cc]", "8aaaaaaa"]
+  runBatcherTest BMJson 8 ["bbb", "cc", "9aaaaaaaa"] ["[bbb,cc]", "9aaaaaaaa"]
+  runBatcherTest BMJson 8 ["bbb", "cc", "dd", "9aaaaaaaa"] ["bbb", "[cc,dd]", "9aaaaaaaa"]
+  runBatcherTest BMJson 8 ["bbb", "cc", "dd", "e", "9aaaaaaaa"] ["[bbb,cc]", "[dd,e]", "9aaaaaaaa"]
+  runBatcherTest BMJson 8 ["bbb", "cc", "aaaaa", "dd"] ["[bbb,cc]", "aaaaa", "dd"]
+  runBatcherTest BMJson 8 ["bbb", "cc", "aaaaa", "dd", "e"] ["[bbb,cc]", "aaaaa", "[dd,e]"]
+  runBatcherTest BMJson 8 ["bbb", "cc", "8aaaaaaa", "dd"] ["[bbb,cc]", "8aaaaaaa", "dd"]
+  runBatcherTest BMJson 8 ["bbb", "cc", "8aaaaaaa", "dd", "e"] ["[bbb,cc]", "8aaaaaaa", "[dd,e]"]
+  runBatcherTest BMJson 8 ["bbb", "cc", "9aaaaaaaa"] ["[bbb,cc]", "9aaaaaaaa"]
+  runBatcherTest BMJson 8 ["bbb", "cc", "9aaaaaaaa", "dd"] ["[bbb,cc]", "9aaaaaaaa", "dd"]
+  runBatcherTest BMJson 8 ["bbb", "cc", "9aaaaaaaa", "dd", "e"] ["[bbb,cc]", "9aaaaaaaa", "[dd,e]"]
+  runBatcherTest BMJson 8 ["9aaaaaaaa", "10aaaaaaaa"] ["9aaaaaaaa", "10aaaaaaaa"]
+  runBatcherTest BMJson 8 ["8aaaaaaa", "9aaaaaaaa", "10aaaaaaaa"] ["8aaaaaaa", "9aaaaaaaa", "10aaaaaaaa"]
+  runBatcherTest BMJson 8 ["9aaaaaaaa", "8aaaaaaa", "10aaaaaaaa"] ["9aaaaaaaa", "8aaaaaaa", "10aaaaaaaa"]
+  runBatcherTest BMJson 8 ["9aaaaaaaa", "10aaaaaaaa", "8aaaaaaa"] ["9aaaaaaaa", "10aaaaaaaa", "8aaaaaaa"]
+  runBatcherTest BMJson 8 ["bb", "cc", "dd", "9aaaaaaaa", "10aaaaaaaa"] ["bb", "[cc,dd]", "9aaaaaaaa", "10aaaaaaaa"]
+  runBatcherTest BMJson 8 ["bb", "cc", "9aaaaaaaa", "dd", "10aaaaaaaa"] ["[bb,cc]", "9aaaaaaaa", "dd", "10aaaaaaaa"]
+  runBatcherTest BMJson 8 ["bb", "9aaaaaaaa", "cc", "dd", "10aaaaaaaa"] ["bb", "9aaaaaaaa", "[cc,dd]", "10aaaaaaaa"]
+  runBatcherTest BMJson 8 ["bb", "9aaaaaaaa", "cc", "10aaaaaaaa", "dd"] ["bb", "9aaaaaaaa", "cc", "10aaaaaaaa", "dd"]
+  runBatcherTest BMJson 8 ["9aaaaaaaa", "bb", "cc", "dd", "10aaaaaaaa"] ["9aaaaaaaa", "bb", "[cc,dd]", "10aaaaaaaa"]
+  runBatcherTest BMJson 8 ["9aaaaaaaa", "bb", "10aaaaaaaa", "cc", "dd"] ["9aaaaaaaa", "bb", "10aaaaaaaa", "[cc,dd]"]
+  runBatcherTest BMJson 8 ["9aaaaaaaa", "10aaaaaaaa", "bb", "cc", "dd"] ["9aaaaaaaa", "10aaaaaaaa", "bb", "[cc,dd]"]
 
 -- Binary batch format: 'B' <count:1> (<len:2> <body>)*
 -- Single element returned as-is (no B prefix)
@@ -115,22 +107,22 @@ testBatchingCorrectness = describe "JSON batching correctness tests" $ do
 testBinaryBatchingCorrectness :: Spec
 testBinaryBatchingCorrectness = describe "Binary batching correctness tests" $ do
   -- Single element: returned as-is
-  runBatcherTest BMBinary 10 ["a"] [] ["a"]
-  runBatcherTest BMBinary 10 ["aaaa"] [] ["aaaa"]
+  runBatcherTest BMBinary 10 ["a"] ["a"]
+  runBatcherTest BMBinary 10 ["aaaa"] ["aaaa"]
   -- Two elements: binary batch format (2 + 2*2 + content = 6 + content)
-  runBatcherTest BMBinary 10 ["a", "b"] [] [binaryBatch ["a", "b"]]  -- 6 + 2 = 8
-  runBatcherTest BMBinary 12 ["aa", "bb"] [] [binaryBatch ["aa", "bb"]]  -- 6 + 4 = 10
+  runBatcherTest BMBinary 10 ["a", "b"] [binaryBatch ["a", "b"]]  -- 6 + 2 = 8
+  runBatcherTest BMBinary 12 ["aa", "bb"] [binaryBatch ["aa", "bb"]]  -- 6 + 4 = 10
   -- Three elements (2 + 3*2 + content = 8 + content)
-  runBatcherTest BMBinary 12 ["a", "b", "c"] [] [binaryBatch ["a", "b", "c"]]  -- 8 + 3 = 11
-  -- Large element: error (9 bytes > limit 8)
-  runBatcherTest BMBinary 8 ["9aaaaaaaa"] ["9aaaaaaaa"] []
+  runBatcherTest BMBinary 12 ["a", "b", "c"] [binaryBatch ["a", "b", "c"]]  -- 8 + 3 = 11
+  -- Large element: sent alone
+  runBatcherTest BMBinary 8 ["9aaaaaaaa"] ["9aaaaaaaa"]
   -- Mix of sizes: batch of 2 3-byte elements = 6 + 6 = 12
-  runBatcherTest BMBinary 12 ["aaa", "bbb", "ccc"] [] ["aaa", binaryBatch ["bbb", "ccc"]]
+  runBatcherTest BMBinary 12 ["aaa", "bbb", "ccc"] ["aaa", binaryBatch ["bbb", "ccc"]]
   -- 4 elements of 2 bytes: batch of 4 = 2 + 8 + 8 = 18, batch of 3 = 2 + 6 + 6 = 14
-  runBatcherTest BMBinary 16 ["aa", "bb", "cc", "dd"] [] ["aa", binaryBatch ["bb", "cc", "dd"]]
+  runBatcherTest BMBinary 16 ["aa", "bb", "cc", "dd"] ["aa", binaryBatch ["bb", "cc", "dd"]]
   -- Each element separate when can't batch due to size differences
-  runBatcherTest BMBinary 10 ["aa", "9aaaaaaaa", "bb"] [] ["aa", "9aaaaaaaa", "bb"]
-  runBatcherTest BMBinary 14 ["aa", "9aaaaaaaa", "bb", "cc"] [] ["aa", "9aaaaaaaa", binaryBatch ["bb", "cc"]]
+  runBatcherTest BMBinary 10 ["aa", "9aaaaaaaa", "bb"] ["aa", "9aaaaaaaa", "bb"]
+  runBatcherTest BMBinary 14 ["aa", "9aaaaaaaa", "bb", "cc"] ["aa", "9aaaaaaaa", binaryBatch ["bb", "cc"]]
 
 -- Helper to construct expected binary batch output
 binaryBatch :: [ByteString] -> ByteString
@@ -150,12 +142,12 @@ testImageFitsSingleBatch = do
       msg s = SndMessage {msgId = 0, sharedMsgId = SharedMsgId "", msgBody = s, signedMsg_ = Nothing}
       batched = "[" <> xMsgNewStr <> "," <> descrStr <> "]"
 
-  runBatcherTest' BMJson maxEncodedMsgLength [msg xMsgNewStr, msg descrStr] [] [batched]
+  runBatcherTest' BMJson maxEncodedMsgLength [msg xMsgNewStr, msg descrStr] [batched]
 
 -- elements are far below maxEncodedMsgLength, so only the element count guard can split this
 testBatchElementCountLimit :: IO ()
 testBatchElementCountLimit =
-  runBatcherTest' BMJson maxEncodedMsgLength (replicate (maxBatchElementCount + 1) "a") [] ["a", batched]
+  runBatcherTest' BMJson maxEncodedMsgLength (replicate (maxBatchElementCount + 1) "a") ["a", batched]
   where
     batched = "[" <> B.intercalate "," (replicate maxBatchElementCount "a") <> "]"
 
@@ -190,20 +182,17 @@ testRelayBatchSingletonOverflow = do
   map deliveryTaskId accepted `shouldBe` []
   map deliveryTaskId large `shouldBe` [1]
 
-runBatcherTest :: BatchMode -> Int -> [SndMessage] -> [ChatError] -> [ByteString] -> Spec
-runBatcherTest mode maxLen msgs expectedErrors expectedBatches =
+runBatcherTest :: BatchMode -> Int -> [SndMessage] -> [ByteString] -> Spec
+runBatcherTest mode maxLen msgs expectedBatches =
   it
     ( (show (map (\SndMessage {msgBody} -> msgBody) msgs) <> ", limit " <> show maxLen <> ": should return ")
-        <> (show (length expectedErrors) <> " large, ")
         <> (show (length expectedBatches) <> " batches")
     )
-    (runBatcherTest' mode maxLen msgs expectedErrors expectedBatches)
+    (runBatcherTest' mode maxLen msgs expectedBatches)
 
-runBatcherTest' :: BatchMode -> Int -> [SndMessage] -> [ChatError] -> [ByteString] -> IO ()
-runBatcherTest' mode maxLen msgs expectedErrors expectedBatches = do
+runBatcherTest' :: BatchMode -> Int -> [SndMessage] -> [ByteString] -> IO ()
+runBatcherTest' mode maxLen msgs expectedBatches = do
   let (errors, batches) = partitionEithers $ batchMessages mode maxLen (map Right msgs)
       batchedStrs = map (\(MsgBatch batchBody _) -> batchBody) batches
-  testErrors errors `shouldBe` testErrors expectedErrors
+  map show errors `shouldBe` []
   batchedStrs `shouldBe` expectedBatches
-  where
-    testErrors = map (\case ChatError (CEInternalError s) -> Just s; _ -> Nothing)

tests/ProtocolTests.hs

@@ -11,6 +11,7 @@
 module ProtocolTests where
 
 import Control.Concurrent.STM (atomically)
+import Control.Monad (forM_)
 import qualified Data.Aeson as J
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
@@ -19,7 +20,8 @@ import qualified Data.List.NonEmpty as L
 import Data.Maybe (fromMaybe)
 import qualified Data.Text as T
 import Data.Time.Clock.System (SystemTime (..), systemToUTCTime)
-import Simplex.Chat.Library.Internal (decodeLinkUserData, encodeShortLinkData)
+import Simplex.Chat.Controller (ChatError)
+import Simplex.Chat.Library.Internal (AgentPayload (..), compressToLimit, decodeLinkUserData, encodeShortLinkData, maxPayloadLength)
 import Simplex.Chat.Messages.Batch (encodeBatchElement)
 import Simplex.Chat.Protocol
 import Simplex.Chat.Types
@@ -30,6 +32,7 @@ import Simplex.Messaging.Compression (compress1)
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Crypto.Ratchet
 import Simplex.Messaging.Encoding (smpEncode)
+import Simplex.Messaging.Encoding.String (strDecode)
 import Simplex.Messaging.Protocol (EntityId (..), supportedSMPClientVRange)
 import Simplex.Messaging.ServiceScheme
 import Simplex.Messaging.Version
@@ -41,6 +44,7 @@ protocolTests = do
   shortLinkDataTests
   batchLimitTests
   compressToLimitTests
+  payloadLimitTests
   forwardDepthTests
   preferencesJSONTests
 
@@ -96,19 +100,19 @@ batchLimitTests = describe "Chat message batch limits" $ do
 compressToLimitTests :: Spec
 compressToLimitTests = describe "Compression to size limit" $ do
   it "keeps a body within the limit uncompressed" $
-    compressToLimit (B.length body) body `shouldBe` Just body
-  it "compresses a body over the limit to exactly the limit" $ do
-    compressToLimit compressedLen body `shouldBe` Just compressed
-    B.length compressed < B.length body `shouldBe` True
+    compressed_ (B.length body) body `shouldBe` Just body
+  it "compresses a body over the limit" $ do
+    compressed_ (B.length compressed) body `shouldBe` Just compressed
+    B.length compressed `shouldSatisfy` (< B.length body)
     compressed ==## msg
   it "fails when the compressed body is still over the limit" $
-    compressToLimit (compressedLen - 1) body `shouldBe` Nothing
+    compressed_ (B.length compressed - 1) body `shouldBe` Nothing
   it "keeps the signature of a compressed signed element" $ do
     g <- C.newRandom
     (pubKey, privKey) <- atomically $ C.generateKeyPair @'C.Ed25519 g
     let signing = MsgSigning {bindingTag = CBGroup, bindingData = "binding", keyRef = KRMember, privKey}
         element = encodeBatchElement (Just $ signChatMsgBody signing body) body
-    case parseChatMessages <$> compressToLimit (B.length element - 1) element of
+    case parseChatMessages <$> compressed_ (B.length element - 1) element of
       Just [Right (APMsg _ (ParsedMsg _ (Just SignedMsg {chatBinding, signatures, signedBody}) _))] -> do
         signedBody `shouldBe` body
         let verified (MsgSignature _ sig) = C.verify (C.APublicVerifyKey C.SEd25519 pubKey) sig (encodeChatBinding chatBinding "binding" <> signedBody)
@@ -116,11 +120,26 @@ compressToLimitTests = describe "Compression to size limit" $ do
       r -> expectationFailure $ "expected one compressed signed message, got " <> show (length <$> r)
   where
     msg = ChatMessage {chatVRange = supportedChatVRange, msgId = Nothing, chatMsgEvent = XMsgNew $ mcSimple (MCText $ T.replicate 2000 "calculator ")}
-    body = case encodeChatMessage maxDecompressedMsgLength msg of
-      ECMEncoded s -> s
-      ECMLarge -> error "compressToLimitTests: unexpected ECMLarge"
+    body = chatMsgToBody msg
     compressed = compressedBatchMsgBody_ body
-    compressedLen = B.length compressed
+    compressed_ maxLen = either (const Nothing) Just . compressToLimit @(Either ChatError) maxLen
+
+payloadLimitTests :: Spec
+payloadLimitTests = describe "Agent payload limits" $
+  forM_ ([("PQ", PQSupportOn), ("no PQ", PQSupportOff)] :: [(String, PQSupport)]) $ \(name, pqSup) -> do
+    it ("message limit is the agent message capacity, " <> name) $ do
+      let fits n = C.canPad (B.length $ smpEncode $ AgentMessage (APrivHeader 1 msgHash) (A_MSG $ B.replicate n 'a')) (e2eEncAgentMsgLength pqSup)
+          maxLen = maxPayloadLength APMessage pqSup
+      (fits maxLen, fits (maxLen + 1)) `shouldBe` (True, False)
+    it ("connection info limit fits the confirmation with a reply queue, " <> name) $ do
+      let reply = smpEncode $ AgentConnInfoReply (replyQueue L.:| []) (B.replicate (maxPayloadLength APConnInfo pqSup) 'a')
+      C.canPad (B.length reply) (e2eEncConnInfoLength pqSup) `shouldBe` True
+  where
+    msgHash = B.replicate 32 'h'
+    -- a preset server with an onion host
+    replyQueue = case strDecode "smp://SkIkI6EPd2D63F4xFKfHk7I1UGZVNn6k1QWZ5rcyr6w=@smp9.simplex.im,jssqzccmrcws6bhmn77vgmhfjmhwlyr3u7puw4erkyoosywgl67slqqd.onion/yKZevnQxYm6-D8UA4Qk7k-FZ_5z23Fhk#/?v=1-4&dh=MCowBQYDK2VuAyEAl4HKmQHRwoMlOkLEYSLSLE9_NB_XnTheQ4171WCx5DQ%3D&q=c" of
+      Right (SMPQueueUri vr addr) -> SMPQueueInfo (maxVersion vr) addr
+      Left e -> error e
 
 forwardDepthTests :: Spec
 forwardDepthTests = describe "Chat message forward depth limit" $ do