From 2c3641f97a1ca03457fcf1ff4960771dbeaa2d12 Mon Sep 17 00:00:00 2001 From: shum Date: Mon, 5 Oct 2026 07:44:32 +0000 Subject: [PATCH] smp-server: remove journal message store --- docs/smp-server-db-load.md | 4 +- simplexmq.cabal | 2 - src/Simplex/Messaging/Agent/Client.hs | 1 - src/Simplex/Messaging/Agent/Lock.hs | 1 - src/Simplex/Messaging/Server.hs | 95 +- src/Simplex/Messaging/Server/Env/STM.hs | 82 +- src/Simplex/Messaging/Server/Main.hs | 223 +--- src/Simplex/Messaging/Server/Main/Init.hs | 4 +- .../Messaging/Server/MsgStore/Journal.hs | 1090 ----------------- .../Server/MsgStore/Journal/SharedLock.hs | 44 - .../Messaging/Server/MsgStore/Postgres.hs | 91 +- src/Simplex/Messaging/Server/MsgStore/STM.hs | 180 +-- .../Messaging/Server/MsgStore/Types.hs | 103 +- src/Simplex/Messaging/Server/Prometheus.hs | 28 +- .../Messaging/Server/QueueStore/Postgres.hs | 309 +---- .../Messaging/Server/QueueStore/STM.hs | 19 +- .../Messaging/Server/QueueStore/Types.hs | 18 +- .../Messaging/Server/StoreLog/ReadWrite.hs | 4 +- tests/AgentTests/FunctionalAPITests.hs | 37 +- tests/AgentTests/NotificationTests.hs | 2 +- tests/CoreTests/MsgStoreTests.hs | 587 +-------- tests/CoreTests/StoreLogTests.hs | 14 +- tests/SMPClient.hs | 85 +- tests/SMPProxyTests.hs | 28 +- tests/ServerTests.hs | 35 +- tests/Test.hs | 18 +- 26 files changed, 435 insertions(+), 2669 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 cd94d7d12..4d65c7194 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 39b40dd33..f15bccff3 100644 --- a/simplexmq.cabal +++ b/simplexmq.cabal @@ -279,8 +279,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/Agent/Client.hs b/src/Simplex/Messaging/Agent/Client.hs index 8cbb4c17b..ed1935e87 100644 --- a/src/Simplex/Messaging/Agent/Client.hs +++ b/src/Simplex/Messaging/Agent/Client.hs @@ -34,7 +34,6 @@ module Simplex.Messaging.Agent.Client withInvLock, withLockMap, withLocksMap, - getMapLock, ipAddressProtected, closeAgentClient, closeProtocolServerClients, diff --git a/src/Simplex/Messaging/Agent/Lock.hs b/src/Simplex/Messaging/Agent/Lock.hs index 18a6f0985..081c53b68 100644 --- a/src/Simplex/Messaging/Agent/Lock.hs +++ b/src/Simplex/Messaging/Agent/Lock.hs @@ -6,7 +6,6 @@ module Simplex.Messaging.Agent.Lock withLock', withGetLock, withGetLocks, - getPutLock, ) where diff --git a/src/Simplex/Messaging/Server.hs b/src/Simplex/Messaging/Server.hs index 405e9b5f0..a50f260a4 100644 --- a/src/Simplex/Messaging/Server.hs +++ b/src/Simplex/Messaging/Server.hs @@ -33,9 +33,6 @@ module Simplex.Messaging.Server ( runSMPServer, runSMPServerBlocking, controlPortAuth, - importMessages, - exportMessages, - printMessageStats, disconnectTransport, verifyCmdAuthorization, dummyVerifyCmd, @@ -108,7 +105,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 @@ -116,6 +112,7 @@ import Simplex.Messaging.Server.NtfStore import Simplex.Messaging.Server.Prometheus import Simplex.Messaging.Server.QueueStore import Simplex.Messaging.Server.QueueStore.QueueInfo +import Simplex.Messaging.Server.QueueStore.STM (withLoadedQueues) import Simplex.Messaging.Server.QueueStore.Types import Simplex.Messaging.Server.Stats import Simplex.Messaging.Server.StoreLog (foldLogLines) @@ -145,7 +142,7 @@ import GHC.Conc.Sync (threadLabel) #endif #if defined(dbServerPostgres) -import Simplex.Messaging.Server.MsgStore.Postgres (exportDbMessages, getDbMessageStats) +import Simplex.Messaging.Server.MsgStore.Postgres (getDbMessageStats) #endif -- | Runs an SMP server using passed configuration. @@ -710,7 +707,11 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg, startOpt (deliveredSubs, deliveredTimes) <- getDeliveredMetrics =<< getSystemSeconds smpSubs <- getSubscribersMetrics subscribers ntfSubs <- getSubscribersMetrics ntfSubscribers - loadedCounts <- loadedQueueCounts $ fromMsgStore ms + loadedCounts <- case ms of + StoreMemory st -> Just <$> loadedQueueCounts st +#if defined(dbServerPostgres) + StoreDatabase _ -> pure Nothing +#endif pure RealTimeMetrics {socketStats, threadsCount, clientsCount, deliveredSubs, deliveredTimes, smpSubs, ntfSubs, loadedCounts} where getSubscribersMetrics ServerSubscribers {queueSubscribers, serviceSubscribers, totalServiceSubs, subClients} = do @@ -2273,40 +2274,27 @@ randomId = fmap EntityId . randomId' saveServerMessages :: Bool -> MsgStore s -> IO () saveServerMessages drainMsgs ms = case ms of - StoreMemory STMMsgStore {storeConfig = STMStoreConfig {storePath}} -> case storePath of - Just f -> exportMessages False ms f drainMsgs + StoreMemory ms'@STMMsgStore {storeConfig = STMStoreConfig {storePath}} -> case storePath of + Just f -> exportMessages 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 -exportMessages :: forall s. MsgStoreClass s => Bool -> MsgStore s -> FilePath -> Bool -> IO () -exportMessages tty st f drainMsgs = do +exportMessages :: STMMsgStore -> FilePath -> Bool -> IO () +exportMessages ms 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 + run $ fmap (\(Sum n) -> n) . withLoadedQueues (queueStore ms) . saveQueueMsgs where - exportMessages_ ms get = fmap (\(Sum n) -> n) . unsafeWithAllMsgQueues tty ms . saveQueueMsgs get run :: (Handle -> IO Int) -> IO () run a = liftIO $ withFile f WriteMode $ tryAny . a >=> \case Right n -> logNote $ "messages saved: " <> tshow n 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) - saveQueueMsgs get h q = do - msgs <- get q + saveQueueMsgs :: Handle -> STMQueue -> IO (Sum Int) + saveQueueMsgs h q = do + msgs <- getQueueMessages drainMsgs q unless (null msgs) $ BLD.hPutBuilder h $ encodeMessages (recipientId q) msgs pure $ Sum $ length msgs encodeMessages rId = mconcat . map (\msg -> BLD.byteString (strEncode $ MLRv3 rId msg) <> BLD.char8 '\n') @@ -2318,37 +2306,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) + Just f -> ifM (doesFileExist f) (Just <$> importMessages 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 @@ -2360,18 +2327,17 @@ processServerMessages StartOptions {skipWarnings} = do | otherwise = logWarn "skipping message expiration" $> Nothing #endif -importMessages :: forall s. MsgStoreClass s => Bool -> s -> FilePath -> Maybe Int64 -> Bool -> IO MessageStats -importMessages tty ms f old_ skipWarnings = do +importMessages :: STMMsgStore -> FilePath -> Maybe Int64 -> Bool -> IO MessageStats +importMessages ms f old_ skipWarnings = do logNote $ "restoring messages from file " <> T.pack f (_, (storedMsgsCount, expiredMsgsCount, overQuota)) <- - foldLogLines tty f restoreMsg (Nothing, (0, 0, M.empty)) + foldLogLines False f restoreMsg (Nothing, (0, 0, M.empty)) renameFile f $ f <> ".bak" mapM_ setOverQuota_ overQuota - logQueueStates ms - EntityCounts {queueCount} <- liftIO $ getEntityCounts @(StoreQueue s) $ queueStore ms + EntityCounts {queueCount} <- liftIO $ getEntityCounts @STMQueue $ queueStore ms pure MessageStats {storedMsgsCount, expiredMsgsCount, storedQueues = queueCount} where - restoreMsg :: (Maybe (RecipientId, StoreQueue s), (Int, Int, Map RecipientId (StoreQueue s))) -> Bool -> ByteString -> IO (Maybe (RecipientId, StoreQueue s), (Int, Int, Map RecipientId (StoreQueue s))) + restoreMsg :: (Maybe (RecipientId, STMQueue), (Int, Int, Map RecipientId STMQueue)) -> Bool -> ByteString -> IO (Maybe (RecipientId, STMQueue), (Int, Int, Map RecipientId STMQueue)) restoreMsg (q_, counts@(!stored, !expired, !overQuota)) eof s = case strDecode s of Right (MLRv3 rId msg) -> runExceptT (addToMsgQueue rId msg) >>= either (exitErr . tshow) pure Left e @@ -2379,7 +2345,6 @@ importMessages tty ms f old_ skipWarnings = do | otherwise -> exitErr $ parsingErr e where exitErr e = do - when tty $ putStrLn "" logError $ "error restoring messages: " <> e liftIO exitFailure parsingErr :: String -> Text @@ -2392,7 +2357,6 @@ importMessages tty ms f old_ skipWarnings = do case qOrErr of Right q -> addToQueue_ q rId msg Left AUTH -> liftIO $ do - when tty $ putStrLn "" warnOrExit $ "queue " <> safeDecodeUtf8 (encode $ unEntityId rId) <> " does not exist" pure (Nothing, counts) Left e -> throwE e @@ -2403,20 +2367,13 @@ importMessages tty ms f old_ skipWarnings = do writeMsg ms q False msg >>= \case Just _ -> pure (stored + 1, expired, overQuota) Nothing -> liftIO $ do - when tty $ putStrLn "" logError $ decodeLatin1 $ "message queue " <> strEncode rId <> " is full, message not restored: " <> strEncode (messageId msg) pure counts | otherwise -> pure (stored, expired + 1, overQuota) MessageQuota {} -> -- queue was over quota at some point, -- it will be set as over quota once fully imported - mergeQuotaMsgs >> writeMsg ms q False msg $> (stored, expired, M.insert rId q overQuota) - where - -- if the first message in queue head is "quota", remove it. - mergeQuotaMsgs = - withPeekMsgQueue ms q "mergeQuotaMsgs" $ maybe (pure ()) $ \case - (mq, MessageQuota {}) -> tryDeleteMsg_ q mq False - _ -> pure () + deleteQuotaMsg q >> writeMsg ms q False msg $> (stored, expired, M.insert rId q overQuota) warnOrExit e | skipWarnings = logWarn e' | otherwise = do diff --git a/src/Simplex/Messaging/Server/Env/STM.hs b/src/Simplex/Messaging/Server/Env/STM.hs index b4333959f..fa81e811b 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, @@ -68,10 +67,6 @@ module Simplex.Messaging.Server.Env.STM defaultInactiveClientExpiration, defaultProxyClientConcurrency, defaultNameResolverConcurrency, - defaultMaxJournalMsgCount, - defaultMaxJournalStateLines, - defaultIdleQueueInterval, - journalMsgStoreDepth, readWriteQueueStore, noPostgresExitStr, noPostgresExit, @@ -96,7 +91,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 (..)) @@ -113,7 +108,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) @@ -146,8 +140,6 @@ data ServerConfig s = ServerConfig smpHandshakeTimeout :: Int, tbqSize :: Natural, msgQueueQuota :: Int, - maxJournalMsgCount :: Int, - maxJournalStateLines :: Int, queueIdBytes :: Int, msgIdBytes :: Int, serverStoreCfg :: ServerStoreCfg s, @@ -164,8 +156,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), @@ -229,9 +219,6 @@ defaultMessageExpiration = checkInterval = 7200 -- seconds, 2 hours } -defaultIdleQueueInterval :: Int64 -defaultIdleQueueInterval = 14400 -- seconds, 4 hours - defNtfExpirationHours :: Int64 defNtfExpirationHours = 24 @@ -255,21 +242,9 @@ defaultProxyClientConcurrency = 32 defaultNameResolverConcurrency :: Int defaultNameResolverConcurrency = 1000 -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, @@ -295,7 +270,6 @@ msgStore = fromMsgStore . msgStore_ fromMsgStore :: MsgStore s -> s fromMsgStore = \case StoreMemory s -> s - StoreJournal s -> s #if defined(dbServerPostgres) StoreDatabase s -> s #endif @@ -303,12 +277,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 @@ -322,8 +294,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 @@ -331,8 +301,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 @@ -340,8 +308,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 @@ -350,14 +316,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 @@ -571,39 +535,21 @@ 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} = do +newEnv config@ServerConfig {smpCredentials, httpCredentials, serverStoreCfg, smpAgentCfg, information, messageExpiration, msgQueueQuota, namesConfig} = do serverActive <- newTVarIO True server <- newServer msgStore_ <- case serverStoreCfg of SSCMemory storePaths_ -> do let storePath = storeMsgsFile =<< storePaths_ ms <- newMsgStore STMStoreConfig {storePath, quota = msgQueueQuota} - forM_ storePaths_ $ \StorePaths {storeLogFile = f} -> loadStoreLog (mkQueue ms True) f $ queueStore ms + forM_ storePaths_ $ \StorePaths {storeLogFile = f} -> loadStoreLog (mkQueue ms) 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 @@ -655,8 +601,7 @@ newEnv config@ServerConfig {smpCredentials, httpCredentials, serverStoreCfg, smp Just f -> do logNote $ "compacting queues in file " <> T.pack f st <- newMsgStore STMStoreConfig {storePath = Nothing, quota = msgQueueQuota} - -- we don't need to have locks in the map - sl <- readWriteQueueStore False (mkQueue st False) f (queueStore st) + sl <- readWriteQueueStore False (mkQueue st) f (queueStore st) setStoreLog (queueStore st) sl closeMsgStore st Nothing -> do @@ -703,7 +648,9 @@ newEnv config@ServerConfig {smpCredentials, httpCredentials, serverStoreCfg, smp Nothing -> SPMMemoryOnly Just StorePaths {storeMsgsFile = Just _} -> SPMMessages _ -> SPMQueues - _ -> SPMMessages +#if defined(dbServerPostgres) + SSCDatabase _ -> SPMMessages +#endif noPostgresExit :: IO a noPostgresExit = putStrLn noPostgresExitStr >> exitFailure @@ -713,21 +660,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 138a25fc0..30128d187 100644 --- a/src/Simplex/Messaging/Server/Main.hs +++ b/src/Simplex/Messaging/Server/Main.hs @@ -28,8 +28,6 @@ module Simplex.Messaging.Server.Main importMessagesToDatabase, exportDatabaseToStoreLog, #endif - newJournalMsgStore, - storeMsgsJournalDir', getServerSourceCode, simplexmqSource, serverPublicInfo, @@ -61,7 +59,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 +66,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, whenM) import System.Directory (createDirectoryIfMissing, doesDirectoryExist, doesFileExist) import System.Exit (exitFailure) import System.FilePath (combine) @@ -98,15 +92,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 (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 +131,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 +143,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 +170,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 +201,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 +227,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 +267,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,20 +276,21 @@ 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" storeLogFilePath = combine logPath "smp-server-store.log" storeMsgsFilePath = combine logPath "smp-server-messages.log" - storeMsgsJournalDir = storeMsgsJournalDir' logPath + storeMsgsJournalDir = combine logPath "messages" storeNtfsFilePath = combine logPath "smp-server-ntfs.log" readStoreType :: Ini -> Either String AStoreType readStoreType ini = case (iniStoreQueues, iniStoreMessage) of ("memory", "memory") -> Right $ ASType SQSMemory SMSMemory - ("memory", "journal") -> Right $ ASType SQSMemory SMSJournal + ("memory", "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 +300,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 +442,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 +457,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 +481,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 @@ -634,47 +553,26 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath = webStaticPath' = eitherToMaybe $ T.unpack <$> lookupValue "WEB" "static_path" ini checkMsgStoreMode :: Ini -> AStoreType -> IO () +#if defined(dbServerPostgres) checkMsgStoreMode ini mode = do - msgsDirExists <- doesDirectoryExist storeMsgsJournalDir - msgsFileExists <- doesFileExist storeMsgsFilePath - storeLogExists <- doesFileExist storeLogFilePath +#else + checkMsgStoreMode _ mode = do +#endif + whenM (doesDirectoryExist storeMsgsJournalDir) $ do + putStrLn $ "Error: " <> storeMsgsJournalDir <> " directory is present.\n" <> journalRemovedStr + exitFailure case mode of #if defined(dbServerPostgres) - ASType SQSPostgres SMSPostgres - | msgsFileExists || msgsDirExists -> do - putStrLn $ "Error: " <> storeMsgsFilePath <> " file or " <> storeMsgsJournalDir <> " directory are present." - putStrLn "Configure memory storage." - exitFailure - | otherwise -> checkDbStorage ini storeLogExists -#endif - ASType qs SMSJournal - | msgsFileExists && msgsDirExists -> exitConfigureMsgStorage - | msgsFileExists -> do - putStrLn $ "Error: store_messages is `journal` with " <> storeMsgsFilePath <> " file present." - putStrLn "Set store_messages to `memory` or use `smp-server journal export` to migrate." - exitFailure - | not msgsDirExists -> - putStrLn $ "store_messages is `journal`, " <> storeMsgsJournalDir <> " directory will be created." - | otherwise -> case qs of - SQSMemory -> - unless (storeLogExists) $ putStrLn $ "store_queues is `memory`, " <> storeLogFilePath <> " file will be created." -#if defined(dbServerPostgres) - SQSPostgres -> checkDbStorage ini storeLogExists + ASType SQSPostgres SMSPostgres -> do + whenM (doesFileExist storeMsgsFilePath) $ do + putStrLn $ "Error: " <> storeMsgsFilePath <> " file is present." + putStrLn "Configure memory storage." + exitFailure + 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." - exitFailure - | otherwise -> pure () - - exitConfigureMsgStorage = do - putStrLn $ "Error: both " <> storeMsgsFilePath <> " file and " <> storeMsgsJournalDir <> " directory are present." - putStrLn "Configure memory storage." - exitFailure + ASType SQSMemory SMSMemory -> pure () #if defined(dbServerPostgres) checkDbStorage ini storeLogExists = do @@ -705,18 +603,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 - sl <- readWriteQueueStore True (mkQueue ms False) storeLogFile st +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) storeLogFile st closeStoreLog sl - queues <- readTVarIO $ loadedQueues st + qs <- readTVarIO $ queues 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 + sCnt <- batchInsertServices services' ps + qCnt <- batchInsertQueues True qs ps renameFile storeLogFile $ storeLogFile <> ".bak" pure (sCnt, qCnt) @@ -735,24 +633,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 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 - -storeMsgsJournalDir' :: FilePath -> FilePath -storeMsgsJournalDir' logPath = combine logPath "messages" +journalRemovedStr :: String +journalRemovedStr = + "Journal message storage is removed.\n" + <> "Export messages with `smp-server journal export` using smp-server v7.1.0.10 or earlier,\n" + <> "then set store_messages to `memory`, or to `database` and run `smp-server database import --table messages`." getServerSourceCode :: IO (Maybe String) getServerSourceCode = @@ -873,7 +769,6 @@ data CliCommand | OnlineCert CertOptions | Start StartOptions | Delete - | Journal StoreCmd | Database StoreCmd DatabaseTable DBOpts data StoreCmd = SCImport | SCExport | SCDelete @@ -899,7 +794,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 @@ -1046,7 +940,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 89df1ad93..db9323c90 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 40ff03af0..000000000 --- a/src/Simplex/Messaging/Server/MsgStore/Journal.hs +++ /dev/null @@ -1,1090 +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, - queueLocks' :: TMap RecipientId 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 #-} - removeQueueLock :: JournalQueue s -> IO () - removeQueueLock JournalQueue {recipientId', queueLock, queueLocks'} = - atomically $ whenM ((Just queueLock ==) <$> TM.lookup recipientId' queueLocks') $ TM.delete recipientId' queueLocks' - -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 {queueLocks, sharedLock} rId qr queueLock = do - queueRec' <- newTVarIO $ Just qr - msgQueue' <- newTVarIO Nothing - activeAt <- newTVarIO 0 - queueState <- newTVarIO Nothing - pure $ - JournalQueue - { recipientId' = rId, - queueLock, - queueLocks' = queueLocks, - 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 87b7294f1..000000000 --- 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 be99fa265..75e77810c 100644 --- a/src/Simplex/Messaging/Server/MsgStore/Postgres.hs +++ b/src/Simplex/Messaging/Server/MsgStore/Postgres.hs @@ -29,7 +29,6 @@ where import Control.Concurrent.STM import qualified Control.Exception as E import Control.Monad -import Control.Monad.Reader import Control.Monad.Trans.Except import qualified Data.ByteString as B import qualified Data.ByteString.Builder as BB @@ -39,7 +38,6 @@ import Data.IORef import Data.Int (Int64) import Data.List (intersperse) import qualified Data.Map.Strict as M -import Data.Text (Text) import Data.Time.Clock.System (SystemTime (..)) import Database.PostgreSQL.Simple (Binary (..), In (..), Only (..), (:.) (..)) import qualified Database.PostgreSQL.Simple as DB @@ -56,7 +54,7 @@ import Simplex.Messaging.Server.QueueStore.Postgres import Simplex.Messaging.Server.QueueStore.Types import Simplex.Messaging.Server.StoreLog (foldLogLines) import Simplex.Messaging.Encoding.String -import Simplex.Messaging.Util (maybeFirstRow, maybeFirstRow', (<$$>)) +import Simplex.Messaging.Util (maybeFirstRow, maybeFirstRow') import System.IO (Handle, hFlush, stdout) data PostgresMsgStore = PostgresMsgStore @@ -81,34 +79,20 @@ instance StoreQueueClass PostgresQueue where {-# INLINE recipientId #-} queueRec = queueRec' {-# INLINE queueRec #-} - withQueueLock PostgresQueue {} _ = id -- TODO [messages] maybe it's just transaction? - {-# INLINE withQueueLock #-} - removeQueueLock _ = pure () - {-# INLINE removeQueueLock #-} - -newtype DBTransaction = DBTransaction {dbConn :: DB.Connection} - -type DBStoreIO a = ReaderT DBTransaction IO a instance MsgStoreClass PostgresMsgStore where - type StoreMonad PostgresMsgStore = ReaderT DBTransaction IO - type MsgQueue PostgresMsgStore = () type QueueStore PostgresMsgStore = PostgresQueueStore' type StoreQueue PostgresMsgStore = PostgresQueue type MsgStoreConfig PostgresMsgStore = PostgresMsgStoreCfg newMsgStore :: PostgresMsgStoreCfg -> IO PostgresMsgStore newMsgStore config = do - queueStore_ <- newQueueStore @PostgresQueue (queueStoreCfg config, False) + queueStore_ <- newQueueStore @PostgresQueue (queueStoreCfg config) pure PostgresMsgStore {config, queueStore_} closeMsgStore :: PostgresMsgStore -> IO () closeMsgStore = closeQueueStore @PostgresQueue . queueStore_ - withActiveMsgQueues _ _ = error "withActiveMsgQueues not used" - - unsafeWithAllMsgQueues _ _ _ = error "unsafeWithAllMsgQueues not used" - expireOldMessages :: Bool -> PostgresMsgStore -> Int64 -> Int64 -> IO MessageStats expireOldMessages _tty ms now ttl = maybeFirstRow' newMessageStats toMessageStats $ withConnection st $ \db -> @@ -152,35 +136,13 @@ instance MsgStoreClass PostgresMsgStore where msg_ = toMaybeMessage mRow in f a rId $ Right ((qr,) <$> msg_) - logQueueStates _ = error "logQueueStates not used" - - logQueueState _ = error "logQueueState not used" - queueStore = queueStore_ {-# INLINE queueStore #-} - loadedQueueCounts :: PostgresMsgStore -> IO LoadedQueueCounts - loadedQueueCounts ms = do - loadedQueueCount <- M.size <$> readTVarIO queues - loadedNotifierCount <- M.size <$> readTVarIO notifiers - notifierLockCount <- M.size <$> readTVarIO notifierLocks - pure LoadedQueueCounts {loadedQueueCount, loadedNotifierCount, openJournalCount = 0, queueLockCount = 0, notifierLockCount} - where - PostgresQueueStore {queues, notifiers, notifierLocks} = queueStore_ ms - - mkQueue :: PostgresMsgStore -> Bool -> RecipientId -> QueueRec -> IO PostgresQueue - mkQueue _ _keepLock rId qr = PostgresQueue rId <$> newTVarIO (Just qr) + mkQueue :: PostgresMsgStore -> RecipientId -> QueueRec -> IO PostgresQueue + mkQueue _ rId qr = PostgresQueue rId <$> newTVarIO (Just qr) {-# INLINE mkQueue #-} - getMsgQueue _ _ _ = pure () - {-# INLINE getMsgQueue #-} - - getPeekMsgQueue :: PostgresMsgStore -> PostgresQueue -> DBStoreIO (Maybe ((), Message)) - getPeekMsgQueue _ q = ((),) <$$> tryPeekMsg_ q () - - withIdleMsgQueue :: Int64 -> PostgresMsgStore -> PostgresQueue -> (() -> DBStoreIO a) -> DBStoreIO (Maybe a, Int) - withIdleMsgQueue _ _ _ _ = error "withIdleMsgQueue not used" - deleteQueue :: PostgresMsgStore -> PostgresQueue -> IO (Either ErrorType QueueRec) deleteQueue ms q = deleteStoreQueue (queueStore_ ms) q {-# INLINE deleteQueue #-} @@ -191,8 +153,6 @@ instance MsgStoreClass PostgresMsgStore where qr <- ExceptT $ deleteStoreQueue (queueStore_ ms) q pure (qr, size) - getQueueMessages_ _ _ _ = error "getQueueMessages_ not used" - writeMsg :: PostgresMsgStore -> PostgresQueue -> Bool -> Message -> ExceptT ErrorType IO (Maybe (Message, Bool)) writeMsg ms q _ msg = uninterruptibleMask_ $ @@ -211,43 +171,26 @@ instance MsgStoreClass PostgresMsgStore where [] -> Nothing PostgresMsgStore {config = PostgresMsgStoreCfg {quota}} = ms - setOverQuota_ :: PostgresQueue -> IO () -- can ONLY be used while restoring messages, not while server running - setOverQuota_ _ = error "TODO setOverQuota_" -- TODO [messages] - - getQueueSize_ :: () -> DBStoreIO Int - getQueueSize_ _ = error "getQueueSize_ not used" - getQueueSize :: PostgresMsgStore -> PostgresQueue -> ExceptT ErrorType IO Int getQueueSize ms q = withDB' "getQueueSize" (queueStore_ ms) $ \db -> maybeFirstRow' 0 fromOnly $ DB.query db "SELECT msg_queue_size FROM msg_queues WHERE recipient_id = ? AND deleted_at IS NULL" (Only (recipientId' q)) - tryPeekMsg_ :: PostgresQueue -> () -> DBStoreIO (Maybe Message) - tryPeekMsg_ q _ = do - db <- asks dbConn - liftIO $ maybeFirstRow toMessage $ - DB.query - db - [sql| - SELECT msg_id, msg_ts, msg_quota, msg_ntf_flag, msg_body - FROM messages - WHERE recipient_id = ? - ORDER BY message_id ASC LIMIT 1 - |] - (Only (recipientId' q)) - - tryDeleteMsg_ :: PostgresQueue -> () -> Bool -> DBStoreIO () - tryDeleteMsg_ _q _ _ = error "tryDeleteMsg_ not used" -- do - - isolateQueue :: PostgresMsgStore -> PostgresQueue -> Text -> DBStoreIO a -> ExceptT ErrorType IO a - isolateQueue ms _q op a = uninterruptibleMask_ $ withDB' op (queueStore_ ms) $ runReaderT a . DBTransaction - - unsafeRunStore _ _ _ = error "unsafeRunStore not used" - tryPeekMsg :: PostgresMsgStore -> PostgresQueue -> ExceptT ErrorType IO (Maybe Message) - tryPeekMsg ms q = isolateQueue ms q "tryPeekMsg" $ tryPeekMsg_ q () - {-# INLINE tryPeekMsg #-} + tryPeekMsg ms q = + uninterruptibleMask_ $ + withDB' "tryPeekMsg" (queueStore_ ms) $ \db -> + maybeFirstRow toMessage $ + DB.query + db + [sql| + SELECT msg_id, msg_ts, msg_quota, msg_ntf_flag, msg_body + FROM messages + WHERE recipient_id = ? + ORDER BY message_id ASC LIMIT 1 + |] + (Only (recipientId' q)) tryPeekMsgs :: PostgresMsgStore -> [PostgresQueue] -> ExceptT ErrorType IO (M.Map RecipientId Message) tryPeekMsgs _ms [] = pure M.empty diff --git a/src/Simplex/Messaging/Server/MsgStore/STM.hs b/src/Simplex/Messaging/Server/MsgStore/STM.hs index 8388efd34..6f9c4e1f2 100644 --- a/src/Simplex/Messaging/Server/MsgStore/STM.hs +++ b/src/Simplex/Messaging/Server/MsgStore/STM.hs @@ -15,6 +15,10 @@ module Simplex.Messaging.Server.MsgStore.STM ( STMMsgStore (..), STMStoreConfig (..), STMQueue, + loadedQueueCounts, + getQueueMessages, + setOverQuota_, + deleteQuotaMsg, ) where @@ -24,7 +28,8 @@ import Control.Monad.Trans.Except import Data.Functor (($>)) import Data.Int (Int64) import qualified Data.Map.Strict as M -import Data.Text (Text) +import Data.Maybe (catMaybes) +import Data.Time.Clock.System (SystemTime (systemSeconds)) import Simplex.Messaging.Protocol import Simplex.Messaging.Server.MsgStore.Types import Simplex.Messaging.Server.QueueStore @@ -61,14 +66,8 @@ instance StoreQueueClass STMQueue where {-# INLINE recipientId #-} queueRec = queueRec' {-# INLINE queueRec #-} - withQueueLock _ _ = id - {-# INLINE withQueueLock #-} - removeQueueLock _ = pure () - {-# INLINE removeQueueLock #-} instance MsgStoreClass STMMsgStore where - type StoreMonad STMMsgStore = STM - type MsgQueue STMMsgStore = STMMsgQueue type QueueStore STMMsgStore = STMQueueStore STMQueue type StoreQueue STMMsgStore = STMQueue type MsgStoreConfig STMMsgStore = STMStoreConfig @@ -80,59 +79,22 @@ instance MsgStoreClass STMMsgStore where closeMsgStore = closeQueueStore @STMQueue . queueStore_ {-# INLINE closeMsgStore #-} - withActiveMsgQueues = withLoadedQueues . queueStore_ - {-# INLINE withActiveMsgQueues #-} - unsafeWithAllMsgQueues _ = withLoadedQueues . queueStore_ - {-# INLINE unsafeWithAllMsgQueues #-} expireOldMessages :: Bool -> STMMsgStore -> Int64 -> Int64 -> IO MessageStats expireOldMessages _tty ms now ttl = - withLoadedQueues (queueStore_ ms) $ atomically . expireQueueMsgs ms now (now - ttl) + withLoadedQueues (queueStore_ ms) $ atomically . expireQueueMsgs (now - ttl) foldRcvServiceMessages :: STMMsgStore -> ServiceId -> (a -> RecipientId -> Either ErrorType (Maybe (QueueRec, Message)) -> IO a) -> a -> IO (Either ErrorType a) foldRcvServiceMessages ms serviceId f = fmap Right . foldRcvServiceQueues (queueStore_ ms) serviceId f' where f' a (q, qr) = runExceptT (tryPeekMsg ms q) >>= f a (recipientId q) . ((qr,) <$$>) - logQueueStates _ = pure () - {-# INLINE logQueueStates #-} - logQueueState _ = pure () - {-# INLINE logQueueState #-} queueStore = queueStore_ {-# INLINE queueStore #-} - loadedQueueCounts :: STMMsgStore -> IO LoadedQueueCounts - 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} - - mkQueue _ _ rId qr = STMQueue rId <$> newTVarIO (Just qr) <*> newTVarIO Nothing + mkQueue _ rId qr = STMQueue rId <$> newTVarIO (Just qr) <*> newTVarIO Nothing {-# INLINE mkQueue #-} - getMsgQueue :: STMMsgStore -> STMQueue -> Bool -> STM STMMsgQueue - getMsgQueue _ STMQueue {msgQueue'} _ = readTVar msgQueue' >>= maybe newQ pure - where - newQ = do - msgTQueue <- newTQueue - canWrite <- newTVar True - size <- newTVar 0 - let q = STMMsgQueue {msgTQueue, canWrite, size} - writeTVar msgQueue' (Just q) - pure q - - getPeekMsgQueue :: STMMsgStore -> STMQueue -> STM (Maybe (STMMsgQueue, Message)) - getPeekMsgQueue _ q@STMQueue {msgQueue'} = readTVar msgQueue' $>>= \mq -> (mq,) <$$> tryPeekMsg_ q mq - - -- does not create queue if it does not exist, does not delete it if it does (can't just close in-memory queue) - withIdleMsgQueue :: Int64 -> STMMsgStore -> STMQueue -> (STMMsgQueue -> STM a) -> STM (Maybe a, Int) - withIdleMsgQueue _ _ STMQueue {msgQueue'} action = readTVar msgQueue' >>= \case - Just q -> do - r <- action q - sz <- getQueueSize_ q - pure (Just r, sz) - Nothing -> pure (Nothing, 0) - deleteQueue :: STMMsgStore -> STMQueue -> IO (Either ErrorType QueueRec) deleteQueue ms q = fst <$$> deleteQueue_ ms q @@ -142,17 +104,9 @@ instance MsgStoreClass STMMsgStore where where getSize = maybe (pure 0) (\STMMsgQueue {size} -> readTVarIO size) - getQueueMessages_ :: Bool -> STMQueue -> STMMsgQueue -> STM [Message] - getQueueMessages_ drainMsgs _ = (if drainMsgs then flushTQueue else snapshotTQueue) . msgTQueue - where - snapshotTQueue q = do - msgs <- flushTQueue q - mapM_ (writeTQueue q) msgs - pure msgs - writeMsg :: STMMsgStore -> STMQueue -> Bool -> Message -> ExceptT ErrorType IO (Maybe (Message, Bool)) writeMsg ms q' _logState msg = liftIO $ atomically $ do - STMMsgQueue {msgTQueue = q, canWrite, size} <- getMsgQueue ms q' True + STMMsgQueue {msgTQueue = q, canWrite, size} <- getMsgQueue q' canWrt <- readTVar canWrite empty <- isEmptyTQueue q if canWrt || empty @@ -168,29 +122,109 @@ instance MsgStoreClass STMMsgStore where STMMsgStore {storeConfig = STMStoreConfig {quota}} = ms msgQuota = MessageQuota {msgId = messageId msg, msgTs = messageTs msg} - setOverQuota_ :: STMQueue -> IO () - setOverQuota_ q = readTVarIO (msgQueue' q) >>= mapM_ (\mq -> atomically $ writeTVar (canWrite mq) False) + tryPeekMsg :: STMMsgStore -> STMQueue -> ExceptT ErrorType IO (Maybe Message) + tryPeekMsg _ q = snd <$$> withPeekMsgQueue q pure + {-# INLINE tryPeekMsg #-} - getQueueSize_ :: STMMsgQueue -> STM Int - getQueueSize_ STMMsgQueue {size} = readTVar size + tryPeekMsgs :: STMMsgStore -> [STMQueue] -> ExceptT ErrorType IO (M.Map RecipientId Message) + tryPeekMsgs st qs = M.fromList . catMaybes <$> mapM (\q -> (recipientId q,) <$$> tryPeekMsg st q) qs - tryPeekMsg_ :: STMQueue -> STMMsgQueue -> STM (Maybe Message) - tryPeekMsg_ _ = tryPeekTQueue . msgTQueue - {-# INLINE tryPeekMsg_ #-} + tryDelMsg :: STMMsgStore -> STMQueue -> MsgId -> ExceptT ErrorType IO (Maybe Message) + tryDelMsg _ q msgId' = + withPeekMsgQueue q $ + maybe (pure Nothing) $ \(mq, msg) -> + if messageId msg == msgId' + then tryDeleteMsg_ mq $> Just msg + else pure Nothing - tryDeleteMsg_ :: STMQueue -> STMMsgQueue -> Bool -> STM () - tryDeleteMsg_ _ STMMsgQueue {msgTQueue = q, size} _logState = - tryReadTQueue q >>= \case - Just _ -> modifyTVar' size (subtract 1) - _ -> pure () + tryDelPeekMsg :: STMMsgStore -> STMQueue -> MsgId -> ExceptT ErrorType IO (Maybe Message, Maybe Message) + tryDelPeekMsg _ q msgId' = + withPeekMsgQueue q $ + maybe (pure (Nothing, Nothing)) $ \(mq, msg) -> + if messageId msg == msgId' + then (Just msg,) <$> (tryDeleteMsg_ mq >> tryPeekMsg_ mq) + else pure (Nothing, Just msg) - isolateQueue :: STMMsgStore -> STMQueue -> Text -> STM a -> ExceptT ErrorType IO a - isolateQueue _ _ _ = liftIO . atomically - {-# INLINE isolateQueue #-} + deleteExpiredMsgs :: STMMsgStore -> STMQueue -> Int64 -> ExceptT ErrorType IO Int + deleteExpiredMsgs _ q old = liftIO $ atomically $ getMsgQueue q >>= deleteExpireMsgs_ old - unsafeRunStore :: STMQueue -> Text -> STM a -> IO a - unsafeRunStore _ _ = atomically - {-# INLINE unsafeRunStore #-} + getQueueSize :: STMMsgStore -> STMQueue -> ExceptT ErrorType IO Int + getQueueSize _ q = withPeekMsgQueue q $ maybe (pure 0) (getQueueSize_ . fst) + {-# INLINE getQueueSize #-} + +loadedQueueCounts :: STMMsgStore -> IO LoadedQueueCounts +loadedQueueCounts STMMsgStore {queueStore_ = st} = do + loadedQueueCount <- M.size <$> readTVarIO (queues st) + loadedNotifierCount <- M.size <$> readTVarIO (notifiers st) + pure LoadedQueueCounts {loadedQueueCount, loadedNotifierCount} + +getMsgQueue :: STMQueue -> STM STMMsgQueue +getMsgQueue STMQueue {msgQueue'} = readTVar msgQueue' >>= maybe newQ pure + where + newQ = do + msgTQueue <- newTQueue + canWrite <- newTVar True + size <- newTVar 0 + let q = STMMsgQueue {msgTQueue, canWrite, size} + writeTVar msgQueue' (Just q) + pure q + +-- The action is called with Nothing when it is known that the queue is empty +withPeekMsgQueue :: STMQueue -> (Maybe (STMMsgQueue, Message) -> STM a) -> ExceptT ErrorType IO a +withPeekMsgQueue STMQueue {msgQueue'} a = + liftIO $ atomically $ (readTVar msgQueue' $>>= \mq -> (mq,) <$$> tryPeekMsg_ mq) >>= a + +getQueueMessages :: Bool -> STMQueue -> IO [Message] +getQueueMessages drainMsgs q = atomically $ (if drainMsgs then flushTQueue else snapshotTQueue) . msgTQueue =<< getMsgQueue q + where + snapshotTQueue mq = do + msgs <- flushTQueue mq + mapM_ (writeTQueue mq) msgs + pure msgs + +-- can ONLY be used while restoring messages, not while server running +setOverQuota_ :: STMQueue -> IO () +setOverQuota_ q = readTVarIO (msgQueue' q) >>= mapM_ (\mq -> atomically $ writeTVar (canWrite mq) False) + +-- if the first message in queue head is "quota", remove it +deleteQuotaMsg :: STMQueue -> ExceptT ErrorType IO () +deleteQuotaMsg q = + withPeekMsgQueue q $ \case + Just (mq, MessageQuota {}) -> tryDeleteMsg_ mq + _ -> pure () + +expireQueueMsgs :: Int64 -> STMQueue -> STM MessageStats +expireQueueMsgs old STMQueue {msgQueue'} = + readTVar msgQueue' >>= \case + Just mq -> do + expiredMsgsCount <- deleteExpireMsgs_ old mq + storedMsgsCount <- getQueueSize_ mq + pure MessageStats {storedMsgsCount, expiredMsgsCount, storedQueues = 1} + -- does not create queue if it does not exist + Nothing -> pure newMessageStats {storedQueues = 1} + +deleteExpireMsgs_ :: Int64 -> STMMsgQueue -> STM Int +deleteExpireMsgs_ old mq = loop 0 + where + loop dc = + tryPeekMsg_ mq >>= \case + Just Message {msgTs} + | systemSeconds msgTs < old -> + tryDeleteMsg_ mq >> loop (dc + 1) + _ -> pure dc + +getQueueSize_ :: STMMsgQueue -> STM Int +getQueueSize_ STMMsgQueue {size} = readTVar size + +tryPeekMsg_ :: STMMsgQueue -> STM (Maybe Message) +tryPeekMsg_ = tryPeekTQueue . msgTQueue +{-# INLINE tryPeekMsg_ #-} + +tryDeleteMsg_ :: STMMsgQueue -> STM () +tryDeleteMsg_ STMMsgQueue {msgTQueue = q, size} = + tryReadTQueue q >>= \case + Just _ -> modifyTVar' size (subtract 1) + _ -> pure () deleteQueue_ :: STMMsgStore -> STMQueue -> IO (Either ErrorType (QueueRec, Maybe STMMsgQueue)) deleteQueue_ ms q = deleteStoreQueue (queueStore_ ms) q >>= mapM remove diff --git a/src/Simplex/Messaging/Server/MsgStore/Types.hs b/src/Simplex/Messaging/Server/MsgStore/Types.hs index a14dfd424..29dcfc47f 100644 --- a/src/Simplex/Messaging/Server/MsgStore/Types.hs +++ b/src/Simplex/Messaging/Server/MsgStore/Types.hs @@ -4,17 +4,12 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilyDependencies #-} -{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} - -{-# HLINT ignore "Redundant multi-way if" #-} - module Simplex.Messaging.Server.MsgStore.Types ( MsgStoreClass (..), MSType (..), @@ -30,107 +25,49 @@ module Simplex.Messaging.Server.MsgStore.Types getQueues, getQueueRecs, readQueueRec, - withPeekMsgQueue, - expireQueueMsgs, - deleteExpireMsgs_, ) where import Control.Concurrent.STM import Control.Monad import Control.Monad.Trans.Except -import Data.Functor (($>)) import Data.Int (Int64) import Data.Kind import Data.Map.Strict (Map) -import qualified Data.Map.Strict as M -import Data.Maybe (catMaybes, fromMaybe) -import Data.Text (Text) -import Data.Time.Clock.System (SystemTime (systemSeconds)) import Simplex.Messaging.Protocol import Simplex.Messaging.Server.QueueStore import Simplex.Messaging.Server.QueueStore.Types -import Simplex.Messaging.Util ((<$$>), ($>>=)) +import Simplex.Messaging.Util (($>>=)) -class (Monad (StoreMonad s), QueueStoreClass (StoreQueue s) (QueueStore s)) => MsgStoreClass s where - type StoreMonad s = (m :: Type -> Type) | m -> s +class QueueStoreClass (StoreQueue s) (QueueStore s) => MsgStoreClass s where type MsgStoreConfig s = c | c -> s - type MsgQueue s = q | q -> s type StoreQueue s = q | q -> s type QueueStore s = qs | qs -> s newMsgStore :: MsgStoreConfig s -> IO s closeMsgStore :: s -> IO () - withActiveMsgQueues :: Monoid a => s -> (StoreQueue s -> IO a) -> IO a - -- This function can only be used in server CLI commands or before server is started. - -- tty, store - unsafeWithAllMsgQueues :: Monoid a => Bool -> s -> (StoreQueue s -> IO a) -> IO a -- tty, store, now, ttl expireOldMessages :: Bool -> s -> Int64 -> Int64 -> IO MessageStats foldRcvServiceMessages :: s -> ServiceId -> (a -> RecipientId -> Either ErrorType (Maybe (QueueRec, Message)) -> IO a) -> a -> IO (Either ErrorType a) - logQueueStates :: s -> IO () - logQueueState :: StoreQueue s -> StoreMonad s () queueStore :: s -> QueueStore s - loadedQueueCounts :: s -> IO LoadedQueueCounts -- message store methods - mkQueue :: s -> Bool -> RecipientId -> QueueRec -> IO (StoreQueue s) - getMsgQueue :: s -> StoreQueue s -> Bool -> StoreMonad s (MsgQueue s) - getPeekMsgQueue :: s -> StoreQueue s -> StoreMonad s (Maybe (MsgQueue s, Message)) - - -- the journal queue will be closed after action if it was initially closed or idle longer than interval in config - withIdleMsgQueue :: Int64 -> s -> StoreQueue s -> (MsgQueue s -> StoreMonad s a) -> StoreMonad s (Maybe a, Int) + mkQueue :: s -> RecipientId -> QueueRec -> IO (StoreQueue s) deleteQueue :: s -> StoreQueue s -> IO (Either ErrorType QueueRec) deleteQueueSize :: s -> StoreQueue s -> IO (Either ErrorType (QueueRec, Int)) - getQueueMessages_ :: Bool -> StoreQueue s -> MsgQueue s -> StoreMonad s [Message] writeMsg :: s -> StoreQueue s -> Bool -> Message -> ExceptT ErrorType IO (Maybe (Message, Bool)) - setOverQuota_ :: StoreQueue s -> IO () -- can ONLY be used while restoring messages, not while server running - getQueueSize_ :: MsgQueue s -> StoreMonad s Int - tryPeekMsg_ :: StoreQueue s -> MsgQueue s -> StoreMonad s (Maybe Message) - tryDeleteMsg_ :: StoreQueue s -> MsgQueue s -> Bool -> StoreMonad s () - isolateQueue :: s -> StoreQueue s -> Text -> StoreMonad s a -> ExceptT ErrorType IO a - unsafeRunStore :: StoreQueue s -> Text -> StoreMonad s a -> IO a - - -- default implementations are overridden for PostgreSQL storage of messages tryPeekMsg :: s -> StoreQueue s -> ExceptT ErrorType IO (Maybe Message) - tryPeekMsg st q = snd <$$> withPeekMsgQueue st q "tryPeekMsg" pure - {-# INLINE tryPeekMsg #-} - tryPeekMsgs :: s -> [StoreQueue s] -> ExceptT ErrorType IO (Map RecipientId Message) - tryPeekMsgs st qs = M.fromList . catMaybes <$> mapM (\q -> (recipientId q,) <$$> tryPeekMsg st q) qs - tryDelMsg :: s -> StoreQueue s -> MsgId -> ExceptT ErrorType IO (Maybe Message) - tryDelMsg st q msgId' = - withPeekMsgQueue st q "tryDelMsg" $ - maybe (pure Nothing) $ \(mq, msg) -> - if - | messageId msg == msgId' -> - tryDeleteMsg_ q mq True $> Just msg - | otherwise -> pure Nothing - -- atomic delete (== read) last and peek next message if available tryDelPeekMsg :: s -> StoreQueue s -> MsgId -> ExceptT ErrorType IO (Maybe Message, Maybe Message) - tryDelPeekMsg st q msgId' = - withPeekMsgQueue st q "tryDelPeekMsg" $ - maybe (pure (Nothing, Nothing)) $ \(mq, msg) -> - if - | messageId msg == msgId' -> (Just msg,) <$> (tryDeleteMsg_ q mq True >> tryPeekMsg_ q mq) - | otherwise -> pure (Nothing, Just msg) - deleteExpiredMsgs :: s -> StoreQueue s -> Int64 -> ExceptT ErrorType IO Int - deleteExpiredMsgs st q old = - isolateQueue st q "deleteExpiredMsgs" $ - getMsgQueue st q False >>= deleteExpireMsgs_ old q - getQueueSize :: s -> StoreQueue s -> ExceptT ErrorType IO Int - 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 @@ -154,17 +91,14 @@ instance Semigroup MessageStats where data LoadedQueueCounts = LoadedQueueCounts { loadedQueueCount :: Int, - loadedNotifierCount :: Int, - openJournalCount :: Int, - queueLockCount :: Int, - notifierLockCount :: Int + loadedNotifierCount :: Int } newMessageStats :: MessageStats newMessageStats = MessageStats 0 0 0 addQueue :: MsgStoreClass s => s -> RecipientId -> QueueRec -> IO (Either ErrorType (StoreQueue s)) -addQueue st = addQueue_ (queueStore st) (mkQueue st True) +addQueue st = addQueue_ (queueStore st) (mkQueue st) {-# INLINE addQueue #-} getQueue :: (MsgStoreClass s, QueueParty p) => s -> SParty p -> QueueId -> IO (Either ErrorType (StoreQueue s)) @@ -184,28 +118,3 @@ getQueueRecs st party qIds = getQueues st party qIds >>= mapM (fmap join . mapM readQueueRec :: StoreQueueClass q => q -> IO (Either ErrorType (q, QueueRec)) readQueueRec q = maybe (Left AUTH) (Right . (q,)) <$> readTVarIO (queueRec q) {-# INLINE readQueueRec #-} - --- The action is called with Nothing when it is known that the queue is empty -withPeekMsgQueue :: MsgStoreClass s => s -> StoreQueue s -> Text -> (Maybe (MsgQueue s, Message) -> StoreMonad s a) -> ExceptT ErrorType IO a -withPeekMsgQueue st q op a = isolateQueue st q op $ getPeekMsgQueue st q >>= a -{-# INLINE withPeekMsgQueue #-} - --- not used with PostgreSQL message store -expireQueueMsgs :: MsgStoreClass s => s -> Int64 -> Int64 -> StoreQueue s -> StoreMonad s MessageStats -expireQueueMsgs st now old q = do - (expired_, stored) <- withIdleMsgQueue now st q $ deleteExpireMsgs_ old q - pure MessageStats {storedMsgsCount = stored, expiredMsgsCount = fromMaybe 0 expired_, storedQueues = 1} - --- not used with PostgreSQL message store -deleteExpireMsgs_ :: MsgStoreClass s => Int64 -> StoreQueue s -> MsgQueue s -> StoreMonad s Int -deleteExpireMsgs_ old q mq = do - n <- loop 0 - logQueueState q - pure n - where - loop dc = - tryPeekMsg_ q mq >>= \case - Just Message {msgTs} - | systemSeconds msgTs < old -> - tryDeleteMsg_ q mq False >> loop (dc + 1) - _ -> pure dc diff --git a/src/Simplex/Messaging/Server/Prometheus.hs b/src/Simplex/Messaging/Server/Prometheus.hs index 85d2624fd..65a8a0ecc 100644 --- a/src/Simplex/Messaging/Server/Prometheus.hs +++ b/src/Simplex/Messaging/Server/Prometheus.hs @@ -46,7 +46,7 @@ data RealTimeMetrics = RealTimeMetrics deliveredTimes :: TimeBuckets, smpSubs :: RTSubscriberMetrics, ntfSubs :: RTSubscriberMetrics, - loadedCounts :: LoadedQueueCounts + loadedCounts :: Maybe LoadedQueueCounts } data RTSubscriberMetrics = RTSubscriberMetrics @@ -562,27 +562,17 @@ prometheusMetrics sm rtm ts = \\n\ \# HELP simplex_smp_subscription_ntf_service_subs_total Total queues subscribed via NTF services\n\ \# 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\ + \simplex_smp_subscription_ntf_service_subs_total " <> mshow (subServiceSubsCount ntfSubs) <> "\n# ntf.subServiceSubsCount\n" + <> maybe "" loadedQueues loadedCounts + loadedQueues LoadedQueueCounts {loadedQueueCount, loadedNotifierCount} = + "\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\ + \simplex_smp_loaded_queues_queue_count " <> mshow loadedQueueCount <> "\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\ - \# TYPE simplex_smp_loaded_queues_ntf_lock_count gauge\n\ - \simplex_smp_loaded_queues_ntf_lock_count " <> mshow (notifierLockCount loadedCounts) <> "\n# loadedCounts.notifierLockCount\n" + \simplex_smp_loaded_queues_ntf_count " <> mshow loadedNotifierCount <> "\n# loadedCounts.loadedNotifierCount\n" showTimeBuckets :: Text -> IM.IntMap Int -> Text showTimeBuckets metric = T.concat . snd . mapAccumL accumBucket (0, 0) . IM.assocs diff --git a/src/Simplex/Messaging/Server/QueueStore/Postgres.hs b/src/Simplex/Messaging/Server/QueueStore/Postgres.hs index 7e419a916..0c7327776 100644 --- a/src/Simplex/Messaging/Server/QueueStore/Postgres.hs +++ b/src/Simplex/Messaging/Server/QueueStore/Postgres.hs @@ -24,9 +24,7 @@ module Simplex.Messaging.Server.QueueStore.Postgres batchInsertServices, batchInsertQueues, foldServiceRecs, - foldRcvServiceQueueRecs, foldQueueRecs, - foldRecentQueueRecs, handleDuplicate, rowToQueueRec, withLog_, @@ -43,13 +41,12 @@ import Control.Monad import Control.Monad.Except import Control.Monad.IO.Class import Control.Monad.Trans.Except -import Data.Bifunctor (first) import Data.ByteString.Builder (Builder) import qualified Data.ByteString.Builder as BB import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Lazy as LB import Data.Bitraversable (bimapM) -import Data.Either (fromRight, lefts) +import Data.Either (fromRight) import Data.Functor (($>)) import Data.Int (Int64) import Data.List (foldl', intersperse, partition) @@ -91,7 +88,7 @@ import Simplex.Messaging.SystemTime import Simplex.Messaging.TMap (TMap) import qualified Simplex.Messaging.TMap as TM import Simplex.Messaging.Transport (SMPServiceRole (..)) -import Simplex.Messaging.Util (eitherToMaybe, firstRow, ifM, maybeFirstRow, maybeFirstRow', tshow, (<$$>), ($>>=)) +import Simplex.Messaging.Util (eitherToMaybe, firstRow, maybeFirstRow, maybeFirstRow', tshow, (<$$>), ($>>=)) import System.Exit (exitFailure) import System.IO (IOMode (..), hFlush, stdout) import UnliftIO.STM @@ -103,33 +100,19 @@ import Simplex.Messaging.Encoding.String data PostgresQueueStore q = PostgresQueueStore { dbStore :: DBStore, dbStoreLog :: Maybe (StoreLog 'WriteMode), - -- this map caches all created and opened queues - queues :: TMap RecipientId q, - -- this map only cashes the queues that were attempted to send messages to, - senders :: TMap SenderId RecipientId, - -- this map only cashes the queues that were attempted to be subscribed to, - notifiers :: TMap NotifierId RecipientId, - notifierLocks :: TMap NotifierId Lock, serviceLocks :: TMap CertFingerprint Lock, - deletedTTL :: Int64, - useCache :: Bool + deletedTTL :: Int64 } -type UseQueueCache = Bool - instance StoreQueueClass q => QueueStoreClass q (PostgresQueueStore q) where - type QueueStoreCfg (PostgresQueueStore q) = (PostgresStoreCfg, UseQueueCache) + type QueueStoreCfg (PostgresQueueStore q) = PostgresStoreCfg - newQueueStore :: (PostgresStoreCfg, UseQueueCache) -> IO (PostgresQueueStore q) - newQueueStore (PostgresStoreCfg {dbOpts, dbStoreLogPath, confirmMigrations, deletedTTL}, useCache) = do + newQueueStore :: PostgresStoreCfg -> IO (PostgresQueueStore q) + newQueueStore PostgresStoreCfg {dbOpts, dbStoreLogPath, confirmMigrations, deletedTTL} = do dbStore <- either err pure =<< createDBStore dbOpts serverMigrations (MigrationConfig confirmMigrations Nothing) dbStoreLog <- mapM (openWriteStoreLog True) dbStoreLogPath - queues <- TM.emptyIO - senders <- TM.emptyIO - notifiers <- TM.emptyIO - notifierLocks <- TM.emptyIO serviceLocks <- TM.emptyIO - pure PostgresQueueStore {dbStore, dbStoreLog, queues, senders, notifiers, notifierLocks, serviceLocks, deletedTTL, useCache} + pure PostgresQueueStore {dbStore, dbStoreLog, serviceLocks, deletedTTL} where err e = do logError $ "STORE: newQueueStore, error opening PostgreSQL database, " <> tshow e @@ -140,9 +123,6 @@ instance StoreQueueClass q => QueueStoreClass q (PostgresQueueStore q) where closeDBStore dbStore mapM_ closeStoreLog dbStoreLog - loadedQueues = queues - {-# INLINE loadedQueues #-} - compactQueues :: PostgresQueueStore q -> IO Int64 compactQueues st@PostgresQueueStore {deletedTTL} = do old <- subtract deletedTTL . systemSeconds <$> liftIO getSystemTime @@ -168,160 +148,45 @@ instance StoreQueueClass q => QueueStoreClass q (PostgresQueueStore q) where (SRMessaging, SRNotifier) pure EntityCounts {queueCount, notifierCount, rcvServiceCount, ntfServiceCount, rcvServiceQueuesCount, ntfServiceQueuesCount} - -- this implementation assumes that the lock is already taken by addQueue - -- and relies on unique constraints in the database to prevent duplicate IDs. + -- this implementation relies on unique constraints in the database to prevent duplicate IDs. addQueue_ :: PostgresQueueStore q -> (RecipientId -> QueueRec -> IO q) -> RecipientId -> QueueRec -> IO (Either ErrorType q) addQueue_ st mkQ rId qr = do - sq <- mkQ rId qr {queueData = withoutLinkData . fst <$> queueData qr} - withQueueLock sq "addQueue_" $ E.uninterruptibleMask_ $ runExceptT $ do + sq <- mkQ rId qr + E.uninterruptibleMask_ $ runExceptT $ do void $ withDB "addQueue_" st $ \db -> E.try (DB.execute db insertQueueQuery $ queueRecToRow (rId, qr)) - >>= bimapM (\e -> unless (isRecipientIdViolation e) (removeQueueLock sq) >> handleDuplicate e) pure - when useCache $ do - atomically $ TM.insert rId sq queues - atomically $ TM.insert (senderId qr) rId senders - forM_ (notifier qr) $ \NtfCreds {notifierId = nId} -> atomically $ TM.insert nId rId notifiers + >>= bimapM handleDuplicate pure withLog "addStoreQueue" st $ \s -> logCreateQueue s rId qr pure sq - where - PostgresQueueStore {queues, senders, notifiers, useCache} = st - -- the lock is kept when another queue has the same recipient ID - isRecipientIdViolation e = constraintViolation e == Just (UniqueViolation "msg_queues_pkey") - -- Not doing duplicate checks in maps as the probability of duplicates is very low. - -- It needs to be reconsidered when IDs are supplied by the users. - -- hasId = anyM [TM.memberIO rId queues, TM.memberIO senderId senders, hasNotifier] - -- hasNotifier = maybe (pure False) (\NtfCreds {notifierId} -> TM.memberIO notifierId notifiers) notifier - getQueue_ :: QueueParty p => PostgresQueueStore q -> (Bool -> RecipientId -> QueueRec -> IO q) -> SParty p -> QueueId -> IO (Either ErrorType q) - getQueue_ st mkQ party qId - | useCache = case party of - SRecipient -> getRcvQueue qId - SSender -> TM.lookupIO qId senders >>= maybe (mask loadSndQueue) getRcvQueue - SSenderLink -> mask loadLinkQueue - -- loaded queue is deleted from notifiers map to reduce cache size after queue was subscribed to by ntf server - SNotifier -> TM.lookupIO qId notifiers >>= maybe (mask loadNtfQueue) (getRcvQueue >=> (atomically (TM.delete qId notifiers) $>)) - | otherwise = case party of - SRecipient -> loadQueueNoCache " WHERE recipient_id = ?" - SSender -> loadQueueNoCache " WHERE sender_id = ?" - SSenderLink -> loadQueueNoCache " WHERE link_id = ?" - SNotifier -> loadQueueNoCache " WHERE notifier_id = ?" + getQueue_ :: QueueParty p => PostgresQueueStore q -> (RecipientId -> QueueRec -> IO q) -> SParty p -> QueueId -> IO (Either ErrorType q) + getQueue_ st mkQ party qId = case party of + SRecipient -> loadQueue " WHERE recipient_id = ?" + SSender -> loadQueue " WHERE sender_id = ?" + SSenderLink -> loadQueue " WHERE link_id = ?" + SNotifier -> loadQueue " WHERE notifier_id = ?" where - PostgresQueueStore {queues, senders, notifiers, useCache} = st - getRcvQueue rId = TM.lookupIO rId queues >>= maybe (mask loadRcvQueue) (pure . Right) - loadRcvQueue = do - (rId, qRec) <- loadQueue " WHERE recipient_id = ?" - cacheQueue rId qRec $ \_ -> pure () -- recipient map already checked, not caching sender ref - loadSndQueue = loadSndQueue_ " WHERE sender_id = ?" cacheSender - -- link IDs are supplied by clients, they are not cached to prevent collisions with sender IDs - loadLinkQueue = loadSndQueue_ " WHERE link_id = ?" $ \_ -> pure () - loadNtfQueue = do - (rId, qRec) <- loadQueue " WHERE notifier_id = ?" - liftIO $ - TM.lookupIO rId queues -- checking recipient map first, not creating lock in map, not caching queue - >>= maybe (mkQ False rId qRec) pure - loadSndQueue_ condition insertRef = do - (rId, qRec) <- loadQueue condition - -- checking recipient map first, ref is only cached for the queue in the map - atomically (TM.lookup rId queues >>= mapM (\sq -> sq <$ insertRef rId)) - >>= maybe (cacheQueue rId qRec insertRef) pure - loadQueueNoCache cond = mask $ loadQueue cond >>= liftIO . uncurry (mkQ True) - mask = E.uninterruptibleMask_ . runExceptT - cacheSender rId = TM.insert qId rId senders - loadQueue condition = loadQueueBy condition qId - loadQueueBy condition qId' = - withDB "getQueue_" st $ \db -> firstRow rowToQueueRec AUTH $ - DB.query db (queueRecQuery <> condition <> " AND deleted_at IS NULL") (Only qId') - cacheQueue rId qRec insertRef = do - sq <- liftIO $ mkQ True rId qRec -- loaded queue - -- This lock prevents the scenario when the queue is added to cache, - -- while another thread is proccessing the same queue in withAllMsgQueues - -- without adding it to cache, possibly trying to open the same files twice. - -- Alse see comment in idleDeleteExpiredMsgs. - ExceptT $ withQueueLock sq "getQueue_" $ runExceptT $ do - -- the queue could have been deleted after it was loaded and before the lock was taken - (_, qRec') <- loadQueueBy " WHERE recipient_id = ?" rId `catchE` \case - AUTH -> liftIO (removeQueueLock sq) >> throwE AUTH - e -> throwE e - atomically $ - -- checking the cache again for concurrent reads, - -- use previously loaded queue if exists. - TM.lookup rId queues >>= \case - Just sq' -> pure sq' - Nothing -> do - writeTVar (queueRec sq) $ Just qRec' - insertRef rId - TM.insert rId sq queues - pure sq + loadQueue condition = E.uninterruptibleMask_ $ runExceptT $ do + (rId, qRec) <- withDB "getQueue_" st $ \db -> firstRow rowToQueueRec AUTH $ + DB.query db (queueRecQuery <> condition <> " AND deleted_at IS NULL") (Only qId) + liftIO $ mkQ rId qRec - getQueues_ :: forall p. BatchParty p => PostgresQueueStore q -> (Bool -> RecipientId -> QueueRec -> IO q) -> SParty p -> [QueueId] -> IO [Either ErrorType q] + getQueues_ :: forall p. BatchParty p => PostgresQueueStore q -> (RecipientId -> QueueRec -> IO q) -> SParty p -> [QueueId] -> IO [Either ErrorType q] getQueues_ st mkQ party qIds | null qIds = pure [] - | useCache = case party of - SRecipient -> do - qs <- readTVarIO queues - let qs' = map (\qId -> get qs qId qId) qIds - E.uninterruptibleMask_ $ loadQueues qs' " WHERE recipient_id IN ?" cacheRcvQueue >>= uncacheDeleted (lefts qs') - SNotifier -> do - ns <- readTVarIO notifiers - qs <- readTVarIO queues - let qs' = map (\qId -> get ns qId qId >>= get qs qId) qIds - E.uninterruptibleMask_ $ loadQueues qs' " WHERE notifier_id IN ?" $ \(rId, qRec) -> - forM (notifier qRec) $ \NtfCreds {notifierId = nId} -> -- it is always Just with this query - (nId,) <$> maybe (mkQ False rId qRec) pure (M.lookup rId qs) | otherwise = E.uninterruptibleMask_ $ case party of - SRecipient -> loadQueuesNoCache " WHERE recipient_id IN ?" $ \(rId, qRec) -> - Just . (rId,) <$> mkQ False rId qRec - SNotifier -> loadQueuesNoCache " WHERE notifier_id IN ?" $ \(rId, qRec) -> - forM (notifier qRec) $ \NtfCreds {notifierId = nId} -> (nId,) <$> mkQ False rId qRec + SRecipient -> loadQueues " WHERE recipient_id IN ?" $ \(rId, qRec) -> + Just . (rId,) <$> mkQ rId qRec + SNotifier -> loadQueues " WHERE notifier_id IN ?" $ \(rId, qRec) -> + forM (notifier qRec) $ \NtfCreds {notifierId = nId} -> (nId,) <$> mkQ rId qRec where - PostgresQueueStore {queues, notifiers, useCache} = st - get :: M.Map QueueId a -> QueueId -> QueueId -> Either QueueId a - get m qId = maybe (Left qId) Right . (`M.lookup` m) - loadQueues :: [Either QueueId q] -> Query -> ((RecipientId, QueueRec) -> IO (Maybe (QueueId, q))) -> IO [Either ErrorType q] - loadQueues qs' cond mkCacheQueue = do - let qIds' = lefts qs' - if null qIds' - then pure $ map (first (const INTERNAL)) qs' - else do - qs_ <- dbLoadQueues qIds' cond mkCacheQueue - pure $ map (result qs_) qs' - where - result :: Either ErrorType (M.Map QueueId q) -> Either QueueId q -> Either ErrorType q - result _ (Right q) = Right q - result qs_ (Left qId) = maybe (Left AUTH) Right . M.lookup qId =<< qs_ - dbLoadQueues qIds' cond mkQueue' = - runExceptT $ fmap M.fromList $ - withDB' "getQueues_" st (\db -> DB.query db (queueRecQuery <> cond <> " AND deleted_at IS NULL") (Only (In qIds'))) - >>= liftIO . fmap catMaybes . mapM (mkQueue' . rowToQueueRec) - cacheRcvQueue (rId, qRec) = do - sq <- mkQ True rId qRec - sq' <- withQueueLock sq "getQueue_" $ atomically $ - -- checking the cache again for concurrent reads, use previously loaded queue if exists. - TM.lookup rId queues >>= \case - Just sq' -> pure sq' - Nothing -> sq <$ TM.insert rId sq queues - pure $ Just (rId, sq') - -- the queues could have been deleted after they were loaded and before they were cached - uncacheDeleted :: [RecipientId] -> [Either ErrorType q] -> IO [Either ErrorType q] - uncacheDeleted qIds' rs = case filter (`S.member` S.fromList qIds') [recipientId sq | Right sq <- rs] of - [] -> pure rs - rIds -> - runExceptT (withDB' "getQueues_" st $ \db -> DB.query db "SELECT recipient_id FROM msg_queues WHERE recipient_id IN ? AND deleted_at IS NULL" (Only (In rIds))) >>= \case - Right live -> mapM (uncache $ S.fromList rIds `S.difference` S.fromList (map fromOnly live)) rs - Left _ -> pure rs - uncache deleted = \case - Right sq | S.member (recipientId sq) deleted -> do - withQueueLock sq "getQueues_" $ do - atomically $ writeTVar (queueRec sq) Nothing >> TM.delete (recipientId sq) queues - removeQueueLock sq - pure $ Left AUTH - r -> pure r - loadQueuesNoCache cond mkQueue' = do - qs_ <- dbLoadQueues qIds cond mkQueue' - pure $ map (result qs_) qIds - where - result :: Either ErrorType (M.Map QueueId q) -> QueueId -> Either ErrorType q - result qs_ qId = maybe (Left AUTH) Right . M.lookup qId =<< qs_ + loadQueues :: Query -> ((RecipientId, QueueRec) -> IO (Maybe (QueueId, q))) -> IO [Either ErrorType q] + loadQueues cond mkQueue' = do + qs_ <- + runExceptT $ fmap M.fromList $ + withDB' "getQueues_" st (\db -> DB.query db (queueRecQuery <> cond <> " AND deleted_at IS NULL") (Only (In qIds))) + >>= liftIO . fmap catMaybes . mapM (mkQueue' . rowToQueueRec) + pure $ map (\qId -> maybe (Left AUTH) Right . M.lookup qId =<< qs_) qIds getQueueLinkData :: PostgresQueueStore q -> q -> LinkId -> IO (Either ErrorType QueueLinkData) getQueueLinkData st sq lnkId = runExceptT $ do @@ -334,7 +199,7 @@ instance StoreQueueClass q => QueueStoreClass q (PostgresQueueStore q) where addQueueLinkData :: PostgresQueueStore q -> q -> LinkId -> QueueLinkData -> IO (Either ErrorType ()) addQueueLinkData st sq lnkId d = - withQueueRec sq "addQueueLinkData" $ \q -> case queueData q of + withQueueRec sq $ \q -> case queueData q of Nothing -> addLink q $ \db -> DB.execute db qry (d :. (lnkId, rId)) Just (lnkId', _) | lnkId' == lnkId -> @@ -344,13 +209,13 @@ instance StoreQueueClass q => QueueStoreClass q (PostgresQueueStore q) where rId = recipientId sq addLink q update = do assertUpdated $ withDB' "addQueueLinkData" st update - atomically $ writeTVar (queueRec sq) $ Just q {queueData = Just $ withoutLinkData lnkId} + atomically $ writeTVar (queueRec sq) $ Just q {queueData = Just (lnkId, d)} withLog "addQueueLinkData" st $ \s -> logCreateLink s rId lnkId d qry = "UPDATE msg_queues SET fixed_data = ?, user_data = ?, link_id = ? WHERE recipient_id = ? AND deleted_at IS NULL" deleteQueueLinkData :: PostgresQueueStore q -> q -> IO (Either ErrorType ()) deleteQueueLinkData st sq = - withQueueRec sq "deleteQueueLinkData" $ \q -> case queueData q of + withQueueRec sq $ \q -> case queueData q of Just _ -> do assertUpdated $ withDB' "deleteQueueLinkData" st $ \db -> DB.execute db "UPDATE msg_queues SET link_id = NULL, fixed_data = NULL, user_data = NULL WHERE recipient_id = ? AND deleted_at IS NULL" (Only rId) @@ -362,7 +227,7 @@ instance StoreQueueClass q => QueueStoreClass q (PostgresQueueStore q) where secureQueue :: PostgresQueueStore q -> q -> SndPublicAuthKey -> IO (Either ErrorType ()) secureQueue st sq sKey = - withQueueRec sq "secureQueue" $ \q -> do + withQueueRec sq $ \q -> do verify q assertUpdated $ withDB' "secureQueue" st $ \db -> DB.execute db "UPDATE msg_queues SET sender_key = ? WHERE recipient_id = ? AND deleted_at IS NULL AND (sender_key IS NULL OR sender_key = ?)" (sKey, rId, sKey) @@ -376,7 +241,7 @@ instance StoreQueueClass q => QueueStoreClass q (PostgresQueueStore q) where updateKeys :: PostgresQueueStore q -> q -> NonEmpty RcvPublicAuthKey -> IO (Either ErrorType ()) updateKeys st sq rKeys = - withQueueRec sq "updateKeys" $ \q -> do + withQueueRec sq $ \q -> do assertUpdated $ withDB' "updateKeys" st $ \db -> DB.execute db "UPDATE msg_queues SET recipient_keys = ? WHERE recipient_id = ? AND deleted_at IS NULL" (rKeys, rId) atomically $ writeTVar (queueRec sq) $ Just q {recipientKeys = rKeys} @@ -386,24 +251,14 @@ instance StoreQueueClass q => QueueStoreClass q (PostgresQueueStore q) where addQueueNotifier :: PostgresQueueStore q -> q -> NtfCreds -> IO (Either ErrorType (Maybe NtfCreds)) addQueueNotifier st sq ntfCreds@NtfCreds {notifierId = nId, notifierKey, rcvNtfDhSecret} = - withQueueRec sq "addQueueNotifier" $ \q -> - checkCachedNotifier $ do - assertUpdated $ withDB "addQueueNotifier" st $ \db -> - E.try (update db) >>= bimapM handleDuplicate pure - nc_ <- forM (notifier q) $ \nc@NtfCreds {notifierId} -> atomically (TM.delete notifierId notifiers) $> nc - let !q' = q {notifier = Just ntfCreds} - atomically $ writeTVar (queueRec sq) $ Just q' - when useCache $ do - atomically $ TM.insert nId rId notifiers - withLog "addQueueNotifier" st $ \s -> logAddNotifier s rId ntfCreds - pure nc_ + withQueueRec sq $ \q -> do + assertUpdated $ withDB "addQueueNotifier" st $ \db -> + E.try (update db) >>= bimapM handleDuplicate pure + let !q' = q {notifier = Just ntfCreds} + atomically $ writeTVar (queueRec sq) $ Just q' + withLog "addQueueNotifier" st $ \s -> logAddNotifier s rId ntfCreds + pure $ notifier q where - checkCachedNotifier add - | useCache = - ExceptT $ withLockMap (notifierLocks st) nId "addQueueNotifier" $ - ifM (TM.memberIO nId notifiers) (pure $ Left DUPLICATE_) $ runExceptT add - | otherwise = add - PostgresQueueStore {notifiers, useCache} = st rId = recipientId sq update db = DB.execute @@ -417,18 +272,13 @@ instance StoreQueueClass q => QueueStoreClass q (PostgresQueueStore q) where deleteQueueNotifier :: PostgresQueueStore q -> q -> IO (Either ErrorType (Maybe NtfCreds)) deleteQueueNotifier st sq = - withQueueRec sq "deleteQueueNotifier" $ \q -> - ExceptT $ fmap sequence $ forM (notifier q) $ \nc@NtfCreds {notifierId = nId} -> - withNotifierLock nId $ runExceptT $ do - assertUpdated $ withDB' "deleteQueueNotifier" st update - when (useCache st) $ atomically $ TM.delete nId $ notifiers st - atomically $ writeTVar (queueRec sq) $ Just q {notifier = Nothing} - withLog "deleteQueueNotifier" st (`logDeleteNotifier` rId) - pure nc + withQueueRec sq $ \q -> + forM (notifier q) $ \nc -> do + assertUpdated $ withDB' "deleteQueueNotifier" st update + atomically $ writeTVar (queueRec sq) $ Just q {notifier = Nothing} + withLog "deleteQueueNotifier" st (`logDeleteNotifier` rId) + pure nc where - withNotifierLock nId - | useCache st = withLockMap (notifierLocks st) nId "deleteQueueNotifier" - | otherwise = id rId = recipientId sq update db = DB.execute @@ -457,7 +307,7 @@ instance StoreQueueClass q => QueueStoreClass q (PostgresQueueStore q) where updateQueueTime :: PostgresQueueStore q -> q -> SystemDate -> IO (Either ErrorType QueueRec) updateQueueTime st sq t = - withQueueRec sq "updateQueueTime" $ \q@QueueRec {updatedAt} -> + withQueueRec sq $ \q@QueueRec {updatedAt} -> if updatedAt == Just t then pure q else do @@ -470,7 +320,6 @@ instance StoreQueueClass q => QueueStoreClass q (PostgresQueueStore q) where where rId = recipientId sq - -- this method is called from JournalMsgStore deleteQueue that already locks the queue deleteStoreQueue :: PostgresQueueStore q -> q -> IO (Either ErrorType QueueRec) deleteStoreQueue st sq = E.uninterruptibleMask_ $ runExceptT $ do q <- ExceptT $ readQueueRecIO qr @@ -478,13 +327,6 @@ instance StoreQueueClass q => QueueStoreClass q (PostgresQueueStore q) where assertUpdated $ withDB' "deleteStoreQueue" st $ \db -> DB.execute db "UPDATE msg_queues SET deleted_at = ? WHERE recipient_id = ? AND deleted_at IS NULL" (ts, rId) atomically $ writeTVar qr Nothing - when (useCache st) $ do - atomically $ do - TM.delete rId $ queues st - TM.delete (senderId q) $ senders st - forM_ (notifier q) $ \NtfCreds {notifierId} -> do - atomically $ TM.delete notifierId $ notifiers st - atomically $ TM.delete notifierId $ notifierLocks st withLog "deleteStoreQueue" st (`logDeleteQueue` rId) pure q where @@ -507,7 +349,7 @@ instance StoreQueueClass q => QueueStoreClass q (PostgresQueueStore q) where pure serviceId setQueueService :: (PartyI p, ServiceParty p) => PostgresQueueStore q -> q -> SParty p -> Maybe ServiceId -> IO (Either ErrorType ()) - setQueueService st sq party serviceId = withQueueRec sq "setQueueService" $ \q -> case party of + setQueueService st sq party serviceId = withQueueRec sq $ \q -> case party of SRecipientService | rcvServiceId q == serviceId -> pure () | otherwise -> do @@ -632,33 +474,8 @@ foldServiceRecs st f = DB.fold_ db "SELECT service_id, service_role, service_cert, service_cert_hash, created_at FROM services" mempty $ \ !acc -> fmap (acc <>) . f . rowToServiceRec -foldRcvServiceQueueRecs :: PostgresQueueStore q -> ServiceId -> (a -> (RecipientId, QueueRec) -> IO a) -> a -> IO (Either ErrorType a) -foldRcvServiceQueueRecs st serviceId f acc = - runExceptT $ withDB' "foldRcvServiceQueueRecs" st $ \db -> - DB.fold db (queueRecQuery <> " WHERE rcv_service_id = ? AND deleted_at IS NULL") (Only serviceId) acc $ \a -> f a . rowToQueueRec - foldQueueRecs :: Monoid a => Bool -> Bool -> PostgresQueueStore q -> ((RecipientId, QueueRec) -> IO a) -> IO a -foldQueueRecs withData = foldQueueRecs_ foldRecs - where - foldRecs db acc f' - | withData = DB.fold_ db (queueRecQueryWithData <> cond) acc $ \acc' -> f' acc' . rowToQueueRecWithData - | otherwise = DB.fold_ db (queueRecQuery <> cond) acc $ \acc' -> f' acc' . rowToQueueRec - cond = " WHERE deleted_at IS NULL ORDER BY recipient_id ASC" - -foldRecentQueueRecs :: Monoid a => Int64 -> Bool -> PostgresQueueStore q -> ((RecipientId, QueueRec) -> IO a) -> IO a -foldRecentQueueRecs old = foldQueueRecs_ foldRecs - where - foldRecs db acc f' = DB.fold db (queueRecQuery <> cond) (Only old) acc $ \acc' -> f' acc' . rowToQueueRec - cond = " WHERE deleted_at IS NULL AND updated_at > ? ORDER BY recipient_id ASC" - -foldQueueRecs_ :: - Monoid a => - (DB.Connection -> (Int, a) -> ((Int, a) -> (RecipientId, QueueRec) -> IO (Int, a)) -> IO (Int, a)) -> - Bool -> - PostgresQueueStore q -> - ((RecipientId, QueueRec) -> IO a) -> - IO a -foldQueueRecs_ foldRecs tty st f = do +foldQueueRecs withData tty st f = do (n, r) <- withTransaction (dbStore st) $ \db -> foldRecs db (0 :: Int, mempty) $ \(i, acc) qr -> do r <- f qr @@ -669,6 +486,10 @@ foldQueueRecs_ foldRecs tty st f = do when tty $ putStrLn $ progress n pure r where + foldRecs db acc f' + | withData = DB.fold_ db (queueRecQueryWithData <> cond) acc $ \acc' -> f' acc' . rowToQueueRecWithData + | otherwise = DB.fold_ db (queueRecQuery <> cond) acc $ \acc' -> f' acc' . rowToQueueRec + cond = " WHERE deleted_at IS NULL ORDER BY recipient_id ASC" progress i = "Processed: " <> show i <> " records" queueRecQuery :: Query @@ -749,7 +570,7 @@ queueDataColumns = \case rowToQueueRec :: QueueRecRow -> (RecipientId, QueueRec) rowToQueueRec (rId, recipientKeys, rcvDhSecret, senderId, senderKey, queueMode, notifierId_, notifierKey_, rcvNtfDhSecret_, ntfServiceId, status, updatedAt, linkId_, rcvServiceId) = let notifier = mkNotifier (notifierId_, notifierKey_, rcvNtfDhSecret_) ntfServiceId - queueData = withoutLinkData <$> linkId_ + queueData = (,(EncDataBytes "", EncDataBytes "")) <$> linkId_ in (rId, QueueRec {recipientKeys, rcvDhSecret, senderId, senderKey, queueMode, queueData, notifier, status, updatedAt, rcvServiceId}) rowToQueueRecWithData :: QueueRecRow :. (Maybe EncDataBytes, Maybe EncDataBytes) -> (RecipientId, QueueRec) @@ -759,10 +580,6 @@ rowToQueueRecWithData ((rId, recipientKeys, rcvDhSecret, senderId, senderKey, qu queueData = (,(encData immutableData_, encData userData_)) <$> linkId_ in (rId, QueueRec {recipientKeys, rcvDhSecret, senderId, senderKey, queueMode, queueData, notifier, status, updatedAt, rcvServiceId}) --- link data is read from the database when requested -withoutLinkData :: LinkId -> (LinkId, QueueLinkData) -withoutLinkData = (,(EncDataBytes "", EncDataBytes "")) - mkNotifier :: (Maybe NotifierId, Maybe NtfPublicAuthKey, Maybe RcvNtfDhSecret) -> Maybe ServiceId -> Maybe NtfCreds mkNotifier (Just notifierId, Just notifierKey, Just rcvNtfDhSecret) ntfServiceId = Just NtfCreds {notifierId, notifierKey, rcvNtfDhSecret, ntfServiceId} @@ -778,15 +595,15 @@ rowToServiceRec (serviceId, serviceRole, serviceCert, Binary fp, serviceCreatedA setStatusDB :: StoreQueueClass q => Text -> PostgresQueueStore q -> q -> ServerEntityStatus -> ExceptT ErrorType IO () -> IO (Either ErrorType ()) setStatusDB op st sq status writeLog = - withQueueRec sq op $ \q -> do + withQueueRec sq $ \q -> do assertUpdated $ withDB' op st $ \db -> DB.execute db "UPDATE msg_queues SET status = ? WHERE recipient_id = ? AND deleted_at IS NULL" (status, recipientId sq) atomically $ writeTVar (queueRec sq) $ Just q {status} writeLog -withQueueRec :: StoreQueueClass q => q -> Text -> (QueueRec -> ExceptT ErrorType IO a) -> IO (Either ErrorType a) -withQueueRec sq op action = - withQueueLock sq op $ E.uninterruptibleMask_ $ runExceptT $ ExceptT (readQueueRecIO $ queueRec sq) >>= action +withQueueRec :: StoreQueueClass q => q -> (QueueRec -> ExceptT ErrorType IO a) -> IO (Either ErrorType a) +withQueueRec sq action = + E.uninterruptibleMask_ $ runExceptT $ ExceptT (readQueueRecIO $ queueRec sq) >>= action assertUpdated :: ExceptT ErrorType IO Int64 -> ExceptT ErrorType IO () assertUpdated = (>>= \n -> when (n == 0) (throwE AUTH)) diff --git a/src/Simplex/Messaging/Server/QueueStore/STM.hs b/src/Simplex/Messaging/Server/QueueStore/STM.hs index 418c34647..fa33f7d88 100644 --- a/src/Simplex/Messaging/Server/QueueStore/STM.hs +++ b/src/Simplex/Messaging/Server/QueueStore/STM.hs @@ -18,6 +18,7 @@ module Simplex.Messaging.Server.QueueStore.STM ( STMQueueStore (..), STMService (..), foldRcvServiceQueues, + withLoadedQueues, setStoreLog, withLog', readQueueRecIO, @@ -47,7 +48,7 @@ import Simplex.Messaging.SystemTime import Simplex.Messaging.TMap (TMap) import qualified Simplex.Messaging.TMap as TM import Simplex.Messaging.Transport (SMPServiceRole (..)) -import Simplex.Messaging.Util (anyM, ifM, tshow, unlessM, ($>>), ($>>=), (<$$), (<$$>)) +import Simplex.Messaging.Util (anyM, ifM, tshow, ($>>), ($>>=), (<$$), (<$$>)) import System.IO import UnliftIO.STM @@ -91,8 +92,6 @@ instance StoreQueueClass q => QueueStoreClass q (STMQueueStore q) where atomically $ TM.clear senders atomically $ TM.clear notifiers - loadedQueues = queues - {-# INLINE loadedQueues #-} compactQueues _ = pure 0 {-# INLINE compactQueues #-} @@ -119,10 +118,7 @@ instance StoreQueueClass q => QueueStoreClass q (STMQueueStore q) where addQueue_ :: STMQueueStore q -> (RecipientId -> QueueRec -> IO q) -> RecipientId -> QueueRec -> IO (Either ErrorType q) addQueue_ st mkQ rId qr@QueueRec {senderId = sId, notifier, queueData, rcvServiceId} = do sq <- mkQ rId qr - add sq >>= \case - Right () -> withLog "addStoreQueue" st (\s -> logCreateQueue s rId qr) $> Right sq - -- the lock is kept when another queue has the same recipient ID - Left e -> Left e <$ unlessM (TM.memberIO rId queues) (removeQueueLock sq) + add sq $>> withLog "addStoreQueue" st (\s -> logCreateQueue s rId qr) $> Right sq where STMQueueStore {queues, senders, notifiers, links} = st add q = atomically $ ifM hasId (pure $ Left DUPLICATE_) $ Right () <$ do @@ -137,7 +133,7 @@ instance StoreQueueClass q => QueueStoreClass q (STMQueueStore q) where hasNotifier = maybe (pure False) (\NtfCreds {notifierId} -> TM.member notifierId notifiers) notifier hasLink = maybe (pure False) (\(lnkId, _) -> TM.member lnkId links) queueData - getQueue_ :: QueueParty p => STMQueueStore q -> (Bool -> RecipientId -> QueueRec -> IO q) -> SParty p -> QueueId -> IO (Either ErrorType q) + getQueue_ :: QueueParty p => STMQueueStore q -> (RecipientId -> QueueRec -> IO q) -> SParty p -> QueueId -> IO (Either ErrorType q) getQueue_ st _ party qId = maybe (Left AUTH) Right <$> case party of SRecipient -> TM.lookupIO qId queues @@ -147,7 +143,7 @@ instance StoreQueueClass q => QueueStoreClass q (STMQueueStore q) where where STMQueueStore {queues, senders, notifiers, links} = st - getQueues_ :: BatchParty p => STMQueueStore q -> (Bool -> RecipientId -> QueueRec -> IO q) -> SParty p -> [QueueId] -> IO [Either ErrorType q] + getQueues_ :: BatchParty p => STMQueueStore q -> (RecipientId -> QueueRec -> IO q) -> SParty p -> [QueueId] -> IO [Either ErrorType q] getQueues_ st _ party qIds = case party of SRecipient -> do qs <- readTVarIO queues @@ -383,6 +379,11 @@ foldRcvServiceQueues st serviceId f acc = where get rId = TM.lookupIO rId (queues st) $>>= \q -> (q,) <$$> readTVarIO (queueRec q) +withLoadedQueues :: Monoid a => STMQueueStore q -> (q -> IO a) -> IO a +withLoadedQueues st f = readTVarIO (queues st) >>= foldM run mempty + where + run !acc = fmap (acc <>) . f + withQueueRec :: TVar (Maybe QueueRec) -> (QueueRec -> STM a) -> IO (Either ErrorType a) withQueueRec qr a = atomically $ readQueueRec qr >>= mapM a diff --git a/src/Simplex/Messaging/Server/QueueStore/Types.hs b/src/Simplex/Messaging/Server/QueueStore/Types.hs index 84cd7b4a7..e8d47751b 100644 --- a/src/Simplex/Messaging/Server/QueueStore/Types.hs +++ b/src/Simplex/Messaging/Server/QueueStore/Types.hs @@ -1,5 +1,4 @@ {-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE BangPatterns #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-} @@ -9,37 +8,29 @@ module Simplex.Messaging.Server.QueueStore.Types ( StoreQueueClass (..), QueueStoreClass (..), EntityCounts (..), - withLoadedQueues, ) where import Control.Concurrent.STM -import Control.Monad import Data.Int (Int64) import Data.List.NonEmpty (NonEmpty) import Data.Map.Strict (Map) -import Data.Text (Text) import Simplex.Messaging.Protocol import Simplex.Messaging.Server.QueueStore import Simplex.Messaging.SystemTime -import Simplex.Messaging.TMap (TMap) class StoreQueueClass q where recipientId :: q -> RecipientId queueRec :: q -> TVar (Maybe QueueRec) - withQueueLock :: q -> Text -> IO a -> IO a - -- must only be called for deleted or not added queues - removeQueueLock :: q -> IO () class StoreQueueClass q => QueueStoreClass q s where type QueueStoreCfg s newQueueStore :: QueueStoreCfg s -> IO s closeQueueStore :: s -> IO () getEntityCounts :: s -> IO EntityCounts - loadedQueues :: s -> TMap RecipientId q compactQueues :: s -> IO Int64 addQueue_ :: s -> (RecipientId -> QueueRec -> IO q) -> RecipientId -> QueueRec -> IO (Either ErrorType q) - getQueue_ :: QueueParty p => s -> (Bool -> RecipientId -> QueueRec -> IO q) -> SParty p -> QueueId -> IO (Either ErrorType q) - getQueues_ :: BatchParty p => s -> (Bool -> RecipientId -> QueueRec -> IO q) -> SParty p -> [QueueId] -> IO [Either ErrorType q] + getQueue_ :: QueueParty p => s -> (RecipientId -> QueueRec -> IO q) -> SParty p -> QueueId -> IO (Either ErrorType q) + getQueues_ :: BatchParty p => s -> (RecipientId -> QueueRec -> IO q) -> SParty p -> [QueueId] -> IO [Either ErrorType q] getQueueLinkData :: s -> q -> LinkId -> IO (Either ErrorType QueueLinkData) addQueueLinkData :: s -> q -> LinkId -> QueueLinkData -> IO (Either ErrorType ()) deleteQueueLinkData :: s -> q -> IO (Either ErrorType ()) @@ -66,8 +57,3 @@ data EntityCounts = EntityCounts rcvServiceQueuesCount :: Int, ntfServiceQueuesCount :: Int } - -withLoadedQueues :: (Monoid a, QueueStoreClass q s) => s -> (q -> IO a) -> IO a -withLoadedQueues st f = readTVarIO (loadedQueues st) >>= foldM run mempty - where - run !acc = fmap (acc <>) . f diff --git a/src/Simplex/Messaging/Server/StoreLog/ReadWrite.hs b/src/Simplex/Messaging/Server/StoreLog/ReadWrite.hs index f5536d66f..21a5470aa 100644 --- a/src/Simplex/Messaging/Server/StoreLog/ReadWrite.hs +++ b/src/Simplex/Messaging/Server/StoreLog/ReadWrite.hs @@ -20,7 +20,7 @@ import Data.Text.Encoding (decodeLatin1) import Simplex.Messaging.Encoding.String import Simplex.Messaging.Protocol (ASubscriberParty (..), ErrorType, RecipientId, SParty (..)) import Simplex.Messaging.Server.QueueStore (QueueRec, ServiceRec (..)) -import Simplex.Messaging.Server.QueueStore.STM (STMQueueStore (..), STMService (..)) +import Simplex.Messaging.Server.QueueStore.STM (STMQueueStore (..), STMService (..), withLoadedQueues) import Simplex.Messaging.Server.QueueStore.Types import Simplex.Messaging.Server.StoreLog import Simplex.Messaging.Util (tshow, ($>>=)) @@ -65,7 +65,7 @@ readQueueStore tty mkQ f st = readLogLines tty f $ \_ -> processLine printError :: String -> IO () printError e = B.putStrLn $ "Error parsing log: " <> B.pack e <> " - " <> s withQueue :: forall a. RecipientId -> T.Text -> (q -> IO (Either ErrorType a)) -> IO () - withQueue qId op a = (getQueue_ st (\_ -> mkQ) SRecipient qId $>>= a) >>= qError qId op + withQueue qId op a = (getQueue_ st mkQ SRecipient qId $>>= a) >>= qError qId op qError qId op = \case Left e -> logError $ logPfx qId op <> tshow e Right _ -> pure () diff --git a/tests/AgentTests/FunctionalAPITests.hs b/tests/AgentTests/FunctionalAPITests.hs index 319f885ea..57e54c55b 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 (..)) @@ -671,8 +669,8 @@ testProxyMatrixWithPrev ps@(t, msType@(ASType qs _ms)) runTest = do it "2 servers, via proxy, prev clients, curr servers" $ withSmpServersProxy2 ps $ withAgentClientsServers2 (agentCfgVPrevPQ, initAgentServersProxy) (agentCfgVPrevPQ, initAgentServersProxy2) $ runTest True False where prev cfg' = updateCfg cfg' $ \cfg_ -> cfg_ {smpServerVRange = prevRange supportedServerSMPRelayVRange} - withSmpServers2Prev a = withServers2 (prev $ cfgMS msType) (prev $ cfgJ2QS qs) a - withSmpServersProxy2Prev a = withServers2 (prev $ proxyCfgMS msType) (prev $ proxyCfgJ2QS qs) a + withSmpServers2Prev a = withServers2 (prev $ cfgMS msType) (prev $ cfgS2QS qs) a + withSmpServersProxy2Prev a = withServers2 (prev $ proxyCfgMS msType) (prev $ proxyCfgS2QS qs) a withServers2 cfg1 cfg2 a = withSmpServerConfigOn t cfg1 testPort $ \_ -> withSmpServerConfigOn t cfg2 testPort2 $ \_ -> a @@ -1554,7 +1552,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 @@ -1576,7 +1574,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) @@ -1739,7 +1737,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 = @@ -1987,18 +1985,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) + st :: PostgresQueueStore PostgresQueue <- newQueueStore @PostgresQueue storeCfg updateDbStore st closeQueueStore @PostgresQueue st -#else - ASSCfg _ _ SSCDatabaseJournal {} -> error "no dbServerPostgres flag" #endif withSmpServer ps $ do @@ -2446,7 +2437,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 @@ -2485,7 +2476,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 @@ -2504,7 +2495,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 @@ -2518,7 +2509,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 @@ -2985,7 +2976,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 @@ -3492,7 +3483,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 @@ -3625,7 +3616,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 agentCfg initAgentServers testDB $ \a -> withAgent 2 agentCfg bServers testDB2 $ \b -> do (aId, bId) <- withSmpServerStoreLogOn ps testPort $ \_ -> runRight $ do @@ -4119,7 +4110,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 d81c08a41..3c7e029d5 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 2f34a8509..5e466ac35 100644 --- a/tests/CoreTests/MsgStoreTests.hs +++ b/tests/CoreTests/MsgStoreTests.hs @@ -16,9 +16,7 @@ module CoreTests.MsgStoreTests where -import AgentTests.FunctionalAPITests (runRight, runRight_) -import Control.Concurrent (threadDelay) -import Control.Concurrent.Async (concurrently) +import AgentTests.FunctionalAPITests (runRight_) import Control.Concurrent.STM import Control.Exception (bracket) import Control.Monad @@ -26,38 +24,26 @@ 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.Either (isRight) -import Data.Int (Int64) -import Data.List (isPrefixOf, isSuffixOf) import qualified Data.Map.Strict as M -import Data.Maybe (fromJust, isNothing) -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 (..), NotifierId, QueueLinkData, RecipientId, SParty (..), SenderId, noMsgFlags) -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.Protocol (EncDataBytes (..), EntityId (..), ErrorType (..), LinkId, Message (..), QueueLinkData, RecipientId, SParty (..), noMsgFlags) 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.STM (STMQueueStore (..)) import Simplex.Messaging.Server.QueueStore.Types -import Simplex.Messaging.Server.StoreLog (closeStoreLog, logCreateQueue) import Simplex.Messaging.TMap (TMap) -import qualified Simplex.Messaging.TMap as TM -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.Int (Int64) +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 @@ -69,51 +55,23 @@ 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 + around (withMsgStore testSMTStoreConfig) $ describe "STM message store" $ do someMsgStoreTests - journalMsgStoreTests - it "should export and import journal store" testExportImportStore - it "should remove deleted queues from queue store maps" $ testDeleteQueueMaps stmQueueMapSizes (Just stmLinksSize) - it "should not leave queue lock when queue is not added" testAddDuplicateQueueLock + it "should remove deleted queues from queue store maps" testDeleteQueueMaps #if defined(dbServerPostgres) around_ (postgressBracket testServerDBConnectInfo) $ do - around (withMsgStore $ testJournalStoreCfg $ PQStoreCfg testPostgresStoreCfg) $ - describe "Postgres+journal message store" $ do - someMsgStoreTests - journalMsgStoreTests - it "should remove deleted queues from queue cache maps" $ testDeleteQueueMaps postgresQueueMapSizes Nothing - it "should not cache queue deleted while loading" testDeletedQueueNotCached - it "should not leave queue lock when queue is not added" testAddDuplicateQueueLock - it "should not keep link data in queue records" testQueueRecNoLinkData around (withMsgStore testPostgresStoreConfig) $ describe "Postgres-only message store" $ do someMsgStoreTests it "should correctly update message counts and canWrite flag" testUpdateMessageCounts it "tryDelPeekMsg (ACK not from NSE) should reset message counts when queue is empty" testResetMessageCounts it "should expire messages across commit batches" testExpireMessagesInBatches - it "should not keep link data in queue records" testQueueRecNoLinkData #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 it "should write/ack messages" testWriteAckMessages - it "should not fail on EOF when changing read journal" testChangeReadJournal it "should resolve sender ID equal to link ID of another queue" testLinkIdSenderIdCollision -- TODO constrain to STM stores? @@ -123,21 +81,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 = @@ -166,12 +109,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 @@ -274,103 +211,24 @@ testWriteAckMessages ms = do void $ ExceptT $ deleteQueue ms q1 void $ ExceptT $ deleteQueue ms q2 -testChangeReadJournal :: MsgStoreClass s => s -> IO () -testChangeReadJournal ms = do - g <- C.newRandom - (rId, qr) <- testNewQueueRec g QMMessaging - 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" - (Msg "message 1", Nothing) <- tryDelPeekMsg ms q mId1 - Just (Message {msgId = mId2}, True) <- write "message 2" - (Msg "message 2", Nothing) <- tryDelPeekMsg ms q mId2 - Just (Message {msgId = mId3}, True) <- write "message 3" - (Msg "message 3", Nothing) <- tryDelPeekMsg ms q mId3 - Just (Message {msgId = mId4}, True) <- write "message 4" - (Msg "message 4", Nothing) <- tryDelPeekMsg ms q mId4 - Just (Message {msgId = mId5}, True) <- write "message 5" - (Msg "message 5", Nothing) <- tryDelPeekMsg ms q mId5 - void $ ExceptT $ deleteQueue ms q +-- sizes of queues, senders, links and notifiers maps +type QueueMapSizes = (Int, Int, Int, Int) -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")) - --- sizes of queues, senders and notifiers maps -type QueueMapSizes = (Int, Int, Int) - -stmQueueMapSizes :: JournalMsgStore 'QSMemory -> IO QueueMapSizes -stmQueueMapSizes ms = queueMapSizes queues senders notifiers +queueMapSizes :: STMMsgStore -> IO QueueMapSizes +queueMapSizes ms = (,,,) <$> size queues <*> size senders <*> size links <*> size notifiers where - STMQueueStore {queues, senders, notifiers} = stmQueueStore ms + STMQueueStore {queues, senders, links, notifiers} = queueStore ms + size :: TMap k v -> IO Int + size = fmap M.size . readTVarIO -stmLinksSize :: JournalMsgStore 'QSMemory -> IO Int -stmLinksSize ms = mapSize links - where - STMQueueStore {links} = stmQueueStore ms - -queueMapSizes :: TMap RecipientId q -> TMap SenderId RecipientId -> TMap NotifierId RecipientId -> IO QueueMapSizes -queueMapSizes qs ss ns = (,,) <$> mapSize qs <*> mapSize ss <*> mapSize ns - -mapSize :: TMap k v -> IO Int -mapSize = fmap M.size . readTVarIO - -testDeleteQueueMaps :: forall s. MsgStoreClass s => (s -> IO QueueMapSizes) -> Maybe (s -> IO Int) -> s -> IO () -testDeleteQueueMaps mapSizes linksSize_ ms = do +testDeleteQueueMaps :: STMMsgStore -> IO () +testDeleteQueueMaps ms = do g <- C.newRandom ntfCreds <- testNtfCreds g - lnkId1 <- testLinkId g - lnkId2 <- testLinkId g - lnkId3 <- testLinkId g + let newLinkId = atomically $ EntityId <$> C.randomBytes 24 g + lnkId1 <- newLinkId + lnkId2 <- newLinkId + lnkId3 <- newLinkId (rId1, qr1) <- testNewQueueRec g QMMessaging (rId2, qr2) <- testNewQueueRecData g QMContact (Just (lnkId1, testLinkData)) (rId3, qr3) <- testNewQueueRec g QMMessaging @@ -378,7 +236,7 @@ testDeleteQueueMaps mapSizes linksSize_ ms = do let rIds = [rId1, rId2, rId3, rId4] :: [RecipientId] sIds = map senderId [qr1, qr2, qr3, qr4] lnkIds = [lnkId1, lnkId2, lnkId3] :: [LinkId] - sizesShouldBe (0, 0, 0) 0 + queueMapSizes ms `shouldReturn` (0, 0, 0, 0) runRight_ $ do q1 <- ExceptT $ addQueue ms rId1 qr1 {notifier = Just ntfCreds} q2 <- ExceptT $ addQueue ms rId2 qr2 @@ -388,37 +246,17 @@ testDeleteQueueMaps mapSizes linksSize_ ms = do ExceptT $ addQueueLinkData (queueStore ms) q4 lnkId3 testLinkData forM_ sIds $ void . ExceptT . getQueue ms SSender forM_ lnkIds $ void . ExceptT . getQueue ms SSenderLink - liftIO $ sizesShouldBe (4, 4, 1) 3 + liftIO $ queueMapSizes ms `shouldReturn` (4, 4, 3, 1) ExceptT $ deleteQueueLinkData (queueStore ms) q3 - liftIO $ sizesShouldBe (4, 4, 1) 2 - forM_ ([q1, q2, q3, q4] :: [StoreQueue s]) $ void . ExceptT . deleteQueue ms - sizesShouldBe (0, 0, 0) 0 + liftIO $ queueMapSizes ms `shouldReturn` (4, 4, 2, 1) + forM_ ([q1, q2, q3, q4] :: [STMQueue]) $ void . ExceptT . deleteQueue ms + queueMapSizes ms `shouldReturn` (0, 0, 0, 0) forM_ rIds $ \rId -> getQueue ms SRecipient rId >>= expectAuth forM_ sIds $ \sId -> getQueue ms SSender sId >>= expectAuth forM_ lnkIds $ \lnkId -> getQueue ms SSenderLink lnkId >>= expectAuth - sizesShouldBe (0, 0, 0) 0 + queueMapSizes ms `shouldReturn` (0, 0, 0, 0) where expectAuth = either (`shouldBe` AUTH) (\_ -> expectationFailure "deleted queue is still found") - sizesShouldBe sizes linksSize = do - mapSizes ms `shouldReturn` sizes - forM_ linksSize_ $ \f -> f ms `shouldReturn` linksSize - -testAddDuplicateQueueLock :: JournalMsgStore s -> IO () -testAddDuplicateQueueLock ms = do - g <- C.newRandom - (rId, qr) <- testNewQueueRec g QMMessaging - (rId', qr') <- testNewQueueRec g QMMessaging - void $ runRight $ ExceptT $ addQueue ms rId qr - -- duplicate sender ID - addQueue ms rId' qr >>= expectError - -- duplicate recipient ID, the lock of the existing queue is kept - addQueue ms rId qr' >>= expectError - queueLockCount <$> loadedQueueCounts ms `shouldReturn` 1 - where - expectError = either (\_ -> pure ()) (\_ -> expectationFailure "duplicate queue is added") - -testLinkId :: TVar ChaChaDRG -> IO LinkId -testLinkId g = atomically $ EntityId <$> C.randomBytes 24 g testLinkData :: QueueLinkData testLinkData = (EncDataBytes "fixed data", EncDataBytes "user data") @@ -438,59 +276,7 @@ testLinkIdSenderIdCollision ms = do qV <- ExceptT $ getQueue ms SSender sIdV liftIO $ recipientId qV `shouldBe` rIdV -testQueueRecNoLinkData :: MsgStoreClass s => s -> IO () -testQueueRecNoLinkData ms = do - g <- C.newRandom - let qd' = (EncDataBytes "fixed data", EncDataBytes "updated user data") - noData = (EncDataBytes "", EncDataBytes "") - lnkId1 <- testLinkId g - lnkId2 <- testLinkId g - (rId1, qr1) <- testNewQueueRecData g QMContact (Just (lnkId1, testLinkData)) - (rId2, qr2) <- testNewQueueRec g QMContact - runRight_ $ do - q1 <- ExceptT $ addQueue ms rId1 qr1 - q2 <- ExceptT $ addQueue ms rId2 qr2 - ExceptT $ addQueueLinkData (queueStore ms) q2 lnkId2 testLinkData - liftIO $ queueLinkData q1 `shouldReturn` Just (lnkId1, noData) - liftIO $ queueLinkData q2 `shouldReturn` Just (lnkId2, noData) - ExceptT (getQueueLinkData (queueStore ms) q1 lnkId1) >>= liftIO . (`shouldBe` testLinkData) - ExceptT (getQueueLinkData (queueStore ms) q2 lnkId2) >>= liftIO . (`shouldBe` testLinkData) - ExceptT $ addQueueLinkData (queueStore ms) q2 lnkId2 qd' - liftIO $ queueLinkData q2 `shouldReturn` Just (lnkId2, noData) - ExceptT (getQueueLinkData (queueStore ms) q2 lnkId2) >>= liftIO . (`shouldBe` qd') - where - queueLinkData q = (queueData =<<) <$> readTVarIO (queueRec q) - #if defined(dbServerPostgres) -postgresQueueMapSizes :: JournalMsgStore 'QSPostgres -> IO QueueMapSizes -postgresQueueMapSizes ms = queueMapSizes queues senders notifiers - where - PostgresQueueStore {queues, senders, notifiers} = postgresQueueStore ms - -testDeletedQueueNotCached :: JournalMsgStore 'QSPostgres -> IO () -testDeletedQueueNotCached ms = do - g <- C.newRandom - -- the queue is cached without sender reference, as after subscription - loadWhileDeleting g getSndQueue $ \_ sId -> TM.delete sId senders - -- the queue is only in the database, as after server restart - loadWhileDeleting g getSndQueue evictQueue - loadWhileDeleting g getRcvQueues evictQueue - where - PostgresQueueStore {queues, senders} = postgresQueueStore ms - getSndQueue _ sId = getQueue ms SSender sId - getRcvQueues rId _ = head <$> getQueues ms SRecipient [rId] - evictQueue rId sId = TM.delete rId queues >> TM.delete sId senders - loadWhileDeleting g load evict = replicateM_ 100 $ do - (rId, qr) <- testNewQueueRec g QMMessaging - q <- runRight $ ExceptT $ addQueue ms rId qr - atomically $ evict rId (senderId qr) - (q_, deleted) <- concurrently (load rId (senderId qr)) (deleteQueue ms q) - deleted `shouldSatisfy` isRight - forM_ q_ $ \q' -> readTVarIO (queueRec q') >>= (`shouldSatisfy` isNothing) - TM.memberIO rId queues `shouldReturn` False - TM.lookupIO (senderId qr) senders `shouldReturn` Nothing - queueLockCount <$> loadedQueueCounts ms `shouldReturn` 0 - testUpdateMessageCounts :: PostgresMsgStore -> IO () testUpdateMessageCounts ms = do g <- C.newRandom @@ -599,320 +385,3 @@ testExpireMessagesInBatches ms = do 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 ac10231e4..36b52707e 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 (..), STMStoreConfig (..)) import Simplex.Messaging.Server.MsgStore.Types import Simplex.Messaging.Server.QueueStore import Simplex.Messaging.Server.QueueStore.STM (STMQueueStore (..)) @@ -165,10 +165,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 @@ -176,14 +176,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 STMStoreConfig {storePath = Nothing, quota = 3} + l <- readWriteQueueStore True (mkQueue st) 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/SMPClient.hs b/tests/SMPClient.hs index 43aa22a76..792debce5 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, @@ -292,20 +294,21 @@ 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 + let dbStoreLogPath = if useDbStoreLog then Just testStoreLogFile else Nothing + storeCfg = PostgresStoreCfg {dbOpts = testStoreDBOpts, dbStoreLogPath, confirmMigrations = MCYesUp, deletedTTL = 86400} + in ASSCfg SQSPostgres SMSPostgres $ SSCDatabase storeCfg +#else + ASType SQSPostgres _ -> error "no dbServerPostgres flag" #endif - where - dbStoreLogPath = if useDbStoreLog then Just testStoreLogFile else Nothing - storeCfg = PostgresStoreCfg {dbOpts = testStoreDBOpts, dbStoreLogPath, confirmMigrations = MCYesUp, deletedTTL = 86400} cfgVPrev :: AStoreType -> AServerConfig cfgVPrev msType = updateCfg (cfgMS msType) $ \cfg' -> cfg' {smpServerVRange = prevRange $ smpServerVRange cfg'} @@ -320,7 +323,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 = @@ -331,13 +334,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. @@ -409,10 +412,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 @@ -433,7 +436,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 430d52304..e721efa6a 100644 --- a/tests/SMPProxyTests.hs +++ b/tests/SMPProxyTests.hs @@ -150,17 +150,17 @@ 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 twoServers_ :: AServerConfig -> AServerConfig -> IO () -> AStoreType -> IO () 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 () @@ -388,15 +388,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 + -- withServer = withServer_ testStoreDBOpts 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 + -- withServer2 = withServer_ testStoreDBOpts2 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 @@ -422,7 +422,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 () @@ -453,7 +453,7 @@ requestRelaySession = -- 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 @@ -509,7 +509,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 116b4f0ec..eb967ef0a 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) @@ -46,17 +45,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.TimeIt (timeItT) import System.Timeout @@ -66,7 +62,11 @@ import Util #if defined(dbServerPostgres) import CoreTests.MsgStoreTests (testPostgresStoreConfig) +import Simplex.Messaging.Server.Env.STM (readWriteQueueStore) import Simplex.Messaging.Server.MsgStore.Postgres (PostgresMsgStoreCfg (..), exportDbMessages) +import Simplex.Messaging.Server.MsgStore.STM (STMStoreConfig (..)) +import Simplex.Messaging.Server.MsgStore.Types (MsgStoreClass (..), newMsgStore) +import Simplex.Messaging.Server.StoreLog (closeStoreLog) #endif serverTests :: SpecWith (ASrvTransport, AStoreType) @@ -1068,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 @@ -1138,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 @@ -1218,28 +1216,21 @@ 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 STMStoreConfig {storePath = Nothing, quota = 4} + readWriteQueueStore True (mkQueue ms) testStoreLogFile (queueStore ms) >>= closeStoreLog + removeFileIfExists testStoreMsgsFile + closeMsgStore ms 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 - removeFileIfExists testStoreMsgsFile - pure ms runTest :: Transport c => TProxy c 'TServer -> (THandleSMP c 'TClient -> IO ()) -> ThreadId -> Expectation runTest _ test' server = do testSMPClient test' `shouldReturn` () @@ -1549,7 +1540,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 16375bcc6..ff6b1c3a2 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