mirror of
https://github.com/simplex-chat/simplexmq.git
synced 2026-07-30 03:10:32 +00:00
209f7826cb
* smp-server: namespaces resolver scaffolding * smp-server: Names resolver hardening + cleanup * smp-server: fuse parallel dispatchers * smp-server: JSON wire format for NameRecord + Names.hs restructure * smp-server: redact RpcAuth in Show * smp-server: JSON wire fixups + spec rewrite + small cleanups * plan: prepend implementation-diverged banner * move SimplexName into shared module * smp-server: name + contract whitelist on RSLV * smp-server: address audit findings (canonical JSON, INI guards, SSRF, TLD case, shutdown) * smp-server: round 2 audit fixes (label case, response cap, ipv6 link-local) * smp-server: round 3 audit fixes (SSRF coverage, drop noop closeManager, CSV order) * smp-server: round 4 audit fixes (0X-hex host, expanded IPv6 forms, pingEndpoint timeout) * smp-server: hardcode TldRegistries (drop registry_tld_* INI keys) * smp-server: round 6 audit fixes (IPv6 SSRF, redirects, ASCII labels) - Reject IPv6 aliases of 169.254.169.254 (IPv4-compatible / IPv4-mapped / 6to4 / NAT64) via numeric range check on parsed IPv6. - Disable HTTP redirects on the Eth RPC request. - Restrict SimplexName labels to ASCII (Cyrillic/Greek/full-width otherwise hash to different on-chain records and diverge from UTS-46 registrars). - pingEndpoint: only JsonRpcErr means "reachable"; transport/decode failures fail startup. boundedIniInt: readMaybe over partial read. - Add 127.0.0.0/8 and 0.0.0.0 to isLoopback. - Replace hand-rolled hex helpers with Data.ByteArray.Encoding; raise managerConnCount to match rpcMaxConcurrency; hex Show for NameOwner. - Fuse parallel http/https when into unless+case; drop reverse/re-reverse in mkDomain TLDWeb; first AbiInvariantViolated; Nothing <$ decodeAddress; forM_ (eitherToMaybe ...); >>= chain in NameOwner FromJSON. - Drop dead imports/exports/pragmas and two restating comments. - Tests: factor unsafeOwner/unsafeLink, addr1/2/3, testNamesConfig; add non-ASCII label rejection coverage. * namespace: bound parser input to 253 bytes (DoS defense) The bare-name fallback and bareDomain parser would otherwise consume arbitrarily many non-space bytes via takeWhile1 before any validation or length check. A crafted multi-megabyte token would be decoded as UTF-8 and re-parsed in full before being rejected. Introduce `boundedNonSpace` (scan with 253-byte cap) at the two takeWhile1 sites. Inputs longer than 253 bytes leave residue that parseOnly's implicit endOfInput rejects, so the parser fails fast without ever allocating the full input. The bound is the DNS full-domain limit, chosen for being a familiar ceiling generous enough to cover any realistic SimpleX name (longest plausible @user.subdomain.simplex stays well under 100 bytes). No per-label cap — SimpleX names don't go through DNS label resolution and there's no semantic reason to constrain individual labels. * namespace: switch to Python HTTP resolver + agent plumbing (#1796) * namespace: relax resolver_endpoint validation (path prefix, http without auth) validateUrl gains two operator-friendly relaxations and a regression test: - Allow a path prefix (e.g. https://gw.example.com:443/snrc) for a resolver behind a reverse-proxy sub-path; /resolve/<name> and /health are appended (HttpResolver already strips one trailing slash, so root and sub-path behave identically). Query/fragment/userinfo stay rejected. - Off-loopback, reject only http WITH resolver_auth (the Authorization header would travel in cleartext). http without auth is now allowed (no secret to leak; resolver data is public — also lets dev setups reach a host resolver via http://host.docker.internal). https is always allowed, with or without auth. Plain http has no response integrity; intended for trusted/local networks only. Exports validateUrl and adds validateUrlSpec (11 cases) to SMPNamesTests. * namespace: NameRecord links as arrays (multi-link, cap 5) * namespace: distinct RSLV error responses RSLV collapsed every non-hit (no resolver, malformed name, not found, backing-store failure) to ERR AUTH, so a client iterating its configured servers could not tell "this router has no resolver, try the next" from "name not registered, stop", and a transient backend error read as an authoritative miss. Names capability is runtime config, orthogonal to the linear SMP version (a future v21 router without [NAMES] must still advertise v21), so it is signalled by a command-time error like allowSMPProxy, not by the version range: no resolver configured -> ERR CMD PROHIBITED (client skips, tries next) backing-store failure -> ERR INTERNAL (transient: retry/surface) not found / malformed -> ERR AUTH (authoritative "no such name") Update the protocol spec error table and add agent tests for the no-resolver (CMD PROHIBITED) and backend-failure (INTERNAL) paths. * refactor(names): server role + one error type Addresses epoberezkin's review (PR #1784). Name resolution becomes a server role like proxy; the agent owns resolution + server selection; one error type flows through the whole stack. - ServerRoles gains `names`; UserServers gains `nameSrvs` (opt-in list); resolveSimplexName drops the explicit server arg and picks a names-capable server via getNextServer. - RSLV carries SimplexNameDomain (was RslvRequest): no JSON on the wire, contract dropped, name validated at parse (invalid -> CMD SYNTAX). - Version check moves from the encoder to Client.hs (no ERR to server). - ErrorType.NAME {nameErr :: NameErrorType} (+ AgentErrorType.NAME), wire- and JSON-encoded; resolver errors surface with diagnostics. Success response renamed NAME -> RNAME to free the collision. - NameOwner -> EthAddress (record selector); NameRecord derives FromJSON and gains field-ordered Encoding; per-field caps removed. - Remove newEnvWithNames / runSMPServerBlockingWithNames test seams; stub resolver folded into ServerConfig.namesResolverCall_. * test(server): update stats backup line count NameResolverStatsData adds 6 lines to the server stats backup (the "rslvStats:" header plus the reqs/succ/notFound/resolverErrs/disabled fields), so testRestoreMessages' expected stats-backup line count is 95 -> 101. * feat(names): public-namespace resolution via RSLV/RNAME SNRC names resolver role: RSLV command -> HTTP resolver -> RNAME record. Agent owns server selection (ServerRoles.names); NAME error family; async, concurrency-bounded resolution; length-prefixed extensible wire; spec. * remove comments Co-authored-by: Evgeny <evgeny@poberezkin.com> * simplify * move tests name * simplify: text addresses, Tail JSON, drop admitRslv * fix * remove spaghetti * reduce diff * async again, refactor * different threads limit for name resolutions * remove comment * FromField instance for SimplexNameInfo * remove comments * unStrJSON * add sameConnShortLink * remove scheme prefix * remove unused import * remove connecttarget tests * remove comment * comment --------- Co-authored-by: Evgeny Poberezkin <evgeny@poberezkin.com> Co-authored-by: Evgeny @ SimpleX Chat <259188159+evgeny-simplex@users.noreply.github.com>
1085 lines
57 KiB
Haskell
1085 lines
57 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
|
|
( EmbeddedWebParams (..),
|
|
WebHttpsParams (..),
|
|
CliCommand (..),
|
|
StoreCmd (..),
|
|
DatabaseTable (..),
|
|
smpServerCLI,
|
|
smpServerCLI_,
|
|
#if defined(dbServerPostgres)
|
|
importStoreLogToDatabase,
|
|
importMessagesToDatabase,
|
|
exportDatabaseToStoreLog,
|
|
#endif
|
|
newJournalMsgStore,
|
|
storeMsgsJournalDir',
|
|
getServerSourceCode,
|
|
simplexmqSource,
|
|
serverPublicInfo,
|
|
validCountryValue,
|
|
validateUrl,
|
|
printSourceCode,
|
|
cliCommandP,
|
|
strParse,
|
|
) where
|
|
|
|
import Control.Concurrent.STM
|
|
import Control.Exception (finally)
|
|
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.List (dropWhileEnd, find, isPrefixOf)
|
|
import qualified Data.List.NonEmpty as L
|
|
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 Network.URI (URI (..), URIAuth (..), parseAbsoluteURI)
|
|
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.Web (EmbeddedWebParams (..), WebHttpsParams (..))
|
|
import Simplex.Messaging.Server.MsgStore.Journal (JournalMsgStore (..), QStoreCfg (..), stmQueueStore)
|
|
import Simplex.Messaging.Server.MsgStore.Types (MsgStoreClass (..), SQSType (..), SMSType (..), newMsgStore)
|
|
import Simplex.Messaging.Server.Names (NamesConfig (..), RpcAuth (..))
|
|
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)
|
|
import System.Directory (createDirectoryIfMissing, doesDirectoryExist, doesFileExist)
|
|
import System.Exit (exitFailure)
|
|
import System.FilePath (combine)
|
|
import System.IO (BufferMode (..), hSetBuffering, stderr, stdout)
|
|
import Text.Read (readMaybe)
|
|
|
|
#if defined(dbServerPostgres)
|
|
import Control.Exception (SomeException, try)
|
|
import Data.Int (Int64)
|
|
import qualified Data.Map.Strict as M
|
|
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 Simplex.Messaging.Util (unlessM)
|
|
import System.Directory (renameFile)
|
|
import System.IO (IOMode (..), withFile)
|
|
#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 (lookupValue "STORE_LOG" "prometheus_interval" ini) >>= readMaybe . T.unpack,
|
|
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)
|
|
True,
|
|
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,
|
|
serverResolverConcurrency = readIniDefault defaultNameResolverConcurrency "NAMES" "resolver_concurrency" ini,
|
|
namesConfig = readNamesConfig 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 (lookupValue "WEB" "http" ini) >>= readMaybe . T.unpack
|
|
generateSite si onionHost webStaticPath
|
|
when (isJust webHttpPort || isJust webHttpsParams) $
|
|
serveStaticFiles EmbeddedWebParams {webStaticPath, webHttpPort, webHttpsParams}
|
|
where
|
|
isOnion = \case THOnionHost _ -> True; _ -> False
|
|
webHttpsParams' = do
|
|
port <- 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, 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"
|
|
|
|
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
|
|
|
|
readNamesConfig :: Ini -> Maybe NamesConfig
|
|
readNamesConfig ini
|
|
| not enabled = Nothing
|
|
| otherwise =
|
|
let resolverAuth_ = either (error . ("[NAMES] resolver_auth: " <>)) Just . parseRpcAuth =<< eitherToMaybe (lookupValue "NAMES" "resolver_auth" ini)
|
|
endpoint = requiredText "resolver_endpoint"
|
|
in Just
|
|
NamesConfig
|
|
{ resolverEndpoint = either (error . ("[NAMES] resolver_endpoint: " <>)) id (validateUrl endpoint resolverAuth_),
|
|
resolverAuth = resolverAuth_,
|
|
resolverTimeoutMs = boundedIniInt 3000 100 60000 "resolver_timeout_ms",
|
|
resolverMaxResponseBytes = boundedIniInt 16000 1024 16000 "resolver_max_response_bytes"
|
|
}
|
|
where
|
|
enabled = fromMaybe False (iniOnOff "NAMES" "enable" ini)
|
|
requiredText key =
|
|
either (error . (("[NAMES] " <> T.unpack key <> " is required: ") <>)) id $
|
|
lookupValue "NAMES" key ini
|
|
boundedIniInt def floor_ ceiling_ key = case lookupValue "NAMES" key ini of
|
|
Left _ -> def
|
|
Right raw -> case readMaybe (T.unpack (T.strip raw)) of
|
|
Nothing ->
|
|
error $ "[NAMES] " <> T.unpack key <> ": not an integer (got " <> show raw <> ")"
|
|
Just n
|
|
| n >= floor_ && n <= ceiling_ -> n
|
|
| otherwise ->
|
|
error $ "[NAMES] " <> T.unpack key <> " must be in [" <> show floor_ <> ".." <> show ceiling_ <> "] (got " <> show n <> ")"
|
|
|
|
-- | Validate the resolver_endpoint URL: it must be an absolute http(s) URL with a host.
|
|
-- http + resolver_auth to a non-loopback host is rejected.
|
|
validateUrl :: Text -> Maybe RpcAuth -> Either String String
|
|
validateUrl url auth_ = do
|
|
let s = T.unpack url
|
|
uri <- maybe (Left "not an absolute URI") Right $ parseAbsoluteURI s
|
|
let scheme = uriScheme uri
|
|
unless (scheme == "http:" || scheme == "https:") $ Left "scheme must be http or https"
|
|
ua <- maybe (Left "missing host") Right (uriAuthority uri)
|
|
let host = uriRegName ua
|
|
when (null host) $ Left "empty host"
|
|
unless (null (uriUserInfo ua)) $ Left "userinfo (user:pass@) not allowed; put credentials in resolver_auth"
|
|
when (scheme == "http:" && isJust auth_ && not (isLoopback host)) $
|
|
Left "http with resolver_auth on a non-loopback host not allowed (the Authorization header would travel in cleartext); use https, or drop resolver_auth"
|
|
Right (dropWhileEnd (== '/') s)
|
|
where
|
|
isLoopback h = h == "localhost" || h == "127.0.0.1" || h == "[::1]" || h == "0.0.0.0"
|
|
|
|
-- | Parse an rpc_auth INI value. Scheme keyword is case-insensitive so
|
|
-- "Bearer <token>" / "BEARER <token>" (Caddy / RFC 7235 convention) work
|
|
-- as well as the lowercase form.
|
|
parseRpcAuth :: Text -> Either String RpcAuth
|
|
parseRpcAuth t = case T.words t of
|
|
[scheme, tok] | T.toLower scheme == "bearer" -> Right $ AuthBearer tok
|
|
[scheme, up] | T.toLower scheme == "basic" -> case T.breakOn ":" up of
|
|
(u, rest)
|
|
| not (T.null u) && ":" `T.isPrefixOf` rest -> Right $ AuthBasic u (T.drop 1 rest)
|
|
_ -> Left "basic auth expects user:password"
|
|
_ -> Left "expected `bearer <token>` or `basic <user>:<pass>`"
|
|
|
|
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
|