From d12ea9205537a570f369fc493ce3e7891511f623 Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin Date: Fri, 31 May 2024 09:47:47 +0100 Subject: [PATCH] agent: report correct errors from xftp handshake so they are treated as temporary (#1184) * agent: report correct errors from xftp handshake so they are treated as temporary * disable slow servers test * remove comments * all tests * remove duplicate functions --- package.yaml | 3 +++ src/Simplex/FileTransfer/Client.hs | 27 +++++++++++++++---------- src/Simplex/FileTransfer/Server.hs | 22 ++++++++++++++++++++ src/Simplex/FileTransfer/Server/Env.hs | 3 ++- src/Simplex/FileTransfer/Server/Main.hs | 3 ++- src/Simplex/Messaging/Agent.hs | 7 ------- tests/XFTPAgent.hs | 8 ++++++-- tests/XFTPClient.hs | 3 ++- 8 files changed, 53 insertions(+), 23 deletions(-) diff --git a/package.yaml b/package.yaml index 6bdb03e4d..7b9486ff4 100644 --- a/package.yaml +++ b/package.yaml @@ -87,6 +87,9 @@ flags: manual: True default: True +# cpp-options: +# - -Dslow_servers + when: - condition: flag(swift) cpp-options: diff --git a/src/Simplex/FileTransfer/Client.hs b/src/Simplex/FileTransfer/Client.hs index ff7742e67..2454a1d57 100644 --- a/src/Simplex/FileTransfer/Client.hs +++ b/src/Simplex/FileTransfer/Client.hs @@ -52,7 +52,7 @@ import Simplex.Messaging.Protocol RecipientId, SenderId, ) -import Simplex.Messaging.Transport (ALPN, THandleAuth (..), THandleParams (..), TransportError (..), TransportPeer (..), supportedParameters) +import Simplex.Messaging.Transport (ALPN, HandshakeError (..), THandleAuth (..), THandleParams (..), TransportError (..), TransportPeer (..), supportedParameters) import Simplex.Messaging.Transport.Client (TransportClientConfig, TransportHost, alpn) import Simplex.Messaging.Transport.HTTP2 import Simplex.Messaging.Transport.HTTP2.Client @@ -98,6 +98,12 @@ defaultXFTPClientConfig = clientALPN = Just supportedXFTPhandshakes } +http2XFTPClientError :: HTTP2ClientError -> XFTPClientError +http2XFTPClientError = \case + HCResponseTimeout -> PCEResponseTimeout + HCNetworkError -> PCENetworkError + HCIOError e -> PCEIOError e + getXFTPClient :: TransportSession FileResponse -> XFTPClientConfig -> (XFTPClient -> IO ()) -> IO (Either XFTPClientError XFTPClient) getXFTPClient transportSession@(_, srv, _) config@XFTPClientConfig {clientALPN, xftpNetworkConfig, serverVRange} disconnected = runExceptT $ do let username = proxyUsername transportSession @@ -116,8 +122,7 @@ getXFTPClient transportSession@(_, srv, _) config@XFTPClientConfig {clientALPN, logDebug $ "Client negotiated handshake protocol: " <> tshow sessionALPN thParams@THandleParams {thVersion} <- case sessionALPN of Just "xftp/1" -> xftpClientHandshakeV1 serverVRange keyHash http2Client thParams0 - Nothing -> pure thParams0 - _ -> throwError $ PCETransportError TEVersion + _ -> pure thParams0 logDebug $ "Client negotiated protocol: " <> tshow thVersion let c = XFTPClient {http2Client, thParams, transportSession, config} atomically $ writeTVar clientVar $ Just c @@ -135,15 +140,15 @@ xftpClientHandshakeV1 serverVRange keyHash@(C.KeyHash kh) c@HTTP2Client {session getServerHandshake = do let helloReq = H.requestNoBody "POST" "/" [] HTTP2Response {respBody = HTTP2Body {bodyHead = shsBody}} <- - liftError' (const $ PCEResponseError HANDSHAKE) $ sendRequest c helloReq Nothing - liftHS . smpDecode =<< liftHS (C.unPad shsBody) + liftError' http2XFTPClientError $ sendRequest c helloReq Nothing + liftTransportErr (TEHandshake PARSE) . smpDecode =<< liftTransportErr TEBadBlock (C.unPad shsBody) processServerHandshake :: XFTPServerHandshake -> ExceptT XFTPClientError IO (VersionRangeXFTP, C.PublicKeyX25519) processServerHandshake XFTPServerHandshake {xftpVersionRange, sessionId = serverSessId, authPubKey = serverAuth} = do - unless (sessionId == serverSessId) $ throwError $ PCEResponseError SESSION + unless (sessionId == serverSessId) $ throwError $ PCETransportError TEBadSession case xftpVersionRange `compatibleVRange` serverVRange of Nothing -> throwError $ PCETransportError TEVersion Just (Compatible vr) -> - fmap (vr,) . liftHS $ do + fmap (vr,) . liftTransportErr (TEHandshake BAD_AUTH) $ do let (X.CertificateChain cert, exact) = serverAuth case cert of [_leaf, ca] | XV.Fingerprint kh == XV.getFingerprint ca X.HashSHA256 -> pure () @@ -152,11 +157,11 @@ xftpClientHandshakeV1 serverVRange keyHash@(C.KeyHash kh) c@HTTP2Client {session C.x509ToPublic (pubKey, []) >>= C.pubKey sendClientHandshake :: XFTPClientHandshake -> ExceptT XFTPClientError IO () sendClientHandshake chs = do - chs' <- liftHS $ C.pad (smpEncode chs) xftpBlockSize + chs' <- liftTransportErr TELargeMsg $ C.pad (smpEncode chs) xftpBlockSize let chsReq = H.requestBuilder "POST" "/" [] $ byteString chs' - HTTP2Response {respBody = HTTP2Body {bodyHead}} <- liftError' (const $ PCEResponseError HANDSHAKE) $ sendRequest c chsReq Nothing - unless (B.null bodyHead) $ throwError $ PCEResponseError HANDSHAKE - liftHS = liftEitherWith (const $ PCEResponseError HANDSHAKE) + HTTP2Response {respBody = HTTP2Body {bodyHead}} <- liftError' http2XFTPClientError $ sendRequest c chsReq Nothing + unless (B.null bodyHead) $ throwError $ PCETransportError TEBadBlock + liftTransportErr e = liftEitherWith (const $ PCETransportError e) closeXFTPClient :: XFTPClient -> IO () closeXFTPClient XFTPClient {http2Client} = closeHTTP2Client http2Client diff --git a/src/Simplex/FileTransfer/Server.hs b/src/Simplex/FileTransfer/Server.hs index ea18b4fdc..7eb65ced2 100644 --- a/src/Simplex/FileTransfer/Server.hs +++ b/src/Simplex/FileTransfer/Server.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} @@ -67,6 +68,9 @@ import Simplex.Messaging.Version import System.Exit (exitFailure) import System.FilePath (()) import System.IO (hPrint, hPutStrLn, universalNewlineMode) +#ifdef slow_servers +import System.Random (getStdRandom, randomR) +#endif import UnliftIO import UnliftIO.Concurrent (threadDelay) import UnliftIO.Directory (doesFileExist, removeFile, renameFile) @@ -138,6 +142,9 @@ xftpServer cfg@XFTPServerConfig {xftpPort, transportConfig, inactiveClientExpira let authPubKey = (chain, C.signX509 serverSignKey $ C.publicToX509 k) let hs = XFTPServerHandshake {xftpVersionRange = xftpServerVRange, sessionId, authPubKey} shs <- encodeXftp hs +#ifdef slow_servers + lift randomDelay +#endif liftIO . sendResponse $ H.responseBuilder N.ok200 [] shs pure Nothing processClientHandshake pk = do @@ -151,6 +158,9 @@ xftpServer cfg@XFTPServerConfig {xftpPort, transportConfig, inactiveClientExpira let auth = THAuthServer {serverPrivKey = pk, sessSecret' = Nothing} thParams = thParams0 {thAuth = Just auth, thVersion = v, thServerVRange = vr} atomically $ TM.insert sessionId (HandshakeAccepted thParams) sessions +#ifdef slow_servers + lift randomDelay +#endif liftIO . sendResponse $ H.responseNoBody N.ok200 [] pure Nothing Nothing -> throwError HANDSHAKE @@ -315,6 +325,9 @@ processRequest XFTPTransportRequest {thParams, reqBody = body@HTTP2Body {bodyHea where sendXFTPResponse (corrId, fId, resp) serverFile_ = do let t_ = xftpEncodeTransmission thParams (corrId, fId, resp) +#ifdef slow_servers + randomDelay +#endif liftIO $ sendResponse $ H.responseStreaming N.ok200 [] $ streamBody t_ where streamBody t_ send done = do @@ -329,6 +342,15 @@ processRequest XFTPTransportRequest {thParams, reqBody = body@HTTP2Body {bodyHea withFile filePath ReadMode $ \h -> sendEncFile h send sbState fileSize done +#ifdef slow_servers +randomDelay :: M () +randomDelay = do + d <- asks $ responseDelay . config + when (d > 0) $ do + pc <- getStdRandom (randomR (-200, 200)) + threadDelay $ (d * (1000 + pc)) `div` 1000 +#endif + data VerificationResult = VRVerified XFTPRequest | VRFailed verifyXFTPTransmission :: Maybe (THandleAuth 'TServer, C.CbNonce) -> Maybe TransmissionAuth -> ByteString -> XFTPFileId -> FileCmd -> M VerificationResult diff --git a/src/Simplex/FileTransfer/Server/Env.hs b/src/Simplex/FileTransfer/Server/Env.hs index 58c1393f3..f8a6bc996 100644 --- a/src/Simplex/FileTransfer/Server/Env.hs +++ b/src/Simplex/FileTransfer/Server/Env.hs @@ -69,7 +69,8 @@ data XFTPServerConfig = XFTPServerConfig logStatsStartTime :: Int64, serverStatsLogFile :: FilePath, serverStatsBackupFile :: Maybe FilePath, - transportConfig :: TransportServerConfig + transportConfig :: TransportServerConfig, + responseDelay :: Int } defaultInactiveClientExpiration :: ExpirationConfig diff --git a/src/Simplex/FileTransfer/Server/Main.hs b/src/Simplex/FileTransfer/Server/Main.hs index ee9a52d34..d31295cd2 100644 --- a/src/Simplex/FileTransfer/Server/Main.hs +++ b/src/Simplex/FileTransfer/Server/Main.hs @@ -185,7 +185,8 @@ xftpServerCLI cfgPath logPath = do defaultTransportServerConfig { logTLSErrors = fromMaybe False $ iniOnOff "TRANSPORT" "log_tls_errors" ini, alpn = Just supportedXFTPhandshakes - } + }, + responseDelay = 0 } data CliCommand diff --git a/src/Simplex/Messaging/Agent.hs b/src/Simplex/Messaging/Agent.hs index 073660ba0..8e9020b7d 100644 --- a/src/Simplex/Messaging/Agent.hs +++ b/src/Simplex/Messaging/Agent.hs @@ -83,8 +83,6 @@ module Simplex.Messaging.Agent testProtocolServer, setNtfServers, setNetworkConfig, - getNetworkConfig, - getNetworkConfig', setUserNetworkInfo, reconnectAllServers, registerNtfToken, @@ -434,11 +432,6 @@ setNetworkConfig c@AgentClient {useNetworkConfig} cfg' = do else True <$ (writeTVar useNetworkConfig $! (slowNetworkConfig cfg', cfg')) when changed $ reconnectAllServers c --- returns fast network config -getNetworkConfig :: AgentClient -> IO NetworkConfig -getNetworkConfig = getNetworkConfig' -{-# INLINE getNetworkConfig #-} - setUserNetworkInfo :: AgentClient -> UserNetworkInfo -> IO () setUserNetworkInfo c@AgentClient {userNetworkInfo, userNetworkUpdated} ni = withAgentEnv' c $ do ts' <- liftIO getCurrentTime diff --git a/tests/XFTPAgent.hs b/tests/XFTPAgent.hs index 4685d4815..e4cf3d704 100644 --- a/tests/XFTPAgent.hs +++ b/tests/XFTPAgent.hs @@ -46,7 +46,11 @@ import XFTPClient xftpAgentTests :: Spec xftpAgentTests = around_ testBracket . describe "agent XFTP API" $ do - it "should send and receive file" testXFTPAgentSendReceive + it "should send and receive file" $ withXFTPServer testXFTPAgentSendReceive + -- uncomment CPP option slow_servers and run hpack to run this test + xit "should send and receive file with slow server responses" $ + withXFTPServerCfg testXFTPServerConfig {responseDelay = 500000} $ + \_ -> testXFTPAgentSendReceive it "should send and receive with encrypted local files" testXFTPAgentSendReceiveEncrypted it "should send and receive large file with a redirect" testXFTPAgentSendReceiveRedirect it "should send and receive small file without a redirect" testXFTPAgentSendReceiveNoRedirect @@ -100,7 +104,7 @@ checkProgress (prev, expected) (progress, total) loop | otherwise = pure () testXFTPAgentSendReceive :: HasCallStack => IO () -testXFTPAgentSendReceive = withXFTPServer $ do +testXFTPAgentSendReceive = do filePath <- createRandomFile -- send file, delete snd file internally (rfd1, rfd2) <- withAgent 1 agentCfg initAgentServers testDB $ \sndr -> runRight $ do diff --git a/tests/XFTPClient.hs b/tests/XFTPClient.hs index 0152625a8..208b54dc5 100644 --- a/tests/XFTPClient.hs +++ b/tests/XFTPClient.hs @@ -124,7 +124,8 @@ testXFTPServerConfig_ alpn = logStatsStartTime = 0, serverStatsLogFile = "tests/tmp/xftp-server-stats.daily.log", serverStatsBackupFile = Nothing, - transportConfig = defaultTransportServerConfig {alpn} + transportConfig = defaultTransportServerConfig {alpn}, + responseDelay = 0 } testXFTPClientConfig :: XFTPClientConfig