diff --git a/src/Simplex/FileTransfer/Server.hs b/src/Simplex/FileTransfer/Server.hs index dd74a975d..f62e75f4b 100644 --- a/src/Simplex/FileTransfer/Server.hs +++ b/src/Simplex/FileTransfer/Server.hs @@ -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