diff --git a/src/Simplex/FileTransfer/Server.hs b/src/Simplex/FileTransfer/Server.hs index a6f32d481..b8ad9b2e6 100644 --- a/src/Simplex/FileTransfer/Server.hs +++ b/src/Simplex/FileTransfer/Server.hs @@ -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 diff --git a/src/Simplex/FileTransfer/Server/Stats.hs b/src/Simplex/FileTransfer/Server/Stats.hs index ff70eec9d..f6e092cdf 100644 --- a/src/Simplex/FileTransfer/Server/Stats.hs +++ b/src/Simplex/FileTransfer/Server/Stats.hs @@ -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} diff --git a/tests/XFTPClient.hs b/tests/XFTPClient.hs index 4fcc21c40..d6b48f6a2 100644 --- a/tests/XFTPClient.hs +++ b/tests/XFTPClient.hs @@ -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 }