mirror of
https://github.com/simplex-chat/simplexmq.git
synced 2026-10-23 17:22:34 +00:00
smp server: PostgreSQL queue store (#1448)
* smp server: queue store typeclass * parameterize JournalMsgStore * typeclass for queue store * postgres WIP * compiles, passes tests * remove StoreType * split migrations * progress * addQueueRec * reduce type spaghetti * remove addQueue from typeclass definition * getQueue * test postgres storage in SMP server * fix schema * comment * import queues to postgresql * import queues to postgresql * log * fix test * counts * ci: test smp server with postgres backend (#1463) * ci: test smp server with postgres backend * postgres service * attempt * attempt * empty * empty * PGHOST attempt * PGHOST + softlink attempt * only softlink attempt * working attempt (PGHOST) * remove env var * empty * do not start server without DB schema, do not import when schema exists * export database * enable all tests, disable two tests * option for migration confirmation * comments --------- Co-authored-by: spaced4ndy <8711996+spaced4ndy@users.noreply.github.com>
This commit is contained in:
1 parent
f9d7b1eebc
commit
4dc40bd795
42 files changed
+1757
-819
No files matched your search
@@ -1,4 +1,5 @@
|
||||
{-# LANGUAGE ApplicativeDo #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
@@ -26,6 +27,7 @@ import Data.Ini (Ini, lookupValue, readIniFile)
|
||||
import Data.List (find, isPrefixOf)
|
||||
import qualified Data.List.NonEmpty as L
|
||||
import Data.Maybe (fromMaybe, isJust, isNothing)
|
||||
import Data.Semigroup (Sum (..))
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import Data.Text.Encoding (decodeLatin1, encodeUtf8)
|
||||
@@ -33,6 +35,9 @@ import qualified Data.Text.IO as T
|
||||
import Network.Socket (HostName)
|
||||
import Options.Applicative
|
||||
import Simplex.Messaging.Agent.Protocol (connReqUriP')
|
||||
import Simplex.Messaging.Agent.Store.Postgres (checkSchemaExists)
|
||||
import Simplex.Messaging.Agent.Store.Postgres.Common (DBOpts (..))
|
||||
import Simplex.Messaging.Agent.Store.Shared (MigrationConfirmation (..))
|
||||
import Simplex.Messaging.Client (HostMode (..), NetworkConfig (..), ProtocolClientConfig (..), SocksMode (..), defaultNetworkConfig, textToHostMode)
|
||||
import Simplex.Messaging.Client.Agent (SMPClientAgentConfig (..), defaultSMPClientAgentConfig)
|
||||
import qualified Simplex.Messaging.Crypto as C
|
||||
@@ -44,13 +49,17 @@ 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.MsgStore.Types (AMSType (..), SMSType (..), newMsgStore)
|
||||
import Simplex.Messaging.Server.QueueStore.STM (readQueueStore)
|
||||
import Simplex.Messaging.Server.MsgStore.Journal (JournalMsgStore (..), JournalQueue, QStoreCfg (..), postgresQueueStore, stmQueueStore)
|
||||
import Simplex.Messaging.Server.MsgStore.Types (MsgStoreClass (..), QSType (..), SQSType (..), SMSType (..), newMsgStore)
|
||||
import Simplex.Messaging.Server.QueueStore.Postgres (batchInsertQueues, foldQueueRecs)
|
||||
import Simplex.Messaging.Server.QueueStore.Types
|
||||
import Simplex.Messaging.Server.StoreLog (logCreateQueue, openWriteStoreLog)
|
||||
import Simplex.Messaging.Server.StoreLog.ReadWrite (readQueueStore)
|
||||
import Simplex.Messaging.Transport (simplexMQVersion, supportedProxyClientSMPRelayVRange, supportedServerSMPRelayVRange)
|
||||
import Simplex.Messaging.Transport.Client (SocksProxy, TransportHost (..), defaultSocksProxy)
|
||||
import Simplex.Messaging.Transport.Server (ServerCredentials (..), TransportServerConfig (..), defaultTransportServerConfig)
|
||||
import Simplex.Messaging.Util (eitherToMaybe, ifM, safeDecodeUtf8, tshow)
|
||||
import System.Directory (createDirectoryIfMissing, doesDirectoryExist, doesFileExist)
|
||||
import System.Directory (createDirectoryIfMissing, doesDirectoryExist, doesFileExist, renameFile)
|
||||
import System.Exit (exitFailure)
|
||||
import System.FilePath (combine)
|
||||
import System.IO (BufferMode (..), hSetBuffering, stderr, stdout)
|
||||
@@ -84,37 +93,30 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath =
|
||||
Journal cmd -> withIniFile $ \ini -> do
|
||||
msgsDirExists <- doesDirectoryExist storeMsgsJournalDir
|
||||
msgsFileExists <- doesFileExist storeMsgsFilePath
|
||||
let enableStoreLog = settingIsOn "STORE_LOG" "enable" ini
|
||||
storeLogFile <- case enableStoreLog $> 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
|
||||
storeLogFile <- getRequiredStoreLogFile ini
|
||||
case cmd of
|
||||
JCImport
|
||||
SCImport
|
||||
| msgsFileExists && msgsDirExists -> exitConfigureMsgStorage
|
||||
| msgsDirExists -> do
|
||||
putStrLn $ storeMsgsJournalDir <> " directory already exists."
|
||||
exitFailure
|
||||
| not msgsFileExists -> do
|
||||
putStrLn $ storeMsgsFilePath <> " file does not exists."
|
||||
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
|
||||
readQueueStore storeLogFile ms
|
||||
ms <- newJournalMsgStore MQStoreCfg
|
||||
readQueueStore True (mkQueue ms) storeLogFile $ stmQueueStore ms
|
||||
msgStats <- importMessages True ms storeMsgsFilePath Nothing False -- no expiration
|
||||
putStrLn "Import completed"
|
||||
printMessageStats "Messages" msgStats
|
||||
putStrLn $ case readMsgStoreType ini of
|
||||
Right (AMSType SMSMemory) -> "store_messages set to `memory`, update it to `journal` in INI file"
|
||||
Right (AMSType SMSJournal) -> "store_messages set to `journal`"
|
||||
Left e -> e <> ", update it to `journal` in INI file"
|
||||
JCExport
|
||||
putStrLn $ case readStoreType ini of
|
||||
Right (ASType SQSMemory SMSMemory) -> "store_messages set to `memory`, 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."
|
||||
@@ -123,15 +125,17 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath =
|
||||
confirmOrExit
|
||||
("WARNING: journal directory " <> storeMsgsJournalDir <> " will be exported to message log file " <> storeMsgsFilePath)
|
||||
"Journal not exported"
|
||||
ms <- newJournalMsgStore
|
||||
readQueueStore storeLogFile ms
|
||||
-- TODO [postgres]
|
||||
ms <- newJournalMsgStore MQStoreCfg
|
||||
readQueueStore True (mkQueue ms) storeLogFile $ stmQueueStore ms
|
||||
exportMessages True ms storeMsgsFilePath False
|
||||
putStrLn "Export completed"
|
||||
putStrLn $ case readMsgStoreType ini of
|
||||
Right (AMSType SMSMemory) -> "store_messages set to `memory`"
|
||||
Right (AMSType SMSJournal) -> "store_messages set to `journal`, update it to `memory` in INI file"
|
||||
Left e -> e <> ", update it to `memory` in INI file"
|
||||
JCDelete
|
||||
putStrLn $ case readStoreType ini of
|
||||
Right (ASType SQSMemory SMSMemory) -> "store_messages set to `memory`, start the server."
|
||||
Right (ASType SQSMemory SMSJournal) -> "store_messages set to `journal`, update it to `memory` in INI file"
|
||||
Right (ASType SQSPostgres SMSJournal) -> "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`)."
|
||||
Left e -> e <> ", configure storage correctly"
|
||||
SCDelete
|
||||
| not msgsDirExists -> do
|
||||
putStrLn $ storeMsgsJournalDir <> " directory does not exists."
|
||||
exitFailure
|
||||
@@ -141,13 +145,73 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath =
|
||||
"Messages NOT deleted"
|
||||
deleteDirIfExists storeMsgsJournalDir
|
||||
putStrLn $ "Deleted all messages in journal " <> storeMsgsJournalDir
|
||||
Database cmd dbOpts@DBOpts {connstr, schema} -> withIniFile $ \ini -> do
|
||||
schemaExists <- checkSchemaExists connstr schema
|
||||
storeLogExists <- doesFileExist storeLogFilePath
|
||||
case cmd of
|
||||
SCImport
|
||||
| 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 imported to PostrgreSQL database: " <> B.unpack connstr <> ", schema: " <> B.unpack schema)
|
||||
"Queue records not imported"
|
||||
ms <- newJournalMsgStore MQStoreCfg
|
||||
readQueueStore True (mkQueue ms) storeLogFile (queueStore ms)
|
||||
queues <- readTVarIO $ loadedQueues $ stmQueueStore ms
|
||||
ps <- newJournalMsgStore $ PQStoreCfg dbOpts {createSchema = True} MCConsole
|
||||
(qCnt, nCnt) <- batchInsertQueues @(JournalQueue 'QSMemory) True queues $ postgresQueueStore ps
|
||||
renameFile storeLogFile $ storeLogFile <> ".bak"
|
||||
putStrLn $ "Import completed: " <> show qCnt <> " queues, " <> show nCnt <> " notifiers"
|
||||
putStrLn $ case readStoreType ini of
|
||||
Right (ASType SQSMemory SMSMemory) -> "store_messages set to `memory`.\nImport messages to journal to use PostgreSQL database for queues (`smp-server journal import`)"
|
||||
Right (ASType SQSMemory SMSJournal) -> "store_queues set to `memory`, update it to `database` in INI file"
|
||||
Right (ASType SQSPostgres SMSJournal) -> "store_queues set to `database`, start the server."
|
||||
Left e -> e <> ", configure storage correctly"
|
||||
SCExport
|
||||
| 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 database schema " <> B.unpack schema <> " (database: " <> B.unpack connstr <> ") will be exported to store log file " <> storeLogFilePath)
|
||||
"Queue records not exported"
|
||||
ps <- newJournalMsgStore $ PQStoreCfg dbOpts MCConsole
|
||||
sl <- openWriteStoreLog storeLogFilePath
|
||||
Sum qCnt <- foldQueueRecs True (postgresQueueStore ps) $ \rId qr -> logCreateQueue sl rId qr $> Sum (1 :: Int)
|
||||
putStrLn $ "Export completed: " <> show qCnt <> " queues"
|
||||
putStrLn $ case readStoreType ini of
|
||||
Right (ASType SQSPostgres SMSJournal) -> "store_queues 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"
|
||||
SCDelete -> undefined -- TODO [postgres]
|
||||
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`."
|
||||
newJournalMsgStore =
|
||||
let cfg = mkJournalStoreConfig storeMsgsJournalDir defaultMsgQueueQuota defaultMaxJournalMsgCount defaultMaxJournalStateLines $ checkInterval defaultMessageExpiration
|
||||
getRequiredStoreLogFile ini = do
|
||||
let enableStoreLog = settingIsOn "STORE_LOG" "enable" ini
|
||||
case enableStoreLog $> 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
|
||||
newJournalMsgStore :: QStoreCfg s -> IO (JournalMsgStore s)
|
||||
newJournalMsgStore qsCfg =
|
||||
let cfg = mkJournalStoreConfig qsCfg storeMsgsJournalDir defaultMsgQueueQuota defaultMaxJournalMsgCount defaultMaxJournalStateLines $ checkInterval defaultMessageExpiration
|
||||
in newMsgStore cfg
|
||||
iniFile = combine cfgPath "smp-server.ini"
|
||||
serverVersion = "SMP server v" <> simplexMQVersion
|
||||
@@ -157,12 +221,23 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath =
|
||||
storeMsgsFilePath = combine logPath "smp-server-messages.log"
|
||||
storeMsgsJournalDir = combine logPath "messages"
|
||||
storeNtfsFilePath = combine logPath "smp-server-ntfs.log"
|
||||
readMsgStoreType :: Ini -> Either String AMSType
|
||||
readMsgStoreType = textToMsgStoreType . fromRight "memory" . lookupValue "STORE_LOG" "store_messages"
|
||||
textToMsgStoreType = \case
|
||||
"memory" -> Right $ AMSType SMSMemory
|
||||
"journal" -> Right $ AMSType SMSJournal
|
||||
s -> Left $ "invalid store_messages: " <> T.unpack s
|
||||
readStoreType :: Ini -> Either String AStoreType
|
||||
readStoreType ini = case (iniStoreQueues, iniStoreMessage) of
|
||||
("memory", "memory") -> Right $ ASType SQSMemory SMSMemory
|
||||
("memory", "journal") -> Right $ ASType SQSMemory SMSJournal
|
||||
("database", "journal") -> Right $ ASType SQSPostgres SMSJournal
|
||||
("database", "memory") -> Left "Using PostgreSQL database requires journal memory storage."
|
||||
(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
|
||||
iniDBOptions :: Ini -> DBOpts
|
||||
iniDBOptions ini =
|
||||
DBOpts
|
||||
{ connstr = either (const defaultDBConnStr) encodeUtf8 $ lookupValue "STORE_LOG" "db_connection" ini,
|
||||
schema = either (const defaultDBSchema) encodeUtf8 $ lookupValue "STORE_LOG" "db_schema" ini,
|
||||
createSchema = False
|
||||
}
|
||||
httpsCertFile = combine cfgPath "web.crt"
|
||||
httpsKeyFile = combine cfgPath "web.key"
|
||||
defaultStaticPath = combine logPath "www"
|
||||
@@ -210,7 +285,7 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath =
|
||||
Just "Error: passing --hosting-country requires passing --hosting"
|
||||
| otherwise = Nothing
|
||||
forM_ err_ $ \err -> putStrLn err >> exitFailure
|
||||
initialize opts'@InitOptions {enableStoreLog, logStats, signAlgorithm, password, controlPort, socksProxy, ownDomains, sourceCode, webStaticPath, disableWeb} = do
|
||||
initialize opts'@InitOptions {enableStoreLog, dbOptions, logStats, signAlgorithm, password, controlPort, socksProxy, ownDomains, sourceCode, webStaticPath, disableWeb} = do
|
||||
checkInitOptions opts'
|
||||
clearDirIfExists cfgPath
|
||||
clearDirIfExists logPath
|
||||
@@ -236,12 +311,17 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath =
|
||||
iniFileContent host basicAuth controlPortPwds =
|
||||
informationIniContent opts'
|
||||
<> "[STORE_LOG]\n\
|
||||
\# The server uses STM memory for persistence,\n\
|
||||
\# that will be lost on restart (e.g., as with redis).\n\
|
||||
\# This option enables saving memory to append only log,\n\
|
||||
\# and restoring it when the server is started.\n\
|
||||
\# The server uses memory or PostgreSQL database for persisting queue records.\n\
|
||||
\# Use `enable: on` to use append-only log to preserve and restore queue records on restart.\n\
|
||||
\# Log is compacted on start (deleted objects are removed).\n"
|
||||
<> ("enable: " <> onOff enableStoreLog <> "\n\n")
|
||||
<> "# Queue storage mode: `memory` or `database` (to store queue records in PostgreSQL database).\n\
|
||||
\# `memory` - in-memory persistence, with optional append-only log (`enable: on`).\n\
|
||||
\# `database`- PostgreSQL databass (requires `store_messages: journal`).\n\
|
||||
\store_queues: memory\n\n\
|
||||
\# Database connection settings for PostgreSQL database (`store_queues: database`).\n"
|
||||
<> (optDisabled dbOptions <> "db_connection: " <> safeDecodeUtf8 (maybe defaultDBConnStr connstr dbOptions) <> "\n")
|
||||
<> (optDisabled dbOptions <> "db_schema: " <> safeDecodeUtf8 (maybe defaultDBSchema schema dbOptions) <> "\n\n")
|
||||
<> "# Message storage mode: `memory` or `journal`.\n\
|
||||
\store_messages: memory\n\n\
|
||||
\# When store_messages is `memory`, undelivered messages are optionally saved and restored\n\
|
||||
@@ -328,13 +408,13 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath =
|
||||
fp <- checkSavedFingerprint cfgPath defaultX509Config
|
||||
let host = either (const "<hostnames>") T.unpack $ lookupValue "TRANSPORT" "host" ini
|
||||
port = T.unpack $ strictIni "TRANSPORT" "port" ini
|
||||
cfg@ServerConfig {information, storeLogFile, msgStoreType, newQueueBasicAuth, messageExpiration, inactiveClientExpiration} = serverConfig
|
||||
cfg@ServerConfig {information, serverStoreCfg, newQueueBasicAuth, messageExpiration, inactiveClientExpiration} = serverConfig
|
||||
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'
|
||||
printServerConfig transports storeLogFile
|
||||
checkMsgStoreMode msgStoreType
|
||||
printSMPServerConfig transports serverStoreCfg
|
||||
checkMsgStoreMode iniStoreType
|
||||
putStrLn $ case messageExpiration of
|
||||
Just ExpirationConfig {ttl} -> "expiring messages after " <> showTTL ttl
|
||||
_ -> "not expiring messages"
|
||||
@@ -347,10 +427,10 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath =
|
||||
then maybe "allowed" (const "requires password") newQueueBasicAuth
|
||||
else "NOT allowed"
|
||||
-- print information
|
||||
let persistence
|
||||
| isNothing storeLogFile = SPMMemoryOnly
|
||||
| isJust (storeMsgsFile cfg) = SPMMessages
|
||||
| otherwise = SPMQueues
|
||||
let persistence = case serverStoreCfg of
|
||||
ASSCfg _ _ (SSCMemory Nothing) -> SPMMemoryOnly
|
||||
ASSCfg _ _ (SSCMemory (Just StorePaths {storeMsgsFile})) | isNothing storeMsgsFile -> SPMQueues
|
||||
_ -> SPMMessages
|
||||
let config =
|
||||
ServerPublicConfig
|
||||
{ persistence,
|
||||
@@ -383,13 +463,12 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath =
|
||||
_ -> enableStoreLog $> path
|
||||
transports = iniTransports ini
|
||||
sharedHTTP = any (\(_, _, addHTTP) -> addHTTP) transports
|
||||
iniMsgStoreType = either error id $! readMsgStoreType ini
|
||||
iniStoreType = either error id $! readStoreType ini
|
||||
serverConfig =
|
||||
ServerConfig
|
||||
{ transports,
|
||||
smpHandshakeTimeout = 120000000,
|
||||
tbqSize = 128,
|
||||
msgStoreType = iniMsgStoreType,
|
||||
msgQueueQuota = defaultMsgQueueQuota,
|
||||
maxJournalMsgCount = defaultMaxJournalMsgCount,
|
||||
maxJournalStateLines = defaultMaxJournalStateLines,
|
||||
@@ -402,10 +481,13 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath =
|
||||
certificateFile = c serverCrtFile
|
||||
},
|
||||
httpCredentials = (\WebHttpsParams {key, cert} -> ServerCredentials {caCertificateFile = Nothing, privateKeyFile = key, certificateFile = cert}) <$> webHttpsParams',
|
||||
storeLogFile = enableStoreLog $> storeLogFilePath,
|
||||
storeMsgsFile = case iniMsgStoreType of
|
||||
AMSType SMSMemory -> restoreMessagesFile storeMsgsFilePath
|
||||
AMSType SMSJournal -> Just storeMsgsJournalDir,
|
||||
serverStoreCfg = case iniStoreType of
|
||||
ASType SQSMemory SMSMemory ->
|
||||
ASSCfg SQSMemory SMSMemory $ SSCMemory $ enableStoreLog $> StorePaths {storeLogFile = storeLogFilePath, storeMsgsFile = restoreMessagesFile storeMsgsFilePath}
|
||||
ASType SQSMemory SMSJournal ->
|
||||
ASSCfg SQSMemory SMSJournal $ SSCMemoryJournal {storeLogFile = storeLogFilePath, storeMsgsPath = storeMsgsJournalDir}
|
||||
ASType SQSPostgres SMSJournal ->
|
||||
ASSCfg SQSPostgres SMSJournal $ SSCDatabaseJournal {storeDBOpts = iniDBOptions ini, confirmMigrations = MCYesUp, storeMsgsPath' = storeMsgsJournalDir},
|
||||
storeNtfsFile = restoreMessagesFile storeNtfsFilePath,
|
||||
-- allow creating new queues by default
|
||||
allowNewQueues = fromMaybe True $ iniOnOff "AUTH" "new_queues" ini,
|
||||
@@ -486,20 +568,20 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath =
|
||||
pure WebHttpsParams {port, cert, key}
|
||||
webStaticPath' = eitherToMaybe $ T.unpack <$> lookupValue "WEB" "static_path" ini
|
||||
|
||||
checkMsgStoreMode :: AMSType -> IO ()
|
||||
checkMsgStoreMode :: AStoreType -> IO ()
|
||||
checkMsgStoreMode mode = do
|
||||
msgsDirExists <- doesDirectoryExist storeMsgsJournalDir
|
||||
msgsFileExists <- doesFileExist storeMsgsFilePath
|
||||
case mode of
|
||||
_ | msgsFileExists && msgsDirExists -> exitConfigureMsgStorage
|
||||
AMSType SMSJournal
|
||||
ASType _ SMSJournal -- TODO [postgres]
|
||||
| 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."
|
||||
AMSType SMSMemory
|
||||
ASType _ SMSMemory
|
||||
| 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."
|
||||
@@ -511,6 +593,11 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath =
|
||||
putStrLn "Configure memory storage."
|
||||
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
|
||||
|
||||
data EmbeddedWebParams = EmbeddedWebParams
|
||||
{ webStaticPath :: FilePath,
|
||||
webHttpPort :: Maybe Int,
|
||||
@@ -533,6 +620,12 @@ getServerSourceCode =
|
||||
simplexmqSource :: String
|
||||
simplexmqSource = "https://github.com/simplex-chat/simplexmq"
|
||||
|
||||
defaultDBConnStr :: ByteString
|
||||
defaultDBConnStr = "postgresql://smp@/smp_server_store"
|
||||
|
||||
defaultDBSchema :: ByteString
|
||||
defaultDBSchema = "smp_server"
|
||||
|
||||
defaultControlPort :: Int
|
||||
defaultControlPort = 5224
|
||||
|
||||
@@ -638,12 +731,15 @@ data CliCommand
|
||||
| OnlineCert CertOptions
|
||||
| Start StartOptions
|
||||
| Delete
|
||||
| Journal JournalCmd
|
||||
| Journal StoreCmd
|
||||
| Database StoreCmd DBOpts
|
||||
|
||||
data JournalCmd = JCImport | JCExport | JCDelete
|
||||
data StoreCmd = SCImport | SCExport | SCDelete
|
||||
|
||||
data InitOptions = InitOptions
|
||||
{ enableStoreLog :: Bool,
|
||||
dbOptions :: Maybe DBOpts,
|
||||
dbMigrateUp :: Bool,
|
||||
logStats :: Bool,
|
||||
signAlgorithm :: SignAlgorithm,
|
||||
ip :: HostName,
|
||||
@@ -673,6 +769,7 @@ cliCommandP cfgPath logPath 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 <*> dbOptsP) (progDesc "Import/export queues to/from PostgreSQL database storage"))
|
||||
)
|
||||
where
|
||||
initP :: Parser InitOptions
|
||||
@@ -683,6 +780,12 @@ cliCommandP cfgPath logPath iniFile =
|
||||
<> short 'l'
|
||||
<> help "Enable store log for persistence"
|
||||
)
|
||||
dbOptions <- optional dbOptsP
|
||||
dbMigrateUp <-
|
||||
switch
|
||||
( long "db-migrate-up"
|
||||
<> help "Automatically confirm \"up\" database migrations"
|
||||
)
|
||||
logStats <-
|
||||
switch
|
||||
( long "daily-stats"
|
||||
@@ -785,6 +888,8 @@ cliCommandP cfgPath logPath iniFile =
|
||||
pure
|
||||
InitOptions
|
||||
{ enableStoreLog,
|
||||
dbOptions,
|
||||
dbMigrateUp,
|
||||
logStats,
|
||||
signAlgorithm,
|
||||
ip,
|
||||
@@ -823,14 +928,47 @@ cliCommandP cfgPath logPath iniFile =
|
||||
( long "skip-warnings"
|
||||
<> help "Start the server with non-critical start warnings"
|
||||
)
|
||||
pure StartOptions {maintenance, skipWarnings}
|
||||
journalCmdP =
|
||||
confirmMigrations <-
|
||||
option
|
||||
parseConfirmMigrations
|
||||
( long "confirm-migrations"
|
||||
<> metavar "CONFIRM_MIGRATIONS"
|
||||
<> help "Confirm PostgreSQL database migration: up, down (default is manual confirmation)"
|
||||
<> value MCConsole
|
||||
)
|
||||
pure StartOptions {maintenance, skipWarnings, confirmMigrations}
|
||||
journalCmdP = storeCmdP "message log file" "journal storage"
|
||||
databaseCmdP = storeCmdP "queue store log file" "PostgreSQL database schema"
|
||||
storeCmdP src dest =
|
||||
hsubparser
|
||||
( command "import" (info (pure JCImport) (progDesc "Import message log file into a new journal storage"))
|
||||
<> command "export" (info (pure JCExport) (progDesc "Export journal storage to message log file"))
|
||||
<> command "delete" (info (pure JCDelete) (progDesc "Delete journal storage"))
|
||||
( 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))
|
||||
)
|
||||
|
||||
dbOptsP = do
|
||||
connstr <-
|
||||
strOption
|
||||
( long "database"
|
||||
<> short 'd'
|
||||
<> metavar "DB_CONN"
|
||||
<> help "Database connection string"
|
||||
<> value defaultDBConnStr
|
||||
<> showDefault
|
||||
)
|
||||
schema <-
|
||||
strOption
|
||||
( long "schema"
|
||||
<> metavar "DB_SCHEMA"
|
||||
<> help "Database schema"
|
||||
<> value defaultDBSchema
|
||||
<> showDefault
|
||||
)
|
||||
pure DBOpts {connstr, schema, createSchema = False}
|
||||
parseConfirmMigrations :: ReadM MigrationConfirmation
|
||||
parseConfirmMigrations = eitherReader $ \case
|
||||
"up" -> Right MCYesUp
|
||||
"down" -> Right MCYesUpDown
|
||||
_ -> Left "invalid migration confirmation, pass 'up' or 'down'"
|
||||
parseBasicAuth :: ReadM ServerPassword
|
||||
parseBasicAuth = eitherReader $ fmap ServerPassword . strDecode . B.pack
|
||||
entityP :: String -> String -> String -> Parser (Maybe Entity, Maybe Text)
|
||||
|
||||
Reference in new issue
Block a user