dandri/simplexmq
1
0
Fork 0
mirror of https://github.com/simplex-chat/simplexmq.git synced 2026-08-28 02:54:51 +00:00
Code Issues Packages Projects Releases Wiki Activity

xftp-server: run expiration checks on start (#1042)

Browse Source 
* xftp-server: run expiration checks on start

* rename

* refactor

---------

Co-authored-by: Evgeny Poberezkin <evgeny@poberezkin.com>
This commit is contained in:
Alexander Bondarenko
2024-04-01 11:29:19 +01:00
committed by GitHub
co-authored by Evgeny Poberezkin
parent 39bb804fab
commit a698f9a0c4
1 changed files with 30 additions and 21 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Simplex/FileTransfer/Server.hs
+30 -21
View File
@@ -1,4 +1,3 @@
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
@@ -85,7 +84,8 @@ runXFTPServerBlocking :: TMVar Bool -> XFTPServerConfig -> IO ()
runXFTPServerBlocking started cfg = newXFTPServerEnv cfg >>= runReaderT (xftpServer cfg started)
xftpServer :: XFTPServerConfig -> TMVar Bool -> M ()
xftpServer cfg@XFTPServerConfig {xftpPort, transportConfig, inactiveClientExpiration} started = do
xftpServer cfg@XFTPServerConfig {xftpPort, transportConfig, inactiveClientExpiration, fileExpiration} started = do
mapM_ (expireServerFiles Nothing) fileExpiration
restoreServerStats
raceAny_ (runServer : expireFilesThread_ cfg <> serverStatsThread_ cfg <> controlPortThread_ cfg) `finally` stopServer
where
@@ -110,28 +110,10 @@ xftpServer cfg@XFTPServerConfig {xftpPort, transportConfig, inactiveClientExpira
expireFiles :: ExpirationConfig -> M ()
expireFiles expCfg = do
st <- asks store
let interval = checkInterval expCfg * 1000000
forever $ do
liftIO $ threadDelay' interval
old <- liftIO $ expireBeforeEpoch expCfg
sIds <- M.keysSet <$> readTVarIO (files st)
forM_ sIds $ \sId -> do
threadDelay 100000
atomically (expiredFilePath st sId old)
>>= mapM_ (maybeRemove $ delete st sId)
where
maybeRemove del = maybe del (remove del)
remove del filePath =
ifM
(doesFileExist filePath)
((removeFile filePath >> del) `catch` \(e :: SomeException) -> logError $ "failed to remove expired file " <> tshow filePath <> ": " <> tshow e)
del
delete st sId = do
withFileLog (`logDeleteFile` sId)
void $ atomically $ deleteFile st sId
FileServerStats {filesExpired} <- asks serverStats
atomically $ modifyTVar' filesExpired (+ 1)
expireServerFiles (Just 100000) expCfg
serverStatsThread_ :: XFTPServerConfig -> [M ()]
serverStatsThread_ XFTPServerConfig {logStatsInterval = Just interval, logStatsStartTime, serverStatsLogFile} =
@@ -457,6 +439,33 @@ deleteServerFile_ FileRec {senderId, fileInfo, filePath} = do
atomically $ modifyTVar' (filesCount stats) (subtract 1)
atomically $ modifyTVar' (filesSize stats) (subtract $ fromIntegral $ size fileInfo)
expireServerFiles :: Maybe Int -> ExpirationConfig -> M ()
expireServerFiles itemDelay expCfg = do
st <- asks store
usedStart <- readTVarIO $ usedStorage st
old <- liftIO $ expireBeforeEpoch expCfg
files' <- readTVarIO (files st)
logInfo $ "Expiration check: " <> tshow (M.size files') <> " files"
forM_ (M.keys files') $ \sId -> do
mapM_ threadDelay itemDelay
atomically (expiredFilePath st sId old)
>>= mapM_ (maybeRemove $ delete st sId)
usedEnd <- readTVarIO $ usedStorage st
logInfo $ "Used " <> mbs usedStart <> " -> " <> mbs usedEnd <> ", " <> mbs (usedStart - usedEnd) <> " reclaimed."
where
mbs bs = tshow (bs `div` 1048576) <> "mb"
maybeRemove del = maybe del (remove del)
remove del filePath =
ifM
(doesFileExist filePath)
((removeFile filePath >> del) `catch` \(e :: SomeException) -> logError $ "failed to remove expired file " <> tshow filePath <> ": " <> tshow e)
del
delete st sId = do
withFileLog (`logDeleteFile` sId)
void . atomically $ deleteFile st sId -- will not update usedStorage if sId isn't in store
FileServerStats {filesExpired} <- asks serverStats
atomically $ modifyTVar' filesExpired (+ 1)
randomId :: Int -> M ByteString
randomId n = atomically . C.randomBytes n =<< asks random