xftp-server: set initial usedStorage from actual file records (#1045)

This commit is contained in:
Alexander Bondarenko
2024-03-19 15:53:02 +02:00
committed by GitHub
parent 46e49fa823
commit d68ff7e22f

View File

@@ -14,12 +14,13 @@ import Control.Monad.IO.Unlift
import Crypto.Random
import Data.Int (Int64)
import Data.List.NonEmpty (NonEmpty)
import qualified Data.Map.Strict as M
import Data.Time.Clock (getCurrentTime)
import Data.Word (Word32)
import Data.X509.Validation (Fingerprint (..))
import Network.Socket
import qualified Network.TLS as T
import Simplex.FileTransfer.Protocol (FileCmd, FileInfo, XFTPFileId)
import Simplex.FileTransfer.Protocol (FileCmd, FileInfo (..), XFTPFileId)
import Simplex.FileTransfer.Server.Stats
import Simplex.FileTransfer.Server.Store
import Simplex.FileTransfer.Server.StoreLog
@@ -95,7 +96,8 @@ newXFTPServerEnv config@XFTPServerConfig {storeLogFile, fileSizeQuota, caCertifi
random <- liftIO C.newRandom
store <- atomically newFileStore
storeLog <- liftIO $ mapM (`readWriteFileStore` store) storeLogFile
used <- readTVarIO (usedStorage store)
used <- countUsedStorage <$> readTVarIO (files store)
atomically $ writeTVar (usedStorage store) used
forM_ fileSizeQuota $ \quota -> do
logInfo $ "Total / available storage: " <> tshow quota <> " / " <> tshow (quota - used)
when (quota < used) $ logInfo "WARNING: storage quota is less than used storage, no files can be uploaded!"
@@ -104,6 +106,9 @@ newXFTPServerEnv config@XFTPServerConfig {storeLogFile, fileSizeQuota, caCertifi
serverStats <- atomically . newFileServerStats =<< liftIO getCurrentTime
pure XFTPEnv {config, store, storeLog, random, tlsServerParams, serverIdentity = C.KeyHash fp, serverStats}
countUsedStorage :: M.Map k FileRec -> Int64
countUsedStorage = M.foldl' (\acc FileRec {fileInfo = FileInfo {size}} -> acc + fromIntegral size) 0
data XFTPRequest
= XFTPReqNew FileInfo (NonEmpty RcvPublicAuthKey) (Maybe BasicAuth)
| XFTPReqCmd XFTPFileId FileRec FileCmd