From e18ee0d437e96864c4943192e7c4eb594ffba5e8 Mon Sep 17 00:00:00 2001 From: sh Date: Thu, 15 Oct 2026 06:55:44 +0000 Subject: [PATCH] smp-server: remove journal message store --- docs/smp-server-db-load.md | 4 +- simplexmq.cabal | 2 - src/Simplex/Messaging/Server.hs | 36 +- src/Simplex/Messaging/Server/Env/STM.hs | 75 +- src/Simplex/Messaging/Server/Main.hs | 186 +-- src/Simplex/Messaging/Server/Main/Init.hs | 4 +- .../Messaging/Server/MsgStore/Journal.hs | 1085 ----------------- .../Server/MsgStore/Journal/SharedLock.hs | 44 - .../Messaging/Server/MsgStore/Postgres.hs | 2 +- src/Simplex/Messaging/Server/MsgStore/STM.hs | 2 +- .../Messaging/Server/MsgStore/Types.hs | 4 +- src/Simplex/Messaging/Server/Prometheus.hs | 10 +- tests/AgentTests/FunctionalAPITests.hs | 31 +- tests/AgentTests/NotificationTests.hs | 2 +- tests/CoreTests/MsgStoreTests.hs | 434 +------ tests/CoreTests/StoreLogTests.hs | 14 +- tests/NamesResolverServer.hs | 3 + tests/SMPClient.hs | 80 +- tests/SMPProxyTests.hs | 28 +- tests/ServerTests.hs | 36 +- tests/Test.hs | 18 +- 21 files changed, 163 insertions(+), 1937 deletions(-) delete mode 100644 src/Simplex/Messaging/Server/MsgStore/Journal.hs delete mode 100644 src/Simplex/Messaging/Server/MsgStore/Journal/SharedLock.hs diff --git a/docs/smp-server-db-load.md b/docs/smp-server-db-load.md index cd94d7d12f..4d65c7194c 100644 --- a/docs/smp-server-db-load.md +++ b/docs/smp-server-db-load.md @@ -144,9 +144,7 @@ space, so it is workload-dependent; `fillfactor = 80` reached 100% for this frac larger share of queues at once would need a lower value. `fillfactor` applies to pages rewritten after the change, so the ratio ramps up as the heap turns over, or immediately after `pg_repack`. -Dropping the index regresses the deprecated journal message store's expiration (`foldRecentQueueRecs`, -`Journal.hs:434`) to a sequential scan; this is accepted because that store is being retired. The -Postgres message store does not read `updated_at`. +The Postgres message store does not read `updated_at`, so no query depends on the dropped index. Autovacuum reloptions applied by the migration: diff --git a/simplexmq.cabal b/simplexmq.cabal index c07df376a1..a7b08d20b7 100644 --- a/simplexmq.cabal +++ b/simplexmq.cabal @@ -284,8 +284,6 @@ library Simplex.Messaging.Server.Main.Init Simplex.Messaging.Server.Web Simplex.Messaging.Server.MsgStore - Simplex.Messaging.Server.MsgStore.Journal - Simplex.Messaging.Server.MsgStore.Journal.SharedLock Simplex.Messaging.Server.MsgStore.STM Simplex.Messaging.Server.MsgStore.Types Simplex.Messaging.Server.Names diff --git a/src/Simplex/Messaging/Server.hs b/src/Simplex/Messaging/Server.hs index e2cef6f502..123f1d5c33 100644 --- a/src/Simplex/Messaging/Server.hs +++ b/src/Simplex/Messaging/Server.hs @@ -108,7 +108,6 @@ import Simplex.Messaging.Server.Control import Simplex.Messaging.Server.Env.STM as Env import Simplex.Messaging.Server.Expiration import Simplex.Messaging.Server.MsgStore -import Simplex.Messaging.Server.MsgStore.Journal (JournalMsgStore, JournalQueue (..), getJournalQueueMessages) import Simplex.Messaging.Server.Names (NamesEnv, closeNamesEnv, resolveName) import Simplex.Messaging.Server.MsgStore.STM import Simplex.Messaging.Server.MsgStore.Types @@ -2307,7 +2306,6 @@ saveServerMessages drainMsgs ms = case ms of StoreMemory STMMsgStore {storeConfig = STMStoreConfig {storePath}} -> case storePath of Just f -> exportMessages False ms f drainMsgs Nothing -> logNote "undelivered messages are not saved" - StoreJournal _ -> logNote "closed journal message storage" #if defined(dbServerPostgres) StoreDatabase _ -> logNote "closed postgres message storage" #endif @@ -2317,7 +2315,6 @@ exportMessages tty st f drainMsgs = do logNote $ "saving messages to file " <> T.pack f run $ case st of StoreMemory ms -> exportMessages_ ms $ getMsgs ms - StoreJournal ms -> exportMessages_ ms $ getJournalMsgs ms #if defined(dbServerPostgres) StoreDatabase ms -> exportDbMessages tty ms #endif @@ -2329,10 +2326,6 @@ exportMessages tty st f drainMsgs = do Left e -> do logError $ "error exporting messages: " <> tshow e exitFailure - getJournalMsgs ms q = - readTVarIO (msgQueue' q) >>= \case - Just _ -> getMsgs ms q - Nothing -> getJournalQueueMessages ms q getMsgs :: MsgStoreClass s' => s' -> StoreQueue s' -> IO [Message] getMsgs ms q = unsafeRunStore q "saveQueueMsgs" $ getQueueMessages_ drainMsgs q =<< getMsgQueue ms q False saveQueueMsgs :: (StoreQueue s -> IO [Message]) -> Handle -> StoreQueue s -> IO (Sum Int) @@ -2349,37 +2342,16 @@ processServerMessages StartOptions {skipWarnings} = do asks msgStore_ >>= liftIO . processMessages old_ expire where processMessages :: Maybe Int64 -> Bool -> MsgStore s' -> IO (Maybe MessageStats) +#if defined(dbServerPostgres) processMessages old_ expire = \case +#else + processMessages old_ _ = \case +#endif StoreMemory ms@STMMsgStore {storeConfig = STMStoreConfig {storePath}} -> case storePath of Just f -> ifM (doesFileExist f) (Just <$> importMessages False ms f old_ skipWarnings) (pure Nothing) Nothing -> pure Nothing - StoreJournal ms -> processJournalMessages old_ expire ms #if defined(dbServerPostgres) StoreDatabase ms -> processDbMessages old_ expire ms -#endif - processJournalMessages :: forall s. Maybe Int64 -> Bool -> JournalMsgStore s -> IO (Maybe MessageStats) - processJournalMessages old_ expire ms - | expire = Just <$> case old_ of - Just old -> do - logNote "expiring journal store messages..." - run $ processExpireQueue old - Nothing -> do - logNote "validating journal store messages..." - run processValidateQueue - | otherwise = logWarn "skipping message expiration" $> Nothing - where - run a = unsafeWithAllMsgQueues False ms a `catchAny` \_ -> exitFailure - processExpireQueue :: Int64 -> JournalQueue s -> IO MessageStats - processExpireQueue old q = unsafeRunStore q "processExpireQueue" $ do - mq <- getMsgQueue ms q False - expiredMsgsCount <- deleteExpireMsgs_ old q mq - storedMsgsCount <- getQueueSize_ mq - pure MessageStats {storedMsgsCount, expiredMsgsCount, storedQueues = 1} - processValidateQueue :: JournalQueue s -> IO MessageStats - processValidateQueue q = unsafeRunStore q "processValidateQueue" $ do - storedMsgsCount <- getQueueSize_ =<< getMsgQueue ms q False - pure newMessageStats {storedMsgsCount, storedQueues = 1} -#if defined(dbServerPostgres) processDbMessages old_ expire ms | expire = Just <$> case old_ of Just old -> do diff --git a/src/Simplex/Messaging/Server/Env/STM.hs b/src/Simplex/Messaging/Server/Env/STM.hs index 2c1843e517..68ddca5bd3 100644 --- a/src/Simplex/Messaging/Server/Env/STM.hs +++ b/src/Simplex/Messaging/Server/Env/STM.hs @@ -42,7 +42,6 @@ module Simplex.Messaging.Server.Env.STM VerifiedTransmission, ResponseAndMessage, newEnv, - mkJournalStoreConfig, msgStore, fromMsgStore, newClient, @@ -69,10 +68,6 @@ module Simplex.Messaging.Server.Env.STM defaultProxyClientConcurrency, defaultNameResolverConcurrency, defaultAuthErrorDelayMs, - defaultMaxJournalMsgCount, - defaultMaxJournalStateLines, - defaultIdleQueueInterval, - journalMsgStoreDepth, readWriteQueueStore, noPostgresExitStr, noPostgresExit, @@ -97,7 +92,7 @@ import Data.List.NonEmpty (NonEmpty) import Data.Map.Strict (Map) import Data.Maybe (isJust) import qualified Data.Text as T -import Data.Time.Clock (getCurrentTime, nominalDay) +import Data.Time.Clock (getCurrentTime) import Data.Time.Clock.System (SystemTime) import qualified Data.X509 as X import Data.X509.Validation (Fingerprint (..)) @@ -114,7 +109,6 @@ import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Protocol import Simplex.Messaging.Server.Expiration import Simplex.Messaging.Server.Information -import Simplex.Messaging.Server.MsgStore.Journal import Simplex.Messaging.Server.MsgStore.STM import Simplex.Messaging.Server.MsgStore.Types import Simplex.Messaging.Server.Names (NamesConfig (..), NamesEnv, newNamesEnv, pingEndpoint) @@ -147,8 +141,6 @@ data ServerConfig s = ServerConfig smpHandshakeTimeout :: Int, tbqSize :: Natural, msgQueueQuota :: Int, - maxJournalMsgCount :: Int, - maxJournalStateLines :: Int, queueIdBytes :: Int, msgIdBytes :: Int, serverStoreCfg :: ServerStoreCfg s, @@ -165,8 +157,6 @@ data ServerConfig s = ServerConfig messageExpiration :: Maybe ExpirationConfig, expireMessagesOnStart :: Bool, expireMessagesOnSend :: Bool, - -- | interval of inactivity after which journal queue is closed - idleQueueInterval :: Int64, -- | notification expiration interval (seconds) notificationExpiration :: ExpirationConfig, -- | time after which the socket with inactive client can be disconnected (without any messages or commands, incl. PING), @@ -231,9 +221,6 @@ defaultMessageExpiration = checkInterval = 7200 -- seconds, 2 hours } -defaultIdleQueueInterval :: Int64 -defaultIdleQueueInterval = 14400 -- seconds, 4 hours - defNtfExpirationHours :: Int64 defNtfExpirationHours = 24 @@ -260,21 +247,9 @@ defaultNameResolverConcurrency = 1000 defaultAuthErrorDelayMs :: Int64 defaultAuthErrorDelayMs = 50 -journalMsgStoreDepth :: Int -journalMsgStoreDepth = 5 - -defaultMaxJournalStateLines :: Int -defaultMaxJournalStateLines = 16 - -defaultMaxJournalMsgCount :: Int -defaultMaxJournalMsgCount = 256 - defaultMsgQueueQuota :: Int defaultMsgQueueQuota = 128 -defaultStateTailSize :: Int -defaultStateTailSize = 512 - data Env s = Env { config :: ServerConfig s, serverActive :: TVar Bool, @@ -300,7 +275,6 @@ msgStore = fromMsgStore . msgStore_ fromMsgStore :: MsgStore s -> s fromMsgStore = \case StoreMemory s -> s - StoreJournal s -> s #if defined(dbServerPostgres) StoreDatabase s -> s #endif @@ -308,12 +282,10 @@ fromMsgStore = \case type family SupportedStore (qs :: QSType) (ms :: MSType) :: Constraint where SupportedStore 'QSMemory 'MSMemory = () - SupportedStore 'QSMemory 'MSJournal = () SupportedStore 'QSMemory 'MSPostgres = (Int ~ Bool, TypeError ('TE.Text "Storing messages in Postgres DB with queues in memory is not supported")) SupportedStore 'QSPostgres 'MSMemory = (Int ~ Bool, TypeError ('TE.Text "Storing messages in memory with queues in Postgres DB is not supported")) - SupportedStore 'QSPostgres 'MSJournal = () #if defined(dbServerPostgres) SupportedStore 'QSPostgres 'MSPostgres = () #else @@ -327,8 +299,6 @@ data AStoreType = data ServerStoreCfg s where SSCMemory :: Maybe StorePaths -> ServerStoreCfg STMMsgStore - SSCMemoryJournal :: {storeLogFile :: FilePath, storeMsgsPath :: FilePath} -> ServerStoreCfg (JournalMsgStore 'QSMemory) - SSCDatabaseJournal :: {storeCfg :: PostgresStoreCfg, storeMsgsPath' :: FilePath} -> ServerStoreCfg (JournalMsgStore 'QSPostgres) #if defined(dbServerPostgres) SSCDatabase :: PostgresStoreCfg -> ServerStoreCfg PostgresMsgStore #endif @@ -336,8 +306,6 @@ data ServerStoreCfg s where dbStoreCfg :: ServerStoreCfg s -> Maybe PostgresStoreCfg dbStoreCfg = \case SSCMemory _ -> Nothing - SSCMemoryJournal {} -> Nothing - SSCDatabaseJournal {storeCfg} -> Just storeCfg #if defined(dbServerPostgres) SSCDatabase cfg -> Just cfg #endif @@ -345,8 +313,6 @@ dbStoreCfg = \case storeLogFile' :: ServerStoreCfg s -> Maybe FilePath storeLogFile' = \case SSCMemory sp_ -> (\StorePaths {storeLogFile} -> storeLogFile) <$> sp_ - SSCMemoryJournal {storeLogFile} -> Just storeLogFile - SSCDatabaseJournal {storeCfg = PostgresStoreCfg {dbStoreLogPath}} -> dbStoreLogPath #if defined(dbServerPostgres) SSCDatabase (PostgresStoreCfg {dbStoreLogPath}) -> dbStoreLogPath #endif @@ -355,14 +321,12 @@ data StorePaths = StorePaths {storeLogFile :: FilePath, storeMsgsFile :: Maybe F type family MsgStoreType (qs :: QSType) (ms :: MSType) where MsgStoreType 'QSMemory 'MSMemory = STMMsgStore - MsgStoreType qs 'MSJournal = JournalMsgStore qs #if defined(dbServerPostgres) MsgStoreType 'QSPostgres 'MSPostgres = PostgresMsgStore #endif data MsgStore s where StoreMemory :: STMMsgStore -> MsgStore STMMsgStore - StoreJournal :: JournalMsgStore qs -> MsgStore (JournalMsgStore qs) #if defined(dbServerPostgres) StoreDatabase :: PostgresMsgStore -> MsgStore PostgresMsgStore #endif @@ -576,7 +540,7 @@ newProhibitedSub = do return Sub {subThread = ProhibitSub, delivered} newEnv :: ServerConfig s -> IO (Env s) -newEnv config@ServerConfig {smpCredentials, httpCredentials, serverStoreCfg, smpAgentCfg, information, messageExpiration, idleQueueInterval, msgQueueQuota, maxJournalMsgCount, maxJournalStateLines, namesConfig, msgIdBytes} = do +newEnv config@ServerConfig {smpCredentials, httpCredentials, serverStoreCfg, smpAgentCfg, information, messageExpiration, msgQueueQuota, namesConfig, msgIdBytes} = do when (msgIdBytes < 24) $ do logError "Error: msgIdBytes must be at least 24" exitFailure @@ -588,30 +552,12 @@ newEnv config@ServerConfig {smpCredentials, httpCredentials, serverStoreCfg, smp ms <- newMsgStore STMStoreConfig {storePath, quota = msgQueueQuota} forM_ storePaths_ $ \StorePaths {storeLogFile = f} -> loadStoreLog (mkQueue ms True) f $ queueStore ms pure $ StoreMemory ms - SSCMemoryJournal {storeLogFile, storeMsgsPath} -> do - logWarn $ - "Journal message store is deprecated and will be removed soon.\n" - <> "Please migrate to in-memory storage using `journal export` command.\n" - <> "After that you can migrate to PostgreSQL using `database import` command." - let qsCfg = MQStoreCfg - cfg = mkJournalStoreConfig qsCfg storeMsgsPath msgQueueQuota maxJournalMsgCount maxJournalStateLines idleQueueInterval - ms <- newMsgStore cfg - loadStoreLog (mkQueue ms True) storeLogFile $ stmQueueStore ms - pure $ StoreJournal ms #if defined(dbServerPostgres) - SSCDatabaseJournal {storeCfg, storeMsgsPath'} -> do - let StartOptions {compactLog, confirmMigrations} = startOptions config - qsCfg = PQStoreCfg (storeCfg {confirmMigrations} :: PostgresStoreCfg) - cfg = mkJournalStoreConfig qsCfg storeMsgsPath' msgQueueQuota maxJournalMsgCount maxJournalStateLines idleQueueInterval - when compactLog $ compactDbStoreLog $ dbStoreLogPath storeCfg - StoreJournal <$> newMsgStore cfg SSCDatabase storeCfg -> do let StartOptions {compactLog, confirmMigrations} = startOptions config cfg = PostgresMsgStoreCfg storeCfg {confirmMigrations} msgQueueQuota when compactLog $ compactDbStoreLog $ dbStoreLogPath storeCfg StoreDatabase <$> newMsgStore cfg -#else - SSCDatabaseJournal {} -> noPostgresExit #endif ntfStore <- NtfStore <$> TM.emptyIO random <- C.newRandom @@ -711,7 +657,9 @@ newEnv config@ServerConfig {smpCredentials, httpCredentials, serverStoreCfg, smp Nothing -> SPMMemoryOnly Just StorePaths {storeMsgsFile = Just _} -> SPMMessages _ -> SPMQueues +#if defined(dbServerPostgres) _ -> SPMMessages +#endif noPostgresExit :: IO a noPostgresExit = putStrLn noPostgresExitStr >> exitFailure @@ -721,21 +669,6 @@ noPostgresExitStr = "Error: server binary is compiled without support for PostgreSQL database.\n" <> "Please download `smp-server-postgres` or re-compile with `cabal build -fserver_postgres`." -mkJournalStoreConfig :: QStoreCfg s -> FilePath -> Int -> Int -> Int -> Int64 -> JournalStoreConfig s -mkJournalStoreConfig queueStoreCfg storePath msgQueueQuota maxJournalMsgCount maxJournalStateLines idleQueueInterval = - JournalStoreConfig - { storePath, - quota = msgQueueQuota, - pathParts = journalMsgStoreDepth, - queueStoreCfg, - maxMsgCount = maxJournalMsgCount, - maxStateLines = maxJournalStateLines, - stateTailSize = defaultStateTailSize, - idleInterval = idleQueueInterval, - expireBackupsAfter = 14 * nominalDay, - keepMinBackups = 2 - } - newSMPProxyAgent :: SMPClientAgentConfig -> TVar ChaChaDRG -> IO ProxyAgent newSMPProxyAgent smpAgentCfg random = do smpAgent <- newSMPClientAgent SSender smpAgentCfg Nothing random diff --git a/src/Simplex/Messaging/Server/Main.hs b/src/Simplex/Messaging/Server/Main.hs index 4a3c909eda..2318a5d3a6 100644 --- a/src/Simplex/Messaging/Server/Main.hs +++ b/src/Simplex/Messaging/Server/Main.hs @@ -28,7 +28,6 @@ module Simplex.Messaging.Server.Main importMessagesToDatabase, exportDatabaseToStoreLog, #endif - newJournalMsgStore, storeMsgsJournalDir', getServerSourceCode, simplexmqSource, @@ -61,7 +60,6 @@ import qualified Data.Text.IO as T import Options.Applicative import Simplex.Messaging.Agent.Protocol (ConnectionLink (..), ConnectionMode (..), 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 @@ -69,23 +67,20 @@ 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 (AttachHTTP, 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.MsgStore.Types (SQSType (..), SMSType (..)) 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, safeDecodeUtf8) +import Simplex.Messaging.Util (eitherToMaybe, safeDecodeUtf8) import System.Directory (createDirectoryIfMissing, doesDirectoryExist, doesFileExist) import System.Exit (exitFailure) import System.FilePath (combine) @@ -98,15 +93,16 @@ 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.Agent.Store.Shared (MigrationConfirmation (..)) import Simplex.Messaging.Server.MsgStore.Postgres -import Simplex.Messaging.Server.QueueStore.Postgres (batchInsertQueues, batchInsertServices, foldQueueRecs, foldServiceRecs) +import Simplex.Messaging.Server.MsgStore.STM (STMQueue, STMStoreConfig (..)) +import Simplex.Messaging.Server.MsgStore.Types (MsgStoreClass (..), newMsgStore) +import Simplex.Messaging.Server.QueueStore.Postgres.Config +import Simplex.Messaging.Server.QueueStore.Postgres (PostgresQueueStore, 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 Simplex.Messaging.Util (ifM) import System.Directory (renameFile) import System.IO (IOMode (..), withFile) #endif @@ -136,79 +132,6 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath = 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 @@ -221,7 +144,7 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath = 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 + (sCnt, qCnt) <- importStoreLogToDatabase storeLogFile dbOpts putStrLn $ "Imported: " <> show sCnt <> " services, " <> show qCnt <> " queues" putStrLn "Importing messages..." mCnt <- importMessagesToDatabase storeMsgsFilePath dbOpts @@ -248,11 +171,10 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath = 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 + (sCnt, qCnt) <- importStoreLogToDatabase 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 SQSMemory SMSMemory) -> setToDbStr <> "\nstore_messages set to `memory`, update it to `database` and import messages (`smp-server database import --table messages`)" Right (ASType SQSPostgres _) -> "store_queues set to `database`, start the server." Left e -> e <> ", configure storage correctly" where @@ -280,7 +202,7 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath = 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 + (sCnt, qCnt) <- exportDatabaseToStoreLog dbOpts storeLogFilePath putStrLn $ "Exported: " <> show sCnt <> " services, " <> show qCnt <> " queues" putStrLn "Exporting messages..." let storeCfg = PostgresStoreCfg {dbOpts, dbStoreLogPath = Nothing, confirmMigrations = MCConsole, deletedTTL = 86400 * defaultDeletedTTL} @@ -306,7 +228,7 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath = 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 + (sCnt, qCnt) <- exportDatabaseToStoreLog 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." @@ -346,6 +268,7 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath = doesFileExist iniFile >>= \case True -> readIniFile iniFile >>= either exitError a _ -> exitError $ "Error: server is not initialized (" <> iniFile <> " does not exist).\nRun `" <> executableName <> " init`." +#if defined(dbServerPostgres) getRequiredStoreLogFile ini = do case enableStoreLog' ini $> storeLogFilePath of Just storeLogFile -> do @@ -354,6 +277,7 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath = (pure storeLogFile) (putStrLn ("Store log file " <> storeLogFile <> " not found") >> exitFailure) Nothing -> putStrLn "Store log disabled, see `[STORE_LOG] enable`" >> exitFailure +#endif iniFile = combine cfgPath "smp-server.ini" serverVersion = "SMP server v" <> simplexmqVersionCommit executableName = "smp-server" @@ -364,10 +288,10 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath = readStoreType :: Ini -> Either String AStoreType readStoreType ini = case (iniStoreQueues, iniStoreMessage) of ("memory", "memory") -> Right $ ASType SQSMemory SMSMemory - ("memory", "journal") -> Right $ ASType SQSMemory SMSJournal + ("memory", "journal") -> Left journalRemovedStr ("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 + ("database", "journal") -> Left journalRemovedStr #if defined(dbServerPostgres) ("database", "database") -> Right $ ASType SQSPostgres SMSPostgres #else @@ -377,10 +301,12 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath = where iniStoreQueues = fromRight "memory" $ lookupValue "STORE_LOG" "store_queues" ini iniStoreMessage = fromRight "memory" $ lookupValue "STORE_LOG" "store_messages" ini +#if defined(dbServerPostgres) iniDeletedTTL ini = readIniDefault (86400 * defaultDeletedTTL) "STORE_LOG" "db_deleted_ttl" ini + enableDbStoreLog' = settingIsOn "STORE_LOG" "db_store_log" +#endif defaultStaticPath = combine logPath "www" enableStoreLog' = settingIsOn "STORE_LOG" "enable" - enableDbStoreLog' = settingIsOn "STORE_LOG" "db_store_log" initializeServer opts | scripted opts = initialize opts | otherwise = do @@ -517,16 +443,13 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath = 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 +#else + iniStoreCfg SQSPostgres _ = error noPostgresExitStr #endif serverConfig :: ServerStoreCfg s -> ServerConfig s serverConfig serverStoreCfg = @@ -535,8 +458,6 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath = 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 = @@ -561,7 +482,6 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath = }, 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 @@ -638,7 +558,6 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath = checkMsgStoreMode ini mode = do msgsDirExists <- doesDirectoryExist storeMsgsJournalDir msgsFileExists <- doesFileExist storeMsgsFilePath - storeLogExists <- doesFileExist storeLogFilePath case mode of #if defined(dbServerPostgres) ASType SQSPostgres SMSPostgres @@ -646,35 +565,22 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath = 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 + | otherwise -> checkDbStorage ini =<< doesFileExist storeLogFilePath #else - SQSPostgres -> noPostgresExit + ASType 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." + putStrLn journalRemovedStr exitFailure | otherwise -> pure () + exitConfigureMsgStorage :: IO () exitConfigureMsgStorage = do putStrLn $ "Error: both " <> storeMsgsFilePath <> " file and " <> storeMsgsJournalDir <> " directory are present." - putStrLn "Configure memory storage." + putStrLn journalRemovedStr exitFailure #if defined(dbServerPostgres) @@ -706,18 +612,18 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath = 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 +importStoreLogToDatabase :: FilePath -> DBOpts -> IO (Int64, Int64) +importStoreLogToDatabase storeLogFile dbOpts = do + ms <- newMsgStore STMStoreConfig {storePath = Nothing, quota = defaultMsgQueueQuota} + let st = queueStore 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 + ps :: PostgresQueueStore PostgresQueue <- newQueueStore @PostgresQueue (storeCfg, False) + sCnt <- batchInsertServices services' ps + qCnt <- batchInsertQueues @STMQueue True queues ps renameFile storeLogFile $ storeLogFile <> ".bak" pure (sCnt, qCnt) @@ -736,21 +642,22 @@ importMessagesToDatabase msgsLogFile dbOpts = do renameFile msgsLogFile $ msgsLogFile <> ".bak" pure mCnt' -exportDatabaseToStoreLog :: FilePath -> DBOpts -> FilePath -> IO (Int, Int) -exportDatabaseToStoreLog logPath dbOpts storeLogFilePath = do +exportDatabaseToStoreLog :: DBOpts -> FilePath -> IO (Int, Int) +exportDatabaseToStoreLog dbOpts storeLogFilePath = do let storeCfg = PostgresStoreCfg {dbOpts, dbStoreLogPath = Nothing, confirmMigrations = MCConsole, deletedTTL = 86400 * defaultDeletedTTL} - ps <- newJournalMsgStore logPath $ PQStoreCfg storeCfg + ps :: PostgresQueueStore PostgresQueue <- newQueueStore @PostgresQueue (storeCfg, False) 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) + Sum sCnt <- foldServiceRecs ps $ \sr -> logNewService sl sr $> Sum (1 :: Int) + Sum qCnt <- foldQueueRecs True True 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 +journalRemovedStr :: String +journalRemovedStr = + "Journal message storage is removed.\n" + <> "Export messages with `smp-server journal export` using smp-server v7.1.0.11 or earlier,\n" + <> "then set store_messages to `memory`, or to `database` and run `smp-server database import --table messages`." storeMsgsJournalDir' :: FilePath -> FilePath storeMsgsJournalDir' logPath = combine logPath "messages" @@ -874,7 +781,6 @@ data CliCommand | OnlineCert CertOptions | Start StartOptions | Delete - | Journal StoreCmd | Database StoreCmd DatabaseTable DBOpts data StoreCmd = SCImport | SCExport | SCDelete @@ -900,7 +806,6 @@ cliCommandP cfgPath logPath iniFile = <> 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 @@ -1047,7 +952,6 @@ cliCommandP cfgPath logPath iniFile = disableWeb, scripted } - journalCmdP = storeCmdP "message log file" "journal storage" databaseCmdP = storeCmdP "queue store log file" "PostgreSQL database schema" storeCmdP src dest = hsubparser diff --git a/src/Simplex/Messaging/Server/Main/Init.hs b/src/Simplex/Messaging/Server/Main/Init.hs index b82061ca3f..382ab7bd91 100644 --- a/src/Simplex/Messaging/Server/Main/Init.hs +++ b/src/Simplex/Messaging/Server/Main/Init.hs @@ -83,7 +83,7 @@ iniFileContent cfgPath logPath opts host basicAuth controlPortPwds = <> ("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\ + \# `database`- PostgreSQL databass (requires `store_messages = database`).\n\ \store_queues = memory\n\n\ \# Database connection settings for PostgreSQL database (`store_queues = database`).\n" <> iniDbOpts dbOptions defaultDBOpts @@ -91,7 +91,7 @@ iniFileContent cfgPath logPath opts host basicAuth controlPortPwds = \# db_store_log = off\n\n\ \# Time to retain deleted queues in the database, days.\n" <> ("# db_deleted_ttl = " <> tshow defaultDeletedTTL <> "\n\n") - <> "# Message storage mode: `memory` or `journal`.\n\ + <> "# Message storage mode: `memory` or `database` (requires `store_queues = database`).\n\ \store_messages = memory\n\n\ \# When store_messages is `memory`, undelivered messages are optionally saved and restored\n\ \# when the server restarts, they are preserved in the .bak file until the next restart.\n" diff --git a/src/Simplex/Messaging/Server/MsgStore/Journal.hs b/src/Simplex/Messaging/Server/MsgStore/Journal.hs deleted file mode 100644 index 185c113b78..0000000000 --- a/src/Simplex/Messaging/Server/MsgStore/Journal.hs +++ /dev/null @@ -1,1085 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE InstanceSigs #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TupleSections #-} - -module Simplex.Messaging.Server.MsgStore.Journal - ( JournalMsgStore (random, expireBackupsBefore), - QStore (..), - QStoreCfg (..), - JournalQueue (msgQueue'), -- msgQueue' is used in tests - JournalMsgQueue (queue, state), - JMQueue (queueDirectory, statePath), - JournalStoreConfig (..), - closeMsgQueue, - closeMsgQueueHandles, - -- below are exported for tests - MsgQueueState (..), - JournalState (..), - SJournalType (..), - msgQueueDirectory, - msgQueueStatePath, - readQueueState, - newMsgQueueState, - getJournalQueueMessages, - newJournalId, - appendState, - queueLogFileName, - journalFilePath, - logFileExt, - stmQueueStore, -#if defined(dbServerPostgres) - postgresQueueStore, -#endif - ) -where - -import Control.Concurrent.STM -import qualified Control.Exception as E -import Control.Logger.Simple -import Control.Monad -import Control.Monad.Trans.Except -import qualified Data.Attoparsec.ByteString.Char8 as A -import Data.ByteString.Char8 (ByteString) -import qualified Data.ByteString.Char8 as B -import Data.Either (fromRight, partitionEithers) -import Data.Functor (($>)) -import Data.Int (Int64) -import Data.List (sort) -import qualified Data.Map.Strict as M -import Data.Maybe (fromMaybe, isJust, isNothing, mapMaybe) -import Data.Text (Text) -import qualified Data.Text as T -import Data.Text.Encoding (decodeLatin1) -import Data.Time.Clock (NominalDiffTime, UTCTime, addUTCTime, getCurrentTime) -import Data.Time.Clock.System (SystemTime (..), getSystemTime) -import Data.Time.Format.ISO8601 (iso8601Show, iso8601ParseM) -import GHC.IO (catchAny) -import Simplex.Messaging.Agent.Client (getMapLock) -import Simplex.Messaging.Agent.Lock -import Simplex.Messaging.Encoding.String -import Simplex.Messaging.Protocol -import Simplex.Messaging.Server.MsgStore.Journal.SharedLock -import Simplex.Messaging.Server.MsgStore.Types -import Simplex.Messaging.Server.QueueStore -#if defined(dbServerPostgres) -import Simplex.Messaging.Server.QueueStore.Postgres -#endif -import Simplex.Messaging.Server.QueueStore.STM -import Simplex.Messaging.Server.QueueStore.Types -import Simplex.Messaging.SystemTime -import Simplex.Messaging.TMap (TMap) -import qualified Simplex.Messaging.TMap as TM -import Simplex.Messaging.Util (ifM, tshow, whenM, ($>>=), (<$$>)) -import System.Directory -import System.FilePath (takeFileName, ()) -import System.IO (BufferMode (..), Handle, IOMode (..), SeekMode (..)) -import qualified System.IO as IO -import System.Random (StdGen, genByteString, newStdGen) - -data JournalMsgStore s = JournalMsgStore - { config :: JournalStoreConfig s, - random :: TVar StdGen, - queueLocks :: TMap RecipientId Lock, - sharedLock :: TMVar RecipientId, - queueStore_ :: QStore s, - openedQueueCount :: TVar Int, - expireBackupsBefore :: UTCTime - } - -data QStore (s :: QSType) where - MQStore :: QStoreType 'QSMemory -> QStore 'QSMemory -#if defined(dbServerPostgres) - PQStore :: QStoreType 'QSPostgres -> QStore 'QSPostgres -#endif - -type family QStoreType s where - QStoreType 'QSMemory = STMQueueStore (JournalQueue 'QSMemory) -#if defined(dbServerPostgres) - QStoreType 'QSPostgres = PostgresQueueStore (JournalQueue 'QSPostgres) -#endif - -withQS :: (QueueStoreClass (JournalQueue s) (QStoreType s) => QStoreType s -> r) -> QStore s -> r -withQS f = \case - MQStore st -> f st -#if defined(dbServerPostgres) - PQStore st -> f st -#endif -{-# INLINE withQS #-} - -stmQueueStore :: JournalMsgStore 'QSMemory -> STMQueueStore (JournalQueue 'QSMemory) -stmQueueStore st = case queueStore_ st of - MQStore st' -> st' - -#if defined(dbServerPostgres) -postgresQueueStore :: JournalMsgStore 'QSPostgres -> PostgresQueueStore (JournalQueue 'QSPostgres) -postgresQueueStore st = case queueStore_ st of - PQStore st' -> st' -#endif - -data JournalStoreConfig s = JournalStoreConfig - { storePath :: FilePath, - pathParts :: Int, - queueStoreCfg :: QStoreCfg s, - quota :: Int, - -- Max number of messages per journal file - ignored in STM store. - -- When this limit is reached, the file will be changed. - -- This number should be set bigger than queue quota. - maxMsgCount :: Int, - maxStateLines :: Int, - stateTailSize :: Int, - -- time in seconds after which the queue will be closed after message expiration - idleInterval :: Int64, - -- expire state backup files - expireBackupsAfter :: NominalDiffTime, - keepMinBackups :: Int - } - -data QStoreCfg s where - MQStoreCfg :: QStoreCfg 'QSMemory -#if defined(dbServerPostgres) - PQStoreCfg :: PostgresStoreCfg -> QStoreCfg 'QSPostgres -#endif - -data JournalQueue (s :: QSType) = JournalQueue - { recipientId' :: RecipientId, - queueLock :: Lock, - sharedLock :: TMVar RecipientId, - -- To avoid race conditions and errors when restoring queues, - -- Nothing is written to TVar when queue is deleted. - queueRec' :: TVar (Maybe QueueRec), - msgQueue' :: TVar (Maybe (JournalMsgQueue s)), - -- system time in seconds since epoch - activeAt :: TVar Int64, - queueState :: TVar (Maybe QState) -- Nothing - unknown - } - -data QState = QState - { hasPending :: Bool, - hasStored :: Bool - } - -data JMQueue = JMQueue - { queueDirectory :: FilePath, - statePath :: FilePath - } - -data JournalMsgQueue (s :: QSType) = JournalMsgQueue - { queue :: JMQueue, - state :: TVar MsgQueueState, - -- tipMsg contains last message and length incl. newline - -- Nothing - unknown, Just Nothing - empty queue. - -- It prevents reading each message twice, - -- and reading it after it was just written. - tipMsg :: TVar (Maybe (Maybe (Message, Int64))), - handles :: TVar (Maybe MsgQueueHandles) - } - -data MsgQueueState = MsgQueueState - { readState :: JournalState 'JTRead, - writeState :: JournalState 'JTWrite, - canWrite :: Bool, - size :: Int - } - deriving (Show) - -data MsgQueueHandles = MsgQueueHandles - { stateHandle :: Handle, -- handle to queue state log file, rotates and removes old backups when server is restarted - readHandle :: Handle, - writeHandle :: Maybe Handle -- optional, used when write file is different from read file - } - -data JournalState t = JournalState - { journalType :: SJournalType t, - journalId :: ByteString, - msgPos :: Int, - msgCount :: Int, - bytePos :: Int64, - byteCount :: Int64 - } - deriving (Show) - -qState :: MsgQueueState -> QState -qState MsgQueueState {size, readState = rs, writeState = ws} = - let hasPending = size > 0 - in QState {hasPending, hasStored = hasPending || msgCount rs > 0 || msgCount ws > 0} -{-# INLINE qState #-} - -data JournalType = JTRead | JTWrite - -data SJournalType (t :: JournalType) where - SJTRead :: SJournalType 'JTRead - SJTWrite :: SJournalType 'JTWrite - -class JournalTypeI t where sJournalType :: SJournalType t - -instance JournalTypeI 'JTRead where sJournalType = SJTRead - -instance JournalTypeI 'JTWrite where sJournalType = SJTWrite - -deriving instance Show (SJournalType t) - -newMsgQueueState :: ByteString -> MsgQueueState -newMsgQueueState journalId = - MsgQueueState - { writeState = newJournalState journalId, - readState = newJournalState journalId, - canWrite = True, - size = 0 - } - -newJournalState :: JournalTypeI t => ByteString -> JournalState t -newJournalState journalId = JournalState sJournalType journalId 0 0 0 0 - -journalFilePath :: FilePath -> ByteString -> FilePath -journalFilePath dir journalId = dir (msgLogFileName <> "." <> B.unpack journalId <> logFileExt) - -instance StrEncoding MsgQueueState where - strEncode MsgQueueState {writeState, readState, canWrite, size} = - B.unwords - [ "write=" <> strEncode writeState, - "read=" <> strEncode readState, - "canWrite=" <> strEncode canWrite, - "size=" <> strEncode size - ] - strP = do - writeState <- "write=" *> strP - readState <- " read=" *> strP - canWrite <- " canWrite=" *> strP - size <- " size=" *> strP - pure MsgQueueState {writeState, readState, canWrite, size} - -instance JournalTypeI t => StrEncoding (JournalState t) where - strEncode JournalState {journalId, msgPos, msgCount, bytePos, byteCount} = - B.intercalate "," [journalId, e msgPos, e msgCount, e bytePos, e byteCount] - where - e :: StrEncoding a => a -> ByteString - e = strEncode - strP = do - journalId <- A.takeTill (== ',') - JournalState sJournalType journalId <$> i <*> i <*> i <*> i - where - i :: Integral a => A.Parser a - i = A.char ',' *> A.decimal - -queueLogFileName :: String -queueLogFileName = "queue_state" - -msgLogFileName :: String -msgLogFileName = "messages" - -logFileExt :: String -logFileExt = ".log" - -newtype StoreIO (s :: QSType) a = StoreIO {unStoreIO :: IO a} - deriving newtype (Functor, Applicative, Monad) - -instance StoreQueueClass (JournalQueue s) where - recipientId = recipientId' - {-# INLINE recipientId #-} - queueRec = queueRec' - {-# INLINE queueRec #-} - withQueueLock :: JournalQueue s -> Text -> IO a -> IO a - withQueueLock JournalQueue {recipientId', queueLock, sharedLock} = - withLockWaitShared recipientId' queueLock sharedLock - {-# INLINE withQueueLock #-} - -instance QueueStoreClass (JournalQueue s) (QStore s) where - type QueueStoreCfg (QStore s) = QStoreCfg s - - newQueueStore :: QStoreCfg s -> IO (QStore s) - newQueueStore = \case - MQStoreCfg -> MQStore <$> newQueueStore @(JournalQueue s) () -#if defined(dbServerPostgres) - PQStoreCfg cfg -> PQStore <$> newQueueStore @(JournalQueue s) (cfg, True) -#endif - - closeQueueStore = withQS (closeQueueStore @(JournalQueue s)) - {-# INLINE closeQueueStore #-} - loadedQueues = withQS loadedQueues - {-# INLINE loadedQueues #-} - compactQueues = withQS (compactQueues @(JournalQueue s)) - {-# INLINE compactQueues #-} - getEntityCounts = withQS (getEntityCounts @(JournalQueue s)) - {-# INLINE getEntityCounts #-} - addQueue_ = withQS addQueue_ - {-# INLINE addQueue_ #-} - getQueue_ = withQS getQueue_ - {-# INLINE getQueue_ #-} - getQueues_ = withQS getQueues_ - {-# INLINE getQueues_ #-} - addQueueLinkData = withQS addQueueLinkData - {-# INLINE addQueueLinkData #-} - getQueueLinkData = withQS getQueueLinkData - {-# INLINE getQueueLinkData #-} - deleteQueueLinkData = withQS deleteQueueLinkData - {-# INLINE deleteQueueLinkData #-} - secureQueue = withQS secureQueue - {-# INLINE secureQueue #-} - updateKeys = withQS updateKeys - {-# INLINE updateKeys #-} - addQueueNotifier = withQS addQueueNotifier - {-# INLINE addQueueNotifier #-} - deleteQueueNotifier = withQS deleteQueueNotifier - {-# INLINE deleteQueueNotifier #-} - suspendQueue = withQS suspendQueue - {-# INLINE suspendQueue #-} - blockQueue = withQS blockQueue - {-# INLINE blockQueue #-} - unblockQueue = withQS unblockQueue - {-# INLINE unblockQueue #-} - updateQueueTime = withQS updateQueueTime - {-# INLINE updateQueueTime #-} - deleteStoreQueue = withQS deleteStoreQueue - {-# INLINE deleteStoreQueue #-} - getCreateService = withQS (getCreateService @(JournalQueue s)) - {-# INLINE getCreateService #-} - setQueueService = withQS setQueueService - {-# INLINE setQueueService #-} - setQueueServices = withQS setQueueServices - {-# INLINE setQueueServices #-} - getQueueNtfServices = withQS (getQueueNtfServices @(JournalQueue s)) - {-# INLINE getQueueNtfServices #-} - getServiceQueueCountHash = withQS (getServiceQueueCountHash @(JournalQueue s)) - {-# INLINE getServiceQueueCountHash #-} - -makeQueue_ :: JournalMsgStore s -> RecipientId -> QueueRec -> Lock -> IO (JournalQueue s) -makeQueue_ JournalMsgStore {sharedLock} rId qr queueLock = do - queueRec' <- newTVarIO $ Just qr - msgQueue' <- newTVarIO Nothing - activeAt <- newTVarIO 0 - queueState <- newTVarIO Nothing - pure $ - JournalQueue - { recipientId' = rId, - queueLock, - sharedLock, - queueRec', - msgQueue', - activeAt, - queueState - } - -instance MsgStoreClass (JournalMsgStore s) where - type StoreMonad (JournalMsgStore s) = StoreIO s - type MsgQueue (JournalMsgStore s) = JournalMsgQueue s - type QueueStore (JournalMsgStore s) = QStore s - type StoreQueue (JournalMsgStore s) = JournalQueue s - type MsgStoreConfig (JournalMsgStore s) = JournalStoreConfig s - - newMsgStore :: JournalStoreConfig s -> IO (JournalMsgStore s) - newMsgStore config@JournalStoreConfig {queueStoreCfg} = do - random <- newTVarIO =<< newStdGen - queueLocks <- TM.emptyIO - sharedLock <- newEmptyTMVarIO - queueStore_ <- newQueueStore @(JournalQueue s) queueStoreCfg - openedQueueCount <- newTVarIO 0 - expireBackupsBefore <- addUTCTime (- expireBackupsAfter config) <$> getCurrentTime - pure JournalMsgStore {config, random, queueLocks, sharedLock, queueStore_, openedQueueCount, expireBackupsBefore} - - closeMsgStore :: JournalMsgStore s -> IO () - closeMsgStore ms = do - let st = queueStore_ ms - closeQueues $ loadedQueues @(JournalQueue s) st - closeQueueStore @(JournalQueue s) st - where - closeQueues qs = readTVarIO qs >>= mapM_ (closeMsgQueue ms) - - withActiveMsgQueues :: Monoid a => JournalMsgStore s -> (JournalQueue s -> IO a) -> IO a - withActiveMsgQueues = withQS withLoadedQueues . queueStore_ - - -- This function can only be used in server CLI commands or before server is started. - -- It does not cache queues and is NOT concurrency safe. - unsafeWithAllMsgQueues :: Monoid a => Bool -> JournalMsgStore s -> (JournalQueue s -> IO a) -> IO a - unsafeWithAllMsgQueues tty ms action = case queueStore_ ms of - MQStore st -> withLoadedQueues st run -#if defined(dbServerPostgres) - PQStore st -> foldQueueRecs False tty st $ uncurry (mkQueue ms False) >=> run -#endif - where - run q = do - r <- action q - closeMsgQueue ms q - pure r - - -- This function is concurrency safe - expireOldMessages :: Bool -> JournalMsgStore s -> Int64 -> Int64 -> IO MessageStats - expireOldMessages tty ms now ttl = case queueStore_ ms of - MQStore st -> - withLoadedQueues st $ \q -> run $ isolateQueue ms q "deleteExpiredMsgs" $ do - StoreIO (readTVarIO $ queueRec q) >>= \case - Just QueueRec {updatedAt = Just (RoundedSystemTime t)} | t > veryOld -> - expireQueueMsgs ms now old q - _ -> pure newMessageStats -#if defined(dbServerPostgres) - PQStore st -> do - let JournalMsgStore {queueLocks, sharedLock} = ms - foldRecentQueueRecs veryOld tty st $ \(rId, qr) -> do - q <- mkQueue ms False rId qr - withSharedWaitLock rId queueLocks sharedLock $ run $ tryStore' "deleteExpiredMsgs" rId $ - getLoadedQueue q >>= unStoreIO . expireQueueMsgs ms now old -#endif - where - old = now - ttl - veryOld = now - 2 * ttl - 86400 - run :: ExceptT ErrorType IO MessageStats -> IO MessageStats - run = fmap (fromRight newMessageStats) . runExceptT - -- Use cached queue if available. - -- Also see the comment in loadQueue in PostgresQueueStore - getLoadedQueue :: JournalQueue s -> IO (JournalQueue s) - getLoadedQueue q = fromMaybe q <$> TM.lookupIO (recipientId q) (loadedQueues $ queueStore_ ms) - - foldRcvServiceMessages :: JournalMsgStore s -> ServiceId -> (a -> RecipientId -> Either ErrorType (Maybe (QueueRec, Message)) -> IO a) -> a -> IO (Either ErrorType a) - foldRcvServiceMessages ms serviceId f acc = case queueStore_ ms of - MQStore st -> fmap Right $ foldRcvServiceQueues st serviceId f' acc - where - f' a (q, qr) = runExceptT (tryPeekMsg ms q) >>= f a (recipientId q) . ((qr,) <$$>) -#if defined(dbServerPostgres) - PQStore st -> foldRcvServiceQueueRecs st serviceId f' acc - where - JournalMsgStore {queueLocks, sharedLock} = ms - f' a (rId, qr) = do - q <- mkQueue ms False rId qr - qMsg_ <- - withSharedWaitLock rId queueLocks sharedLock $ runExceptT $ tryStore' "foldRcvServiceMessages" rId $ - (qr,) . snd <$$> (getLoadedQueue q >>= unStoreIO . getPeekMsgQueue ms) - f a rId qMsg_ - -- Use cached queue if available. - -- Also see the comment in loadQueue in PostgresQueueStore - getLoadedQueue q = fromMaybe q <$> TM.lookupIO (recipientId q) (loadedQueues $ queueStore_ ms) -#endif - - logQueueStates :: JournalMsgStore s -> IO () - logQueueStates ms = withActiveMsgQueues ms $ unStoreIO . logQueueState - - logQueueState :: JournalQueue s -> StoreIO s () - logQueueState q = - StoreIO . void $ - readTVarIO (msgQueue' q) - $>>= \mq -> readTVarIO (handles mq) - $>>= (\hs -> (readTVarIO (state mq) >>= appendState (stateHandle hs)) $> Just ()) - - queueStore = queueStore_ - {-# INLINE queueStore #-} - - loadedQueueCounts :: JournalMsgStore s -> IO LoadedQueueCounts - loadedQueueCounts ms = do - let (qs, ns, nLocks_) = loaded - loadedQueueCount <- M.size <$> readTVarIO qs - loadedNotifierCount <- M.size <$> readTVarIO ns - openJournalCount <- readTVarIO (openedQueueCount ms) - queueLockCount <- M.size <$> readTVarIO (queueLocks ms) - notifierLockCount <- maybe (pure 0) (fmap M.size . readTVarIO) nLocks_ - pure LoadedQueueCounts {loadedQueueCount, loadedNotifierCount, openJournalCount, queueLockCount, notifierLockCount} - where - loaded :: (TMap RecipientId (JournalQueue s), TMap NotifierId RecipientId, Maybe (TMap NotifierId Lock)) - loaded = case queueStore_ ms of - MQStore STMQueueStore {queues, notifiers} -> (queues, notifiers, Nothing) -#if defined(dbServerPostgres) - PQStore PostgresQueueStore {queues, notifiers, notifierLocks} -> (queues, notifiers, Just notifierLocks) -#endif - - mkQueue :: JournalMsgStore s -> Bool -> RecipientId -> QueueRec -> IO (JournalQueue s) - mkQueue ms keepLock rId qr = do - lock <- if keepLock then atomically $ getMapLock (queueLocks ms) rId else createLockIO - makeQueue_ ms rId qr lock - - getMsgQueue :: JournalMsgStore s -> JournalQueue s -> Bool -> StoreIO s (JournalMsgQueue s) - getMsgQueue ms@JournalMsgStore {random} q'@JournalQueue {recipientId' = rId, msgQueue'} forWrite = - StoreIO $ readTVarIO msgQueue' >>= maybe newQ pure - where - newQ = do - let dir = msgQueueDirectory ms rId - statePath = msgQueueStatePath dir rId - queue = JMQueue {queueDirectory = dir, statePath} - q <- ifM (doesDirectoryExist dir) (openMsgQueue ms queue forWrite) (createQ queue) - atomically $ writeTVar msgQueue' $ Just q - st <- readTVarIO $ state q - atomically $ writeTVar (queueState q') $ Just $! qState st - pure q - where - createQ :: JMQueue -> IO (JournalMsgQueue s) - createQ queue = do - -- folder and files are not created here, - -- to avoid file IO for queues without messages during subscription - journalId <- newJournalId random - mkJournalQueue queue (newMsgQueueState journalId) Nothing - - getPeekMsgQueue :: JournalMsgStore s -> JournalQueue s -> StoreIO s (Maybe (JournalMsgQueue s, Message)) - getPeekMsgQueue ms q@JournalQueue {queueState} = - StoreIO (readTVarIO queueState) >>= \case - Just QState {hasPending} -> if hasPending then peek else pure Nothing - Nothing -> do - -- We only close the queue if we just learnt it's empty. - -- This is needed to reduce file descriptors and memory usage - -- after the server just started and many clients subscribe. - -- In case the queue became non-empty on write and then again empty on read - -- we won't be closing it, to avoid frequent open/close on active queues. - r <- peek - when (isNothing r) $ StoreIO $ closeMsgQueue ms q - pure r - where - peek = do - mq <- getMsgQueue ms q False - (mq,) <$$> tryPeekMsg_ q mq - - -- only runs action if queue is not empty - withIdleMsgQueue :: Int64 -> JournalMsgStore s -> JournalQueue s -> (JournalMsgQueue s -> StoreIO s a) -> StoreIO s (Maybe a, Int) - withIdleMsgQueue now ms@JournalMsgStore {config} q@JournalQueue {queueState} action = - StoreIO $ readTVarIO (msgQueue' q) >>= \case - Nothing -> - E.bracket - getNonEmptyMsgQueue - (mapM_ $ \_ -> closeMsgQueue ms q) - (maybe (pure (Nothing, 0)) (unStoreIO . run)) - where - run mq = do - r <- action mq - sz <- getQueueSize_ mq - pure (Just r, sz) - Just mq -> do - ts <- readTVarIO $ activeAt q - r <- if now - ts >= idleInterval config - then Just <$> unStoreIO (action mq) `E.finally` closeMsgQueue ms q - else pure Nothing - sz <- unStoreIO $ getQueueSize_ mq - pure (r, sz) - where - getNonEmptyMsgQueue :: IO (Maybe (JournalMsgQueue s)) - getNonEmptyMsgQueue = - readTVarIO queueState >>= \case - Just QState {hasStored} - | hasStored -> Just <$> unStoreIO (getMsgQueue ms q False) - | otherwise -> pure Nothing - Nothing -> do - mq <- unStoreIO $ getMsgQueue ms q False - -- queueState was updated in getMsgQueue - readTVarIO queueState >>= \case - Just QState {hasStored} | not hasStored -> closeMsgQueue ms q $> Nothing - _ -> pure $ Just mq - - deleteQueue :: JournalMsgStore s -> JournalQueue s -> IO (Either ErrorType QueueRec) - deleteQueue ms q = fst <$$> deleteQueue_ ms q - - deleteQueueSize :: JournalMsgStore s -> JournalQueue s -> IO (Either ErrorType (QueueRec, Int)) - deleteQueueSize ms q = - deleteQueue_ ms q >>= mapM (traverse getSize) - -- traverse operates on the second tuple element - where - getSize = maybe (pure (-1)) (fmap size . readTVarIO . state) - - -- drainMsgs is never True with Journal storage - getQueueMessages_ :: Bool -> JournalQueue s -> JournalMsgQueue s -> StoreIO s [Message] - getQueueMessages_ drainMsgs q' q = StoreIO $ if drainMsgs then run [] else readTVarIO (state q) >>= runFast - where - run msgs = readTVarIO (handles q) >>= maybe (pure []) (getMsg msgs) - getMsg msgs hs = chooseReadJournal q' q drainMsgs hs >>= maybe (pure msgs) readMsg - where - readMsg (rs, h) = do - (msg, len) <- hGetMsgAt h $ bytePos rs - updateReadPos q' q drainMsgs len hs - (msg :) <$> run msgs - runFast MsgQueueState {writeState = ws, readState = rs, size} - | size > 0 = - readTVarIO (handles q) >>= \case - Just (MsgQueueHandles _ rh wh_) -> do - msgs <- getJournalRange rh (bytePos rs) (byteCount rs) - case wh_ of - Just wh -> (msgs ++) <$> getJournalRange wh 0 (bytePos ws) - Nothing -> pure msgs - Nothing -> pure [] - | otherwise = pure [] - - writeMsg :: JournalMsgStore s -> JournalQueue s -> Bool -> Message -> ExceptT ErrorType IO (Maybe (Message, Bool)) - writeMsg ms q' logState msg = isolateQueue ms q' "writeMsg" $ do - q <- getMsgQueue ms q' True - StoreIO $ (`E.finally` updateActiveAt q') $ do - st@MsgQueueState {canWrite, size} <- readTVarIO (state q) - let empty = size == 0 - if canWrite || empty - then do - let canWrt' = quota > size - if canWrt' - then writeToJournal q st canWrt' msg $> Just (msg, empty) - else writeToJournal q st canWrt' msgQuota $> Nothing - else pure Nothing - where - JournalStoreConfig {quota, maxMsgCount} = config ms - msgQuota = MessageQuota {msgId = messageId msg, msgTs = messageTs msg} - writeToJournal q st@MsgQueueState {writeState, readState = rs, size} canWrt' !msg' = do - let msgStr = strEncode msg' `B.snoc` '\n' - msgLen = fromIntegral $ B.length msgStr - hs <- maybe createQueueDir pure =<< readTVarIO handles - (ws, wh) <- case writeHandle hs of - Nothing | msgCount writeState >= maxMsgCount -> switchWriteJournal hs - wh_ -> pure (writeState, fromMaybe (readHandle hs) wh_) - let msgPos' = msgPos ws + 1 - bytePos' = bytePos ws + msgLen - ws' = ws {msgPos = msgPos', msgCount = msgPos', bytePos = bytePos', byteCount = bytePos'} - rs' = if journalId ws == journalId rs then rs {msgCount = msgPos', byteCount = bytePos'} else rs - !st' = st {writeState = ws', readState = rs', canWrite = canWrt', size = size + 1} - hAppend wh (bytePos ws) msgStr - updateQueueState q' q logState hs st' $ - when (size == 0) $ writeTVar (tipMsg q) $ Just (Just (msg, msgLen)) - where - JournalMsgQueue {queue = JMQueue {queueDirectory, statePath}, handles} = q - createQueueDir = do - createDirectoryIfMissing True queueDirectory - sh <- openFile statePath AppendMode - rh <- createNewJournal queueDirectory $ journalId rs - let hs = MsgQueueHandles {stateHandle = sh, readHandle = rh, writeHandle = Nothing} - atomically $ writeTVar handles $ Just hs - atomically $ modifyTVar' (openedQueueCount ms) (+ 1) - pure hs - switchWriteJournal hs = do - journalId <- newJournalId $ random ms - wh <- createNewJournal queueDirectory journalId - atomically $ writeTVar handles $ Just $ hs {writeHandle = Just wh} - pure (newJournalState journalId, wh) - - -- can ONLY be used while restoring messages, not while server running - setOverQuota_ :: JournalQueue s -> IO () - setOverQuota_ q = - readTVarIO (msgQueue' q) - >>= mapM_ (\JournalMsgQueue {state} -> atomically $ modifyTVar' state $ \st -> st {canWrite = False}) - - getQueueSize_ :: JournalMsgQueue s -> StoreIO s Int - getQueueSize_ JournalMsgQueue {state} = StoreIO $ size <$> readTVarIO state - - tryPeekMsg_ :: JournalQueue s -> JournalMsgQueue s -> StoreIO s (Maybe Message) - tryPeekMsg_ q mq@JournalMsgQueue {tipMsg, handles} = - StoreIO $ (readTVarIO handles $>>= chooseReadJournal q mq True $>>= peekMsg) - where - peekMsg (rs, h) = readTVarIO tipMsg >>= maybe readMsg (pure . fmap fst) - where - readMsg = do - ml@(msg, _) <- hGetMsgAt h $ bytePos rs - atomically $ writeTVar tipMsg $ Just (Just ml) - pure $ Just msg - - tryDeleteMsg_ :: JournalQueue s -> JournalMsgQueue s -> Bool -> StoreIO s () - tryDeleteMsg_ q mq@JournalMsgQueue {tipMsg, handles} logState = StoreIO $ (`E.finally` when logState (updateActiveAt q)) $ - void $ - readTVarIO tipMsg -- if there is no cached tipMsg, do nothing - $>>= (pure . fmap snd) - $>>= \len -> readTVarIO handles - $>>= \hs -> updateReadPos q mq logState len hs $> Just () - - isolateQueue :: JournalMsgStore s -> JournalQueue s -> Text -> StoreIO s a -> ExceptT ErrorType IO a - isolateQueue _ sq op = tryStore' op (recipientId' sq) . withQueueLock sq op . unStoreIO - - unsafeRunStore :: JournalQueue s -> Text -> StoreIO s a -> IO a - unsafeRunStore sq op a = - unStoreIO a `E.catch` \e -> storeError op (recipientId' sq) e >> E.throwIO e - -updateActiveAt :: JournalQueue s -> IO () -updateActiveAt q = atomically . writeTVar (activeAt q) . systemSeconds =<< getSystemTime - -tryStore' :: Text -> RecipientId -> IO a -> ExceptT ErrorType IO a -tryStore' op rId = tryStore op rId . fmap Right - -tryStore :: forall a. Text -> RecipientId -> IO (Either ErrorType a) -> ExceptT ErrorType IO a -tryStore op rId a = ExceptT $ E.mask_ $ a `E.catch` storeError op rId - -storeError :: Text -> RecipientId -> E.SomeException -> IO (Either ErrorType a) -storeError op rId e = - let e' = T.intercalate ", " [op, decodeLatin1 $ strEncode rId, tshow e] - in logError ("STORE: " <> e') $> Left (STORE e') - -isolateQueueId :: Text -> JournalMsgStore s -> RecipientId -> IO (Either ErrorType a) -> ExceptT ErrorType IO a -isolateQueueId op JournalMsgStore {queueLocks, sharedLock} rId = - tryStore op rId . withLockMapWaitShared rId queueLocks sharedLock op - -openMsgQueue :: JournalMsgStore s -> JMQueue -> Bool -> IO (JournalMsgQueue s) -openMsgQueue ms@JournalMsgStore {config} q@JMQueue {queueDirectory = dir, statePath} forWrite = do - (st_, shouldBackup) <- readQueueState ms statePath - case st_ of - Nothing -> do - st <- newMsgQueueState <$> newJournalId (random ms) - when shouldBackup $ backupQueueState statePath -- rename invalid state file - mkJournalQueue q st Nothing - Just st - | size st == 0 -> do - (st', hs_) <- removeJournals st shouldBackup - when (isJust hs_) incOpenedCount - mkJournalQueue q st' hs_ - | otherwise -> do - sh <- openBackupQueueState st shouldBackup - (st', rh, wh_) <- closeOnException sh $ openJournals ms dir st sh - let hs = MsgQueueHandles {stateHandle = sh, readHandle = rh, writeHandle = wh_} - incOpenedCount - mkJournalQueue q st' (Just hs) - where - incOpenedCount = atomically $ modifyTVar' (openedQueueCount ms) (+ 1) - -- If the queue is empty, journals are deleted. - -- New journal is created if queue is written to. - -- canWrite is set to True. - removeJournals MsgQueueState {readState = rs, writeState = ws} shouldBackup = E.uninterruptibleMask_ $ do - rjId <- newJournalId $ random ms - let st = newMsgQueueState rjId - hs_ <- - if forWrite - then Just <$> newJournalHandles st rjId - else Nothing <$ backupQueueState statePath - removeJournalIfExists dir rs - unless (journalId ws == journalId rs) $ removeJournalIfExists dir ws - pure (st, hs_) - where - newJournalHandles st rjId = do - sh <- openBackupQueueState st shouldBackup - appendState_ sh st - rh <- closeOnException sh $ createNewJournal dir rjId - pure MsgQueueHandles {stateHandle = sh, readHandle = rh, writeHandle = Nothing} - openBackupQueueState st shouldBackup - | shouldBackup = do - -- State backup is made in two steps to mitigate the crash during the backup. - -- Temporary backup file will be used when it is present. - let tempBackup = statePath <> ".bak" - renameFile statePath tempBackup -- 1) temp backup - sh <- openFile statePath AppendMode - closeOnException sh $ appendState sh st -- 2) save state to new file - backupQueueState tempBackup -- 3) timed backup - pure sh - | otherwise = openFile statePath AppendMode - backupQueueState path = do - ts <- getCurrentTime - renameFile path $ stateBackupPath statePath ts - -- remove old backups - times <- sort . mapMaybe backupPathTime <$> listDirectory dir - let toDelete = filter (< expireBackupsBefore ms) $ take (length times - keepMinBackups config) times - mapM_ (safeRemoveFile "removeBackups" . stateBackupPath statePath) toDelete - where - backupPathTime :: FilePath -> Maybe UTCTime - backupPathTime = iso8601ParseM . T.unpack <=< T.stripSuffix ".bak" <=< T.stripPrefix statePathPfx . T.pack - statePathPfx = T.pack $ takeFileName statePath <> "." - -mkJournalQueue :: JMQueue -> MsgQueueState -> Maybe MsgQueueHandles -> IO (JournalMsgQueue s) -mkJournalQueue queue st hs_ = do - state <- newTVarIO st - tipMsg <- newTVarIO Nothing - handles <- newTVarIO hs_ - -- using the same queue lock which is currently locked, - -- to avoid map lookup on queue operations - pure JournalMsgQueue {queue, state, tipMsg, handles} - -chooseReadJournal :: JournalQueue s -> JournalMsgQueue s -> Bool -> MsgQueueHandles -> IO (Maybe (JournalState 'JTRead, Handle)) -chooseReadJournal q' q log' hs = do - st@MsgQueueState {writeState = ws, readState = rs} <- readTVarIO (state q) - case writeHandle hs of - Just wh | msgPos rs >= msgCount rs && journalId rs /= journalId ws -> do - -- switching to write journal - atomically $ writeTVar (handles q) $ Just hs {readHandle = wh, writeHandle = Nothing} - hClose $ readHandle hs - when log' $ removeJournal (queueDirectory $ queue q) rs - let !rs' = (newJournalState $ journalId ws) {msgCount = msgCount ws, byteCount = byteCount ws} - !st' = st {readState = rs'} - updateQueueState q' q log' hs st' $ pure () - pure $ Just (rs', wh) - _ | msgPos rs >= msgCount rs && journalId rs == journalId ws -> pure Nothing - _ -> pure $ Just (rs, readHandle hs) - -updateQueueState :: JournalQueue s -> JournalMsgQueue s -> Bool -> MsgQueueHandles -> MsgQueueState -> STM () -> IO () -updateQueueState q' q log' hs st a = do - unless (validQueueState st) $ E.throwIO $ userError $ "updateQueueState invalid state: " <> show st - when log' $ appendState (stateHandle hs) st - atomically $ writeTVar (queueState q') $ Just $! qState st - atomically $ writeTVar (state q) st >> a - -appendState :: Handle -> MsgQueueState -> IO () -appendState h = E.uninterruptibleMask_ . appendState_ h -{-# INLINE appendState #-} - -appendState_ :: Handle -> MsgQueueState -> IO () -appendState_ h st = B.hPutStr h $ strEncode st `B.snoc` '\n' - -updateReadPos :: JournalQueue s -> JournalMsgQueue s -> Bool -> Int64 -> MsgQueueHandles -> IO () -updateReadPos q' q log' len hs = do - st@MsgQueueState {readState = rs, size} <- readTVarIO (state q) - let JournalState {msgPos, bytePos} = rs - let msgPos' = msgPos + 1 - rs' = rs {msgPos = msgPos', bytePos = bytePos + len} - st' = st {readState = rs', size = size - 1} - updateQueueState q' q log' hs st' $ writeTVar (tipMsg q) Nothing - -msgQueueDirectory :: JournalMsgStore s -> RecipientId -> FilePath -msgQueueDirectory JournalMsgStore {config = JournalStoreConfig {storePath, pathParts}} rId = - storePath B.unpack (B.intercalate "/" $ splitSegments pathParts $ strEncode rId) - where - splitSegments _ "" = [] - splitSegments 1 s = [s] - splitSegments n s = - let (seg, s') = B.splitAt 2 s - in seg : splitSegments (n - 1) s' - -msgQueueStatePath :: FilePath -> RecipientId -> FilePath -msgQueueStatePath dir rId = dir (queueLogFileName <> "." <> B.unpack (strEncode rId) <> logFileExt) - -createNewJournal :: FilePath -> ByteString -> IO Handle -createNewJournal dir journalId = do - let path = journalFilePath dir journalId -- TODO retry if file exists - h <- openFile path ReadWriteMode - B.hPutStr h "" - pure h - -newJournalId :: TVar StdGen -> IO ByteString -newJournalId g = strEncode <$> atomically (stateTVar g $ genByteString 12) - -openJournals :: JournalMsgStore s -> FilePath -> MsgQueueState -> Handle -> IO (MsgQueueState, Handle, Maybe Handle) -openJournals ms dir st@MsgQueueState {readState = rs, writeState = ws} sh = do - let rjId = journalId rs - wjId = journalId ws - openJournal rs >>= \case - Left path - | rjId == wjId -> do - logError $ "STORE: openJournals, no read/write file - creating new file, " <> T.pack path - newReadJournal - | otherwise -> do - let rs' = (newJournalState wjId) {msgCount = msgCount ws, byteCount = byteCount ws} - st' = st {readState = rs', size = msgCount ws} - openJournal rs' >>= \case - Left path' -> do - logError $ "STORE: openJournals, no read and write files - creating new file, read: " <> T.pack path <> ", write: " <> T.pack path' - newReadJournal - Right rh -> do - logError $ "STORE: openJournals, no read file - switched to write file, " <> T.pack path - closeOnException rh $ fixFileSize rh $ bytePos ws - pure (st', rh, Nothing) - Right rh - | rjId == wjId -> do - closeOnException rh $ fixFileSize rh $ bytePos ws - pure (st, rh, Nothing) - | otherwise -> closeOnException rh $ do - fixFileSize rh $ byteCount rs - openJournal ws >>= \case - Left path -> do - let msgs = msgCount rs - bytes = byteCount rs - size' = msgs - msgPos rs - ws' = (newJournalState rjId) {msgPos = msgs, msgCount = msgs, bytePos = bytes, byteCount = bytes} - st' = st {writeState = ws', size = size'} -- we don't amend canWrite to trigger QCONT - logError $ "STORE: openJournals, no write file, " <> T.pack path - pure (st', rh, Nothing) - Right wh -> do - closeOnException wh $ fixFileSize wh $ bytePos ws - pure (st, rh, Just wh) - where - newReadJournal = do - rjId' <- newJournalId $ random ms - rh <- createNewJournal dir rjId' - let st' = newMsgQueueState rjId' - closeOnException rh $ appendState sh st' - pure (st', rh, Nothing) - openJournal :: JournalState t -> IO (Either FilePath Handle) - openJournal JournalState {journalId} = - let path = journalFilePath dir journalId - in ifM (doesFileExist path) (Right <$> openFile path ReadWriteMode) (pure $ Left path) - -- do that for all append operations - -fixFileSize :: Handle -> Int64 -> IO () -fixFileSize h pos = do - let pos' = fromIntegral pos - size <- IO.hFileSize h - if - | size > pos' -> do - name <- IO.hShow h - logWarn $ "STORE: fixFileSize, size " <> tshow size <> " > pos " <> tshow pos <> " - truncating, " <> T.pack name - IO.hSetFileSize h pos' - | size < pos' -> do - -- From code logic this can't happen. - name <- IO.hShow h - E.throwIO $ userError $ "fixFileSize size " <> show size <> " < pos " <> show pos <> " - aborting: " <> name - | otherwise -> pure () - -removeJournal :: FilePath -> JournalState t -> IO () -removeJournal dir JournalState {journalId} = - safeRemoveFile "removeJournal" $ journalFilePath dir journalId - -removeJournalIfExists :: FilePath -> JournalState t -> IO () -removeJournalIfExists dir JournalState {journalId} = do - let path = journalFilePath dir journalId - handleError "removeJournalIfExists" path $ - whenM (doesFileExist path) $ removeFile path - -safeRemoveFile :: Text -> FilePath -> IO () -safeRemoveFile cxt path = handleError cxt path $ removeFile path - -handleError :: Text -> FilePath -> IO () -> IO () -handleError cxt path a = - a `catchAny` \e -> logError $ "STORE: " <> cxt <> ", " <> T.pack path <> ", " <> tshow e - --- This function is supposed to be resilient to crashes while updating state files, --- and also resilient to crashes during its execution. -readQueueState :: JournalMsgStore s -> FilePath -> IO (Maybe MsgQueueState, Bool) -readQueueState JournalMsgStore {config} statePath = - ifM - (doesFileExist tempBackup) - (renameFile tempBackup statePath >> readState) - (ifM (doesFileExist statePath) readState $ pure (Nothing, False)) - where - tempBackup = statePath <> ".bak" - readState = do - ls <- B.lines <$> readFileTail - case ls of - [] -> do - logWarn $ "STORE: readWriteQueueState, empty queue state, " <> T.pack statePath - pure (Nothing, False) - _ -> do - r <- useLastLine (length ls) True ls - forM_ (fst r) $ \st -> - unless (validQueueState st) $ E.throwIO $ userError $ "readWriteQueueState inconsistent state: " <> show st - pure r - useLastLine len isLastLine ls = case strDecode $ last ls of - Right st -> - -- when state file has fewer than maxStateLines, we don't compact it - let shouldBackup = len > maxStateLines config || not isLastLine - in pure (Just st, shouldBackup) - Left e -- if the last line failed to parse - | isLastLine -> case init ls of -- or use the previous line - [] -> do - logWarn $ "STORE: readWriteQueueState, invalid 1-line queue state - initialized, " <> T.pack statePath - pure (Nothing, True) -- backup state file, because last line was invalid - ls' -> do - logWarn $ "STORE: readWriteQueueState, invalid last line in queue state - using the previous line, " <> T.pack statePath - useLastLine len False ls' - | otherwise -> E.throwIO $ userError $ "readWriteQueueState invalid state " <> statePath <> ": " <> show e - readFileTail = - IO.withFile statePath ReadMode $ \h -> do - size <- IO.hFileSize h - let sz = stateTailSize config - sz' = fromIntegral sz - if size > sz' - then IO.hSeek h AbsoluteSeek (size - sz') >> B.hGet h sz - else B.hGet h (fromIntegral size) - -stateBackupPath :: FilePath -> UTCTime -> FilePath -stateBackupPath statePath ts = statePath <> "." <> iso8601Show ts <> ".bak" - -validQueueState :: MsgQueueState -> Bool -validQueueState MsgQueueState {readState = rs, writeState = ws, size} - | journalId rs == journalId ws = - alwaysValid - && msgPos rs <= msgPos ws - && msgCount rs == msgCount ws - && bytePos rs <= bytePos ws - && byteCount rs == byteCount ws - && size == msgCount rs - msgPos rs - | otherwise = - alwaysValid - && size == msgCount ws + msgCount rs - msgPos rs - where - alwaysValid = - msgPos rs <= msgCount rs - && bytePos rs <= byteCount rs - && msgPos ws == msgCount ws - && bytePos ws == byteCount ws - -deleteQueue_ :: JournalMsgStore s -> JournalQueue s -> IO (Either ErrorType (QueueRec, Maybe (JournalMsgQueue s))) -deleteQueue_ ms q = - runExceptT $ isolateQueueId "deleteQueue_" ms rId $ do - r <- deleteStoreQueue (queueStore_ ms) q >>= mapM remove - atomically $ TM.delete rId (queueLocks ms) - pure r - where - rId = recipientId q - remove qr = do - mq_ <- atomically $ swapTVar (msgQueue' q) Nothing - mapM_ (closeMsgQueueHandles ms) mq_ - removeQueueDirectory ms rId - pure (qr, mq_) - -closeMsgQueue :: JournalMsgStore s -> JournalQueue s -> IO () -closeMsgQueue ms JournalQueue {msgQueue'} = atomically (swapTVar msgQueue' Nothing) >>= mapM_ (closeMsgQueueHandles ms) - -closeMsgQueueHandles :: JournalMsgStore s -> JournalMsgQueue s -> IO () -closeMsgQueueHandles ms q = readTVarIO (handles q) >>= mapM_ closeHandles - where - closeHandles (MsgQueueHandles sh rh wh_) = do - hClose sh - hClose rh - mapM_ hClose wh_ - atomically $ modifyTVar' (openedQueueCount ms) (subtract 1) - -removeQueueDirectory :: JournalMsgStore s -> RecipientId -> IO () -removeQueueDirectory st = removeQueueDirectory_ . msgQueueDirectory st - -removeQueueDirectory_ :: FilePath -> IO () -removeQueueDirectory_ dir = - handleError "removeQueueDirectory" dir $ removePathForcibly dir - -hAppend :: Handle -> Int64 -> ByteString -> IO () -hAppend h pos s = do - fixFileSize h pos - IO.hSeek h SeekFromEnd 0 - B.hPutStr h s - -hGetMsgAt :: Handle -> Int64 -> IO (Message, Int64) -hGetMsgAt h pos = do - IO.hSeek h AbsoluteSeek $ fromIntegral pos - s <- B.hGetLine h - case strDecode s of - Right !msg -> - let !len = fromIntegral (B.length s) + 1 - in pure (msg, len) - Left e -> E.throwIO $ userError $ "hGetMsgAt invalid message: " <> e - -openFile :: FilePath -> IOMode -> IO Handle -openFile f mode = do - h <- IO.openFile f mode - IO.hSetBuffering h LineBuffering - pure h - -hClose :: Handle -> IO () -hClose h = - IO.hClose h `catchAny` \e -> do - name <- IO.hShow h - logError $ "STORE: hClose, " <> T.pack name <> ", " <> tshow e - -closeOnException :: Handle -> IO a -> IO a -closeOnException h a = a `E.onException` hClose h - -getJournalQueueMessages :: JournalMsgStore s -> JournalQueue s -> IO [Message] -getJournalQueueMessages ms q = - readQueueState ms (msgQueueStatePath dir rId) >>= \case - (Just MsgQueueState {readState = rs, writeState = ws, size}, _) | size > 0 -> do - msgs <- getMsgs (journalId rs) (bytePos rs) (byteCount rs) - if journalId rs == journalId ws - then pure msgs - else (msgs ++) <$> getMsgs (journalId ws) 0 (bytePos ws) - _ -> pure [] - where - rId = recipientId' q - dir = msgQueueDirectory ms rId - getMsgs jId from to = - IO.withFile (journalFilePath dir jId) ReadWriteMode $ \h' -> - getJournalRange h' from to - -getJournalRange :: Handle -> Int64 -> Int64 -> IO [Message] -getJournalRange h from to - | to > from = do - IO.hSeek h AbsoluteSeek $ fromIntegral from - parseMsgs =<< B.hGet h (fromIntegral $ to - from) - | otherwise = pure [] - where - parseMsgs s = do - let (errs, msgs) = partitionEithers $ map strDecode $ B.lines s - unless (null errs) $ do - f <- IO.hShow h - putStrLn $ "Error reading " <> show (length errs) <> " messages from " <> f - pure msgs diff --git a/src/Simplex/Messaging/Server/MsgStore/Journal/SharedLock.hs b/src/Simplex/Messaging/Server/MsgStore/Journal/SharedLock.hs deleted file mode 100644 index 87b7294f1b..0000000000 --- a/src/Simplex/Messaging/Server/MsgStore/Journal/SharedLock.hs +++ /dev/null @@ -1,44 +0,0 @@ -module Simplex.Messaging.Server.MsgStore.Journal.SharedLock - ( withLockWaitShared, - withLockMapWaitShared, - withSharedWaitLock, - ) -where - -import Control.Concurrent.STM -import qualified Control.Exception as E -import Control.Monad -import Data.Text (Text) -import Simplex.Messaging.Agent.Lock -import Simplex.Messaging.Agent.Client (getMapLock) -import Simplex.Messaging.Protocol (RecipientId) -import Simplex.Messaging.TMap (TMap) -import qualified Simplex.Messaging.TMap as TM -import Simplex.Messaging.Util (($>>), ($>>=)) - --- wait until shared lock with passed ID is released and take lock -withLockWaitShared :: RecipientId -> Lock -> TMVar RecipientId -> Text -> IO a -> IO a -withLockWaitShared rId lock shared name = - E.bracket_ - (atomically $ waitShared rId shared >> putTMVar lock name) - (void $ atomically $ takeTMVar lock) - --- wait until shared lock with passed ID is released and take lock from Map for this ID -withLockMapWaitShared :: RecipientId -> TMap RecipientId Lock -> TMVar RecipientId -> Text -> IO a -> IO a -withLockMapWaitShared rId locks shared name a = - E.bracket - (atomically $ waitShared rId shared >> getPutLock (getMapLock locks) rId name) - (atomically . takeTMVar) - (const a) - -waitShared :: RecipientId -> TMVar RecipientId -> STM () -waitShared rId shared = tryReadTMVar shared >>= mapM_ (\rId' -> when (rId == rId') retry) - --- wait until lock with passed ID in Map is released and take shared lock for this ID -withSharedWaitLock :: RecipientId -> TMap RecipientId Lock -> TMVar RecipientId -> IO a -> IO a -withSharedWaitLock rId locks shared = - E.bracket_ - (atomically $ waitLock >> putTMVar shared rId) - (atomically $ takeTMVar shared) - where - waitLock = TM.lookup rId locks $>>= tryReadTMVar $>> retry diff --git a/src/Simplex/Messaging/Server/MsgStore/Postgres.hs b/src/Simplex/Messaging/Server/MsgStore/Postgres.hs index c8506709c7..821c5e7f25 100644 --- a/src/Simplex/Messaging/Server/MsgStore/Postgres.hs +++ b/src/Simplex/Messaging/Server/MsgStore/Postgres.hs @@ -162,7 +162,7 @@ instance MsgStoreClass PostgresMsgStore where loadedQueueCount <- M.size <$> readTVarIO queues loadedNotifierCount <- M.size <$> readTVarIO notifiers notifierLockCount <- M.size <$> readTVarIO notifierLocks - pure LoadedQueueCounts {loadedQueueCount, loadedNotifierCount, openJournalCount = 0, queueLockCount = 0, notifierLockCount} + pure LoadedQueueCounts {loadedQueueCount, loadedNotifierCount, queueLockCount = 0, notifierLockCount} where PostgresQueueStore {queues, notifiers, notifierLocks} = queueStore_ ms diff --git a/src/Simplex/Messaging/Server/MsgStore/STM.hs b/src/Simplex/Messaging/Server/MsgStore/STM.hs index f118e007ca..0607ef8b56 100644 --- a/src/Simplex/Messaging/Server/MsgStore/STM.hs +++ b/src/Simplex/Messaging/Server/MsgStore/STM.hs @@ -103,7 +103,7 @@ instance MsgStoreClass STMMsgStore where loadedQueueCounts STMMsgStore {queueStore_ = st} = do loadedQueueCount <- M.size <$> readTVarIO (queues st) loadedNotifierCount <- M.size <$> readTVarIO (notifiers st) - pure LoadedQueueCounts {loadedQueueCount, loadedNotifierCount, openJournalCount = 0, queueLockCount = 0, notifierLockCount = 0} + pure LoadedQueueCounts {loadedQueueCount, loadedNotifierCount, queueLockCount = 0, notifierLockCount = 0} mkQueue _ _ rId qr = STMQueue rId <$> newTVarIO (Just qr) <*> newTVarIO Nothing {-# INLINE mkQueue #-} diff --git a/src/Simplex/Messaging/Server/MsgStore/Types.hs b/src/Simplex/Messaging/Server/MsgStore/Types.hs index a14dfd4242..dce3bc638f 100644 --- a/src/Simplex/Messaging/Server/MsgStore/Types.hs +++ b/src/Simplex/Messaging/Server/MsgStore/Types.hs @@ -124,13 +124,12 @@ class (Monad (StoreMonad s), QueueStoreClass (StoreQueue s) (QueueStore s)) => M getQueueSize st q = withPeekMsgQueue st q "getQueueSize" $ maybe (pure 0) (getQueueSize_ . fst) {-# INLINE getQueueSize #-} -data MSType = MSMemory | MSJournal | MSPostgres +data MSType = MSMemory | MSPostgres data QSType = QSMemory | QSPostgres data SMSType :: MSType -> Type where SMSMemory :: SMSType 'MSMemory - SMSJournal :: SMSType 'MSJournal SMSPostgres :: SMSType 'MSPostgres data SQSType :: QSType -> Type where @@ -155,7 +154,6 @@ instance Semigroup MessageStats where data LoadedQueueCounts = LoadedQueueCounts { loadedQueueCount :: Int, loadedNotifierCount :: Int, - openJournalCount :: Int, queueLockCount :: Int, notifierLockCount :: Int } diff --git a/src/Simplex/Messaging/Server/Prometheus.hs b/src/Simplex/Messaging/Server/Prometheus.hs index 864a2014f0..9f953d646f 100644 --- a/src/Simplex/Messaging/Server/Prometheus.hs +++ b/src/Simplex/Messaging/Server/Prometheus.hs @@ -569,23 +569,19 @@ prometheusMetrics sm rtm ts = \# TYPE simplex_smp_subscription_ntf_service_subs_total gauge\n\ \simplex_smp_subscription_ntf_service_subs_total " <> mshow (subServiceSubsCount ntfSubs) <> "\n# ntf.subServiceSubsCount\n\ \\n\ - \# HELP simplex_smp_loaded_queues_queue_count Total loaded queues count (all queues for memory/journal storage)\n\ + \# HELP simplex_smp_loaded_queues_queue_count Total loaded queues count (all queues for memory storage)\n\ \# TYPE simplex_smp_loaded_queues_queue_count gauge\n\ \simplex_smp_loaded_queues_queue_count " <> mshow (loadedQueueCount loadedCounts) <> "\n# loadedCounts.loadedQueueCount\n\ \\n\ - \# HELP simplex_smp_loaded_queues_ntf_count Total loaded ntf credential references (all ntf credentials for memory/journal storage)\n\ + \# HELP simplex_smp_loaded_queues_ntf_count Total loaded ntf credential references (all ntf credentials for memory storage)\n\ \# TYPE simplex_smp_loaded_queues_ntf_count gauge\n\ \simplex_smp_loaded_queues_ntf_count " <> mshow (loadedNotifierCount loadedCounts) <> "\n# loadedCounts.loadedNotifierCount\n\ \\n\ - \# HELP simplex_smp_loaded_queues_open_journal_count Total opened queue journals (0 for memory storage)\n\ - \# TYPE simplex_smp_loaded_queues_open_journal_count gauge\n\ - \simplex_smp_loaded_queues_open_journal_count " <> mshow (openJournalCount loadedCounts) <> "\n# loadedCounts.openJournalCount\n\ - \\n\ \# HELP simplex_smp_loaded_queues_queue_lock_count Total queue locks (0 for memory storage)\n\ \# TYPE simplex_smp_loaded_queues_queue_lock_count gauge\n\ \simplex_smp_loaded_queues_queue_lock_count " <> mshow (queueLockCount loadedCounts) <> "\n# loadedCounts.queueLockCount\n\ \\n\ - \# HELP simplex_smp_loaded_queues_ntf_lock_count Total notifier locks (0 for memory/journal storage)\n\ + \# HELP simplex_smp_loaded_queues_ntf_lock_count Total notifier locks (0 for memory storage)\n\ \# TYPE simplex_smp_loaded_queues_ntf_lock_count gauge\n\ \simplex_smp_loaded_queues_ntf_lock_count " <> mshow (notifierLockCount loadedCounts) <> "\n# loadedCounts.notifierLockCount\n" diff --git a/tests/AgentTests/FunctionalAPITests.hs b/tests/AgentTests/FunctionalAPITests.hs index ebcd8d7d1e..966982062d 100644 --- a/tests/AgentTests/FunctionalAPITests.hs +++ b/tests/AgentTests/FunctionalAPITests.hs @@ -133,9 +133,7 @@ import Simplex.Messaging.Agent.Store.AgentStore (deleteClientService, getSubscri import qualified Database.PostgreSQL.Simple as PSQL import qualified Simplex.Messaging.Agent.Store.Postgres as Postgres import qualified Simplex.Messaging.Agent.Store.Postgres.Common as Postgres -import Simplex.Messaging.Server.MsgStore.Journal (JournalQueue) import Simplex.Messaging.Server.MsgStore.Postgres (PostgresQueue) -import Simplex.Messaging.Server.MsgStore.Types (QSType (..)) import Simplex.Messaging.Server.QueueStore.Postgres import Simplex.Messaging.Server.QueueStore.Postgres.Migrations import Simplex.Messaging.Server.QueueStore.Types (QueueStoreClass (..)) @@ -1590,7 +1588,7 @@ testAllowConnectionClientRestart ps@(t, ASType qsType _) = do bob <- getSMPAgentClient' 2 agentCfg initAgentServersSrv2 testDB2 withSmpServerStoreLogOn ps testPort $ \_ -> do (aliceId, bobId, confId) <- - withSmpServerConfigOn t (cfgJ2QS qsType) testPort2 $ \_ -> do + withSmpServerConfigOn t (cfgS2QS qsType) testPort2 $ \_ -> do runRight $ do (bobId, qInfo) <- createConnection alice 1 True SCMInvitation Nothing SMSubscribe (aliceId, sqSecured) <- joinConnection bob 1 True qInfo "bob's connInfo" SMSubscribe @@ -1612,7 +1610,7 @@ testAllowConnectionClientRestart ps@(t, ASType qsType _) = do alice2 <- getSMPAgentClient' 3 agentCfg initAgentServers testDB runRight_ $ subscribeConnection alice2 bobId threadDelay 500000 - withSmpServerConfigOn t (cfgJ2QS qsType) testPort2 $ \_ -> do + withSmpServerConfigOn t (cfgS2QS qsType) testPort2 $ \_ -> do runRight $ do ("", "", UP _ _) <- nGet bob get alice2 ##> ("", bobId, CON) @@ -1775,7 +1773,7 @@ withServer1 :: (ASrvTransport, AStoreType) -> IO a -> IO a withServer1 ps = withSmpServerStoreLogOn ps testPort . const withServer2 :: (ASrvTransport, AStoreType) -> IO a -> IO a -withServer2 (t, ASType qsType _) = withSmpServerConfigOn t (cfgJ2QS qsType) testPort2 . const +withServer2 (t, ASType qsType _) = withSmpServerConfigOn t (cfgS2QS qsType) testPort2 . const testInvitationShortLink :: HasCallStack => Bool -> AgentClient -> AgentClient -> IO () testInvitationShortLink viaProxy a b = @@ -2015,18 +2013,11 @@ testOldContactQueueShortLink ps@(_, msType) = withAgentClients2 $ \a b -> do #endif () <- case testServerStoreConfig msType of ASSCfg _ _ (SSCMemory sp_) -> mapM_ (\StorePaths {storeLogFile} -> updateStoreLog storeLogFile) sp_ - ASSCfg _ _ SSCMemoryJournal {storeLogFile} -> updateStoreLog storeLogFile #if defined(dbServerPostgres) - ASSCfg _ _ SSCDatabaseJournal {storeCfg} -> do - st :: PostgresQueueStore (JournalQueue 'QSPostgres) <- newQueueStore @(JournalQueue 'QSPostgres) (storeCfg, True) - updateDbStore st - closeQueueStore @(JournalQueue 'QSPostgres) st ASSCfg _ _ (SSCDatabase storeCfg) -> do st :: PostgresQueueStore PostgresQueue <- newQueueStore @PostgresQueue (storeCfg, False) updateDbStore st closeQueueStore @PostgresQueue st -#else - ASSCfg _ _ SSCDatabaseJournal {} -> error "no dbServerPostgres flag" #endif withSmpServer ps $ do @@ -2532,7 +2523,7 @@ testExpireMessageQuota (t, msType) = withSmpServerConfigOn t cfg' testPort $ \_ ackMessage b' aId 4 Nothing disposeAgentClient a where - cfg' = updateCfg (cfgMS msType) $ \cfg_ -> cfg_ {msgQueueQuota = 1, maxJournalMsgCount = 2} + cfg' = updateCfg (cfgMS msType) $ \cfg_ -> cfg_ {msgQueueQuota = 1} testExpireManyMessagesQuota :: (ASrvTransport, AStoreType) -> IO () testExpireManyMessagesQuota (t, msType) = withSmpServerConfigOn t cfg' testPort $ \_ -> do @@ -2571,7 +2562,7 @@ testExpireManyMessagesQuota (t, msType) = withSmpServerConfigOn t cfg' testPort ackMessage b' aId 4 Nothing disposeAgentClient a where - cfg' = updateCfg (cfgMS msType) $ \cfg_ -> cfg_ {msgQueueQuota = 1, maxJournalMsgCount = 2} + cfg' = updateCfg (cfgMS msType) $ \cfg_ -> cfg_ {msgQueueQuota = 1} testJoinFullContactAsync :: HasCallStack => (ASrvTransport, AStoreType) -> IO () testJoinFullContactAsync (t, msType) = withSmpServerConfigOn t cfg' testPort $ \_ -> do @@ -2590,7 +2581,7 @@ testJoinFullContactAsync (t, msType) = withSmpServerConfigOn t cfg' testPort $ \ ("", _, A.REQ _ _ _ "bob's connInfo" _ _) <- get alice pure () where - cfg' = updateCfg (cfgMS msType) $ \cfg_ -> cfg_ {msgQueueQuota = 1, maxJournalMsgCount = 2} + cfg' = updateCfg (cfgMS msType) $ \cfg_ -> cfg_ {msgQueueQuota = 1} testJoinFullContactAsyncExpire :: HasCallStack => (ASrvTransport, AStoreType) -> IO () testJoinFullContactAsyncExpire (t, msType) = withSmpServerConfigOn t cfg' testPort $ \_ -> do @@ -2604,7 +2595,7 @@ testJoinFullContactAsyncExpire (t, msType) = withSmpServerConfigOn t cfg' testPo noMessages bob "joining should be retried until quota exceeded timeout" get bob =##> \case ("2", c, ERR (SMP _ QUOTA)) -> c == aliceId; _ -> False where - cfg' = updateCfg (cfgMS msType) $ \cfg_ -> cfg_ {msgQueueQuota = 1, maxJournalMsgCount = 2} + cfg' = updateCfg (cfgMS msType) $ \cfg_ -> cfg_ {msgQueueQuota = 1} fillContactAddress :: HasCallStack => IO (ConnId, ConnectionRequestUri 'CMContact) fillContactAddress = do @@ -3182,7 +3173,7 @@ testBatchedSubscriptions nCreate nDel ps@(t, ASType qsType _) = do runServers :: ExceptT AgentErrorType IO a -> IO a runServers a = do withSmpServerStoreLogOn ps testPort $ \t1 -> do - res <- withSmpServerConfigOn t (cfgJ2QS qsType) testPort2 $ \t2 -> + res <- withSmpServerConfigOn t (cfgS2QS qsType) testPort2 $ \t2 -> runRight a `finally` killThread t2 killThread t1 pure res @@ -3689,7 +3680,7 @@ testJoinConnectionAsyncReplyError ps@(t, ASType qsType _) = do ConnectionStats {rcvQueuesInfo = [], sndQueuesInfo = [SndQueueInfo {}]} <- getConnectionServers b aId pure (aId, bId) nGet a =##> \case ("", "", DOWN _ [c]) -> c == bId; _ -> False - withSmpServerConfigOn t (cfgJ2QS qsType) testPort2 $ \_ -> do + withSmpServerConfigOn t (cfgS2QS qsType) testPort2 $ \_ -> do confId <- withSmpServerStoreLogOn ps testPort $ \_ -> do -- both servers need to be online for connection to progress because of SKEY get b =##> \case ("2", c, JOINED sqSecured) -> c == aId && sqSecured; _ -> False @@ -3822,7 +3813,7 @@ fastSwitchComplete a bId b aId = do testFastSwitchDeadOldServer :: HasCallStack => (ASrvTransport, AStoreType) -> IO () testFastSwitchDeadOldServer ps@(t, ASType qsType _) = do let bServers = initAgentServers {smp = userServers [testSMPServer2]} - withSmpServerConfigOn t (cfgJ2QS qsType) testPort2 $ \_ -> + withSmpServerConfigOn t (cfgS2QS qsType) testPort2 $ \_ -> withAgent 1 aCfg initAgentServers testDB $ \a -> withAgent 2 agentCfg bServers testDB2 $ \b -> do (aId, bId) <- withSmpServerStoreLogOn ps testPort $ \_ -> runRight $ do @@ -4382,7 +4373,7 @@ testDeliveryReceiptsConcurrent (t, msType) = liftIO $ noMessages a "nothing else should be delivered to alice" liftIO $ noMessages b "nothing else should be delivered to bob" where - cfg' = updateCfg (cfgMS msType) $ \cfg_ -> cfg_ {msgQueueQuota = 256, maxJournalMsgCount = 512} + cfg' = updateCfg (cfgMS msType) $ \cfg_ -> cfg_ {msgQueueQuota = 256} runClient :: String -> AgentClient -> ConnId -> IO () runClient _cName client connId = do concurrently_ send receive diff --git a/tests/AgentTests/NotificationTests.hs b/tests/AgentTests/NotificationTests.hs index 8e1a85e8aa..134fa559c5 100644 --- a/tests/AgentTests/NotificationTests.hs +++ b/tests/AgentTests/NotificationTests.hs @@ -869,7 +869,7 @@ testNotificationsSMPRestartBatch n ps@(t, ASType qsType _) apns = runServers :: ExceptT AgentErrorType IO a -> IO a runServers a = do withSmpServerStoreLogOn ps testPort $ \t1 -> do - res <- withSmpServerConfigOn t (cfgJ2QS qsType) testPort2 $ \t2 -> + res <- withSmpServerConfigOn t (cfgS2QS qsType) testPort2 $ \t2 -> runRight a `finally` killThread t2 killThread t1 pure res diff --git a/tests/CoreTests/MsgStoreTests.hs b/tests/CoreTests/MsgStoreTests.hs index d9a2590519..41796eeabf 100644 --- a/tests/CoreTests/MsgStoreTests.hs +++ b/tests/CoreTests/MsgStoreTests.hs @@ -16,8 +16,7 @@ module CoreTests.MsgStoreTests where -import AgentTests.FunctionalAPITests (runRight, runRight_) -import Control.Concurrent (threadDelay) +import AgentTests.FunctionalAPITests (runRight_) import Control.Concurrent.STM import Control.Exception (bracket) import Control.Monad @@ -25,33 +24,23 @@ import Control.Monad.IO.Class import Control.Monad.Trans.Except import Crypto.Random (ChaChaDRG) import Data.ByteString.Char8 (ByteString) -import qualified Data.ByteString.Char8 as B import Data.Int (Int64) -import Data.List (isPrefixOf, isSuffixOf) -import Data.Maybe (fromJust) -import Data.Time.Clock (addUTCTime) -import Data.Time.Clock.System (SystemTime (..), getSystemTime) -import SMPClient (testStoreLogFile, testStoreMsgsDir, testStoreMsgsDir2, testStoreMsgsFile, testStoreMsgsFile2) +import Data.Time.Clock.System (getSystemTime) import Simplex.Messaging.Crypto (pattern MaxLenBS) import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Protocol (EncDataBytes (..), EntityId (..), ErrorType (..), LinkId, Message (..), QueueLinkData, RecipientId, SParty (..), noMsgFlags, randomMsgId) -import Simplex.Messaging.Server (exportMessages, importMessages, printMessageStats) -import Simplex.Messaging.Server.Env.STM (MsgStore (..), journalMsgStoreDepth, readWriteQueueStore) -import Simplex.Messaging.Server.Expiration (ExpirationConfig (..), expireBeforeEpoch) -import Simplex.Messaging.Server.MsgStore.Journal import Simplex.Messaging.Server.MsgStore.STM import Simplex.Messaging.Server.MsgStore.Types import Simplex.Messaging.Server.QueueStore import Simplex.Messaging.Server.QueueStore.QueueInfo import Simplex.Messaging.Server.QueueStore.Types -import Simplex.Messaging.Server.StoreLog (closeStoreLog, logCreateQueue) -import System.Directory (copyFile, createDirectoryIfMissing, listDirectory, removeFile, renameFile) -import System.FilePath (()) -import System.IO (IOMode (..), withFile) import Test.Hspec hiding (fit, it) import Util #if defined(dbServerPostgres) +import AgentTests.FunctionalAPITests (runRight) +import Control.Concurrent (threadDelay) +import Data.Time.Clock.System (SystemTime (..)) import Database.PostgreSQL.Simple (Only (..)) import qualified Database.PostgreSQL.Simple as DB import Simplex.Messaging.Agent.Store.Postgres.Common @@ -64,16 +53,8 @@ import SMPClient (postgressBracket, testServerDBConnectInfo, testStoreDBOpts) msgStoreTests :: Spec msgStoreTests = do around (withMsgStore testSMTStoreConfig) $ describe "STM message store" someMsgStoreTests - around (withMsgStore $ testJournalStoreCfg MQStoreCfg) $ describe "Journal message store" $ do - someMsgStoreTests - journalMsgStoreTests - it "should export and import journal store" testExportImportStore #if defined(dbServerPostgres) around_ (postgressBracket testServerDBConnectInfo) $ do - around (withMsgStore $ testJournalStoreCfg $ PQStoreCfg testPostgresStoreCfg) $ - describe "Postgres+journal message store" $ do - someMsgStoreTests - journalMsgStoreTests around (withMsgStore testPostgresStoreConfig) $ describe "Postgres-only message store" $ do someMsgStoreTests @@ -81,21 +62,7 @@ msgStoreTests = do it "tryDelPeekMsg (ACK not from NSE) should reset message counts when queue is empty" testResetMessageCounts it "should expire messages across commit batches" testExpireMessagesInBatches #endif - describe "Journal message store: queue state backup expiration" $ do - it "should remove old queue state backups" testRemoveQueueStateBackups - it "should expire messages in idle queues" testExpireIdleQueues where - journalMsgStoreTests :: SpecWith (JournalMsgStore s) - journalMsgStoreTests = do - describe "queue state" $ do - it "should restore queue state from the last line" testQueueState - it "should recover when message is written and state is not" testMessageState - it "should remove journal files when queue is empty" testRemoveJournals - describe "missing files" $ do - it "should create read file when missing" testReadFileMissing - it "should switch to write file when read file missing" testReadFileMissingSwitch - it "should create write file when missing" testWriteFileMissing - it "should create read file when read and write files are missing" testReadAndWriteFilesMissing someMsgStoreTests :: MsgStoreClass s => SpecWith s someMsgStoreTests = do it "should get queue and store/read messages" testGetQueue @@ -110,21 +77,6 @@ withMsgStore cfg = bracket (newMsgStore cfg) closeMsgStore testSMTStoreConfig :: STMStoreConfig testSMTStoreConfig = STMStoreConfig {storePath = Nothing, quota = 3} -testJournalStoreCfg :: QStoreCfg s -> JournalStoreConfig s -testJournalStoreCfg queueStoreCfg = - JournalStoreConfig - { storePath = testStoreMsgsDir, - pathParts = journalMsgStoreDepth, - queueStoreCfg, - quota = 3, - maxMsgCount = 4, - maxStateLines = 2, - stateTailSize = 256, - idleInterval = 21600, - expireBackupsAfter = 0, - keepMinBackups = 1 - } - #if defined(dbServerPostgres) testPostgresStoreConfig :: PostgresMsgStoreCfg testPostgresStoreConfig = @@ -153,12 +105,6 @@ mkMessage body = liftIO $ do pattern Msg :: ByteString -> Maybe Message pattern Msg s <- Just Message {msgBody = MaxLenBS s} -deriving instance Eq MsgQueueState - -deriving instance Eq (JournalState t) - -deriving instance Eq (SJournalType t) - testNewQueueRec :: TVar ChaChaDRG -> QueueMode -> IO (RecipientId, QueueRec) testNewQueueRec g qm = testNewQueueRecData g qm Nothing @@ -295,58 +241,6 @@ testLinkDataSecuredQueue ms = do void $ ExceptT $ deleteQueue ms q void $ ExceptT $ deleteQueue ms cq -testExportImportStore :: JournalMsgStore 'QSMemory -> IO () -testExportImportStore ms = do - g <- C.newRandom - (rId1, qr1) <- testNewQueueRec g QMMessaging - (rId2, qr2) <- testNewQueueRec g QMMessaging - sl <- readWriteQueueStore True (mkQueue ms True) testStoreLogFile $ stmQueueStore ms - runRight_ $ do - let write q s = writeMsg ms q True =<< mkMessage s - q1 <- ExceptT $ addQueue ms rId1 qr1 - liftIO $ logCreateQueue sl rId1 qr1 - Just (Message {}, True) <- write q1 "message 1" - Just (Message {}, False) <- write q1 "message 2" - q2 <- ExceptT $ addQueue ms rId2 qr2 - liftIO $ logCreateQueue sl rId2 qr2 - Just (Message {msgId = mId3}, True) <- write q2 "message 3" - Just (Message {msgId = mId4}, False) <- write q2 "message 4" - (Msg "message 3", Msg "message 4") <- tryDelPeekMsg ms q2 mId3 - (Msg "message 4", Nothing) <- tryDelPeekMsg ms q2 mId4 - Just (Message {}, True) <- write q2 "message 5" - Just (Message {}, False) <- write q2 "message 6" - Just (Message {}, False) <- write q2 "message 7" - Nothing <- write q2 "message 8" - pure () - length <$> listDirectory (msgQueueDirectory ms rId1) `shouldReturn` 2 - length <$> listDirectory (msgQueueDirectory ms rId2) `shouldReturn` 3 - exportMessages False (StoreJournal ms) testStoreMsgsFile False - closeMsgStore ms - closeStoreLog sl - -- export with closed queues and compare - ms2 <- newMsgStore $ testJournalStoreCfg MQStoreCfg - readWriteQueueStore True (mkQueue ms2 True) testStoreLogFile (stmQueueStore ms2) >>= closeStoreLog - exportMessages False (StoreJournal ms2) (testStoreMsgsFile <> ".copy") False - s <- B.readFile testStoreMsgsFile - B.readFile (testStoreMsgsFile <> ".copy") `shouldReturn` s - - let cfg = (testJournalStoreCfg MQStoreCfg :: JournalStoreConfig 'QSMemory) {storePath = testStoreMsgsDir2} - ms' <- newMsgStore cfg - readWriteQueueStore True (mkQueue ms' True) testStoreLogFile (stmQueueStore ms') >>= closeStoreLog - stats@MessageStats {storedMsgsCount = 5, expiredMsgsCount = 0, storedQueues = 2} <- - importMessages False ms' testStoreMsgsFile Nothing False - printMessageStats "Messages" stats - length <$> listDirectory (msgQueueDirectory ms rId1) `shouldReturn` 2 - length <$> listDirectory (msgQueueDirectory ms rId2) `shouldReturn` 3 -- 2 message files - exportMessages False (StoreJournal ms') testStoreMsgsFile2 False - (B.readFile testStoreMsgsFile2 `shouldReturn`) =<< B.readFile (testStoreMsgsFile <> ".bak") - stmStore <- newMsgStore testSMTStoreConfig - readWriteQueueStore True (mkQueue stmStore True) testStoreLogFile (queueStore stmStore) >>= closeStoreLog - MessageStats {storedMsgsCount = 5, expiredMsgsCount = 0, storedQueues = 2} <- - importMessages False stmStore testStoreMsgsFile2 Nothing False - exportMessages False (StoreMemory stmStore) testStoreMsgsFile False - (B.sort <$> B.readFile testStoreMsgsFile `shouldReturn`) =<< (B.sort <$> B.readFile (testStoreMsgsFile2 <> ".bak")) - #if defined(dbServerPostgres) testUpdateMessageCounts :: PostgresMsgStore -> IO () testUpdateMessageCounts ms = do @@ -455,321 +349,3 @@ testExpireMessagesInBatches ms = do where go n = write q "fill" >>= maybe (pure n) (const $ go (n + 1)) #endif - -testQueueState :: JournalMsgStore s -> IO () -testQueueState ms = do - g <- C.newRandom - rId <- EntityId <$> atomically (C.randomBytes 24 g) - let dir = msgQueueDirectory ms rId - statePath = msgQueueStatePath dir rId - createDirectoryIfMissing True dir - state <- newMsgQueueState <$> newJournalId (random ms) - withFile statePath WriteMode (`appendState` state) - length . lines <$> readFile statePath `shouldReturn` 1 - readQueueState ms statePath `shouldReturn` (Just state, False) - length <$> listDirectory dir `shouldReturn` 1 -- no backup - let state1 = - state - { size = 1, - readState = (readState state) {msgCount = 1, byteCount = 100}, - writeState = (writeState state) {msgPos = 1, msgCount = 1, bytePos = 100, byteCount = 100} - } - withFile statePath AppendMode (`appendState` state1) - length . lines <$> readFile statePath `shouldReturn` 2 - readQueueState ms statePath `shouldReturn` (Just state1, False) - length <$> listDirectory dir `shouldReturn` 1 -- no backup - let state2 = - state - { size = 2, - readState = (readState state) {msgCount = 2, byteCount = 200}, - writeState = (writeState state) {msgPos = 2, msgCount = 2, bytePos = 200, byteCount = 200} - } - withFile statePath AppendMode (`appendState` state2) - length . lines <$> readFile statePath `shouldReturn` 3 - copyFile statePath (statePath <> ".2") - readQueueState ms statePath `shouldReturn` (Just state2, True) - length <$> listDirectory dir `shouldReturn` 2 -- new state + copy - ls <- lines <$> readFile statePath - length ls `shouldBe` 3 - -- mock compacting file - writeFile statePath $ last ls - - -- corrupt the only line - corruptFile statePath - (Nothing, True) <- readQueueState ms statePath - - -- corrupt the last line - renameFile (statePath <> ".2") statePath - removeOtherFiles dir statePath - length . lines <$> readFile statePath `shouldReturn` 3 - corruptFile statePath - readQueueState ms statePath `shouldReturn` (Just state1, True) - length <$> listDirectory dir `shouldReturn` 1 - length . lines <$> readFile statePath `shouldReturn` 3 - where - corruptFile f = do - s <- readFile f - removeFile f - writeFile f $ take (length s - 4) s - removeOtherFiles dir keep = do - names <- listDirectory dir - forM_ names $ \name -> - let f = dir name - in unless (f == keep) $ removeFile f - -testMessageState :: JournalMsgStore s -> IO () -testMessageState ms = do - g <- C.newRandom - (rId, qr) <- testNewQueueRec g QMMessaging - let dir = msgQueueDirectory ms rId - statePath = msgQueueStatePath dir rId - write q s = writeMsg ms q True =<< mkMessage s - - mId1 <- runRight $ do - q <- ExceptT $ addQueue ms rId qr - Just (Message {msgId = mId1}, True) <- write q "message 1" - Just (Message {}, False) <- write q "message 2" - liftIO $ closeMsgQueue ms q - pure mId1 - - ls <- B.lines <$> B.readFile statePath - B.writeFile statePath $ B.unlines $ take (length ls - 1) ls - - runRight_ $ do - q <- ExceptT $ getQueue ms SRecipient rId - Just (Message {msgId = mId3}, False) <- write q "message 3" - (Msg "message 1", Msg "message 3") <- tryDelPeekMsg ms q mId1 - (Msg "message 3", Nothing) <- tryDelPeekMsg ms q mId3 - liftIO $ closeMsgQueue ms q - -testRemoveJournals :: JournalMsgStore s -> IO () -testRemoveJournals ms = do - g <- C.newRandom - (rId, qr) <- testNewQueueRec g QMMessaging - let dir = msgQueueDirectory ms rId - statePath = msgQueueStatePath dir rId - write q s = writeMsg ms q True =<< mkMessage s - - runRight $ do - q <- ExceptT $ addQueue ms rId qr - Just (Message {msgId = mId1}, True) <- write q "message 1" - Just (Message {msgId = mId2}, False) <- write q "message 2" - (Msg "message 1", Msg "message 2") <- tryDelPeekMsg ms q mId1 - (Msg "message 2", Nothing) <- tryDelPeekMsg ms q mId2 - liftIO $ closeMsgQueue ms q - - ls <- B.lines <$> B.readFile statePath - length ls `shouldBe` 4 - journalFilesCount dir `shouldReturn` 1 - stateBackupCount dir `shouldReturn` 0 - - runRight $ do - q <- ExceptT $ getQueue ms SRecipient rId - -- not removed yet - liftIO $ journalFilesCount dir `shouldReturn` 1 - liftIO $ stateBackupCount dir `shouldReturn` 0 - Nothing <- tryPeekMsg ms q - -- still not removed, queue is empty and not opened - liftIO $ journalFilesCount dir `shouldReturn` 1 - _mq <- isolateQueue ms q "test" $ getMsgQueue ms q False - -- journal is removed - liftIO $ journalFilesCount dir `shouldReturn` 0 - liftIO $ stateBackupCount dir `shouldReturn` 1 - Just (Message {msgId = mId3}, True) <- write q "message 3" - -- journal is created - liftIO $ journalFilesCount dir `shouldReturn` 1 - Just (Message {msgId = mId4}, False) <- write q "message 4" - (Msg "message 3", Msg "message 4") <- tryDelPeekMsg ms q mId3 - (Msg "message 4", Nothing) <- tryDelPeekMsg ms q mId4 - Just (Message {msgId = mId5}, True) <- write q "message 5" - Just (Message {msgId = mId6}, False) <- write q "message 6" - liftIO $ journalFilesCount dir `shouldReturn` 1 - Just (Message {msgId = mId7}, False) <- write q "message 7" - -- separate write journal is created - liftIO $ journalFilesCount dir `shouldReturn` 2 - Nothing <- write q "message 8" - (Msg "message 5", Msg "message 6") <- tryDelPeekMsg ms q mId5 - liftIO $ journalFilesCount dir `shouldReturn` 2 - (Msg "message 6", Msg "message 7") <- tryDelPeekMsg ms q mId6 - -- read journal is removed - liftIO $ journalFilesCount dir `shouldReturn` 1 - (Msg "message 7", Just MessageQuota {msgId = mId8}) <- tryDelPeekMsg ms q mId7 - (Just MessageQuota {}, Nothing) <- tryDelPeekMsg ms q mId8 - liftIO $ closeMsgQueue ms q - - journalFilesCount dir `shouldReturn` 1 - runRight $ do - q <- ExceptT $ getQueue ms SRecipient rId - Just (Message {}, True) <- write q "message 8" - liftIO $ journalFilesCount dir `shouldReturn` 1 - liftIO $ stateBackupCount dir `shouldReturn` 2 - liftIO $ closeMsgQueue ms q - where - journalFilesCount dir = length . filter ("messages." `isPrefixOf`) <$> listDirectory dir - stateBackupCount dir = length . filter (".bak" `isSuffixOf`) <$> listDirectory dir - -testRemoveQueueStateBackups :: IO () -testRemoveQueueStateBackups = do - g <- C.newRandom - (rId, qr) <- testNewQueueRec g QMMessaging - - ms' <- newMsgStore (testJournalStoreCfg MQStoreCfg) {maxStateLines = 1, expireBackupsAfter = 0, keepMinBackups = 0} - -- set expiration time 1 second ahead - let ms = ms' {expireBackupsBefore = addUTCTime 1 $ expireBackupsBefore ms'} - - let dir = msgQueueDirectory ms rId - write q s = writeMsg ms q True =<< mkMessage s - - runRight $ do - q <- ExceptT $ addQueue ms rId qr - Just (Message {msgId = mId1}, True) <- write q "message 1" - Just (Message {msgId = mId2}, False) <- write q "message 2" - (Msg "message 1", Msg "message 2") <- tryDelPeekMsg ms q mId1 - (Msg "message 2", Nothing) <- tryDelPeekMsg ms q mId2 - liftIO $ closeMsgQueue ms q - liftIO $ stateBackupCount dir `shouldReturn` 0 - - q1 <- ExceptT $ getQueue ms SRecipient rId - Just (Message {}, True) <- write q1 "message 3" - Just (Message {}, False) <- write q1 "message 4" - liftIO $ closeMsgQueue ms q1 - liftIO $ stateBackupCount dir `shouldReturn` 0 - - liftIO $ threadDelay 1000000 - q2 <- ExceptT $ getQueue ms SRecipient rId - Just (Message {}, False) <- write q2 "message 5" - Nothing <- write q2 "message 5" - liftIO $ closeMsgQueue ms q2 - liftIO $ stateBackupCount dir `shouldReturn` 1 - where - stateBackupCount dir = length . filter (".bak" `isSuffixOf`) <$> listDirectory dir - -testExpireIdleQueues :: IO () -testExpireIdleQueues = do - g <- C.newRandom - (rId, qr) <- testNewQueueRec g QMMessaging - - ms <- newMsgStore (testJournalStoreCfg MQStoreCfg) {idleInterval = 0} - - let dir = msgQueueDirectory ms rId - statePath = msgQueueStatePath dir rId - write q s = writeMsg ms q True =<< mkMessage s - - q <- runRight $ do - q <- ExceptT $ addQueue ms rId qr - Just (Message {msgId = mId1}, True) <- write q "message 1" - Just (Message {msgId = mId2}, False) <- write q "message 2" - (Msg "message 1", Msg "message 2") <- tryDelPeekMsg ms q mId1 - (Msg "message 2", Nothing) <- tryDelPeekMsg ms q mId2 - liftIO $ closeMsgQueue ms q - pure q - - (Just MsgQueueState {size = 0, readState = rs, writeState = ws}, True) <- readQueueState ms statePath - msgCount rs `shouldBe` 2 - msgCount ws `shouldBe` 2 - - old <- expireBeforeEpoch ExpirationConfig {ttl = 1, checkInterval = 1} -- no old messages - now <- systemSeconds <$> getSystemTime - - (expired_, stored) <- runRight $ isolateQueue ms q "" $ withIdleMsgQueue now ms q $ deleteExpireMsgs_ old q - expired_ `shouldBe` Just 0 - stored `shouldBe` 0 - (Nothing, False) <- readQueueState ms statePath - pure () - -testReadFileMissing :: JournalMsgStore s -> IO () -testReadFileMissing ms = do - g <- C.newRandom - (rId, qr) <- testNewQueueRec g QMMessaging - let write q s = writeMsg ms q True =<< mkMessage s - q <- runRight $ do - q <- ExceptT $ addQueue ms rId qr - Just (Message {}, True) <- write q "message 1" - Msg "message 1" <- tryPeekMsg ms q - pure q - - mq <- fromJust <$> readTVarIO (msgQueue' q) - MsgQueueState {readState = rs} <- readTVarIO $ state mq - closeMsgQueue ms q - let path = journalFilePath (queueDirectory $ queue mq) $ journalId rs - removeFile path - - runRight_ $ do - q' <- ExceptT $ getQueue ms SRecipient rId - Nothing <- tryPeekMsg ms q' - Just (Message {}, True) <- write q' "message 2" - Msg "message 2" <- tryPeekMsg ms q' - pure () - -testReadFileMissingSwitch :: JournalMsgStore s -> IO () -testReadFileMissingSwitch ms = do - g <- C.newRandom - (rId, qr) <- testNewQueueRec g QMMessaging - q <- writeMessages ms rId qr - - mq <- fromJust <$> readTVarIO (msgQueue' q) - MsgQueueState {readState = rs} <- readTVarIO $ state mq - closeMsgQueue ms q - let path = journalFilePath (queueDirectory $ queue mq) $ journalId rs - removeFile path - - runRight_ $ do - q' <- ExceptT $ getQueue ms SRecipient rId - Just (Message {}, False) <- writeMsg ms q' True =<< mkMessage "message 6" - Msg "message 5" <- tryPeekMsg ms q' - pure () - -testWriteFileMissing :: JournalMsgStore s -> IO () -testWriteFileMissing ms = do - g <- C.newRandom - (rId, qr) <- testNewQueueRec g QMMessaging - q <- writeMessages ms rId qr - - mq <- fromJust <$> readTVarIO (msgQueue' q) - MsgQueueState {writeState = ws} <- readTVarIO $ state mq - closeMsgQueue ms q - let path = journalFilePath (queueDirectory $ queue mq) $ journalId ws - print path - removeFile path - - runRight_ $ do - q' <- ExceptT $ getQueue ms SRecipient rId - Just Message {msgId = mId3} <- tryPeekMsg ms q' - (Msg "message 3", Msg "message 4") <- tryDelPeekMsg ms q' mId3 - Just Message {msgId = mId4} <- tryPeekMsg ms q' - (Msg "message 4", Nothing) <- tryDelPeekMsg ms q' mId4 - Just (Message {}, True) <- writeMsg ms q' True =<< mkMessage "message 6" - Msg "message 6" <- tryPeekMsg ms q' - pure () - -testReadAndWriteFilesMissing :: JournalMsgStore s -> IO () -testReadAndWriteFilesMissing ms = do - g <- C.newRandom - (rId, qr) <- testNewQueueRec g QMMessaging - q <- writeMessages ms rId qr - - mq <- fromJust <$> readTVarIO (msgQueue' q) - MsgQueueState {readState = rs, writeState = ws} <- readTVarIO $ state mq - closeMsgQueue ms q - removeFile $ journalFilePath (queueDirectory $ queue mq) $ journalId rs - removeFile $ journalFilePath (queueDirectory $ queue mq) $ journalId ws - - runRight_ $ do - q' <- ExceptT $ getQueue ms SRecipient rId - Nothing <- tryPeekMsg ms q' - Just (Message {}, True) <- writeMsg ms q' True =<< mkMessage "message 6" - Msg "message 6" <- tryPeekMsg ms q' - pure () - -writeMessages :: JournalMsgStore s -> RecipientId -> QueueRec -> IO (JournalQueue s) -writeMessages ms rId qr = runRight $ do - q <- ExceptT $ addQueue ms rId qr - let write s = writeMsg ms q True =<< mkMessage s - Just (Message {msgId = mId1}, True) <- write "message 1" - Just (Message {msgId = mId2}, False) <- write "message 2" - Just (Message {}, False) <- write "message 3" - (Msg "message 1", Msg "message 2") <- tryDelPeekMsg ms q mId1 - (Msg "message 2", Msg "message 3") <- tryDelPeekMsg ms q mId2 - Just (Message {}, False) <- write "message 4" - Just (Message {}, False) <- write "message 5" - pure q diff --git a/tests/CoreTests/StoreLogTests.hs b/tests/CoreTests/StoreLogTests.hs index 81a0535d54..ccbcc80421 100644 --- a/tests/CoreTests/StoreLogTests.hs +++ b/tests/CoreTests/StoreLogTests.hs @@ -28,7 +28,7 @@ import Simplex.Messaging.Encoding.String import Simplex.Messaging.Protocol import Simplex.Messaging.Protocol.Types (ClientNotice (..)) import Simplex.Messaging.Server.Env.STM (readWriteQueueStore) -import Simplex.Messaging.Server.MsgStore.Journal +import Simplex.Messaging.Server.MsgStore.STM (STMMsgStore (..)) import Simplex.Messaging.Server.MsgStore.Types import Simplex.Messaging.Server.QueueStore import Simplex.Messaging.Server.QueueStore.STM (STMQueueStore (..)) @@ -177,10 +177,10 @@ testSMPStoreLog testSuite tests = closeStoreLog l replicateM_ 3 $ testReadWrite t #if defined(dbServerPostgres) - (sCnt, qCnt) <- importStoreLogToDatabase "tests/tmp/" testStoreLogFile testStoreDBOpts + (sCnt, qCnt) <- importStoreLogToDatabase testStoreLogFile testStoreDBOpts fromIntegral (sCnt + qCnt) `shouldBe` length (compacted t) imported <- B.readFile $ testStoreLogFile <> ".bak" - (sCnt', qCnt') <- exportDatabaseToStoreLog "tests/tmp/" testStoreDBOpts testStoreLogFile + (sCnt', qCnt') <- exportDatabaseToStoreLog testStoreDBOpts testStoreLogFile sCnt' `shouldBe` fromIntegral sCnt qCnt' `shouldBe` fromIntegral qCnt exported <- B.readFile testStoreLogFile @@ -188,14 +188,14 @@ testSMPStoreLog testSuite tests = #endif where testReadWrite SLTC {compacted, state} = do - st <- newMsgStore $ testJournalStoreCfg MQStoreCfg - l <- readWriteQueueStore True (mkQueue st True) testStoreLogFile $ stmQueueStore st + st <- newMsgStore testSMTStoreConfig + l <- readWriteQueueStore True (mkQueue st True) testStoreLogFile $ queueStore st storeState st `shouldReturn` state closeStoreLog l ([], compacted') <- partitionEithers . map strDecode . B.lines <$> B.readFile testStoreLogFile compacted' `shouldBe` compacted - storeState :: JournalMsgStore 'QSMemory -> IO (M.Map RecipientId QueueRec) - storeState st = M.mapMaybe id <$> (readTVarIO (queues $ stmQueueStore st) >>= mapM (readTVarIO . queueRec)) + storeState :: STMMsgStore -> IO (M.Map RecipientId QueueRec) + storeState st = M.mapMaybe id <$> (readTVarIO (queues $ queueStore st) >>= mapM (readTVarIO . queueRec)) type FileRecState = (FileInfo, RoundedFileTime, Maybe RoundedFileTime, ServerEntityStatus) diff --git a/tests/NamesResolverServer.hs b/tests/NamesResolverServer.hs index 054d55e404..d44e38f5f0 100644 --- a/tests/NamesResolverServer.hs +++ b/tests/NamesResolverServer.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} @@ -77,7 +78,9 @@ memCfg2 = case memCfg of newStoreCfg :: ServerStoreCfg s -> ServerStoreCfg s newStoreCfg = \case SSCMemory _ -> SSCMemory (Just StorePaths {storeLogFile = testStoreLogFile2, storeMsgsFile = Just testStoreMsgsFile2}) +#if defined(dbServerPostgres) other -> other +#endif withNames :: Int -> AServerConfig -> AServerConfig withNames port c = updateCfg c $ \cfg_ -> cfg_ {namesConfig = Just (testNamesConfig port)} diff --git a/tests/SMPClient.hs b/tests/SMPClient.hs index 2db4a98196..27b8e03df0 100644 --- a/tests/SMPClient.hs +++ b/tests/SMPClient.hs @@ -33,7 +33,6 @@ import Simplex.Messaging.Protocol import Simplex.Messaging.Server (runSMPServerBlocking) import Simplex.Messaging.Server.Env.STM import Simplex.Messaging.Server.MsgStore.Types (MsgStoreClass (..), SMSType (..), SQSType (..)) -import Simplex.Messaging.Server.QueueStore.Postgres.Config (PostgresStoreCfg (..)) import Simplex.Messaging.Transport import Simplex.Messaging.Transport.Client import Simplex.Messaging.Transport.Server @@ -51,6 +50,7 @@ import Util #if defined(dbServerPostgres) import Database.PostgreSQL.Simple (defaultConnectInfo) +import Simplex.Messaging.Server.QueueStore.Postgres.Config (PostgresStoreCfg (..)) #endif #if defined(dbPostgres) || defined(dbServerPostgres) @@ -123,12 +123,6 @@ testStoreMsgsFile = "tests/tmp/smp-server-messages.log" testStoreMsgsFile2 :: FilePath testStoreMsgsFile2 = "tests/tmp/smp-server-messages.log.2" -testStoreMsgsDir :: FilePath -testStoreMsgsDir = "tests/tmp/messages" - -testStoreMsgsDir2 :: FilePath -testStoreMsgsDir2 = "tests/tmp/messages.2" - testStoreNtfsFile :: FilePath testStoreNtfsFile = "tests/tmp/smp-server-ntfs.log" @@ -212,24 +206,35 @@ ntfTestServerCredentials = } cfg :: AServerConfig -cfg = cfgMS (ASType SQSMemory SMSJournal) +cfg = cfgMS (ASType SQSMemory SMSMemory) -cfgJ2 :: AServerConfig -cfgJ2 = journalCfg cfg testStoreLogFile2 testStoreMsgsDir2 +cfgS2 :: AServerConfig +cfgS2 = memoryCfg cfg testStoreLogFile2 testStoreMsgsFile2 -cfgJ2QS :: SQSType s -> AServerConfig -cfgJ2QS = \case - SQSMemory -> journalCfg (cfgMS $ ASType SQSMemory SMSJournal) testStoreLogFile2 testStoreMsgsDir2 - SQSPostgres -> journalCfgDB (cfgMS $ ASType SQSPostgres SMSJournal) testStoreDBOpts2 testStoreMsgsDir2 +cfgS2QS :: SQSType s -> AServerConfig +cfgS2QS = \case + SQSMemory -> memoryCfg (cfgMS $ ASType SQSMemory SMSMemory) testStoreLogFile2 testStoreMsgsFile2 + SQSPostgres -> databaseCfg (cfgMS postgresStoreType) testStoreDBOpts2 -journalCfg :: AServerConfig -> FilePath -> FilePath -> AServerConfig -journalCfg (ASrvCfg _ _ cfg') storeLogFile storeMsgsPath = - ASrvCfg SQSMemory SMSJournal cfg' {serverStoreCfg = SSCMemoryJournal {storeLogFile, storeMsgsPath}} +memoryCfg :: AServerConfig -> FilePath -> FilePath -> AServerConfig +memoryCfg (ASrvCfg _ _ cfg') storeLogFile storeMsgsFile = + ASrvCfg SQSMemory SMSMemory cfg' {serverStoreCfg = SSCMemory $ Just StorePaths {storeLogFile, storeMsgsFile = Just storeMsgsFile}} -journalCfgDB :: AServerConfig -> DBOpts -> FilePath -> AServerConfig -journalCfgDB (ASrvCfg _ _ cfg') dbOpts storeMsgsPath' = +databaseCfg :: AServerConfig -> DBOpts -> AServerConfig +#if defined(dbServerPostgres) +databaseCfg (ASrvCfg _ _ cfg') dbOpts = let storeCfg = PostgresStoreCfg {dbOpts, dbStoreLogPath = Nothing, confirmMigrations = MCYesUp, deletedTTL = 86400} - in ASrvCfg SQSPostgres SMSJournal cfg' {serverStoreCfg = SSCDatabaseJournal {storeCfg, storeMsgsPath'}} + in ASrvCfg SQSPostgres SMSPostgres cfg' {serverStoreCfg = SSCDatabase storeCfg} +#else +databaseCfg _ _ = error "no dbServerPostgres flag" +#endif + +postgresStoreType :: AStoreType +#if defined(dbServerPostgres) +postgresStoreType = ASType SQSPostgres SMSPostgres +#else +postgresStoreType = error "no dbServerPostgres flag" +#endif cfgMS :: AStoreType -> AServerConfig cfgMS msType = withStoreCfg (testServerStoreConfig msType) $ \serverStoreCfg -> @@ -238,8 +243,6 @@ cfgMS msType = withStoreCfg (testServerStoreConfig msType) $ \serverStoreCfg -> smpHandshakeTimeout = 60000000, tbqSize = 4, msgQueueQuota = 4, - maxJournalMsgCount = 5, - maxJournalStateLines = 2, queueIdBytes = 24, msgIdBytes = 24, serverStoreCfg, @@ -252,7 +255,6 @@ cfgMS msType = withStoreCfg (testServerStoreConfig msType) $ \serverStoreCfg -> messageExpiration = Just defaultMessageExpiration, expireMessagesOnStart = True, expireMessagesOnSend = False, - idleQueueInterval = defaultIdleQueueInterval, notificationExpiration = defaultNtfExpiration, inactiveClientExpiration = Just defaultInactiveClientExpiration, logStatsInterval = Nothing, @@ -293,20 +295,22 @@ testServerStoreConfig :: AStoreType -> AServerStoreCfg testServerStoreConfig = serverStoreConfig_ False serverStoreConfig_ :: Bool -> AStoreType -> AServerStoreCfg +#if defined(dbServerPostgres) serverStoreConfig_ useDbStoreLog = \case +#else +serverStoreConfig_ _ = \case +#endif ASType SQSMemory SMSMemory -> ASSCfg SQSMemory SMSMemory $ SSCMemory $ Just StorePaths {storeLogFile = testStoreLogFile, storeMsgsFile = Just testStoreMsgsFile} - ASType SQSMemory SMSJournal -> - ASSCfg SQSMemory SMSJournal $ SSCMemoryJournal {storeLogFile = testStoreLogFile, storeMsgsPath = testStoreMsgsDir} - ASType SQSPostgres SMSJournal -> - ASSCfg SQSPostgres SMSJournal SSCDatabaseJournal {storeCfg, storeMsgsPath' = testStoreMsgsDir} #if defined(dbServerPostgres) ASType SQSPostgres SMSPostgres -> ASSCfg SQSPostgres SMSPostgres $ SSCDatabase storeCfg -#endif where dbStoreLogPath = if useDbStoreLog then Just testStoreLogFile else Nothing storeCfg = PostgresStoreCfg {dbOpts = testStoreDBOpts, dbStoreLogPath, confirmMigrations = MCYesUp, deletedTTL = 86400} +#else + ASType SQSPostgres _ -> error "no dbServerPostgres flag" +#endif cfgVPrev :: AStoreType -> AServerConfig cfgVPrev msType = updateCfg (cfgMS msType) $ \cfg' -> cfg' {smpServerVRange = prevRange $ smpServerVRange cfg'} @@ -321,7 +325,7 @@ nextVersion :: Version v -> Version v nextVersion (Version v) = Version (v + 1) proxyCfg :: AServerConfig -proxyCfg = proxyCfgMS (ASType SQSMemory SMSJournal) +proxyCfg = proxyCfgMS (ASType SQSMemory SMSMemory) proxyCfgMS :: AStoreType -> AServerConfig proxyCfgMS msType = @@ -332,13 +336,13 @@ proxyCfgMS msType = smpAgentCfg = smpAgentCfg' {smpCfg = (smpCfg smpAgentCfg') {agreeSecret = True, proxyServer = True, serverVRange = supportedProxyClientSMPRelayVRange}} } -proxyCfgJ2 :: AServerConfig -proxyCfgJ2 = journalCfg proxyCfg testStoreLogFile2 testStoreMsgsDir2 +proxyCfgS2 :: AServerConfig +proxyCfgS2 = memoryCfg proxyCfg testStoreLogFile2 testStoreMsgsFile2 -proxyCfgJ2QS :: SQSType qs -> AServerConfig -proxyCfgJ2QS = \case - SQSMemory -> journalCfg (proxyCfgMS $ ASType SQSMemory SMSJournal) testStoreLogFile2 testStoreMsgsDir2 - SQSPostgres -> journalCfgDB (proxyCfgMS $ ASType SQSPostgres SMSJournal) testStoreDBOpts2 testStoreMsgsDir2 +proxyCfgS2QS :: SQSType qs -> AServerConfig +proxyCfgS2QS = \case + SQSMemory -> memoryCfg (proxyCfgMS $ ASType SQSMemory SMSMemory) testStoreLogFile2 testStoreMsgsFile2 + SQSPostgres -> databaseCfg (proxyCfgMS postgresStoreType) testStoreDBOpts2 -- Proxy config with a short relay-connection timeout, to bound how long a failing -- proxy->relay connection attempt blocks in the relay reconnection tests. @@ -420,10 +424,10 @@ withSmpServerProxy :: HasCallStack => (ASrvTransport, AStoreType) -> IO a -> IO withSmpServerProxy (t, msType) = withSmpServerConfigOn t (proxyCfgMS msType) testPort . const withSmpServers2 :: HasCallStack => (ASrvTransport, AStoreType) -> IO a -> IO a -withSmpServers2 ps@(t, ASType qs _ms) = withSmpServer ps . withSmpServerConfigOn t (cfgJ2QS qs) testPort2 . const +withSmpServers2 ps@(t, ASType qs _ms) = withSmpServer ps . withSmpServerConfigOn t (cfgS2QS qs) testPort2 . const withSmpServersProxy2 :: HasCallStack => (ASrvTransport, AStoreType) -> IO a -> IO a -withSmpServersProxy2 ps@(t, ASType qs _ms) = withSmpServerProxy ps . withSmpServerConfigOn t (proxyCfgJ2QS qs) testPort2 . const +withSmpServersProxy2 ps@(t, ASType qs _ms) = withSmpServerProxy ps . withSmpServerConfigOn t (proxyCfgS2QS qs) testPort2 . const runSmpTest :: forall c a. (HasCallStack, Transport c) => AStoreType -> (HasCallStack => THandleSMP c 'TClient -> IO a) -> IO a runSmpTest msType test = withSmpServerConfigOn (transport @c) (cfgMS msType) testPort $ \_ -> testSMPClient test @@ -444,7 +448,7 @@ smpServerTest :: TProxy c 'TServer -> (Maybe TAuthorizations, ByteString, ByteString, smp) -> IO (Maybe TAuthorizations, ByteString, ByteString, BrokerMsg) -smpServerTest _ t = runSmpTest (ASType SQSMemory SMSJournal) $ \h -> tPut' h t >> tGet' h +smpServerTest _ t = runSmpTest (ASType SQSMemory SMSMemory) $ \h -> tPut' h t >> tGet' h where tPut' :: THandleSMP c 'TClient -> (Maybe TAuthorizations, ByteString, ByteString, smp) -> IO () tPut' h@THandle {params = THandleParams {sessionId, implySessId}} (sig, corrId, queueId, smp) = do diff --git a/tests/SMPProxyTests.hs b/tests/SMPProxyTests.hs index 62bb4a85e2..7288213cf6 100644 --- a/tests/SMPProxyTests.hs +++ b/tests/SMPProxyTests.hs @@ -161,11 +161,11 @@ smpProxyTests = do let deliver nAgents nMsgs = agentDeliverMessagesViaProxyConc (replicate nAgents [srv1]) (map bshow [1 :: Int .. nMsgs]) it "25 agents, 300 pairs, 17 messages" . oneServer . withNumCapabilities 4 $ deliver 25 17 where - oneServer test msType = withSmpServerConfigOn (transport @TLS) (updateCfg (proxyCfgMS msType) $ \cfg_ -> cfg_ {msgQueueQuota = 128, maxJournalMsgCount = 256}) testPort $ const test + oneServer test msType = withSmpServerConfigOn (transport @TLS) (updateCfg (proxyCfgMS msType) $ \cfg_ -> cfg_ {msgQueueQuota = 128}) testPort $ const test twoServers test msType = twoServers_ (proxyCfgMS msType) (proxyCfgMS msType) test msType - twoServersFirstProxy test msType = twoServers_ (proxyCfgMS msType) (updateCfg (cfgMS msType) $ \cfg_ -> cfg_ {msgQueueQuota = 128, maxJournalMsgCount = 256}) test msType - twoServersMoreConc test msType = twoServers_ (updateCfg (proxyCfgMS msType) $ \cfg_ -> cfg_ {serverClientConcurrency = 128}) (updateCfg (cfgMS msType) $ \cfg_ -> cfg_ {msgQueueQuota = 128, maxJournalMsgCount = 256}) test msType - twoServersNoConc test msType = twoServers_ (updateCfg (proxyCfgMS msType) $ \cfg_ -> cfg_ {serverClientConcurrency = 1}) (updateCfg (cfgMS msType) $ \cfg_ -> cfg_ {msgQueueQuota = 128, maxJournalMsgCount = 256}) test msType + twoServersFirstProxy test msType = twoServers_ (proxyCfgMS msType) (updateCfg (cfgMS msType) $ \cfg_ -> cfg_ {msgQueueQuota = 128}) test msType + twoServersMoreConc test msType = twoServers_ (updateCfg (proxyCfgMS msType) $ \cfg_ -> cfg_ {serverClientConcurrency = 128}) (updateCfg (cfgMS msType) $ \cfg_ -> cfg_ {msgQueueQuota = 128}) test msType + twoServersNoConc test msType = twoServers_ (updateCfg (proxyCfgMS msType) $ \cfg_ -> cfg_ {serverClientConcurrency = 1}) (updateCfg (cfgMS msType) $ \cfg_ -> cfg_ {msgQueueQuota = 128}) test msType twoServersPrevProxy test msType = twoServers_ (proxyCfgVPrev msType) (cfgMS msType) test msType twoServersPrevRelay test msType = twoServers_ (proxyCfgMS msType) (prevServerVRange $ cfgMS msType) test msType prevServerVRange cfg' = updateCfg cfg' $ \cfg_ -> cfg_ {smpServerVRange = prevRange $ smpServerVRange cfg_} @@ -173,8 +173,8 @@ smpProxyTests = do twoServers_ cfg1 cfg2 runTest (ASType qsType _) = withSmpServerConfigOn (transport @TLS) cfg1 testPort $ \_ -> let cfg2' = case qsType of - SQSMemory -> journalCfg cfg2 testStoreLogFile2 testStoreMsgsDir2 - SQSPostgres -> journalCfgDB cfg2 testStoreDBOpts2 testStoreMsgsDir2 + SQSMemory -> memoryCfg cfg2 testStoreLogFile2 testStoreMsgsFile2 + SQSPostgres -> databaseCfg cfg2 testStoreDBOpts2 in withSmpServerConfigOn (transport @TLS) cfg2' testPort2 $ const runTest deliverMessageViaProxy :: (C.AlgorithmI a, C.AuthAlgorithm a) => SMPServer -> SMPServer -> C.SAlgorithm a -> ByteString -> ByteString -> IO () @@ -405,15 +405,15 @@ agentViaProxyRetryOffline = do ackMessage alice bobId (baseId + 4) Nothing where withServer :: (ThreadId -> IO a) -> IO a - withServer = withServer_ testStoreLogFile testStoreMsgsDir testStoreNtfsFile testPort + withServer = withServer_ testStoreLogFile testStoreMsgsFile testStoreNtfsFile testPort -- TODO [postgres] -- withServer = withServer_ testStoreDBOpts testStoreMsgsDir testStoreNtfsFile testPort withServer2 :: (ThreadId -> IO a) -> IO a - withServer2 = withServer_ testStoreLogFile2 testStoreMsgsDir2 testStoreNtfsFile2 testPort2 + withServer2 = withServer_ testStoreLogFile2 testStoreMsgsFile2 testStoreNtfsFile2 testPort2 -- TODO [postgres] -- withServer2 = withServer_ testStoreDBOpts2 testStoreMsgsDir2 testStoreNtfsFile2 testPort2 withServer_ storeLog storeMsgs storeNtfs = - let cfg' = updateCfg (journalCfg proxyCfg storeLog storeMsgs) $ \cfg_ -> cfg_ {storeNtfsFile = Just storeNtfs} + let cfg' = updateCfg (memoryCfg proxyCfg storeLog storeMsgs) $ \cfg_ -> cfg_ {storeNtfsFile = Just storeNtfs} in withSmpServerConfigOn (transport @TLS) cfg' a `up` cId = nGet a =##> \case ("", "", UP _ [c]) -> c == cId; _ -> False a `down` cId = nGet a =##> \case ("", "", DOWN _ [c]) -> c == cId; _ -> False @@ -439,7 +439,7 @@ agentViaProxyRetryNoSession = do _ <- runRight $ makeConnection b a pure () where - withServer2 = withSmpServerConfigOn (transport @TLS) proxyCfgJ2 testPort2 + withServer2 = withSmpServerConfigOn (transport @TLS) proxyCfgS2 testPort2 servers srv = initAgentServersProxy {smp = userServers [srv]} testNoProxy :: AStoreType -> IO () @@ -483,7 +483,7 @@ testChangedFwdVersion = testFwdCorrIdSize :: IO () testFwdCorrIdSize = withSmpServerConfigOn (transport @TLS) proxyCfg testPort $ \_ -> - withSmpServerConfigOn (transport @TLS) cfgJ2 testPort2 $ \_ -> + withSmpServerConfigOn (transport @TLS) cfgS2 testPort2 $ \_ -> testSMPClient_ "localhost" testPort supportedServerSMPRelayVRange Nothing $ \(th :: THandleSMP TLS 'TClient) -> do (_, _, Right (SMP.PKEY sessId _ _)) <- sendRecv th (Nothing, "1", NoEntity, SMP.PRXY testSMPServer2 Nothing) g <- C.newRandom @@ -495,7 +495,7 @@ testFwdCorrIdSize = testForwardedAuthErrorDelay :: IO () testForwardedAuthErrorDelay = withSmpServerConfigOn (transport @TLS) proxyCfg testPort $ \_ -> - withSmpServerConfigOn (transport @TLS) (updateCfg cfgJ2 $ \cfg_ -> cfg_ {authErrorDelay = 500000}) testPort2 $ \_ -> do + withSmpServerConfigOn (transport @TLS) (updateCfg cfgS2 $ \cfg_ -> cfg_ {authErrorDelay = 500000}) testPort2 $ \_ -> do g <- C.newRandom ts <- getCurrentTime pc <- either (fail . show) pure =<< getProtocolClient g NRMInteractive (1, testSMPServer, Nothing) defaultSMPClientConfig [] Nothing ts (\_ -> pure ()) @@ -510,7 +510,7 @@ testForwardedAuthErrorDelay = -- let any stored connection error expire, then require the proxy to establish the session (PKEY). requireProxyReconnect :: IO () requireProxyReconnect = - withSmpServerConfigOn (transport @TLS) proxyCfgJ2 testPort2 $ \_ -> do + withSmpServerConfigOn (transport @TLS) proxyCfgS2 testPort2 $ \_ -> do testSMPClient_ "127.0.0.1" testPort2 supportedServerSMPRelayVRange Nothing $ \(th :: THandleSMP TLS 'TClient) -> do (_, _, reply) <- sendRecv th (Nothing, "0", NoEntity, SMP.PING) reply `shouldBe` Right SMP.PONG @@ -566,7 +566,7 @@ testAgentClientReconnectAfterCancel = t <- async $ runExceptT $ A.createConnection a NRMInteractive 1 True True SCMInvitation Nothing Nothing CR.IKPQOn False SMSubscribe threadDelay 1000000 -- let the connect to the stalling relay start, then kill it mid-flight cancel t - withSmpServerConfigOn (transport @TLS) cfgJ2 testPort2 $ \_ -> do + withSmpServerConfigOn (transport @TLS) cfgS2 testPort2 $ \_ -> do testSMPClient_ "127.0.0.1" testPort2 supportedServerSMPRelayVRange Nothing $ \(th :: THandleSMP TLS 'TClient) -> do (_, _, reply) <- sendRecv th (Nothing, "0", NoEntity, SMP.PING) reply `shouldBe` Right SMP.PONG -- the relay is up and reachable, so a timeout can only be the poisoned var diff --git a/tests/ServerTests.hs b/tests/ServerTests.hs index aff1fdbe0c..e6d0e57944 100644 --- a/tests/ServerTests.hs +++ b/tests/ServerTests.hs @@ -24,7 +24,6 @@ import Control.Concurrent.STM import Control.Exception (SomeException, throwIO, try) import Control.Monad import Control.Monad.IO.Class -import CoreTests.MsgStoreTests (testJournalStoreCfg) import Data.Bifunctor (first) import qualified Data.ByteString.Base64 as B64 import Data.ByteString.Char8 (ByteString) @@ -47,17 +46,14 @@ import Simplex.Messaging.Encoding import Simplex.Messaging.Encoding.String import Simplex.Messaging.Parsers (parseAll, parseString) import Simplex.Messaging.Protocol -import Simplex.Messaging.Server (exportMessages) -import Simplex.Messaging.Server.Env.STM (AStoreType (..), MsgStore (..), ServerConfig (..), ServerStoreCfg (..), readWriteQueueStore) +import Simplex.Messaging.Server.Env.STM (AStoreType (..), ServerConfig (..), ServerStoreCfg (..)) import Simplex.Messaging.Server.Expiration -import Simplex.Messaging.Server.MsgStore.Journal (JournalStoreConfig (..), QStoreCfg (..), stmQueueStore) -import Simplex.Messaging.Server.MsgStore.Types (MsgStoreClass (..), QSType (..), SMSType (..), SQSType (..), newMsgStore) +import Simplex.Messaging.Server.MsgStore.Types (SMSType (..), SQSType (..)) import Simplex.Messaging.Server.Stats (PeriodStatsData (..), ServerStatsData (..)) -import Simplex.Messaging.Server.StoreLog (StoreLogRecord (..), closeStoreLog) +import Simplex.Messaging.Server.StoreLog (StoreLogRecord (..)) import Simplex.Messaging.Transport import Simplex.Messaging.Transport.Credentials -import Simplex.Messaging.Util (whenM) -import System.Directory (doesDirectoryExist, doesFileExist, removeDirectoryRecursive, removeFile) +import System.Directory (doesFileExist, removeFile) import System.IO (IOMode (..), withFile) import System.Timeout import Test.HUnit @@ -65,8 +61,11 @@ import Test.Hspec hiding (fit, it) import Util #if defined(dbServerPostgres) -import CoreTests.MsgStoreTests (testPostgresStoreConfig) +import CoreTests.MsgStoreTests (testPostgresStoreConfig, testSMTStoreConfig) +import Simplex.Messaging.Server.Env.STM (readWriteQueueStore) import Simplex.Messaging.Server.MsgStore.Postgres (PostgresMsgStoreCfg (..), exportDbMessages) +import Simplex.Messaging.Server.MsgStore.Types (MsgStoreClass (..), newMsgStore) +import Simplex.Messaging.Server.StoreLog (closeStoreLog) #endif serverTests :: SpecWith (ASrvTransport, AStoreType) @@ -1069,7 +1068,6 @@ testRestoreMessages = it "should store messages on exit and restore on start" $ \(at@(ATransport t), msType) -> do removeFileIfExists testStoreLogFile removeFileIfExists testStoreMsgsFile - whenM (doesDirectoryExist testStoreMsgsDir) $ removeDirectoryRecursive testStoreMsgsDir removeFileIfExists testServerStatsBackupFile g <- C.newRandom @@ -1139,7 +1137,6 @@ testRestoreMessages = Right stats3 <- strDecode <$> B.readFile testServerStatsBackupFile checkStats stats3 [rId] 5 5 removeFileIfExists testStoreMsgsFile - whenM (doesDirectoryExist testStoreMsgsDir) $ removeDirectoryRecursive testStoreMsgsDir removeFile testServerStatsBackupFile where runTest :: Transport c => TProxy c 'TServer -> (THandleSMP c 'TClient -> IO ()) -> ThreadId -> Expectation @@ -1219,28 +1216,23 @@ testRestoreExpireMessages = where exportStoreMessages :: AStoreType -> IO () exportStoreMessages = \case - ASType _ SMSJournal -> export ASType _ SMSPostgres -> exportDB ASType _ SMSMemory -> pure () where - export = do - ms <- readWriteQueues - exportMessages False (StoreJournal ms) testStoreMsgsFile False - closeMsgStore ms #if defined(dbServerPostgres) exportDB = do readWriteQueues >>= closeMsgStore ms' <- newMsgStore (testPostgresStoreConfig {quota = 4} :: PostgresMsgStoreCfg) _n <- withFile testStoreMsgsFile WriteMode $ exportDbMessages False ms' closeMsgStore ms' -#else - exportDB = error "compiled without server_postgres flag" -#endif readWriteQueues = do - ms <- newMsgStore ((testJournalStoreCfg MQStoreCfg) {quota = 4} :: JournalStoreConfig 'QSMemory) - readWriteQueueStore True (mkQueue ms True) testStoreLogFile (stmQueueStore ms) >>= closeStoreLog + ms <- newMsgStore testSMTStoreConfig + readWriteQueueStore True (mkQueue ms True) testStoreLogFile (queueStore ms) >>= closeStoreLog removeFileIfExists testStoreMsgsFile pure ms +#else + exportDB = error "compiled without server_postgres flag" +#endif runTest :: Transport c => TProxy c 'TServer -> (THandleSMP c 'TClient -> IO ()) -> ThreadId -> Expectation runTest _ test' server = do testSMPClient test' `shouldReturn` () @@ -1577,7 +1569,7 @@ testMsgExpireOnInterval = it "should expire messages that are not received before messageTTL after expiry interval" $ \(ATransport (t :: TProxy c 'TServer), msType) -> do g <- C.newRandom (sPub, sKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g - let cfg' = updateCfg (cfgMS msType) $ \cfg_ -> cfg_ {messageExpiration = Just ExpirationConfig {ttl = 1, checkInterval = 1}, idleQueueInterval = 1} + let cfg' = updateCfg (cfgMS msType) $ \cfg_ -> cfg_ {messageExpiration = Just ExpirationConfig {ttl = 1, checkInterval = 1}} withSmpServerConfigOn (ATransport t) cfg' testPort $ \_ -> testSMPClient @c $ \sh -> do (sId, rId, rKey, _) <- testSMPClient @c $ \rh -> createAndSecureQueue rh sPub diff --git a/tests/Test.hs b/tests/Test.hs index 16375bcc60..ff6b1c3a2d 100644 --- a/tests/Test.hs +++ b/tests/Test.hs @@ -115,19 +115,15 @@ main = do testStoreDBOpts "src/Simplex/Messaging/Server/QueueStore/Postgres/server_schema.sql" around_ (postgressBracket testServerDBConnectInfo) $ do - -- xdescribe "SMP server via TLS, postgres+jornal message store" $ - -- before (pure (transport @TLS, ASType SQSPostgres SMSJournal)) serverTests describe "SMP server via TLS, postgres-only message store" $ before (pure (transport @TLS, ASType SQSPostgres SMSPostgres)) serverTests #endif - describe "SMP server via TLS, jornal message store" $ do + describe "SMP server via TLS, memory message store" $ do describe "SMP syntax" $ serverSyntaxTests (transport @TLS) - before (pure (transport @TLS, ASType SQSMemory SMSJournal)) serverTests - describe "SMP server via TLS, memory message store" $ before (pure (transport @TLS, ASType SQSMemory SMSMemory)) serverTests -- xdescribe "SMP server via WebSockets" $ do -- describe "SMP syntax" $ serverSyntaxTests (transport @WS) - -- before (pure (transport @WS, ASType SQSMemory SMSJournal)) serverTests + -- before (pure (transport @WS, ASType SQSMemory SMSMemory)) serverTests #if defined(dbServerPostgres) around_ (postgressBracket ntfTestServerDBConnectInfo) $ describe "Ntf server schema dump" $ @@ -140,22 +136,16 @@ main = do describe "Notifications server (SMP server: memory store)" $ ntfServerTests (transport @TLS, ASType SQSMemory SMSMemory) around_ (postgressBracket testServerDBConnectInfo) $ do - -- xdescribe "Notifications server (SMP server: postgres+jornal store)" $ - -- ntfServerTests (transport @TLS, ASType SQSPostgres SMSJournal) describe "Notifications server (SMP server: postgres-only store)" $ ntfServerTests (transport @TLS, ASType SQSPostgres SMSPostgres) around_ (postgressBracket testServerDBConnectInfo) $ do - -- xdescribe "SMP client agent, postgres+jornal message store" $ agentTests (transport @TLS, ASType SQSPostgres SMSJournal) describe "SMP client agent, server postgres-only message store" $ agentTests (transport @TLS, ASType SQSPostgres SMSPostgres) - -- xdescribe "SMP proxy, postgres+jornal message store" $ - -- before (pure $ ASType SQSPostgres SMSJournal) smpProxyTests describe "SMP proxy, postgres-only message store" $ before (pure $ ASType SQSPostgres SMSPostgres) smpProxyTests #endif - -- xdescribe "SMP client agent, server jornal message store" $ agentTests (transport @TLS, ASType SQSMemory SMSJournal) describe "SMP client agent, server memory message store" $ agentTests (transport @TLS, ASType SQSMemory SMSMemory) - describe "SMP proxy, jornal message store" $ - before (pure $ ASType SQSMemory SMSJournal) smpProxyTests + describe "SMP proxy, memory message store" $ + before (pure $ ASType SQSMemory SMSMemory) smpProxyTests describe "XFTP" $ do describe "XFTP server" $ before (pure $ AFSType SFSMemory) xftpServerTests