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/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

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 "<hostnames>" $ 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,

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

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