mirror of
https://github.com/simplex-chat/simplexmq.git
synced 2026-04-02 09:25:54 +00:00
1009 lines
53 KiB
Haskell
1009 lines
53 KiB
Haskell
{-# LANGUAGE ApplicativeDo #-}
|
|
{-# LANGUAGE CPP #-}
|
|
{-# LANGUAGE DataKinds #-}
|
|
{-# LANGUAGE DuplicateRecordFields #-}
|
|
{-# LANGUAGE FlexibleContexts #-}
|
|
{-# LANGUAGE GADTs #-}
|
|
{-# LANGUAGE LambdaCase #-}
|
|
{-# LANGUAGE MultiWayIf #-}
|
|
{-# LANGUAGE NamedFieldPuns #-}
|
|
{-# LANGUAGE OverloadedLists #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE PatternSynonyms #-}
|
|
{-# LANGUAGE ScopedTypeVariables #-}
|
|
{-# LANGUAGE StrictData #-}
|
|
{-# LANGUAGE TypeApplications #-}
|
|
{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}
|
|
|
|
module Simplex.Messaging.Server.Main where
|
|
|
|
import Control.Concurrent.STM
|
|
import Control.Exception (SomeException, finally, try)
|
|
import Control.Logger.Simple
|
|
import Control.Monad
|
|
import qualified Data.Attoparsec.ByteString.Char8 as A
|
|
import Data.ByteString.Char8 (ByteString)
|
|
import qualified Data.ByteString.Char8 as B
|
|
import Data.Char (isAlpha, isAscii, toUpper)
|
|
import Data.Either (fromRight)
|
|
import Data.Functor (($>))
|
|
import Data.Ini (Ini, lookupValue, readIniFile)
|
|
import Data.Int (Int64)
|
|
import Data.List (find, isPrefixOf)
|
|
import qualified Data.List.NonEmpty as L
|
|
import qualified Data.Map.Strict as M
|
|
import Data.Maybe (fromMaybe, isJust, isNothing)
|
|
import Data.Text (Text)
|
|
import qualified Data.Text as T
|
|
import Data.Text.Encoding (decodeLatin1, encodeUtf8)
|
|
import qualified Data.Text.IO as T
|
|
import Options.Applicative
|
|
import Simplex.Messaging.Agent.Protocol (ConnectionLink (..), connReqUriP')
|
|
import Simplex.Messaging.Agent.Store.Postgres.Options (DBOpts (..))
|
|
import Simplex.Messaging.Agent.Store.Shared (MigrationConfirmation (..))
|
|
import Simplex.Messaging.Client (HostMode (..), NetworkConfig (..), ProtocolClientConfig (..), SMPWebPortServers (..), SocksMode (..), defaultNetworkConfig, textToHostMode)
|
|
import Simplex.Messaging.Client.Agent (SMPClientAgentConfig (..), defaultSMPClientAgentConfig)
|
|
import qualified Simplex.Messaging.Crypto as C
|
|
import Simplex.Messaging.Encoding.String
|
|
import Simplex.Messaging.Parsers (parseAll)
|
|
import Simplex.Messaging.Protocol (BasicAuth (..), ProtoServerWithAuth (ProtoServerWithAuth), pattern SMPServer)
|
|
import Simplex.Messaging.Server (AttachHTTP, exportMessages, importMessages, printMessageStats, runSMPServer)
|
|
import Simplex.Messaging.Server.CLI
|
|
import Simplex.Messaging.Server.Env.STM
|
|
import Simplex.Messaging.Server.Expiration
|
|
import Simplex.Messaging.Server.Information
|
|
import Simplex.Messaging.Server.Main.Init
|
|
import Simplex.Messaging.Server.MsgStore.Journal (JournalMsgStore (..), QStoreCfg (..), stmQueueStore)
|
|
import Simplex.Messaging.Server.MsgStore.Types (MsgStoreClass (..), SQSType (..), SMSType (..), newMsgStore)
|
|
import Simplex.Messaging.Server.QueueStore.Postgres.Config
|
|
import Simplex.Messaging.Server.StoreLog.ReadWrite (readQueueStore)
|
|
import Simplex.Messaging.Transport (supportedProxyClientSMPRelayVRange, alpnSupportedSMPHandshakes, supportedServerSMPRelayVRange)
|
|
import Simplex.Messaging.Transport.Client (TransportHost (..), defaultSocksProxy)
|
|
import Simplex.Messaging.Transport.HTTP2 (httpALPN)
|
|
import Simplex.Messaging.Transport.Server (ServerCredentials (..), mkTransportServerConfig)
|
|
import Simplex.Messaging.Util (eitherToMaybe, ifM, unlessM)
|
|
import System.Directory (createDirectoryIfMissing, doesDirectoryExist, doesFileExist)
|
|
import System.Exit (exitFailure)
|
|
import System.FilePath (combine)
|
|
import System.IO (BufferMode (..), IOMode (..), hSetBuffering, stderr, stdout, withFile)
|
|
import Text.Read (readMaybe)
|
|
|
|
#if defined(dbServerPostgres)
|
|
import Data.Semigroup (Sum (..))
|
|
import Simplex.Messaging.Agent.Store.Postgres (checkSchemaExists)
|
|
import Simplex.Messaging.Server.MsgStore.Journal (JournalQueue)
|
|
import Simplex.Messaging.Server.MsgStore.Types (QSType (..))
|
|
import Simplex.Messaging.Server.MsgStore.Journal (postgresQueueStore)
|
|
import Simplex.Messaging.Server.MsgStore.Postgres
|
|
import Simplex.Messaging.Server.QueueStore.Postgres (batchInsertQueues, batchInsertServices, foldQueueRecs, foldServiceRecs)
|
|
import Simplex.Messaging.Server.QueueStore.STM (STMQueueStore (..))
|
|
import Simplex.Messaging.Server.QueueStore.Types
|
|
import Simplex.Messaging.Server.StoreLog (closeStoreLog, logNewService, logCreateQueue, openWriteStoreLog)
|
|
import System.Directory (renameFile)
|
|
#endif
|
|
|
|
smpServerCLI :: FilePath -> FilePath -> IO ()
|
|
smpServerCLI = smpServerCLI_ (\_ _ _ -> pure ()) (\_ -> pure ()) (\_ -> error "attachStaticFiles not available")
|
|
|
|
smpServerCLI_ ::
|
|
(ServerInformation -> Maybe TransportHost -> FilePath -> IO ()) ->
|
|
(EmbeddedWebParams -> IO ()) ->
|
|
(FilePath -> (AttachHTTP -> IO ()) -> IO ()) ->
|
|
FilePath ->
|
|
FilePath ->
|
|
IO ()
|
|
smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath =
|
|
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 -> withIniFile $ \_ -> genOnline cfgPath certOpts
|
|
Start opts -> withIniFile $ runServer opts
|
|
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"
|
|
Journal cmd -> withIniFile $ \ini -> do
|
|
msgsDirExists <- doesDirectoryExist storeMsgsJournalDir
|
|
msgsFileExists <- doesFileExist storeMsgsFilePath
|
|
storeLogFile <- getRequiredStoreLogFile ini
|
|
case cmd of
|
|
SCImport
|
|
| msgsFileExists && msgsDirExists -> exitConfigureMsgStorage
|
|
| msgsDirExists -> do
|
|
putStrLn $ storeMsgsJournalDir <> " directory already exists."
|
|
exitFailure
|
|
| not msgsFileExists -> do
|
|
putStrLn $ storeMsgsFilePath <> " file does not exist."
|
|
exitFailure
|
|
| otherwise -> do
|
|
confirmOrExit
|
|
("WARNING: message log file " <> storeMsgsFilePath <> " will be imported to journal directory " <> storeMsgsJournalDir)
|
|
"Messages not imported"
|
|
ms <- newJournalMsgStore logPath MQStoreCfg
|
|
readQueueStore True (mkQueue ms False) storeLogFile $ stmQueueStore ms
|
|
msgStats <- importMessages True ms storeMsgsFilePath Nothing False -- no expiration
|
|
putStrLn "Import completed"
|
|
printMessageStats "Messages" msgStats
|
|
putStrLn $ case readStoreType ini of
|
|
Right (ASType SQSMemory SMSMemory) -> "store_messages set to `memory`, update it to `journal` in INI file"
|
|
Right (ASType SQSPostgres SMSPostgres) -> "store_messages set to `database`, update it to `journal` in INI file"
|
|
Right (ASType _ SMSJournal) -> "store_messages set to `journal`"
|
|
Left e -> e <> ", configure storage correctly"
|
|
SCExport
|
|
| msgsFileExists && msgsDirExists -> exitConfigureMsgStorage
|
|
| msgsFileExists -> do
|
|
putStrLn $ storeMsgsFilePath <> " file already exists."
|
|
exitFailure
|
|
| otherwise -> do
|
|
confirmOrExit
|
|
("WARNING: journal directory " <> storeMsgsJournalDir <> " will be exported to message log file " <> storeMsgsFilePath)
|
|
"Journal not exported"
|
|
case readStoreType ini of
|
|
Right (ASType SQSMemory msType) -> do
|
|
ms <- newJournalMsgStore logPath MQStoreCfg
|
|
readQueueStore True (mkQueue ms False) storeLogFile $ stmQueueStore ms
|
|
exportMessages True (StoreJournal ms) storeMsgsFilePath False
|
|
putStrLn "Export completed"
|
|
putStrLn $ case msType of
|
|
SMSMemory -> "store_messages set to `memory`, start the server."
|
|
SMSJournal -> "store_messages set to `journal`, update it to `memory` in INI file"
|
|
#if defined(dbServerPostgres)
|
|
Right (ASType SQSPostgres SMSJournal) -> do
|
|
let dbStoreLogPath = enableDbStoreLog' ini $> storeLogFilePath
|
|
dbOpts@DBOpts {connstr, schema} = iniDBOptions ini defaultDBOpts
|
|
unlessM (checkSchemaExists connstr schema) $ do
|
|
putStrLn $ "Schema " <> B.unpack schema <> " does not exist in PostrgreSQL database: " <> B.unpack connstr
|
|
exitFailure
|
|
ms <- newJournalMsgStore logPath $ PQStoreCfg PostgresStoreCfg {dbOpts, dbStoreLogPath, confirmMigrations = MCYesUp, deletedTTL = iniDeletedTTL ini}
|
|
exportMessages True (StoreJournal ms) storeMsgsFilePath False
|
|
putStrLn "Export completed"
|
|
putStrLn "store_messages set to `journal`, store_queues is set to `database`.\nExport queues to store log to use memory storage for messages (`smp-server database export`)."
|
|
Right (ASType SQSPostgres SMSPostgres) -> do
|
|
putStrLn $ "Messages can be exported with `dabatase export --table messages`."
|
|
exitFailure
|
|
#else
|
|
Right (ASType SQSPostgres SMSJournal) -> noPostgresExit
|
|
#endif
|
|
Left e -> putStrLn $ e <> ", configure storage correctly"
|
|
SCDelete
|
|
| not msgsDirExists -> do
|
|
putStrLn $ storeMsgsJournalDir <> " directory does not exists."
|
|
exitFailure
|
|
| otherwise -> do
|
|
confirmOrExit
|
|
("WARNING: journal directory " <> storeMsgsJournalDir <> " will be permanently deleted.\nTHIS CANNOT BE UNDONE!")
|
|
"Messages NOT deleted"
|
|
deleteDirIfExists storeMsgsJournalDir
|
|
putStrLn $ "Deleted all messages in journal " <> storeMsgsJournalDir
|
|
#if defined(dbServerPostgres)
|
|
Database cmd tables dbOpts@DBOpts {connstr, schema} -> withIniFile $ \ini -> do
|
|
schemaExists <- checkSchemaExists connstr schema
|
|
storeLogExists <- doesFileExist storeLogFilePath
|
|
msgsFileExists <- doesFileExist storeMsgsFilePath
|
|
case (cmd, tables) of
|
|
(SCImport, DTAll)
|
|
| not schemaExists && storeLogExists && msgsFileExists -> do
|
|
storeLogFile <- getRequiredStoreLogFile ini
|
|
confirmOrExit
|
|
("WARNING: store log file " <> storeLogFile <> " and message log file " <> storeMsgsFilePath <> " will be imported to PostrgreSQL database: " <> B.unpack connstr <> ", schema: " <> B.unpack schema)
|
|
"Store logs not imported"
|
|
(sCnt, qCnt) <- importStoreLogToDatabase logPath storeLogFile dbOpts
|
|
putStrLn $ "Imported: " <> show sCnt <> " services, " <> show qCnt <> " queues"
|
|
putStrLn "Importing messages..."
|
|
mCnt <- importMessagesToDatabase storeMsgsFilePath dbOpts
|
|
putStrLn $ "Import completed: " <> show mCnt <> " messages"
|
|
putStrLn $ case readStoreType ini of
|
|
Right (ASType SQSPostgres SMSPostgres) -> "store_queues and store_messages set to `database`, start the server."
|
|
Right _ -> "set store_queues and store_messages to `database` in INI file"
|
|
Left e -> e <> ", configure storage correctly"
|
|
| otherwise -> do
|
|
when schemaExists $ putStrLn $ "Schema " <> B.unpack schema <> " already exists in PostrgreSQL database: " <> B.unpack connstr
|
|
unless storeLogExists $ putStrLn $ storeLogFilePath <> " file does not exist."
|
|
unless msgsFileExists $ putStrLn $ storeMsgsFilePath <> " file does not exist."
|
|
exitFailure
|
|
(SCImport, DTQueues)
|
|
| schemaExists && storeLogExists -> exitConfigureQueueStore connstr schema
|
|
| schemaExists -> do
|
|
putStrLn $ "Schema " <> B.unpack schema <> " already exists in PostrgreSQL database: " <> B.unpack connstr
|
|
exitFailure
|
|
| not storeLogExists -> do
|
|
putStrLn $ storeLogFilePath <> " file does not exist."
|
|
exitFailure
|
|
| otherwise -> do
|
|
storeLogFile <- getRequiredStoreLogFile ini
|
|
confirmOrExit
|
|
("WARNING: store log file " <> storeLogFile <> " will be compacted and imported to PostrgreSQL database: " <> B.unpack connstr <> ", schema: " <> B.unpack schema)
|
|
"Queue records not imported"
|
|
(sCnt, qCnt) <- importStoreLogToDatabase logPath storeLogFile dbOpts
|
|
putStrLn $ "Import completed: " <> show sCnt <> " services, " <> show qCnt <> " queues"
|
|
putStrLn $ case readStoreType ini of
|
|
Right (ASType SQSMemory SMSMemory) -> setToDbStr <> "\nstore_messages set to `memory`, import messages to journal to use PostgreSQL database for queues (`smp-server journal import`)"
|
|
Right (ASType SQSMemory SMSJournal) -> setToDbStr
|
|
Right (ASType SQSPostgres _) -> "store_queues set to `database`, start the server."
|
|
Left e -> e <> ", configure storage correctly"
|
|
where
|
|
setToDbStr :: String
|
|
setToDbStr = "store_queues set to `memory`, update it to `database` in INI file"
|
|
(SCImport, DTMessages)
|
|
| not schemaExists -> do
|
|
putStrLn $ "Schema " <> B.unpack schema <> " does not exist in PostrgreSQL database: " <> B.unpack connstr
|
|
exitFailure
|
|
| not msgsFileExists -> do
|
|
putStrLn $ storeMsgsFilePath <> " file does not exist."
|
|
exitFailure
|
|
| otherwise -> do
|
|
confirmOrExit
|
|
("WARNING: message log file " <> storeMsgsFilePath <> " will be imported to PostrgreSQL database " <> B.unpack connstr <> ", schema: " <> B.unpack schema)
|
|
"Message records not imported"
|
|
mCnt <- importMessagesToDatabase storeMsgsFilePath dbOpts
|
|
putStrLn $ "Import completed: " <> show mCnt <> " messages"
|
|
putStrLn $ case readStoreType ini of
|
|
Right (ASType SQSPostgres SMSPostgres) -> "store_queues and store_messages set to `database`, start the server."
|
|
Right _ -> "set store_queues and store_messages to `database` in INI file"
|
|
Left e -> e <> ", configure storage correctly"
|
|
(SCExport, DTAll)
|
|
| schemaExists && not storeLogExists && not msgsFileExists -> do
|
|
confirmOrExit
|
|
("WARNING: PostrgreSQL schema " <> B.unpack schema <> " (database: " <> B.unpack connstr <> ") will be exported to store log file " <> storeLogFilePath <> " and to message log file " <> storeMsgsFilePath)
|
|
"Database store not exported"
|
|
(sCnt, qCnt) <- exportDatabaseToStoreLog logPath dbOpts storeLogFilePath
|
|
putStrLn $ "Exported: " <> show sCnt <> " services, " <> show qCnt <> " queues"
|
|
putStrLn "Exporting messages..."
|
|
let storeCfg = PostgresStoreCfg {dbOpts, dbStoreLogPath = Nothing, confirmMigrations = MCConsole, deletedTTL = 86400 * defaultDeletedTTL}
|
|
ms <- newMsgStore $ PostgresMsgStoreCfg storeCfg defaultMsgQueueQuota
|
|
withFile storeMsgsFilePath WriteMode (try . exportDbMessages True ms) >>= \case
|
|
Right mCnt -> putStrLn $ "Export completed: " <> show mCnt <> " messages"
|
|
Left (e :: SomeException) -> putStrLn $ "Error exporting messages: " <> show e
|
|
closeMsgStore ms
|
|
| otherwise -> do
|
|
unless schemaExists $ putStrLn $ "Schema " <> B.unpack schema <> " does not exist in PostrgreSQL database: " <> B.unpack connstr
|
|
when storeLogExists $ putStrLn $ storeLogFilePath <> " file already exists."
|
|
when msgsFileExists $ putStrLn $ storeMsgsFilePath <> " file already exists."
|
|
exitFailure
|
|
(SCExport, DTQueues)
|
|
| schemaExists && storeLogExists -> exitConfigureQueueStore connstr schema
|
|
| not schemaExists -> do
|
|
putStrLn $ "Schema " <> B.unpack schema <> " does not exist in PostrgreSQL database: " <> B.unpack connstr
|
|
exitFailure
|
|
| storeLogExists -> do
|
|
putStrLn $ storeLogFilePath <> " file already exists."
|
|
exitFailure
|
|
| otherwise -> do
|
|
confirmOrExit
|
|
("WARNING: PostrgreSQL schema " <> B.unpack schema <> " (database: " <> B.unpack connstr <> ") will be exported to store log file " <> storeLogFilePath)
|
|
"Queue records not exported"
|
|
(sCnt, qCnt) <- exportDatabaseToStoreLog logPath dbOpts storeLogFilePath
|
|
putStrLn $ "Export completed: " <> show sCnt <> " services, " <> show qCnt <> " queues"
|
|
putStrLn $ case readStoreType ini of
|
|
Right (ASType SQSPostgres _) -> "store_queues or store_messages set to `database`, update it to `memory` in INI file."
|
|
Right (ASType SQSMemory _) -> "store_queues set to `memory`, start the server"
|
|
Left e -> e <> ", configure storage correctly"
|
|
(SCExport, DTMessages)
|
|
| not schemaExists -> do
|
|
putStrLn $ "Schema " <> B.unpack schema <> " does not exist in PostrgreSQL database: " <> B.unpack connstr
|
|
exitFailure
|
|
| msgsFileExists -> do
|
|
putStrLn $ storeMsgsFilePath <> " file already exists."
|
|
exitFailure
|
|
| otherwise -> do
|
|
confirmOrExit
|
|
("WARNING: Messages from PostrgreSQL schema " <> B.unpack schema <> " (database: " <> B.unpack connstr <> ") will be exported to message log file " <> storeMsgsFilePath)
|
|
"Message records not exported"
|
|
let storeCfg = PostgresStoreCfg {dbOpts, dbStoreLogPath = Nothing, confirmMigrations = MCConsole, deletedTTL = 86400 * defaultDeletedTTL}
|
|
ms <- newMsgStore $ PostgresMsgStoreCfg storeCfg defaultMsgQueueQuota
|
|
withFile storeMsgsFilePath WriteMode (try . exportDbMessages True ms) >>= \case
|
|
Right mCnt -> do
|
|
putStrLn $ "Export completed: " <> show mCnt <> " messages"
|
|
putStrLn "Export queues with `smp-server database export queues`"
|
|
Left (e :: SomeException) -> putStrLn $ "Error exporting messages: " <> show e
|
|
closeMsgStore ms
|
|
(SCDelete, _)
|
|
| not schemaExists -> do
|
|
putStrLn $ "Schema " <> B.unpack schema <> " does not exist in PostrgreSQL database: " <> B.unpack connstr
|
|
exitFailure
|
|
| otherwise -> do
|
|
putStrLn $ "Open database: psql " <> B.unpack connstr
|
|
putStrLn $ "Delete schema: DROP SCHEMA " <> B.unpack schema <> " CASCADE;"
|
|
#else
|
|
Database {} -> noPostgresExit
|
|
#endif
|
|
where
|
|
withIniFile a =
|
|
doesFileExist iniFile >>= \case
|
|
True -> readIniFile iniFile >>= either exitError a
|
|
_ -> exitError $ "Error: server is not initialized (" <> iniFile <> " does not exist).\nRun `" <> executableName <> " init`."
|
|
getRequiredStoreLogFile ini = do
|
|
case enableStoreLog' ini $> storeLogFilePath of
|
|
Just storeLogFile -> do
|
|
ifM
|
|
(doesFileExist storeLogFile)
|
|
(pure storeLogFile)
|
|
(putStrLn ("Store log file " <> storeLogFile <> " not found") >> exitFailure)
|
|
Nothing -> putStrLn "Store log disabled, see `[STORE_LOG] enable`" >> exitFailure
|
|
iniFile = combine cfgPath "smp-server.ini"
|
|
serverVersion = "SMP server v" <> simplexmqVersionCommit
|
|
executableName = "smp-server"
|
|
storeLogFilePath = combine logPath "smp-server-store.log"
|
|
storeMsgsFilePath = combine logPath "smp-server-messages.log"
|
|
storeMsgsJournalDir = storeMsgsJournalDir' logPath
|
|
storeNtfsFilePath = combine logPath "smp-server-ntfs.log"
|
|
readStoreType :: Ini -> Either String AStoreType
|
|
readStoreType ini = case (iniStoreQueues, iniStoreMessage) of
|
|
("memory", "memory") -> Right $ ASType SQSMemory SMSMemory
|
|
("memory", "journal") -> Right $ ASType SQSMemory SMSJournal
|
|
("memory", "database") -> Left "Database and memory storage are not compatible."
|
|
("database", "memory") -> Left "Database and memory storage are not compatible."
|
|
("database", "journal") -> Right $ ASType SQSPostgres SMSJournal
|
|
#if defined(dbServerPostgres)
|
|
("database", "database") -> Right $ ASType SQSPostgres SMSPostgres
|
|
#else
|
|
("database", "database") -> Left noPostgresExitStr
|
|
#endif
|
|
(q, m) -> Left $ T.unpack $ "Invalid storage settings: store_queues: " <> q <> ", store_messages: " <> m
|
|
where
|
|
iniStoreQueues = fromRight "memory" $ lookupValue "STORE_LOG" "store_queues" ini
|
|
iniStoreMessage = fromRight "memory" $ lookupValue "STORE_LOG" "store_messages" ini
|
|
iniDeletedTTL ini = readIniDefault (86400 * defaultDeletedTTL) "STORE_LOG" "db_deleted_ttl" ini
|
|
defaultStaticPath = combine logPath "www"
|
|
enableStoreLog' = settingIsOn "STORE_LOG" "enable"
|
|
enableDbStoreLog' = settingIsOn "STORE_LOG" "db_store_log"
|
|
initializeServer opts
|
|
| scripted opts = initialize opts
|
|
| otherwise = do
|
|
let InitOptions {ip, fqdn, sourceCode = src', webStaticPath = sp', disableWeb = noWeb'} = opts
|
|
putStrLn "Use `smp-server init -h` for available options."
|
|
checkInitOptions opts
|
|
void $ withPrompt "SMP server will be initialized (press Enter)" getLine
|
|
enableStoreLog <- onOffPrompt "Enable store log to restore queues and messages on server restart" True
|
|
logStats <- onOffPrompt "Enable logging daily statistics" False
|
|
putStrLn "Require a password to create new messaging queues?"
|
|
password <- withPrompt "'r' for random (default), 'n' - no password (recommended for public servers), or enter password: " serverPassword
|
|
let host = fromMaybe ip fqdn
|
|
host' <- withPrompt ("Enter server FQDN or IP address for certificate (" <> host <> "): ") getLine
|
|
sourceCode' <- withPrompt ("Enter server source code URI (" <> maybe simplexmqSource T.unpack src' <> "): ") getServerSourceCode
|
|
staticPath' <- withPrompt ("Enter path to store generated server pages to show connection links (" <> fromMaybe defaultStaticPath sp' <> "): ") getLine
|
|
initialize
|
|
opts
|
|
{ enableStoreLog,
|
|
logStats,
|
|
fqdn = if null host' then fqdn else Just host',
|
|
password,
|
|
sourceCode = (T.pack <$> sourceCode') <|> src' <|> Just (T.pack simplexmqSource),
|
|
webStaticPath = if null staticPath' then sp' else Just staticPath',
|
|
disableWeb = noWeb'
|
|
}
|
|
where
|
|
serverPassword =
|
|
getLine >>= \case
|
|
"" -> pure $ Just SPRandom
|
|
"r" -> pure $ Just SPRandom
|
|
"n" -> pure Nothing
|
|
s ->
|
|
case strDecode $ encodeUtf8 $ T.pack s of
|
|
Right auth -> pure . Just $ ServerPassword auth
|
|
_ -> putStrLn "Invalid password. Only latin letters, digits and symbols other than '@' and ':' are allowed" >> serverPassword
|
|
checkInitOptions InitOptions {sourceCode, serverInfo, operatorCountry, hostingCountry} = do
|
|
let err_
|
|
| isNothing sourceCode && hasServerInfo serverInfo =
|
|
Just "Error: passing any server information requires passing --source-code"
|
|
| isNothing (operator serverInfo) && isJust operatorCountry =
|
|
Just "Error: passing --operator-country requires passing --operator"
|
|
| isNothing (hosting serverInfo) && isJust hostingCountry =
|
|
Just "Error: passing --hosting-country requires passing --hosting"
|
|
| otherwise = Nothing
|
|
forM_ err_ $ \err -> putStrLn err >> exitFailure
|
|
initialize opts'@InitOptions {ip, fqdn, signAlgorithm, password, controlPort, sourceCode} = do
|
|
checkInitOptions opts'
|
|
clearDirIfExists cfgPath
|
|
clearDirIfExists logPath
|
|
createDirectoryIfMissing True cfgPath
|
|
createDirectoryIfMissing True logPath
|
|
let x509cfg = defaultX509Config {commonName = fromMaybe ip fqdn, signAlgorithm}
|
|
fp <- createServerX509 cfgPath x509cfg
|
|
basicAuth <- mapM createServerPassword password
|
|
controlPortPwds <- forM controlPort $ \_ -> let pwd = decodeLatin1 <$> randomBase64 18 in (,) <$> pwd <*> pwd
|
|
let host = fromMaybe (if ip == "127.0.0.1" then "<hostnames>" else ip) fqdn
|
|
srv = ProtoServerWithAuth (SMPServer [THDomainName host] "" (C.KeyHash fp)) basicAuth
|
|
T.writeFile iniFile $ iniFileContent cfgPath logPath opts' host basicAuth controlPortPwds
|
|
putStrLn $ "Server initialized, please provide additional server information in " <> iniFile <> "."
|
|
putStrLn $ "Run `" <> executableName <> " start` to start server."
|
|
warnCAPrivateKeyFile cfgPath x509cfg
|
|
printServiceInfo serverVersion srv
|
|
printSourceCode sourceCode
|
|
where
|
|
createServerPassword = \case
|
|
ServerPassword s -> pure s
|
|
SPRandom -> BasicAuth <$> randomBase64 32
|
|
randomBase64 n = strEncode <$> (atomically . C.randomBytes n =<< C.newRandom)
|
|
runServer startOptions ini = do
|
|
setLogLevel $ logLevel startOptions
|
|
hSetBuffering stdout LineBuffering
|
|
hSetBuffering stderr LineBuffering
|
|
run iniStoreType
|
|
where
|
|
run :: AStoreType -> IO ()
|
|
run (ASType qs ms) = do
|
|
fp <- checkSavedFingerprint cfgPath defaultX509Config
|
|
let host = either (const "<hostnames>") T.unpack $ lookupValue "TRANSPORT" "host" ini
|
|
port = T.unpack $ strictIni "TRANSPORT" "port" ini
|
|
serverStoreCfg = iniStoreCfg qs ms
|
|
cfg@ServerConfig {information, newQueueBasicAuth, messageExpiration, inactiveClientExpiration} = serverConfig serverStoreCfg
|
|
sourceCode' = (\ServerPublicInfo {sourceCode} -> sourceCode) <$> information
|
|
srv = ProtoServerWithAuth (SMPServer [THDomainName host] (if port == "5223" then "" else port) (C.KeyHash fp)) newQueueBasicAuth
|
|
printServiceInfo serverVersion srv
|
|
printSourceCode sourceCode'
|
|
printSMPServerConfig transports serverStoreCfg
|
|
checkMsgStoreMode ini iniStoreType
|
|
putStrLn $ case messageExpiration of
|
|
Just ExpirationConfig {ttl} -> "expiring messages after " <> showTTL ttl
|
|
_ -> "not expiring messages"
|
|
putStrLn $ case inactiveClientExpiration of
|
|
Just ExpirationConfig {ttl, checkInterval} -> "expiring clients inactive for " <> show ttl <> " seconds every " <> show checkInterval <> " seconds"
|
|
_ -> "not expiring inactive clients"
|
|
putStrLn $
|
|
"creating new queues "
|
|
<> if allowNewQueues cfg
|
|
then maybe "allowed" (const "requires password") newQueueBasicAuth
|
|
else "NOT allowed"
|
|
-- print information
|
|
let persistence = case serverStoreCfg of
|
|
SSCMemory Nothing -> SPMMemoryOnly
|
|
SSCMemory (Just StorePaths {storeMsgsFile}) | isNothing storeMsgsFile -> SPMQueues
|
|
_ -> SPMMessages
|
|
let config =
|
|
ServerPublicConfig
|
|
{ persistence,
|
|
messageExpiration = ttl <$> messageExpiration,
|
|
statsEnabled = isJust logStats,
|
|
newQueuesAllowed = allowNewQueues cfg,
|
|
basicAuthEnabled = isJust newQueueBasicAuth
|
|
}
|
|
case webStaticPath' of
|
|
Just path | sharedHTTP -> do
|
|
runWebServer path Nothing ServerInformation {config, information}
|
|
attachStaticFiles path $ \attachHTTP -> do
|
|
logDebug "Allocated web server resources"
|
|
runSMPServer cfg (Just attachHTTP) `finally` logDebug "Releasing web server resources..."
|
|
Just path -> do
|
|
runWebServer path webHttpsParams' ServerInformation {config, information}
|
|
runSMPServer cfg Nothing
|
|
Nothing -> do
|
|
logWarn "No server static path set"
|
|
runSMPServer cfg Nothing
|
|
logDebug "Bye"
|
|
logStats = settingIsOn "STORE_LOG" "log_stats" ini
|
|
c = combine cfgPath . ($ defaultX509Config)
|
|
restoreMessagesFile path = case iniOnOff "STORE_LOG" "restore_messages" ini of
|
|
Just True -> Just path
|
|
Just False -> Nothing
|
|
-- if the setting is not set, it is enabled when store log is enabled
|
|
_ -> enableStoreLog' ini $> path
|
|
transports = iniTransports ini
|
|
sharedHTTP = any (\(_, _, addHTTP) -> addHTTP) transports
|
|
iniStoreType = either error id $! readStoreType ini
|
|
iniStoreCfg :: SupportedStore qs ms => SQSType qs -> SMSType ms -> ServerStoreCfg (MsgStoreType qs ms)
|
|
iniStoreCfg SQSMemory SMSMemory = SSCMemory $ enableStoreLog' ini $> StorePaths {storeLogFile = storeLogFilePath, storeMsgsFile = restoreMessagesFile storeMsgsFilePath}
|
|
iniStoreCfg SQSMemory SMSJournal = SSCMemoryJournal {storeLogFile = storeLogFilePath, storeMsgsPath = storeMsgsJournalDir}
|
|
iniStoreCfg SQSPostgres SMSJournal =
|
|
let dbStoreLogPath = enableDbStoreLog' ini $> storeLogFilePath
|
|
storeCfg = PostgresStoreCfg {dbOpts = iniDBOptions ini defaultDBOpts, dbStoreLogPath, confirmMigrations = MCYesUp, deletedTTL = iniDeletedTTL ini}
|
|
in SSCDatabaseJournal {storeCfg, storeMsgsPath' = storeMsgsJournalDir}
|
|
#if defined(dbServerPostgres)
|
|
iniStoreCfg SQSPostgres SMSPostgres =
|
|
let dbStoreLogPath = enableDbStoreLog' ini $> storeLogFilePath
|
|
storeCfg = PostgresStoreCfg {dbOpts = iniDBOptions ini defaultDBOpts, dbStoreLogPath, confirmMigrations = MCYesUp, deletedTTL = iniDeletedTTL ini}
|
|
in SSCDatabase storeCfg
|
|
#endif
|
|
serverConfig :: ServerStoreCfg s -> ServerConfig s
|
|
serverConfig serverStoreCfg =
|
|
ServerConfig
|
|
{ transports,
|
|
smpHandshakeTimeout = 120000000,
|
|
tbqSize = 128,
|
|
msgQueueQuota = defaultMsgQueueQuota,
|
|
maxJournalMsgCount = defaultMaxJournalMsgCount,
|
|
maxJournalStateLines = defaultMaxJournalStateLines,
|
|
queueIdBytes = 24,
|
|
msgIdBytes = 24, -- must be at least 24 bytes, it is used as 192-bit nonce for XSalsa20
|
|
smpCredentials =
|
|
ServerCredentials
|
|
{ caCertificateFile = Just $ c caCrtFile,
|
|
privateKeyFile = c serverKeyFile,
|
|
certificateFile = c serverCrtFile
|
|
},
|
|
httpCredentials = (\WebHttpsParams {key, cert} -> ServerCredentials {caCertificateFile = Nothing, privateKeyFile = key, certificateFile = cert}) <$> webHttpsParams',
|
|
serverStoreCfg,
|
|
storeNtfsFile = restoreMessagesFile storeNtfsFilePath,
|
|
-- allow creating new queues by default
|
|
allowNewQueues = fromMaybe True $ iniOnOff "AUTH" "new_queues" ini,
|
|
newQueueBasicAuth = 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,
|
|
dailyBlockQueueQuota = readIniDefault 20 "AUTH" "daily_block_queue_quota" ini,
|
|
messageExpiration =
|
|
Just
|
|
defaultMessageExpiration
|
|
{ ttl = 86400 * readIniDefault defMsgExpirationDays "STORE_LOG" "expire_messages_days" ini
|
|
},
|
|
expireMessagesOnStart = fromMaybe True $ iniOnOff "STORE_LOG" "expire_messages_on_start" ini,
|
|
expireMessagesOnSend = fromMaybe True $ iniOnOff "STORE_LOG" "expire_messages_on_send" ini,
|
|
idleQueueInterval = defaultIdleQueueInterval,
|
|
notificationExpiration =
|
|
defaultNtfExpiration
|
|
{ ttl = 3600 * readIniDefault defNtfExpirationHours "STORE_LOG" "expire_ntfs_hours" ini
|
|
},
|
|
inactiveClientExpiration =
|
|
settingIsOn "INACTIVE_CLIENTS" "disconnect" ini
|
|
$> ExpirationConfig
|
|
{ ttl = readStrictIni "INACTIVE_CLIENTS" "ttl" ini,
|
|
checkInterval = readStrictIni "INACTIVE_CLIENTS" "check_interval" ini
|
|
},
|
|
logStatsInterval = logStats $> 86400, -- seconds
|
|
logStatsStartTime = 0, -- seconds from 00:00 UTC
|
|
serverStatsLogFile = combine logPath "smp-server-stats.daily.log",
|
|
serverStatsBackupFile = logStats $> combine logPath "smp-server-stats.log",
|
|
prometheusInterval = eitherToMaybe $ read . T.unpack <$> lookupValue "STORE_LOG" "prometheus_interval" ini,
|
|
prometheusMetricsFile = combine logPath "smp-server-metrics.txt",
|
|
pendingENDInterval = 15000000, -- 15 seconds
|
|
ntfDeliveryInterval = 1500000, -- 1.5 second
|
|
smpServerVRange = supportedServerSMPRelayVRange,
|
|
transportConfig =
|
|
mkTransportServerConfig
|
|
(fromMaybe False $ iniOnOff "TRANSPORT" "log_tls_errors" ini)
|
|
(Just $ alpnSupportedSMPHandshakes <> httpALPN)
|
|
(fromMaybe True $ iniOnOff "TRANSPORT" "accept_service_credentials" ini), -- TODO [certs] remove this option
|
|
controlPort = eitherToMaybe $ T.unpack <$> lookupValue "TRANSPORT" "control_port" ini,
|
|
smpAgentCfg =
|
|
defaultSMPClientAgentConfig
|
|
{ smpCfg =
|
|
(smpCfg defaultSMPClientAgentConfig)
|
|
{ serverVRange = supportedProxyClientSMPRelayVRange,
|
|
agreeSecret = True,
|
|
proxyServer = True,
|
|
networkConfig =
|
|
defaultNetworkConfig
|
|
{ socksProxy = either error id <$!> strDecodeIni "PROXY" "socks_proxy" ini,
|
|
socksMode = maybe SMOnion (either error id) $! strDecodeIni "PROXY" "socks_mode" ini,
|
|
hostMode = either (const HMPublic) (either error id . textToHostMode) $ lookupValue "PROXY" "host_mode" ini,
|
|
requiredHostMode = fromMaybe False $ iniOnOff "PROXY" "required_host_mode" ini,
|
|
smpWebPortServers = SWPOff
|
|
}
|
|
},
|
|
ownServerDomains = either (const []) textToOwnServers $ lookupValue "PROXY" "own_server_domains" ini,
|
|
persistErrorInterval = 30 -- seconds
|
|
},
|
|
allowSMPProxy = True,
|
|
serverClientConcurrency = readIniDefault defaultProxyClientConcurrency "PROXY" "client_concurrency" ini,
|
|
information = serverPublicInfo ini,
|
|
startOptions
|
|
}
|
|
textToOwnServers :: Text -> [ByteString]
|
|
textToOwnServers = map encodeUtf8 . T.words
|
|
runWebServer webStaticPath webHttpsParams si = do
|
|
let onionHost =
|
|
either (const Nothing) (find isOnion) $
|
|
strDecode @(L.NonEmpty TransportHost) . encodeUtf8 =<< lookupValue "TRANSPORT" "host" ini
|
|
webHttpPort = eitherToMaybe $ read . T.unpack <$> lookupValue "WEB" "http" ini
|
|
generateSite si onionHost webStaticPath
|
|
when (isJust webHttpPort || isJust webHttpsParams) $
|
|
serveStaticFiles EmbeddedWebParams {webStaticPath, webHttpPort, webHttpsParams}
|
|
where
|
|
isOnion = \case THOnionHost _ -> True; _ -> False
|
|
webHttpsParams' =
|
|
eitherToMaybe $ do
|
|
port <- read . T.unpack <$> lookupValue "WEB" "https" ini
|
|
cert <- T.unpack <$> lookupValue "WEB" "cert" ini
|
|
key <- T.unpack <$> lookupValue "WEB" "key" ini
|
|
pure WebHttpsParams {port, cert, key}
|
|
webStaticPath' = eitherToMaybe $ T.unpack <$> lookupValue "WEB" "static_path" ini
|
|
|
|
checkMsgStoreMode :: Ini -> AStoreType -> IO ()
|
|
checkMsgStoreMode ini mode = do
|
|
msgsDirExists <- doesDirectoryExist storeMsgsJournalDir
|
|
msgsFileExists <- doesFileExist storeMsgsFilePath
|
|
storeLogExists <- doesFileExist storeLogFilePath
|
|
case mode of
|
|
#if defined(dbServerPostgres)
|
|
ASType SQSPostgres SMSPostgres
|
|
| msgsFileExists || msgsDirExists -> do
|
|
putStrLn $ "Error: " <> storeMsgsFilePath <> " file or " <> storeMsgsJournalDir <> " directory are present."
|
|
putStrLn "Configure memory storage."
|
|
exitFailure
|
|
| otherwise -> checkDbStorage ini storeLogExists
|
|
#endif
|
|
ASType qs SMSJournal
|
|
| msgsFileExists && msgsDirExists -> exitConfigureMsgStorage
|
|
| msgsFileExists -> do
|
|
putStrLn $ "Error: store_messages is `journal` with " <> storeMsgsFilePath <> " file present."
|
|
putStrLn "Set store_messages to `memory` or use `smp-server journal export` to migrate."
|
|
exitFailure
|
|
| not msgsDirExists ->
|
|
putStrLn $ "store_messages is `journal`, " <> storeMsgsJournalDir <> " directory will be created."
|
|
| otherwise -> case qs of
|
|
SQSMemory ->
|
|
unless (storeLogExists) $ putStrLn $ "store_queues is `memory`, " <> storeLogFilePath <> " file will be created."
|
|
#if defined(dbServerPostgres)
|
|
SQSPostgres -> checkDbStorage ini storeLogExists
|
|
#else
|
|
SQSPostgres -> noPostgresExit
|
|
#endif
|
|
ASType SQSMemory SMSMemory
|
|
| msgsFileExists && msgsDirExists -> exitConfigureMsgStorage
|
|
| msgsDirExists -> do
|
|
putStrLn $ "Error: store_messages is `memory` with " <> storeMsgsJournalDir <> " directory present."
|
|
putStrLn "Set store_messages to `journal` or use `smp-server journal import` to migrate."
|
|
exitFailure
|
|
| otherwise -> pure ()
|
|
|
|
exitConfigureMsgStorage = do
|
|
putStrLn $ "Error: both " <> storeMsgsFilePath <> " file and " <> storeMsgsJournalDir <> " directory are present."
|
|
putStrLn "Configure memory storage."
|
|
exitFailure
|
|
|
|
#if defined(dbServerPostgres)
|
|
checkDbStorage ini storeLogExists = do
|
|
let DBOpts {connstr, schema} = iniDBOptions ini defaultDBOpts
|
|
schemaExists <- checkSchemaExists connstr schema
|
|
case enableDbStoreLog' ini of
|
|
Just ()
|
|
| not schemaExists -> noDatabaseSchema connstr schema
|
|
| not storeLogExists -> do
|
|
putStrLn $ "Error: db_store_log is `on`, " <> storeLogFilePath <> " does not exist"
|
|
exitFailure
|
|
| otherwise -> pure ()
|
|
Nothing
|
|
| storeLogExists && schemaExists -> exitConfigureQueueStore connstr schema
|
|
| storeLogExists -> do
|
|
putStrLn $ "Error: store_queues is `database` with " <> storeLogFilePath <> " file present."
|
|
putStrLn "Set store_queues to `memory` or use `smp-server database import` to migrate."
|
|
exitFailure
|
|
| not schemaExists -> noDatabaseSchema connstr schema
|
|
| otherwise -> pure ()
|
|
where
|
|
noDatabaseSchema connstr schema = do
|
|
putStrLn $ "Error: store_queues is `database`, create schema " <> B.unpack schema <> " in PostgreSQL database " <> B.unpack connstr
|
|
exitFailure
|
|
|
|
exitConfigureQueueStore connstr schema = do
|
|
putStrLn $ "Error: both " <> storeLogFilePath <> " file and " <> B.unpack schema <> " schema are present (database: " <> B.unpack connstr <> ")."
|
|
putStrLn "Configure queue storage."
|
|
exitFailure
|
|
|
|
importStoreLogToDatabase :: FilePath -> FilePath -> DBOpts -> IO (Int64, Int64)
|
|
importStoreLogToDatabase logPath storeLogFile dbOpts = do
|
|
ms <- newJournalMsgStore logPath MQStoreCfg
|
|
let st = stmQueueStore ms
|
|
sl <- readWriteQueueStore True (mkQueue ms False) storeLogFile st
|
|
closeStoreLog sl
|
|
queues <- readTVarIO $ loadedQueues st
|
|
services' <- M.elems <$> readTVarIO (services st)
|
|
let storeCfg = PostgresStoreCfg {dbOpts = dbOpts {createSchema = True}, dbStoreLogPath = Nothing, confirmMigrations = MCConsole, deletedTTL = 86400 * defaultDeletedTTL}
|
|
ps <- newJournalMsgStore logPath $ PQStoreCfg storeCfg
|
|
sCnt <- batchInsertServices services' $ postgresQueueStore ps
|
|
qCnt <- batchInsertQueues @(JournalQueue 'QSMemory) True queues $ postgresQueueStore ps
|
|
renameFile storeLogFile $ storeLogFile <> ".bak"
|
|
pure (sCnt, qCnt)
|
|
|
|
importMessagesToDatabase :: FilePath -> DBOpts -> IO Int64
|
|
importMessagesToDatabase msgsLogFile dbOpts = do
|
|
let storeCfg = PostgresStoreCfg {dbOpts, dbStoreLogPath = Nothing, confirmMigrations = MCConsole, deletedTTL = 86400 * defaultDeletedTTL}
|
|
ms <- newMsgStore $ PostgresMsgStoreCfg storeCfg defaultMsgQueueQuota
|
|
mCnt <- getDbMessageCount ms
|
|
when (mCnt > 0) $ do
|
|
confirmOrExit ("WARNING: the database contains messages, they will be deleted.") "Message records not imported"
|
|
deleteAllMessages ms
|
|
inserted <- batchInsertMessages True msgsLogFile $ queueStore ms
|
|
mCnt' <- getDbMessageCount ms
|
|
unless (inserted == mCnt') $ putStrLn $ "WARNING: inserted " <> show inserted <> " rows, table has " <> show mCnt' <> " messages."
|
|
updateQueueCounts ms
|
|
renameFile msgsLogFile $ msgsLogFile <> ".bak"
|
|
pure mCnt'
|
|
|
|
exportDatabaseToStoreLog :: FilePath -> DBOpts -> FilePath -> IO (Int, Int)
|
|
exportDatabaseToStoreLog logPath dbOpts storeLogFilePath = do
|
|
let storeCfg = PostgresStoreCfg {dbOpts, dbStoreLogPath = Nothing, confirmMigrations = MCConsole, deletedTTL = 86400 * defaultDeletedTTL}
|
|
ps <- newJournalMsgStore logPath $ PQStoreCfg storeCfg
|
|
sl <- openWriteStoreLog False storeLogFilePath
|
|
Sum sCnt <- foldServiceRecs (postgresQueueStore ps) $ \sr -> logNewService sl sr $> Sum (1 :: Int)
|
|
Sum qCnt <- foldQueueRecs True True (postgresQueueStore ps) $ \(rId, qr) -> logCreateQueue sl rId qr $> Sum (1 :: Int)
|
|
closeStoreLog sl
|
|
pure (sCnt, qCnt)
|
|
#endif
|
|
|
|
newJournalMsgStore :: FilePath -> QStoreCfg s -> IO (JournalMsgStore s)
|
|
newJournalMsgStore logPath qsCfg =
|
|
let cfg = mkJournalStoreConfig qsCfg (storeMsgsJournalDir' logPath) defaultMsgQueueQuota defaultMaxJournalMsgCount defaultMaxJournalStateLines $ checkInterval defaultMessageExpiration
|
|
in newMsgStore cfg
|
|
|
|
storeMsgsJournalDir' :: FilePath -> FilePath
|
|
storeMsgsJournalDir' logPath = combine logPath "messages"
|
|
|
|
data EmbeddedWebParams = EmbeddedWebParams
|
|
{ webStaticPath :: FilePath,
|
|
webHttpPort :: Maybe Int,
|
|
webHttpsParams :: Maybe WebHttpsParams
|
|
}
|
|
|
|
data WebHttpsParams = WebHttpsParams
|
|
{ port :: Int,
|
|
cert :: FilePath,
|
|
key :: FilePath
|
|
}
|
|
|
|
getServerSourceCode :: IO (Maybe String)
|
|
getServerSourceCode =
|
|
getLine >>= \case
|
|
"" -> pure Nothing
|
|
s | "https://" `isPrefixOf` s || "http://" `isPrefixOf` s -> pure $ Just s
|
|
_ -> putStrLn "Invalid source code. URI should start from http:// or https://" >> getServerSourceCode
|
|
|
|
simplexmqSource :: String
|
|
simplexmqSource = "https://github.com/simplex-chat/simplexmq"
|
|
|
|
serverPublicInfo :: Ini -> Maybe ServerPublicInfo
|
|
serverPublicInfo ini = serverInfo <$!> infoValue "source_code"
|
|
where
|
|
serverInfo sourceCode =
|
|
ServerPublicInfo
|
|
{ sourceCode,
|
|
usageConditions =
|
|
(\conditions -> ServerConditions {conditions, amendments = infoValue "condition_amendments"})
|
|
<$!> infoValue "usage_conditions",
|
|
serverCountry = countryValue "server_country",
|
|
operator = iniEntity "operator" "operator_country",
|
|
website = infoValue "website",
|
|
adminContacts = iniContacts "admin_simplex" "admin_email" "admin_pgp" "admin_pgp_fingerprint",
|
|
complaintsContacts = iniContacts "complaints_simplex" "complaints_email" "complaints_pgp" "complaints_pgp_fingerprint",
|
|
hosting = iniEntity "hosting" "hosting_country",
|
|
hostingType = either error id <$!> strDecodeIni "INFORMATION" "hosting_type" ini
|
|
}
|
|
infoValue name = eitherToMaybe $ lookupValue "INFORMATION" name ini
|
|
iniEntity nameField countryField =
|
|
(\name -> Entity {name, country = countryValue countryField})
|
|
<$!> infoValue nameField
|
|
countryValue field = (either error id . validCountryValue (T.unpack field) . T.unpack) <$!> infoValue field
|
|
iniContacts simplexField emailField pgpKeyUriField pgpKeyFingerprintField =
|
|
let simplex = either error id . parseAll linkP . encodeUtf8 <$!> eitherToMaybe (lookupValue "INFORMATION" simplexField ini)
|
|
linkP = CLFull <$> connReqUriP' Nothing <|> CLShort <$> strP
|
|
email = infoValue emailField
|
|
pkURI_ = infoValue pgpKeyUriField
|
|
pkFingerprint_ = infoValue pgpKeyFingerprintField
|
|
in case (simplex, email, pkURI_, pkFingerprint_) of
|
|
(Nothing, Nothing, Nothing, _) -> Nothing
|
|
(Nothing, Nothing, _, Nothing) -> Nothing
|
|
(_, _, pkURI, pkFingerprint) -> Just ServerContactAddress {simplex, email, pgp = PGPKey <$> pkURI <*> pkFingerprint}
|
|
|
|
validCountryValue :: String -> String -> Either String Text
|
|
validCountryValue field s
|
|
| length s == 2 && all (\c -> isAscii c && isAlpha c) s = Right $ T.pack $ map toUpper s
|
|
| otherwise = Left $ "Use ISO3166 2-letter code for " <> field
|
|
|
|
printSourceCode :: Maybe Text -> IO ()
|
|
printSourceCode = \case
|
|
Just sourceCode -> T.putStrLn $ "Server source code: " <> sourceCode
|
|
Nothing -> do
|
|
putStrLn "Warning: server source code is not specified."
|
|
putStrLn "Add 'source_code' property to [INFORMATION] section of INI file."
|
|
|
|
data CliCommand
|
|
= Init InitOptions
|
|
| OnlineCert CertOptions
|
|
| Start StartOptions
|
|
| Delete
|
|
| Journal StoreCmd
|
|
| Database StoreCmd DatabaseTable DBOpts
|
|
|
|
data StoreCmd = SCImport | SCExport | SCDelete
|
|
|
|
data DatabaseTable = DTQueues | DTMessages | DTAll
|
|
|
|
instance StrEncoding DatabaseTable where
|
|
strEncode = \case
|
|
DTQueues -> "queues"
|
|
DTMessages -> "messages"
|
|
DTAll -> "all"
|
|
strP =
|
|
A.takeTill (== ' ') >>= \case
|
|
"queues" -> pure DTQueues
|
|
"messages" -> pure DTMessages
|
|
"all" -> pure DTAll
|
|
_ -> fail "DatabaseTable"
|
|
|
|
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 <$> startOptionsP) (progDesc $ "Start server (configuration: " <> iniFile <> ")"))
|
|
<> command "delete" (info (pure Delete) (progDesc "Delete configuration and log files"))
|
|
<> command "journal" (info (Journal <$> journalCmdP) (progDesc "Import/export messages to/from journal storage"))
|
|
<> command "database" (info (Database <$> databaseCmdP <*> dbTableP <*> dbOptsP defaultDBOpts) (progDesc "Import/export queues to/from PostgreSQL database storage"))
|
|
)
|
|
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)"
|
|
)
|
|
dbOptions <- dbOptsP defaultDBOpts
|
|
logStats <-
|
|
switch
|
|
( long "daily-stats"
|
|
<> short 's'
|
|
<> help "Enable logging daily server statistics"
|
|
)
|
|
signAlgorithm <-
|
|
option
|
|
(maybeReader readMaybe)
|
|
( long "sign-algorithm"
|
|
<> short 'a'
|
|
<> help "Signature algorithm used for TLS certificates: ED25519, ED448"
|
|
<> value ED25519
|
|
<> 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"
|
|
<> metavar "FQDN"
|
|
)
|
|
password <-
|
|
flag' Nothing (long "no-password" <> help "Allow creating new queues without password")
|
|
<|> Just
|
|
<$> option
|
|
parseBasicAuth
|
|
( long "password"
|
|
<> metavar "PASSWORD"
|
|
<> help "Set password to create new messaging queues"
|
|
<> value SPRandom
|
|
)
|
|
controlPort <-
|
|
flag' (Just defaultControlPort) (long "control-port" <> help ("Enable control port on " <> show defaultControlPort))
|
|
<|> option strParse (long "control-port" <> help "Enable control port" <> metavar "PORT" <> value Nothing)
|
|
socksProxy <-
|
|
flag' (Just defaultSocksProxy) (long "socks-proxy" <> help "Outgoing SOCKS proxy on port 9050")
|
|
<|> option
|
|
strParse
|
|
( long "socks-proxy"
|
|
<> metavar "PROXY"
|
|
<> help "Outgoing SOCKS proxy to forward messages to onion-only servers"
|
|
<> value Nothing
|
|
)
|
|
ownDomains :: Maybe (L.NonEmpty TransportHost) <-
|
|
option
|
|
strParse
|
|
( long "own-domains"
|
|
<> metavar "DOMAINS"
|
|
<> help "Own server domain names (comma-separated)"
|
|
<> value Nothing
|
|
)
|
|
sourceCode <-
|
|
flag' (Just simplexmqSource) (long "source-code" <> help ("Server source code (default: " <> simplexmqSource <> ")"))
|
|
<|> (optional . strOption) (long "source-code" <> metavar "URI" <> help "Server source code")
|
|
operator_ <- entityP "operator" "OPERATOR" "Server operator"
|
|
hosting_ <- entityP "hosting" "HOSTING" "Hosting provider"
|
|
hostingType <-
|
|
option
|
|
strParse
|
|
( long "hosting-type"
|
|
<> metavar "HOSTING_TYPE"
|
|
<> help "Hosting type: virtual, dedicated, colocation, owned"
|
|
<> value Nothing
|
|
)
|
|
serverCountry <- countryP "server" "SERVER" "Server datacenter"
|
|
website <-
|
|
(optional . strOption)
|
|
( long "operator-website"
|
|
<> help "Operator public website"
|
|
<> metavar "WEBSITE"
|
|
)
|
|
webStaticPath <-
|
|
(optional . strOption)
|
|
( long "web-path"
|
|
<> help "Directory to store generated static site with server information"
|
|
<> metavar "PATH"
|
|
)
|
|
disableWeb <-
|
|
switch
|
|
( long "disable-web"
|
|
<> help "Disable starting static web server with server information"
|
|
)
|
|
scripted <-
|
|
switch
|
|
( long "yes"
|
|
<> short 'y'
|
|
<> help "Non-interactive initialization using command-line options"
|
|
)
|
|
pure
|
|
InitOptions
|
|
{ enableStoreLog,
|
|
dbOptions,
|
|
logStats,
|
|
signAlgorithm,
|
|
ip,
|
|
fqdn,
|
|
password,
|
|
controlPort,
|
|
socksProxy,
|
|
ownDomains,
|
|
sourceCode = T.pack <$> sourceCode,
|
|
serverInfo =
|
|
ServerPublicInfo
|
|
{ sourceCode = T.pack $ fromMaybe simplexmqSource sourceCode,
|
|
usageConditions = Nothing,
|
|
operator = fst operator_,
|
|
website,
|
|
adminContacts = Nothing,
|
|
complaintsContacts = Nothing,
|
|
hosting = fst hosting_,
|
|
hostingType,
|
|
serverCountry
|
|
},
|
|
operatorCountry = snd operator_,
|
|
hostingCountry = snd hosting_,
|
|
webStaticPath,
|
|
disableWeb,
|
|
scripted
|
|
}
|
|
journalCmdP = storeCmdP "message log file" "journal storage"
|
|
databaseCmdP = storeCmdP "queue store log file" "PostgreSQL database schema"
|
|
storeCmdP src dest =
|
|
hsubparser
|
|
( command "import" (info (pure SCImport) (progDesc $ "Import " <> src <> " into a new " <> dest))
|
|
<> command "export" (info (pure SCExport) (progDesc $ "Export " <> dest <> " to " <> src))
|
|
<> command "delete" (info (pure SCDelete) (progDesc $ "Delete " <> dest))
|
|
)
|
|
dbTableP =
|
|
option
|
|
strParse
|
|
( long "table"
|
|
<> help "Database tables: queues/messages"
|
|
<> metavar "TABLE"
|
|
<> value DTAll
|
|
)
|
|
parseBasicAuth :: ReadM ServerPassword
|
|
parseBasicAuth = eitherReader $ fmap ServerPassword . strDecode . B.pack
|
|
entityP :: String -> String -> String -> Parser (Maybe Entity, Maybe Text)
|
|
entityP opt' metavar' help' = do
|
|
name_ <-
|
|
(optional . strOption)
|
|
( long opt'
|
|
<> metavar (metavar' <> "_NAME")
|
|
<> help (help' <> " name")
|
|
)
|
|
country <- countryP opt' metavar' help'
|
|
pure ((\name -> Entity {name, country}) <$> name_, country)
|
|
countryP :: String -> String -> String -> Parser (Maybe Text)
|
|
countryP opt' metavar' help' =
|
|
(optional . option (eitherReader $ validCountryValue opt'))
|
|
( long (opt' <> "-country")
|
|
<> metavar (metavar' <> "_COUNTRY")
|
|
<> help (help' <> " country")
|
|
)
|
|
|
|
strParse :: StrEncoding a => ReadM a
|
|
strParse = eitherReader $ parseAll strP . encodeUtf8 . T.pack
|