From b20da580e458759064c76fdcd26d5886a8fb3bde Mon Sep 17 00:00:00 2001 From: shum Date: Wed, 30 Sep 2026 11:00:30 +0000 Subject: [PATCH] core: size payloads by agent capacity --- docs/protocol/simplex-chat.md | 2 +- src/Simplex/Chat/Library/Commands.hs | 21 +- src/Simplex/Chat/Library/Internal.hs | 92 ++++++--- src/Simplex/Chat/Library/Subscriber.hs | 41 ++-- src/Simplex/Chat/Messages/Batch.hs | 8 +- src/Simplex/Chat/Protocol.hs | 21 -- tests/ChatTests/Direct.hs | 33 ++- tests/ChatTests/Profiles.hs | 268 ++++++++++++------------- tests/ChatTests/Utils.hs | 13 ++ tests/MessageBatching.hs | 135 ++++++------- tests/ProtocolTests.hs | 41 +++- 11 files changed, 373 insertions(+), 302 deletions(-) diff --git a/docs/protocol/simplex-chat.md b/docs/protocol/simplex-chat.md index 45344d49e0..d7b990ab64 100644 --- a/docs/protocol/simplex-chat.md +++ b/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). diff --git a/src/Simplex/Chat/Library/Commands.hs b/src/Simplex/Chat/Library/Commands.hs index 9e2168e985..580a1e28ff 100644 --- a/src/Simplex/Chat/Library/Commands.hs +++ b/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 diff --git a/src/Simplex/Chat/Library/Internal.hs b/src/Simplex/Chat/Library/Internal.hs index f4fc435689..1d6524139d 100644 --- a/src/Simplex/Chat/Library/Internal.hs +++ b/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 () diff --git a/src/Simplex/Chat/Library/Subscriber.hs b/src/Simplex/Chat/Library/Subscriber.hs index f956c292bc..ae6ed9a648 100644 --- a/src/Simplex/Chat/Library/Subscriber.hs +++ b/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). diff --git a/src/Simplex/Chat/Messages/Batch.hs b/src/Simplex/Chat/Messages/Batch.hs index 0aa177cf27..34f5cb6bf7 100644 --- a/src/Simplex/Chat/Messages/Batch.hs +++ b/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 =()* -- 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 diff --git a/src/Simplex/Chat/Protocol.hs b/src/Simplex/Chat/Protocol.hs index b36b173dcd..a1c16a0012 100644 --- a/src/Simplex/Chat/Protocol.hs +++ b/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 #-} diff --git a/tests/ChatTests/Direct.hs b/tests/ChatTests/Direct.hs index 6a85f6f463..ffe09592c2 100644 --- a/tests/ChatTests/Direct.hs +++ b/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 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 $ diff --git a/tests/ChatTests/Profiles.hs b/tests/ChatTests/Profiles.hs index 19df8bdb4f..aeb6bac469 100644 --- a/tests/ChatTests/Profiles.hs +++ b/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 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 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 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 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 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 $ diff --git a/tests/ChatTests/Utils.hs b/tests/ChatTests/Utils.hs index 9586957281..38ca4a2d1a 100644 --- a/tests/ChatTests/Utils.hs +++ b/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)] diff --git a/tests/MessageBatching.hs b/tests/MessageBatching.hs index 01515fb6a3..47dac4f255 100644 --- a/tests/MessageBatching.hs +++ b/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' ( )* -- 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) diff --git a/tests/ProtocolTests.hs b/tests/ProtocolTests.hs index 73570aa34b..c5c6ed4754 100644 --- a/tests/ProtocolTests.hs +++ b/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