dandri/simplexmq
1
0
Fork 0
mirror of https://github.com/simplex-chat/simplexmq.git synced 2026-09-17 10:15:51 +00:00
Code Issues Packages Projects Releases Wiki Activity

wait for user network availability (#1085)

Browse Source 
* ghc-options

* wait for user network availability

* test

* update

* comment

* refactor

* slow config

* line

* waitForUserNetwork in xftp and ntf workers

* refactor

* refactor with registerDelay

---------

Co-authored-by: spaced4ndy <8711996+spaced4ndy@users.noreply.github.com>
This commit is contained in:
Evgeny Poberezkin
2024-04-10 21:50:05 +01:00
committed by GitHub
co-authored by spaced4ndy
parent 91cf6841e0
commit 8fa9ed6317
9 changed files with 188 additions and 42 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Simplex/FileTransfer/Agent.hs
+8 -4
View File
@@ -179,7 +179,8 @@ runXFTPRcvWorker c srv Worker {doWork} = do
RcvFileChunk {rcvFileId, rcvFileEntityId, fileTmpPath, replicas = []} -> rcvWorkerInternalError c rcvFileId rcvFileEntityId (Just fileTmpPath) "chunk has no replicas"
fc@RcvFileChunk {userId, rcvFileId, rcvFileEntityId, digest, fileTmpPath, replicas = replica@RcvFileChunkReplica {rcvChunkReplicaId, server, delay} : _} -> do
let ri' = maybe ri (\d -> ri {initialInterval = d, increaseAfter = 0}) delay
withRetryIntervalLimit xftpConsecutiveRetries ri' $ \delay' loop ->
withRetryIntervalLimit xftpConsecutiveRetries ri' $ \delay' loop -> do
lift $ waitForUserNetwork c
downloadFileChunk fc replica
`catchAgentError` \e -> retryOnError "XFTP rcv worker" (retryLoop loop e delay') (retryDone e) e
where
@@ -422,7 +423,8 @@ runXFTPSndPrepareWorker c Worker {doWork} = do
where
tryCreate = do
usedSrvs <- newTVarIO ([] :: [XFTPServer])
withRetryInterval (riFast ri) $ \_ loop ->
withRetryInterval (riFast ri) $ \_ loop -> do
lift $ waitForUserNetwork c
createWithNextSrv usedSrvs
`catchAgentError` \e -> retryOnError "XFTP prepare worker" (retryLoop loop) (throwError e) e
where
@@ -454,7 +456,8 @@ runXFTPSndWorker c srv Worker {doWork} = do
SndFileChunk {sndFileId, sndFileEntityId, filePrefixPath, replicas = []} -> sndWorkerInternalError c sndFileId sndFileEntityId (Just filePrefixPath) "chunk has no replicas"
fc@SndFileChunk {userId, sndFileId, sndFileEntityId, filePrefixPath, digest, replicas = replica@SndFileChunkReplica {sndChunkReplicaId, server, delay} : _} -> do
let ri' = maybe ri (\d -> ri {initialInterval = d, increaseAfter = 0}) delay
withRetryIntervalLimit xftpConsecutiveRetries ri' $ \delay' loop ->
withRetryIntervalLimit xftpConsecutiveRetries ri' $ \delay' loop -> do
lift $ waitForUserNetwork c
uploadFileChunk cfg fc replica
`catchAgentError` \e -> retryOnError "XFTP snd worker" (retryLoop loop e delay') (retryDone e) e
where
@@ -620,7 +623,8 @@ runXFTPDelWorker c srv Worker {doWork} = do
where
processDeletedReplica replica@DeletedSndChunkReplica {deletedSndChunkReplicaId, userId, server, chunkDigest, delay} = do
let ri' = maybe ri (\d -> ri {initialInterval = d, increaseAfter = 0}) delay
withRetryIntervalLimit xftpConsecutiveRetries ri' $ \delay' loop ->
withRetryIntervalLimit xftpConsecutiveRetries ri' $ \delay' loop -> do
lift $ waitForUserNetwork c
deleteChunkReplica
`catchAgentError` \e -> retryOnError "XFTP del worker" (retryLoop loop e delay') (retryDone e) e
where
src/Simplex/FileTransfer/Client.hs
+8 -6
View File
@@ -27,7 +27,6 @@ import qualified Data.X509 as X
import qualified Data.X509.Validation as XV
import qualified Network.HTTP.Types as N
import qualified Network.HTTP2.Client as H
import Simplex.FileTransfer.Description (mb)
import Simplex.FileTransfer.Protocol
import Simplex.FileTransfer.Transport
import Simplex.Messaging.Client
@@ -70,7 +69,6 @@ data XFTPClient = XFTPClient
data XFTPClientConfig = XFTPClientConfig
{ xftpNetworkConfig :: NetworkConfig,
uploadTimeoutPerMb :: Int64,
serverVRange :: VersionRangeXFTP
}
@@ -93,7 +91,6 @@ defaultXFTPClientConfig :: XFTPClientConfig
defaultXFTPClientConfig =
XFTPClientConfig
{ xftpNetworkConfig = defaultNetworkConfig,
uploadTimeoutPerMb = 10000000, -- 10 seconds
serverVRange = supportedFileServerVRange
}
@@ -190,8 +187,8 @@ sendXFTPCommand c@XFTPClient {thParams} pKey fId cmd chunkSpec_ = do
sendXFTPTransmission :: XFTPClient -> ByteString -> Maybe XFTPChunkSpec -> ExceptT XFTPClientError IO (FileResponse, HTTP2Body)
sendXFTPTransmission XFTPClient {config, thParams, http2Client} t chunkSpec_ = do
let req = H.requestStreaming N.methodPost "/" [] streamBody
reqTimeout = (\XFTPChunkSpec {chunkSize} -> chunkTimeout config chunkSize) <$> chunkSpec_
HTTP2Response {respBody = body@HTTP2Body {bodyHead}} <- withExceptT xftpClientError . ExceptT $ sendRequest http2Client req reqTimeout
reqTimeout = xftpReqTimeout config $ (\XFTPChunkSpec {chunkSize} -> chunkSize) <$> chunkSpec_
HTTP2Response {respBody = body@HTTP2Body {bodyHead}} <- withExceptT xftpClientError . ExceptT $ sendRequest http2Client req (Just reqTimeout)
when (B.length bodyHead /= xftpBlockSize) $ throwError $ PCEResponseError BLOCK
-- TODO validate that the file ID is the same as in the request?
(_, _, (_, _fId, respOrErr)) <- liftEither . first PCEResponseError $ xftpDecodeTransmission thParams bodyHead
@@ -251,8 +248,13 @@ downloadXFTPChunk g c@XFTPClient {config} rpKey fId chunkSpec@XFTPRcvChunkSpec {
_ -> throwError $ PCEResponseError NO_FILE
(r, _) -> throwError . PCEUnexpectedResponse $ bshow r
xftpReqTimeout :: XFTPClientConfig -> Maybe Word32 -> Int
xftpReqTimeout cfg@XFTPClientConfig {xftpNetworkConfig = NetworkConfig {tcpTimeout}} chunkSize_ =
maybe tcpTimeout (chunkTimeout cfg) chunkSize_
chunkTimeout :: XFTPClientConfig -> Word32 -> Int
chunkTimeout config chunkSize = fromIntegral $ (fromIntegral chunkSize * uploadTimeoutPerMb config) `div` mb 1
chunkTimeout XFTPClientConfig {xftpNetworkConfig = NetworkConfig {tcpTimeout, tcpTimeoutPerKb}} sz =
tcpTimeout + 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