From 3ab5e9d110407b312c8c056dfff7b3bc2a130efa Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com> Date: Fri, 24 Feb 2023 07:09:51 +0000 Subject: [PATCH] xftp: expire files on the server, track/limit used storage (#651) * xftp: expire files on the server * track/limit used storage * support storage quota and disabling queue creation in CLI parameters * fix ini file * correction --------- Co-authored-by: spaced4ndy <8711996+spaced4ndy@users.noreply.github.com> --- src/Simplex/FileTransfer/Protocol.hs | 4 ++ src/Simplex/FileTransfer/Server.hs | 45 +++++++++++++++-- src/Simplex/FileTransfer/Server/Env.hs | 29 ++++++++++- src/Simplex/FileTransfer/Server/Main.hs | 40 ++++++++++++--- src/Simplex/FileTransfer/Server/Store.hs | 49 ++++++++++++------ src/Simplex/FileTransfer/Server/StoreLog.hs | 19 +++---- src/Simplex/Messaging/Server/CLI.hs | 6 ++- src/Simplex/Messaging/Server/Main.hs | 4 +- tests/XFTPClient.hs | 6 ++- tests/XFTPServerTests.hs | 55 +++++++++++++++++++++ 10 files changed, 214 insertions(+), 43 deletions(-) diff --git a/src/Simplex/FileTransfer/Protocol.hs b/src/Simplex/FileTransfer/Protocol.hs index 41d7b7aff..21e5e1cbe 100644 --- a/src/Simplex/FileTransfer/Protocol.hs +++ b/src/Simplex/FileTransfer/Protocol.hs @@ -335,6 +335,8 @@ data XFTPErrorType AUTH | -- | incorrent file size SIZE + | -- | storage quota exceeded + QUOTA | -- | incorrent file digest DIGEST | -- | file encryption/decryption failed @@ -358,6 +360,7 @@ instance Encoding XFTPErrorType where CMD err -> "CMD " <> smpEncode err AUTH -> "AUTH" SIZE -> "SIZE" + QUOTA -> "QUOTA" DIGEST -> "DIGEST" CRYPTO -> "CRYPTO" NO_FILE -> "NO_FILE" @@ -373,6 +376,7 @@ instance Encoding XFTPErrorType where "CMD" -> CMD <$> _smpP "AUTH" -> pure AUTH "SIZE" -> pure SIZE + "QUOTA" -> pure QUOTA "DIGEST" -> pure DIGEST "CRYPTO" -> pure CRYPTO "NO_FILE" -> pure NO_FILE diff --git a/src/Simplex/FileTransfer/Server.hs b/src/Simplex/FileTransfer/Server.hs index 6fd8aa148..cf4b460ec 100644 --- a/src/Simplex/FileTransfer/Server.hs +++ b/src/Simplex/FileTransfer/Server.hs @@ -25,8 +25,10 @@ import qualified Data.ByteString.Char8 as B import Data.Functor (($>)) import Data.List (intercalate) import qualified Data.List.NonEmpty as L +import qualified Data.Map.Strict as M import qualified Data.Text as T import Data.Time.Clock (UTCTime (..), diffTimeToPicoseconds, getCurrentTime) +import Data.Time.Clock.System (getSystemTime) import Data.Time.Format.ISO8601 (iso8601Show) import Data.Word (Word32) import qualified Network.HTTP.Types as N @@ -41,6 +43,7 @@ import qualified Simplex.Messaging.Crypto.Lazy as LC import Simplex.Messaging.Encoding.String import Simplex.Messaging.Protocol (CorrId, RcvPublicDhKey, RecipientId) import Simplex.Messaging.Server (dummyVerifyCmd, verifyCmdSignature) +import Simplex.Messaging.Server.Expiration import Simplex.Messaging.Server.Stats import Simplex.Messaging.Server.StoreLog (StoreLog, closeStoreLog) import Simplex.Messaging.Transport.HTTP2 @@ -68,7 +71,7 @@ runXFTPServerBlocking started cfg = newXFTPServerEnv cfg >>= runReaderT (xftpSer xftpServer :: XFTPServerConfig -> TMVar Bool -> M () xftpServer cfg@XFTPServerConfig {xftpPort, logTLSErrors} started = do restoreServerStats - raceAny_ (runServer : serverStatsThread_ cfg) `finally` stopServer + raceAny_ (runServer : expireFilesThread_ cfg <> serverStatsThread_ cfg) `finally` stopServer where runServer :: M () runServer = do @@ -84,6 +87,29 @@ xftpServer cfg@XFTPServerConfig {xftpPort, logTLSErrors} started = do withFileLog closeStoreLog saveServerStats + expireFilesThread_ :: XFTPServerConfig -> [M ()] + expireFilesThread_ XFTPServerConfig {fileExpiration = Just fileExp} = [expireFiles fileExp] + expireFilesThread_ _ = [] + + expireFiles :: ExpirationConfig -> M () + expireFiles expCfg = do + st <- asks store + let interval = checkInterval expCfg * 1000000 + forever $ do + threadDelay interval + old <- liftIO $ expireBeforeEpoch expCfg + sIds <- M.keysSet <$> readTVarIO (files st) + forM_ sIds $ \sId -> do + threadDelay 100000 + atomically (expiredFilePath st sId old) + >>= mapM_ (remove $ void $ atomically $ deleteFile st sId) + where + remove delete filePath = + ifM + (doesFileExist filePath) + (removeFile filePath >> delete `catch` \(e :: SomeException) -> logError $ "failed to remove expired file " <> tshow filePath <> ": " <> tshow e) + delete + serverStatsThread_ :: XFTPServerConfig -> [M ()] serverStatsThread_ XFTPServerConfig {logStatsInterval = Just interval, logStatsStartTime, serverStatsLogFile} = [logServerStats logStatsStartTime interval serverStatsLogFile] @@ -189,8 +215,9 @@ processXFTPRequest HTTP2Body {bodyPart} = \case -- TODO retry on duplicate IDs? sId <- getFileId rIds <- mapM (const getFileId) rcps + ts <- liftIO getSystemTime r <- runExceptT $ do - ExceptT $ atomically $ addFile st sId file + ExceptT $ atomically $ addFile st sId file ts forM (L.zip rIds rcps) $ \rcp -> ExceptT $ atomically $ addRecipient st sId rcp noFile $ either FRErr (const $ FRSndIds sId rIds) r @@ -207,7 +234,7 @@ processXFTPRequest HTTP2Body {bodyPart} = \case where noFile resp = pure (resp, Nothing) receiveServerFile :: FileRec -> M FileResponse - receiveServerFile FileRec {senderId, fileInfo, filePath} = case bodyPart of + receiveServerFile fr@FileRec {senderId, fileInfo} = case bodyPart of -- TODO do not allow repeated file upload Nothing -> pure $ FRErr SIZE Just getBody -> do @@ -215,10 +242,18 @@ processXFTPRequest HTTP2Body {bodyPart} = \case path <- asks $ filesPath . config let fPath = path B.unpack (B64.encode senderId) FileInfo {size, digest} = fileInfo + st <- asks store + quota_ <- asks $ fileSizeQuota . config liftIO $ runExceptT (receiveFile getBody (XFTPRcvChunkSpec fPath size digest)) >>= \case - Right () -> atomically $ writeTVar filePath (Just fPath) $> FROk - Left e -> (whenM (doesFileExist fPath) (removeFile fPath) `catch` logFileError) $> FRErr e + 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 + 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 diff --git a/src/Simplex/FileTransfer/Server/Env.hs b/src/Simplex/FileTransfer/Server/Env.hs index 9147f1f20..e52f69965 100644 --- a/src/Simplex/FileTransfer/Server/Env.hs +++ b/src/Simplex/FileTransfer/Server/Env.hs @@ -3,12 +3,16 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE StrictData #-} module Simplex.FileTransfer.Server.Env where +import Control.Logger.Simple (logInfo) +import Control.Monad import Control.Monad.IO.Unlift import Crypto.Random +import Data.Int (Int64) import Data.List.NonEmpty (NonEmpty) import Data.Time.Clock (getCurrentTime) import Data.X509.Validation (Fingerprint (..)) @@ -19,8 +23,10 @@ import Simplex.FileTransfer.Server.Stats import Simplex.FileTransfer.Server.Store import Simplex.FileTransfer.Server.StoreLog import qualified Simplex.Messaging.Crypto as C -import Simplex.Messaging.Protocol (RcvPublicVerifyKey) +import Simplex.Messaging.Protocol (BasicAuth, RcvPublicVerifyKey) +import Simplex.Messaging.Server.Expiration import Simplex.Messaging.Transport.Server (loadFingerprint, loadTLSServerParams) +import Simplex.Messaging.Util (tshow) import System.IO (IOMode (..)) import UnliftIO.STM @@ -29,6 +35,14 @@ data XFTPServerConfig = XFTPServerConfig fileIdSize :: Int, storeLogFile :: Maybe FilePath, filesPath :: FilePath, + -- | server storage quota + fileSizeQuota :: Maybe Int64, + -- | set to False to prohibit creating new files + allowNewFiles :: Bool, + -- | simple password that the clients need to pass in handshake to be able to create new files + newFileBasicAuth :: Maybe BasicAuth, + -- | time after which the files can be removed and check interval, seconds + fileExpiration :: Maybe ExpirationConfig, -- CA certificate private key is not needed for initialization caCertificateFile :: FilePath, privateKeyFile :: FilePath, @@ -51,11 +65,22 @@ data XFTPEnv = XFTPEnv serverStats :: FileServerStats } +defaultFileExpiration :: ExpirationConfig +defaultFileExpiration = + ExpirationConfig + { ttl = 48 * 3600, -- seconds, 48 hours + checkInterval = 2 * 3600 -- seconds, 2 hours + } + newXFTPServerEnv :: (MonadUnliftIO m, MonadRandom m) => XFTPServerConfig -> m XFTPEnv -newXFTPServerEnv config@XFTPServerConfig {storeLogFile, caCertificateFile, certificateFile, privateKeyFile} = do +newXFTPServerEnv config@XFTPServerConfig {storeLogFile, fileSizeQuota, caCertificateFile, certificateFile, privateKeyFile} = do idsDrg <- drgNew >>= newTVarIO store <- atomically newFileStore storeLog <- liftIO $ mapM (`readWriteFileStore` store) storeLogFile + used <- readTVarIO (usedStorage store) + 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!" tlsServerParams <- liftIO $ loadTLSServerParams caCertificateFile certificateFile privateKeyFile Fingerprint fp <- liftIO $ loadFingerprint caCertificateFile serverStats <- atomically . newFileServerStats =<< liftIO getCurrentTime diff --git a/src/Simplex/FileTransfer/Server/Main.hs b/src/Simplex/FileTransfer/Server/Main.hs index 5f3465698..42091f2de 100644 --- a/src/Simplex/FileTransfer/Server/Main.hs +++ b/src/Simplex/FileTransfer/Server/Main.hs @@ -14,8 +14,9 @@ import Data.Maybe (fromMaybe) import qualified Data.Text as T import Network.Socket (HostName) import Options.Applicative +import Simplex.FileTransfer.Description (FileSize (..)) import Simplex.FileTransfer.Server (runXFTPServer) -import Simplex.FileTransfer.Server.Env (XFTPServerConfig (..)) +import Simplex.FileTransfer.Server.Env (XFTPServerConfig (..), defaultFileExpiration) import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Protocol (ProtoServerWithAuth (..), pattern XFTPServer) import Simplex.Messaging.Server.CLI @@ -72,33 +73,52 @@ xftpServerCLI cfgPath logPath = do \# and restoring it when the server is started.\n\ \# Log is compacted on start (deleted objects are removed).\n" <> ("enable: " <> onOff enableStoreLog <> "\n\n") - <> "log_stats: off\n\n\ + <> "log_stats: off\n\ + \\n\ + \[AUTH]\n\ + \# Set new_files option to off to completely prohibit uploading new files.\n\ + \# This can be useful when you want to decommission the server, but still allow downloading the existing files.\n\ + \new_files: on\n\ + \\n\ + \# Use create_password option to enable basic auth to upload new files.\n\ + \# The password should be used as part of server address in client configuration:\n\ + \# xftp://fingerprint:password@host1,host2\n\ + \# The password will not be shared with file recipients, you must share it only\n\ + \# with the users who you want to allow uploading files to your server.\n\ + \# create_password: password to upload files (any printable ASCII characters without whitespace, '@', ':' and '/')\n\ + \\n\ \[TRANSPORT]\n\ \# host is only used to print server address on start\n" <> ("host: " <> host <> "\n") <> ("port: " <> defaultServerPort <> "\n") - <> "log_tls_errors: off\n\n\ + <> "log_tls_errors: off\n\ + \\n\ \[FILES]\n" <> ("path: " <> filesPath <> "\n") + <> "# storage_quota: 100gb\n" runServer ini = do hSetBuffering stdout LineBuffering hSetBuffering stderr LineBuffering fp <- checkSavedFingerprint cfgPath defaultX509Config let host = fromRight "" $ T.unpack <$> lookupValue "TRANSPORT" "host" ini port = T.unpack $ strictIni "TRANSPORT" "port" ini - cfg@XFTPServerConfig {xftpPort, storeLogFile} = serverConfig srv = ProtoServerWithAuth (XFTPServer [THDomainName host] (if port == "443" then "" else port) (C.KeyHash fp)) Nothing printServiceInfo serverVersion srv - printXFTPConfig xftpPort storeLogFile - runXFTPServer cfg + printXFTPConfig serverConfig + runXFTPServer serverConfig where enableStoreLog = settingIsOn "STORE_LOG" "enable" ini logStats = settingIsOn "STORE_LOG" "log_stats" ini c = combine cfgPath . ($ defaultX509Config) - printXFTPConfig xftpPort logFile = do - putStrLn $ case logFile of + printXFTPConfig XFTPServerConfig {allowNewFiles, newFileBasicAuth, xftpPort, storeLogFile} = do + putStrLn $ case storeLogFile of Just f -> "Store log: " <> f _ -> "Store log disabled." + putStrLn $ + "Uploading new files " + <> if allowNewFiles + then maybe "allowed." (const "requires password.") newFileBasicAuth + else "NOT allowed." putStrLn $ "Listening on port " <> xftpPort <> "..." serverConfig = @@ -107,6 +127,10 @@ xftpServerCLI cfgPath logPath = do fileIdSize = 16, storeLogFile = enableStoreLog $> storeLogFilePath, filesPath = T.unpack $ strictIni "FILES" "path" ini, + fileSizeQuota = either error unFileSize <$> strDecodeIni "FILES" "storage_quota" ini, + allowNewFiles = fromMaybe True $ iniOnOff "AUTH" "new_files" ini, + newFileBasicAuth = either error id <$> strDecodeIni "AUTH" "create_password" ini, + fileExpiration = Just defaultFileExpiration, caCertificateFile = c caCrtFile, privateKeyFile = c serverKeyFile, certificateFile = c serverCrtFile, diff --git a/src/Simplex/FileTransfer/Server/Store.hs b/src/Simplex/FileTransfer/Server/Store.hs index 01d6f9a80..7bce800fe 100644 --- a/src/Simplex/FileTransfer/Server/Store.hs +++ b/src/Simplex/FileTransfer/Server/Store.hs @@ -9,9 +9,11 @@ module Simplex.FileTransfer.Server.Store newFileStore, addFile, setFilePath, + setFilePath', addRecipient, deleteFile, deleteRecipient, + expiredFilePath, getFile, ackFile, ) @@ -19,25 +21,29 @@ where import Control.Concurrent.STM import Data.Functor (($>)) +import Data.Int (Int64) import Data.Set (Set) import qualified Data.Set as S +import Data.Time.Clock.System (SystemTime (..)) import Simplex.FileTransfer.Protocol (FileInfo (..), SFileParty (..), XFTPErrorType (..), XFTPFileId) import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Protocol (RcvPublicVerifyKey, RecipientId, SenderId) import Simplex.Messaging.TMap (TMap) import qualified Simplex.Messaging.TMap as TM -import Simplex.Messaging.Util (ifM) +import Simplex.Messaging.Util (ifM, ($>>=)) data FileStore = FileStore { files :: TMap SenderId FileRec, - recipients :: TMap RecipientId (SenderId, RcvPublicVerifyKey) + recipients :: TMap RecipientId (SenderId, RcvPublicVerifyKey), + usedStorage :: TVar Int64 } data FileRec = FileRec { senderId :: SenderId, fileInfo :: FileInfo, filePath :: TVar (Maybe FilePath), - recipientIds :: TVar (Set RecipientId) + recipientIds :: TVar (Set RecipientId), + createdAt :: SystemTime } deriving (Eq) @@ -45,25 +51,30 @@ newFileStore :: STM FileStore newFileStore = do files <- TM.empty recipients <- TM.empty - pure FileStore {files, recipients} + usedStorage <- newTVar 0 + pure FileStore {files, recipients, usedStorage} -addFile :: FileStore -> SenderId -> FileInfo -> STM (Either XFTPErrorType ()) -addFile FileStore {files} sId fileInfo = +addFile :: FileStore -> SenderId -> FileInfo -> SystemTime -> STM (Either XFTPErrorType ()) +addFile FileStore {files} sId fileInfo createdAt = ifM (TM.member sId files) (pure $ Left DUPLICATE_) $ do - f <- newFileRec sId fileInfo + f <- newFileRec sId fileInfo createdAt TM.insert sId f files pure $ Right () -newFileRec :: SenderId -> FileInfo -> STM FileRec -newFileRec senderId fileInfo = do +newFileRec :: SenderId -> FileInfo -> SystemTime -> STM FileRec +newFileRec senderId fileInfo createdAt = do recipientIds <- newTVar S.empty filePath <- newTVar Nothing - pure FileRec {senderId, fileInfo, filePath, recipientIds} + pure FileRec {senderId, fileInfo, filePath, recipientIds, createdAt} setFilePath :: FileStore -> SenderId -> FilePath -> STM (Either XFTPErrorType ()) setFilePath st sId fPath = - withFile st sId $ \FileRec {filePath} -> - writeTVar filePath (Just fPath) $> Right () + withFile st sId $ \fr -> setFilePath' st fr fPath $> Right () + +setFilePath' :: FileStore -> FileRec -> FilePath -> STM () +setFilePath' st FileRec {fileInfo, filePath} fPath = do + writeTVar filePath (Just fPath) + modifyTVar' (usedStorage st) (+ fromIntegral (size fileInfo)) addRecipient :: FileStore -> SenderId -> (RecipientId, RcvPublicVerifyKey) -> STM (Either XFTPErrorType ()) addRecipient st@FileStore {recipients} senderId (rId, rKey) = @@ -77,11 +88,13 @@ addRecipient st@FileStore {recipients} senderId (rId, rKey) = TM.insert rId (senderId, rKey) recipients pure $ Right () +-- this function must be called after the file is deleted from the file system deleteFile :: FileStore -> SenderId -> STM (Either XFTPErrorType ()) -deleteFile FileStore {files, recipients} senderId = do +deleteFile FileStore {files, recipients, usedStorage} senderId = do TM.lookupDelete senderId files >>= \case - Just FileRec {recipientIds} -> do + Just FileRec {fileInfo, recipientIds} -> do readTVar recipientIds >>= mapM_ (`TM.delete` recipients) + modifyTVar' usedStorage $ subtract (fromIntegral $ size fileInfo) pure $ Right () _ -> pure $ Left AUTH @@ -98,6 +111,14 @@ getFile st party fId = case party of Just (sId, rKey) -> withFile st sId $ pure . Right . (,rKey) _ -> pure $ Left AUTH +expiredFilePath :: FileStore -> XFTPFileId -> Int64 -> STM (Maybe FilePath) +expiredFilePath FileStore {files} sId old = + TM.lookup sId files + $>>= \FileRec {filePath, createdAt} -> + if systemSeconds createdAt < old + then readTVar filePath + else pure Nothing + ackFile :: FileStore -> RecipientId -> STM (Either XFTPErrorType ()) ackFile st@FileStore {recipients} recipientId = do TM.lookupDelete recipientId recipients >>= \case diff --git a/src/Simplex/FileTransfer/Server/StoreLog.hs b/src/Simplex/FileTransfer/Server/StoreLog.hs index 4258c6784..37e6df390 100644 --- a/src/Simplex/FileTransfer/Server/StoreLog.hs +++ b/src/Simplex/FileTransfer/Server/StoreLog.hs @@ -22,11 +22,12 @@ import Control.Concurrent.STM import Control.Monad.Except import qualified Data.Attoparsec.ByteString.Char8 as A import qualified Data.ByteString.Char8 as B -import Data.Composition ((.:)) +import Data.Composition ((.:), (.:.)) import Data.List.NonEmpty (NonEmpty) import qualified Data.List.NonEmpty as L import Data.Map.Strict (Map) import qualified Data.Map.Strict as M +import Data.Time.Clock.System (SystemTime) import Simplex.FileTransfer.Protocol (FileInfo (..)) import Simplex.FileTransfer.Server.Store import Simplex.Messaging.Encoding.String @@ -37,7 +38,7 @@ import System.Directory (doesFileExist, renameFile) import System.IO data FileStoreLogRecord - = AddFile SenderId FileInfo + = AddFile SenderId FileInfo SystemTime | PutFile SenderId FilePath | AddRecipients SenderId (NonEmpty (RecipientId, RcvPublicVerifyKey)) | DeleteFile SenderId @@ -45,14 +46,14 @@ data FileStoreLogRecord instance StrEncoding FileStoreLogRecord where strEncode = \case - AddFile sId file -> strEncode (Str "FNEW", sId, file) + AddFile sId file createdAt -> strEncode (Str "FNEW", sId, file, createdAt) PutFile sId path -> strEncode (Str "FPUT", sId, path) AddRecipients sId rcps -> strEncode (Str "FADD", sId, rcps) DeleteFile sId -> strEncode (Str "FDEL", sId) AckFile rId -> strEncode (Str "FACK", rId) strP = A.choice - [ "FNEW " *> (AddFile <$> strP_ <*> strP), + [ "FNEW " *> (AddFile <$> strP_ <*> strP_ <*> strP), "FPUT " *> (PutFile <$> strP_ <*> strP), "FADD " *> (AddRecipients <$> strP_ <*> strP), "FDEL " *> (DeleteFile <$> strP), @@ -62,8 +63,8 @@ instance StrEncoding FileStoreLogRecord where logFileStoreRecord :: StoreLog 'WriteMode -> FileStoreLogRecord -> IO () logFileStoreRecord = writeStoreLogRecord -logAddFile :: StoreLog 'WriteMode -> SenderId -> FileInfo -> IO () -logAddFile s = logFileStoreRecord s .: AddFile +logAddFile :: StoreLog 'WriteMode -> SenderId -> FileInfo -> SystemTime -> IO () +logAddFile s = logFileStoreRecord s .:. AddFile logPutFile :: StoreLog 'WriteMode -> SenderId -> FilePath -> IO () logPutFile s = logFileStoreRecord s .: PutFile @@ -96,7 +97,7 @@ readFileStore f st = mapM_ addFileLogRecord . B.lines =<< B.readFile f Left e -> B.putStrLn $ "Log processing error (" <> bshow e <> "): " <> B.take 100 s _ -> pure () addToStore = \case - AddFile sId file -> addFile st sId file + AddFile sId file createdAt -> addFile st sId file createdAt PutFile qId path -> setFilePath st qId path AddRecipients sId rcps -> runExceptT $ addRecipients sId rcps DeleteFile sId -> deleteFile st sId @@ -109,8 +110,8 @@ writeFileStore s FileStore {files, recipients} = do readTVarIO files >>= mapM_ (logFile allRcps) where logFile :: Map RecipientId (SenderId, RcvPublicVerifyKey) -> FileRec -> IO () - logFile allRcps FileRec {senderId, fileInfo, filePath, recipientIds} = do - logAddFile s senderId fileInfo + logFile allRcps FileRec {senderId, fileInfo, filePath, recipientIds, createdAt} = do + logAddFile s senderId fileInfo createdAt (rcpErrs, rcps) <- M.mapEither getRcp . M.fromSet id <$> readTVarIO recipientIds mapM_ (logAddRecipients s senderId) $ L.nonEmpty $ M.elems rcps mapM_ (B.putStrLn . ("Error storing log: " <>)) rcpErrs diff --git a/src/Simplex/Messaging/Server/CLI.hs b/src/Simplex/Messaging/Server/CLI.hs index 462274b47..6f393a018 100644 --- a/src/Simplex/Messaging/Server/CLI.hs +++ b/src/Simplex/Messaging/Server/CLI.hs @@ -16,6 +16,7 @@ import Data.Either (fromRight) import Data.Ini (Ini, lookupValue) import Data.Text (Text) import qualified Data.Text as T +import Data.Text.Encoding (encodeUtf8) import Data.X509.Validation (Fingerprint (..)) import Network.Socket (HostName, ServiceName) import Options.Applicative @@ -24,7 +25,7 @@ import Simplex.Messaging.Protocol (ProtoServerWithAuth (..), ProtocolServer (..) import Simplex.Messaging.Transport (ATransport (..), TLS, Transport (..)) import Simplex.Messaging.Transport.Server (loadFingerprint) import Simplex.Messaging.Transport.WebSockets (WS) -import Simplex.Messaging.Util (whenM) +import Simplex.Messaging.Util (eitherToMaybe, whenM) import System.Directory (doesDirectoryExist, listDirectory, removeDirectoryRecursive, removePathForcibly) import System.Exit (exitFailure) import System.FilePath (combine) @@ -170,6 +171,9 @@ iniOnOff section name ini = case lookupValue section name ini of Right s -> error . T.unpack $ "invalid INI setting " <> name <> ": " <> s _ -> Nothing +strDecodeIni :: StrEncoding a => Text -> Text -> Ini -> Maybe (Either String a) +strDecodeIni section name ini = strDecode . encodeUtf8 <$> eitherToMaybe (lookupValue section name ini) + withPrompt :: String -> IO a -> IO a withPrompt s a = putStr s >> hFlush stdout >> a diff --git a/src/Simplex/Messaging/Server/Main.hs b/src/Simplex/Messaging/Server/Main.hs index b66ed5ba4..49a24a0bc 100644 --- a/src/Simplex/Messaging/Server/Main.hs +++ b/src/Simplex/Messaging/Server/Main.hs @@ -178,9 +178,7 @@ smpServerCLI cfgPath logPath = _ -> enableStoreLog $> messagesPath, -- allow creating new queues by default allowNewQueues = fromMaybe True $ iniOnOff "AUTH" "new_queues" ini, - newQueueBasicAuth = case lookupValue "AUTH" "create_password" ini of - Right auth -> either error Just . strDecode $ encodeUtf8 auth - _ -> Nothing, + newQueueBasicAuth = either error id <$> strDecodeIni "AUTH" "create_password" ini, messageExpiration = Just defaultMessageExpiration, inactiveClientExpiration = settingIsOn "INACTIVE_CLIENTS" "disconnect" ini diff --git a/tests/XFTPClient.hs b/tests/XFTPClient.hs index 6f7242126..ec1b67432 100644 --- a/tests/XFTPClient.hs +++ b/tests/XFTPClient.hs @@ -11,7 +11,7 @@ import Network.Socket (ServiceName) import SMPClient (serverBracket) import Simplex.FileTransfer.Client import Simplex.FileTransfer.Server (runXFTPServerBlocking) -import Simplex.FileTransfer.Server.Env (XFTPServerConfig (..)) +import Simplex.FileTransfer.Server.Env (XFTPServerConfig (..), defaultFileExpiration) import Simplex.Messaging.Protocol (XFTPServer) import Test.Hspec @@ -77,6 +77,10 @@ testXFTPServerConfig = fileIdSize = 16, storeLogFile = Nothing, filesPath = xftpServerFiles, + fileSizeQuota = Nothing, + allowNewFiles = True, + newFileBasicAuth = Nothing, + fileExpiration = Just defaultFileExpiration, caCertificateFile = "tests/fixtures/ca.crt", privateKeyFile = "tests/fixtures/server.key", certificateFile = "tests/fixtures/server.crt", diff --git a/tests/XFTPServerTests.hs b/tests/XFTPServerTests.hs index 695101a96..e7a06fd89 100644 --- a/tests/XFTPServerTests.hs +++ b/tests/XFTPServerTests.hs @@ -7,6 +7,7 @@ module XFTPServerTests where import AgentTests.FunctionalAPITests (runRight_) +import Control.Concurrent (threadDelay) import Control.Exception (SomeException) import Control.Monad.Except import Crypto.Random (getRandomBytes) @@ -17,11 +18,13 @@ import qualified Data.ByteString.Lazy.Char8 as LB import Data.List (isInfixOf) import Simplex.FileTransfer.Client import Simplex.FileTransfer.Protocol (FileInfo (..), XFTPErrorType (..)) +import Simplex.FileTransfer.Server.Env (XFTPServerConfig (..)) import Simplex.FileTransfer.Transport (XFTPRcvChunkSpec (..)) import Simplex.Messaging.Client (ProtocolClientError (..)) import qualified Simplex.Messaging.Crypto as C import qualified Simplex.Messaging.Crypto.Lazy as LC import Simplex.Messaging.Protocol (SenderId) +import Simplex.Messaging.Server.Expiration (ExpirationConfig (..)) import System.Directory (createDirectoryIfMissing, removeDirectoryRecursive) import System.FilePath (()) import Test.Hspec @@ -39,6 +42,8 @@ xftpServerTests = it "should delete file chunk (2 clients)" testFileChunkDelete2 it "should acknowledge file chunk reception (1 client)" testFileChunkAck it "should acknowledge file chunk reception (2 clients)" testFileChunkAck2 + it "should expire chunks after set interval" testFileChunkExpiration + it "should not allow uploading chunks after specified storage quota" testFileStorageQuota chSize :: Num n => n chSize = 128 * 1024 @@ -133,3 +138,53 @@ runTestFileChunkAck s r = do `catchError` (liftIO . (`shouldBe` PCEProtocolError AUTH)) ackXFTPChunk r rpKey rId `catchError` (liftIO . (`shouldBe` PCEProtocolError AUTH)) + +testFileChunkExpiration :: Expectation +testFileChunkExpiration = withXFTPServerCfg testXFTPServerConfig {fileExpiration} $ + \_ -> testXFTPClient $ \c -> runRight_ $ do + (sndKey, spKey) <- liftIO $ C.generateSignatureKeyPair C.SEd25519 + (rcvKey, rpKey) <- liftIO $ C.generateSignatureKeyPair C.SEd25519 + bytes <- liftIO $ createTestChunk testChunkPath + digest <- liftIO $ LC.sha512Hash <$> LB.readFile testChunkPath + let file = FileInfo {sndKey, size = chSize, digest} + chunkSpec = XFTPChunkSpec {filePath = testChunkPath, chunkOffset = 0, chunkSize = chSize} + (sId, [rId]) <- createXFTPChunk c spKey file [rcvKey] + uploadXFTPChunk c spKey sId chunkSpec + + downloadXFTPChunk c rpKey rId $ XFTPRcvChunkSpec "tests/tmp/received_chunk1" chSize digest + liftIO $ B.readFile "tests/tmp/received_chunk1" `shouldReturn` bytes + + liftIO $ threadDelay 1000000 + downloadXFTPChunk c rpKey rId (XFTPRcvChunkSpec "tests/tmp/received_chunk2" chSize digest) + `catchError` (liftIO . (`shouldBe` PCEProtocolError AUTH)) + deleteXFTPChunk c spKey sId + `catchError` (liftIO . (`shouldBe` PCEProtocolError AUTH)) + where + fileExpiration = Just ExpirationConfig {ttl = 1, checkInterval = 1} + +testFileStorageQuota :: Expectation +testFileStorageQuota = withXFTPServerCfg testXFTPServerConfig {fileSizeQuota = Just $ chSize * 2} $ + \_ -> testXFTPClient $ \c -> runRight_ $ do + (sndKey, spKey) <- liftIO $ C.generateSignatureKeyPair C.SEd25519 + (rcvKey, rpKey) <- liftIO $ C.generateSignatureKeyPair C.SEd25519 + bytes <- liftIO $ createTestChunk testChunkPath + digest <- liftIO $ LC.sha512Hash <$> LB.readFile testChunkPath + let file = FileInfo {sndKey, size = chSize, digest} + chunkSpec = XFTPChunkSpec {filePath = testChunkPath, chunkOffset = 0, chunkSize = chSize} + download rId = do + downloadXFTPChunk c rpKey rId $ XFTPRcvChunkSpec "tests/tmp/received_chunk1" chSize digest + liftIO $ B.readFile "tests/tmp/received_chunk1" `shouldReturn` bytes + (sId1, [rId1]) <- createXFTPChunk c spKey file [rcvKey] + uploadXFTPChunk c spKey sId1 chunkSpec + download rId1 + (sId2, [rId2]) <- createXFTPChunk c spKey file [rcvKey] + uploadXFTPChunk c spKey sId2 chunkSpec + download rId2 + + (sId3, [rId3]) <- createXFTPChunk c spKey file [rcvKey] + uploadXFTPChunk c spKey sId3 chunkSpec + `catchError` (liftIO . (`shouldBe` PCEProtocolError QUOTA)) + + deleteXFTPChunk c spKey sId1 + uploadXFTPChunk c spKey sId3 chunkSpec + download rId3