diff --git a/src/Simplex/FileTransfer/Server/Env.hs b/src/Simplex/FileTransfer/Server/Env.hs index 3a09f3143..e5289ecb6 100644 --- a/src/Simplex/FileTransfer/Server/Env.hs +++ b/src/Simplex/FileTransfer/Server/Env.hs @@ -3,6 +3,7 @@ {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE KindSignatures #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} @@ -17,6 +18,8 @@ module Simplex.FileTransfer.Server.Env defFileExpirationHours, defaultFileExpiration, newXFTPServerEnv, + runWithStoreConfig, + checkFileStoreMode, ) where import Control.Logger.Simple @@ -31,11 +34,17 @@ import Network.Socket import qualified Network.TLS as T import Simplex.FileTransfer.Protocol (FileCmd, FileInfo (..), XFTPFileId) import Simplex.FileTransfer.Server.Stats +import Data.Ini (Ini) import Simplex.FileTransfer.Server.Store import Simplex.FileTransfer.Server.Store.STM (STMFileStore (..)) +import Simplex.Messaging.Agent.Store.Shared (MigrationConfirmation) #if defined(dbServerPostgres) +import Data.Functor (($>)) import Simplex.FileTransfer.Server.Store.Postgres (PostgresFileStore) -import Simplex.FileTransfer.Server.Store.Postgres.Config (PostgresFileStoreCfg) +import Simplex.FileTransfer.Server.Store.Postgres.Config (PostgresFileStoreCfg (..), defaultXFTPDBOpts) +import Simplex.Messaging.Server.CLI (iniDBOptions, settingIsOn) +import System.Directory (doesFileExist) +import System.Exit (exitFailure) #endif import Simplex.FileTransfer.Server.StoreLog import Simplex.FileTransfer.Transport (VersionRangeXFTP) @@ -149,3 +158,45 @@ data XFTPRequest = XFTPReqNew FileInfo (NonEmpty RcvPublicAuthKey) (Maybe BasicAuth) | XFTPReqCmd XFTPFileId FileRec FileCmd | XFTPReqPing + +-- | Select and run the store config based on INI settings. +-- CPP guards for Postgres are handled here so Main.hs stays CPP-free. +runWithStoreConfig :: + Ini -> + String -> + Maybe FilePath -> + FilePath -> + MigrationConfirmation -> + (forall s. FileStoreClass s => XFTPStoreConfig s -> IO ()) -> + IO () +runWithStoreConfig _ini storeType storeLogFile_ _storeLogFilePath _confirmMigrations run = case storeType of + "memory" -> run $ XSCMemory storeLogFile_ +#if defined(dbServerPostgres) + "database" -> run $ XSCDatabase dbCfg + where + enableDbStoreLog' = settingIsOn "STORE_LOG" "db_store_log" _ini + dbStoreLogPath = enableDbStoreLog' $> _storeLogFilePath + dbCfg = PostgresFileStoreCfg {dbOpts = iniDBOptions _ini defaultXFTPDBOpts, dbStoreLogPath, confirmMigrations = _confirmMigrations} +#else + "database" -> error "Error: server binary is compiled without support for PostgreSQL database.\nPlease re-compile with `cabal build -fserver_postgres`." +#endif + _ -> error $ "Invalid store_files value: " <> storeType + +-- | Validate startup config when store_files=database. +checkFileStoreMode :: Ini -> String -> FilePath -> IO () +#if defined(dbServerPostgres) +checkFileStoreMode ini storeType storeLogFilePath = case storeType of + "database" -> do + storeLogExists <- doesFileExist storeLogFilePath + let dbStoreLogOn = settingIsOn "STORE_LOG" "db_store_log" ini + when (storeLogExists && isNothing_ dbStoreLogOn) $ do + putStrLn $ "Error: store log file " <> storeLogFilePath <> " exists but store_files is `database`." + putStrLn "Use `file-server database import` to migrate, or set `db_store_log: on`." + exitFailure + _ -> pure () + where + isNothing_ Nothing = True + isNothing_ _ = False +#else +checkFileStoreMode _ _ _ = pure () +#endif diff --git a/src/Simplex/FileTransfer/Server/Main.hs b/src/Simplex/FileTransfer/Server/Main.hs index 42c53d32c..f39825aa3 100644 --- a/src/Simplex/FileTransfer/Server/Main.hs +++ b/src/Simplex/FileTransfer/Server/Main.hs @@ -28,11 +28,12 @@ import Options.Applicative import Simplex.FileTransfer.Chunks import Simplex.FileTransfer.Description (FileSize (..)) import Simplex.FileTransfer.Server (runXFTPServer) -import Simplex.FileTransfer.Server.Env (XFTPServerConfig (..), XFTPStoreConfig (..), defFileExpirationHours, defaultFileExpiration, defaultInactiveClientExpiration) +import Simplex.FileTransfer.Server.Env (XFTPServerConfig (..), defFileExpirationHours, defaultFileExpiration, defaultInactiveClientExpiration, runWithStoreConfig, checkFileStoreMode) import Simplex.FileTransfer.Transport (alpnSupportedXFTPhandshakes, supportedFileServerVRange) import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Encoding.String import Simplex.Messaging.Protocol (ProtoServerWithAuth (..), pattern XFTPServer) +import Simplex.Messaging.Agent.Store.Shared (MigrationConfirmation (..)) import Simplex.Messaging.Server.CLI import Simplex.Messaging.Server.Expiration import Simplex.Messaging.Server.Information (ServerPublicInfo (..)) @@ -66,9 +67,9 @@ xftpServerCLI_ generateSite serveStaticFiles cfgPath logPath = do doesFileExist iniFile >>= \case True -> genOnline cfgPath certOpts _ -> exitError $ "Error: server is not initialized (" <> iniFile <> " does not exist).\nRun `" <> executableName <> " init`." - Start -> + Start opts -> doesFileExist iniFile >>= \case - True -> readIniFile iniFile >>= either exitError runServer + True -> readIniFile iniFile >>= either exitError (runServer opts) _ -> exitError $ "Error: server is not initialized (" <> iniFile <> " does not exist).\nRun `" <> executableName <> " init`." Delete -> do confirmOrExit @@ -126,6 +127,14 @@ xftpServerCLI_ generateSite serveStaticFiles 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") + <> "# File storage mode: `memory` or `database` (PostgreSQL).\n\ + \store_files: memory\n\n\ + \# Database connection settings for PostgreSQL database (`store_files: database`).\n\ + \# db_connection: postgresql://xftp@/xftp_server_store\n\ + \# db_schema: xftp_server\n\ + \# db_pool_size: 10\n\n\ + \# Write database changes to store log file\n\ + \# db_store_log: off\n\n" <> "# Expire files after the specified number of hours.\n" <> ("expire_files_hours: " <> tshow defFileExpirationHours <> "\n\n") <> "log_stats: off\n\ @@ -173,7 +182,7 @@ xftpServerCLI_ generateSite serveStaticFiles cfgPath logPath = do \# TLS credentials for HTTPS web server on the same port as XFTP.\n\ \# cert: " <> T.pack (cfgPath `combine` "web.crt") <> "\n\ \# key: " <> T.pack (cfgPath `combine` "web.key") <> "\n" - runServer ini = do + runServer StartOptions {confirmMigrations} ini = do hSetBuffering stdout LineBuffering hSetBuffering stderr LineBuffering fp <- checkSavedFingerprint cfgPath defaultX509Config @@ -194,8 +203,10 @@ xftpServerCLI_ generateSite serveStaticFiles cfgPath logPath = do when (isJust webHttpPort || isJust webHttpsParams') $ serveStaticFiles EmbeddedWebParams {webStaticPath = path, webHttpPort, webHttpsParams = webHttpsParams'} Nothing -> pure () - let storeCfg = XSCMemory $ storeLogFile serverConfig - runXFTPServer storeCfg serverConfig + let storeType = fromRight "memory" $ T.unpack <$> lookupValue "STORE_LOG" "store_files" ini + checkFileStoreMode ini storeType storeLogFilePath + runWithStoreConfig ini storeType (storeLogFile serverConfig) storeLogFilePath confirmMigrations $ + \storeCfg -> runXFTPServer storeCfg serverConfig where isOnion = \case THOnionHost _ -> True; _ -> False enableStoreLog = settingIsOn "STORE_LOG" "enable" ini @@ -290,9 +301,13 @@ xftpServerCLI_ generateSite serveStaticFiles cfgPath logPath = do data CliCommand = Init InitOptions | OnlineCert CertOptions - | Start + | Start StartOptions | Delete +newtype StartOptions = StartOptions + { confirmMigrations :: MigrationConfirmation + } + data InitOptions = InitOptions { enableStoreLog :: Bool, signAlgorithm :: SignAlgorithm, @@ -309,7 +324,7 @@ cliCommandP cfgPath logPath iniFile = hsubparser ( command "init" (info (Init <$> initP) (progDesc $ "Initialize server - creates " <> cfgPath <> " and " <> logPath <> " directories and configuration files")) <> command "cert" (info (OnlineCert <$> certOptionsP) (progDesc $ "Generate new online TLS server credentials (configuration: " <> iniFile <> ")")) - <> command "start" (info (pure Start) (progDesc $ "Start server (configuration: " <> iniFile <> ")")) + <> command "start" (info (Start <$> startOptsP) (progDesc $ "Start server (configuration: " <> iniFile <> ")")) <> command "delete" (info (pure Delete) (progDesc "Delete configuration and log files")) ) where @@ -376,3 +391,20 @@ cliCommandP cfgPath logPath iniFile = <> metavar "PATH" ) pure InitOptions {enableStoreLog, signAlgorithm, ip, fqdn, filesPath, fileSizeQuota, webStaticPath} + startOptsP :: Parser StartOptions + startOptsP = do + confirmMigrations <- + option + parseConfirmMigrations + ( long "confirm-migrations" + <> metavar "CONFIRM_MIGRATIONS" + <> help "Confirm PostgreSQL database migration: up, down (default is manual confirmation)" + <> value MCConsole + ) + pure StartOptions {confirmMigrations} + where + parseConfirmMigrations :: ReadM MigrationConfirmation + parseConfirmMigrations = eitherReader $ \case + "up" -> Right MCYesUp + "down" -> Right MCYesUpDown + _ -> Left "invalid migration confirmation, pass 'up' or 'down'"