feat: add PostgreSQL INI config, store dispatch, startup validation

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

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'"