From b678ccd9006c399d7cbeaf996544ebf2265324ad Mon Sep 17 00:00:00 2001
From: Evgeny Poberezkin <evgeny@poberezkin.com>
Date: Sat, 22 Mar 2025 09:09:37 +0000
Subject: [PATCH] core: compress commands in remote connection

---
 simplex-chat.cabal                  |  1 +
 src/Simplex/Chat/Remote.hs          |  2 +-
 src/Simplex/Chat/Remote/Protocol.hs | 16 ++++++++++++----
 3 files changed, 14 insertions(+), 5 deletions(-)

diff --git a/simplex-chat.cabal b/simplex-chat.cabal
index c9dc9f6afe..c9defcdb72 100644
--- a/simplex-chat.cabal
+++ b/simplex-chat.cabal
@@ -276,6 +276,7 @@ library
     , unliftio-core ==0.2.*
     , uuid ==1.3.*
     , zip ==2.0.*
+    , zstd ==0.1.3.*
   default-language: Haskell2010
   if flag(swift)
     cpp-options: -DswiftJSON
diff --git a/src/Simplex/Chat/Remote.hs b/src/Simplex/Chat/Remote.hs
index a7f44eb465..bf1b0fcb55 100644
--- a/src/Simplex/Chat/Remote.hs
+++ b/src/Simplex/Chat/Remote.hs
@@ -509,7 +509,7 @@ handleRemoteCommand execChatCommand encryption remoteOutputQ HTTP2Request {reque
     parseRequest :: ExceptT RemoteProtocolError IO (C.SbKeyNonce, GetChunk, RemoteCommand)
     parseRequest = do
       (rfKN, header, getNext) <- parseDecryptHTTP2Body encryption request reqBody
-      (rfKN,getNext,) <$> liftEitherWith RPEInvalidJSON (J.eitherDecode header)
+      (rfKN,getNext,) <$> liftEitherWith RPEInvalidJSON (J.eitherDecodeStrict header)
     replyError = reply . RRChatResponse . CRChatCmdError Nothing
     processCommand :: User -> C.SbKeyNonce -> GetChunk -> RemoteCommand -> CM ()
     processCommand user rfKN getNext = \case
diff --git a/src/Simplex/Chat/Remote/Protocol.hs b/src/Simplex/Chat/Remote/Protocol.hs
index 00fc56f897..9e6ea6681d 100644
--- a/src/Simplex/Chat/Remote/Protocol.hs
+++ b/src/Simplex/Chat/Remote/Protocol.hs
@@ -11,6 +11,7 @@
 
 module Simplex.Chat.Remote.Protocol where
 
+import qualified Codec.Compression.Zstd as Z1
 import Control.Monad
 import Control.Monad.Except
 import Control.Monad.Reader
@@ -27,6 +28,7 @@ import Data.ByteString (ByteString)
 import qualified Data.ByteString as B
 import Data.ByteString.Builder (Builder, byteString, lazyByteString)
 import qualified Data.ByteString.Lazy as LB
+import qualified Data.ByteString.Lazy.Internal as LB
 import Data.String (fromString)
 import Data.Text (Text)
 import Data.Text.Encoding (decodeUtf8)
@@ -152,7 +154,7 @@ sendRemoteCommand RemoteHostClient {httpClient, hostEncoding, encryption} file_
   let req = httpRequest encFile_ encCmd
   HTTP2Response {response, respBody} <- liftError' (RPEHTTP2 . tshow) $ sendRequestDirect httpClient req Nothing
   (rfKN, header, getNext) <- parseDecryptHTTP2Body encryption response respBody
-  rr <- liftEitherWith (RPEInvalidJSON . fromString) $ J.eitherDecode header >>= JT.parseEither J.parseJSON . convertJSON hostEncoding localEncoding
+  rr <- liftEitherWith (RPEInvalidJSON . fromString) $ J.eitherDecodeStrict header >>= JT.parseEither J.parseJSON . convertJSON hostEncoding localEncoding
   pure (rfKN, getNext, rr)
   where
     httpRequest encFile_ cmdBld = H.requestStreaming N.methodPost "/" mempty $ \send flush -> do
@@ -224,7 +226,8 @@ pattern OwsfTag = (SingleFieldJSONTag, J.Bool True)
 
 encryptEncodeHTTP2Body :: Word32 -> C.SbKeyNonce -> RemoteCrypto -> LazyByteString -> ExceptT RemoteProtocolError IO Builder
 encryptEncodeHTTP2Body corrId cmdKN RemoteCrypto {sessionCode, signatures} s = do
-  ct <- liftError PRERemoteControl $ RC.rcEncryptBody cmdKN $ LB.fromStrict (smpEncode sessionCode) <> s
+  let s' = LB.fromStrict $ Z1.compress 3 $ LB.toStrict s
+  ct <- liftError PRERemoteControl $ RC.rcEncryptBody cmdKN $ LB.Chunk (smpEncode sessionCode) s'
   let ctLen = encodeWord32 (fromIntegral $ LB.length ct)
       signed = LB.fromStrict (encodeWord32 corrId <> ctLen) <> ct
   sigs <- bodySignatures signed
@@ -242,12 +245,12 @@ encryptEncodeHTTP2Body corrId cmdKN RemoteCrypto {sessionCode, signatures} s = d
     sign k = C.signatureBytes . C.sign' k . BA.convert . CH.hashFinalize
 
 -- | Parse and decrypt HTTP2 request/response
-parseDecryptHTTP2Body :: HTTP2BodyChunk a => RemoteCrypto -> a -> HTTP2Body -> ExceptT RemoteProtocolError IO (C.SbKeyNonce, LazyByteString, Int -> IO ByteString)
+parseDecryptHTTP2Body :: HTTP2BodyChunk a => RemoteCrypto -> a -> HTTP2Body -> ExceptT RemoteProtocolError IO (C.SbKeyNonce, ByteString, Int -> IO ByteString)
 parseDecryptHTTP2Body rc@RemoteCrypto {sessionCode, signatures} hr HTTP2Body {bodyBuffer} = do
   (corrId, ct) <- getBody
   (cmdKN, rfKN) <- ExceptT $ atomically $ getRemoteRcvKeys rc corrId
   s <- liftError PRERemoteControl $ RC.rcDecryptBody cmdKN ct
-  s' <- parseBody s
+  s' <- decompress =<< parseBody s
   pure (rfKN, s', getNext)
   where
     getBody :: ExceptT RemoteProtocolError IO (Word32, LazyByteString)
@@ -296,3 +299,8 @@ parseDecryptHTTP2Body rc@RemoteCrypto {sessionCode, signatures} hr HTTP2Body {bo
           unless (LB.length bs == n) $ throwError PRESessionCode
           pure (LB.toStrict bs, rest)
     getNext sz = getBuffered bodyBuffer sz Nothing $ getBodyChunk hr
+    decompress :: LazyByteString -> ExceptT RemoteProtocolError IO ByteString
+    decompress s = case Z1.decompress $ LB.toStrict s of
+      Z1.Error e -> throwError $ RPEInvalidBody e
+      Z1.Skip -> pure B.empty
+      Z1.Decompress s' -> pure s'