dandri/simplexmq
1
0
Fork 0
mirror of https://github.com/simplex-chat/simplexmq.git synced 2026-10-06 05:37:17 +00:00
Code Issues Packages Projects Releases Wiki Activity

smp-server: remove journal message store

Browse Source
This commit is contained in:
shum
2026-10-05 07:44:32 +00:00
parent f929911fa0
commit 2c3641f97a
26 changed files with 435 additions and 2669 deletions
Download Patch File Download Diff File Expand all files Collapse all files
docs/smp-server-db-load.md
+1 -3
View File
@@ -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:
simplexmq.cabal
-2
View File
@@ -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
src/Simplex/Messaging/Agent/Client.hs
-1
View File
@@ -34,7 +34,6 @@ module Simplex.Messaging.Agent.Client
withInvLock,
withLockMap,
withLocksMap,
getMapLock,
ipAddressProtected,
closeAgentClient,
closeProtocolServerClients,
src/Simplex/Messaging/Agent/Lock.hs
-1
View File
@@ -6,7 +6,6 @@ module Simplex.Messaging.Agent.Lock
withLock',
withGetLock,
withGetLocks,
getPutLock,
)
where
src/Simplex/Messaging/Server.hs
+26 -69
View File
@@ -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
src/Simplex/Messaging/Server/Env/STM.hs
+7 -75
View File
@@ -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
src/Simplex/Messaging/Server/Main.hs
+58 -165
View File
@@ -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
src/Simplex/Messaging/Server/Main/Init.hs
+2 -2
View File
@@ -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"
src/Simplex/Messaging/Server/MsgStore/Journal.hs
-1090
View File
File diff suppressed because it is too large Load Diff
src/Simplex/Messaging/Server/MsgStore/Journal/SharedLock.hs
-44
View File
@@ -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
src/Simplex/Messaging/Server/MsgStore/Postgres.hs
+17 -74
View File
@@ -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
src/Simplex/Messaging/Server/MsgStore/STM.hs
+107 -73
View File
@@ -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
src/Simplex/Messaging/Server/MsgStore/Types.hs
+6 -97
View File
@@ -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
src/Simplex/Messaging/Server/Prometheus.hs
+9 -19
View File
@@ -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
src/Simplex/Messaging/Server/QueueStore/Postgres.hs
+63 -246
View File
@@ -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))
src/Simplex/Messaging/Server/QueueStore/STM.hs
+10 -9
View File
@@ -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
src/Simplex/Messaging/Server/QueueStore/Types.hs
+2 -16
View File
@@ -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
src/Simplex/Messaging/Server/StoreLog/ReadWrite.hs
+2 -2
View File
@@ -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 ()
tests/AgentTests/FunctionalAPITests.hs
+14 -23
View File
@@ -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
tests/AgentTests/NotificationTests.hs
+1 -1
View File
@@ -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
tests/CoreTests/MsgStoreTests.hs
+28 -559
View File
@@ -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
tests/CoreTests/StoreLogTests.hs
+7 -7
View File
@@ -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)
tests/SMPClient.hs
+44 -41
View File
@@ -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
tests/SMPProxyTests.hs
+14 -14
View File
@@ -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
tests/ServerTests.hs
+13 -22
View File
@@ -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
tests/Test.hs
+4 -14
View File
@@ -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