{-# 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.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.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
{ forall s. XFTPServerConfig s -> String
xftpPort :: ServiceName,
forall s. XFTPServerConfig s -> Maybe String
controlPort :: Maybe ServiceName,
forall s. XFTPServerConfig s -> Int
fileIdSize :: Int,
forall s. XFTPServerConfig s -> XFTPStoreConfig s
serverStoreCfg :: XFTPStoreConfig s,
forall s. XFTPServerConfig s -> Maybe String
storeLogFile :: Maybe FilePath,
forall s. XFTPServerConfig s -> String
filesPath :: FilePath,
forall s. XFTPServerConfig s -> Maybe Int64
fileSizeQuota :: Maybe Int64,
forall s. XFTPServerConfig s -> [Word32]
allowedChunkSizes :: [Word32],
forall s. XFTPServerConfig s -> Bool
allowNewFiles :: Bool,
forall s. XFTPServerConfig s -> Maybe BasicAuth
newFileBasicAuth :: Maybe BasicAuth,
forall s. XFTPServerConfig s -> Maybe BasicAuth
controlPortUserAuth :: Maybe BasicAuth,
forall s. XFTPServerConfig s -> Maybe BasicAuth
controlPortAdminAuth :: Maybe BasicAuth,
forall s. XFTPServerConfig s -> Maybe ExpirationConfig
fileExpiration :: Maybe ExpirationConfig,
forall s. XFTPServerConfig s -> Int
fileTimeout :: Int,
forall s. XFTPServerConfig s -> Maybe ExpirationConfig
inactiveClientExpiration :: Maybe ExpirationConfig,
forall s. XFTPServerConfig s -> ServerCredentials
xftpCredentials :: ServerCredentials,
forall s. XFTPServerConfig s -> Maybe ServerCredentials
httpCredentials :: Maybe ServerCredentials,
forall s. XFTPServerConfig s -> VersionRangeXFTP
xftpServerVRange :: VersionRangeXFTP,
forall s. XFTPServerConfig s -> Maybe Int64
logStatsInterval :: Maybe Int64,
forall s. XFTPServerConfig s -> Int64
logStatsStartTime :: Int64,
forall s. XFTPServerConfig s -> String
serverStatsLogFile :: FilePath,
forall s. XFTPServerConfig s -> Maybe String
serverStatsBackupFile :: Maybe FilePath,
forall s. XFTPServerConfig s -> Maybe Int
prometheusInterval :: Maybe Int,
forall s. XFTPServerConfig s -> String
prometheusMetricsFile :: FilePath,
forall s. XFTPServerConfig s -> TransportServerConfig
transportConfig :: TransportServerConfig,
forall s. XFTPServerConfig s -> Int
responseDelay :: Int,
forall s. XFTPServerConfig s -> Maybe String
webStaticPath :: Maybe FilePath
}
defaultInactiveClientExpiration :: ExpirationConfig
defaultInactiveClientExpiration :: ExpirationConfig
defaultInactiveClientExpiration =
ExpirationConfig
{ ttl :: Int64
ttl = Int64
21600,
checkInterval :: Int64
checkInterval = Int64
3600
}
data XFTPEnv s = XFTPEnv
{ forall s. XFTPEnv s -> XFTPServerConfig s
config :: XFTPServerConfig s,
forall s. XFTPEnv s -> FileStore s
store :: FileStore s,
forall s. XFTPEnv s -> TVar Int64
usedStorage :: TVar Int64,
forall s. XFTPEnv s -> Maybe (StoreLog 'WriteMode)
storeLog :: Maybe (StoreLog 'WriteMode),
forall s. XFTPEnv s -> TVar ChaChaDRG
random :: TVar ChaChaDRG,
forall s. XFTPEnv s -> KeyHash
serverIdentity :: C.KeyHash,
forall s. XFTPEnv s -> Credential
tlsServerCreds :: T.Credential,
forall s. XFTPEnv s -> Maybe Credential
httpServerCreds :: Maybe T.Credential,
forall s. XFTPEnv s -> FileServerStats
serverStats :: FileServerStats
}
fileStore :: XFTPEnv s -> s
fileStore :: forall s. XFTPEnv s -> s
fileStore = FileStore s -> s
forall s. FileStore s -> s
fromFileStore (FileStore s -> s) -> (XFTPEnv s -> FileStore s) -> XFTPEnv s -> s
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XFTPEnv s -> FileStore s
forall s. XFTPEnv s -> FileStore s
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 :: forall s. FileStore s -> s
fromFileStore = \case
StoreMemory STMFileStore
s -> s
STMFileStore
s
#if defined(dbServerPostgres)
StoreDatabase s -> s
#endif
{-# INLINE fromFileStore #-}
defFileExpirationHours :: Int64
defFileExpirationHours :: Int64
defFileExpirationHours = Int64
48
defaultFileExpiration :: ExpirationConfig
defaultFileExpiration :: ExpirationConfig
defaultFileExpiration =
ExpirationConfig
{ ttl :: Int64
ttl = Int64
defFileExpirationHours Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
* Int64
3600,
checkInterval :: Int64
checkInterval = Int64
2 Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
* Int64
3600
}
newXFTPServerEnv :: FileStoreClass s => XFTPServerConfig s -> IO (XFTPEnv s)
newXFTPServerEnv :: forall s. FileStoreClass s => XFTPServerConfig s -> IO (XFTPEnv s)
newXFTPServerEnv config :: XFTPServerConfig s
config@XFTPServerConfig {XFTPStoreConfig s
$sel:serverStoreCfg:XFTPServerConfig :: forall s. XFTPServerConfig s -> XFTPStoreConfig s
serverStoreCfg :: XFTPStoreConfig s
serverStoreCfg, Maybe Int64
$sel:fileSizeQuota:XFTPServerConfig :: forall s. XFTPServerConfig s -> Maybe Int64
fileSizeQuota :: Maybe Int64
fileSizeQuota, ServerCredentials
$sel:xftpCredentials:XFTPServerConfig :: forall s. XFTPServerConfig s -> ServerCredentials
xftpCredentials :: ServerCredentials
xftpCredentials, Maybe ServerCredentials
$sel:httpCredentials:XFTPServerConfig :: forall s. XFTPServerConfig s -> Maybe ServerCredentials
httpCredentials :: Maybe ServerCredentials
httpCredentials} = do
TVar ChaChaDRG
random <- IO (TVar ChaChaDRG)
C.newRandom
(FileStore s
store, Maybe (StoreLog 'WriteMode)
storeLog) <- case XFTPStoreConfig s
serverStoreCfg of
XSCMemory Maybe String
storeLogPath -> do
STMFileStore
st <- FileStoreConfig STMFileStore -> IO STMFileStore
forall s. FileStoreClass s => FileStoreConfig s -> IO s
newFileStore ()
Maybe (StoreLog 'WriteMode)
sl <- (String -> IO (StoreLog 'WriteMode))
-> Maybe String -> IO (Maybe (StoreLog 'WriteMode))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Maybe a -> m (Maybe b)
mapM (String -> STMFileStore -> IO (StoreLog 'WriteMode)
`readWriteFileStore` STMFileStore
st) Maybe String
storeLogPath
STM () -> IO ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TVar (Maybe (StoreLog 'WriteMode))
-> Maybe (StoreLog 'WriteMode) -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar (STMFileStore -> TVar (Maybe (StoreLog 'WriteMode))
stmStoreLog STMFileStore
st) Maybe (StoreLog 'WriteMode)
sl
(FileStore s, Maybe (StoreLog 'WriteMode))
-> IO (FileStore s, Maybe (StoreLog 'WriteMode))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (STMFileStore -> FileStore STMFileStore
StoreMemory STMFileStore
st, Maybe (StoreLog 'WriteMode)
sl)
#if defined(dbServerPostgres)
XSCDatabase dbCfg -> do
st <- newFileStore dbCfg
pure (StoreDatabase st, Nothing)
#endif
Int64
used <- s -> IO Int64
forall s. FileStoreClass s => s -> IO Int64
getUsedStorage (FileStore s -> s
forall s. FileStore s -> s
fromFileStore FileStore s
store)
TVar Int64
usedStorage <- Int64 -> IO (TVar Int64)
forall (m :: * -> *) a. MonadIO m => a -> m (TVar a)
newTVarIO Int64
used
Maybe Int64 -> (Int64 -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe Int64
fileSizeQuota ((Int64 -> IO ()) -> IO ()) -> (Int64 -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Int64
quota -> do
Text -> IO ()
forall (m :: * -> *). (HasCallStack, MonadIO m) => Text -> m ()
logNote (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"Total / available storage: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int64 -> Text
forall a. Show a => a -> Text
tshow Int64
quota Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" / " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int64 -> Text
forall a. Show a => a -> Text
tshow (Int64
quota Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
- Int64
used)
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int64
quota Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
< Int64
used) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> IO ()
forall (m :: * -> *). (HasCallStack, MonadIO m) => Text -> m ()
logWarn Text
"WARNING: storage quota is less than used storage, no files can be uploaded!"
Credential
tlsServerCreds <- ServerCredentials -> IO Credential
loadServerCredential ServerCredentials
xftpCredentials
Maybe Credential
httpServerCreds <- (ServerCredentials -> IO Credential)
-> Maybe ServerCredentials -> IO (Maybe Credential)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Maybe a -> m (Maybe b)
mapM ServerCredentials -> IO Credential
loadServerCredential Maybe ServerCredentials
httpCredentials
Fingerprint ByteString
fp <- ServerCredentials -> IO Fingerprint
loadFingerprint ServerCredentials
xftpCredentials
FileServerStats
serverStats <- UTCTime -> IO FileServerStats
newFileServerStats (UTCTime -> IO FileServerStats) -> IO UTCTime -> IO FileServerStats
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO UTCTime
getCurrentTime
XFTPEnv s -> IO (XFTPEnv s)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure XFTPEnv {XFTPServerConfig s
$sel:config:XFTPEnv :: XFTPServerConfig s
config :: XFTPServerConfig s
config, FileStore s
$sel:store:XFTPEnv :: FileStore s
store :: FileStore s
store, TVar Int64
$sel:usedStorage:XFTPEnv :: TVar Int64
usedStorage :: TVar Int64
usedStorage, Maybe (StoreLog 'WriteMode)
$sel:storeLog:XFTPEnv :: Maybe (StoreLog 'WriteMode)
storeLog :: Maybe (StoreLog 'WriteMode)
storeLog, TVar ChaChaDRG
$sel:random:XFTPEnv :: TVar ChaChaDRG
random :: TVar ChaChaDRG
random, Credential
$sel:tlsServerCreds:XFTPEnv :: Credential
tlsServerCreds :: Credential
tlsServerCreds, Maybe Credential
$sel:httpServerCreds:XFTPEnv :: Maybe Credential
httpServerCreds :: Maybe Credential
httpServerCreds, $sel:serverIdentity:XFTPEnv :: KeyHash
serverIdentity = ByteString -> KeyHash
C.KeyHash ByteString
fp, FileServerStats
$sel:serverStats:XFTPEnv :: FileServerStats
serverStats :: FileServerStats
serverStats}
data XFTPRequest
= XFTPReqNew FileInfo (NonEmpty RcvPublicAuthKey) (Maybe BasicAuth)
| XFTPReqCmd XFTPFileId FileRec FileCmd
| XFTPReqPing
readFileStoreType :: Ini -> Either String AFStoreType
readFileStoreType :: Ini -> Either String AFStoreType
readFileStoreType Ini
ini = case String -> Either String String -> String
forall b a. b -> Either a b -> b
fromRight String
"memory" (Either String String -> String) -> Either String String -> String
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack (Text -> String) -> Either String Text -> Either String String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Text -> Ini -> Either String Text
lookupValue Text
"STORE_LOG" Text
"store_files" Ini
ini of
String
"memory" -> AFStoreType -> Either String AFStoreType
forall a b. b -> Either a b
Right (AFStoreType -> Either String AFStoreType)
-> AFStoreType -> Either String AFStoreType
forall a b. (a -> b) -> a -> b
$ SFSType 'FSMemory -> AFStoreType
forall (fs :: FSType). SFSType fs -> AFStoreType
AFSType SFSType 'FSMemory
SFSMemory
String
"database" -> AFStoreType -> Either String AFStoreType
forall a b. b -> Either a b
Right (AFStoreType -> Either String AFStoreType)
-> AFStoreType -> Either String AFStoreType
forall a b. (a -> b) -> a -> b
$ SFSType 'FSPostgres -> AFStoreType
forall (fs :: FSType). SFSType fs -> AFStoreType
AFSType SFSType 'FSPostgres
SFSPostgres
String
other -> String -> Either String AFStoreType
forall a b. a -> Either a b
Left (String -> Either String AFStoreType)
-> String -> Either String AFStoreType
forall a b. (a -> b) -> a -> b
$ String
"Invalid store_files value: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
other
runWithStoreConfig ::
AFStoreType ->
Ini ->
FilePath ->
MigrationConfirmation ->
(forall s. FileStoreClass s => XFTPStoreConfig s -> IO ()) ->
IO ()
runWithStoreConfig :: AFStoreType
-> Ini
-> String
-> MigrationConfirmation
-> (forall s. FileStoreClass s => XFTPStoreConfig s -> IO ())
-> IO ()
runWithStoreConfig (AFSType SFSType fs
SFSMemory) Ini
ini String
storeLogFilePath MigrationConfirmation
_confirmMigrations forall s. FileStoreClass s => XFTPStoreConfig s -> IO ()
run =
XFTPStoreConfig STMFileStore -> IO ()
forall s. FileStoreClass s => XFTPStoreConfig s -> IO ()
run (XFTPStoreConfig STMFileStore -> IO ())
-> XFTPStoreConfig STMFileStore -> IO ()
forall a b. (a -> b) -> a -> b
$ Maybe String -> XFTPStoreConfig STMFileStore
XSCMemory (Maybe ()
enableStoreLog' Maybe () -> String -> Maybe String
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> String
storeLogFilePath)
where
enableStoreLog' :: Maybe ()
enableStoreLog' = Text -> Text -> Ini -> Maybe ()
settingIsOn Text
"STORE_LOG" Text
"enable" Ini
ini
runWithStoreConfig (AFSType SFSType fs
SFSPostgres) Ini
ini String
storeLogFilePath MigrationConfirmation
confirmMigrations forall s. FileStoreClass s => XFTPStoreConfig s -> IO ()
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
String -> IO ()
forall a. HasCallStack => String -> a
error String
"server binary is compiled without support for PostgreSQL database"
#endif
checkFileStoreMode :: Ini -> AFStoreType -> FilePath -> IO ()
checkFileStoreMode :: Ini -> AFStoreType -> String -> IO ()
checkFileStoreMode Ini
ini (AFSType SFSType fs
SFSPostgres) String
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
String -> IO ()
putStrLn String
"Error: server binary is compiled without support for PostgreSQL database."
String -> IO ()
putStrLn String
"Please re-compile with `cabal build -fserver_postgres`."
IO ()
forall a. IO a
exitFailure
#endif
checkFileStoreMode Ini
_ (AFSType SFSType fs
SFSMemory) String
_ = () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
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 :: String -> Ini -> MigrationConfirmation -> IO ()
importToDatabase String
_ Ini
_ MigrationConfirmation
_ = String -> IO ()
forall a. HasCallStack => String -> a
error String
"Error: server binary is compiled without support for PostgreSQL database.\nPlease re-compile with `cabal build -fserver_postgres`."
#endif
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 :: String -> Ini -> MigrationConfirmation -> IO ()
exportFromDatabase String
_ Ini
_ MigrationConfirmation
_ = String -> IO ()
forall a. HasCallStack => String -> a
error String
"Error: server binary is compiled without support for PostgreSQL database.\nPlease re-compile with `cabal build -fserver_postgres`."
#endif