simplexmq/src/Simplex/FileTransfer/Server/Env.hs

{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE StrictData #-}

module Simplex.FileTransfer.Server.Env
  ( XFTPServerConfig (..),
    XFTPStoreConfig (..),
    XFTPEnv (..),
    XFTPRequest (..),
    defaultInactiveClientExpiration,
    defFileExpirationHours,
    defaultFileExpiration,
    newXFTPServerEnv,
    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.Ini (Ini)
import Simplex.FileTransfer.Server.Store
import Simplex.Messaging.Agent.Store.Shared (MigrationConfirmation)
#if defined(dbServerPostgres)
import Data.Functor (($>))
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, settingIsOn)
import System.Directory (doesFileExist)
import System.Exit (exitFailure)
#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 = XFTPServerConfig
  { xftpPort :: ServiceName,
    controlPort :: Maybe ServiceName,
    fileIdSize :: Int,
    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 :: Maybe ExpirationConfig,
    -- | 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 XFTPStoreConfig s where
  XSCMemory :: Maybe FilePath -> XFTPStoreConfig STMFileStore
#if defined(dbServerPostgres)
  XSCDatabase :: PostgresFileStoreCfg -> XFTPStoreConfig PostgresFileStore
#endif

data XFTPEnv s = XFTPEnv
  { config :: XFTPServerConfig,
    store :: s,
    usedStorage :: TVar Int64,
    storeLog :: Maybe (StoreLog 'WriteMode),
    random :: TVar ChaChaDRG,
    serverIdentity :: C.KeyHash,
    tlsServerCreds :: T.Credential,
    httpServerCreds :: Maybe T.Credential,
    serverStats :: FileServerStats
  }

defFileExpirationHours :: Int64
defFileExpirationHours = 48

defaultFileExpiration :: ExpirationConfig
defaultFileExpiration =
  ExpirationConfig
    { ttl = defFileExpirationHours * 3600, -- seconds
      checkInterval = 2 * 3600 -- seconds, 2 hours
    }

newXFTPServerEnv :: FileStoreClass s => XFTPStoreConfig s -> XFTPServerConfig -> IO (XFTPEnv s)
newXFTPServerEnv storeCfg config@XFTPServerConfig {fileSizeQuota, xftpCredentials, httpCredentials} = do
  random <- C.newRandom
  (store, storeLog) <- case storeCfg of
    XSCMemory storeLogPath -> do
      st <- newFileStore ()
      sl <- mapM (`readWriteFileStore` st) storeLogPath
      pure (st, sl)
#if defined(dbServerPostgres)
    XSCDatabase dbCfg -> do
      st <- newFileStore dbCfg
      pure (st, Nothing)
#endif
  used <- getUsedStorage 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)
  | 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 ()
#else
checkFileStoreMode _ _ _ = pure ()
#endif

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