diff --git a/package.yaml b/package.yaml index 49dc27c0c..0eaa36d79 100644 --- a/package.yaml +++ b/package.yaml @@ -85,6 +85,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 e407279ce..49b278e14 100644 --- a/src/Simplex/FileTransfer/Client.hs +++ b/src/Simplex/FileTransfer/Client.hs @@ -50,7 +50,7 @@ import Simplex.Messaging.Protocol RecipientId, SenderId, ) -import Simplex.Messaging.Transport (ALPN, HandshakeError (VERSION), 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 @@ -96,6 +96,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 tcConfig = (transportClientConfig xftpNetworkConfig) {alpn = clientALPN} @@ -112,8 +118,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 (TEHandshake VERSION) + _ -> pure thParams0 logDebug $ "Client negotiated protocol: " <> tshow thVersion let c = XFTPClient {http2Client, thParams, transportSession, config} atomically $ writeTVar clientVar $ Just c @@ -130,15 +135,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 (VersionXFTP, C.PublicKeyX25519) processServerHandshake XFTPServerHandshake {xftpVersionRange, sessionId = serverSessId, authPubKey = serverAuth} = do - unless (sessionId == serverSessId) $ throwError $ PCEResponseError SESSION + unless (sessionId == serverSessId) $ throwError $ PCETransportError TEBadSession case xftpVersionRange `compatibleVersion` serverVRange of - Nothing -> throwError $ PCEResponseError HANDSHAKE + Nothing -> throwError $ PCETransportError (TEHandshake VERSION) Just (Compatible v) -> - fmap (v,) . liftHS $ do + fmap (v,) . 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 () @@ -147,11 +152,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 7b6787a43..6b9c81a26 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 (isCompatible) 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) @@ -136,6 +140,9 @@ xftpServer cfg@XFTPServerConfig {xftpPort, transportConfig, inactiveClientExpira let authPubKey = (chain, C.signX509 serverSignKey $ C.publicToX509 k) let hs = XFTPServerHandshake {xftpVersionRange = supportedFileServerVRange, sessionId, authPubKey} shs <- encodeXftp hs +#ifdef slow_servers + lift randomDelay +#endif liftIO . sendResponse $ H.responseBuilder N.ok200 [] shs pure Nothing processClientHandshake pk = do @@ -147,6 +154,9 @@ xftpServer cfg@XFTPServerConfig {xftpPort, transportConfig, inactiveClientExpira unless (xftpVersion `isCompatible` supportedFileServerVRange) $ throwError HANDSHAKE let auth = THAuthServer {serverPrivKey = pk, sessSecret' = Nothing} atomically $ TM.insert sessionId (HandshakeAccepted auth xftpVersion) sessions +#ifdef slow_servers + lift randomDelay +#endif liftIO . sendResponse $ H.responseNoBody N.ok200 [] pure Nothing sendError :: XFTPErrorType -> M (Maybe (THandleParams XFTPVersion 'TServer)) @@ -310,6 +320,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 @@ -324,6 +337,15 @@ processRequest XFTPTransportRequest {thParams, reqBody = body@HTTP2Body {bodyHea withFile filePath ReadMode $ \h -> sendEncFile h send sbState (fromIntegral 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 414bfb4c4..76cafcad4 100644 --- a/src/Simplex/FileTransfer/Server/Env.hs +++ b/src/Simplex/FileTransfer/Server/Env.hs @@ -66,7 +66,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 d53b3f4fa..271259451 100644 --- a/src/Simplex/FileTransfer/Server/Main.hs +++ b/src/Simplex/FileTransfer/Server/Main.hs @@ -182,7 +182,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/tests/XFTPAgent.hs b/tests/XFTPAgent.hs index 88786bb40..2deb1c655 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 5f38cc639..a3ee9dd1f 100644 --- a/tests/XFTPClient.hs +++ b/tests/XFTPClient.hs @@ -122,7 +122,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