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

@@ -85,6 +85,9 @@ flags:
     manual: True
     default: True
 
+# cpp-options:
+#   - -Dslow_servers
+
 when:
   - condition: flag(swift)
     cpp-options:

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

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

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

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

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

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