Main.hs

{-# LANGUAGE ApplicativeDo #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# 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 (..), defFileExpirationHours, defaultFileExpiration, defaultInactiveClientExpiration, 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_ ::
  (XFTPServerConfig -> 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)
      printXFTPConfig serverConfig
      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 serverConfig information onionHost path
          when (isJust webHttpPort || isJust webHttpsParams') $
            serveStaticFiles EmbeddedWebParams {webStaticPath = path, webHttpPort, webHttpsParams = webHttpsParams'}
        Nothing -> pure ()
      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
        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 =
          XFTPServerConfig
            { xftpPort = T.unpack $ strictIni "TRANSPORT" "port" ini,
              controlPort = either (const Nothing) (Just . T.unpack) $ lookupValue "TRANSPORT" "control_port" ini,
              fileIdSize = 16,
              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}
      where
        parseConfirmMigrations :: ReadM MigrationConfirmation
        parseConfirmMigrations = eitherReader $ \case
          "up" -> Right MCYesUp
          "down" -> Right MCYesUpDown
          _ -> Left "invalid migration confirmation, pass 'up' or 'down'"
    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"))
        )