core: restrict body size for XRCP commands and responses, limit decompressed size (#7616)

Co-authored-by: Evgeny @ SimpleX Chat <259188159+evgeny-simplex@users.noreply.github.com>

src/Simplex/Chat/Remote.hs

@@ -517,7 +517,7 @@ handleRemoteCommand execCC encryption remoteOutputQ HTTP2Request {request, reqBo
   where
     parseRequest :: ExceptT RemoteProtocolError IO (C.SbKeyNonce, GetChunk, RemoteCommand)
     parseRequest = do
-      (rfKN, header, getNext) <- parseDecryptHTTP2Body encryption request reqBody
+      (rfKN, header, getNext) <- parseDecryptHTTP2Body maxCommandBodySize encryption request reqBody
       (rfKN,getNext,) <$> liftEitherWith RPEInvalidJSON (J.eitherDecodeStrict header)
     replyError = reply . RRChatResponse . RRError
     processCommand :: User -> C.SbKeyNonce -> GetChunk -> RemoteCommand -> CM ()

src/Simplex/Chat/Remote/Protocol.hs

@@ -40,7 +40,8 @@ import Simplex.Chat.Controller
 import Simplex.Chat.Remote.Transport
 import Simplex.Chat.Remote.Types
 import Simplex.Chat.Types (BoolDef (..))
-import Simplex.FileTransfer.Description (FileDigest (..))
+import Simplex.FileTransfer.Description (FileDigest (..), mb)
+import Simplex.Messaging.Compression (limitDecompress')
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Crypto.File (CryptoFile (..))
 import Simplex.Messaging.Crypto.Lazy (LazyByteString)
@@ -180,7 +181,7 @@ sendRemoteCommand RemoteHostClient {httpClient, hostEncoding, encryption} file_
   encFile_ <- mapM (prepareEncryptedFile sfKN) file_
   let req = httpRequest encFile_ encCmd
   HTTP2Response {response, respBody} <- liftError' (RPEHTTP2 . tshow) $ sendRequestDirect httpClient req Nothing
-  (rfKN, header, getNext) <- parseDecryptHTTP2Body encryption response respBody
+  (rfKN, header, getNext) <- parseDecryptHTTP2Body maxResponseBodySize encryption response respBody
   rr <- liftEitherWith (RPEInvalidJSON . fromString) $ J.eitherDecodeStrict header >>= JT.parseEither J.parseJSON . convertJSON hostEncoding localEncoding
   pure (rfKN, getNext, rr)
   where
@@ -273,9 +274,15 @@ encryptEncodeHTTP2Body corrId cmdKN RemoteCrypto {sessionCode, signatures, compr
     sign :: C.PrivateKeyEd25519 -> CH.Context SHA512 -> ByteString
     sign k = C.signatureBytes . C.sign' k . BA.convert . CH.hashFinalize
 
+maxCommandBodySize :: Int
+maxCommandBodySize = mb 64
+
+maxResponseBodySize :: Int
+maxResponseBodySize = mb 512
+
 -- | Parse and decrypt HTTP2 request/response
-parseDecryptHTTP2Body :: HTTP2BodyChunk a => RemoteCrypto -> a -> HTTP2Body -> ExceptT RemoteProtocolError IO (C.SbKeyNonce, ByteString, Int -> IO ByteString)
-parseDecryptHTTP2Body rc@RemoteCrypto {sessionCode, signatures, compression} hr HTTP2Body {bodyBuffer} = do
+parseDecryptHTTP2Body :: HTTP2BodyChunk a => Int -> RemoteCrypto -> a -> HTTP2Body -> ExceptT RemoteProtocolError IO (C.SbKeyNonce, ByteString, Int -> IO ByteString)
+parseDecryptHTTP2Body maxSize rc@RemoteCrypto {sessionCode, signatures, compression} hr HTTP2Body {bodyBuffer} = do
   (corrId, ct) <- getBody
   (cmdKN, rfKN) <- ExceptT $ atomically $ getRemoteRcvKeys rc corrId
   s <- liftError PRERemoteControl $ RC.rcDecryptBody cmdKN ct
@@ -287,7 +294,7 @@ parseDecryptHTTP2Body rc@RemoteCrypto {sessionCode, signatures, compression} hr
       corrIdStr <- liftIO $ getNext 4
       ctLenStr <- liftIO $ getNext 4
       let ctLen = decodeWord32 ctLenStr
-      when (ctLen > fromIntegral (maxBound :: Int)) $ throwError RPEInvalidSize
+      when (ctLen > fromIntegral maxSize) $ throwError RPEInvalidSize
       chunks <- liftIO $ getLazy $ fromIntegral ctLen
       let hc = CH.hashUpdates (CH.hashInit @SHA512) [corrIdStr, ctLenStr]
           hc' = CH.hashUpdates hc chunks
@@ -330,8 +337,5 @@ parseDecryptHTTP2Body rc@RemoteCrypto {sessionCode, signatures, compression} hr
     getNext sz = getBuffered bodyBuffer sz Nothing $ getBodyChunk hr
     decompress :: LazyByteString -> ExceptT RemoteProtocolError IO ByteString
     decompress s
-      | compression = case Z1.decompress $ LB.toStrict s of
-          Z1.Error e -> throwError $ RPEInvalidBody e
-          Z1.Skip -> pure B.empty
-          Z1.Decompress s' -> pure s'
+      | compression = liftEitherWith RPEInvalidBody $ limitDecompress' maxSize $ LB.toStrict s
       | otherwise = pure $ LB.toStrict s

tests/RemoteTests.hs

@@ -14,19 +14,26 @@ import Control.Monad
 import Control.Monad.Except (runExceptT)
 import qualified Data.Aeson as J
 import qualified Data.ByteString as B
+import Data.ByteString.Builder (toLazyByteString)
 import qualified Data.ByteString.Lazy.Char8 as LB
 import Data.List (find, isPrefixOf)
 import qualified Data.Map.Strict as M
+import Data.Word (Word32)
 import Simplex.Chat.Controller (ChatCommand (..), ChatConfig (..), versionNumber)
 import Simplex.Chat.Files (safeFileNameStr)
 import Simplex.Chat.Library.Commands (parseChatCommand)
 import qualified Simplex.Chat.Controller as Controller
 import Simplex.Chat.Mobile.File
 import Simplex.Chat.Remote (remoteFilesFolder, validRemoteFileName)
-import Simplex.Chat.Remote.Protocol (remoteStoreFile)
+import Simplex.Chat.Remote.Protocol (encryptEncodeHTTP2Body, parseDecryptHTTP2Body, remoteStoreFile)
 import Simplex.Chat.Remote.Types
+import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Crypto.File (CryptoFileArgs (..))
+import Simplex.Messaging.Encoding (smpEncode)
 import Simplex.Messaging.Encoding.String (strEncode)
+import qualified Simplex.Messaging.TMap as TM
+import Simplex.Messaging.Transport (TSbChainKeys (..))
+import Simplex.Messaging.Transport.HTTP2 (HTTP2BodyChunk (..), getHTTP2Body)
 import Simplex.Messaging.Util
 import Simplex.RemoteControl.Types (RCCtrlAddress (..))
 import System.FilePath (takeFileName, (</>))
@@ -54,6 +61,24 @@ remoteTests = describe "Remote" $ do
       filter (not . sanitized) fileNames `shouldBe` []
     it "sanitizes to a name with no directory components" $ \_ ->
       filter (not . bareName) fileNames `shouldBe` []
+  describe "body size limit" $ do
+    it "rejects encrypted body above limit without reading it" $ \_ -> do
+      rc <- testRemoteCrypto
+      chunks <- newIORef [smpEncode (1 :: Word32, 1025 :: Word32), "body"]
+      r <- parseDecryptChunks 1024 rc chunks
+      r `shouldSatisfy` \case
+        Left RPEInvalidSize -> True
+        _ -> False
+      readIORef chunks `shouldReturn` ["body"]
+    it "rejects decompressed body above limit" $ \_ -> do
+      rc <- testRemoteCrypto
+      (corrId, cmdKN, _) <- atomically $ getRemoteSndKeys rc
+      Right encBody <- runExceptT $ encryptEncodeHTTP2Body corrId cmdKN rc $ LB.replicate 1025 'a'
+      chunks <- newIORef $ LB.toChunks $ toLazyByteString encBody
+      r <- parseDecryptChunks 1024 rc chunks
+      r `shouldSatisfy` \case
+        Left (RPEInvalidBody _) -> True
+        _ -> False
   xdescribe "No compression" $ aroundWith (. ((False, False),)) runRemoteTests
   xdescribe "Mobile offers compression" $ aroundWith (. ((True, False),)) runRemoteTests
   xdescribe "Desktop offers compression" $ aroundWith (. ((False, True),)) runRemoteTests
@@ -665,3 +690,28 @@ eventually retries action =
     Left err | retries == 0 -> throwIO err
     Left _ -> eventually (retries - 1) action
     Right r -> pure r
+
+newtype TestBody = TestBody (IORef [B.ByteString])
+
+instance HTTP2BodyChunk TestBody where
+  getBodyChunk (TestBody chunks) = atomicModifyIORef' chunks $ \case
+    c : cs -> (cs, c)
+    [] -> ([], "")
+  getBodySize _ = Nothing
+
+testRemoteCrypto :: IO RemoteCrypto
+testRemoteCrypto = do
+  drg <- C.newRandom
+  (_, idPrivKey) <- atomically $ C.generateKeyPair drg
+  (_, sessPrivKey) <- atomically $ C.generateKeyPair drg
+  let (chainKey, _) = C.sbcInit "" ("secret" :: B.ByteString)
+  chainKeys <- TSbChainKeys <$> newTVarIO chainKey <*> newTVarIO chainKey
+  sndCounter <- newTVarIO 0
+  rcvCounter <- newTVarIO 0
+  skippedKeys <- TM.emptyIO
+  pure RemoteCrypto {sessionCode = "", sndCounter, rcvCounter, chainKeys, skippedKeys, signatures = RSSign {idPrivKey, sessPrivKey}, compression = True}
+
+parseDecryptChunks :: Int -> RemoteCrypto -> IORef [B.ByteString] -> IO (Either RemoteProtocolError ())
+parseDecryptChunks maxSize rc chunks = do
+  body <- getHTTP2Body (TestBody chunks) 0
+  runExceptT . void $ parseDecryptHTTP2Body maxSize rc (TestBody chunks) body