@@ -63,6 +63,7 @@ import Simplex.Messaging.Agent.Client
63
63
import Simplex.Messaging.Agent.Env.SQLite
64
64
import Simplex.Messaging.Agent.Protocol
65
65
import Simplex.Messaging.Agent.RetryInterval
66
+ import Simplex.Messaging.Agent.Stats
66
67
import Simplex.Messaging.Agent.Store.SQLite
67
68
import qualified Simplex.Messaging.Agent.Store.SQLite.DB as DB
68
69
import qualified Simplex.Messaging.Crypto as C
@@ -184,6 +185,7 @@ runXFTPRcvWorker c srv Worker {doWork} = do
184
185
let ri' = maybe ri (\ d -> ri {initialInterval = d, increaseAfter = 0 }) delay
185
186
withRetryIntervalLimit xftpConsecutiveRetries ri' $ \ delay' loop -> do
186
187
liftIO $ waitForUserNetwork c
188
+ atomically $ incXFTPServerStat c userId srv downloadAttempts
187
189
downloadFileChunk fc replica approvedRelays
188
190
`catchAgentError` \ e -> retryOnError " XFTP rcv worker" (retryLoop loop e delay') (retryDone e) e
189
191
where
@@ -194,7 +196,11 @@ runXFTPRcvWorker c srv Worker {doWork} = do
194
196
withStore' c $ \ db -> updateRcvChunkReplicaDelay db rcvChunkReplicaId replicaDelay
195
197
atomically $ assertAgentForeground c
196
198
loop
197
- retryDone = rcvWorkerInternalError c rcvFileId rcvFileEntityId (Just fileTmpPath)
199
+ retryDone e = do
200
+ atomically . incXFTPServerStat c userId srv $ case e of
201
+ XFTP _ XFTP. AUTH -> downloadAuthErrs
202
+ _ -> downloadErrs
203
+ rcvWorkerInternalError c rcvFileId rcvFileEntityId (Just fileTmpPath) e
198
204
downloadFileChunk :: RcvFileChunk -> RcvFileChunkReplica -> Bool -> AM ()
199
205
downloadFileChunk RcvFileChunk {userId, rcvFileId, rcvFileEntityId, rcvChunkId, chunkNo, chunkSize, digest, fileTmpPath} replica approvedRelays = do
200
206
unlessM ((approvedRelays || ) <$> ipAddressProtected') $ throwE $ FILE NOT_APPROVED
@@ -214,6 +220,7 @@ runXFTPRcvWorker c srv Worker {doWork} = do
214
220
Just RcvFileRedirect {redirectFileInfo = RedirectFileInfo {size = FileSize finalSize}, redirectEntityId} -> (redirectEntityId, finalSize)
215
221
liftIO . when complete $ updateRcvFileStatus db rcvFileId RFSReceived
216
222
pure (entityId, complete, RFPROG rcvd total)
223
+ atomically $ incXFTPServerStat c userId srv downloads
217
224
notify c entityId progress
218
225
when complete . lift . void $
219
226
getXFTPRcvWorker True c Nothing
@@ -484,6 +491,7 @@ runXFTPSndWorker c srv Worker {doWork} = do
484
491
let ri' = maybe ri (\ d -> ri {initialInterval = d, increaseAfter = 0 }) delay
485
492
withRetryIntervalLimit xftpConsecutiveRetries ri' $ \ delay' loop -> do
486
493
liftIO $ waitForUserNetwork c
494
+ atomically $ incXFTPServerStat c userId srv uploadAttempts
487
495
uploadFileChunk cfg fc replica
488
496
`catchAgentError` \ e -> retryOnError " XFTP snd worker" (retryLoop loop e delay') (retryDone e) e
489
497
where
@@ -494,7 +502,9 @@ runXFTPSndWorker c srv Worker {doWork} = do
494
502
withStore' c $ \ db -> updateSndChunkReplicaDelay db sndChunkReplicaId replicaDelay
495
503
atomically $ assertAgentForeground c
496
504
loop
497
- retryDone = sndWorkerInternalError c sndFileId sndFileEntityId (Just filePrefixPath)
505
+ retryDone e = do
506
+ atomically $ incXFTPServerStat c userId srv uploadErrs
507
+ sndWorkerInternalError c sndFileId sndFileEntityId (Just filePrefixPath) e
498
508
uploadFileChunk :: AgentConfig -> SndFileChunk -> SndFileChunkReplica -> AM ()
499
509
uploadFileChunk AgentConfig {xftpMaxRecipientsPerRequest = maxRecipients} sndFileChunk@ SndFileChunk {sndFileId, userId, chunkSpec = chunkSpec@ XFTPChunkSpec {filePath}, digest = chunkDigest} replica = do
500
510
replica'@ SndFileChunkReplica {sndChunkReplicaId} <- addRecipients sndFileChunk replica
@@ -510,6 +520,7 @@ runXFTPSndWorker c srv Worker {doWork} = do
510
520
let uploaded = uploadedSize chunks
511
521
total = totalSize chunks
512
522
complete = all chunkUploaded chunks
523
+ atomically $ incXFTPServerStat c userId srv uploads
513
524
notify c sndFileEntityId $ SFPROG uploaded total
514
525
when complete $ do
515
526
(sndDescr, rcvDescrs) <- sndFileToDescrs sf
@@ -651,6 +662,7 @@ runXFTPDelWorker c srv Worker {doWork} = do
651
662
let ri' = maybe ri (\ d -> ri {initialInterval = d, increaseAfter = 0 }) delay
652
663
withRetryIntervalLimit xftpConsecutiveRetries ri' $ \ delay' loop -> do
653
664
liftIO $ waitForUserNetwork c
665
+ atomically $ incXFTPServerStat c userId srv deleteAttempts
654
666
deleteChunkReplica
655
667
`catchAgentError` \ e -> retryOnError " XFTP del worker" (retryLoop loop e delay') (retryDone e) e
656
668
where
@@ -661,10 +673,13 @@ runXFTPDelWorker c srv Worker {doWork} = do
661
673
withStore' c $ \ db -> updateDeletedSndChunkReplicaDelay db deletedSndChunkReplicaId replicaDelay
662
674
atomically $ assertAgentForeground c
663
675
loop
664
- retryDone = delWorkerInternalError c deletedSndChunkReplicaId
676
+ retryDone e = do
677
+ atomically $ incXFTPServerStat c userId srv deleteErrs
678
+ delWorkerInternalError c deletedSndChunkReplicaId e
665
679
deleteChunkReplica = do
666
680
agentXFTPDeleteChunk c userId replica
667
681
withStore' c $ \ db -> deleteDeletedSndChunkReplica db deletedSndChunkReplicaId
682
+ atomically $ incXFTPServerStat c userId srv deletions
668
683
669
684
delWorkerInternalError :: AgentClient -> Int64 -> AgentErrorType -> AM ()
670
685
delWorkerInternalError c deletedSndChunkReplicaId e = do
0 commit comments