xftp: server stats

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

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}

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
     }