mirror of
https://github.com/simplex-chat/simplexmq.git
synced 2026-09-02 00:38:39 +00:00
279 lines
11 KiB
Haskell
279 lines
11 KiB
Haskell
{-# LANGUAGE CPP #-}
|
|
{-# LANGUAGE DataKinds #-}
|
|
{-# LANGUAGE DuplicateRecordFields #-}
|
|
{-# LANGUAGE FlexibleContexts #-}
|
|
{-# LANGUAGE GADTs #-}
|
|
{-# LANGUAGE KindSignatures #-}
|
|
{-# LANGUAGE RankNTypes #-}
|
|
{-# LANGUAGE LambdaCase #-}
|
|
{-# LANGUAGE NamedFieldPuns #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE StrictData #-}
|
|
{-# LANGUAGE TypeFamilies #-}
|
|
|
|
module Simplex.FileTransfer.Server.Env
|
|
( XFTPServerConfig (..),
|
|
XFTPStoreConfig (..),
|
|
XFTPEnv (..),
|
|
XFTPRequest (..),
|
|
XFTPStoreType,
|
|
FileStore (..),
|
|
AFStoreType (..),
|
|
fileStore,
|
|
fromFileStore,
|
|
defaultInactiveClientExpiration,
|
|
defFileExpirationHours,
|
|
defaultFileExpiration,
|
|
newXFTPServerEnv,
|
|
readFileStoreType,
|
|
runWithStoreConfig,
|
|
checkFileStoreMode,
|
|
importToDatabase,
|
|
exportFromDatabase,
|
|
) where
|
|
|
|
import Control.Logger.Simple
|
|
import Control.Monad
|
|
import Crypto.Random
|
|
import Data.Int (Int64)
|
|
import Data.List.NonEmpty (NonEmpty)
|
|
import Data.Map.Strict (Map)
|
|
import qualified Data.Map.Strict as M
|
|
import Data.Text (Text)
|
|
import Data.Time.Clock (getCurrentTime)
|
|
import Data.Word (Word32)
|
|
import Data.X509.Validation (Fingerprint (..))
|
|
import Network.Socket
|
|
import qualified Network.TLS as T
|
|
import Simplex.FileTransfer.Protocol (FileCmd, FileInfo (..), XFTPFileId)
|
|
import Simplex.Messaging.Crypto.Entitlement (EntitlementProof)
|
|
import Simplex.FileTransfer.Server.Stats
|
|
import Data.Either (fromRight)
|
|
import Data.Ini (Ini, lookupValue)
|
|
import qualified Data.Text as T
|
|
import Simplex.FileTransfer.Server.Store
|
|
import Simplex.Messaging.Agent.Store.Shared (MigrationConfirmation)
|
|
import Data.Functor (($>))
|
|
import Simplex.Messaging.Server.CLI (settingIsOn)
|
|
import System.Exit (exitFailure)
|
|
#if defined(dbServerPostgres)
|
|
import Data.Maybe (isNothing)
|
|
import Simplex.FileTransfer.Server.Store.Postgres (PostgresFileStore, importFileStore, exportFileStore)
|
|
import Simplex.FileTransfer.Server.Store.Postgres.Config (PostgresFileStoreCfg (..), defaultXFTPDBOpts)
|
|
import Simplex.Messaging.Server.CLI (iniDBOptions)
|
|
import System.Directory (doesFileExist)
|
|
#endif
|
|
import Simplex.FileTransfer.Server.StoreLog
|
|
import Simplex.FileTransfer.Transport (VersionRangeXFTP)
|
|
import qualified Simplex.Messaging.Crypto as C
|
|
import Simplex.Messaging.Protocol (BasicAuth, RcvPublicAuthKey)
|
|
import Simplex.Messaging.Server.Expiration
|
|
import Simplex.Messaging.Transport.Server (ServerCredentials (..), TransportServerConfig (..), loadFingerprint, loadServerCredential)
|
|
import Simplex.Messaging.Util (tshow)
|
|
import System.IO (IOMode (..))
|
|
import UnliftIO.STM
|
|
|
|
data XFTPServerConfig s = XFTPServerConfig
|
|
{ xftpPort :: ServiceName,
|
|
controlPort :: Maybe ServiceName,
|
|
fileIdSize :: Int,
|
|
serverStoreCfg :: XFTPStoreConfig s,
|
|
storeLogFile :: Maybe FilePath,
|
|
filesPath :: FilePath,
|
|
-- | server storage quota
|
|
fileSizeQuota :: Maybe Int64,
|
|
-- | allowed file chunk sizes
|
|
allowedChunkSizes :: [Word32],
|
|
-- | 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,
|
|
-- | control port passwords,
|
|
controlPortUserAuth :: Maybe BasicAuth,
|
|
controlPortAdminAuth :: Maybe BasicAuth,
|
|
-- | time after which the files can be removed and check interval, seconds
|
|
fileExpiration :: ExpirationConfig,
|
|
-- | maximum storage time per entitlement name, seconds
|
|
fileStorageEntitlements :: Map Text Int64,
|
|
-- | timeout to receive file
|
|
fileTimeout :: Int,
|
|
-- | time after which inactive clients can be disconnected and check interval, seconds
|
|
inactiveClientExpiration :: Maybe ExpirationConfig,
|
|
xftpCredentials :: ServerCredentials,
|
|
httpCredentials :: Maybe ServerCredentials,
|
|
-- | XFTP client-server protocol version range
|
|
xftpServerVRange :: VersionRangeXFTP,
|
|
-- stats config - see SMP server config
|
|
logStatsInterval :: Maybe Int64,
|
|
logStatsStartTime :: Int64,
|
|
serverStatsLogFile :: FilePath,
|
|
serverStatsBackupFile :: Maybe FilePath,
|
|
prometheusInterval :: Maybe Int,
|
|
prometheusMetricsFile :: FilePath,
|
|
transportConfig :: TransportServerConfig,
|
|
responseDelay :: Int,
|
|
webStaticPath :: Maybe FilePath
|
|
}
|
|
|
|
defaultInactiveClientExpiration :: ExpirationConfig
|
|
defaultInactiveClientExpiration =
|
|
ExpirationConfig
|
|
{ ttl = 21600, -- seconds, 6 hours
|
|
checkInterval = 3600 -- seconds, 1 hours
|
|
}
|
|
|
|
data XFTPEnv s = XFTPEnv
|
|
{ config :: XFTPServerConfig s,
|
|
store :: FileStore s,
|
|
usedStorage :: TVar Int64,
|
|
storeLog :: Maybe (StoreLog 'WriteMode),
|
|
random :: TVar ChaChaDRG,
|
|
serverIdentity :: C.KeyHash,
|
|
tlsServerCreds :: T.Credential,
|
|
httpServerCreds :: Maybe T.Credential,
|
|
serverStats :: FileServerStats
|
|
}
|
|
|
|
fileStore :: XFTPEnv s -> s
|
|
fileStore = fromFileStore . store
|
|
{-# INLINE fileStore #-}
|
|
|
|
data XFTPStoreConfig s where
|
|
XSCMemory :: Maybe FilePath -> XFTPStoreConfig STMFileStore
|
|
#if defined(dbServerPostgres)
|
|
XSCDatabase :: PostgresFileStoreCfg -> XFTPStoreConfig PostgresFileStore
|
|
#endif
|
|
|
|
type family XFTPStoreType (fs :: FSType) where
|
|
XFTPStoreType 'FSMemory = STMFileStore
|
|
#if defined(dbServerPostgres)
|
|
XFTPStoreType 'FSPostgres = PostgresFileStore
|
|
#endif
|
|
|
|
data FileStore s where
|
|
StoreMemory :: STMFileStore -> FileStore STMFileStore
|
|
#if defined(dbServerPostgres)
|
|
StoreDatabase :: PostgresFileStore -> FileStore PostgresFileStore
|
|
#endif
|
|
|
|
data AFStoreType = forall fs. AFSType (SFSType fs)
|
|
|
|
fromFileStore :: FileStore s -> s
|
|
fromFileStore = \case
|
|
StoreMemory s -> s
|
|
#if defined(dbServerPostgres)
|
|
StoreDatabase s -> s
|
|
#endif
|
|
{-# INLINE fromFileStore #-}
|
|
|
|
defFileExpirationHours :: Int64
|
|
defFileExpirationHours = 48
|
|
|
|
defaultFileExpiration :: ExpirationConfig
|
|
defaultFileExpiration =
|
|
ExpirationConfig
|
|
{ ttl = defFileExpirationHours * 3600, -- seconds
|
|
checkInterval = 2 * 3600 -- seconds, 2 hours
|
|
}
|
|
|
|
newXFTPServerEnv :: FileStoreClass s => XFTPServerConfig s -> IO (XFTPEnv s)
|
|
newXFTPServerEnv config@XFTPServerConfig {serverStoreCfg, fileSizeQuota, fileExpiration, fileStorageEntitlements, xftpCredentials, httpCredentials} = do
|
|
let defaultMax = ttl fileExpiration
|
|
unless (all (>= defaultMax) (M.elems fileStorageEntitlements)) $ do
|
|
logError "STORE: entitlement storage time is below the default file expiration"
|
|
exitFailure
|
|
random <- C.newRandom
|
|
(store, storeLog) <- case serverStoreCfg of
|
|
XSCMemory storeLogPath -> do
|
|
st <- newFileStore ()
|
|
sl <- mapM (`readWriteFileStore` st) storeLogPath
|
|
atomically $ writeTVar (stmStoreLog st) sl
|
|
pure (StoreMemory st, sl)
|
|
#if defined(dbServerPostgres)
|
|
XSCDatabase dbCfg -> do
|
|
st <- newFileStore dbCfg
|
|
pure (StoreDatabase st, Nothing)
|
|
#endif
|
|
used <- getUsedStorage (fromFileStore store)
|
|
usedStorage <- newTVarIO used
|
|
forM_ fileSizeQuota $ \quota -> do
|
|
logNote $ "Total / available storage: " <> tshow quota <> " / " <> tshow (quota - used)
|
|
when (quota < used) $ logWarn "WARNING: storage quota is less than used storage, no files can be uploaded!"
|
|
tlsServerCreds <- loadServerCredential xftpCredentials
|
|
httpServerCreds <- mapM loadServerCredential httpCredentials
|
|
Fingerprint fp <- loadFingerprint xftpCredentials
|
|
serverStats <- newFileServerStats =<< getCurrentTime
|
|
pure XFTPEnv {config, store, usedStorage, storeLog, random, tlsServerCreds, httpServerCreds, serverIdentity = C.KeyHash fp, serverStats}
|
|
|
|
data XFTPRequest
|
|
= XFTPReqNew FileInfo (NonEmpty RcvPublicAuthKey) (Maybe BasicAuth) (Maybe Int64) (Maybe EntitlementProof)
|
|
| XFTPReqCmd XFTPFileId FileRec FileCmd
|
|
| XFTPReqPing
|
|
|
|
readFileStoreType :: Ini -> Either String AFStoreType
|
|
readFileStoreType ini = case fromRight "memory" $ T.unpack <$> lookupValue "STORE_LOG" "store_files" ini of
|
|
"memory" -> Right $ AFSType SFSMemory
|
|
"database" -> Right $ AFSType SFSPostgres
|
|
other -> Left $ "Invalid store_files value: " <> other
|
|
|
|
-- | Dispatch store config from AFStoreType singleton and run the callback.
|
|
-- CPP guards for Postgres are handled here so Main.hs stays CPP-free.
|
|
runWithStoreConfig ::
|
|
AFStoreType ->
|
|
Ini ->
|
|
FilePath ->
|
|
MigrationConfirmation ->
|
|
(forall s. FileStoreClass s => XFTPStoreConfig s -> IO ()) ->
|
|
IO ()
|
|
runWithStoreConfig (AFSType SFSMemory) ini storeLogFilePath _confirmMigrations run =
|
|
run $ XSCMemory (enableStoreLog' $> storeLogFilePath)
|
|
where
|
|
enableStoreLog' = settingIsOn "STORE_LOG" "enable" ini
|
|
runWithStoreConfig (AFSType SFSPostgres) ini storeLogFilePath confirmMigrations run =
|
|
#if defined(dbServerPostgres)
|
|
run $ XSCDatabase dbCfg
|
|
where
|
|
enableDbStoreLog' = settingIsOn "STORE_LOG" "db_store_log" ini
|
|
dbStoreLogPath = enableDbStoreLog' $> storeLogFilePath
|
|
dbCfg = PostgresFileStoreCfg {dbOpts = iniDBOptions ini defaultXFTPDBOpts, dbStoreLogPath, confirmMigrations}
|
|
#else
|
|
error "server binary is compiled without support for PostgreSQL database"
|
|
#endif
|
|
|
|
-- | Validate startup config when store_files=database.
|
|
checkFileStoreMode :: Ini -> AFStoreType -> FilePath -> IO ()
|
|
checkFileStoreMode ini (AFSType SFSPostgres) storeLogFilePath = do
|
|
#if defined(dbServerPostgres)
|
|
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
|
|
#else
|
|
putStrLn "Error: server binary is compiled without support for PostgreSQL database."
|
|
putStrLn "Please re-compile with `cabal build -fserver_postgres`."
|
|
exitFailure
|
|
#endif
|
|
checkFileStoreMode _ (AFSType SFSMemory) _ = pure ()
|
|
|
|
-- | Import StoreLog to PostgreSQL database.
|
|
importToDatabase :: FilePath -> Ini -> MigrationConfirmation -> IO ()
|
|
#if defined(dbServerPostgres)
|
|
importToDatabase storeLogFilePath ini _confirmMigrations = do
|
|
let dbCfg = PostgresFileStoreCfg {dbOpts = iniDBOptions ini defaultXFTPDBOpts, dbStoreLogPath = Nothing, confirmMigrations = _confirmMigrations}
|
|
importFileStore storeLogFilePath dbCfg
|
|
#else
|
|
importToDatabase _ _ _ = error "Error: server binary is compiled without support for PostgreSQL database.\nPlease re-compile with `cabal build -fserver_postgres`."
|
|
#endif
|
|
|
|
-- | Export PostgreSQL database to StoreLog.
|
|
exportFromDatabase :: FilePath -> Ini -> MigrationConfirmation -> IO ()
|
|
#if defined(dbServerPostgres)
|
|
exportFromDatabase storeLogFilePath ini _confirmMigrations = do
|
|
let dbCfg = PostgresFileStoreCfg {dbOpts = iniDBOptions ini defaultXFTPDBOpts, dbStoreLogPath = Nothing, confirmMigrations = _confirmMigrations}
|
|
exportFileStore storeLogFilePath dbCfg
|
|
#else
|
|
exportFromDatabase _ _ _ = error "Error: server binary is compiled without support for PostgreSQL database.\nPlease re-compile with `cabal build -fserver_postgres`."
|
|
#endif
|