Files
simplexmq/src/Simplex/FileTransfer/Server/Main.hs
T
sh 1e1f897c79 core: use = as INI key-value separator (#1767)
* core: use = as INI key-value separator

* core: update docker entrypoints for = INI separator

* core: update INI separator in README and test scripts
2026-04-20 09:22:14 +01:00

440 lines
21 KiB
Haskell

{-# LANGUAGE ApplicativeDo #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeApplications #-}
module Simplex.FileTransfer.Server.Main
( xftpServerCLI,
xftpServerCLI_,
) where
import Control.Monad (unless, when)
import Data.Either (fromRight)
import Data.Functor (($>))
import Data.Ini (lookupValue, readIniFile)
import Data.Int (Int64)
import Data.List (find)
import qualified Data.List.NonEmpty as L
import Data.Maybe (fromMaybe, isJust)
import Data.Text.Encoding (encodeUtf8)
import qualified Data.Text as T
import qualified Data.Text.IO as T
import Network.Socket (HostName)
import Options.Applicative
import Simplex.FileTransfer.Chunks
import Simplex.FileTransfer.Description (FileSize (..))
import Simplex.FileTransfer.Server (runXFTPServer)
import Simplex.FileTransfer.Server.Env (XFTPServerConfig (..), XFTPStoreConfig, AFStoreType (..), defFileExpirationHours, defaultFileExpiration, defaultInactiveClientExpiration, readFileStoreType, runWithStoreConfig, checkFileStoreMode, importToDatabase, exportFromDatabase)
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 (..))
import Simplex.Messaging.Server.Main (serverPublicInfo, printSourceCode)
import Simplex.Messaging.Server.Web (EmbeddedWebParams (..), WebHttpsParams (..))
import Simplex.Messaging.Transport.Client (TransportHost (..))
import Simplex.Messaging.Transport.HTTP2 (httpALPN)
import Simplex.Messaging.Transport.Server (ServerCredentials (..), TransportServerConfig (..), mkTransportServerConfig)
import Simplex.Messaging.Util (eitherToMaybe, safeDecodeUtf8, tshow)
import System.Directory (createDirectoryIfMissing, doesFileExist)
import System.FilePath (combine)
import System.IO (BufferMode (..), hSetBuffering, stderr, stdout)
import Text.Read (readMaybe)
xftpServerCLI :: FilePath -> FilePath -> IO ()
xftpServerCLI = xftpServerCLI_ (\_ _ _ _ -> pure ()) (\_ -> pure ())
xftpServerCLI_ ::
(forall s. XFTPServerConfig s -> Maybe ServerPublicInfo -> Maybe TransportHost -> FilePath -> IO ()) ->
(EmbeddedWebParams -> IO ()) ->
FilePath ->
FilePath ->
IO ()
xftpServerCLI_ generateSite serveStaticFiles cfgPath logPath = do
getCliCommand' (cliCommandP cfgPath logPath iniFile) serverVersion >>= \case
Init opts ->
doesFileExist iniFile >>= \case
True -> exitError $ "Error: server is already initialized (" <> iniFile <> " exists).\nRun `" <> executableName <> " start`."
_ -> initializeServer opts
OnlineCert certOpts ->
doesFileExist iniFile >>= \case
True -> genOnline cfgPath certOpts
_ -> exitError $ "Error: server is not initialized (" <> iniFile <> " does not exist).\nRun `" <> executableName <> " init`."
Start opts ->
doesFileExist iniFile >>= \case
True -> readIniFile iniFile >>= either exitError (runServer opts)
_ -> exitError $ "Error: server is not initialized (" <> iniFile <> " does not exist).\nRun `" <> executableName <> " init`."
Database cmd ->
doesFileExist iniFile >>= \case
True -> readIniFile iniFile >>= either exitError (runDatabaseCmd cmd)
_ -> exitError $ "Error: server is not initialized (" <> iniFile <> " does not exist).\nRun `" <> executableName <> " init`."
Delete -> do
confirmOrExit
"WARNING: deleting the server will make all queues inaccessible, because the server identity (certificate fingerprint) will change.\nTHIS CANNOT BE UNDONE!"
"Server NOT deleted"
deleteDirIfExists cfgPath
deleteDirIfExists logPath
putStrLn "Deleted configuration and log files"
where
iniFile = combine cfgPath "file-server.ini"
serverVersion = "SimpleX XFTP server v" <> simplexmqVersionCommit
defaultServerPort = "443"
executableName = "file-server"
storeLogFilePath = combine logPath "file-server-store.log"
defaultStaticPath = combine logPath "www"
runDatabaseCmd cmd ini = case cmd of
SCImport -> do
storeLogExists <- doesFileExist storeLogFilePath
unless storeLogExists $ exitError $ "Error: store log file " <> storeLogFilePath <> " does not exist."
confirmOrExit
("Import store log " <> storeLogFilePath <> " to PostgreSQL database?")
"Import cancelled."
importToDatabase storeLogFilePath ini MCYesUp
SCExport -> do
storeLogExists <- doesFileExist storeLogFilePath
when storeLogExists $ exitError $ "Error: store log file " <> storeLogFilePath <> " already exists."
confirmOrExit
("Export PostgreSQL database to store log " <> storeLogFilePath <> "?")
"Export cancelled."
exportFromDatabase storeLogFilePath ini MCConsole
initializeServer InitOptions {enableStoreLog, signAlgorithm, ip, fqdn, filesPath, fileSizeQuota, webStaticPath = webStaticPath_} = do
clearDirIfExists cfgPath
clearDirIfExists logPath
createDirectoryIfMissing True cfgPath
createDirectoryIfMissing True logPath
let x509cfg = defaultX509Config {commonName = fromMaybe ip fqdn, signAlgorithm}
fp <- createServerX509 cfgPath x509cfg
let host = fromMaybe (if ip == "127.0.0.1" then "<hostnames>" else ip) fqdn
srv = ProtoServerWithAuth (XFTPServer [THDomainName host] "" (C.KeyHash fp)) Nothing
T.writeFile iniFile $ iniFileContent host
putStrLn $ "Server initialized, you can modify configuration in " <> iniFile <> ".\nRun `" <> executableName <> " start` to start server."
warnCAPrivateKeyFile cfgPath x509cfg
printServiceInfo serverVersion srv
where
iniFileContent host =
"[INFORMATION]\n\
\# AGPLv3 license requires that you make any source code modifications\n\
\# available to the end users of the server.\n\
\# LICENSE: https://github.com/simplex-chat/simplexmq/blob/stable/LICENSE\n\
\# Include correct source code URI in case the server source code is modified in any way.\n\
\# source_code = https://github.com/simplex-chat/simplexmq\n\
\\n\
\# Declaring all below information is optional, any of these fields can be omitted.\n\
\# server_country = ISO-3166 2-letter code\n\
\# operator = entity (organization or person name)\n\
\# operator_country = ISO-3166 2-letter code\n\
\# website =\n\
\# admin_simplex = SimpleX address\n\
\# admin_email =\n\
\# complaints_simplex = SimpleX address\n\
\# complaints_email =\n\
\# hosting = entity (organization or person name)\n\
\# hosting_country = ISO-3166 2-letter code\n\
\# hosting_type = virtual\n\
\\n\
\[STORE_LOG]\n\
\# The server uses STM memory for persistence,\n\
\# that will be lost on restart (e.g., as with redis).\n\
\# This option enables saving memory to append only log,\n\
\# 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\
\\n\
\# Log interval for real-time Prometheus metrics\n\
\# prometheus_interval = 60\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\
\# control_port_admin_password =\n\
\# control_port_user_password =\n\
\\n\
\[TRANSPORT]\n\
\# host is only used to print server address on start\n"
<> ("host = " <> T.pack host <> "\n")
<> ("port = " <> T.pack defaultServerPort <> "\n")
<> "log_tls_errors = off\n\
\# control_port = 5226\n\
\\n\
\[FILES]\n"
<> ("path = " <> T.pack filesPath <> "\n")
<> ("storage_quota = " <> safeDecodeUtf8 (strEncode fileSizeQuota) <> "\n")
<> "\n\
\[INACTIVE_CLIENTS]\n\
\# TTL and interval to check inactive clients\n\
\disconnect = off\n"
<> ("# ttl = " <> tshow (ttl defaultInactiveClientExpiration) <> "\n")
<> ("# check_interval = " <> tshow (checkInterval defaultInactiveClientExpiration) <> "\n")
<> "\n\
\[WEB]\n\
\# Set path to generate static mini-site for server information\n"
<> ("static_path = " <> T.pack (fromMaybe defaultStaticPath webStaticPath_) <> "\n\n")
<> "# Run an embedded HTTP server on this port.\n\
\# http = 8000\n\n\
\# 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 StartOptions {confirmMigrations} 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
srv = ProtoServerWithAuth (XFTPServer [THDomainName host] (if port == "443" then "" else port) (C.KeyHash fp)) Nothing
printServiceInfo serverVersion srv
let information = serverPublicInfo ini
printSourceCode (sourceCode <$> information)
case readFileStoreType ini of
Left err -> error err
Right fsType -> do
checkFileStoreMode ini fsType storeLogFilePath
runWithStoreConfig fsType ini storeLogFilePath confirmMigrations $ \storeCfg -> do
let cfg = serverConfig storeCfg
printXFTPConfig cfg
case webStaticPath' of
Just path -> do
let onionHost =
either (const Nothing) (find isOnion) $
strDecode @(L.NonEmpty TransportHost) . encodeUtf8 =<< lookupValue "TRANSPORT" "host" ini
webHttpPort = eitherToMaybe (lookupValue "WEB" "http" ini) >>= readMaybe . T.unpack
generateSite cfg information onionHost path
when (isJust webHttpPort || isJust webHttpsParams') $
serveStaticFiles EmbeddedWebParams {webStaticPath = path, webHttpPort, webHttpsParams = webHttpsParams'}
Nothing -> pure ()
runXFTPServer cfg
where
isOnion = \case THOnionHost _ -> True; _ -> False
enableStoreLog = settingIsOn "STORE_LOG" "enable" ini
logStats = settingIsOn "STORE_LOG" "log_stats" ini
c = combine cfgPath . ($ defaultX509Config)
printXFTPConfig XFTPServerConfig {allowNewFiles, newFileBasicAuth, xftpPort, storeLogFile, fileExpiration, inactiveClientExpiration} = do
putStrLn $ case storeLogFile of
Just f -> "Store log: " <> f
_ -> "Store log disabled."
putStrLn $ case fileExpiration of
Just ExpirationConfig {ttl} -> "expiring files after " <> showTTL ttl
_ -> "not expiring files"
putStrLn $ case inactiveClientExpiration of
Just ExpirationConfig {ttl, checkInterval} -> "expiring clients inactive for " <> show ttl <> " seconds every " <> show checkInterval <> " seconds"
_ -> "not expiring inactive clients"
putStrLn $
"Uploading new files "
<> if allowNewFiles
then maybe "allowed." (const "requires password.") newFileBasicAuth
else "NOT allowed."
putStrLn $ "Listening on port " <> xftpPort <> "..."
httpCredentials_ =
eitherToMaybe $ do
cert <- T.unpack <$> lookupValue "WEB" "cert" ini
key <- T.unpack <$> lookupValue "WEB" "key" ini
pure
ServerCredentials
{ caCertificateFile = Nothing,
certificateFile = cert,
privateKeyFile = key
}
webHttpsParams' = do
httpsPort <- eitherToMaybe (lookupValue "WEB" "https" ini) >>= readMaybe . T.unpack
cert <- eitherToMaybe $ T.unpack <$> lookupValue "WEB" "cert" ini
key <- eitherToMaybe $ T.unpack <$> lookupValue "WEB" "key" ini
pure WebHttpsParams {port = httpsPort, cert, key}
webStaticPath' = eitherToMaybe $ T.unpack <$> lookupValue "WEB" "static_path" ini
serverConfig :: XFTPStoreConfig s -> XFTPServerConfig s
serverConfig serverStoreCfg =
XFTPServerConfig
{ xftpPort = T.unpack $ strictIni "TRANSPORT" "port" ini,
controlPort = either (const Nothing) (Just . T.unpack) $ lookupValue "TRANSPORT" "control_port" ini,
fileIdSize = 16,
serverStoreCfg,
storeLogFile = enableStoreLog $> storeLogFilePath,
filesPath = T.unpack $ strictIni "FILES" "path" ini,
fileSizeQuota = either error unFileSize <$> strDecodeIni "FILES" "storage_quota" ini,
allowedChunkSizes = serverChunkSizes,
allowNewFiles = fromMaybe True $ iniOnOff "AUTH" "new_files" ini,
newFileBasicAuth = either error id <$> strDecodeIni "AUTH" "create_password" ini,
controlPortAdminAuth = either error id <$> strDecodeIni "AUTH" "control_port_admin_password" ini,
controlPortUserAuth = either error id <$> strDecodeIni "AUTH" "control_port_user_password" ini,
fileExpiration =
Just
defaultFileExpiration
{ ttl = 3600 * readIniDefault defFileExpirationHours "STORE_LOG" "expire_files_hours" ini
},
fileTimeout = 5 * 60 * 1000000, -- 5 mins to send 4mb chunk
inactiveClientExpiration =
settingIsOn "INACTIVE_CLIENTS" "disconnect" ini
$> ExpirationConfig
{ ttl = readStrictIni "INACTIVE_CLIENTS" "ttl" ini,
checkInterval = readStrictIni "INACTIVE_CLIENTS" "check_interval" ini
},
xftpCredentials =
ServerCredentials
{ caCertificateFile = Just $ c caCrtFile,
privateKeyFile = c serverKeyFile,
certificateFile = c serverCrtFile
},
httpCredentials = httpCredentials_,
xftpServerVRange = supportedFileServerVRange,
logStatsInterval = logStats $> 86400, -- seconds
logStatsStartTime = 0, -- seconds from 00:00 UTC
serverStatsLogFile = combine logPath "file-server-stats.daily.log",
serverStatsBackupFile = logStats $> combine logPath "file-server-stats.log",
prometheusInterval = eitherToMaybe (lookupValue "STORE_LOG" "prometheus_interval" ini) >>= readMaybe . T.unpack,
prometheusMetricsFile = combine logPath "xftp-server-metrics.txt",
transportConfig =
let cfg =
mkTransportServerConfig
(fromMaybe False $ iniOnOff "TRANSPORT" "log_tls_errors" ini)
(Just $ alpnSupportedXFTPhandshakes <> httpALPN)
False
in cfg {addCORSHeaders = isJust httpCredentials_},
responseDelay = 0,
webStaticPath = webStaticPath'
}
data CliCommand
= Init InitOptions
| OnlineCert CertOptions
| Start StartOptions
| Database StoreCmd
| Delete
data StoreCmd = SCImport | SCExport
newtype StartOptions = StartOptions
{ confirmMigrations :: MigrationConfirmation
}
data InitOptions = InitOptions
{ enableStoreLog :: Bool,
signAlgorithm :: SignAlgorithm,
ip :: HostName,
fqdn :: Maybe HostName,
filesPath :: FilePath,
fileSizeQuota :: FileSize Int64,
webStaticPath :: Maybe FilePath
}
deriving (Show)
cliCommandP :: FilePath -> FilePath -> FilePath -> Parser CliCommand
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 (Start <$> startOptsP) (progDesc $ "Start server (configuration: " <> iniFile <> ")"))
<> command "database" (info (Database <$> storeCmdP) (progDesc "Import/export file store to/from PostgreSQL database"))
<> command "delete" (info (pure Delete) (progDesc "Delete configuration and log files"))
)
where
initP :: Parser InitOptions
initP = do
enableStoreLog <-
flag'
False
( long "disable-store-log"
<> help "Disable store log for persistence (enabled by default)"
)
<|> flag
True
True
( long "store-log"
<> short 'l'
<> help "Enable store log for persistence (DEPRECATED, enabled by default)"
)
signAlgorithm <-
option
(maybeReader readMaybe)
( long "sign-algorithm"
<> short 'a'
<> help "Signature algorithm used for TLS certificates: ED25519, ED448"
<> value ED448
<> showDefault
<> metavar "ALG"
)
ip <-
strOption
( long "ip"
<> help
"Server IP address, used as Common Name for TLS online certificate if FQDN is not supplied"
<> value "127.0.0.1"
<> showDefault
<> metavar "IP"
)
fqdn <-
(optional . strOption)
( long "fqdn"
<> short 'n'
<> help "Server FQDN used as Common Name for TLS online certificate"
<> showDefault
<> metavar "FQDN"
)
filesPath <-
strOption
( long "path"
<> short 'p'
<> help "Path to the directory to store files"
<> metavar "PATH"
)
fileSizeQuota <-
strOption
( long "quota"
<> short 'q'
<> help "File storage quota (e.g. 100gb)"
<> metavar "QUOTA"
)
webStaticPath <-
(optional . strOption)
( long "web-path"
<> help "Directory to store generated static site with server information"
<> 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}
storeCmdP :: Parser StoreCmd
storeCmdP =
hsubparser
( command "import" (info (pure SCImport) (progDesc "Import store log file into PostgreSQL database"))
<> command "export" (info (pure SCExport) (progDesc "Export PostgreSQL database to store log file"))
)