From 7c0cd58ad07f0754bf4c9b3789a75e1cd72c71e2 Mon Sep 17 00:00:00 2001 From: shum Date: Tue, 29 Sep 2026 16:22:05 +0000 Subject: [PATCH] core: compress over limit, error if still over --- src/Simplex/Chat/Library/Commands.hs | 4 +- src/Simplex/Chat/Library/Internal.hs | 33 ++++++----- src/Simplex/Chat/Protocol.hs | 17 ++++-- tests/ChatTests/Profiles.hs | 85 ++++++++++++++++++++++------ tests/ProtocolTests.hs | 35 ++++++++++++ 5 files changed, 134 insertions(+), 40 deletions(-) diff --git a/src/Simplex/Chat/Library/Commands.hs b/src/Simplex/Chat/Library/Commands.hs index 03cc9e9acb..9e2168e985 100644 --- a/src/Simplex/Chat/Library/Commands.hs +++ b/src/Simplex/Chat/Library/Commands.hs @@ -189,8 +189,8 @@ checkInfoSize what event = do vr <- chatVersionRange let info = ChatMessage {chatVRange = vr, msgId = Nothing, chatMsgEvent = event} case encodeChatMessage (maxEncodedInfoLength - maxConnInfoOverhead) info of - ECMEncoded _ -> pure () - ECMLarge -> throwCmdError $ what <> " is too large" + ECMEncoded s | isJust $ compressToLimit (maxEncodedInfoLengthPQ - maxConnInfoOverhead) s -> pure () + _ -> throwCmdError $ what <> " is too large" imageExtensions :: [String] imageExtensions = [".jpg", ".jpeg", ".png", ".gif"] diff --git a/src/Simplex/Chat/Library/Internal.hs b/src/Simplex/Chat/Library/Internal.hs index 0d048a937b..f4fc435689 100644 --- a/src/Simplex/Chat/Library/Internal.hs +++ b/src/Simplex/Chat/Library/Internal.hs @@ -2445,8 +2445,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 maxEncodedInfoLength info of - ECMEncoded connInfo -> compressConnInfoPQ pqSup connInfo + case encodeChatMessage maxDecompressedMsgLength info of + ECMEncoded connInfo -> compressConnInfo 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,17 +2454,18 @@ encodeSignedConnInfo :: MsgEncodingI e => PQSupport -> MsgSigning -> ChatMsgEven encodeSignedConnInfo pqSup signing chatMsgEvent = do vr <- chatVersionRange let info = ChatMessage {chatVRange = vr, msgId = Nothing, chatMsgEvent} - case encodeChatMessage maxEncodedInfoLength info of - ECMEncoded body -> compressConnInfoPQ pqSup $ encodeBatchElement (Just $ signChatMsgBody signing body) body + case encodeChatMessage maxDecompressedMsgLength info of + ECMEncoded body -> compressConnInfo pqSup $ encodeBatchElement (Just $ signChatMsgBody signing body) body ECMLarge -> throwChatError $ CEException "large signed info" -compressConnInfoPQ :: PQSupport -> ByteString -> CM ByteString -compressConnInfoPQ pqSup connInfo = case pqSup of - PQSupportOn | B.length connInfo > maxCompressedInfoLength -> do - let connInfo' = compressedBatchMsgBody_ connInfo - when (B.length connInfo' > maxCompressedInfoLength) $ throwChatError $ CEException "large compressed info" - pure connInfo' - _ -> pure connInfo +compressConnInfo :: PQSupport -> ByteString -> CM ByteString +compressConnInfo pqSup connInfo = + maybe (throwChatError $ CEException "large compressed info") pure $ compressToLimit (maxConnInfoLength pqSup) connInfo + +maxConnInfoLength :: PQSupport -> Int +maxConnInfoLength = \case + PQSupportOn -> maxEncodedInfoLengthPQ + PQSupportOff -> maxEncodedInfoLength -- 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 @@ -2498,7 +2499,7 @@ deliverMessages msgs = deliverMessagesB $ L.map Right msgs deliverMessagesB :: NonEmpty (Either ChatError ChatMsgReq) -> CM (NonEmpty (Either ChatError ([Int64], PQEncryption))) deliverMessagesB msgReqs = do - msgReqs' <- if any connSupportsPQ msgReqs then liftIO compressBodies else pure msgReqs + msgReqs' <- liftIO $ compressBodies $ if any connSupportsPQ msgReqs then maxEncodedMsgLengthPQ else maxEncodedMsgLength 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 @@ -2506,13 +2507,11 @@ deliverMessagesB msgReqs = do connSupportsPQ = \case Right (Connection {pqSupport = PQSupportOn}, _, _) -> True _ -> False - compressBodies = + -- one limit for the batch: connections share message bodies via VRRef + compressBodies maxLen = forME msgReqs $ \(conn, msgFlags, (mbr, msgIds)) -> runExceptT $ do mbr' <- case mbr of - VRValue i msgBody | B.length msgBody > maxCompressedMsgLength -> do - let msgBody' = compressedBatchMsgBody_ msgBody - when (B.length msgBody' > maxCompressedMsgLength) $ throwError $ ChatError $ CEException "large compressed message" - pure $ VRValue i msgBody' + VRValue i msgBody -> maybe (throwError $ ChatError $ CEException "large compressed message") (pure . VRValue i) $ compressToLimit maxLen msgBody v -> pure v pure (conn, msgFlags, (mbr', msgIds)) toAgent prev = \case diff --git a/src/Simplex/Chat/Protocol.hs b/src/Simplex/Chat/Protocol.hs index fbdafca782..0dcf1fffb5 100644 --- a/src/Simplex/Chat/Protocol.hs +++ b/src/Simplex/Chat/Protocol.hs @@ -925,8 +925,8 @@ maxEncodedMsgLength :: Int maxEncodedMsgLength = 15602 -- maxEncodedMsgLength - 2222, see e2eEncUserMsgLength in agent -maxCompressedMsgLength :: Int -maxCompressedMsgLength = 13380 +maxEncodedMsgLengthPQ :: Int +maxEncodedMsgLengthPQ = 13380 maxDecompressedMsgLength :: Int maxDecompressedMsgLength = 65536 @@ -962,8 +962,8 @@ rosterBlobP = do maxEncodedInfoLength :: Int maxEncodedInfoLength = 14694 -maxCompressedInfoLength :: Int -maxCompressedInfoLength = 10968 -- maxEncodedInfoLength - 3726, see e2eEncConnInfoLength in agent +maxEncodedInfoLengthPQ :: Int +maxEncodedInfoLengthPQ = 10968 -- maxEncodedInfoLength - 3726, see e2eEncConnInfoLength in agent data EncodedChatMessage = ECMEncoded ByteString | ECMLarge @@ -1038,6 +1038,15 @@ 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/Profiles.hs b/tests/ChatTests/Profiles.hs index 2198bf85ce..66913cf522 100644 --- a/tests/ChatTests/Profiles.hs +++ b/tests/ChatTests/Profiles.hs @@ -2,6 +2,7 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PostfixOperators #-} {-# LANGUAGE TypeApplications #-} @@ -34,6 +35,7 @@ import Simplex.Chat.Types (ConnStatus (..), GroupProfile, GroupRejectionReason ( 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.Chat.Types.Shared (GroupMemberRole (..)) import Simplex.Chat.Types.UITheme import Simplex.Messaging.Agent.Env.SQLite @@ -85,6 +87,7 @@ chatProfileTests = do 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 @@ -1330,11 +1333,11 @@ testBusinessAddressProfileSizeLimit :: HasCallStack => TestParams -> IO () testBusinessAddressProfileSizeLimit ps = do Right (pk, sk) <- bbsKeyGen img <- largeProfileImage - bizProfile <- profileOfSize maxCheckedInfoSize (businessProfile :: Profile) {image = Just img} - bobProfile' <- profileOfSize maxCheckedInfoSize (bobProfile :: Profile) {image = Just img} - testChatCfg2 (testCfg {badgePublicKeys = testBadgeKeys pk}) bizProfile bobProfile' (test sk) ps + bizProfile <- profileOfSize textOfSize maxCheckedInfoSize (businessProfile :: Profile) {image = Just img} + bobProfile'@Profile {description = Just bobDescr} <- profileOfSize textOfSize maxCheckedInfoSize (bobProfile :: Profile) {image = Just img} + testChatCfg2 (testCfg {badgePublicKeys = testBadgeKeys pk}) bizProfile bobProfile' (test sk bobDescr) ps where - test sk biz bob = do + test sk bobDescr biz bob = do -- the badge proof is added to bob's profile in XContact and in the signed XInfo reply addTestBadge bob =<< issueTestBadge sk futureDate biz ##> "/ad" @@ -1352,28 +1355,49 @@ testBusinessAddressProfileSizeLimit ps = do bob <# "#biz biz_1> hi" bob #> "#biz hello" biz <# "#bob bob_1> hello" + biz ##> "/i #bob bob_1" + biz <## "group ID: 1" + biz <## "member ID: 2" + biz <## "supporter badge - active" + biz <## "expires 2100-01-01" + biz <## "description:" + biz <## T.unpack bobDescr + 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 (maxCheckedInfoSize + 1) (aliceProfile :: Profile) {image = Just img} + 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 (maxCheckedInfoSize + 1) (teamProfile img) + gp <- groupProfileOfSize textOfSize (maxCheckedInfoSize + 1) (teamProfile img) alice `send` ("/_group_profile #1 " <> T.unpack (encodeJSON gp)) - _trimmedCmd2 <- getTermLine alice + _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 bobProfile $ \alice bob -> do + testChat2 (aliceProfile :: Profile) {displayName = T.pack hostName} bobProfile $ \alice bob -> do img <- largeProfileImage - gp@Types.GroupProfile {Types.description = Just welcomeMsg} <- groupProfileOfSize maxCheckedInfoSize (teamProfile img) + 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" @@ -1388,10 +1412,32 @@ testGroupLinkProfileSizeLimit = do bob <## "#team: joining the group..." bob <## "#team: you joined the group" - bob <# ("#team alice> " <> T.unpack welcomeMsg) + bob <# ("#team " <> hostName <> "> " <> T.unpack welcomeMsg) ] alice #> "#team hello" - bob <# "#team alice> 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 @@ -1413,15 +1459,15 @@ teamProfile img descr = Types.memberAdmission = Nothing } --- description is filled with text-like words, so that the encoded XInfo is exactly n bytes -profileOfSize :: Int -> Profile -> IO Profile -profileOfSize n p = do +-- 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 <- textOfSize $ n - infoSize (XInfo p' Nothing) + text <- genText $ n - infoSize (XInfo p' Nothing) pure (p' :: Profile) {description = Just text} -groupProfileOfSize :: Int -> (T.Text -> GroupProfile) -> IO GroupProfile -groupProfileOfSize n withDescr = withDescr <$> textOfSize (n - infoSize (XGrpInfo $ withDescr "")) +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 @@ -1439,6 +1485,11 @@ textOfSize n = do 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) + testBusinessUpdateProfiles :: HasCallStack => TestParams -> IO () testBusinessUpdateProfiles = testChat4 businessProfile aliceProfile bobProfile cathProfile $ \biz alice bob cath -> do diff --git a/tests/ProtocolTests.hs b/tests/ProtocolTests.hs index d748b5cba2..bd62ba4a6f 100644 --- a/tests/ProtocolTests.hs +++ b/tests/ProtocolTests.hs @@ -1,21 +1,26 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -fno-warn-ambiguous-fields #-} module ProtocolTests where +import Control.Concurrent.STM (atomically) import qualified Data.Aeson as J import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B import Data.List (isInfixOf) 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.Messages.Batch (encodeBatchElement) import Simplex.Chat.Protocol import Simplex.Chat.Types import Simplex.Chat.Types.Preferences @@ -35,6 +40,7 @@ protocolTests = do decodeChatMessageTest shortLinkDataTests batchLimitTests + compressToLimitTests preferencesJSONTests preferencesJSONTests :: Spec @@ -86,6 +92,35 @@ batchLimitTests = describe "Chat message batch limits" $ do [Left e] -> e rs -> "expected a single error, got " <> show (length rs) <> " results" +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 ==## msg + it "fails when the compressed body is still over the limit" $ + compressToLimit (compressedLen - 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 + 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) + all verified signatures `shouldBe` True + 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" + compressed = compressedBatchMsgBody_ body + compressedLen = B.length compressed + srv :: SMPServer srv = SMPServer "smp.simplex.im" "5223" (C.KeyHash "\215m\248\251")