mirror of
https://github.com/simplex-chat/simplexmq.git
synced 2026-05-14 16:15:12 +00:00
xftp: server stats (#661)
This commit is contained in:
Evgeny Poberezkin
committed by
GitHub
GitHub
parent
875a4bac5e
commit
524c1de4de
@@ -123,7 +123,7 @@ xftpServer cfg@XFTPServerConfig {xftpPort, logTLSErrors} started = do
|
||||
initialDelay <- (startAt -) . fromIntegral . (`div` 1000000_000000) . diffTimeToPicoseconds . utctDayTime <$> liftIO getCurrentTime
|
||||
liftIO $ putStrLn $ "server stats log enabled: " <> statsFilePath
|
||||
threadDelay $ 1_000_000 * (initialDelay + if initialDelay < 0 then 86_400 else 0)
|
||||
FileServerStats {fromTime, filesCreated, fileRecipients, filesUploaded, filesDeleted, filesDownloaded, fileDownloads, fileDownloadAcks} <- asks serverStats
|
||||
FileServerStats {fromTime, filesCreated, fileRecipients, filesUploaded, filesDeleted, filesDownloaded, fileDownloads, fileDownloadAcks, filesCount, filesSize} <- asks serverStats
|
||||
let interval = 1_000_000 * logInterval
|
||||
forever $ do
|
||||
withFile statsFilePath AppendMode $ \h -> liftIO $ do
|
||||
@@ -137,6 +137,8 @@ xftpServer cfg@XFTPServerConfig {xftpPort, logTLSErrors} started = do
|
||||
files <- atomically $ periodStatCounts filesDownloaded ts
|
||||
fileDownloads' <- atomically $ swapTVar fileDownloads 0
|
||||
fileDownloadAcks' <- atomically $ swapTVar fileDownloadAcks 0
|
||||
filesCount' <- atomically $ swapTVar filesCount 0
|
||||
filesSize' <- atomically $ swapTVar filesSize 0
|
||||
hPutStrLn h $
|
||||
intercalate
|
||||
","
|
||||
@@ -149,7 +151,9 @@ xftpServer cfg@XFTPServerConfig {xftpPort, logTLSErrors} started = do
|
||||
weekCount files,
|
||||
monthCount files,
|
||||
show fileDownloads',
|
||||
show fileDownloadAcks'
|
||||
show fileDownloadAcks',
|
||||
show filesCount',
|
||||
show filesSize'
|
||||
]
|
||||
threadDelay interval
|
||||
|
||||
@@ -248,6 +252,9 @@ processXFTPRequest HTTP2Body {bodyPart} = \case
|
||||
withFileLog $ \sl -> do
|
||||
logAddFile sl sId file ts
|
||||
logAddRecipients sl sId rcps
|
||||
stats <- asks serverStats
|
||||
atomically $ modifyTVar' (filesCreated stats) (+ 1)
|
||||
atomically $ modifyTVar' (fileRecipients stats) (+ length rks)
|
||||
let rIds = L.map (\(FileRecipient rId _) -> rId) rcps
|
||||
pure $ FRSndIds sId rIds
|
||||
pure $ either FRErr id r
|
||||
@@ -283,39 +290,55 @@ processXFTPRequest HTTP2Body {bodyPart} = \case
|
||||
st <- asks store
|
||||
quota_ <- asks $ fileSizeQuota . config
|
||||
-- TODO timeout file upload, remove partially uploaded files
|
||||
stats <- asks serverStats
|
||||
liftIO $
|
||||
runExceptT (receiveFile getBody (XFTPRcvChunkSpec fPath size digest)) >>= \case
|
||||
Right () -> do
|
||||
used <- readTVarIO $ usedStorage st
|
||||
if maybe False (used + fromIntegral size >) quota_
|
||||
then remove fPath $> FRErr QUOTA
|
||||
else atomically (setFilePath' st fr fPath) $> FROk
|
||||
else do
|
||||
atomically (setFilePath' st fr fPath)
|
||||
atomically $ modifyTVar' (filesUploaded stats) (+ 1)
|
||||
atomically $ modifyTVar' (filesCount stats) (+ 1)
|
||||
atomically $ modifyTVar' (filesSize stats) (+ fromIntegral size)
|
||||
pure FROk
|
||||
Left e -> remove fPath $> FRErr e
|
||||
where
|
||||
remove fPath = whenM (doesFileExist fPath) (removeFile fPath) `catch` logFileError
|
||||
|
||||
sendServerFile :: FileRec -> RcvPublicDhKey -> M (FileResponse, Maybe ServerFile)
|
||||
sendServerFile FileRec {filePath, fileInfo = FileInfo {size}} rDhKey = do
|
||||
sendServerFile FileRec {senderId, filePath, fileInfo = FileInfo {size}} rDhKey = do
|
||||
readTVarIO filePath >>= \case
|
||||
Just path -> do
|
||||
(sDhKey, spDhKey) <- liftIO C.generateKeyPair'
|
||||
let dhSecret = C.dh' rDhKey spDhKey
|
||||
cbNonce <- liftIO C.randomCbNonce
|
||||
pure $ case LC.cbInit dhSecret cbNonce of
|
||||
Right sbState -> (FRFile sDhKey cbNonce, Just ServerFile {filePath = path, fileSize = size, sbState})
|
||||
_ -> (FRErr INTERNAL, Nothing)
|
||||
case LC.cbInit dhSecret cbNonce of
|
||||
Right sbState -> do
|
||||
stats <- asks serverStats
|
||||
atomically $ modifyTVar' (fileDownloads stats) (+ 1)
|
||||
atomically $ updatePeriodStats (filesDownloaded stats) senderId
|
||||
pure (FRFile sDhKey cbNonce, Just ServerFile {filePath = path, fileSize = size, sbState})
|
||||
_ -> pure (FRErr INTERNAL, Nothing)
|
||||
_ -> pure (FRErr NO_FILE, Nothing)
|
||||
|
||||
deleteServerFile :: FileRec -> M FileResponse
|
||||
deleteServerFile FileRec {senderId, filePath} = do
|
||||
deleteServerFile FileRec {senderId, fileInfo, filePath} = do
|
||||
withFileLog (`logDeleteFile` senderId)
|
||||
r <- runExceptT $ do
|
||||
path <- readTVarIO filePath
|
||||
ExceptT $ first (\(_ :: SomeException) -> FILE_IO) <$> try (forM_ path $ \p -> whenM (doesFileExist p) (removeFile p))
|
||||
stats <- asks serverStats
|
||||
ExceptT $ first (\(_ :: SomeException) -> FILE_IO) <$> try (forM_ path $ \p -> whenM (doesFileExist p) (removeFile p >> deletedStats stats))
|
||||
st <- asks store
|
||||
void $ atomically $ deleteFile st senderId
|
||||
atomically $ modifyTVar' (filesDeleted stats) (+ 1)
|
||||
pure FROk
|
||||
either (pure . FRErr) pure r
|
||||
where
|
||||
deletedStats stats = do
|
||||
atomically $ modifyTVar' (filesCount stats) (subtract 1)
|
||||
atomically $ modifyTVar' (filesSize stats) (subtract $ fromIntegral $ size fileInfo)
|
||||
|
||||
logFileError :: SomeException -> IO ()
|
||||
logFileError e = logError $ "Error deleting file: " <> tshow e
|
||||
@@ -325,6 +348,8 @@ processXFTPRequest HTTP2Body {bodyPart} = \case
|
||||
withFileLog (`logAckFile` rId)
|
||||
st <- asks store
|
||||
atomically $ deleteRecipient st rId fr
|
||||
stats <- asks serverStats
|
||||
atomically $ modifyTVar' (fileDownloadAcks stats) (+ 1)
|
||||
pure FROk
|
||||
|
||||
randomId :: (MonadUnliftIO m, MonadReader XFTPEnv m) => Int -> m ByteString
|
||||
@@ -361,7 +386,10 @@ restoreServerStats = asks (serverStatsBackupFile . config) >>= mapM_ restoreStat
|
||||
liftIO (strDecode <$> B.readFile f) >>= \case
|
||||
Right d -> do
|
||||
s <- asks serverStats
|
||||
atomically $ setFileServerStats s d
|
||||
fs <- readTVarIO . files =<< asks store
|
||||
let _filesCount = length $ M.keys fs
|
||||
_filesSize = M.foldl' (\n -> (n +) . fromIntegral . size . fileInfo) 0 fs
|
||||
atomically $ setFileServerStats s d {_filesCount, _filesSize}
|
||||
renameFile f $ f <> ".bak"
|
||||
logInfo "server stats restored"
|
||||
Left e -> do
|
||||
|
||||
@@ -6,6 +6,7 @@ module Simplex.FileTransfer.Server.Stats where
|
||||
|
||||
import qualified Data.Attoparsec.ByteString.Char8 as A
|
||||
import qualified Data.ByteString.Char8 as B
|
||||
import Data.Int (Int64)
|
||||
import Data.Time.Clock (UTCTime)
|
||||
import Simplex.Messaging.Encoding.String
|
||||
import Simplex.Messaging.Protocol (SenderId)
|
||||
@@ -20,7 +21,9 @@ data FileServerStats = FileServerStats
|
||||
filesDeleted :: TVar Int,
|
||||
filesDownloaded :: PeriodStats SenderId,
|
||||
fileDownloads :: TVar Int,
|
||||
fileDownloadAcks :: TVar Int
|
||||
fileDownloadAcks :: TVar Int,
|
||||
filesCount :: TVar Int,
|
||||
filesSize :: TVar Int64
|
||||
}
|
||||
|
||||
data FileServerStatsData = FileServerStatsData
|
||||
@@ -31,8 +34,11 @@ data FileServerStatsData = FileServerStatsData
|
||||
_filesDeleted :: Int,
|
||||
_filesDownloaded :: PeriodStatsData SenderId,
|
||||
_fileDownloads :: Int,
|
||||
_fileDownloadAcks :: Int
|
||||
_fileDownloadAcks :: Int,
|
||||
_filesCount :: Int,
|
||||
_filesSize :: Int64
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
newFileServerStats :: UTCTime -> STM FileServerStats
|
||||
newFileServerStats ts = do
|
||||
@@ -44,7 +50,9 @@ newFileServerStats ts = do
|
||||
filesDownloaded <- newPeriodStats
|
||||
fileDownloads <- newTVar 0
|
||||
fileDownloadAcks <- newTVar 0
|
||||
pure FileServerStats {fromTime, filesCreated, fileRecipients, filesUploaded, filesDeleted, filesDownloaded, fileDownloads, fileDownloadAcks}
|
||||
filesCount <- newTVar 0
|
||||
filesSize <- newTVar 0
|
||||
pure FileServerStats {fromTime, filesCreated, fileRecipients, filesUploaded, filesDeleted, filesDownloaded, fileDownloads, fileDownloadAcks, filesCount, filesSize}
|
||||
|
||||
getFileServerStatsData :: FileServerStats -> STM FileServerStatsData
|
||||
getFileServerStatsData s = do
|
||||
@@ -56,7 +64,9 @@ getFileServerStatsData s = do
|
||||
_filesDownloaded <- getPeriodStatsData $ filesDownloaded s
|
||||
_fileDownloads <- readTVar $ fileDownloads s
|
||||
_fileDownloadAcks <- readTVar $ fileDownloadAcks s
|
||||
pure FileServerStatsData {_fromTime, _filesCreated, _fileRecipients, _filesUploaded, _filesDeleted, _filesDownloaded, _fileDownloads, _fileDownloadAcks}
|
||||
_filesCount <- readTVar $ filesCount s
|
||||
_filesSize <- readTVar $ filesSize s
|
||||
pure FileServerStatsData {_fromTime, _filesCreated, _fileRecipients, _filesUploaded, _filesDeleted, _filesDownloaded, _fileDownloads, _fileDownloadAcks, _filesCount, _filesSize}
|
||||
|
||||
setFileServerStats :: FileServerStats -> FileServerStatsData -> STM ()
|
||||
setFileServerStats s d = do
|
||||
@@ -68,6 +78,8 @@ setFileServerStats s d = do
|
||||
setPeriodStats (filesDownloaded s) $! _filesDownloaded d
|
||||
writeTVar (fileDownloads s) $! _fileDownloads d
|
||||
writeTVar (fileDownloadAcks s) $! _fileDownloadAcks d
|
||||
writeTVar (filesCount s) $! _filesCount d
|
||||
writeTVar (filesSize s) $! _filesSize d
|
||||
|
||||
instance StrEncoding FileServerStatsData where
|
||||
strEncode FileServerStatsData {_fromTime, _filesCreated, _fileRecipients, _filesUploaded, _filesDeleted, _filesDownloaded, _fileDownloads, _fileDownloadAcks} =
|
||||
@@ -77,7 +89,8 @@ instance StrEncoding FileServerStatsData where
|
||||
"fileRecipients=" <> strEncode _fileRecipients,
|
||||
"filesUploaded=" <> strEncode _filesUploaded,
|
||||
"filesDeleted=" <> strEncode _filesDeleted,
|
||||
"filesDownloaded=" <> strEncode _filesDownloaded,
|
||||
"filesDownloaded:",
|
||||
strEncode _filesDownloaded,
|
||||
"fileDownloads=" <> strEncode _fileDownloads,
|
||||
"fileDownloadAcks=" <> strEncode _fileDownloadAcks
|
||||
]
|
||||
@@ -87,7 +100,7 @@ instance StrEncoding FileServerStatsData where
|
||||
_fileRecipients <- "fileRecipients=" *> strP <* A.endOfLine
|
||||
_filesUploaded <- "filesUploaded=" *> strP <* A.endOfLine
|
||||
_filesDeleted <- "filesDeleted=" *> strP <* A.endOfLine
|
||||
_filesDownloaded <- "filesDownloaded=" *> strP <* A.endOfLine
|
||||
_filesDownloaded <- "filesDownloaded:" *> A.endOfLine *> strP <* A.endOfLine
|
||||
_fileDownloads <- "fileDownloads=" *> strP <* A.endOfLine
|
||||
_fileDownloadAcks <- "fileDownloadAcks=" *> strP <* A.endOfLine
|
||||
pure FileServerStatsData {_fromTime, _filesCreated, _fileRecipients, _filesUploaded, _filesDeleted, _filesDownloaded, _fileDownloads, _fileDownloadAcks}
|
||||
pure FileServerStatsData {_fromTime, _filesCreated, _fileRecipients, _filesUploaded, _filesDeleted, _filesDownloaded, _fileDownloads, _fileDownloadAcks, _filesCount = 0, _filesSize = 0}
|
||||
|
||||
+2
-2
@@ -97,8 +97,8 @@ testXFTPServerConfig =
|
||||
certificateFile = "tests/fixtures/server.crt",
|
||||
logStatsInterval = Nothing,
|
||||
logStatsStartTime = 0,
|
||||
serverStatsLogFile = "tests/xftp-server-stats.daily.log",
|
||||
serverStatsBackupFile = Nothing,
|
||||
serverStatsLogFile = "tests/tmp/xftp-server-stats.daily.log",
|
||||
serverStatsBackupFile = Just "tests/tmp/xftp-server-stats.log",
|
||||
logTLSErrors = True
|
||||
}
|
||||
|
||||
|
||||
Reference in New Issue
Block a user