agent: support different timeouts for interactive and background requests (#1582)

* agent: support different timeouts for interactive and background requests

* fix tests

* use one constructor for the first request and for retries

Author: epoberezkin

src/Simplex/FileTransfer/Client.hs

@@ -36,8 +36,10 @@ import Simplex.FileTransfer.Protocol
 import Simplex.FileTransfer.Transport
 import Simplex.Messaging.Client
   ( NetworkConfig (..),
+    NetworkRequestMode (..),
     ProtocolClientError (..),
     TransportSession,
+    netTimeoutInt,
     chooseTransportHost,
     defaultNetworkConfig,
     transportClientConfig,
@@ -107,7 +109,7 @@ getXFTPClient transportSession@(_, srv, _) config@XFTPClientConfig {clientALPN,
   let socksCreds = clientSocksCredentials xftpNetworkConfig proxySessTs transportSession
       ProtocolServer _ host port keyHash = srv
   useHost <- liftEither $ chooseTransportHost xftpNetworkConfig host
-  let tcConfig = transportClientConfig xftpNetworkConfig useHost False clientALPN
+  let tcConfig = transportClientConfig xftpNetworkConfig NRMBackground useHost False clientALPN
       http2Config = xftpHTTP2Config tcConfig config
   clientVar <- newTVarIO Nothing
   let usePort = if null port then "443" else port
@@ -178,7 +180,7 @@ xftpHTTP2Config transportConfig XFTPClientConfig {xftpNetworkConfig = NetworkCon
   defaultHTTP2ClientConfig
     { bodyHeadSize = xftpBlockSize,
       suportedTLSParams = defaultSupportedParams,
-      connTimeout = tcpConnectTimeout,
+      connTimeout = netTimeoutInt tcpConnectTimeout NRMBackground,
       transportConfig
     }
 
@@ -268,11 +270,11 @@ downloadXFTPChunk g c@XFTPClient {config} rpKey fId chunkSpec@XFTPRcvChunkSpec {
 
 xftpReqTimeout :: XFTPClientConfig -> Maybe Word32 -> Int
 xftpReqTimeout cfg@XFTPClientConfig {xftpNetworkConfig = NetworkConfig {tcpTimeout}} chunkSize_ =
-  maybe tcpTimeout (chunkTimeout cfg) chunkSize_
+  maybe (netTimeoutInt tcpTimeout NRMBackground) (chunkTimeout cfg) chunkSize_
 
 chunkTimeout :: XFTPClientConfig -> Word32 -> Int
 chunkTimeout XFTPClientConfig {xftpNetworkConfig = NetworkConfig {tcpTimeout, tcpTimeoutPerKb}} sz =
-  tcpTimeout + fromIntegral (min ((fromIntegral sz `div` 1024) * tcpTimeoutPerKb) (fromIntegral (maxBound :: Int)))
+  netTimeoutInt tcpTimeout NRMBackground + fromIntegral (min ((fromIntegral sz `div` 1024) * tcpTimeoutPerKb) (fromIntegral (maxBound :: Int)))
 
 deleteXFTPChunk :: XFTPClient -> C.APrivateAuthKey -> SenderId -> ExceptT XFTPClientError IO ()
 deleteXFTPChunk c spKey sId = sendXFTPCommand c spKey sId FDEL Nothing >>= okResponse

src/Simplex/FileTransfer/Client/Agent.hs

@@ -19,7 +19,7 @@ import Data.Text.Encoding (decodeUtf8)
 import Data.Time.Clock (UTCTime, getCurrentTime)
 import Simplex.FileTransfer.Client
 import Simplex.Messaging.Agent.RetryInterval
-import Simplex.Messaging.Client (NetworkConfig (..), ProtocolClientError (..), temporaryClientError)
+import Simplex.Messaging.Client (NetworkConfig (..), NetworkRequestMode (..), ProtocolClientError (..), netTimeoutInt, temporaryClientError)
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Protocol (ProtocolServer (..), XFTPServer)
 import Simplex.Messaging.TMap (TMap)
@@ -90,7 +90,7 @@ getXFTPServerClient XFTPClientAgent {xftpClients, startedAt, config} srv = do
     waitForXFTPClient :: XFTPClientVar -> ME XFTPClient
     waitForXFTPClient clientVar = do
       let XFTPClientConfig {xftpNetworkConfig = NetworkConfig {tcpConnectTimeout}} = xftpConfig config
-      client_ <- liftIO $ tcpConnectTimeout `timeout` atomically (readTMVar clientVar)
+      client_ <- liftIO $ netTimeoutInt tcpConnectTimeout NRMBackground `timeout` atomically (readTMVar clientVar)
       liftEither $ case client_ of
         Just (Right c) -> Right c
         Just (Left e) -> Left e
@@ -127,6 +127,6 @@ closeXFTPServerClient XFTPClientAgent {xftpClients, config} srv =
   where
     closeClient cVar = do
       let NetworkConfig {tcpConnectTimeout} = xftpNetworkConfig $ xftpConfig config
-      tcpConnectTimeout `timeout` atomically (readTMVar cVar) >>= \case
+      netTimeoutInt tcpConnectTimeout NRMBackground `timeout` atomically (readTMVar cVar) >>= \case
         Just (Right client) -> closeXFTPClient client `catchAll_` pure ()
         _ -> pure ()

src/Simplex/Messaging/Agent.hs

@@ -45,6 +45,7 @@ import Simplex.Messaging.Agent.Stats
 import Simplex.Messaging.Agent.Store
 import Simplex.Messaging.Agent.Store.AgentStore
 import qualified Simplex.Messaging.Agent.Store.DB as DB
+import Simplex.Messaging.Client (NetworkRequestMode (..))
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Notifications.Protocol
 import Simplex.Messaging.Notifications.Types
@@ -572,7 +573,7 @@ runNtfTknDelWorker c srv Worker {doWork} =
           notifyInternalError' c (show e)
     processTknToDelete :: NtfTokenToDelete -> AM ()
     processTknToDelete (tknDbId, ntfPrivKey, tknId) = do
-      agentNtfDeleteToken c srv ntfPrivKey tknId
+      agentNtfDeleteToken c NRMBackground srv ntfPrivKey tknId
       withStore' c $ \db -> deleteNtfTokenToDelete db tknDbId
 
 closeNtfSupervisor :: NtfSupervisor -> IO ()