From 59b31e263112bf8057b147504fb71a096b178199 Mon Sep 17 00:00:00 2001 From: Evgeny Date: Tue, 30 Dec 2025 07:49:17 +0000 Subject: [PATCH] core: compress commands in remote connection (#5776) * core: compress commands in remote connection * backwards compatible compression * show in CLI if compression is enabled * use aroundWith for ghc 8.10.7 compatibility * skip bot API tests in GHC 8.10.7 --- src/Simplex/Chat.hs | 1 + src/Simplex/Chat/Controller.hs | 16 ++-- src/Simplex/Chat/Library/Commands.hs | 2 +- src/Simplex/Chat/Remote.hs | 45 ++++++--- src/Simplex/Chat/Remote/Protocol.hs | 43 ++++++--- src/Simplex/Chat/Remote/Types.hs | 11 ++- src/Simplex/Chat/View.hs | 10 +- tests/ChatTests/Utils.hs | 6 +- tests/RemoteTests.hs | 132 ++++++++++++++++----------- tests/Test.hs | 2 + 10 files changed, 171 insertions(+), 97 deletions(-) diff --git a/src/Simplex/Chat.hs b/src/Simplex/Chat.hs index 93132fb413..35234e1136 100644 --- a/src/Simplex/Chat.hs +++ b/src/Simplex/Chat.hs @@ -110,6 +110,7 @@ defaultChatConfig = deliveryWorkerDelay = 0, deliveryBucketSize = 10000, deviceNameForRemote = "", + remoteCompression = True, chatHooks = defaultChatHooks } diff --git a/src/Simplex/Chat/Controller.hs b/src/Simplex/Chat/Controller.hs index 8003f66324..34ad95b800 100644 --- a/src/Simplex/Chat/Controller.hs +++ b/src/Simplex/Chat/Controller.hs @@ -159,6 +159,7 @@ data ChatConfig = ChatConfig deliveryBucketSize :: Int, highlyAvailable :: Bool, deviceNameForRemote :: Text, + remoteCompression :: Bool, chatHooks :: ChatHooks } @@ -754,7 +755,7 @@ data ChatResponse | CRRemoteFileStored {remoteHostId :: RemoteHostId, remoteFileSource :: CryptoFile} | CRRemoteCtrlList {remoteCtrls :: [RemoteCtrlInfo]} | CRRemoteCtrlConnecting {remoteCtrl_ :: Maybe RemoteCtrlInfo, ctrlAppInfo :: CtrlAppInfo, appVersion :: AppVersion} - | CRRemoteCtrlConnected {remoteCtrl :: RemoteCtrlInfo} + | CRRemoteCtrlConnected {remoteCtrl :: RemoteCtrlInfo, compression :: Bool} | CRSQLResult {rows :: [Text]} #if !defined(dbPostgres) | CRArchiveExported {archiveErrors :: [ArchiveError]} @@ -857,7 +858,7 @@ data ChatEvent | CEvtNtfMessage {user :: User, connEntity :: ConnectionEntity, ntfMessage :: NtfMsgAckInfo} | CEvtRemoteHostSessionCode {remoteHost_ :: Maybe RemoteHostInfo, sessionCode :: Text} | CEvtNewRemoteHost {remoteHost :: RemoteHostInfo} - | CEvtRemoteHostConnected {remoteHost :: RemoteHostInfo} + | CEvtRemoteHostConnected {remoteHost :: RemoteHostInfo, compression :: Bool} | CEvtRemoteHostStopped {remoteHostId_ :: Maybe RemoteHostId, rhsState :: RemoteHostSessionState, rhStopReason :: RemoteHostStopReason} | CEvtRemoteCtrlFound {remoteCtrl :: RemoteCtrlInfo, ctrlAppInfo_ :: Maybe CtrlAppInfo, appVersion :: AppVersion, compatible :: Bool} | CEvtRemoteCtrlSessionCode {remoteCtrl_ :: Maybe RemoteCtrlInfo, sessionCode :: Text} @@ -897,7 +898,7 @@ allowRemoteEvent = \case CEvtChatSuspended -> False CEvtRemoteHostSessionCode {} -> False CEvtNewRemoteHost _ -> False - CEvtRemoteHostConnected _ -> False + CEvtRemoteHostConnected {} -> False CEvtRemoteHostStopped {} -> False CEvtRemoteCtrlFound {} -> False CEvtRemoteCtrlSessionCode {} -> False @@ -1397,7 +1398,8 @@ data RemoteCtrlSession | RCSessionConnecting { remoteCtrlId_ :: Maybe RemoteCtrlId, rcsClient :: RCCtrlClient, - rcsWaitSession :: Async () + rcsWaitSession :: Async (), + ctrlAppInfo :: CtrlAppInfo } | RCSessionPendingConfirmation { remoteCtrlId_ :: Maybe RemoteCtrlId, @@ -1406,7 +1408,8 @@ data RemoteCtrlSession tls :: TLS 'TClient, sessionCode :: Text, rcsWaitSession :: Async (), - rcsWaitConfirmation :: TMVar (Either RCErrorType (RCCtrlSession, RCCtrlPairing)) + rcsWaitConfirmation :: TMVar (Either RCErrorType (RCCtrlSession, RCCtrlPairing)), + ctrlAppInfo :: CtrlAppInfo } | RCSessionConnected { remoteCtrlId :: RemoteCtrlId, @@ -1414,7 +1417,8 @@ data RemoteCtrlSession tls :: TLS 'TClient, rcsSession :: RCCtrlSession, http2Server :: Async (), - remoteOutputQ :: TBQueue (Either ChatError ChatEvent) + remoteOutputQ :: TBQueue (Either ChatError ChatEvent), + ctrlAppInfo :: CtrlAppInfo } data RemoteCtrlSessionState diff --git a/src/Simplex/Chat/Library/Commands.hs b/src/Simplex/Chat/Library/Commands.hs index 57f4244fab..fc6a0ea782 100644 --- a/src/Simplex/Chat/Library/Commands.hs +++ b/src/Simplex/Chat/Library/Commands.hs @@ -2959,7 +2959,7 @@ processChatCommand vr nm = \case ConfirmRemoteCtrl rcId -> withUser_ $ do (rc, ctrlAppInfo) <- confirmRemoteCtrl rcId pure CRRemoteCtrlConnecting {remoteCtrl_ = Just rc, ctrlAppInfo, appVersion = currentAppVersion} - VerifyRemoteCtrlSession sessId -> withUser_ $ CRRemoteCtrlConnected <$> verifyRemoteCtrlSession (execChatCommand Nothing) sessId + VerifyRemoteCtrlSession sessId -> withUser_ $ verifyRemoteCtrlSession (execChatCommand Nothing) sessId StopRemoteCtrl -> withUser_ $ stopRemoteCtrl >> ok_ ListRemoteCtrls -> withUser_ $ CRRemoteCtrlList <$> listRemoteCtrls DeleteRemoteCtrl rc -> withUser_ $ deleteRemoteCtrl rc >> ok_ diff --git a/src/Simplex/Chat/Remote.hs b/src/Simplex/Chat/Remote.hs index 255af5f318..b89d8a11f0 100644 --- a/src/Simplex/Chat/Remote.hs +++ b/src/Simplex/Chat/Remote.hs @@ -165,7 +165,8 @@ startRemoteHost rh_ rcAddrPrefs_ port_ = do where mkCtrlAppInfo = do deviceName <- chatReadVar localDeviceName - pure CtrlAppInfo {appVersionRange = ctrlAppVersionRange, deviceName} + useCompression <- asks $ remoteCompression . config + pure CtrlAppInfo {appVersionRange = ctrlAppVersionRange, deviceName, compression = BoolDef useCompression} parseHostAppInfo :: RCHostHello -> ExceptT RemoteHostError IO HostAppInfo parseHostAppInfo RCHostHello {app = hostAppInfo} = do hostInfo@HostAppInfo {appVersion, encoding} <- @@ -213,7 +214,9 @@ startRemoteHost rh_ rcAddrPrefs_ port_ = do RHSessionConfirmed _ RHPendingSession {rchClient} -> Right ((), RHSessionConnected {rchClient, tls, rhClient, pollAction, storePath}) _ -> Left $ ChatErrorRemoteHost rhKey RHEBadState chatWriteVar currentRemoteHost $ Just remoteHostId -- this is required for commands to be passed to remote host - toView $ CEvtRemoteHostConnected rhi {sessionState = Just RHSConnected {sessionCode}} + let RemoteHostClient {encryption = RemoteCrypto {compression}} = rhClient + remoteHost = rhi {sessionState = Just RHSConnected {sessionCode}} :: RemoteHostInfo + toView $ CEvtRemoteHostConnected {remoteHost, compression} upsertRemoteHost :: RCHostPairing -> Maybe RemoteHostInfo -> Maybe RCCtrlAddress -> Text -> SessionSeq -> RemoteHostSessionState -> CM RemoteHostInfo upsertRemoteHost pairing'@RCHostPairing {knownHost = kh_} rhi_ rcAddr_ hostDeviceName sseq state = do KnownHostPairing {hostDhPubKey = hostDhPubKey'} <- maybe (throwError . ChatError $ CEInternalError "KnownHost is known after verification") pure kh_ @@ -459,7 +462,7 @@ startRemoteCtrlSession = do connectRemoteCtrl :: RCVerifiedInvitation -> SessionSeq -> CM (Maybe RemoteCtrlInfo, CtrlAppInfo) connectRemoteCtrl verifiedInv@(RCVerifiedInvitation inv@RCInvitation {ca, app}) sseq = handleCtrlError sseq RCSRConnectionFailed "connectRemoteCtrl" $ do - ctrlInfo@CtrlAppInfo {deviceName = ctrlDeviceName} <- parseCtrlAppInfo app + ctrlInfo <- parseCtrlAppInfo app v <- checkAppVersion ctrlInfo rc_ <- withStore' $ \db -> getRemoteCtrlByFingerprint db ca mapM_ (validateRemoteCtrl inv) rc_ @@ -469,23 +472,23 @@ connectRemoteCtrl verifiedInv@(RCVerifiedInvitation inv@RCInvitation {ca, app}) cmdOk <- newEmptyTMVarIO rcsWaitSession <- async $ do atomically $ takeTMVar cmdOk - handleCtrlError sseq RCSRConnectionFailed "waitForCtrlSession" $ waitForCtrlSession rc_ ctrlDeviceName rcsClient vars + handleCtrlError sseq RCSRConnectionFailed "waitForCtrlSession" $ waitForCtrlSession rc_ ctrlInfo rcsClient vars updateRemoteCtrlSession sseq $ \case - RCSessionStarting -> Right RCSessionConnecting {remoteCtrlId_ = remoteCtrlId' <$> rc_, rcsClient, rcsWaitSession} + RCSessionStarting -> Right RCSessionConnecting {remoteCtrlId_ = remoteCtrlId' <$> rc_, rcsClient, rcsWaitSession, ctrlAppInfo = ctrlInfo} _ -> Left $ ChatErrorRemoteCtrl RCEBadState atomically $ putTMVar cmdOk () pure ((`remoteCtrlInfo` Just RCSConnecting) <$> rc_, ctrlInfo) where validateRemoteCtrl RCInvitation {idkey} RemoteCtrl {ctrlPairing = RCCtrlPairing {idPubKey}} = unless (idkey == idPubKey) $ throwError $ ChatErrorRemoteCtrl $ RCEProtocolError $ PRERemoteControl RCEIdentity - waitForCtrlSession :: Maybe RemoteCtrl -> Text -> RCCtrlClient -> RCStepTMVar (ByteString, TLS 'TClient, RCStepTMVar (RCCtrlSession, RCCtrlPairing)) -> CM () - waitForCtrlSession rc_ ctrlName rcsClient vars = do + waitForCtrlSession :: Maybe RemoteCtrl -> CtrlAppInfo -> RCCtrlClient -> RCStepTMVar (ByteString, TLS 'TClient, RCStepTMVar (RCCtrlSession, RCCtrlPairing)) -> CM () + waitForCtrlSession rc_ ctrlAppInfo@CtrlAppInfo {deviceName = ctrlName} rcsClient vars = do (uniq, tls, rcsWaitConfirmation) <- timeoutThrow (ChatErrorRemoteCtrl RCETimeout) networkIOTimeout $ takeRCStep vars let sessionCode = verificationCode uniq updateRemoteCtrlSession sseq $ \case RCSessionConnecting {rcsWaitSession} -> let remoteCtrlId_ = remoteCtrlId' <$> rc_ - in Right RCSessionPendingConfirmation {remoteCtrlId_, ctrlDeviceName = ctrlName, rcsClient, tls, sessionCode, rcsWaitSession, rcsWaitConfirmation} + in Right RCSessionPendingConfirmation {remoteCtrlId_, ctrlDeviceName = ctrlName, rcsClient, tls, sessionCode, rcsWaitSession, rcsWaitConfirmation, ctrlAppInfo} _ -> Left $ ChatErrorRemoteCtrl RCEBadState toView CEvtRemoteCtrlSessionCode {remoteCtrl_ = (`remoteCtrlInfo` Just RCSPendingConfirmation {sessionCode}) <$> rc_, sessionCode} checkAppVersion CtrlAppInfo {appVersionRange} = @@ -495,7 +498,8 @@ connectRemoteCtrl verifiedInv@(RCVerifiedInvitation inv@RCInvitation {ca, app}) getHostAppInfo appVersion = do hostDeviceName <- chatReadVar localDeviceName encryptFiles <- chatReadVar encryptLocalFiles - pure HostAppInfo {appVersion, deviceName = hostDeviceName, encoding = localEncoding, encryptFiles} + useCompression <- asks $ remoteCompression . config + pure HostAppInfo {appVersion, deviceName = hostDeviceName, encoding = localEncoding, encryptFiles, compression = BoolDef useCompression} parseCtrlAppInfo :: JT.Value -> CM CtrlAppInfo parseCtrlAppInfo ctrlAppInfo = do @@ -514,7 +518,7 @@ handleRemoteCommand execCC encryption remoteOutputQ HTTP2Request {request, reqBo 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 . RRError processCommand :: User -> C.SbKeyNonce -> GetChunk -> RemoteCommand -> CM () processCommand user rfKN getNext = \case @@ -611,7 +615,7 @@ remoteCtrlInfo RemoteCtrl {remoteCtrlId, ctrlDeviceName} sessionState = RemoteCtrlInfo {remoteCtrlId, ctrlDeviceName, sessionState} -- | Take a look at emoji of tlsunique, commit pairing, and start session server -verifyRemoteCtrlSession :: (ByteString -> Int -> CM' (Either ChatError ChatResponse)) -> Text -> CM RemoteCtrlInfo +verifyRemoteCtrlSession :: (ByteString -> Int -> CM' (Either ChatError ChatResponse)) -> Text -> CM ChatResponse verifyRemoteCtrlSession execCC sessCode' = do (sseq, client, ctrlName, sessionCode, vars) <- chatReadVar remoteCtrlSession >>= \case @@ -625,14 +629,15 @@ verifyRemoteCtrlSession execCC sessCode' = do (rcsSession@RCCtrlSession {tls, sessionKeys}, rcCtrlPairing) <- timeoutThrow (ChatErrorRemoteCtrl RCETimeout) networkIOTimeout $ takeRCStep vars rc@RemoteCtrl {remoteCtrlId} <- upsertRemoteCtrl ctrlName rcCtrlPairing remoteOutputQ <- asks (tbqSize . config) >>= newTBQueueIO - encryption <- mkCtrlRemoteCrypto sessionKeys $ tlsUniq tls + encryption@RemoteCrypto {compression} <- mkCtrlRemoteCrypto sessionKeys (tlsUniq tls) =<< getRemoteCtrlAppInfo sseq cc <- ask http2Server <- liftIO . async $ attachHTTP2Server tls $ \req -> handleRemoteCommand execCC encryption remoteOutputQ req `runReaderT` cc void . forkIO $ monitor sseq http2Server updateRemoteCtrlSession sseq $ \case - RCSessionPendingConfirmation {} -> Right RCSessionConnected {remoteCtrlId, rcsClient = client, rcsSession, tls, http2Server, remoteOutputQ} + RCSessionPendingConfirmation {ctrlAppInfo} -> Right RCSessionConnected {remoteCtrlId, rcsClient = client, rcsSession, tls, http2Server, remoteOutputQ, ctrlAppInfo} _ -> Left $ ChatErrorRemoteCtrl RCEBadState - pure $ remoteCtrlInfo rc $ Just RCSConnected {sessionCode = tlsSessionCode tls} + let remoteCtrl = remoteCtrlInfo rc $ Just RCSConnected {sessionCode = tlsSessionCode tls} + pure CRRemoteCtrlConnected {remoteCtrl, compression} where upsertRemoteCtrl :: Text -> RCCtrlPairing -> CM RemoteCtrl upsertRemoteCtrl ctrlName rcCtrlPairing = withStore $ \db -> do @@ -717,6 +722,18 @@ updateRemoteCtrlSession sseq state = do Right st' -> Right () <$ writeTVar session (Just (sseq, st')) liftEither r +getRemoteCtrlAppInfo :: SessionSeq -> CM (Maybe CtrlAppInfo) +getRemoteCtrlAppInfo sseq = chatReadVar remoteCtrlSession $>>= pure . appInfo + where + appInfo (currSseq, sess) + | sseq == currSseq = case sess of + RCSessionStarting -> Nothing + RCSessionSearching {} -> Nothing + RCSessionConnecting {ctrlAppInfo} -> Just ctrlAppInfo + RCSessionPendingConfirmation {ctrlAppInfo} -> Just ctrlAppInfo + RCSessionConnected {ctrlAppInfo} -> Just ctrlAppInfo + | otherwise = Nothing + utf8String :: [Char] -> ByteString utf8String = encodeUtf8 . T.pack {-# INLINE utf8String #-} diff --git a/src/Simplex/Chat/Remote/Protocol.hs b/src/Simplex/Chat/Remote/Protocol.hs index d8155db7d6..b71c6baed8 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) @@ -37,6 +39,7 @@ import Network.Transport.Internal (decodeWord32, encodeWord32) 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 qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Crypto.File (CryptoFile (..)) @@ -102,10 +105,10 @@ $(JQ.deriveJSON (taggedObjectJSON $ dropPrefix "RR") ''RemoteResponse) -- * Client side / desktop mkRemoteHostClient :: HTTP2Client -> HostSessKeys -> SessionCode -> FilePath -> HostAppInfo -> CM RemoteHostClient -mkRemoteHostClient httpClient sessionKeys sessionCode storePath HostAppInfo {encoding, deviceName, encryptFiles} = do +mkRemoteHostClient httpClient sessionKeys sessionCode storePath HostAppInfo {encoding, deviceName, encryptFiles, compression} = do let HostSessKeys {chainKeys, idPrivKey, sessPrivKey} = sessionKeys signatures = RSSign {idPrivKey, sessPrivKey} - encryption <- liftIO $ mkRemoteCrypto sessionCode chainKeys signatures + encryption <- mkRemoteCrypto sessionCode chainKeys signatures $ isTrue compression pure RemoteHostClient { hostEncoding = encoding, @@ -116,17 +119,19 @@ mkRemoteHostClient httpClient sessionKeys sessionCode storePath HostAppInfo {enc storePath } -mkCtrlRemoteCrypto :: CtrlSessKeys -> SessionCode -> CM RemoteCrypto -mkCtrlRemoteCrypto CtrlSessKeys {chainKeys, idPubKey, sessPubKey} sessionCode = +mkCtrlRemoteCrypto :: CtrlSessKeys -> SessionCode -> Maybe CtrlAppInfo -> CM RemoteCrypto +mkCtrlRemoteCrypto CtrlSessKeys {chainKeys, idPubKey, sessPubKey} sessionCode ctrlAppInfo_ = do let signatures = RSVerify {idPubKey, sessPubKey} - in liftIO $ mkRemoteCrypto sessionCode chainKeys signatures + peerCompression = maybe False (\CtrlAppInfo {compression} -> isTrue compression) ctrlAppInfo_ + mkRemoteCrypto sessionCode chainKeys signatures peerCompression -mkRemoteCrypto :: SessionCode -> TSbChainKeys -> RemoteSignatures -> IO RemoteCrypto -mkRemoteCrypto sessionCode chainKeys signatures = do +mkRemoteCrypto :: SessionCode -> TSbChainKeys -> RemoteSignatures -> Bool -> CM RemoteCrypto +mkRemoteCrypto sessionCode chainKeys signatures peerCompression = do sndCounter <- newTVarIO 0 rcvCounter <- newTVarIO 0 skippedKeys <- liftIO TM.emptyIO - pure RemoteCrypto {sessionCode, sndCounter, rcvCounter, chainKeys, skippedKeys, signatures} + useCompression <- asks $ remoteCompression . config + pure RemoteCrypto {sessionCode, sndCounter, rcvCounter, chainKeys, skippedKeys, signatures, compression = peerCompression && useCompression} closeRemoteHostClient :: RemoteHostClient -> IO () closeRemoteHostClient RemoteHostClient {httpClient} = closeHTTP2Client httpClient @@ -176,7 +181,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 @@ -247,8 +252,11 @@ pattern OwsfTag = (SingleFieldJSONTag, J.Bool True) -- See https://github.com/simplex-chat/simplexmq/blob/master/rfcs/2023-10-25-remote-control.md for encoding 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 +encryptEncodeHTTP2Body corrId cmdKN RemoteCrypto {sessionCode, signatures, compression} s = do + let s' + | compression = LB.fromStrict $ Z1.compress 3 $ LB.toStrict s + | otherwise = 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 @@ -266,12 +274,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 rc@RemoteCrypto {sessionCode, signatures} hr HTTP2Body {bodyBuffer} = do +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 (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) @@ -320,3 +328,10 @@ 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 + | compression = case Z1.decompress $ LB.toStrict s of + Z1.Error e -> throwError $ RPEInvalidBody e + Z1.Skip -> pure B.empty + Z1.Decompress s' -> pure s' + | otherwise = pure $ LB.toStrict s diff --git a/src/Simplex/Chat/Remote/Types.hs b/src/Simplex/Chat/Remote/Types.hs index b7af624e9e..746aa7f566 100644 --- a/src/Simplex/Chat/Remote/Types.hs +++ b/src/Simplex/Chat/Remote/Types.hs @@ -21,7 +21,7 @@ import Data.Int (Int64) import Data.Text (Text) import Data.Word (Word16, Word32) import Simplex.Chat.Remote.AppVersion -import Simplex.Chat.Types (verificationCode) +import Simplex.Chat.Types (BoolDef, verificationCode) import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Crypto.File (CryptoFile) import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, enumJSON, sumTypeJSON) @@ -47,7 +47,8 @@ data RemoteCrypto = RemoteCrypto rcvCounter :: TVar Word32, chainKeys :: TSbChainKeys, skippedKeys :: TM.TMap Word32 (C.SbKeyNonce, C.SbKeyNonce), - signatures :: RemoteSignatures + signatures :: RemoteSignatures, + compression :: Bool } getRemoteSndKeys :: RemoteCrypto -> STM (Word32, C.SbKeyNonce, C.SbKeyNonce) @@ -220,7 +221,8 @@ data RemoteFile = RemoteFile data CtrlAppInfo = CtrlAppInfo { appVersionRange :: AppVersionRange, - deviceName :: Text + deviceName :: Text, + compression :: BoolDef } deriving (Show) @@ -228,7 +230,8 @@ data HostAppInfo = HostAppInfo { appVersion :: AppVersion, deviceName :: Text, encoding :: PlatformEncoding, - encryptFiles :: Bool -- if the host encrypts files in app storage + encryptFiles :: Bool, -- if the host encrypts files in app storage + compression :: BoolDef } $(J.deriveJSON defaultJSON ''RemoteFile) diff --git a/src/Simplex/Chat/View.hs b/src/Simplex/Chat/View.hs index 4e1106c0d8..a8526e357f 100644 --- a/src/Simplex/Chat/View.hs +++ b/src/Simplex/Chat/View.hs @@ -273,8 +273,10 @@ chatResponseToView hu cfg@ChatConfig {logLevel, showReactions, testView} liveIte [ (maybe "connecting new remote controller" (\RemoteCtrlInfo {remoteCtrlId} -> "connecting remote controller " <> sShow remoteCtrlId) remoteCtrl_ <> ": ") <> viewRemoteCtrl ctrlAppInfo appVersion True ] - CRRemoteCtrlConnected RemoteCtrlInfo {remoteCtrlId = rcId, ctrlDeviceName} -> - ["remote controller " <> sShow rcId <> " session started with " <> plain ctrlDeviceName] + CRRemoteCtrlConnected RemoteCtrlInfo {remoteCtrlId = rcId, ctrlDeviceName} compression -> + ["remote controller " <> sShow rcId <> " session started with " <> plain ctrlDeviceName <> " (" <> compressStr <> " compression)"] + where + compressStr = if compression then "with" else "no" CRSQLResult rows -> map plain rows #if !defined(dbPostgres) CRArchiveExported archiveErrs -> if null archiveErrs then ["ok"] else ["archive export errors: " <> plain (show archiveErrs)] @@ -486,7 +488,9 @@ chatEventToView hu ChatConfig {logLevel, showReactions, showReceipts, testView} plain sessionCode ] CEvtNewRemoteHost RemoteHostInfo {remoteHostId = rhId, hostDeviceName} -> ["new remote host " <> sShow rhId <> " added: " <> plain hostDeviceName] - CEvtRemoteHostConnected RemoteHostInfo {remoteHostId = rhId} -> ["remote host " <> sShow rhId <> " connected"] + CEvtRemoteHostConnected RemoteHostInfo {remoteHostId = rhId} compression -> ["remote host " <> sShow rhId <> " connected (" <> compressStr <> " compression)"] + where + compressStr = if compression then "with" else "no" CEvtRemoteHostStopped {remoteHostId_} -> [ maybe "new remote host" (mappend "remote host " . sShow) remoteHostId_ <> " stopped" ] diff --git a/tests/ChatTests/Utils.hs b/tests/ChatTests/Utils.hs index 87be15afe5..0e99b26bc5 100644 --- a/tests/ChatTests/Utils.hs +++ b/tests/ChatTests/Utils.hs @@ -81,19 +81,19 @@ businessProfile = mkProfile "biz" "Biz Inc" Nothing mkProfile :: T.Text -> T.Text -> Maybe ImageData -> Profile mkProfile displayName descr image = Profile {displayName, fullName = "", shortDescr = Just descr, image, contactLink = Nothing, peerType = Nothing, preferences = defaultPrefs} -it :: HasCallStack => String -> (TestParams -> Expectation) -> SpecWith (Arg (TestParams -> Expectation)) +it :: HasCallStack => String -> (ps -> Expectation) -> SpecWith (Arg (ps -> Expectation)) it name test = Hspec.it name $ \tmp -> timeout t (test tmp) >>= maybe (error "test timed out") pure where t = 90 * 1000000 -xit' :: HasCallStack => String -> (TestParams -> Expectation) -> SpecWith (Arg (TestParams -> Expectation)) +xit' :: HasCallStack => String -> (ps -> Expectation) -> SpecWith (Arg (ps -> Expectation)) xit' = if os == "linux" then xit else it xit'' :: (HasCallStack, Example a) => String -> a -> SpecWith (Arg a) xit'' = ifCI xit Hspec.it -xitMacCI :: HasCallStack => String -> (TestParams -> Expectation) -> SpecWith (Arg (TestParams -> Expectation)) +xitMacCI :: HasCallStack => String -> (ps -> Expectation) -> SpecWith (Arg (ps -> Expectation)) xitMacCI = ifCI (if os == "darwin" then xit else it) it xdescribe'' :: HasCallStack => String -> SpecWith a -> SpecWith a diff --git a/tests/RemoteTests.hs b/tests/RemoteTests.hs index 6f215a5dc8..51f4324bf0 100644 --- a/tests/RemoteTests.hs +++ b/tests/RemoteTests.hs @@ -2,6 +2,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} module RemoteTests where @@ -15,7 +16,7 @@ import qualified Data.ByteString as B import qualified Data.ByteString.Lazy.Char8 as LB import Data.List (find, isPrefixOf) import qualified Data.Map.Strict as M -import Simplex.Chat.Controller (versionNumber) +import Simplex.Chat.Controller (ChatConfig (..), versionNumber) import qualified Simplex.Chat.Controller as Controller import Simplex.Chat.Mobile.File import Simplex.Chat.Remote (remoteFilesFolder) @@ -31,6 +32,13 @@ import UnliftIO.Directory remoteTests :: SpecWith TestParams remoteTests = describe "Remote" $ do + xdescribe "No compression" $ aroundWith (. ((False, False),)) runRemoteTests + xdescribe "Mobile offers compression" $ aroundWith (. ((True, False),)) runRemoteTests + xdescribe "Desktop offers compression" $ aroundWith (. ((False, True),)) runRemoteTests + describe "With compression" $ aroundWith (. ((True, True),)) runRemoteTests + +runRemoteTests :: SpecWith ((Bool, Bool), TestParams) +runRemoteTests = do describe "protocol handshake" $ do it "connects with new pairing (stops mobile)" $ remoteHandshakeTest False it "connects with new pairing (stops desktop)" $ remoteHandshakeTest True @@ -48,14 +56,14 @@ remoteTests = describe "Remote" $ do -- * Chat commands -remoteHandshakeTest :: HasCallStack => Bool -> TestParams -> IO () -remoteHandshakeTest viaDesktop = testChat2 aliceProfile aliceDesktopProfile $ \mobile desktop -> do +remoteHandshakeTest :: HasCallStack => Bool -> ((Bool, Bool), TestParams) -> IO () +remoteHandshakeTest viaDesktop = testRemote $ \compress mobile desktop -> do desktop ##> "/list remote hosts" desktop <## "No remote hosts" mobile ##> "/list remote ctrls" mobile <## "No remote controllers" - startRemote mobile desktop + startRemote compress mobile desktop desktop ##> "/list remote hosts" desktop <## "Remote hosts:" @@ -77,14 +85,14 @@ remoteHandshakeTest viaDesktop = testChat2 aliceProfile aliceDesktopProfile $ \m mobile ##> "/list remote ctrls" mobile <## "No remote controllers" -remoteHandshakeStoredTest :: HasCallStack => TestParams -> IO () -remoteHandshakeStoredTest = testChat2 aliceProfile aliceDesktopProfile $ \mobile desktop -> do +remoteHandshakeStoredTest :: HasCallStack => ((Bool, Bool), TestParams) -> IO () +remoteHandshakeStoredTest = testRemote $ \compress mobile desktop -> do logNote "Starting new session" - startRemote mobile desktop + startRemote compress mobile desktop stopMobile mobile desktop `catchAny` (logError . tshow) logNote "Starting stored session" - startRemoteStored mobile desktop + startRemoteStored compress mobile desktop stopDesktop mobile desktop `catchAny` (logError . tshow) desktop ##> "/list remote hosts" @@ -95,23 +103,23 @@ remoteHandshakeStoredTest = testChat2 aliceProfile aliceDesktopProfile $ \mobile mobile <## "1. My desktop" logNote "Starting stored session again" - startRemoteStored mobile desktop + startRemoteStored compress mobile desktop stopMobile mobile desktop `catchAny` (logError . tshow) -remoteHandshakeDiscoverTest :: HasCallStack => TestParams -> IO () -remoteHandshakeDiscoverTest = testChat2 aliceProfile aliceDesktopProfile $ \mobile desktop -> do +remoteHandshakeDiscoverTest :: HasCallStack => ((Bool, Bool), TestParams) -> IO () +remoteHandshakeDiscoverTest = testRemote $ \compress mobile desktop -> do logNote "Preparing new session" - startRemote mobile desktop + startRemote compress mobile desktop stopMobile mobile desktop `catchAny` (logError . tshow) logNote "Starting stored session with multicast" - startRemoteDiscover mobile desktop + startRemoteDiscover compress mobile desktop stopMobile mobile desktop `catchAny` (logError . tshow) -remoteHandshakeRejectTest :: HasCallStack => TestParams -> IO () -remoteHandshakeRejectTest = testChat3 aliceProfile aliceDesktopProfile bobProfile $ \mobile desktop mobileBob -> do +remoteHandshakeRejectTest :: HasCallStack => ((Bool, Bool), TestParams) -> IO () +remoteHandshakeRejectTest = testRemote3 $ \compress mobile desktop mobileBob -> do logNote "Starting new session" - startRemote mobile desktop + startRemote compress mobile desktop stopMobile mobile desktop mobileBob ##> "/set device name MobileBob" @@ -135,12 +143,12 @@ remoteHandshakeRejectTest = testChat3 aliceProfile aliceDesktopProfile bobProfil mobile <## "Compare session code with controller and use:" mobile <## ("/verify remote ctrl " <> sessId) mobile ##> ("/verify remote ctrl " <> sessId) - mobile <## "remote controller 1 session started with My desktop" - desktop <## "remote host 1 connected" + mobile <## ("remote controller 1 session started with My desktop" <> compress) + desktop <## ("remote host 1 connected" <> compress) stopMobile mobile desktop -storedBindingsTest :: HasCallStack => TestParams -> IO () -storedBindingsTest = testChat2 aliceProfile aliceDesktopProfile $ \mobile desktop -> do +storedBindingsTest :: HasCallStack => ((Bool, Bool), TestParams) -> IO () +storedBindingsTest = testRemote $ \compress mobile desktop -> do desktop ##> "/set device name My desktop" desktop <## "ok" mobile ##> "/set device name Mobile" @@ -166,9 +174,9 @@ storedBindingsTest = testChat2 aliceProfile aliceDesktopProfile $ \mobile deskto desktop <## "new remote host connecting" mobile <## "new remote controller connected" verifyRemoteCtrl mobile desktop - mobile <## "remote controller 1 session started with My desktop" + mobile <## ("remote controller 1 session started with My desktop" <> compress) desktop <## "new remote host 1 added: Mobile" - desktop <## "remote host 1 connected" + desktop <## ("remote host 1 connected" <> compress) desktop ##> "/list remote hosts" desktop <## "Remote hosts:" @@ -180,9 +188,9 @@ storedBindingsTest = testChat2 aliceProfile aliceDesktopProfile $ \mobile deskto -- TODO: more parser tests -remoteMessageTest :: HasCallStack => TestParams -> IO () -remoteMessageTest = testChat3 aliceProfile aliceDesktopProfile bobProfile $ \mobile desktop bob -> do - startRemote mobile desktop +remoteMessageTest :: HasCallStack => ((Bool, Bool), TestParams) -> IO () +remoteMessageTest = testRemote3 $ \compress mobile desktop bob -> do + startRemote compress mobile desktop contactBob desktop bob logNote "sending messages" @@ -206,9 +214,9 @@ remoteMessageTest = testChat3 aliceProfile aliceDesktopProfile bobProfile $ \mob threadDelay 1000000 logNote "done" -remoteStoreFileTest :: HasCallStack => TestParams -> IO () +remoteStoreFileTest :: HasCallStack => ((Bool, Bool), TestParams) -> IO () remoteStoreFileTest = - testChat3 aliceProfile aliceDesktopProfile bobProfile $ \mobile desktop bob -> + testRemote3 $ \compress mobile desktop bob -> withXFTPServer $ do let mobileFiles = "./tests/tmp/mobile_files" mobile ##> ("/_files_folder " <> mobileFiles) @@ -223,7 +231,7 @@ remoteStoreFileTest = bob ##> ("/_files_folder " <> bobFiles) bob <## "ok" - startRemote mobile desktop + startRemote compress mobile desktop contactBob desktop bob rhs <- readTVarIO (Controller.remoteHostSessions $ chatController desktop) @@ -336,8 +344,8 @@ remoteStoreFileTest = r `shouldStartWith` "remote host 1 error" r `shouldContain` err -remoteCLIFileTest :: HasCallStack => TestParams -> IO () -remoteCLIFileTest = testChat3 aliceProfile aliceDesktopProfile bobProfile $ \mobile desktop bob -> withXFTPServer $ do +remoteCLIFileTest :: HasCallStack => ((Bool, Bool), TestParams) -> IO () +remoteCLIFileTest = testRemote3 $ \compress mobile desktop bob -> withXFTPServer $ do let mobileFiles = "./tests/tmp/mobile_files" mobile ##> ("/_files_folder " <> mobileFiles) mobile <## "ok" @@ -347,7 +355,7 @@ remoteCLIFileTest = testChat3 aliceProfile aliceDesktopProfile bobProfile $ \mob desktop ##> ("/remote_hosts_folder " <> desktopHostFiles) desktop <## "ok" - startRemote mobile desktop + startRemote compress mobile desktop contactBob desktop bob rhs <- readTVarIO (Controller.remoteHostSessions $ chatController desktop) @@ -405,9 +413,9 @@ remoteCLIFileTest = testChat3 aliceProfile aliceDesktopProfile bobProfile $ \mob stopMobile mobile desktop -switchRemoteHostTest :: TestParams -> IO () -switchRemoteHostTest = testChat3 aliceProfile aliceDesktopProfile bobProfile $ \mobile desktop bob -> do - startRemote mobile desktop +switchRemoteHostTest :: HasCallStack => ((Bool, Bool), TestParams) -> IO () +switchRemoteHostTest = testRemote3 $ \compress mobile desktop bob -> do + startRemote compress mobile desktop contactBob desktop bob desktop ##> "/contacts" @@ -431,10 +439,10 @@ switchRemoteHostTest = testChat3 aliceProfile aliceDesktopProfile bobProfile $ \ desktop <## "remote host 1 error: RHEInactive" desktop ##> "/contacts" -indicateRemoteHostTest :: TestParams -> IO () -indicateRemoteHostTest = testChat4 aliceProfile aliceDesktopProfile bobProfile cathProfile $ \mobile desktop bob cath -> do +indicateRemoteHostTest :: HasCallStack => ((Bool, Bool), TestParams) -> IO () +indicateRemoteHostTest = testRemote4 $ \compress mobile desktop bob cath -> do connectUsers desktop cath - startRemote mobile desktop + startRemote compress mobile desktop contactBob desktop bob -- remote contact -> remote host bob #> "@alice hi" @@ -455,8 +463,8 @@ indicateRemoteHostTest = testChat4 aliceProfile aliceDesktopProfile bobProfile c desktop <##> cath cath <##> desktop -multipleProfilesTest :: TestParams -> IO () -multipleProfilesTest = testChat4 aliceProfile aliceDesktopProfile bobProfile cathProfile $ \mobile desktop bob cath -> do +multipleProfilesTest :: HasCallStack => ((Bool, Bool), TestParams) -> IO () +multipleProfilesTest = testRemote4 $ \compress mobile desktop bob cath -> do connectUsers desktop cath desktop ##> "/create user desk_bottom" @@ -466,7 +474,7 @@ multipleProfilesTest = testChat4 aliceProfile aliceDesktopProfile bobProfile cat desktop <## "alice_desktop (Alice Desktop)" desktop <## "desk_bottom (active)" - startRemote mobile desktop + startRemote compress mobile desktop contactBob desktop bob desktop ##> "/users" desktop <## "alice (Alice) (active)" @@ -502,8 +510,28 @@ multipleProfilesTest = testChat4 aliceProfile aliceDesktopProfile bobProfile cat -- * Utils -startRemote :: TestCC -> TestCC -> IO () -startRemote mobile desktop = do +testRemote :: HasCallStack => (String -> TestCC -> TestCC -> IO()) -> ((Bool, Bool), TestParams) -> IO () +testRemote test ((mobileCompression, desktopCompression), ps) = + withNewTestChatCfg ps testCfg {remoteCompression = mobileCompression} "mobile" aliceProfile $ \mobile -> + withNewTestChatCfg ps testCfg {remoteCompression = desktopCompression} "desktop" aliceDesktopProfile $ \desktop -> + let compress = " (" <> (if mobileCompression && desktopCompression then "with" else "no") <> " compression)" + in test compress mobile desktop + + +testRemote3 :: HasCallStack => (String -> TestCC -> TestCC -> TestCC -> IO()) -> ((Bool, Bool), TestParams) -> IO () +testRemote3 test ps = + testRemote + (\compress mobile desktop -> withNewTestChat (snd ps) "bob" bobProfile $ test compress mobile desktop) + ps + +testRemote4 :: HasCallStack => (String -> TestCC -> TestCC -> TestCC -> TestCC -> IO()) -> ((Bool, Bool), TestParams) -> IO () +testRemote4 test ps = + testRemote3 + (\compress mobile desktop bob -> withNewTestChat (snd ps) "cath" cathProfile $ test compress mobile desktop bob) + ps + +startRemote :: String -> TestCC -> TestCC -> IO () +startRemote compress mobile desktop = do desktop ##> "/set device name My desktop" desktop <## "ok" mobile ##> "/set device name Mobile" @@ -518,12 +546,12 @@ startRemote mobile desktop = do desktop <## "new remote host connecting" mobile <## "new remote controller connected" verifyRemoteCtrl mobile desktop - mobile <## "remote controller 1 session started with My desktop" + mobile <## ("remote controller 1 session started with My desktop" <> compress) desktop <## "new remote host 1 added: Mobile" - desktop <## "remote host 1 connected" + desktop <## ("remote host 1 connected" <> compress) -startRemoteStored :: TestCC -> TestCC -> IO () -startRemoteStored mobile desktop = do +startRemoteStored :: String -> TestCC -> TestCC -> IO () +startRemoteStored compress mobile desktop = do desktop ##> "/start remote host 1" desktop <##. "remote host 1 started on " desktop <##. "other addresses: " @@ -534,11 +562,11 @@ startRemoteStored mobile desktop = do desktop <## "remote host 1 connecting" mobile <## "remote controller 1 connected" verifyRemoteCtrl mobile desktop - mobile <## "remote controller 1 session started with My desktop" - desktop <## "remote host 1 connected" + mobile <## ("remote controller 1 session started with My desktop" <> compress) + desktop <## ("remote host 1 connected" <> compress) -startRemoteDiscover :: TestCC -> TestCC -> IO () -startRemoteDiscover mobile desktop = do +startRemoteDiscover :: String -> TestCC -> TestCC -> IO () +startRemoteDiscover compress mobile desktop = do desktop ##> "/start remote host 1 multicast=on" desktop <##. "remote host 1 started on " desktop <##. "other addresses: " @@ -554,8 +582,8 @@ startRemoteDiscover mobile desktop = do desktop <## "remote host 1 connecting" mobile <## "remote controller 1 connected" verifyRemoteCtrl mobile desktop - mobile <## "remote controller 1 session started with My desktop" - desktop <## "remote host 1 connected" + mobile <## ("remote controller 1 session started with My desktop" <> compress) + desktop <## ("remote host 1 connected" <> compress) verifyRemoteCtrl :: TestCC -> TestCC -> IO () verifyRemoteCtrl mobile desktop = do diff --git a/tests/Test.hs b/tests/Test.hs index e1a5a58c7d..639708441e 100644 --- a/tests/Test.hs +++ b/tests/Test.hs @@ -55,7 +55,9 @@ main = do "src/Simplex/Chat/Store/Postgres/Migrations/chat_schema.sql" #else describe "Schema dump" schemaDumpTest +#if MIN_VERSION_base(4,18,0) describe "Bot API docs" apiDocsTest +#endif around tmpBracket $ describe "WebRTC encryption" webRTCTests #endif describe "SimpleX chat markdown" markdownTests