core: compress over limit, error if still over

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"]

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

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 #-}

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 <name> 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

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")