From 4dc40bd7958792e8900c9455b4e94ab8e4c498ec Mon Sep 17 00:00:00 2001 From: Evgeny Date: Mon, 24 Feb 2025 15:47:27 +0000 Subject: [PATCH 01/14] smp server: PostgreSQL queue store (#1448) * smp server: queue store typeclass * parameterize JournalMsgStore * typeclass for queue store * postgres WIP * compiles, passes tests * remove StoreType * split migrations * progress * addQueueRec * reduce type spaghetti * remove addQueue from typeclass definition * getQueue * test postgres storage in SMP server * fix schema * comment * import queues to postgresql * import queues to postgresql * log * fix test * counts * ci: test smp server with postgres backend (#1463) * ci: test smp server with postgres backend * postgres service * attempt * attempt * empty * empty * PGHOST attempt * PGHOST + softlink attempt * only softlink attempt * working attempt (PGHOST) * remove env var * empty * do not start server without DB schema, do not import when schema exists * export database * enable all tests, disable two tests * option for migration confirmation * comments --------- Co-authored-by: spaced4ndy <8711996+spaced4ndy@users.noreply.github.com> --- .github/workflows/build.yml | 17 + simplexmq.cabal | 25 +- src/Simplex/FileTransfer/Types.hs | 2 +- src/Simplex/Messaging/Agent/Protocol.hs | 4 +- src/Simplex/Messaging/Agent/Stats.hs | 4 +- src/Simplex/Messaging/Agent/Store.hs | 2 +- .../Messaging/Agent/Store/AgentStore.hs | 39 +- src/Simplex/Messaging/Agent/Store/DB.hs | 1 - src/Simplex/Messaging/Agent/Store/Postgres.hs | 85 ++-- .../Messaging/Agent/Store/Postgres/Common.hs | 14 +- .../Messaging/Agent/Store/Postgres/DB.hs | 26 +- src/Simplex/Messaging/Agent/Store/SQLite.hs | 8 - .../Messaging/Agent/Store/SQLite/Common.hs | 9 + .../Messaging/Agent/Store/SQLite/DB.hs | 26 +- src/Simplex/Messaging/Crypto.hs | 4 +- src/Simplex/Messaging/Crypto/Ratchet.hs | 6 +- .../Messaging/Notifications/Protocol.hs | 3 +- src/Simplex/Messaging/Notifications/Types.hs | 3 +- src/Simplex/Messaging/Parsers.hs | 54 --- src/Simplex/Messaging/Server.hs | 192 ++++----- src/Simplex/Messaging/Server/CLI.hs | 8 + src/Simplex/Messaging/Server/Env/STM.hs | 115 ++++-- src/Simplex/Messaging/Server/Main.hs | 266 ++++++++++--- .../Messaging/Server/MsgStore/Journal.hs | 291 ++++++++++---- src/Simplex/Messaging/Server/MsgStore/STM.hs | 80 ++-- .../Messaging/Server/MsgStore/Types.hs | 73 ++-- src/Simplex/Messaging/Server/QueueStore.hs | 11 + .../Messaging/Server/QueueStore/Postgres.hs | 376 ++++++++++++++++++ .../Server/QueueStore/Postgres/Migrations.hs | 49 +++ .../Messaging/Server/QueueStore/STM.hs | 322 +++++++-------- .../Messaging/Server/QueueStore/Types.hs | 48 +++ src/Simplex/Messaging/Server/StoreLog.hs | 19 +- .../Messaging/Server/StoreLog/ReadWrite.hs | 66 +++ src/Simplex/Messaging/Util.hs | 27 +- tests/AgentTests/FunctionalAPITests.hs | 20 +- tests/AgentTests/NotificationTests.hs | 4 +- tests/CoreTests/MsgStoreTests.hs | 58 +-- tests/CoreTests/StoreLogTests.hs | 10 +- tests/SMPClient.hs | 105 +++-- tests/SMPProxyTests.hs | 12 +- tests/ServerTests.hs | 74 ++-- tests/Test.hs | 18 +- 42 files changed, 1757 insertions(+), 819 deletions(-) create mode 100644 src/Simplex/Messaging/Server/QueueStore/Postgres.hs create mode 100644 src/Simplex/Messaging/Server/QueueStore/Postgres/Migrations.hs create mode 100644 src/Simplex/Messaging/Server/QueueStore/Types.hs create mode 100644 src/Simplex/Messaging/Server/StoreLog/ReadWrite.hs diff --git a/.github/workflows/build.yml b/.github/workflows/build.yml index be58c10b4..bf051bf3f 100644 --- a/.github/workflows/build.yml +++ b/.github/workflows/build.yml @@ -13,6 +13,21 @@ jobs: build: name: build-${{ matrix.os }}-${{ matrix.ghc }} runs-on: ${{ matrix.os }} + + services: + postgres: + image: postgres:15 + env: + POSTGRES_HOST_AUTH_METHOD: trust # Allows passwordless access + options: >- + --health-cmd pg_isready + --health-interval 10s + --health-timeout 5s + --health-retries 5 + ports: + # Maps tcp port 5432 on service container to the host + - 5432:5432 + strategy: fail-fast: false matrix: @@ -52,6 +67,8 @@ jobs: timeout-minutes: 40 shell: bash run: cabal test --test-show-details=direct + env: + PGHOST: localhost - name: Prepare binaries if: startsWith(github.ref, 'refs/tags/v') diff --git a/simplexmq.cabal b/simplexmq.cabal index 400f2d29a..d8a38e5ed 100644 --- a/simplexmq.cabal +++ b/simplexmq.cabal @@ -148,16 +148,9 @@ library Simplex.RemoteControl.Types if flag(client_postgres) exposed-modules: - Simplex.Messaging.Agent.Store.Postgres - Simplex.Messaging.Agent.Store.Postgres.Common - Simplex.Messaging.Agent.Store.Postgres.DB - Simplex.Messaging.Agent.Store.Postgres.Migrations Simplex.Messaging.Agent.Store.Postgres.Migrations.App Simplex.Messaging.Agent.Store.Postgres.Migrations.M20241210_initial Simplex.Messaging.Agent.Store.Postgres.Migrations.M20250203_msg_bodies - if !flag(client_library) - exposed-modules: - Simplex.Messaging.Agent.Store.Postgres.Util else exposed-modules: Simplex.Messaging.Agent.Store.SQLite @@ -213,6 +206,11 @@ library Simplex.FileTransfer.Server.Stats Simplex.FileTransfer.Server.Store Simplex.FileTransfer.Server.StoreLog + Simplex.Messaging.Agent.Store.Postgres + Simplex.Messaging.Agent.Store.Postgres.Common + Simplex.Messaging.Agent.Store.Postgres.DB + Simplex.Messaging.Agent.Store.Postgres.Migrations + Simplex.Messaging.Agent.Store.Postgres.Util Simplex.Messaging.Notifications.Server Simplex.Messaging.Notifications.Server.Control Simplex.Messaging.Notifications.Server.Env @@ -236,8 +234,12 @@ library Simplex.Messaging.Server.Prometheus Simplex.Messaging.Server.QueueStore Simplex.Messaging.Server.QueueStore.STM + Simplex.Messaging.Server.QueueStore.Postgres + Simplex.Messaging.Server.QueueStore.Postgres.Migrations + Simplex.Messaging.Server.QueueStore.Types Simplex.Messaging.Server.Stats Simplex.Messaging.Server.StoreLog + Simplex.Messaging.Server.StoreLog.ReadWrite Simplex.Messaging.Server.StoreLog.Types Simplex.Messaging.Transport.WebSockets other-modules: @@ -304,15 +306,16 @@ library case-insensitive ==1.2.* , hashable ==1.4.* , ini ==0.4.1 + , postgresql-simple ==0.7.* , optparse-applicative >=0.15 && <0.17 , process ==1.6.* + , raw-strings-qq ==1.1.* , temporary ==1.3.* , websockets ==0.12.* - if flag(client_postgres) + if flag(client_postgres) || !flag(client_library) build-depends: postgresql-libpq >=0.10.0.0 - , postgresql-simple ==0.7.* - , raw-strings-qq ==1.1.* + if flag(client_postgres) cpp-options: -DdbPostgres else build-depends: @@ -490,6 +493,7 @@ test-suite simplexmq-test , memory , mtl , network + , postgresql-simple ==0.7.* , process , QuickCheck ==2.14.* , random @@ -513,7 +517,6 @@ test-suite simplexmq-test if flag(client_postgres) build-depends: postgresql-libpq >=0.10.0.0 - , postgresql-simple ==0.7.* , raw-strings-qq ==1.1.* cpp-options: -DdbPostgres else diff --git a/src/Simplex/FileTransfer/Types.hs b/src/Simplex/FileTransfer/Types.hs index d80ff7c77..953080480 100644 --- a/src/Simplex/FileTransfer/Types.hs +++ b/src/Simplex/FileTransfer/Types.hs @@ -22,7 +22,7 @@ import Simplex.Messaging.Encoding.String import Simplex.Messaging.Parsers import Simplex.Messaging.Protocol (XFTPServer) import System.FilePath (()) -import Simplex.Messaging.Agent.Store.DB (FromField (..), ToField (..)) +import Simplex.Messaging.Agent.Store.DB (FromField (..), ToField (..), fromTextField_) type RcvFileId = ByteString -- Agent entity ID diff --git a/src/Simplex/Messaging/Agent/Protocol.hs b/src/Simplex/Messaging/Agent/Protocol.hs index 365ef0766..4c6c75d8c 100644 --- a/src/Simplex/Messaging/Agent/Protocol.hs +++ b/src/Simplex/Messaging/Agent/Protocol.hs @@ -168,7 +168,7 @@ import Data.Time.Clock.System (SystemTime) import Data.Type.Equality import Data.Typeable () import Data.Word (Word16, Word32) -import Simplex.Messaging.Agent.Store.DB (Binary (..), FromField (..), ToField (..)) +import Simplex.Messaging.Agent.Store.DB (Binary (..), FromField (..), ToField (..), blobFieldDecoder, fromTextField_) import Simplex.FileTransfer.Description import Simplex.FileTransfer.Protocol (FileParty (..)) import Simplex.FileTransfer.Transport (XFTPErrorType) @@ -1016,7 +1016,7 @@ instance Encoding AMessage where instance ToField AMessage where toField = toField . Binary . smpEncode -instance FromField AMessage where fromField = blobFieldParser smpP +instance FromField AMessage where fromField = blobFieldDecoder smpDecode instance Encoding AMessageReceipt where smpEncode AMessageReceipt {agentMsgId, msgHash, rcptInfo} = diff --git a/src/Simplex/Messaging/Agent/Stats.hs b/src/Simplex/Messaging/Agent/Stats.hs index 020c6a89c..cb78d0c02 100644 --- a/src/Simplex/Messaging/Agent/Stats.hs +++ b/src/Simplex/Messaging/Agent/Stats.hs @@ -11,8 +11,8 @@ import Data.Int (Int64) import Data.Map.Strict (Map) import qualified Data.Map.Strict as M import Simplex.Messaging.Agent.Protocol (UserId) -import Simplex.Messaging.Agent.Store.DB (FromField (..), ToField (..)) -import Simplex.Messaging.Parsers (defaultJSON, fromTextField_) +import Simplex.Messaging.Agent.Store.DB (FromField (..), ToField (..), fromTextField_) +import Simplex.Messaging.Parsers (defaultJSON) import Simplex.Messaging.Protocol (NtfServer, SMPServer, XFTPServer) import Simplex.Messaging.Util (decodeJSON, encodeJSON) import UnliftIO.STM diff --git a/src/Simplex/Messaging/Agent/Store.hs b/src/Simplex/Messaging/Agent/Store.hs index 5449ce848..14e1f1fc8 100644 --- a/src/Simplex/Messaging/Agent/Store.hs +++ b/src/Simplex/Messaging/Agent/Store.hs @@ -30,7 +30,7 @@ import Data.Type.Equality import Simplex.Messaging.Agent.Protocol import Simplex.Messaging.Agent.RetryInterval (RI2State) import Simplex.Messaging.Agent.Store.Common -import Simplex.Messaging.Agent.Store.Interface (DBOpts, createDBStore) +import Simplex.Messaging.Agent.Store.Interface (createDBStore) import Simplex.Messaging.Agent.Store.Migrations.App (appMigrations) import Simplex.Messaging.Agent.Store.Shared (MigrationConfirmation (..), MigrationError (..)) import qualified Simplex.Messaging.Crypto as C diff --git a/src/Simplex/Messaging/Agent/Store/AgentStore.hs b/src/Simplex/Messaging/Agent/Store/AgentStore.hs index 33beab129..a8c1e1fb0 100644 --- a/src/Simplex/Messaging/Agent/Store/AgentStore.hs +++ b/src/Simplex/Messaging/Agent/Store/AgentStore.hs @@ -237,7 +237,7 @@ import Control.Monad import Control.Monad.IO.Class import Control.Monad.Trans.Except import Crypto.Random (ChaChaDRG) -import Data.Bifunctor (first, second) +import Data.Bifunctor (first) import Data.ByteString (ByteString) import qualified Data.ByteString.Base64.URL as U import qualified Data.ByteString.Char8 as B @@ -247,7 +247,7 @@ import Data.List (foldl', sortBy) import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.List.NonEmpty as L import qualified Data.Map.Strict as M -import Data.Maybe (catMaybes, fromMaybe, isJust, isNothing, listToMaybe) +import Data.Maybe (catMaybes, fromMaybe, isJust, isNothing) import Data.Ord (Down (..)) import Data.Text.Encoding (decodeLatin1, encodeUtf8) import Data.Time.Clock (NominalDiffTime, UTCTime, addUTCTime, getCurrentTime) @@ -263,7 +263,7 @@ import Simplex.Messaging.Agent.Stats import Simplex.Messaging.Agent.Store import Simplex.Messaging.Agent.Store.Common import qualified Simplex.Messaging.Agent.Store.DB as DB -import Simplex.Messaging.Agent.Store.DB (Binary (..), BoolInt (..), FromField (..), ToField (..)) +import Simplex.Messaging.Agent.Store.DB (Binary (..), BoolInt (..), FromField (..), ToField (..), blobFieldDecoder, fromTextField_) import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Crypto.File (CryptoFile (..), CryptoFileArgs (..)) import Simplex.Messaging.Crypto.Ratchet (PQEncryption (..), PQSupport (..), RatchetX448, SkippedMsgDiff (..), SkippedMsgKeys) @@ -272,11 +272,11 @@ import Simplex.Messaging.Encoding import Simplex.Messaging.Encoding.String import Simplex.Messaging.Notifications.Protocol (DeviceToken (..), NtfSubscriptionId, NtfTknStatus (..), NtfTokenId, SMPQueueNtf (..)) import Simplex.Messaging.Notifications.Types -import Simplex.Messaging.Parsers (blobFieldParser, fromTextField_) +import Simplex.Messaging.Parsers (parseAll) import Simplex.Messaging.Protocol import qualified Simplex.Messaging.Protocol as SMP import Simplex.Messaging.Transport.Client (TransportHost) -import Simplex.Messaging.Util (bshow, catchAllErrors, eitherToMaybe, ifM, tshow, ($>>=), (<$$>)) +import Simplex.Messaging.Util (bshow, catchAllErrors, eitherToMaybe, firstRow, firstRow', ifM, maybeFirstRow, tshow, ($>>=), (<$$>)) import Simplex.Messaging.Version.Internal import qualified UnliftIO.Exception as E import UnliftIO.STM @@ -1743,23 +1743,23 @@ deriving newtype instance FromField InternalId instance ToField AgentMessageType where toField = toField . Binary . smpEncode -instance FromField AgentMessageType where fromField = blobFieldParser smpP +instance FromField AgentMessageType where fromField = blobFieldDecoder smpDecode instance ToField MsgIntegrity where toField = toField . Binary . strEncode -instance FromField MsgIntegrity where fromField = blobFieldParser strP +instance FromField MsgIntegrity where fromField = blobFieldDecoder strDecode instance ToField SMPQueueUri where toField = toField . Binary . strEncode -instance FromField SMPQueueUri where fromField = blobFieldParser strP +instance FromField SMPQueueUri where fromField = blobFieldDecoder strDecode instance ToField AConnectionRequestUri where toField = toField . Binary . strEncode -instance FromField AConnectionRequestUri where fromField = blobFieldParser strP +instance FromField AConnectionRequestUri where fromField = blobFieldDecoder strDecode instance ConnectionModeI c => ToField (ConnectionRequestUri c) where toField = toField . Binary . strEncode -instance (E.Typeable c, ConnectionModeI c) => FromField (ConnectionRequestUri c) where fromField = blobFieldParser strP +instance (E.Typeable c, ConnectionModeI c) => FromField (ConnectionRequestUri c) where fromField = blobFieldDecoder strDecode instance ToField ConnectionMode where toField = toField . decodeLatin1 . strEncode @@ -1775,7 +1775,7 @@ instance FromField MsgFlags where fromField = fromTextField_ $ eitherToMaybe . s instance ToField [SMPQueueInfo] where toField = toField . Binary . smpEncodeList -instance FromField [SMPQueueInfo] where fromField = blobFieldParser smpListP +instance FromField [SMPQueueInfo] where fromField = blobFieldDecoder $ parseAll smpListP instance ToField (NonEmpty TransportHost) where toField = toField . decodeLatin1 . strEncode @@ -1783,11 +1783,11 @@ instance FromField (NonEmpty TransportHost) where fromField = fromTextField_ $ e instance ToField AgentCommand where toField = toField . Binary . strEncode -instance FromField AgentCommand where fromField = blobFieldParser strP +instance FromField AgentCommand where fromField = blobFieldDecoder strDecode instance ToField AgentCommandTag where toField = toField . Binary . strEncode -instance FromField AgentCommandTag where fromField = blobFieldParser strP +instance FromField AgentCommandTag where fromField = blobFieldDecoder strDecode instance ToField MsgReceiptStatus where toField = toField . decodeLatin1 . strEncode @@ -1805,23 +1805,10 @@ deriving newtype instance ToField ChunkReplicaId deriving newtype instance FromField ChunkReplicaId -listToEither :: e -> [a] -> Either e a -listToEither _ (x : _) = Right x -listToEither e _ = Left e - -firstRow :: (a -> b) -> e -> IO [a] -> IO (Either e b) -firstRow f e a = second f . listToEither e <$> a - -maybeFirstRow :: Functor f => (a -> b) -> f [a] -> f (Maybe b) -maybeFirstRow f q = fmap f . listToMaybe <$> q - fromOnlyBI :: Only BoolInt -> Bool fromOnlyBI (Only (BI b)) = b {-# INLINE fromOnlyBI #-} -firstRow' :: (a -> Either e b) -> e -> IO [a] -> IO (Either e b) -firstRow' f e a = (f <=< listToEither e) <$> a - #if !defined(dbPostgres) {- ORMOLU_DISABLE -} -- SQLite.Simple only has these up to 10 fields, which is insufficient for some of our queries diff --git a/src/Simplex/Messaging/Agent/Store/DB.hs b/src/Simplex/Messaging/Agent/Store/DB.hs index ade1f7e6d..2e9bd30ee 100644 --- a/src/Simplex/Messaging/Agent/Store/DB.hs +++ b/src/Simplex/Messaging/Agent/Store/DB.hs @@ -16,4 +16,3 @@ import Simplex.Messaging.Agent.Store.Postgres.DB where import Simplex.Messaging.Agent.Store.SQLite.DB #endif - diff --git a/src/Simplex/Messaging/Agent/Store/Postgres.hs b/src/Simplex/Messaging/Agent/Store/Postgres.hs index ec4527af3..1c7abb701 100644 --- a/src/Simplex/Messaging/Agent/Store/Postgres.hs +++ b/src/Simplex/Messaging/Agent/Store/Postgres.hs @@ -7,6 +7,7 @@ module Simplex.Messaging.Agent.Store.Postgres ( DBOpts (..), Migrations.getCurrentMigrations, + checkSchemaExists, createDBStore, closeDBStore, reopenDBStore, @@ -14,13 +15,15 @@ module Simplex.Messaging.Agent.Store.Postgres ) where -import Control.Exception (throwIO) -import Control.Monad (unless, void) +import Control.Concurrent.STM +import Control.Exception (bracketOnError, finally, onException, throwIO) +import Control.Logger.Simple (logError) +import Control.Monad (void, when) import Data.ByteString (ByteString) import Data.Functor (($>)) -import Data.String (fromString) import Data.Text (Text) import Database.PostgreSQL.Simple (Only (..)) +import Database.PostgreSQL.Simple.Types (Query (..)) import qualified Database.PostgreSQL.Simple as PSQL import Database.PostgreSQL.Simple.SqlQQ (sql) import Simplex.Messaging.Agent.Store.Migrations (DBMigrate (..), sharedMigrateSchema) @@ -28,23 +31,16 @@ import qualified Simplex.Messaging.Agent.Store.Postgres.Migrations as Migrations import Simplex.Messaging.Agent.Store.Postgres.Common import qualified Simplex.Messaging.Agent.Store.Postgres.DB as DB import Simplex.Messaging.Agent.Store.Shared (Migration (..), MigrationConfirmation (..), MigrationError (..)) -import Simplex.Messaging.Util (ifM) -import UnliftIO.Exception (bracketOnError, onException) +import Simplex.Messaging.Util (ifM, safeDecodeUtf8) +import System.Exit (exitFailure) import UnliftIO.MVar -import UnliftIO.STM - -data DBOpts = DBOpts - { connstr :: ByteString, - schema :: String - } -- | Create a new Postgres DBStore with the given connection string, schema name and migrations. -- If passed schema does not exist in connectInfo database, it will be created. -- Applies necessary migrations to schema. --- TODO [postgres] authentication / user password, db encryption (?) createDBStore :: DBOpts -> [Migration] -> MigrationConfirmation -> IO (Either MigrationError DBStore) -createDBStore DBOpts {connstr, schema} migrations confirmMigrations = do - st <- connectPostgresStore connstr schema +createDBStore opts migrations confirmMigrations = do + st <- connectPostgresStore opts r <- migrateSchema st `onException` closeDBStore st case r of Right () -> pure $ Right st @@ -56,35 +52,50 @@ createDBStore DBOpts {connstr, schema} migrations confirmMigrations = do dbm = DBMigrate {initialize, getCurrent, run = Migrations.run st, backup = pure ()} in sharedMigrateSchema dbm (dbNew st) migrations confirmMigrations -connectPostgresStore :: ByteString -> String -> IO DBStore -connectPostgresStore dbConnstr dbSchema = do - (dbConn, dbNew) <- connectDB dbConnstr dbSchema -- TODO [postgres] analogue for dbBusyLoop? +connectPostgresStore :: DBOpts -> IO DBStore +connectPostgresStore DBOpts {connstr, schema, createSchema} = do + (dbConn, dbNew) <- connectDB connstr schema createSchema -- TODO [postgres] analogue for dbBusyLoop? dbConnection <- newMVar dbConn dbClosed <- newTVarIO False - pure DBStore {dbConnstr, dbSchema, dbConnection, dbNew, dbClosed} + pure DBStore {dbConnstr = connstr, dbSchema = schema, dbConnection, dbNew, dbClosed} -connectDB :: ByteString -> String -> IO (DB.Connection, Bool) -connectDB connstr schema = do +connectDB :: ByteString -> ByteString -> Bool -> IO (DB.Connection, Bool) +connectDB connstr schema createSchema = do db <- PSQL.connectPostgreSQL connstr - schemaExists <- prepare db `onException` PSQL.close db - let dbNew = not schemaExists + dbNew <- prepare db `onException` PSQL.close db pure (db, dbNew) where prepare db = do void $ PSQL.execute_ db "SET client_min_messages TO WARNING" - [Only schemaExists] <- - PSQL.query - db - [sql| - SELECT EXISTS ( - SELECT 1 FROM pg_catalog.pg_namespace - WHERE nspname = ? - ) - |] - (Only schema) - unless schemaExists $ void $ PSQL.execute_ db (fromString $ "CREATE SCHEMA " <> schema) - void $ PSQL.execute_ db (fromString $ "SET search_path TO " <> schema) - pure schemaExists + dbNew <- not <$> doesSchemaExist db schema + when dbNew $ + if createSchema + then void $ PSQL.execute_ db $ Query $ "CREATE SCHEMA " <> schema + else do + logError $ "connectPostgresStore, schema " <> safeDecodeUtf8 schema <> " does not exist, exiting." + PSQL.close db + exitFailure + void $ PSQL.execute_ db $ Query $ "SET search_path TO " <> schema + pure dbNew + +checkSchemaExists :: ByteString -> ByteString -> IO Bool +checkSchemaExists connstr schema = do + db <- PSQL.connectPostgreSQL connstr + doesSchemaExist db schema `finally` DB.close db + +doesSchemaExist :: DB.Connection -> ByteString -> IO Bool +doesSchemaExist db schema = do + [Only schemaExists] <- + PSQL.query + db + [sql| + SELECT EXISTS ( + SELECT 1 FROM pg_catalog.pg_namespace + WHERE nspname = ? + ) + |] + (Only schema) + pure schemaExists -- can share with SQLite closeDBStore :: DBStore -> IO () @@ -100,7 +111,7 @@ openPostgresStore_ DBStore {dbConnstr, dbSchema, dbConnection, dbClosed} = (takeMVar dbConnection) (tryPutMVar dbConnection) $ \_dbConn -> do - (dbConn, _dbNew) <- connectDB dbConnstr dbSchema + (dbConn, _dbNew) <- connectDB dbConnstr dbSchema False atomically $ writeTVar dbClosed False putMVar dbConnection dbConn @@ -110,6 +121,6 @@ reopenDBStore st@DBStore {dbClosed} = where open = openPostgresStore_ st --- TODO [postgres] not necessary for postgres (used for ExecAgentStoreSQL, ExecChatStoreSQL) +-- not used with postgres client (used for ExecAgentStoreSQL, ExecChatStoreSQL) execSQL :: PSQL.Connection -> Text -> IO [Text] execSQL _db _query = throwIO (userError "not implemented") diff --git a/src/Simplex/Messaging/Agent/Store/Postgres/Common.hs b/src/Simplex/Messaging/Agent/Store/Postgres/Common.hs index f130a1b5f..be14d1a5b 100644 --- a/src/Simplex/Messaging/Agent/Store/Postgres/Common.hs +++ b/src/Simplex/Messaging/Agent/Store/Postgres/Common.hs @@ -2,6 +2,7 @@ module Simplex.Messaging.Agent.Store.Postgres.Common ( DBStore (..), + DBOpts (..), withConnection, withConnection', withTransaction, @@ -18,25 +19,36 @@ import UnliftIO.STM -- TODO [postgres] use log_min_duration_statement instead of custom slow queries (SQLite's Connection type) data DBStore = DBStore { dbConnstr :: ByteString, - dbSchema :: String, + dbSchema :: ByteString, dbConnection :: MVar PSQL.Connection, dbClosed :: TVar Bool, dbNew :: Bool } +data DBOpts = DBOpts + { connstr :: ByteString, + schema :: ByteString, + createSchema :: Bool + } + deriving (Show) + -- TODO [postgres] connection pool withConnectionPriority :: DBStore -> Bool -> (PSQL.Connection -> IO a) -> IO a withConnectionPriority DBStore {dbConnection} _priority action = withMVar dbConnection action +{-# INLINE withConnectionPriority #-} withConnection :: DBStore -> (PSQL.Connection -> IO a) -> IO a withConnection st = withConnectionPriority st False +{-# INLINE withConnection #-} withConnection' :: DBStore -> (PSQL.Connection -> IO a) -> IO a withConnection' = withConnection +{-# INLINE withConnection' #-} withTransaction' :: DBStore -> (PSQL.Connection -> IO a) -> IO a withTransaction' = withTransaction +{-# INLINE withTransaction' #-} withTransaction :: DBStore -> (PSQL.Connection -> IO a) -> IO a withTransaction st = withTransactionPriority st False diff --git a/src/Simplex/Messaging/Agent/Store/Postgres/DB.hs b/src/Simplex/Messaging/Agent/Store/Postgres/DB.hs index 38debb070..fc2c7cef0 100644 --- a/src/Simplex/Messaging/Agent/Store/Postgres/DB.hs +++ b/src/Simplex/Messaging/Agent/Store/Postgres/DB.hs @@ -13,16 +13,23 @@ module Simplex.Messaging.Agent.Store.Postgres.DB executeMany, PSQL.query, PSQL.query_, + blobFieldDecoder, + fromTextField_, ) where import Control.Monad (void) +import Data.ByteString.Char8 (ByteString) import Data.Int (Int64) +import Data.Text (Text) +import Data.Text.Encoding (decodeUtf8) +import Data.Typeable (Typeable) import Data.Word (Word16, Word32) import Database.PostgreSQL.Simple (ResultError (..)) import qualified Database.PostgreSQL.Simple as PSQL -import Database.PostgreSQL.Simple.FromField (FromField (..), returnError) +import Database.PostgreSQL.Simple.FromField (Field (..), FieldParser, FromField (..), returnError) import Database.PostgreSQL.Simple.ToField (ToField (..)) +import Database.PostgreSQL.Simple.TypeInfo.Static (textOid, varcharOid) newtype BoolInt = BI {unBI :: Bool} @@ -63,3 +70,20 @@ instance FromField Word16 where if i >= 0 && i <= fromIntegral (maxBound :: Word16) then pure (fromIntegral i :: Word16) else returnError ConversionFailed field "Negative value can't be converted to Word16" + +blobFieldDecoder :: Typeable k => (ByteString -> Either String k) -> FieldParser k +blobFieldDecoder dec f val = do + x <- fromField f val + case dec x of + Right k -> pure k + Left e -> returnError ConversionFailed f ("couldn't parse field: " ++ e) + +fromTextField_ :: Typeable a => (Text -> Maybe a) -> FieldParser a +fromTextField_ fromText f val = + if typeOid f `elem` [textOid, varcharOid] + then case val of + Just t -> case fromText $ decodeUtf8 t of + Just x -> pure x + _ -> returnError ConversionFailed f "invalid text value" + Nothing -> returnError UnexpectedNull f "NULL value found for non-NULL field" + else returnError Incompatible f "expecting TEXT or VARCHAR column type" diff --git a/src/Simplex/Messaging/Agent/Store/SQLite.hs b/src/Simplex/Messaging/Agent/Store/SQLite.hs index 72792ba65..c724c031b 100644 --- a/src/Simplex/Messaging/Agent/Store/SQLite.hs +++ b/src/Simplex/Messaging/Agent/Store/SQLite.hs @@ -67,14 +67,6 @@ import UnliftIO.STM -- * SQLite Store implementation -data DBOpts = DBOpts - { dbFilePath :: FilePath, - dbKey :: ScrubbedBytes, - keepKey :: Bool, - vacuum :: Bool, - track :: DB.TrackQueries - } - createDBStore :: DBOpts -> [Migration] -> MigrationConfirmation -> IO (Either MigrationError DBStore) createDBStore DBOpts {dbFilePath, dbKey, keepKey, track, vacuum} migrations confirmMigrations = do let dbDir = takeDirectory dbFilePath diff --git a/src/Simplex/Messaging/Agent/Store/SQLite/Common.hs b/src/Simplex/Messaging/Agent/Store/SQLite/Common.hs index 3b0c4d6c8..3800dc362 100644 --- a/src/Simplex/Messaging/Agent/Store/SQLite/Common.hs +++ b/src/Simplex/Messaging/Agent/Store/SQLite/Common.hs @@ -5,6 +5,7 @@ module Simplex.Messaging.Agent.Store.SQLite.Common ( DBStore (..), + DBOpts (..), withConnection, withConnection', withTransaction, @@ -39,6 +40,14 @@ data DBStore = DBStore dbNew :: Bool } +data DBOpts = DBOpts + { dbFilePath :: FilePath, + dbKey :: ScrubbedBytes, + keepKey :: Bool, + vacuum :: Bool, + track :: DB.TrackQueries + } + withConnectionPriority :: DBStore -> Bool -> (DB.Connection -> IO a) -> IO a withConnectionPriority DBStore {dbSem, dbConnection} priority action | priority = E.bracket_ signal release $ withMVar dbConnection action diff --git a/src/Simplex/Messaging/Agent/Store/SQLite/DB.hs b/src/Simplex/Messaging/Agent/Store/SQLite/DB.hs index 59c282c46..7da6b2ca2 100644 --- a/src/Simplex/Messaging/Agent/Store/SQLite/DB.hs +++ b/src/Simplex/Messaging/Agent/Store/SQLite/DB.hs @@ -21,6 +21,8 @@ module Simplex.Messaging.Agent.Store.SQLite.DB executeMany, query, query_, + blobFieldDecoder, + fromTextField_, ) where @@ -33,10 +35,14 @@ import Data.Int (Int64) import Data.Map.Strict (Map) import qualified Data.Map.Strict as M import Data.Text (Text) +import qualified Data.Text as T import Data.Time (diffUTCTime, getCurrentTime) -import Database.SQLite.Simple (FromRow, Query, ToRow) +import Data.Typeable (Typeable) +import Database.SQLite.Simple (FromRow, ResultError (..), Query, SQLData (..), ToRow) import qualified Database.SQLite.Simple as SQL -import Database.SQLite.Simple.FromField (FromField (..)) +import Database.SQLite.Simple.FromField (FieldParser, FromField (..), returnError) +import Database.SQLite.Simple.Internal (Field (..)) +import Database.SQLite.Simple.Ok (Ok (Ok)) import Database.SQLite.Simple.ToField (ToField (..)) import Simplex.Messaging.Parsers (defaultJSON) import Simplex.Messaging.TMap (TMap) @@ -129,4 +135,20 @@ query_ :: FromRow r => Connection -> Query -> IO [r] query_ c sql = timeIt c sql $ SQL.query_ (conn c) sql {-# INLINE query_ #-} +blobFieldDecoder :: Typeable k => (ByteString -> Either String k) -> FieldParser k +blobFieldDecoder dec = \case + f@(Field (SQLBlob b) _) -> + case dec b of + Right k -> Ok k + Left e -> returnError ConversionFailed f ("couldn't parse field: " ++ e) + f -> returnError ConversionFailed f "expecting SQLBlob column type" + +fromTextField_ :: Typeable a => (Text -> Maybe a) -> Field -> Ok a +fromTextField_ fromText = \case + f@(Field (SQLText t) _) -> + case fromText t of + Just x -> Ok x + _ -> returnError ConversionFailed f ("invalid text: " <> T.unpack t) + f -> returnError ConversionFailed f "expecting SQLText column type" + $(J.deriveJSON defaultJSON ''SlowQueryStats) diff --git a/src/Simplex/Messaging/Crypto.hs b/src/Simplex/Messaging/Crypto.hs index 5a22ef203..b4af69450 100644 --- a/src/Simplex/Messaging/Crypto.hs +++ b/src/Simplex/Messaging/Crypto.hs @@ -239,10 +239,10 @@ import Data.X509 import Data.X509.Validation (Fingerprint (..), getFingerprint) import GHC.TypeLits (ErrorMessage (..), KnownNat, Nat, TypeError, natVal, type (+)) import Network.Transport.Internal (decodeWord16, encodeWord16) -import Simplex.Messaging.Agent.Store.DB (Binary (..), FromField (..), ToField (..)) +import Simplex.Messaging.Agent.Store.DB (Binary (..), FromField (..), ToField (..), blobFieldDecoder) import Simplex.Messaging.Encoding import Simplex.Messaging.Encoding.String -import Simplex.Messaging.Parsers (blobFieldDecoder, parseAll, parseString) +import Simplex.Messaging.Parsers (parseAll, parseString) import Simplex.Messaging.Util ((<$?>)) -- | Cryptographic algorithms. diff --git a/src/Simplex/Messaging/Crypto/Ratchet.hs b/src/Simplex/Messaging/Crypto/Ratchet.hs index bd87f70b9..5ac052ad8 100644 --- a/src/Simplex/Messaging/Crypto/Ratchet.hs +++ b/src/Simplex/Messaging/Crypto/Ratchet.hs @@ -116,12 +116,12 @@ import Data.Type.Equality import Data.Typeable (Typeable) import Data.Word (Word16, Word32) import Simplex.Messaging.Agent.QueryString -import Simplex.Messaging.Agent.Store.DB (Binary (..), BoolInt (..), FromField (..), ToField (..)) +import Simplex.Messaging.Agent.Store.DB (Binary (..), BoolInt (..), FromField (..), ToField (..), blobFieldDecoder) import Simplex.Messaging.Crypto import Simplex.Messaging.Crypto.SNTRUP761.Bindings import Simplex.Messaging.Encoding import Simplex.Messaging.Encoding.String -import Simplex.Messaging.Parsers (blobFieldDecoder, blobFieldParser, defaultJSON, parseE, parseE') +import Simplex.Messaging.Parsers (defaultJSON, parseE, parseE') import Simplex.Messaging.Util (($>>=), (<$?>)) import Simplex.Messaging.Version import Simplex.Messaging.Version.Internal @@ -1186,4 +1186,4 @@ instance Encoding (MsgEncryptKey a) where instance AlgorithmI a => ToField (MsgEncryptKey a) where toField = toField . Binary . smpEncode -instance (AlgorithmI a, Typeable a) => FromField (MsgEncryptKey a) where fromField = blobFieldParser smpP +instance (AlgorithmI a, Typeable a) => FromField (MsgEncryptKey a) where fromField = blobFieldDecoder smpDecode diff --git a/src/Simplex/Messaging/Notifications/Protocol.hs b/src/Simplex/Messaging/Notifications/Protocol.hs index 4284a6131..3594c2bc7 100644 --- a/src/Simplex/Messaging/Notifications/Protocol.hs +++ b/src/Simplex/Messaging/Notifications/Protocol.hs @@ -28,12 +28,11 @@ import Data.Time.Clock.System import Data.Type.Equality import Data.Word (Word16) import Simplex.Messaging.Agent.Protocol (updateSMPServerHosts) -import Simplex.Messaging.Agent.Store.DB (FromField (..), ToField (..)) +import Simplex.Messaging.Agent.Store.DB (FromField (..), ToField (..), fromTextField_) import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Encoding import Simplex.Messaging.Encoding.String import Simplex.Messaging.Notifications.Transport (NTFVersion, invalidReasonNTFVersion, ntfClientHandshake) -import Simplex.Messaging.Parsers (fromTextField_) import Simplex.Messaging.Protocol hiding (Command (..), CommandTag (..)) import Simplex.Messaging.Util (eitherToMaybe, (<$?>)) diff --git a/src/Simplex/Messaging/Notifications/Types.hs b/src/Simplex/Messaging/Notifications/Types.hs index 3daf97970..4a335c964 100644 --- a/src/Simplex/Messaging/Notifications/Types.hs +++ b/src/Simplex/Messaging/Notifications/Types.hs @@ -10,11 +10,10 @@ import qualified Data.Attoparsec.ByteString.Char8 as A import Data.Text.Encoding (decodeLatin1, encodeUtf8) import Data.Time (UTCTime) import Simplex.Messaging.Agent.Protocol (ConnId, NotificationsMode (..), UserId) -import Simplex.Messaging.Agent.Store.DB (Binary (..), FromField (..), ToField (..)) +import Simplex.Messaging.Agent.Store.DB (Binary (..), FromField (..), ToField (..), blobFieldDecoder, fromTextField_) import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Encoding import Simplex.Messaging.Notifications.Protocol -import Simplex.Messaging.Parsers (blobFieldDecoder, fromTextField_) import Simplex.Messaging.Protocol (NotifierId, NtfServer, SMPServer) data NtfTknAction diff --git a/src/Simplex/Messaging/Parsers.hs b/src/Simplex/Messaging/Parsers.hs index 008acd1d5..4e1a5ee20 100644 --- a/src/Simplex/Messaging/Parsers.hs +++ b/src/Simplex/Messaging/Parsers.hs @@ -16,24 +16,11 @@ import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B import Data.Char (isAlphaNum, toLower) import Data.String -import Data.Text (Text) import qualified Data.Text as T import Data.Time.Clock (UTCTime) import Data.Time.ISO8601 (parseISO8601) -import Data.Typeable (Typeable) import Simplex.Messaging.Util (safeDecodeUtf8, (<$?>)) import Text.Read (readMaybe) -#if defined(dbPostgres) -import Database.PostgreSQL.Simple (ResultError (..)) -import Database.PostgreSQL.Simple.FromField (FromField(..), FieldParser, returnError, Field (..)) -import Database.PostgreSQL.Simple.TypeInfo.Static (textOid, varcharOid) -import qualified Data.Text.Encoding as TE -#else -import Database.SQLite.Simple (ResultError (..), SQLData (..)) -import Database.SQLite.Simple.FromField (FieldParser, returnError) -import Database.SQLite.Simple.Internal (Field (..)) -import Database.SQLite.Simple.Ok (Ok (Ok)) -#endif base64P :: Parser ByteString base64P = decode <$?> paddedBase64 rawBase64P @@ -83,47 +70,6 @@ wordEnd c = c == ' ' || c == '\n' parseString :: (ByteString -> Either String a) -> (String -> a) parseString p = either error id . p . B.pack -blobFieldParser :: Typeable k => Parser k -> FieldParser k -blobFieldParser = blobFieldDecoder . parseAll - -#if defined(dbPostgres) -blobFieldDecoder :: Typeable k => (ByteString -> Either String k) -> FieldParser k -blobFieldDecoder dec f val = do - x <- fromField f val - case dec x of - Right k -> pure k - Left e -> returnError ConversionFailed f ("couldn't parse field: " ++ e) -#else -blobFieldDecoder :: Typeable k => (ByteString -> Either String k) -> FieldParser k -blobFieldDecoder dec = \case - f@(Field (SQLBlob b) _) -> - case dec b of - Right k -> Ok k - Left e -> returnError ConversionFailed f ("couldn't parse field: " ++ e) - f -> returnError ConversionFailed f "expecting SQLBlob column type" -#endif - --- TODO [postgres] review -#if defined(dbPostgres) -fromTextField_ :: Typeable a => (Text -> Maybe a) -> FieldParser a -fromTextField_ fromText f val = - if typeOid f `elem` [textOid, varcharOid] - then case val of - Just t -> case fromText (TE.decodeUtf8 t) of - Just x -> pure x - _ -> returnError ConversionFailed f "invalid text value" - Nothing -> returnError UnexpectedNull f "NULL value found for non-NULL field" - else returnError Incompatible f "expecting TEXT or VARCHAR column type" -#else -fromTextField_ :: Typeable a => (Text -> Maybe a) -> Field -> Ok a -fromTextField_ fromText = \case - f@(Field (SQLText t) _) -> - case fromText t of - Just x -> Ok x - _ -> returnError ConversionFailed f ("invalid text: " <> T.unpack t) - f -> returnError ConversionFailed f "expecting SQLText column type" -#endif - fstToLower :: String -> String fstToLower "" = "" fstToLower (h : t) = toLower h : t diff --git a/src/Simplex/Messaging/Server.hs b/src/Simplex/Messaging/Server.hs index 8452a2eb6..e1d4d7861 100644 --- a/src/Simplex/Messaging/Server.hs +++ b/src/Simplex/Messaging/Server.hs @@ -13,6 +13,7 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} -- | -- Module : Simplex.Messaging.Server @@ -96,14 +97,14 @@ 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 (JournalQueue, closeMsgQueue) +import Simplex.Messaging.Server.MsgStore.Journal (JournalMsgStore, JournalQueue, closeMsgQueue) import Simplex.Messaging.Server.MsgStore.STM import Simplex.Messaging.Server.MsgStore.Types 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 +import Simplex.Messaging.Server.QueueStore.Types import Simplex.Messaging.Server.Stats import Simplex.Messaging.Server.StoreLog (foldLogLines) import Simplex.Messaging.TMap (TMap) @@ -234,7 +235,7 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg, startOpt saveServer :: Bool -> M () saveServer drainMsgs = do - ams@(AMS _ ms) <- asks msgStore + ams@(AMS _ _ ms) <- asks msgStore liftIO $ saveServerMessages drainMsgs ams >> closeMsgStore ms saveServerNtfs saveServerStats @@ -284,17 +285,17 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg, startOpt -- This case catches Just Nothing - it cannot happen here. -- Nothing is there only before client thread is started. _ -> TM.lookup qId ss >>= mapM readTVar -- do not insert client if it is already disconnected, but send END to any other client - clientToBeNotified ac@(AClient _ c') + clientToBeNotified ac@(AClient _ _ c') | clntId == clientId c' = pure Nothing | otherwise = (\yes -> if yes then Just ((qId, subscribed), ac) else Nothing) <$> readTVar (connected c') endPreviousSubscriptions :: ((QueueId, Subscribed), AClient) -> IO (Maybe s) - endPreviousSubscriptions (qEvt@(qId, _), ac@(AClient _ c)) = do + endPreviousSubscriptions (qEvt@(qId, _), ac@(AClient _ _ c)) = do atomically $ modifyTVar' (pendingEvts s) $ IM.alter (Just . maybe [qEvt] (qEvt <|)) (clientId c) atomically $ do sub <- TM.lookupDelete qId (clientSubs c) removeWhenNoSubs ac $> sub -- remove client from server's subscribed cients - removeWhenNoSubs (AClient _ c) = whenM (null <$> readTVar (clientSubs c)) $ modifyTVar' (subClnts s) $ IM.delete (clientId c) + removeWhenNoSubs (AClient _ _ c) = whenM (null <$> readTVar (clientSubs c)) $ modifyTVar' (subClnts s) $ IM.delete (clientId c) deliverNtfsThread :: Server -> M () deliverNtfsThread Server {ntfSubClients} = do @@ -305,7 +306,7 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg, startOpt threadDelay ntfInt readTVarIO ntfSubClients >>= mapM_ (deliverNtfs ns stats) where - deliverNtfs ns stats (AClient _ Client {clientId, ntfSubscriptions, sndQ, connected}) = + deliverNtfs ns stats (AClient _ _ Client {clientId, ntfSubscriptions, sndQ, connected}) = whenM (currentClient readTVarIO) $ do subs <- readTVarIO ntfSubscriptions ntfQs <- M.assocs . M.filterWithKey (\nId _ -> M.member nId subs) <$> readTVarIO ns @@ -351,7 +352,7 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg, startOpt ends <- atomically $ swapTVar ref IM.empty unless (null ends) $ forM_ (IM.assocs ends) $ \(cId, qEvts) -> mapM_ (queueEvts qEvts) . join . IM.lookup cId =<< readTVarIO cls - queueEvts qEvts (AClient _ c@Client {connected, sndQ = q}) = + queueEvts qEvts (AClient _ _ c@Client {connected, sndQ = q}) = whenM (readTVarIO connected) $ do sent <- atomically $ ifM (isFullTBQueue q) (pure False) (writeTBQueue q ts $> True) if sent @@ -389,7 +390,7 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg, startOpt expireMessagesThread :: ExpirationConfig -> M () expireMessagesThread expCfg = do - AMS _ ms <- asks msgStore + AMS _ _ ms <- asks msgStore let interval = checkInterval expCfg * 1000000 stats <- asks serverStats labelMyThread "expireMessagesThread" @@ -434,9 +435,9 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg, startOpt liftIO $ threadDelay' $ 1000000 * (initialDelay + if initialDelay < 0 then 86400 else 0) ss@ServerStats {fromTime, qCreated, qSecured, qDeletedAll, qDeletedAllB, qDeletedNew, qDeletedSecured, qSub, qSubAllB, qSubAuth, qSubDuplicate, qSubProhibited, qSubEnd, qSubEndB, ntfCreated, ntfDeleted, ntfDeletedB, ntfSub, ntfSubB, ntfSubAuth, ntfSubDuplicate, msgSent, msgSentAuth, msgSentQuota, msgSentLarge, msgRecv, msgRecvGet, msgGet, msgGetNoMsg, msgGetAuth, msgGetDuplicate, msgGetProhibited, msgExpired, activeQueues, msgSentNtf, msgRecvNtf, activeQueuesNtf, qCount, msgCount, ntfCount, pRelays, pRelaysOwn, pMsgFwds, pMsgFwdsOwn, pMsgFwdsRecv} <- asks serverStats - AMS _ st <- asks msgStore - let STMQueueStore {queues, notifiers} = stmQueueStore st - interval = 1000000 * logInterval + AMS _ _ (st :: s) <- asks msgStore + QueueCounts {queueCount, notifierCount} <- liftIO $ queueCounts @(StoreQueue s) $ queueStore st + let interval = 1000000 * logInterval forever $ do withFile statsFilePath AppendMode $ \h -> liftIO $ do hSetBuffering h LineBuffering @@ -489,8 +490,6 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg, startOpt pMsgFwdsOwn' <- getResetProxyStatsData pMsgFwdsOwn pMsgFwdsRecv' <- atomicSwapIORef pMsgFwdsRecv 0 qCount' <- readIORef qCount - qCount'' <- M.size <$> readTVarIO queues - notifierCount' <- M.size <$> readTVarIO notifiers msgCount' <- readIORef msgCount ntfCount' <- readIORef ntfCount hPutStrLn h $ @@ -543,13 +542,13 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg, startOpt "0", -- dayCount psSub; psSub is removed to reduce memory usage "0", -- weekCount psSub "0", -- monthCount psSub - show qCount'', + show queueCount, show ntfCreated', show ntfDeleted', show ntfSub', show ntfSubAuth', show ntfSubDuplicate', - show notifierCount', + show notifierCount, show qDeletedAllB', show qSubAllB', show qSubEnd', @@ -575,7 +574,7 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg, startOpt savePrometheusMetrics saveInterval metricsFile = do labelMyThread "savePrometheusMetrics" liftIO $ putStrLn $ "Prometheus metrics saved every " <> show saveInterval <> " seconds to " <> metricsFile - AMS _ st <- asks msgStore + AMS _ _ st <- asks msgStore ss <- asks serverStats env <- ask let interval = 1000000 * saveInterval @@ -586,14 +585,12 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg, startOpt rtm <- getRealTimeMetrics env T.writeFile metricsFile $ prometheusMetrics sm rtm ts - getServerMetrics :: STMStoreClass s => s -> ServerStats -> IO ServerMetrics + getServerMetrics :: forall s. MsgStoreClass s => s -> ServerStats -> IO ServerMetrics getServerMetrics st ss = do d <- getServerStatsData ss let ps = periodStatDataCounts $ _activeQueues d psNtf = periodStatDataCounts $ _activeQueuesNtf d - STMQueueStore {queues, notifiers} = stmQueueStore st - queueCount <- M.size <$> readTVarIO queues - notifierCount <- M.size <$> readTVarIO notifiers + QueueCounts {queueCount, notifierCount} <- queueCounts @(StoreQueue s) $ queueStore st pure ServerMetrics {statsData = d, activeQueueCounts = ps, activeNtfCounts = psNtf, queueCount, notifierCount} getRealTimeMetrics :: Env -> IO RealTimeMetrics @@ -670,7 +667,7 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg, startOpt CPClients -> withAdminRole $ do active <- unliftIO u (asks clients) >>= readTVarIO hPutStrLn h "clientId,sessionId,connected,createdAt,rcvActiveAt,sndActiveAt,age,subscriptions" - forM_ (IM.toList active) $ \(cid, cl) -> forM_ cl $ \(AClient _ Client {sessionId, connected, createdAt, rcvActiveAt, sndActiveAt, subscriptions}) -> do + forM_ (IM.toList active) $ \(cid, cl) -> forM_ cl $ \(AClient _ _ Client {sessionId, connected, createdAt, rcvActiveAt, sndActiveAt, subscriptions}) -> do connected' <- bshow <$> readTVarIO connected rcvActiveAt' <- strEncode <$> readTVarIO rcvActiveAt sndActiveAt' <- strEncode <$> readTVarIO sndActiveAt @@ -680,9 +677,9 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg, startOpt hPutStrLn h . B.unpack $ B.intercalate "," [bshow cid, encode sessionId, connected', strEncode createdAt, rcvActiveAt', sndActiveAt', bshow age, subscriptions'] CPStats -> withUserRole $ do ss <- unliftIO u $ asks serverStats - AMS _ st <- unliftIO u $ asks msgStore - let STMQueueStore {queues, notifiers} = stmQueueStore st - getStat :: (ServerStats -> IORef a) -> IO a + AMS _ _ (st :: s) <- unliftIO u $ asks msgStore + QueueCounts {queueCount, notifierCount} <- queueCounts @(StoreQueue s) $ queueStore st + let getStat :: (ServerStats -> IORef a) -> IO a getStat var = readIORef (var ss) putStat :: Show a => String -> (ServerStats -> IORef a) -> IO () putStat label var = getStat var >>= \v -> hPutStrLn h $ label <> ": " <> show v @@ -719,9 +716,7 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg, startOpt putStat "msgNtfsB" msgNtfsB putStat "msgNtfExpired" msgNtfExpired putStat "qCount" qCount - qCount2 <- M.size <$> readTVarIO queues - hPutStrLn h $ "qCount 2: " <> show qCount2 - notifierCount <- M.size <$> readTVarIO notifiers + hPutStrLn h $ "qCount 2: " <> show queueCount hPutStrLn h $ "notifiers: " <> show notifierCount putStat "msgCount" msgCount putStat "ntfCount" ntfCount @@ -822,7 +817,7 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg, startOpt where addSubs :: (Int, (Int, Int, Int, Int), Int, (Natural, Natural, Natural)) -> Maybe AClient -> IO (Int, (Int, Int, Int, Int), Int, (Natural, Natural, Natural)) addSubs acc Nothing = pure acc - addSubs (!subCnt, cnts@(!c1, !c2, !c3, !c4), !clCnt, !qs) (Just acl@(AClient _ cl)) = do + addSubs (!subCnt, cnts@(!c1, !c2, !c3, !c4), !clCnt, !qs) (Just acl@(AClient _ _ cl)) = do subs <- readTVarIO $ subSel cl cnts' <- case countSubs_ of Nothing -> pure cnts @@ -835,7 +830,7 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg, startOpt pure (subCnt + cnt, cnts', clCnt', qs') clientTBQueueLengths' :: Foldable t => t (Maybe AClient) -> IO (Natural, Natural, Natural) clientTBQueueLengths' = foldM (\acc -> maybe (pure acc) (addQueueLengths acc)) (0, 0, 0) - addQueueLengths (!rl, !sl, !ml) (AClient _ cl) = do + addQueueLengths (!rl, !sl, !ml) (AClient _ _ cl) = do (rl', sl', ml') <- queueLengths cl pure (rl + rl', sl + sl', ml + ml') queueLengths Client {rcvQ, sndQ, msgQ} = do @@ -855,7 +850,7 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg, startOpt SubThread _ -> (c1, c2, c3 + 1, c4) ProhibitSub -> pure (c1, c2, c3, c4 + 1) CPDelete sId -> withUserRole $ unliftIO u $ do - AMS _ st <- asks msgStore + AMS _ _ st <- asks msgStore r <- liftIO $ runExceptT $ do q <- ExceptT $ getQueue st SSender sId ExceptT $ deleteQueueSize st q @@ -865,27 +860,27 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg, startOpt updateDeletedStats qr liftIO $ hPutStrLn h $ "ok, " <> show numDeleted <> " messages deleted" CPStatus sId -> withUserRole $ unliftIO u $ do - AMS _ st <- asks msgStore + AMS _ _ st <- asks msgStore q <- liftIO $ getQueueRec st SSender sId liftIO $ hPutStrLn h $ case q of Left e -> "error: " <> show e Right (_, QueueRec {sndSecure, status, updatedAt}) -> "status: " <> show status <> ", updatedAt: " <> show updatedAt <> ", sndSecure: " <> show sndSecure CPBlock sId info -> withUserRole $ unliftIO u $ do - AMS _ st <- asks msgStore + AMS _ _ (st :: s) <- asks msgStore r <- liftIO $ runExceptT $ do q <- ExceptT $ getQueue st SSender sId - ExceptT $ blockQueue st q info + ExceptT $ blockQueue (queueStore st) q info case r of Left e -> liftIO $ hPutStrLn h $ "error: " <> show e Right () -> do incStat . qBlocked =<< asks serverStats liftIO $ hPutStrLn h "ok" CPUnblock sId -> withUserRole $ unliftIO u $ do - AMS _ st <- asks msgStore + AMS _ _ (st :: s) <- asks msgStore r <- liftIO $ runExceptT $ do q <- ExceptT $ getQueue st SSender sId - ExceptT $ unblockQueue st q + ExceptT $ unblockQueue (queueStore st) q liftIO $ hPutStrLn h $ case r of Left e -> "error: " <> show e Right () -> "ok" @@ -917,13 +912,13 @@ runClientTransport h@THandle {params = thParams@THandleParams {thVersion, sessio nextClientId <- asks clientSeq clientId <- atomically $ stateTVar nextClientId $ \next -> (next, next + 1) atomically $ modifyTVar' active $ IM.insert clientId Nothing - AMS msType ms <- asks msgStore - c <- liftIO $ newClient msType clientId q thVersion sessionId ts - runClientThreads msType ms active c clientId `finally` clientDisconnected c + AMS qt mt ms <- asks msgStore + c <- liftIO $ newClient qt mt clientId q thVersion sessionId ts + runClientThreads qt mt ms active c clientId `finally` clientDisconnected c where - runClientThreads :: STMStoreClass (MsgStore s) => SMSType s -> MsgStore s -> TVar (IM.IntMap (Maybe AClient)) -> Client (MsgStore s) -> IS.Key -> M () - runClientThreads msType ms active c clientId = do - atomically $ modifyTVar' active $ IM.insert clientId $ Just (AClient msType c) + runClientThreads :: MsgStoreClass (MsgStore qs ms) => SQSType qs -> SMSType ms -> MsgStore qs ms -> TVar (IM.IntMap (Maybe AClient)) -> Client (MsgStore qs ms) -> IS.Key -> M () + runClientThreads qt mt ms active c clientId = do + atomically $ modifyTVar' active $ IM.insert clientId $ Just (AClient qt mt c) s <- asks server expCfg <- asks $ inactiveClientExpiration . config th <- newMVar h -- put TH under a fair lock to interleave messages and command responses @@ -967,7 +962,7 @@ clientDisconnected c@Client {clientId, subscriptions, ntfSubscriptions, connecte mapM_ (\c' -> atomically $ whenM (sameClientId c <$> readTVar c') $ TM.delete qId srvSubs) sameClientId :: Client s -> AClient -> Bool -sameClientId Client {clientId} (AClient _ Client {clientId = cId'}) = clientId == cId' +sameClientId Client {clientId} ac = clientId == clientId' ac cancelSub :: Sub -> IO () cancelSub s = case subThread s of @@ -977,7 +972,7 @@ cancelSub s = case subThread s of _ -> pure () ProhibitSub -> pure () -receive :: forall c s. (Transport c, STMStoreClass s) => THandleSMP c 'TServer -> s -> Client s -> M () +receive :: forall c s. (Transport c, MsgStoreClass s) => THandleSMP c 'TServer -> s -> Client s -> M () receive h@THandle {params = THandleParams {thAuth}} ms Client {rcvQ, sndQ, rcvActiveAt, sessionId} = do labelMyThread . B.unpack $ "client $" <> encode sessionId <> " receive" sa <- asks serverActive @@ -1077,7 +1072,7 @@ data VerificationResult s = VRVerified (Maybe (StoreQueue s, QueueRec)) | VRFail -- - the queue or party key do not exist. -- In all cases, the time of the verification should depend only on the provided authorization type, -- a dummy key is used to run verification in the last two cases, and failure is returned irrespective of the result. -verifyTransmission :: forall s. STMStoreClass s => s -> Maybe (THandleAuth 'TServer, C.CbNonce) -> Maybe TransmissionAuth -> ByteString -> QueueId -> Cmd -> M (VerificationResult s) +verifyTransmission :: forall s. MsgStoreClass s => s -> Maybe (THandleAuth 'TServer, C.CbNonce) -> Maybe TransmissionAuth -> ByteString -> QueueId -> Cmd -> M (VerificationResult s) verifyTransmission ms auth_ tAuth authorized queueId cmd = case cmd of Cmd SRecipient (NEW k _ _ _ _) -> pure $ Nothing `verifiedWith` k @@ -1154,7 +1149,7 @@ forkClient Client {endThreads, endThreadSeq} label action = do action `finally` atomically (modifyTVar' endThreads $ IM.delete tId) mkWeakThreadId t >>= atomically . modifyTVar' endThreads . IM.insert tId -client :: forall s. STMStoreClass s => THandleParams SMPVersion 'TServer -> Server -> s -> Client s -> M () +client :: forall s. MsgStoreClass s => THandleParams SMPVersion 'TServer -> Server -> s -> Client s -> M () client thParams' Server {subscribedQ, ntfSubscribedQ, subscribers} @@ -1325,7 +1320,7 @@ client secureQueue_ :: StoreQueue s -> SndPublicAuthKey -> M BrokerMsg secureQueue_ q sKey = do - liftIO (secureQueue ms q sKey) >>= \case + liftIO (secureQueue (queueStore ms) q sKey) >>= \case Left e -> pure $ ERR e Right () -> do stats <- asks serverStats @@ -1343,7 +1338,7 @@ client addNotifierRetry n rcvPublicDhKey rcvNtfDhSecret = do notifierId <- randomId =<< asks (queueIdBytes . config) let ntfCreds = NtfCreds {notifierId, notifierKey, rcvNtfDhSecret} - liftIO (addQueueNotifier ms q ntfCreds) >>= \case + liftIO (addQueueNotifier (queueStore ms) q ntfCreds) >>= \case Left DUPLICATE_ -> addNotifierRetry (n - 1) rcvPublicDhKey rcvNtfDhSecret Left e -> pure $ ERR e Right nId_ -> do @@ -1353,7 +1348,7 @@ client deleteQueueNotifier_ :: StoreQueue s -> M (Transmission BrokerMsg) deleteQueueNotifier_ q = - liftIO (deleteQueueNotifier ms q) >>= \case + liftIO (deleteQueueNotifier (queueStore ms) q) >>= \case Right (Just nId) -> do -- Possibly, the same should be done if the queue is suspended, but currently we do not use it stats <- asks serverStats @@ -1366,7 +1361,7 @@ client Left e -> pure $ err e suspendQueue_ :: (StoreQueue s, QueueRec) -> M (Transmission BrokerMsg) - suspendQueue_ (q, _) = liftIO $ either err (const ok) <$> suspendQueue ms q + suspendQueue_ (q, _) = liftIO $ either err (const ok) <$> suspendQueue (queueStore ms) q subscribeQueue :: StoreQueue s -> QueueRec -> M (Transmission BrokerMsg) subscribeQueue q qr = @@ -1383,7 +1378,7 @@ client incStat $ qSubDuplicate stats atomically (tryTakeTMVar $ delivered s) >> deliver False s where - rId = recipientId' q + rId = recipientId q newSub :: M Sub newSub = time "SUB newSub" . atomically $ do writeTQueue subscribedQ (rId, clientId, True) @@ -1447,7 +1442,7 @@ client t <- liftIO getSystemDate if updatedAt == Just t then action q qr - else liftIO (updateQueueTime ms q t) >>= either (pure . err) (action q) + else liftIO (updateQueueTime (queueStore ms) q t) >>= either (pure . err) (action q) subscribeNotifications :: M (Transmission BrokerMsg) subscribeNotifications = do @@ -1544,10 +1539,10 @@ client when (notification msgFlags) $ do mapM_ (`enqueueNotification` msg) (notifier qr) incStat $ msgSentNtf stats - liftIO $ updatePeriodStats (activeQueuesNtf stats) (recipientId' q) + liftIO $ updatePeriodStats (activeQueuesNtf stats) (recipientId q) incStat $ msgSent stats incStat $ msgCount stats - liftIO $ updatePeriodStats (activeQueues stats) (recipientId' q) + liftIO $ updatePeriodStats (activeQueues stats) (recipientId q) pure ok where mkMessage :: MsgId -> C.MaxLenBS MaxMessageLen -> IO Message @@ -1575,14 +1570,14 @@ client whenM (TM.memberIO rId subscribers) $ atomically deliverToSub >>= mapM_ forkDeliver where - rId = recipientId' q + rId = recipientId q deliverToSub = -- lookup has ot be in the same transaction, -- so that if subscription ends, it re-evalutates -- and delivery is cancelled - -- the new client will receive message in response to SUB. (TM.lookup rId subscribers >>= mapM readTVar) - $>>= \rc@(AClient _ Client {subscriptions = subs, sndQ = sndQ'}) -> TM.lookup rId subs + $>>= \rc@(AClient _ _ Client {subscriptions = subs, sndQ = sndQ'}) -> TM.lookup rId subs $>>= \s@Sub {subThread, delivered} -> case subThread of ProhibitSub -> pure Nothing ServerSub st -> readTVar st >>= \case @@ -1599,7 +1594,7 @@ client let encMsg = encryptMsg qr msg writeTBQueue sndQ' [(CorrId "", rId, MSG encMsg)] void $ setDelivered s msg - forkDeliver ((AClient _ rc@Client {sndQ = sndQ'}), s@Sub {delivered}, st) = do + forkDeliver ((AClient _ _ rc@Client {sndQ = sndQ'}), s@Sub {delivered}, st) = do t <- mkWeakThreadId =<< forkIO deliverThread atomically $ modifyTVar' st $ \case -- this case is needed because deliverThread can exit before it @@ -1798,10 +1793,10 @@ randomId = fmap EntityId . randomId' saveServerMessages :: Bool -> AMsgStore -> IO () saveServerMessages drainMsgs = \case - AMS SMSMemory ms@STMMsgStore {storeConfig = STMStoreConfig {storePath}} -> case storePath of + AMS SQSMemory SMSMemory ms@STMMsgStore {storeConfig = STMStoreConfig {storePath}} -> case storePath of Just f -> exportMessages False ms f drainMsgs Nothing -> logInfo "undelivered messages are not saved" - AMS SMSJournal _ -> logInfo "closed journal message storage" + AMS _ SMSJournal _ -> logInfo "closed journal message storage" exportMessages :: MsgStoreClass s => Bool -> s -> FilePath -> Bool -> IO () exportMessages tty ms f drainMsgs = do @@ -1814,7 +1809,7 @@ exportMessages tty ms f drainMsgs = do exitFailure where saveQueueMsgs h q = do - let rId = recipientId' q + let rId = recipientId q runExceptT (getQueueMessages drainMsgs ms q) >>= \case Right msgs -> Sum (length msgs) <$ BLD.hPutBuilder h (encodeMessages rId msgs) Left e -> do @@ -1830,41 +1825,46 @@ processServerMessages StartOptions {skipWarnings} = do where processMessages :: Maybe Int64 -> Bool -> AMsgStore -> IO (Maybe MessageStats) processMessages old_ expire = \case - AMS SMSMemory ms@STMMsgStore {storeConfig = STMStoreConfig {storePath}} -> case storePath of + AMS SQSMemory SMSMemory ms@STMMsgStore {storeConfig = STMStoreConfig {storePath}} -> case storePath of Just f -> ifM (doesFileExist f) (Just <$> importMessages False ms f old_ skipWarnings) (pure Nothing) Nothing -> pure Nothing - AMS SMSJournal ms - | expire -> Just <$> case old_ of - Just old -> do - logInfo "expiring journal store messages..." - withAllMsgQueues False ms $ processExpireQueue old - Nothing -> do - logInfo "validating journal store messages..." - withAllMsgQueues False ms $ processValidateQueue - | otherwise -> logWarn "skipping message expiration" $> Nothing - where - processExpireQueue old q = - runExceptT expireQueue >>= \case - Right (storedMsgsCount, expiredMsgsCount) -> - pure MessageStats {storedMsgsCount, expiredMsgsCount, storedQueues = 1} - Left e -> do - logError $ "STORE: processExpireQueue, failed expiring messages in queue, " <> tshow e - exitFailure - where - expireQueue = do - expired'' <- deleteExpiredMsgs ms q old - stored'' <- getQueueSize ms q - liftIO $ closeMsgQueue q - pure (stored'', expired'') - processValidateQueue :: JournalQueue -> IO MessageStats - processValidateQueue q = - runExceptT (getQueueSize ms q) >>= \case - Right storedMsgsCount -> pure newMessageStats {storedMsgsCount, storedQueues = 1} - Left e -> do - logError $ "STORE: processValidateQueue, failed opening message queue, " <> tshow e - exitFailure + AMS _ SMSJournal ms -> processJournalMessages old_ expire ms + -- TODO [postgres] is it needed? + -- AMS (SType SQSPostgres SMSJournal) ms -> processJournalMessages old_ expire ms + processJournalMessages :: forall s. Maybe Int64 -> Bool -> JournalMsgStore s -> IO (Maybe MessageStats) + processJournalMessages old_ expire ms + | expire = Just <$> case old_ of + Just old -> do + logInfo "expiring journal store messages..." + withAllMsgQueues False ms $ processExpireQueue old + Nothing -> do + logInfo "validating journal store messages..." + withAllMsgQueues False ms $ processValidateQueue + | otherwise = logWarn "skipping message expiration" $> Nothing + where + processExpireQueue :: Int64 -> JournalQueue s -> IO MessageStats + processExpireQueue old q = + runExceptT expireQueue >>= \case + Right (storedMsgsCount, expiredMsgsCount) -> + pure MessageStats {storedMsgsCount, expiredMsgsCount, storedQueues = 1} + Left e -> do + logError $ "STORE: processExpireQueue, failed expiring messages in queue, " <> tshow e + exitFailure + where + expireQueue = do + expired'' <- deleteExpiredMsgs ms q old + stored'' <- getQueueSize ms q + liftIO $ closeMsgQueue q + pure (stored'', expired'') + processValidateQueue :: JournalQueue s -> IO MessageStats + processValidateQueue q = + runExceptT (getQueueSize ms q) >>= \case + Right storedMsgsCount -> pure newMessageStats {storedMsgsCount, storedQueues = 1} + Left e -> do + logError $ "STORE: processValidateQueue, failed opening message queue, " <> tshow e + exitFailure -importMessages :: forall s. STMStoreClass s => Bool -> s -> FilePath -> Maybe Int64 -> Bool -> IO MessageStats +importMessages :: forall s. MsgStoreClass s => Bool -> s -> FilePath -> Maybe Int64 -> Bool -> IO MessageStats importMessages tty ms f old_ skipWarnings = do logInfo $ "restoring messages from file " <> T.pack f (_, (storedMsgsCount, expiredMsgsCount, overQuota)) <- @@ -1872,8 +1872,8 @@ importMessages tty ms f old_ skipWarnings = do renameFile f $ f <> ".bak" mapM_ setOverQuota_ overQuota logQueueStates ms - storedQueues <- M.size <$> readTVarIO (queues $ stmQueueStore ms) - pure MessageStats {storedMsgsCount, expiredMsgsCount, storedQueues} + QueueCounts {queueCount} <- liftIO $ queueCounts @(StoreQueue s) $ queueStore ms + pure MessageStats {storedMsgsCount, expiredMsgsCount, storedQueues = queueCount} where restoreMsg :: (Maybe (RecipientId, StoreQueue s), (Int, Int, M.Map RecipientId (StoreQueue s))) -> Bool -> ByteString -> IO (Maybe (RecipientId, StoreQueue s), (Int, Int, M.Map RecipientId (StoreQueue s))) restoreMsg (q_, counts@(!stored, !expired, !overQuota)) eof s = case strDecode s of @@ -1999,8 +1999,8 @@ restoreServerStats msgStats_ ntfStats = asks (serverStatsBackupFile . config) >> liftIO (strDecode <$> B.readFile f) >>= \case Right d@ServerStatsData {_qCount = statsQCount, _msgCount = statsMsgCount, _ntfCount = statsNtfCount} -> do s <- asks serverStats - AMS _ st <- asks msgStore - _qCount <- M.size <$> readTVarIO (queues $ stmQueueStore st) + AMS _ _ (st :: s) <- asks msgStore + QueueCounts {queueCount = _qCount} <- liftIO $ queueCounts @(StoreQueue s) $ queueStore st let _msgCount = maybe statsMsgCount storedMsgsCount msgStats_ _ntfCount = storedMsgsCount ntfStats _msgExpired' = _msgExpired d + maybe 0 expiredMsgsCount msgStats_ diff --git a/src/Simplex/Messaging/Server/CLI.hs b/src/Simplex/Messaging/Server/CLI.hs index feead1163..6dd7d184a 100644 --- a/src/Simplex/Messaging/Server/CLI.hs +++ b/src/Simplex/Messaging/Server/CLI.hs @@ -29,6 +29,7 @@ import Network.Socket (HostName, ServiceName) import Options.Applicative import Simplex.Messaging.Encoding.String import Simplex.Messaging.Protocol (ProtoServerWithAuth (..), ProtocolServer (..), ProtocolTypeI) +import Simplex.Messaging.Server.Env.STM (AServerStoreCfg (..), ServerStoreCfg (..), StorePaths (..)) import Simplex.Messaging.Transport (ATransport (..), TLS, Transport (..)) import Simplex.Messaging.Transport.Server (AddHTTP, loadFileFingerprint) import Simplex.Messaging.Transport.WebSockets (WS) @@ -301,6 +302,13 @@ printServerConfig transports logFile = do putStrLn $ "Serving SMP protocol on port " <> descr when addHTTP $ putStrLn $ "Serving static site on port " <> descr +-- TODO [postgres] +printSMPServerConfig :: [(ServiceName, ATransport, AddHTTP)] -> AServerStoreCfg -> IO () +printSMPServerConfig transports (ASSCfg _ _ cfg) = printServerConfig transports $ case cfg of + SSCMemory sp_ -> (\StorePaths {storeLogFile} -> storeLogFile) <$> sp_ + SSCMemoryJournal {storeLogFile} -> Just storeLogFile + SSCDatabaseJournal {} -> Just "postgres database" + deleteDirIfExists :: FilePath -> IO () deleteDirIfExists path = whenM (doesDirectoryExist path) $ removeDirectoryRecursive path diff --git a/src/Simplex/Messaging/Server/Env/STM.hs b/src/Simplex/Messaging/Server/Env/STM.hs index 005ce6d9b..b09e0549c 100644 --- a/src/Simplex/Messaging/Server/Env/STM.hs +++ b/src/Simplex/Messaging/Server/Env/STM.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} @@ -9,6 +10,8 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StrictData #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} module Simplex.Messaging.Server.Env.STM where @@ -21,18 +24,23 @@ import Data.ByteString.Char8 (ByteString) import Data.Int (Int64) import Data.IntMap.Strict (IntMap) import qualified Data.IntMap.Strict as IM +import Data.Kind (Constraint) import Data.List (intercalate) import Data.List.NonEmpty (NonEmpty) -import Data.Maybe (isJust, isNothing) +import Data.Maybe (isJust) import qualified Data.Text as T import Data.Time.Clock (getCurrentTime, nominalDay) import Data.Time.Clock.System (SystemTime) import qualified Data.X509 as X import Data.X509.Validation (Fingerprint (..)) +import GHC.TypeLits (TypeError) +import qualified GHC.TypeLits as TE import Network.Socket (ServiceName) import qualified Network.TLS as T import Numeric.Natural import Simplex.Messaging.Agent.Lock +import Simplex.Messaging.Agent.Store.Postgres.Common (DBOpts) +import Simplex.Messaging.Agent.Store.Shared (MigrationConfirmation (..)) import Simplex.Messaging.Client.Agent (SMPClientAgent, SMPClientAgentConfig, newSMPClientAgent) import Simplex.Messaging.Crypto (KeyHash (..)) import qualified Simplex.Messaging.Crypto as C @@ -44,9 +52,11 @@ import Simplex.Messaging.Server.MsgStore.STM import Simplex.Messaging.Server.MsgStore.Types import Simplex.Messaging.Server.NtfStore import Simplex.Messaging.Server.QueueStore -import Simplex.Messaging.Server.QueueStore.STM +import Simplex.Messaging.Server.QueueStore.STM (STMQueueStore, setStoreLog) +import Simplex.Messaging.Server.QueueStore.Types import Simplex.Messaging.Server.Stats import Simplex.Messaging.Server.StoreLog +import Simplex.Messaging.Server.StoreLog.ReadWrite import Simplex.Messaging.TMap (TMap) import qualified Simplex.Messaging.TMap as TM import Simplex.Messaging.Transport (ATransport, VersionRangeSMP, VersionSMP) @@ -61,14 +71,12 @@ data ServerConfig = ServerConfig { transports :: [(ServiceName, ATransport, AddHTTP)], smpHandshakeTimeout :: Int, tbqSize :: Natural, - msgStoreType :: AMSType, msgQueueQuota :: Int, maxJournalMsgCount :: Int, maxJournalStateLines :: Int, queueIdBytes :: Int, msgIdBytes :: Int, - storeLogFile :: Maybe FilePath, - storeMsgsFile :: Maybe FilePath, + serverStoreCfg :: AServerStoreCfg, storeNtfsFile :: Maybe FilePath, -- | set to False to prohibit creating new queues allowNewQueues :: Bool, @@ -122,7 +130,8 @@ data ServerConfig = ServerConfig data StartOptions = StartOptions { maintenance :: Bool, - skipWarnings :: Bool + skipWarnings :: Bool, + confirmMigrations :: MigrationConfirmation } defMsgExpirationDays :: Int64 @@ -191,19 +200,31 @@ data Env = Env proxyAgent :: ProxyAgent -- senders served on this proxy } -type family MsgStore s where - MsgStore 'MSMemory = STMMsgStore - MsgStore 'MSJournal = JournalMsgStore +type family SupportedStore (qs :: QSType) (ms :: MSType) :: Constraint where + SupportedStore 'QSMemory 'MSMemory = () + SupportedStore 'QSMemory 'MSJournal = () + SupportedStore 'QSPostgres 'MSJournal = () + SupportedStore 'QSPostgres 'MSMemory = + (Int ~ Bool, TypeError ('TE.Text "Storing messages in memory with Postgres DB is not supported")) -data AMsgStore = forall s. (STMStoreClass (MsgStore s), MsgStoreClass (MsgStore s)) => AMS (SMSType s) (MsgStore s) +data AStoreType = forall qs ms. SupportedStore qs ms => ASType (SQSType qs) (SMSType ms) -data AStoreQueue = forall s. MsgStoreClass (MsgStore s) => ASQ (SMSType s) (StoreQueue (MsgStore s)) +data ServerStoreCfg qs ms where + SSCMemory :: Maybe StorePaths -> ServerStoreCfg 'QSMemory 'MSMemory + SSCMemoryJournal :: {storeLogFile :: FilePath, storeMsgsPath :: FilePath} -> ServerStoreCfg 'QSMemory 'MSJournal + SSCDatabaseJournal :: {storeDBOpts :: DBOpts, confirmMigrations :: MigrationConfirmation, storeMsgsPath' :: FilePath} -> ServerStoreCfg 'QSPostgres 'MSJournal -data AMsgStoreCfg = forall s. MsgStoreClass (MsgStore s) => AMSC (SMSType s) (MsgStoreConfig (MsgStore s)) +data StorePaths = StorePaths {storeLogFile :: FilePath, storeMsgsFile :: Maybe FilePath} -msgPersistence :: AMsgStoreCfg -> Bool -msgPersistence (AMSC SMSMemory (STMStoreConfig {storePath})) = isJust storePath -msgPersistence (AMSC SMSJournal _) = True +data AServerStoreCfg = forall qs ms. SupportedStore qs ms => ASSCfg (SQSType qs) (SMSType ms) (ServerStoreCfg qs ms) + +type family MsgStore (qs :: QSType) (ms :: MSType) where + MsgStore 'QSMemory 'MSMemory = STMMsgStore + MsgStore qs 'MSJournal = JournalMsgStore qs + +data AMsgStore = + forall qs ms. (SupportedStore qs ms, MsgStoreClass (MsgStore qs ms)) => + AMS (SQSType qs) (SMSType ms) (MsgStore qs ms) type Subscribed = Bool @@ -225,10 +246,11 @@ newtype ProxyAgent = ProxyAgent type ClientId = Int -data AClient = forall s. MsgStoreClass (MsgStore s) => AClient (SMSType s) (Client (MsgStore s)) +data AClient = forall qs ms. MsgStoreClass (MsgStore qs ms) => AClient (SQSType qs) (SMSType ms) (Client (MsgStore qs ms)) clientId' :: AClient -> ClientId -clientId' (AClient _ Client {clientId}) = clientId +clientId' (AClient _ _ Client {clientId}) = clientId +{-# INLINE clientId' #-} data Client s = Client { clientId :: ClientId, @@ -270,8 +292,8 @@ newServer = do savingLock <- createLockIO return Server {subscribedQ, subscribers, ntfSubscribedQ, notifiers, subClients, ntfSubClients, pendingSubEvents, pendingNtfSubEvents, savingLock} -newClient :: SMSType s -> ClientId -> Natural -> VersionSMP -> ByteString -> SystemTime -> IO (Client (MsgStore s)) -newClient _msType clientId qSize thVersion sessionId createdAt = do +newClient :: SQSType qs -> SMSType ms -> ClientId -> Natural -> VersionSMP -> ByteString -> SystemTime -> IO (Client (MsgStore qs ms)) +newClient _ _ clientId qSize thVersion sessionId createdAt = do subscriptions <- TM.emptyIO ntfSubscriptions <- TM.emptyIO rcvQ <- newTBQueueIO qSize @@ -297,22 +319,29 @@ newProhibitedSub = do return Sub {subThread = ProhibitSub, delivered} newEnv :: ServerConfig -> IO Env -newEnv config@ServerConfig {smpCredentials, httpCredentials, storeLogFile, msgStoreType, storeMsgsFile, smpAgentCfg, information, messageExpiration, idleQueueInterval, msgQueueQuota, maxJournalMsgCount, maxJournalStateLines} = do +newEnv config@ServerConfig {smpCredentials, httpCredentials, serverStoreCfg, smpAgentCfg, information, messageExpiration, idleQueueInterval, msgQueueQuota, maxJournalMsgCount, maxJournalStateLines, startOptions} = do serverActive <- newTVarIO True server <- newServer - msgStore@(AMS _ store) <- case msgStoreType of - AMSType SMSMemory -> AMS SMSMemory <$> newMsgStore STMStoreConfig {storePath = storeMsgsFile, quota = msgQueueQuota} - AMSType SMSJournal -> case storeMsgsFile of - Just storePath -> - let cfg = mkJournalStoreConfig storePath msgQueueQuota maxJournalMsgCount maxJournalStateLines idleQueueInterval - in AMS SMSJournal <$> newMsgStore cfg - Nothing -> putStrLn "Error: journal msg store require path in [STORE_LOG], restore_messages" >> exitFailure + msgStore <- case serverStoreCfg of + ASSCfg qt mt (SSCMemory storePaths_) -> do + let storePath = storeMsgsFile =<< storePaths_ + ms <- newMsgStore STMStoreConfig {storePath, quota = msgQueueQuota} + forM_ storePaths_ $ \StorePaths {storeLogFile = f} -> loadStoreLog (mkQueue ms) f $ queueStore ms + pure $ AMS qt mt ms + ASSCfg qt mt SSCMemoryJournal {storeLogFile, storeMsgsPath} -> do + let qsCfg = MQStoreCfg + cfg = mkJournalStoreConfig qsCfg storeMsgsPath msgQueueQuota maxJournalMsgCount maxJournalStateLines idleQueueInterval + ms <- newMsgStore cfg + loadStoreLog (mkQueue ms) storeLogFile $ stmQueueStore ms + pure $ AMS qt mt ms + ASSCfg qt mt SSCDatabaseJournal {storeDBOpts, storeMsgsPath'} -> do + let StartOptions {confirmMigrations} = startOptions + qsCfg = PQStoreCfg storeDBOpts confirmMigrations + cfg = mkJournalStoreConfig qsCfg storeMsgsPath' msgQueueQuota maxJournalMsgCount maxJournalStateLines idleQueueInterval + ms <- newMsgStore cfg + pure $ AMS qt mt ms ntfStore <- NtfStore <$> TM.emptyIO random <- C.newRandom - forM_ storeLogFile $ \f -> do - logInfo $ "restoring queues from file " <> T.pack f - sl <- readWriteQueueStore f store - setStoreLog store sl tlsServerCreds <- getCredentials "SMP" smpCredentials httpServerCreds <- mapM (getCredentials "HTTPS") httpCredentials mapM_ checkHTTPSCredentials httpServerCreds @@ -325,6 +354,11 @@ newEnv config@ServerConfig {smpCredentials, httpCredentials, storeLogFile, msgSt proxyAgent <- newSMPProxyAgent smpAgentCfg random pure Env {serverActive, config, serverInfo, server, serverIdentity, msgStore, ntfStore, random, tlsServerCreds, httpServerCreds, serverStats, sockets, clientSeq, clients, proxyAgent} where + loadStoreLog :: StoreQueueClass q => (RecipientId -> QueueRec -> IO q) -> FilePath -> STMQueueStore q -> IO () + loadStoreLog mkQ f st = do + logInfo $ "restoring queues from file " <> T.pack f + sl <- readWriteQueueStore False mkQ f st + setStoreLog st sl getCredentials protocol creds = do files <- missingCreds unless (null files) $ do @@ -358,17 +392,20 @@ newEnv config@ServerConfig {smpCredentials, httpCredentials, storeLogFile, msgSt } } where - persistence - | isNothing storeLogFile = SPMMemoryOnly - | isJust storeMsgsFile = SPMMessages - | otherwise = SPMQueues + persistence = case serverStoreCfg of + ASSCfg _ _ (SSCMemory sp_) -> case sp_ of + Nothing -> SPMMemoryOnly + Just StorePaths {storeMsgsFile = Just _} -> SPMMessages + _ -> SPMQueues + _ -> SPMMessages -mkJournalStoreConfig :: FilePath -> Int -> Int -> Int -> Int64 -> JournalStoreConfig -mkJournalStoreConfig storePath msgQueueQuota maxJournalMsgCount maxJournalStateLines idleQueueInterval = +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, @@ -382,5 +419,5 @@ newSMPProxyAgent smpAgentCfg random = do smpAgent <- newSMPClientAgent smpAgentCfg random pure ProxyAgent {smpAgent} -readWriteQueueStore :: STMStoreClass s => FilePath -> s -> IO (StoreLog 'WriteMode) -readWriteQueueStore = readWriteStoreLog readQueueStore writeQueueStore +readWriteQueueStore :: forall q s. QueueStoreClass q s => Bool -> (RecipientId -> QueueRec -> IO q) -> FilePath -> s -> IO (StoreLog 'WriteMode) +readWriteQueueStore tty mkQ = readWriteStoreLog (readQueueStore tty mkQ) (writeQueueStore @q) diff --git a/src/Simplex/Messaging/Server/Main.hs b/src/Simplex/Messaging/Server/Main.hs index e35803171..56f6cc414 100644 --- a/src/Simplex/Messaging/Server/Main.hs +++ b/src/Simplex/Messaging/Server/Main.hs @@ -1,4 +1,5 @@ {-# LANGUAGE ApplicativeDo #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} @@ -26,6 +27,7 @@ import Data.Ini (Ini, lookupValue, readIniFile) import Data.List (find, isPrefixOf) import qualified Data.List.NonEmpty as L import Data.Maybe (fromMaybe, isJust, isNothing) +import Data.Semigroup (Sum (..)) import Data.Text (Text) import qualified Data.Text as T import Data.Text.Encoding (decodeLatin1, encodeUtf8) @@ -33,6 +35,9 @@ import qualified Data.Text.IO as T import Network.Socket (HostName) import Options.Applicative import Simplex.Messaging.Agent.Protocol (connReqUriP') +import Simplex.Messaging.Agent.Store.Postgres (checkSchemaExists) +import Simplex.Messaging.Agent.Store.Postgres.Common (DBOpts (..)) +import Simplex.Messaging.Agent.Store.Shared (MigrationConfirmation (..)) import Simplex.Messaging.Client (HostMode (..), NetworkConfig (..), ProtocolClientConfig (..), SocksMode (..), defaultNetworkConfig, textToHostMode) import Simplex.Messaging.Client.Agent (SMPClientAgentConfig (..), defaultSMPClientAgentConfig) import qualified Simplex.Messaging.Crypto as C @@ -44,13 +49,17 @@ import Simplex.Messaging.Server.CLI import Simplex.Messaging.Server.Env.STM import Simplex.Messaging.Server.Expiration import Simplex.Messaging.Server.Information -import Simplex.Messaging.Server.MsgStore.Types (AMSType (..), SMSType (..), newMsgStore) -import Simplex.Messaging.Server.QueueStore.STM (readQueueStore) +import Simplex.Messaging.Server.MsgStore.Journal (JournalMsgStore (..), JournalQueue, QStoreCfg (..), postgresQueueStore, stmQueueStore) +import Simplex.Messaging.Server.MsgStore.Types (MsgStoreClass (..), QSType (..), SQSType (..), SMSType (..), newMsgStore) +import Simplex.Messaging.Server.QueueStore.Postgres (batchInsertQueues, foldQueueRecs) +import Simplex.Messaging.Server.QueueStore.Types +import Simplex.Messaging.Server.StoreLog (logCreateQueue, openWriteStoreLog) +import Simplex.Messaging.Server.StoreLog.ReadWrite (readQueueStore) import Simplex.Messaging.Transport (simplexMQVersion, supportedProxyClientSMPRelayVRange, supportedServerSMPRelayVRange) import Simplex.Messaging.Transport.Client (SocksProxy, TransportHost (..), defaultSocksProxy) import Simplex.Messaging.Transport.Server (ServerCredentials (..), TransportServerConfig (..), defaultTransportServerConfig) import Simplex.Messaging.Util (eitherToMaybe, ifM, safeDecodeUtf8, tshow) -import System.Directory (createDirectoryIfMissing, doesDirectoryExist, doesFileExist) +import System.Directory (createDirectoryIfMissing, doesDirectoryExist, doesFileExist, renameFile) import System.Exit (exitFailure) import System.FilePath (combine) import System.IO (BufferMode (..), hSetBuffering, stderr, stdout) @@ -84,37 +93,30 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath = Journal cmd -> withIniFile $ \ini -> do msgsDirExists <- doesDirectoryExist storeMsgsJournalDir msgsFileExists <- doesFileExist storeMsgsFilePath - let enableStoreLog = settingIsOn "STORE_LOG" "enable" ini - storeLogFile <- case enableStoreLog $> storeLogFilePath of - Just storeLogFile -> do - ifM - (doesFileExist storeLogFile) - (pure storeLogFile) - (putStrLn ("Store log file " <> storeLogFile <> " not found") >> exitFailure) - Nothing -> putStrLn "Store log disabled, see `[STORE_LOG] enable`" >> exitFailure + storeLogFile <- getRequiredStoreLogFile ini case cmd of - JCImport + SCImport | msgsFileExists && msgsDirExists -> exitConfigureMsgStorage | msgsDirExists -> do putStrLn $ storeMsgsJournalDir <> " directory already exists." exitFailure | not msgsFileExists -> do - putStrLn $ storeMsgsFilePath <> " file does not exists." + putStrLn $ storeMsgsFilePath <> " file does not exist." exitFailure | otherwise -> do confirmOrExit ("WARNING: message log file " <> storeMsgsFilePath <> " will be imported to journal directory " <> storeMsgsJournalDir) "Messages not imported" - ms <- newJournalMsgStore - readQueueStore storeLogFile ms + ms <- newJournalMsgStore MQStoreCfg + readQueueStore True (mkQueue ms) storeLogFile $ stmQueueStore ms msgStats <- importMessages True ms storeMsgsFilePath Nothing False -- no expiration putStrLn "Import completed" printMessageStats "Messages" msgStats - putStrLn $ case readMsgStoreType ini of - Right (AMSType SMSMemory) -> "store_messages set to `memory`, update it to `journal` in INI file" - Right (AMSType SMSJournal) -> "store_messages set to `journal`" - Left e -> e <> ", update it to `journal` in INI file" - JCExport + putStrLn $ case readStoreType ini of + Right (ASType SQSMemory SMSMemory) -> "store_messages set to `memory`, update it to `journal` in INI file" + Right (ASType _ SMSJournal) -> "store_messages set to `journal`" + Left e -> e <> ", configure storage correctly" + SCExport | msgsFileExists && msgsDirExists -> exitConfigureMsgStorage | msgsFileExists -> do putStrLn $ storeMsgsFilePath <> " file already exists." @@ -123,15 +125,17 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath = confirmOrExit ("WARNING: journal directory " <> storeMsgsJournalDir <> " will be exported to message log file " <> storeMsgsFilePath) "Journal not exported" - ms <- newJournalMsgStore - readQueueStore storeLogFile ms + -- TODO [postgres] + ms <- newJournalMsgStore MQStoreCfg + readQueueStore True (mkQueue ms) storeLogFile $ stmQueueStore ms exportMessages True ms storeMsgsFilePath False putStrLn "Export completed" - putStrLn $ case readMsgStoreType ini of - Right (AMSType SMSMemory) -> "store_messages set to `memory`" - Right (AMSType SMSJournal) -> "store_messages set to `journal`, update it to `memory` in INI file" - Left e -> e <> ", update it to `memory` in INI file" - JCDelete + putStrLn $ case readStoreType ini of + Right (ASType SQSMemory SMSMemory) -> "store_messages set to `memory`, start the server." + Right (ASType SQSMemory SMSJournal) -> "store_messages set to `journal`, update it to `memory` in INI file" + Right (ASType SQSPostgres SMSJournal) -> "store_messages set to `journal`, store_queues is set to `database`.\nExport queues to store log to use memory storage for messages (`smp-server database export`)." + Left e -> e <> ", configure storage correctly" + SCDelete | not msgsDirExists -> do putStrLn $ storeMsgsJournalDir <> " directory does not exists." exitFailure @@ -141,13 +145,73 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath = "Messages NOT deleted" deleteDirIfExists storeMsgsJournalDir putStrLn $ "Deleted all messages in journal " <> storeMsgsJournalDir + Database cmd dbOpts@DBOpts {connstr, schema} -> withIniFile $ \ini -> do + schemaExists <- checkSchemaExists connstr schema + storeLogExists <- doesFileExist storeLogFilePath + case cmd of + SCImport + | schemaExists && storeLogExists -> exitConfigureQueueStore connstr schema + | schemaExists -> do + putStrLn $ "Schema " <> B.unpack schema <> " already exists in PostrgreSQL database: " <> B.unpack connstr + exitFailure + | not storeLogExists -> do + putStrLn $ storeLogFilePath <> " file does not exist." + exitFailure + | otherwise -> do + storeLogFile <- getRequiredStoreLogFile ini + confirmOrExit + ("WARNING: store log file " <> storeLogFile <> " will be imported to PostrgreSQL database: " <> B.unpack connstr <> ", schema: " <> B.unpack schema) + "Queue records not imported" + ms <- newJournalMsgStore MQStoreCfg + readQueueStore True (mkQueue ms) storeLogFile (queueStore ms) + queues <- readTVarIO $ loadedQueues $ stmQueueStore ms + ps <- newJournalMsgStore $ PQStoreCfg dbOpts {createSchema = True} MCConsole + (qCnt, nCnt) <- batchInsertQueues @(JournalQueue 'QSMemory) True queues $ postgresQueueStore ps + renameFile storeLogFile $ storeLogFile <> ".bak" + putStrLn $ "Import completed: " <> show qCnt <> " queues, " <> show nCnt <> " notifiers" + putStrLn $ case readStoreType ini of + Right (ASType SQSMemory SMSMemory) -> "store_messages set to `memory`.\nImport messages to journal to use PostgreSQL database for queues (`smp-server journal import`)" + Right (ASType SQSMemory SMSJournal) -> "store_queues set to `memory`, update it to `database` in INI file" + Right (ASType SQSPostgres SMSJournal) -> "store_queues set to `database`, start the server." + Left e -> e <> ", configure storage correctly" + SCExport + | schemaExists && storeLogExists -> exitConfigureQueueStore connstr schema + | not schemaExists -> do + putStrLn $ "Schema " <> B.unpack schema <> " does not exist in PostrgreSQL database: " <> B.unpack connstr + exitFailure + | storeLogExists -> do + putStrLn $ storeLogFilePath <> " file already exists." + exitFailure + | otherwise -> do + confirmOrExit + ("WARNING: PostrgreSQL database schema " <> B.unpack schema <> " (database: " <> B.unpack connstr <> ") will be exported to store log file " <> storeLogFilePath) + "Queue records not exported" + ps <- newJournalMsgStore $ PQStoreCfg dbOpts MCConsole + sl <- openWriteStoreLog storeLogFilePath + Sum qCnt <- foldQueueRecs True (postgresQueueStore ps) $ \rId qr -> logCreateQueue sl rId qr $> Sum (1 :: Int) + putStrLn $ "Export completed: " <> show qCnt <> " queues" + putStrLn $ case readStoreType ini of + Right (ASType SQSPostgres SMSJournal) -> "store_queues set to `database`, update it to `memory` in INI file." + Right (ASType SQSMemory _) -> "store_queues set to `memory`, start the server" + Left e -> e <> ", configure storage correctly" + SCDelete -> undefined -- TODO [postgres] where withIniFile a = doesFileExist iniFile >>= \case True -> readIniFile iniFile >>= either exitError a _ -> exitError $ "Error: server is not initialized (" <> iniFile <> " does not exist).\nRun `" <> executableName <> " init`." - newJournalMsgStore = - let cfg = mkJournalStoreConfig storeMsgsJournalDir defaultMsgQueueQuota defaultMaxJournalMsgCount defaultMaxJournalStateLines $ checkInterval defaultMessageExpiration + getRequiredStoreLogFile ini = do + let enableStoreLog = settingIsOn "STORE_LOG" "enable" ini + case enableStoreLog $> storeLogFilePath of + Just storeLogFile -> do + ifM + (doesFileExist storeLogFile) + (pure storeLogFile) + (putStrLn ("Store log file " <> storeLogFile <> " not found") >> exitFailure) + Nothing -> putStrLn "Store log disabled, see `[STORE_LOG] enable`" >> exitFailure + newJournalMsgStore :: QStoreCfg s -> IO (JournalMsgStore s) + newJournalMsgStore qsCfg = + let cfg = mkJournalStoreConfig qsCfg storeMsgsJournalDir defaultMsgQueueQuota defaultMaxJournalMsgCount defaultMaxJournalStateLines $ checkInterval defaultMessageExpiration in newMsgStore cfg iniFile = combine cfgPath "smp-server.ini" serverVersion = "SMP server v" <> simplexMQVersion @@ -157,12 +221,23 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath = storeMsgsFilePath = combine logPath "smp-server-messages.log" storeMsgsJournalDir = combine logPath "messages" storeNtfsFilePath = combine logPath "smp-server-ntfs.log" - readMsgStoreType :: Ini -> Either String AMSType - readMsgStoreType = textToMsgStoreType . fromRight "memory" . lookupValue "STORE_LOG" "store_messages" - textToMsgStoreType = \case - "memory" -> Right $ AMSType SMSMemory - "journal" -> Right $ AMSType SMSJournal - s -> Left $ "invalid store_messages: " <> T.unpack s + readStoreType :: Ini -> Either String AStoreType + readStoreType ini = case (iniStoreQueues, iniStoreMessage) of + ("memory", "memory") -> Right $ ASType SQSMemory SMSMemory + ("memory", "journal") -> Right $ ASType SQSMemory SMSJournal + ("database", "journal") -> Right $ ASType SQSPostgres SMSJournal + ("database", "memory") -> Left "Using PostgreSQL database requires journal memory storage." + (q, m) -> Left $ T.unpack $ "Invalid storage settings: store_queues: " <> q <> ", store_messages: " <> m + where + iniStoreQueues = fromRight "memory" $ lookupValue "STORE_LOG" "store_queues" ini + iniStoreMessage = fromRight "memory" $ lookupValue "STORE_LOG" "store_messages" ini + iniDBOptions :: Ini -> DBOpts + iniDBOptions ini = + DBOpts + { connstr = either (const defaultDBConnStr) encodeUtf8 $ lookupValue "STORE_LOG" "db_connection" ini, + schema = either (const defaultDBSchema) encodeUtf8 $ lookupValue "STORE_LOG" "db_schema" ini, + createSchema = False + } httpsCertFile = combine cfgPath "web.crt" httpsKeyFile = combine cfgPath "web.key" defaultStaticPath = combine logPath "www" @@ -210,7 +285,7 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath = Just "Error: passing --hosting-country requires passing --hosting" | otherwise = Nothing forM_ err_ $ \err -> putStrLn err >> exitFailure - initialize opts'@InitOptions {enableStoreLog, logStats, signAlgorithm, password, controlPort, socksProxy, ownDomains, sourceCode, webStaticPath, disableWeb} = do + initialize opts'@InitOptions {enableStoreLog, dbOptions, logStats, signAlgorithm, password, controlPort, socksProxy, ownDomains, sourceCode, webStaticPath, disableWeb} = do checkInitOptions opts' clearDirIfExists cfgPath clearDirIfExists logPath @@ -236,12 +311,17 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath = iniFileContent host basicAuth controlPortPwds = informationIniContent opts' <> "[STORE_LOG]\n\ - \# The server uses STM memory for persistence,\n\ - \# that will be lost on restart (e.g., as with redis).\n\ - \# This option enables saving memory to append only log,\n\ - \# and restoring it when the server is started.\n\ + \# The server uses memory or PostgreSQL database for persisting queue records.\n\ + \# Use `enable: on` to use append-only log to preserve and restore queue records on restart.\n\ \# Log is compacted on start (deleted objects are removed).\n" <> ("enable: " <> onOff enableStoreLog <> "\n\n") + <> "# Queue storage mode: `memory` or `database` (to store queue records in PostgreSQL database).\n\ + \# `memory` - in-memory persistence, with optional append-only log (`enable: on`).\n\ + \# `database`- PostgreSQL databass (requires `store_messages: journal`).\n\ + \store_queues: memory\n\n\ + \# Database connection settings for PostgreSQL database (`store_queues: database`).\n" + <> (optDisabled dbOptions <> "db_connection: " <> safeDecodeUtf8 (maybe defaultDBConnStr connstr dbOptions) <> "\n") + <> (optDisabled dbOptions <> "db_schema: " <> safeDecodeUtf8 (maybe defaultDBSchema schema dbOptions) <> "\n\n") <> "# Message storage mode: `memory` or `journal`.\n\ \store_messages: memory\n\n\ \# When store_messages is `memory`, undelivered messages are optionally saved and restored\n\ @@ -328,13 +408,13 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath = fp <- checkSavedFingerprint cfgPath defaultX509Config let host = either (const "") T.unpack $ lookupValue "TRANSPORT" "host" ini port = T.unpack $ strictIni "TRANSPORT" "port" ini - cfg@ServerConfig {information, storeLogFile, msgStoreType, newQueueBasicAuth, messageExpiration, inactiveClientExpiration} = serverConfig + cfg@ServerConfig {information, serverStoreCfg, newQueueBasicAuth, messageExpiration, inactiveClientExpiration} = serverConfig sourceCode' = (\ServerPublicInfo {sourceCode} -> sourceCode) <$> information srv = ProtoServerWithAuth (SMPServer [THDomainName host] (if port == "5223" then "" else port) (C.KeyHash fp)) newQueueBasicAuth printServiceInfo serverVersion srv printSourceCode sourceCode' - printServerConfig transports storeLogFile - checkMsgStoreMode msgStoreType + printSMPServerConfig transports serverStoreCfg + checkMsgStoreMode iniStoreType putStrLn $ case messageExpiration of Just ExpirationConfig {ttl} -> "expiring messages after " <> showTTL ttl _ -> "not expiring messages" @@ -347,10 +427,10 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath = then maybe "allowed" (const "requires password") newQueueBasicAuth else "NOT allowed" -- print information - let persistence - | isNothing storeLogFile = SPMMemoryOnly - | isJust (storeMsgsFile cfg) = SPMMessages - | otherwise = SPMQueues + let persistence = case serverStoreCfg of + ASSCfg _ _ (SSCMemory Nothing) -> SPMMemoryOnly + ASSCfg _ _ (SSCMemory (Just StorePaths {storeMsgsFile})) | isNothing storeMsgsFile -> SPMQueues + _ -> SPMMessages let config = ServerPublicConfig { persistence, @@ -383,13 +463,12 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath = _ -> enableStoreLog $> path transports = iniTransports ini sharedHTTP = any (\(_, _, addHTTP) -> addHTTP) transports - iniMsgStoreType = either error id $! readMsgStoreType ini + iniStoreType = either error id $! readStoreType ini serverConfig = ServerConfig { transports, smpHandshakeTimeout = 120000000, tbqSize = 128, - msgStoreType = iniMsgStoreType, msgQueueQuota = defaultMsgQueueQuota, maxJournalMsgCount = defaultMaxJournalMsgCount, maxJournalStateLines = defaultMaxJournalStateLines, @@ -402,10 +481,13 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath = certificateFile = c serverCrtFile }, httpCredentials = (\WebHttpsParams {key, cert} -> ServerCredentials {caCertificateFile = Nothing, privateKeyFile = key, certificateFile = cert}) <$> webHttpsParams', - storeLogFile = enableStoreLog $> storeLogFilePath, - storeMsgsFile = case iniMsgStoreType of - AMSType SMSMemory -> restoreMessagesFile storeMsgsFilePath - AMSType SMSJournal -> Just storeMsgsJournalDir, + serverStoreCfg = case iniStoreType of + ASType SQSMemory SMSMemory -> + ASSCfg SQSMemory SMSMemory $ SSCMemory $ enableStoreLog $> StorePaths {storeLogFile = storeLogFilePath, storeMsgsFile = restoreMessagesFile storeMsgsFilePath} + ASType SQSMemory SMSJournal -> + ASSCfg SQSMemory SMSJournal $ SSCMemoryJournal {storeLogFile = storeLogFilePath, storeMsgsPath = storeMsgsJournalDir} + ASType SQSPostgres SMSJournal -> + ASSCfg SQSPostgres SMSJournal $ SSCDatabaseJournal {storeDBOpts = iniDBOptions ini, confirmMigrations = MCYesUp, storeMsgsPath' = storeMsgsJournalDir}, storeNtfsFile = restoreMessagesFile storeNtfsFilePath, -- allow creating new queues by default allowNewQueues = fromMaybe True $ iniOnOff "AUTH" "new_queues" ini, @@ -486,20 +568,20 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath = pure WebHttpsParams {port, cert, key} webStaticPath' = eitherToMaybe $ T.unpack <$> lookupValue "WEB" "static_path" ini - checkMsgStoreMode :: AMSType -> IO () + checkMsgStoreMode :: AStoreType -> IO () checkMsgStoreMode mode = do msgsDirExists <- doesDirectoryExist storeMsgsJournalDir msgsFileExists <- doesFileExist storeMsgsFilePath case mode of _ | msgsFileExists && msgsDirExists -> exitConfigureMsgStorage - AMSType SMSJournal + ASType _ SMSJournal -- TODO [postgres] | msgsFileExists -> do putStrLn $ "Error: store_messages is `journal` with " <> storeMsgsFilePath <> " file present." putStrLn "Set store_messages to `memory` or use `smp-server journal export` to migrate." exitFailure | not msgsDirExists -> putStrLn $ "store_messages is `journal`, " <> storeMsgsJournalDir <> " directory will be created." - AMSType SMSMemory + ASType _ SMSMemory | msgsDirExists -> do putStrLn $ "Error: store_messages is `memory` with " <> storeMsgsJournalDir <> " directory present." putStrLn "Set store_messages to `journal` or use `smp-server journal import` to migrate." @@ -511,6 +593,11 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath = putStrLn "Configure memory storage." exitFailure + exitConfigureQueueStore connstr schema = do + putStrLn $ "Error: both " <> storeLogFilePath <> " file and " <> B.unpack schema <> " schema are present (database: " <> B.unpack connstr <> ")." + putStrLn "Configure queue storage." + exitFailure + data EmbeddedWebParams = EmbeddedWebParams { webStaticPath :: FilePath, webHttpPort :: Maybe Int, @@ -533,6 +620,12 @@ getServerSourceCode = simplexmqSource :: String simplexmqSource = "https://github.com/simplex-chat/simplexmq" +defaultDBConnStr :: ByteString +defaultDBConnStr = "postgresql://smp@/smp_server_store" + +defaultDBSchema :: ByteString +defaultDBSchema = "smp_server" + defaultControlPort :: Int defaultControlPort = 5224 @@ -638,12 +731,15 @@ data CliCommand | OnlineCert CertOptions | Start StartOptions | Delete - | Journal JournalCmd + | Journal StoreCmd + | Database StoreCmd DBOpts -data JournalCmd = JCImport | JCExport | JCDelete +data StoreCmd = SCImport | SCExport | SCDelete data InitOptions = InitOptions { enableStoreLog :: Bool, + dbOptions :: Maybe DBOpts, + dbMigrateUp :: Bool, logStats :: Bool, signAlgorithm :: SignAlgorithm, ip :: HostName, @@ -673,6 +769,7 @@ cliCommandP cfgPath logPath iniFile = <> command "start" (info (Start <$> startOptionsP) (progDesc $ "Start server (configuration: " <> iniFile <> ")")) <> command "delete" (info (pure Delete) (progDesc "Delete configuration and log files")) <> command "journal" (info (Journal <$> journalCmdP) (progDesc "Import/export messages to/from journal storage")) + <> command "database" (info (Database <$> databaseCmdP <*> dbOptsP) (progDesc "Import/export queues to/from PostgreSQL database storage")) ) where initP :: Parser InitOptions @@ -683,6 +780,12 @@ cliCommandP cfgPath logPath iniFile = <> short 'l' <> help "Enable store log for persistence" ) + dbOptions <- optional dbOptsP + dbMigrateUp <- + switch + ( long "db-migrate-up" + <> help "Automatically confirm \"up\" database migrations" + ) logStats <- switch ( long "daily-stats" @@ -785,6 +888,8 @@ cliCommandP cfgPath logPath iniFile = pure InitOptions { enableStoreLog, + dbOptions, + dbMigrateUp, logStats, signAlgorithm, ip, @@ -823,14 +928,47 @@ cliCommandP cfgPath logPath iniFile = ( long "skip-warnings" <> help "Start the server with non-critical start warnings" ) - pure StartOptions {maintenance, skipWarnings} - journalCmdP = + confirmMigrations <- + option + parseConfirmMigrations + ( long "confirm-migrations" + <> metavar "CONFIRM_MIGRATIONS" + <> help "Confirm PostgreSQL database migration: up, down (default is manual confirmation)" + <> value MCConsole + ) + pure StartOptions {maintenance, skipWarnings, confirmMigrations} + journalCmdP = storeCmdP "message log file" "journal storage" + databaseCmdP = storeCmdP "queue store log file" "PostgreSQL database schema" + storeCmdP src dest = hsubparser - ( command "import" (info (pure JCImport) (progDesc "Import message log file into a new journal storage")) - <> command "export" (info (pure JCExport) (progDesc "Export journal storage to message log file")) - <> command "delete" (info (pure JCDelete) (progDesc "Delete journal storage")) + ( command "import" (info (pure SCImport) (progDesc $ "Import " <> src <> " into a new " <> dest)) + <> command "export" (info (pure SCExport) (progDesc $ "Export " <> dest <> " to " <> src)) + <> command "delete" (info (pure SCDelete) (progDesc $ "Delete " <> dest)) ) - + dbOptsP = do + connstr <- + strOption + ( long "database" + <> short 'd' + <> metavar "DB_CONN" + <> help "Database connection string" + <> value defaultDBConnStr + <> showDefault + ) + schema <- + strOption + ( long "schema" + <> metavar "DB_SCHEMA" + <> help "Database schema" + <> value defaultDBSchema + <> showDefault + ) + pure DBOpts {connstr, schema, createSchema = False} + parseConfirmMigrations :: ReadM MigrationConfirmation + parseConfirmMigrations = eitherReader $ \case + "up" -> Right MCYesUp + "down" -> Right MCYesUpDown + _ -> Left "invalid migration confirmation, pass 'up' or 'down'" parseBasicAuth :: ReadM ServerPassword parseBasicAuth = eitherReader $ fmap ServerPassword . strDecode . B.pack entityP :: String -> String -> String -> Parser (Maybe Entity, Maybe Text) diff --git a/src/Simplex/Messaging/Server/MsgStore/Journal.hs b/src/Simplex/Messaging/Server/MsgStore/Journal.hs index 4498677af..8ad63e162 100644 --- a/src/Simplex/Messaging/Server/MsgStore/Journal.hs +++ b/src/Simplex/Messaging/Server/MsgStore/Journal.hs @@ -2,20 +2,25 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE InstanceSigs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TupleSections #-} module Simplex.Messaging.Server.MsgStore.Journal - ( JournalMsgStore (queueStore, random, expireBackupsBefore), + ( JournalMsgStore (random, expireBackupsBefore), + QStore (..), + QStoreCfg (..), JournalQueue, JournalMsgQueue (queue, state), JMQueue (queueDirectory, statePath), @@ -35,6 +40,8 @@ module Simplex.Messaging.Server.MsgStore.Journal queueLogFileName, journalFilePath, logFileExt, + stmQueueStore, + postgresQueueStore, ) where @@ -58,11 +65,15 @@ import Data.Time.Format.ISO8601 (iso8601Show, iso8601ParseM) import GHC.IO (catchAny) import Simplex.Messaging.Agent.Client (getMapLock, withLockMap) import Simplex.Messaging.Agent.Lock +import Simplex.Messaging.Agent.Store.Postgres.Common (DBOpts) +import Simplex.Messaging.Agent.Store.Shared (MigrationConfirmation) import Simplex.Messaging.Encoding.String import Simplex.Messaging.Protocol import Simplex.Messaging.Server.MsgStore.Types import Simplex.Messaging.Server.QueueStore +import Simplex.Messaging.Server.QueueStore.Postgres import Simplex.Messaging.Server.QueueStore.STM +import Simplex.Messaging.Server.QueueStore.Types import Simplex.Messaging.TMap (TMap) import qualified Simplex.Messaging.TMap as TM import Simplex.Messaging.Server.StoreLog @@ -74,17 +85,30 @@ import System.IO (BufferMode (..), Handle, IOMode (..), SeekMode (..), stdout) import qualified System.IO as IO import System.Random (StdGen, genByteString, newStdGen) -data JournalMsgStore = JournalMsgStore - { config :: JournalStoreConfig, +data JournalMsgStore s = JournalMsgStore + { config :: JournalStoreConfig s, random :: TVar StdGen, queueLocks :: TMap RecipientId Lock, - queueStore :: STMQueueStore JournalQueue, + queueStore_ :: QStore s, expireBackupsBefore :: UTCTime } -data JournalStoreConfig = JournalStoreConfig +data QStore (s :: QSType) where + MQStore :: STMQueueStore (JournalQueue 'QSMemory) -> QStore 'QSMemory + PQStore :: PostgresQueueStore (JournalQueue 'QSPostgres) -> QStore 'QSPostgres + +stmQueueStore :: JournalMsgStore 'QSMemory -> STMQueueStore (JournalQueue 'QSMemory) +stmQueueStore st = case queueStore_ st of + MQStore st' -> st' + +postgresQueueStore :: JournalMsgStore 'QSPostgres -> PostgresQueueStore (JournalQueue 'QSPostgres) +postgresQueueStore st = case queueStore_ st of + PQStore st' -> st' + +data JournalStoreConfig s = JournalStoreConfig { storePath :: FilePath, pathParts :: Int, + queueStoreCfg :: QStoreCfg s, quota :: Int, -- Max number of messages per journal file - ignored in STM store. -- When this limit is reached, the file will be changed. @@ -99,13 +123,17 @@ data JournalStoreConfig = JournalStoreConfig keepMinBackups :: Int } -data JournalQueue = JournalQueue - { recipientId :: RecipientId, +data QStoreCfg s where + MQStoreCfg :: QStoreCfg 'QSMemory + PQStoreCfg :: DBOpts -> MigrationConfirmation -> QStoreCfg 'QSPostgres + +data JournalQueue (s :: QSType) = JournalQueue + { recipientId' :: RecipientId, queueLock :: Lock, -- To avoid race conditions and errors when restoring queues, -- Nothing is written to TVar when queue is deleted. - queueRec :: TVar (Maybe QueueRec), - msgQueue_ :: TVar (Maybe JournalMsgQueue), + queueRec' :: TVar (Maybe QueueRec), + msgQueue' :: TVar (Maybe (JournalMsgQueue s)), -- system time in seconds since epoch activeAt :: TVar Int64, queueState :: TVar (Maybe QState) -- Nothing - unknown @@ -121,7 +149,7 @@ data JMQueue = JMQueue statePath :: FilePath } -data JournalMsgQueue = JournalMsgQueue +data JournalMsgQueue (s :: QSType) = JournalMsgQueue { queue :: JMQueue, state :: TVar MsgQueueState, -- tipMsg contains last message and length incl. newline @@ -228,54 +256,126 @@ msgLogFileName = "messages" logFileExt :: String logFileExt = ".log" -newtype StoreIO a = StoreIO {unStoreIO :: IO a} +newtype StoreIO (s :: QSType) a = StoreIO {unStoreIO :: IO a} deriving newtype (Functor, Applicative, Monad) -instance STMStoreClass JournalMsgStore where - stmQueueStore JournalMsgStore {queueStore} = queueStore - mkQueue st rId qr = do - queueLock <- getMapLock (queueLocks st) rId - queueRec <- newTVar $ Just qr - msgQueue_ <- newTVar Nothing - activeAt <- newTVar 0 - queueState <- newTVar Nothing - pure $ - JournalQueue - { recipientId = rId, - queueLock, - queueRec, - msgQueue_, - activeAt, - queueState - } - msgQueue_' = msgQueue_ +instance StoreQueueClass (JournalQueue s) where + type MsgQueue (JournalQueue s) = JournalMsgQueue s + recipientId = recipientId' + {-# INLINE recipientId #-} + queueRec = queueRec' + {-# INLINE queueRec #-} + msgQueue = msgQueue' + {-# INLINE msgQueue #-} + withQueueLock :: JournalQueue s -> String -> IO a -> IO a + withQueueLock = withLock' . queueLock + {-# INLINE withQueueLock #-} -instance MsgStoreClass JournalMsgStore where - type StoreMonad JournalMsgStore = StoreIO - type StoreQueue JournalMsgStore = JournalQueue - type MsgQueue JournalMsgStore = JournalMsgQueue - type MsgStoreConfig JournalMsgStore = JournalStoreConfig +instance QueueStoreClass (JournalQueue s) (QStore s) where + type QueueStoreCfg (QStore s) = QStoreCfg s - newMsgStore :: JournalStoreConfig -> IO JournalMsgStore - newMsgStore config = do + newQueueStore :: QStoreCfg s -> IO (QStore s) + newQueueStore = \case + MQStoreCfg -> MQStore <$> newQueueStore @(JournalQueue s) () + PQStoreCfg dbOpts confirmMigrations -> PQStore <$> newQueueStore @(JournalQueue s) (dbOpts, confirmMigrations) + + loadedQueues = \case + MQStore st -> loadedQueues st + PQStore st -> loadedQueues st + {-# INLINE loadedQueues #-} + + queueCounts = \case + -- TODO [postgres] combine these functions + MQStore st -> queueCounts @(JournalQueue s) st + PQStore st -> queueCounts @(JournalQueue s) st + {-# INLINE queueCounts #-} + + addQueue_ = \case + MQStore st -> addQueue_ st + PQStore st -> addQueue_ st + {-# INLINE addQueue_ #-} + + getQueue_ = \case + MQStore st -> getQueue_ st + PQStore st -> getQueue_ st + {-# INLINE getQueue_ #-} + + secureQueue = \case + MQStore st -> secureQueue st + PQStore st -> secureQueue st + {-# INLINE secureQueue #-} + + addQueueNotifier = \case + MQStore st -> addQueueNotifier st + PQStore st -> addQueueNotifier st + {-# INLINE addQueueNotifier #-} + + deleteQueueNotifier = \case + MQStore st -> deleteQueueNotifier st + PQStore st -> deleteQueueNotifier st + {-# INLINE deleteQueueNotifier #-} + + suspendQueue = \case + MQStore st -> suspendQueue st + PQStore st -> suspendQueue st + {-# INLINE suspendQueue #-} + + blockQueue = \case + MQStore st -> blockQueue st + PQStore st -> blockQueue st + {-# INLINE blockQueue #-} + + unblockQueue = \case + MQStore st -> unblockQueue st + PQStore st -> unblockQueue st + {-# INLINE unblockQueue #-} + + updateQueueTime = \case + MQStore st -> updateQueueTime st + PQStore st -> updateQueueTime st + {-# INLINE updateQueueTime #-} + + deleteStoreQueue = \case + MQStore st -> deleteStoreQueue st + PQStore st -> deleteStoreQueue st + {-# INLINE deleteStoreQueue #-} + + +instance MsgStoreClass (JournalMsgStore s) where + type StoreMonad (JournalMsgStore s) = StoreIO s + type QueueStore (JournalMsgStore s) = QStore s + type StoreQueue (JournalMsgStore s) = JournalQueue s + type MsgStoreConfig (JournalMsgStore s) = JournalStoreConfig s + + newMsgStore :: JournalStoreConfig s -> IO (JournalMsgStore s) + newMsgStore config@JournalStoreConfig {queueStoreCfg} = do random <- newTVarIO =<< newStdGen queueLocks <- TM.emptyIO - queueStore <- newQueueStore + queueStore_ <- newQueueStore @(JournalQueue s) queueStoreCfg expireBackupsBefore <- addUTCTime (- expireBackupsAfter config) <$> getCurrentTime - pure JournalMsgStore {config, random, queueLocks, queueStore, expireBackupsBefore} + pure JournalMsgStore {config, random, queueLocks, queueStore_, expireBackupsBefore} - setStoreLog :: JournalMsgStore -> StoreLog 'WriteMode -> IO () - setStoreLog st sl = atomically $ writeTVar (storeLog $ queueStore st) (Just sl) + closeMsgStore :: JournalMsgStore s -> IO () + closeMsgStore ms = case queueStore_ ms of + MQStore st -> do + readTVarIO (storeLog st) >>= mapM_ closeStoreLog + closeQueues $ loadedQueues @(JournalQueue s) st + PQStore st -> + closeQueues $ loadedQueues @(JournalQueue s) st + where + closeQueues qs = readTVarIO qs >>= mapM_ closeMsgQueue - closeMsgStore JournalMsgStore {queueStore = st} = do - readTVarIO (storeLog st) >>= mapM_ closeStoreLog - readTVarIO (queues st) >>= mapM_ closeMsgQueue + withActiveMsgQueues :: Monoid a => JournalMsgStore s -> (JournalQueue s -> IO a) -> IO a + withActiveMsgQueues ms f = case queueStore_ ms of + MQStore st -> withLoadedQueues st f + PQStore st -> withLoadedQueues st f -- This function is a "foldr" that opens and closes all queues, processes them as defined by action and accumulates the result. -- It is used to export storage to a single file and also to expire messages and validate all queues when server is started. -- TODO this function requires case-sensitive file system, because it uses queue directory as recipient ID. -- It can be made to support case-insensite FS by supporting more than one queue per directory, by getting recipient ID from state file name. - withAllMsgQueues :: forall a. Monoid a => Bool -> JournalMsgStore -> (JournalQueue -> IO a) -> IO a + -- TODO [postgres] this should simply load all known queues and process them + withAllMsgQueues :: forall a. Monoid a => Bool -> JournalMsgStore s -> (JournalQueue s -> IO a) -> IO a withAllMsgQueues tty ms@JournalMsgStore {config} action = ifM (doesDirectoryExist storePath) processStore (pure mempty) where processStore = do @@ -315,44 +415,58 @@ instance MsgStoreClass JournalMsgStore where (pure $ Just (queueId', path')) (Nothing <$ putStrLn ("Error: path " <> path' <> " is not a directory, skipping")) - logQueueStates :: JournalMsgStore -> IO () + logQueueStates :: JournalMsgStore s -> IO () logQueueStates ms = withActiveMsgQueues ms $ unStoreIO . logQueueState - logQueueState :: JournalQueue -> StoreIO () + logQueueState :: JournalQueue s -> StoreIO s () logQueueState q = StoreIO . void $ - readTVarIO (msgQueue_ q) + readTVarIO (msgQueue' q) $>>= \mq -> readTVarIO (handles mq) $>>= (\hs -> (readTVarIO (state mq) >>= appendState (stateHandle hs)) $> Just ()) - recipientId' = recipientId - {-# INLINE recipientId' #-} + queueStore = queueStore_ + {-# INLINE queueStore #-} - queueRec' = queueRec - {-# INLINE queueRec' #-} + mkQueue :: JournalMsgStore s -> RecipientId -> QueueRec -> IO (JournalQueue s) + mkQueue ms rId qr = do + queueLock <- atomically $ getMapLock (queueLocks ms) rId + queueRec' <- newTVarIO $ Just qr + msgQueue' <- newTVarIO Nothing + activeAt <- newTVarIO 0 + queueState <- newTVarIO Nothing + pure $ + JournalQueue + { recipientId' = rId, + queueLock, + queueRec', + msgQueue', + activeAt, + queueState + } - getMsgQueue :: JournalMsgStore -> JournalQueue -> Bool -> StoreIO JournalMsgQueue - getMsgQueue ms@JournalMsgStore {random} q'@JournalQueue {recipientId = rId, msgQueue_} forWrite = - StoreIO $ readTVarIO msgQueue_ >>= maybe newQ pure + getMsgQueue :: JournalMsgStore s -> JournalQueue s -> Bool -> StoreIO s (JournalMsgQueue s) + getMsgQueue ms@JournalMsgStore {random} q'@JournalQueue {recipientId' = rId, msgQueue'} forWrite = + StoreIO $ readTVarIO msgQueue' >>= maybe newQ pure where newQ = do let dir = msgQueueDirectory ms rId statePath = msgQueueStatePath dir $ B.unpack (strEncode rId) queue = JMQueue {queueDirectory = dir, statePath} q <- ifM (doesDirectoryExist dir) (openMsgQueue ms queue forWrite) (createQ queue) - atomically $ writeTVar msgQueue_ $ Just q + atomically $ writeTVar msgQueue' $ Just q st <- readTVarIO $ state q atomically $ writeTVar (queueState q') $ Just $! qState st pure q where - createQ :: JMQueue -> IO JournalMsgQueue + createQ :: JMQueue -> IO (JournalMsgQueue s) createQ queue = do -- folder and files are not created here, -- to avoid file IO for queues without messages during subscription journalId <- newJournalId random mkJournalQueue queue (newMsgQueueState journalId) Nothing - getPeekMsgQueue :: JournalMsgStore -> JournalQueue -> StoreIO (Maybe (JournalMsgQueue, Message)) + getPeekMsgQueue :: JournalMsgStore s -> JournalQueue s -> StoreIO s (Maybe (JournalMsgQueue s, Message)) getPeekMsgQueue ms q@JournalQueue {queueState} = StoreIO (readTVarIO queueState) >>= \case Just QState {hasPending} -> if hasPending then peek else pure Nothing @@ -371,9 +485,9 @@ instance MsgStoreClass JournalMsgStore where (mq,) <$$> tryPeekMsg_ q mq -- only runs action if queue is not empty - withIdleMsgQueue :: Int64 -> JournalMsgStore -> JournalQueue -> (JournalMsgQueue -> StoreIO a) -> StoreIO (Maybe a, Int) + withIdleMsgQueue :: Int64 -> JournalMsgStore s -> JournalQueue s -> (JournalMsgQueue s -> StoreIO s a) -> StoreIO s (Maybe a, Int) withIdleMsgQueue now ms@JournalMsgStore {config} q@JournalQueue {queueState} action = - StoreIO $ readTVarIO (msgQueue_ q) >>= \case + StoreIO $ readTVarIO (msgQueue' q) >>= \case Nothing -> E.bracket getNonEmptyMsgQueue @@ -392,7 +506,7 @@ instance MsgStoreClass JournalMsgStore where sz <- unStoreIO $ getQueueSize_ mq pure (r, sz) where - getNonEmptyMsgQueue :: IO (Maybe JournalMsgQueue) + getNonEmptyMsgQueue :: IO (Maybe (JournalMsgQueue s)) getNonEmptyMsgQueue = readTVarIO queueState >>= \case Just QState {hasStored} @@ -405,17 +519,17 @@ instance MsgStoreClass JournalMsgStore where Just QState {hasStored} | not hasStored -> closeMsgQueue q $> Nothing _ -> pure $ Just mq - deleteQueue :: JournalMsgStore -> JournalQueue -> IO (Either ErrorType QueueRec) + deleteQueue :: JournalMsgStore s -> JournalQueue s -> IO (Either ErrorType QueueRec) deleteQueue ms q = fst <$$> deleteQueue_ ms q - deleteQueueSize :: JournalMsgStore -> JournalQueue -> IO (Either ErrorType (QueueRec, Int)) + deleteQueueSize :: JournalMsgStore s -> JournalQueue s -> IO (Either ErrorType (QueueRec, Int)) deleteQueueSize ms q = deleteQueue_ ms q >>= mapM (traverse getSize) -- traverse operates on the second tuple element where getSize = maybe (pure (-1)) (fmap size . readTVarIO . state) - getQueueMessages_ :: Bool -> JournalQueue -> JournalMsgQueue -> StoreIO [Message] + getQueueMessages_ :: Bool -> JournalQueue s -> JournalMsgQueue s -> StoreIO s [Message] getQueueMessages_ drainMsgs q' q = StoreIO (run []) where run msgs = readTVarIO (handles q) >>= maybe (pure []) (getMsg msgs) @@ -426,7 +540,7 @@ instance MsgStoreClass JournalMsgStore where updateReadPos q' q drainMsgs len hs (msg :) <$> run msgs - writeMsg :: JournalMsgStore -> JournalQueue -> Bool -> Message -> ExceptT ErrorType IO (Maybe (Message, Bool)) + writeMsg :: JournalMsgStore s -> JournalQueue s -> Bool -> Message -> ExceptT ErrorType IO (Maybe (Message, Bool)) writeMsg ms q' logState msg = isolateQueue q' "writeMsg" $ do q <- getMsgQueue ms q' True StoreIO $ (`E.finally` updateActiveAt q') $ do @@ -473,15 +587,15 @@ instance MsgStoreClass JournalMsgStore where pure (newJournalState journalId, wh) -- can ONLY be used while restoring messages, not while server running - setOverQuota_ :: JournalQueue -> IO () + setOverQuota_ :: JournalQueue s -> IO () setOverQuota_ q = - readTVarIO (msgQueue_ q) + readTVarIO (msgQueue' q) >>= mapM_ (\JournalMsgQueue {state} -> atomically $ modifyTVar' state $ \st -> st {canWrite = False}) - getQueueSize_ :: JournalMsgQueue -> StoreIO Int + getQueueSize_ :: JournalMsgQueue s -> StoreIO s Int getQueueSize_ JournalMsgQueue {state} = StoreIO $ size <$> readTVarIO state - tryPeekMsg_ :: JournalQueue -> JournalMsgQueue -> StoreIO (Maybe Message) + tryPeekMsg_ :: JournalQueue s -> JournalMsgQueue s -> StoreIO s (Maybe Message) tryPeekMsg_ q mq@JournalMsgQueue {tipMsg, handles} = StoreIO $ (readTVarIO handles $>>= chooseReadJournal q mq True $>>= peekMsg) where @@ -492,7 +606,7 @@ instance MsgStoreClass JournalMsgStore where atomically $ writeTVar tipMsg $ Just (Just ml) pure $ Just msg - tryDeleteMsg_ :: JournalQueue -> JournalMsgQueue -> Bool -> StoreIO () + tryDeleteMsg_ :: JournalQueue s -> JournalMsgQueue s -> Bool -> StoreIO s () tryDeleteMsg_ q mq@JournalMsgQueue {tipMsg, handles} logState = StoreIO $ (`E.finally` when logState (updateActiveAt q)) $ void $ readTVarIO tipMsg -- if there is no cached tipMsg, do nothing @@ -500,11 +614,11 @@ instance MsgStoreClass JournalMsgStore where $>>= \len -> readTVarIO handles $>>= \hs -> updateReadPos q mq logState len hs $> Just () - isolateQueue :: JournalQueue -> String -> StoreIO a -> ExceptT ErrorType IO a - isolateQueue JournalQueue {recipientId, queueLock} op = - tryStore' op recipientId . withLock' queueLock op . unStoreIO + isolateQueue :: JournalQueue s -> String -> StoreIO s a -> ExceptT ErrorType IO a + isolateQueue JournalQueue {recipientId' = rId, queueLock} op a = + tryStore' op rId $ withLock' queueLock op $ unStoreIO a -updateActiveAt :: JournalQueue -> IO () +updateActiveAt :: JournalQueue s -> IO () updateActiveAt q = atomically . writeTVar (activeAt q) . systemSeconds =<< getSystemTime tryStore' :: String -> RecipientId -> IO a -> ExceptT ErrorType IO a @@ -518,10 +632,10 @@ tryStore op rId a = ExceptT $ E.mask_ $ E.try a >>= either storeErr pure let e' = intercalate ", " [op, B.unpack $ strEncode rId, show e] in logError ("STORE: " <> T.pack e') $> Left (STORE e') -isolateQueueId :: String -> JournalMsgStore -> RecipientId -> IO (Either ErrorType a) -> ExceptT ErrorType IO a +isolateQueueId :: String -> JournalMsgStore s -> RecipientId -> IO (Either ErrorType a) -> ExceptT ErrorType IO a isolateQueueId op ms rId = tryStore op rId . withLockMap (queueLocks ms) rId op -openMsgQueue :: JournalMsgStore -> JMQueue -> Bool -> IO JournalMsgQueue +openMsgQueue :: JournalMsgStore s -> JMQueue -> Bool -> IO (JournalMsgQueue s) openMsgQueue ms@JournalMsgStore {config} q@JMQueue {queueDirectory = dir, statePath} forWrite = do (st_, shouldBackup) <- readQueueState ms statePath case st_ of @@ -581,7 +695,7 @@ openMsgQueue ms@JournalMsgStore {config} q@JMQueue {queueDirectory = dir, stateP backupPathTime = iso8601ParseM . T.unpack <=< T.stripSuffix ".bak" <=< T.stripPrefix statePathPfx . T.pack statePathPfx = T.pack $ takeFileName statePath <> "." -mkJournalQueue :: JMQueue -> MsgQueueState -> Maybe MsgQueueHandles -> IO JournalMsgQueue +mkJournalQueue :: JMQueue -> MsgQueueState -> Maybe MsgQueueHandles -> IO (JournalMsgQueue s) mkJournalQueue queue st hs_ = do state <- newTVarIO st tipMsg <- newTVarIO Nothing @@ -590,7 +704,7 @@ mkJournalQueue queue st hs_ = do -- to avoid map lookup on queue operations pure JournalMsgQueue {queue, state, tipMsg, handles} -chooseReadJournal :: JournalQueue -> JournalMsgQueue -> Bool -> MsgQueueHandles -> IO (Maybe (JournalState 'JTRead, Handle)) +chooseReadJournal :: JournalQueue s -> JournalMsgQueue s -> Bool -> MsgQueueHandles -> IO (Maybe (JournalState 'JTRead, Handle)) chooseReadJournal q' q log' hs = do st@MsgQueueState {writeState = ws, readState = rs} <- readTVarIO (state q) case writeHandle hs of @@ -606,7 +720,7 @@ chooseReadJournal q' q log' hs = do _ | msgPos rs >= msgCount rs && journalId rs == journalId ws -> pure Nothing _ -> pure $ Just (rs, readHandle hs) -updateQueueState :: JournalQueue -> JournalMsgQueue -> Bool -> MsgQueueHandles -> MsgQueueState -> STM () -> IO () +updateQueueState :: JournalQueue s -> JournalMsgQueue s -> Bool -> MsgQueueHandles -> MsgQueueState -> STM () -> IO () updateQueueState q' q log' hs st a = do unless (validQueueState st) $ E.throwIO $ userError $ "updateQueueState invalid state: " <> show st when log' $ appendState (stateHandle hs) st @@ -620,7 +734,7 @@ appendState h = E.uninterruptibleMask_ . appendState_ h appendState_ :: Handle -> MsgQueueState -> IO () appendState_ h st = B.hPutStr h $ strEncode st `B.snoc` '\n' -updateReadPos :: JournalQueue -> JournalMsgQueue -> Bool -> Int64 -> MsgQueueHandles -> IO () +updateReadPos :: JournalQueue s -> JournalMsgQueue s -> Bool -> Int64 -> MsgQueueHandles -> IO () updateReadPos q' q log' len hs = do st@MsgQueueState {readState = rs, size} <- readTVarIO (state q) let JournalState {msgPos, bytePos} = rs @@ -629,7 +743,7 @@ updateReadPos q' q log' len hs = do st' = st {readState = rs', size = size - 1} updateQueueState q' q log' hs st' $ writeTVar (tipMsg q) Nothing -msgQueueDirectory :: JournalMsgStore -> RecipientId -> FilePath +msgQueueDirectory :: JournalMsgStore s -> RecipientId -> FilePath msgQueueDirectory JournalMsgStore {config = JournalStoreConfig {storePath, pathParts}} rId = storePath B.unpack (B.intercalate "/" $ splitSegments pathParts $ strEncode rId) where @@ -652,7 +766,7 @@ createNewJournal dir journalId = do newJournalId :: TVar StdGen -> IO ByteString newJournalId g = strEncode <$> atomically (stateTVar g $ genByteString 12) -openJournals :: JournalMsgStore -> FilePath -> MsgQueueState -> Handle -> IO (MsgQueueState, Handle, Maybe Handle) +openJournals :: JournalMsgStore s -> FilePath -> MsgQueueState -> Handle -> IO (MsgQueueState, Handle, Maybe Handle) openJournals ms dir st@MsgQueueState {readState = rs, writeState = ws} sh = do let rjId = journalId rs wjId = journalId ws @@ -737,7 +851,7 @@ handleError cxt path a = -- This function is supposed to be resilient to crashes while updating state files, -- and also resilient to crashes during its execution. -readQueueState :: JournalMsgStore -> FilePath -> IO (Maybe MsgQueueState, Bool) +readQueueState :: JournalMsgStore s -> FilePath -> IO (Maybe MsgQueueState, Bool) readQueueState JournalMsgStore {config} statePath = ifM (doesFileExist tempBackup) @@ -801,10 +915,11 @@ validQueueState MsgQueueState {readState = rs, writeState = ws, size} && msgPos ws == msgCount ws && bytePos ws == byteCount ws -deleteQueue_ :: JournalMsgStore -> JournalQueue -> IO (Either ErrorType (QueueRec, Maybe JournalMsgQueue)) +-- TODO [postgres] possibly, we need to remove the lock from map +deleteQueue_ :: JournalMsgStore s -> JournalQueue s -> IO (Either ErrorType (QueueRec, Maybe (JournalMsgQueue s))) deleteQueue_ ms q = runExceptT $ isolateQueueId "deleteQueue_" ms rId $ - deleteQueue' ms q >>= mapM remove + deleteStoreQueue (queueStore_ ms) q >>= mapM remove where rId = recipientId q remove r@(_, mq_) = do @@ -812,10 +927,10 @@ deleteQueue_ ms q = removeQueueDirectory ms rId pure r -closeMsgQueue :: JournalQueue -> IO () -closeMsgQueue JournalQueue {msgQueue_} = atomically (swapTVar msgQueue_ Nothing) >>= mapM_ closeMsgQueueHandles +closeMsgQueue :: JournalQueue s -> IO () +closeMsgQueue JournalQueue {msgQueue'} = atomically (swapTVar msgQueue' Nothing) >>= mapM_ closeMsgQueueHandles -closeMsgQueueHandles :: JournalMsgQueue -> IO () +closeMsgQueueHandles :: JournalMsgQueue s -> IO () closeMsgQueueHandles q = readTVarIO (handles q) >>= mapM_ closeHandles where closeHandles (MsgQueueHandles sh rh wh_) = do @@ -823,7 +938,7 @@ closeMsgQueueHandles q = readTVarIO (handles q) >>= mapM_ closeHandles hClose rh mapM_ hClose wh_ -removeQueueDirectory :: JournalMsgStore -> RecipientId -> IO () +removeQueueDirectory :: JournalMsgStore s -> RecipientId -> IO () removeQueueDirectory st = removeQueueDirectory_ . msgQueueDirectory st removeQueueDirectory_ :: FilePath -> IO () diff --git a/src/Simplex/Messaging/Server/MsgStore/STM.hs b/src/Simplex/Messaging/Server/MsgStore/STM.hs index ac462a71a..d2a31d3d2 100644 --- a/src/Simplex/Messaging/Server/MsgStore/STM.hs +++ b/src/Simplex/Messaging/Server/MsgStore/STM.hs @@ -7,12 +7,14 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TupleSections #-} module Simplex.Messaging.Server.MsgStore.STM ( STMMsgStore (..), STMStoreConfig (..), + STMQueue, ) where @@ -25,25 +27,25 @@ import Simplex.Messaging.Protocol import Simplex.Messaging.Server.MsgStore.Types import Simplex.Messaging.Server.QueueStore import Simplex.Messaging.Server.QueueStore.STM +import Simplex.Messaging.Server.QueueStore.Types import Simplex.Messaging.Server.StoreLog import Simplex.Messaging.Util ((<$$>), ($>>=)) -import System.IO (IOMode (..)) data STMMsgStore = STMMsgStore { storeConfig :: STMStoreConfig, - queueStore :: STMQueueStore STMQueue + queueStore_ :: STMQueueStore STMQueue } data STMQueue = STMQueue { -- To avoid race conditions and errors when restoring queues, -- Nothing is written to TVar when queue is deleted. - recipientId :: RecipientId, - queueRec :: TVar (Maybe QueueRec), - msgQueue_ :: TVar (Maybe STMMsgQueue) + recipientId' :: RecipientId, + queueRec' :: TVar (Maybe QueueRec), + msgQueue' :: TVar (Maybe STMMsgQueue) } data STMMsgQueue = STMMsgQueue - { msgQueue :: TQueue Message, + { msgTQueue :: TQueue Message, canWrite :: TVar Bool, size :: TVar Int } @@ -53,59 +55,61 @@ data STMStoreConfig = STMStoreConfig quota :: Int } -instance STMStoreClass STMMsgStore where - stmQueueStore = queueStore - mkQueue _ rId qr = STMQueue rId <$> newTVar (Just qr) <*> newTVar Nothing - msgQueue_' = msgQueue_ +instance StoreQueueClass STMQueue where + type MsgQueue STMQueue = STMMsgQueue + recipientId = recipientId' + {-# INLINE recipientId #-} + queueRec = queueRec' + {-# INLINE queueRec #-} + msgQueue = msgQueue' + {-# INLINE msgQueue #-} + withQueueLock _ _ = id + {-# INLINE withQueueLock #-} instance MsgStoreClass STMMsgStore where type StoreMonad STMMsgStore = STM + type QueueStore STMMsgStore = STMQueueStore STMQueue type StoreQueue STMMsgStore = STMQueue - type MsgQueue STMMsgStore = STMMsgQueue type MsgStoreConfig STMMsgStore = STMStoreConfig newMsgStore :: STMStoreConfig -> IO STMMsgStore newMsgStore storeConfig = do - queueStore <- newQueueStore - pure STMMsgStore {storeConfig, queueStore} + queueStore_ <- newQueueStore @STMQueue () + pure STMMsgStore {storeConfig, queueStore_} - setStoreLog :: STMMsgStore -> StoreLog 'WriteMode -> IO () - setStoreLog st sl = atomically $ writeTVar (storeLog $ queueStore st) (Just sl) + closeMsgStore st = readTVarIO (storeLog $ queueStore_ st) >>= mapM_ closeStoreLog - closeMsgStore st = readTVarIO (storeLog $ queueStore st) >>= mapM_ closeStoreLog - - withAllMsgQueues _ = withActiveMsgQueues + withActiveMsgQueues = withLoadedQueues . queueStore_ + {-# INLINE withActiveMsgQueues #-} + withAllMsgQueues _ = withLoadedQueues . queueStore_ {-# INLINE withAllMsgQueues #-} - logQueueStates _ = pure () {-# INLINE logQueueStates #-} - logQueueState _ = pure () {-# INLINE logQueueState #-} + queueStore = queueStore_ + {-# INLINE queueStore #-} - recipientId' = recipientId - {-# INLINE recipientId' #-} - - queueRec' = queueRec - {-# INLINE queueRec' #-} + 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 + getMsgQueue _ STMQueue {msgQueue'} _ = readTVar msgQueue' >>= maybe newQ pure where newQ = do - msgQueue <- newTQueue + msgTQueue <- newTQueue canWrite <- newTVar True size <- newTVar 0 - let q = STMMsgQueue {msgQueue, canWrite, size} - writeTVar msgQueue_ (Just q) + 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 + 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 + withIdleMsgQueue _ _ STMQueue {msgQueue'} action = readTVar msgQueue' >>= \case Just q -> do r <- action q sz <- getQueueSize_ q @@ -113,16 +117,16 @@ instance MsgStoreClass STMMsgStore where Nothing -> pure (Nothing, 0) deleteQueue :: STMMsgStore -> STMQueue -> IO (Either ErrorType QueueRec) - deleteQueue ms q = fst <$$> deleteQueue' ms q + deleteQueue ms q = fst <$$> deleteStoreQueue (queueStore_ ms) q deleteQueueSize :: STMMsgStore -> STMQueue -> IO (Either ErrorType (QueueRec, Int)) - deleteQueueSize ms q = deleteQueue' ms q >>= mapM (traverse getSize) + deleteQueueSize ms q = deleteStoreQueue (queueStore_ ms) q >>= mapM (traverse getSize) -- traverse operates on the second tuple element where getSize = maybe (pure 0) (\STMMsgQueue {size} -> readTVarIO size) getQueueMessages_ :: Bool -> STMQueue -> STMMsgQueue -> STM [Message] - getQueueMessages_ drainMsgs _ = (if drainMsgs then flushTQueue else snapshotTQueue) . msgQueue + getQueueMessages_ drainMsgs _ = (if drainMsgs then flushTQueue else snapshotTQueue) . msgTQueue where snapshotTQueue q = do msgs <- flushTQueue q @@ -131,7 +135,7 @@ instance MsgStoreClass STMMsgStore where writeMsg :: STMMsgStore -> STMQueue -> Bool -> Message -> ExceptT ErrorType IO (Maybe (Message, Bool)) writeMsg ms q' _logState msg = liftIO $ atomically $ do - STMMsgQueue {msgQueue = q, canWrite, size} <- getMsgQueue ms q' True + STMMsgQueue {msgTQueue = q, canWrite, size} <- getMsgQueue ms q' True canWrt <- readTVar canWrite empty <- isEmptyTQueue q if canWrt || empty @@ -148,17 +152,17 @@ instance MsgStoreClass STMMsgStore where msgQuota = MessageQuota {msgId = messageId msg, msgTs = messageTs msg} setOverQuota_ :: STMQueue -> IO () - setOverQuota_ q = readTVarIO (msgQueue_ q) >>= mapM_ (\mq -> atomically $ writeTVar (canWrite mq) False) + setOverQuota_ q = readTVarIO (msgQueue' q) >>= mapM_ (\mq -> atomically $ writeTVar (canWrite mq) False) getQueueSize_ :: STMMsgQueue -> STM Int getQueueSize_ STMMsgQueue {size} = readTVar size tryPeekMsg_ :: STMQueue -> STMMsgQueue -> STM (Maybe Message) - tryPeekMsg_ _ = tryPeekTQueue . msgQueue + tryPeekMsg_ _ = tryPeekTQueue . msgTQueue {-# INLINE tryPeekMsg_ #-} tryDeleteMsg_ :: STMQueue -> STMMsgQueue -> Bool -> STM () - tryDeleteMsg_ _ STMMsgQueue {msgQueue = q, size} _logState = + tryDeleteMsg_ _ STMMsgQueue {msgTQueue = q, size} _logState = tryReadTQueue q >>= \case Just _ -> modifyTVar' size (subtract 1) _ -> pure () diff --git a/src/Simplex/Messaging/Server/MsgStore/Types.hs b/src/Simplex/Messaging/Server/MsgStore/Types.hs index ada1ca333..2aa741a8f 100644 --- a/src/Simplex/Messaging/Server/MsgStore/Types.hs +++ b/src/Simplex/Messaging/Server/MsgStore/Types.hs @@ -6,7 +6,9 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilyDependencies #-} {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} @@ -15,7 +17,6 @@ module Simplex.Messaging.Server.MsgStore.Types where import Control.Concurrent.STM -import Control.Monad (foldM) import Control.Monad.Trans.Except import Data.Functor (($>)) import Data.Int (Int64) @@ -23,63 +24,63 @@ import Data.Kind import Data.Time.Clock.System (SystemTime (systemSeconds)) import Simplex.Messaging.Protocol import Simplex.Messaging.Server.QueueStore -import Simplex.Messaging.Server.StoreLog.Types -import Simplex.Messaging.TMap (TMap) -import Simplex.Messaging.Util ((<$$>)) -import System.IO (IOMode (..)) +import Simplex.Messaging.Server.QueueStore.Types +import Simplex.Messaging.Util ((<$$>), ($>>=)) -data STMQueueStore q = STMQueueStore - { queues :: TMap RecipientId q, - senders :: TMap SenderId RecipientId, - notifiers :: TMap NotifierId RecipientId, - storeLog :: TVar (Maybe (StoreLog 'WriteMode)) - } - -class MsgStoreClass s => STMStoreClass s where - stmQueueStore :: s -> STMQueueStore (StoreQueue s) - mkQueue :: s -> RecipientId -> QueueRec -> STM (StoreQueue s) - msgQueue_' :: StoreQueue s -> TVar (Maybe (MsgQueue s)) - -class Monad (StoreMonad s) => MsgStoreClass s where +class (Monad (StoreMonad s), QueueStoreClass (StoreQueue s) (QueueStore s)) => MsgStoreClass s where type StoreMonad s = (m :: Type -> Type) | m -> s type MsgStoreConfig s = c | c -> s type StoreQueue s = q | q -> s - type MsgQueue s = q | q -> s + type QueueStore s = qs | qs -> s newMsgStore :: MsgStoreConfig s -> IO s - setStoreLog :: s -> StoreLog 'WriteMode -> IO () closeMsgStore :: s -> IO () + withActiveMsgQueues :: Monoid a => s -> (StoreQueue s -> IO a) -> IO a withAllMsgQueues :: Monoid a => Bool -> s -> (StoreQueue s -> IO a) -> IO a logQueueStates :: s -> IO () logQueueState :: StoreQueue s -> StoreMonad s () - recipientId' :: StoreQueue s -> RecipientId - queueRec' :: StoreQueue s -> TVar (Maybe QueueRec) - getPeekMsgQueue :: s -> StoreQueue s -> StoreMonad s (Maybe (MsgQueue s, Message)) - getMsgQueue :: s -> StoreQueue s -> Bool -> StoreMonad s (MsgQueue s) + queueStore :: s -> QueueStore s + + -- message store methods + mkQueue :: s -> RecipientId -> QueueRec -> IO (StoreQueue s) + getMsgQueue :: s -> StoreQueue s -> Bool -> StoreMonad s (MsgQueue (StoreQueue s)) + getPeekMsgQueue :: s -> StoreQueue s -> StoreMonad s (Maybe (MsgQueue (StoreQueue 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) + withIdleMsgQueue :: Int64 -> s -> StoreQueue s -> (MsgQueue (StoreQueue s) -> StoreMonad s a) -> StoreMonad s (Maybe a, Int) 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] + getQueueMessages_ :: Bool -> StoreQueue s -> MsgQueue (StoreQueue 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 () + getQueueSize_ :: MsgQueue (StoreQueue s) -> StoreMonad s Int + tryPeekMsg_ :: StoreQueue s -> MsgQueue (StoreQueue s) -> StoreMonad s (Maybe Message) + tryDeleteMsg_ :: StoreQueue s -> MsgQueue (StoreQueue s) -> Bool -> StoreMonad s () isolateQueue :: StoreQueue s -> String -> StoreMonad s a -> ExceptT ErrorType IO a data MSType = MSMemory | MSJournal +data QSType = QSMemory | QSPostgres + data SMSType :: MSType -> Type where SMSMemory :: SMSType 'MSMemory SMSJournal :: SMSType 'MSJournal -data AMSType = forall s. AMSType (SMSType s) +data SQSType :: QSType -> Type where + SQSMemory :: SQSType 'QSMemory + SQSPostgres :: SQSType 'QSPostgres -withActiveMsgQueues :: (STMStoreClass s, Monoid a) => s -> (StoreQueue s -> IO a) -> IO a -withActiveMsgQueues st f = readTVarIO (queues $ stmQueueStore st) >>= foldM run mempty - where - run !acc = fmap (acc <>) . f +addQueue :: MsgStoreClass s => s -> RecipientId -> QueueRec -> IO (Either ErrorType (StoreQueue s)) +addQueue st = addQueue_ (queueStore st) (mkQueue st) +{-# INLINE addQueue #-} + +getQueue :: (MsgStoreClass s, DirectParty p) => s -> SParty p -> QueueId -> IO (Either ErrorType (StoreQueue s)) +getQueue st = getQueue_ (queueStore st) (mkQueue st) +{-# INLINE getQueue #-} + +getQueueRec :: (MsgStoreClass s, DirectParty p) => s -> SParty p -> QueueId -> IO (Either ErrorType (StoreQueue s, QueueRec)) +getQueueRec st party qId = + getQueue st party qId + $>>= (\q -> maybe (Left AUTH) (Right . (q,)) <$> readTVarIO (queueRec q)) getQueueMessages :: MsgStoreClass s => Bool -> s -> StoreQueue s -> ExceptT ErrorType IO [Message] getQueueMessages drainMsgs st q = withPeekMsgQueue st q "getQueueSize" $ maybe (pure []) (getQueueMessages_ drainMsgs q . fst) @@ -112,7 +113,7 @@ tryDelPeekMsg st q msgId' = | otherwise -> pure (Nothing, Just msg) -- The action is called with Nothing when it is known that the queue is empty -withPeekMsgQueue :: MsgStoreClass s => s -> StoreQueue s -> String -> (Maybe (MsgQueue s, Message) -> StoreMonad s a) -> ExceptT ErrorType IO a +withPeekMsgQueue :: MsgStoreClass s => s -> StoreQueue s -> String -> (Maybe (MsgQueue (StoreQueue s), Message) -> StoreMonad s a) -> ExceptT ErrorType IO a withPeekMsgQueue st q op a = isolateQueue q op $ getPeekMsgQueue st q >>= a {-# INLINE withPeekMsgQueue #-} @@ -128,7 +129,7 @@ idleDeleteExpiredMsgs now st q old = isolateQueue q "idleDeleteExpiredMsgs" $ withIdleMsgQueue now st q (deleteExpireMsgs_ old q) -deleteExpireMsgs_ :: MsgStoreClass s => Int64 -> StoreQueue s -> MsgQueue s -> StoreMonad s Int +deleteExpireMsgs_ :: MsgStoreClass s => Int64 -> StoreQueue s -> MsgQueue (StoreQueue s) -> StoreMonad s Int deleteExpireMsgs_ old q mq = do n <- loop 0 logQueueState q diff --git a/src/Simplex/Messaging/Server/QueueStore.hs b/src/Simplex/Messaging/Server/QueueStore.hs index af26b91f7..476f4936b 100644 --- a/src/Simplex/Messaging/Server/QueueStore.hs +++ b/src/Simplex/Messaging/Server/QueueStore.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE LambdaCase #-} @@ -11,9 +12,14 @@ module Simplex.Messaging.Server.QueueStore where import Control.Applicative ((<|>)) import Data.Functor (($>)) import Data.Int (Int64) +import Data.Text.Encoding (decodeLatin1, encodeUtf8) import Data.Time.Clock.System (SystemTime (..), getSystemTime) +import Database.PostgreSQL.Simple.FromField (FromField (..)) +import Database.PostgreSQL.Simple.ToField (ToField (..)) +import Simplex.Messaging.Agent.Store.Postgres.DB (fromTextField_) import Simplex.Messaging.Encoding.String import Simplex.Messaging.Protocol +import Simplex.Messaging.Util (eitherToMaybe) data QueueRec = QueueRec { recipientKey :: !RcvPublicAuthKey, @@ -56,8 +62,13 @@ instance StrEncoding ServerEntityStatus where <|> "blocked," *> (EntityBlocked <$> strP) <|> "off" $> EntityOff +instance FromField ServerEntityStatus where fromField = fromTextField_ $ eitherToMaybe . strDecode . encodeUtf8 + +instance ToField ServerEntityStatus where toField = toField . decodeLatin1 . strEncode + newtype RoundedSystemTime = RoundedSystemTime Int64 deriving (Eq, Ord, Show) + deriving newtype (FromField, ToField) instance StrEncoding RoundedSystemTime where strEncode (RoundedSystemTime t) = strEncode t diff --git a/src/Simplex/Messaging/Server/QueueStore/Postgres.hs b/src/Simplex/Messaging/Server/QueueStore/Postgres.hs new file mode 100644 index 000000000..edb9f3dc0 --- /dev/null +++ b/src/Simplex/Messaging/Server/QueueStore/Postgres.hs @@ -0,0 +1,376 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Simplex.Messaging.Server.QueueStore.Postgres where + +import Control.Concurrent.STM +import qualified Control.Exception as E +import Control.Logger.Simple +import Control.Monad +import Data.Bitraversable (bimapM) +import Data.Functor (($>)) +import Data.Int (Int64) +import qualified Data.Map.Strict as M +import Data.Maybe (catMaybes, mapMaybe) +import qualified Data.Text as T +import Database.PostgreSQL.Simple (Binary (..), Only (..), Query, SqlError, (:.) (..)) +import qualified Database.PostgreSQL.Simple as PSQL +import Database.PostgreSQL.Simple.Errors (ConstraintViolation (..), constraintViolation) +import Database.PostgreSQL.Simple.SqlQQ (sql) +import Simplex.Messaging.Agent.Client (withLockMap) +import Simplex.Messaging.Agent.Lock (Lock) +import Simplex.Messaging.Agent.Store.Postgres (createDBStore) +import Simplex.Messaging.Agent.Store.Postgres.Common +import Simplex.Messaging.Agent.Store.Postgres.DB (FromField (..), ToField (..), blobFieldDecoder) +import qualified Simplex.Messaging.Agent.Store.Postgres.DB as DB +import Simplex.Messaging.Agent.Store.Shared (MigrationConfirmation) +import qualified Simplex.Messaging.Crypto as C +import Simplex.Messaging.Encoding.String +import Simplex.Messaging.Protocol +import Simplex.Messaging.Server.QueueStore +import Simplex.Messaging.Server.QueueStore.Postgres.Migrations (serverMigrations) +import Simplex.Messaging.Server.QueueStore.STM (readQueueRecIO, setStatus, withQueueRec) +import Simplex.Messaging.Server.QueueStore.Types +import Simplex.Messaging.TMap (TMap) +import qualified Simplex.Messaging.TMap as TM +import Simplex.Messaging.Util (firstRow, ifM, tshow, ($>>), ($>>=), (<$$), (<$$>)) +import System.Exit (exitFailure) +import System.IO (hFlush, stdout) + +data PostgresQueueStore q = PostgresQueueStore + { dbStore :: DBStore, + -- 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 + } + +instance StoreQueueClass q => QueueStoreClass q (PostgresQueueStore q) where + type QueueStoreCfg (PostgresQueueStore q) = (DBOpts, MigrationConfirmation) + + newQueueStore :: (DBOpts, MigrationConfirmation) -> IO (PostgresQueueStore q) + newQueueStore (dbOpts, confirmMigrations) = do + dbStore <- either err pure =<< createDBStore dbOpts serverMigrations confirmMigrations + queues <- TM.emptyIO + senders <- TM.emptyIO + notifiers <- TM.emptyIO + notifierLocks <- TM.emptyIO + pure PostgresQueueStore {dbStore, queues, senders, notifiers, notifierLocks} + where + err e = do + logError $ "STORE: newQueueStore, error opening PostgreSQL database, " <> tshow e + exitFailure + + loadedQueues = queues + {-# INLINE loadedQueues #-} + + queueCounts :: PostgresQueueStore q -> IO QueueCounts + queueCounts st = + withConnection (dbStore st) $ \db -> do + (queueCount, notifierCount) : _ <- + DB.query_ + db + [sql| + SELECT + (SELECT COUNT(1) FROM msg_queues) AS queue_count, + (SELECT COUNT(1) FROM msg_notifiers) AS notifier_count + |] + pure QueueCounts {queueCount, notifierCount} + + -- this implementation assumes that the lock is already taken by addQueue + -- and 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 + withQueueLock sq "addQueue_" $ + addDB $>> add sq + where + PostgresQueueStore {queues, senders} = st + addDB = + withDB "addQueue_" st $ \db -> + E.try (insertQueueDB db rId qr) >>= bimapM handleDuplicate pure + add sq = do + atomically $ TM.insert rId sq queues + atomically $ TM.insert (senderId qr) rId senders + pure $ Right sq + -- 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_ :: DirectParty p => PostgresQueueStore q -> (RecipientId -> QueueRec -> IO q) -> SParty p -> QueueId -> IO (Either ErrorType q) + getQueue_ st mkQ party qId = case party of + SRecipient -> getRcvQueue qId + SSender -> TM.lookupIO qId senders >>= maybe loadSndQueue getRcvQueue + SNotifier -> TM.lookupIO qId notifiers >>= maybe loadNtfQueue getRcvQueue + where + PostgresQueueStore {queues, senders, notifiers} = st + getRcvQueue rId = TM.lookupIO rId queues >>= maybe loadRcvQueue (pure . Right) + loadRcvQueue = loadQueue " WHERE q.recipient_id = ?" $ \_ -> pure () + loadSndQueue = loadQueue " WHERE q.sender_id = ?" $ \rId -> TM.insert qId rId senders + loadNtfQueue = loadQueue " WHERE n.notifier_id = ?" $ \_ -> pure () -- do NOT cache ref - ntf subscriptions are rare + loadQueue condition insertRef = + loadQueueRec $>>= \(rId, qRec) -> do + sq <- mkQ rId qRec + atomically $ + -- checking the cache again for concurrent reads + TM.lookup rId queues >>= \case + Just sq' -> pure $ Right sq' + Nothing -> do + insertRef rId + TM.insert rId sq queues + pure $ Right sq + where + loadQueueRec = + withDB "getQueue_" st $ \db -> firstRow rowToQueueRec AUTH $ + DB.query db (queueRecQuery <> condition) (Only qId) + + secureQueue :: PostgresQueueStore q -> q -> SndPublicAuthKey -> IO (Either ErrorType ()) + secureQueue st sq sKey = + withQueueLock sq "secureQueue" $ + readQueueRecIO qr + $>>= \q -> verify q + $>> secureDB + $>> secure q + where + qr = queueRec sq + verify q = pure $ case senderKey q of + Just k | sKey /= k -> Left AUTH + _ -> Right () + secureDB = + withDB' "secureQueue" st $ \db -> + DB.execute db "UPDATE msg_queues SET sender_key = ? WHERE recipient_id = ?" (sKey, recipientId sq) + secure q = do + atomically $ writeTVar qr $ Just q {senderKey = Just sKey} + pure $ Right () + + addQueueNotifier :: PostgresQueueStore q -> q -> NtfCreds -> IO (Either ErrorType (Maybe NotifierId)) + addQueueNotifier st sq ntfCreds@NtfCreds {notifierId = nId, notifierKey, rcvNtfDhSecret} = + withQueueLock sq "addQueueNotifier" $ + readQueueRecIO qr $>>= add + where + PostgresQueueStore {notifiers} = st + rId = recipientId sq + qr = queueRec sq + add q = + withLockMap (notifierLocks st) nId "addQueueNotifier" $ + ifM (TM.memberIO nId notifiers) (pure $ Left DUPLICATE_) $ + addDB $>> do + nId_ <- forM (notifier q) $ \NtfCreds {notifierId} -> atomically (TM.delete notifierId notifiers) $> notifierId + let !q' = q {notifier = Just ntfCreds} + atomically $ writeTVar qr $ Just q' + -- cache queue notifier ID – after notifier is added ntf server will likely subscribe + atomically $ TM.insert nId rId notifiers + pure $ Right nId_ + addDB = + withDB "addQueueNotifier" st $ \db -> + E.try (insert db) >>= bimapM handleDuplicate pure + where + -- TODO [postgres] test how this query works with duplicate recipient_id (updates) and notifier_id (fails) + insert db = + DB.execute + db + [sql| + INSERT INTO msg_notifiers (recipient_id, notifier_id, notifier_key, rcv_ntf_dh_secret) + VALUES (?, ?, ?, ?) + ON CONFLICT (recipient_id) DO UPDATE + SET notifier_id = EXCLUDED.notifier_id, + notifier_key = EXCLUDED.notifier_key, + rcv_ntf_dh_secret = EXCLUDED.rcv_ntf_dh_secret + |] + (rId, nId, notifierKey, rcvNtfDhSecret) + + deleteQueueNotifier :: PostgresQueueStore q -> q -> IO (Either ErrorType (Maybe NotifierId)) + deleteQueueNotifier st sq = + withQueueLock sq "deleteQueueNotifier" $ + readQueueRecIO qr $>>= fmap sequence . delete + where + qr = queueRec sq + delete :: QueueRec -> IO (Maybe (Either ErrorType NotifierId)) + delete q = forM (notifier q) $ \NtfCreds {notifierId = nId} -> + withLockMap (notifierLocks st) nId "deleteQueueNotifier" $ do + deleteDB nId $>> do + atomically $ TM.delete nId $ notifiers st + atomically $ writeTVar qr $! Just q {notifier = Nothing} + pure $ Right nId + deleteDB nId = + withDB' "deleteQueueNotifier" st $ \db -> + DB.execute db "DELETE FROM msg_notifiers WHERE notifier_id = ?" (Only nId) + + -- TODO [postgres] only update STM on DB success + suspendQueue :: PostgresQueueStore q -> q -> IO (Either ErrorType ()) + suspendQueue st sq = + setStatus (queueRec sq) EntityOff + $>> setStatusDB "suspendQueue" st (recipientId sq) EntityOff + + -- TODO [postgres] only update STM on DB success + blockQueue :: PostgresQueueStore q -> q -> BlockingInfo -> IO (Either ErrorType ()) + blockQueue st sq info = + setStatus (queueRec sq) (EntityBlocked info) + $>> setStatusDB "blockQueue" st (recipientId sq) (EntityBlocked info) + + -- TODO [postgres] only update STM on DB success + unblockQueue :: PostgresQueueStore q -> q -> IO (Either ErrorType ()) + unblockQueue st sq = + setStatus (queueRec sq) EntityActive + $>> setStatusDB "unblockQueue" st (recipientId sq) EntityActive + + -- TODO [postgres] only update STM on DB success + updateQueueTime :: PostgresQueueStore q -> q -> RoundedSystemTime -> IO (Either ErrorType QueueRec) + updateQueueTime st sq t = withQueueRec qr update $>>= updateDB + where + qr = queueRec sq + update q@QueueRec {updatedAt} + | updatedAt == Just t = pure (q, False) + | otherwise = + let !q' = q {updatedAt = Just t} + in (writeTVar qr $! Just q') $> (q', True) + updateDB (q, changed) + | changed = q <$$ withDB' "updateQueueTime" st (\db -> DB.execute db "UPDATE msg_queues SET updated_at = ? WHERE recipient_id = ?" (t, Binary $ unEntityId $ recipientId sq)) + | otherwise = pure $ Right q + + -- TODO [postgres] only update STM on DB success + deleteStoreQueue :: PostgresQueueStore q -> q -> IO (Either ErrorType (QueueRec, Maybe (MsgQueue q))) + deleteStoreQueue st sq = + withQueueRec qr delete + $>>= \q -> deleteDB + >>= mapM (\_ -> (q,) <$> atomically (swapTVar (msgQueue sq) Nothing)) + where + qr = queueRec sq + delete q = do + writeTVar qr Nothing + TM.delete (senderId q) $ senders st + -- TODO [postgres] probably we should delete it? + -- forM_ (notifier q) $ \NtfCreds {notifierId} -> TM.delete notifierId $ notifiers st + pure q + deleteDB = + withDB' "deleteStoreQueue" st $ \db -> + DB.execute db "DELETE FROM msg_queues WHERE recipient_id = ?" (Only $ Binary $ unEntityId $ recipientId sq) + +insertQueueDB :: DB.Connection -> RecipientId -> QueueRec -> IO () +insertQueueDB db rId QueueRec {recipientKey, rcvDhSecret, senderId, senderKey, sndSecure, notifier, status, updatedAt} = do + DB.execute db insertQueueQuery (rId, recipientKey, rcvDhSecret, senderId, senderKey, sndSecure, status, updatedAt) + forM_ notifier $ \NtfCreds {notifierId, notifierKey, rcvNtfDhSecret} -> + DB.execute db insertNotifierQuery (rId, notifierId, notifierKey, rcvNtfDhSecret) + +batchInsertQueues :: StoreQueueClass q => Bool -> M.Map RecipientId q -> PostgresQueueStore q' -> IO (Int64, Int64) +batchInsertQueues tty queues toStore = do + qs <- catMaybes <$> mapM (\(rId, q) -> (rId,) <$$> readTVarIO (queueRec q)) (M.assocs queues) + putStrLn $ "Importing " <> show (length qs) <> " queues..." + let st = dbStore toStore + (ns, count) <- foldM (processChunk st) ((0, 0), 0) $ toChunks 1000000 qs + putStrLn $ progress count + pure ns + where + processChunk st ((qCnt, nCnt), i) qs = do + qCnt' <- withConnection st $ \db -> PSQL.executeMany db insertQueueQuery $ map toQueueRow qs + nCnt' <- withConnection st $ \db -> PSQL.executeMany db insertNotifierQuery $ mapMaybe toNotifierRow qs + let i' = i + length qs + when tty $ putStr (progress i' <> "\r") >> hFlush stdout + pure ((qCnt + qCnt', nCnt + nCnt'), i') + progress i = "Imported: " <> show i <> " queues" + toQueueRow (rId, QueueRec {recipientKey, rcvDhSecret, senderId, senderKey, sndSecure, status, updatedAt}) = + (rId, recipientKey, rcvDhSecret, senderId, senderKey, sndSecure, status, updatedAt) + toNotifierRow (rId, QueueRec {notifier}) = + (\NtfCreds {notifierId, notifierKey, rcvNtfDhSecret} -> (rId, notifierId, notifierKey, rcvNtfDhSecret)) <$> notifier + toChunks :: Int -> [a] -> [[a]] + toChunks _ [] = [] + toChunks n xs = + let (ys, xs') = splitAt n xs + in ys : toChunks n xs' + +insertQueueQuery :: Query +insertQueueQuery = + [sql| + INSERT INTO msg_queues + (recipient_id, recipient_key, rcv_dh_secret, sender_id, sender_key, snd_secure, status, updated_at) + VALUES (?,?,?,?,?,?,?,?) + |] + +insertNotifierQuery :: Query +insertNotifierQuery = + [sql| + INSERT INTO msg_notifiers (recipient_id, notifier_id, notifier_key, rcv_ntf_dh_secret) + VALUES (?, ?, ?, ?) + |] + +foldQueueRecs :: Monoid a => Bool -> PostgresQueueStore q -> (RecipientId -> QueueRec -> IO a) -> IO a +foldQueueRecs tty st f = do + fmap snd $ withConnection (dbStore st) $ \db -> + PSQL.fold_ db queueRecQuery (0 :: Int, mempty) $ \(!i, !acc) row -> do + r <- uncurry f (rowToQueueRec row) + let i' = i + 1 + when (tty && i' `mod` 100000 == 0) $ putStr ("Processed: " <> show i <> " records\r") >> hFlush stdout + pure (i', acc <> r) + +queueRecQuery :: Query +queueRecQuery = + [sql| + SELECT q.recipient_id, q.recipient_key, q.rcv_dh_secret, q.sender_id, q.sender_key, q.snd_secure, q.status, q.updated_at, + n.notifier_id, n.notifier_key, n.rcv_ntf_dh_secret + FROM msg_queues q + LEFT JOIN msg_notifiers n ON q.recipient_id = n.recipient_id + |] + +rowToQueueRec :: ( (RecipientId, RcvPublicAuthKey, RcvDhSecret, SenderId, Maybe SndPublicAuthKey, SenderCanSecure, ServerEntityStatus, Maybe RoundedSystemTime) + :. (Maybe NotifierId, Maybe NtfPublicAuthKey, Maybe RcvNtfDhSecret) + ) -> (RecipientId, QueueRec) +rowToQueueRec ((rId, recipientKey, rcvDhSecret, senderId, senderKey, sndSecure, status, updatedAt) :. (notifierId_, notifierKey_, rcvNtfDhSecret_)) = + let notifier = NtfCreds <$> notifierId_ <*> notifierKey_ <*> rcvNtfDhSecret_ + in (rId, QueueRec {recipientKey, rcvDhSecret, senderId, senderKey, sndSecure, notifier, status, updatedAt}) + +setStatusDB :: String -> PostgresQueueStore q -> RecipientId -> ServerEntityStatus -> IO (Either ErrorType ()) +setStatusDB name st rId status = + withDB' name st $ \db -> + DB.execute db "UPDATE msg_queues SET status = ? WHERE recipient_id = ?" (status, rId) + +withDB' :: String -> PostgresQueueStore q -> (DB.Connection -> IO a) -> IO (Either ErrorType a) +withDB' name st' action = withDB name st' $ fmap Right . action + +-- TODO [postgres] possibly, use with connection if queries in addQueue_ are combined +withDB :: forall a q. String -> PostgresQueueStore q -> (DB.Connection -> IO (Either ErrorType a)) -> IO (Either ErrorType a) +withDB name st' action = + E.try (withTransaction (dbStore st') action) >>= either logErr pure + where + logErr :: E.SomeException -> IO (Either ErrorType a) + logErr e = logError ("STORE: " <> T.pack err) $> Left (STORE err) + where + err = name <> ", withLog, " <> show e + +handleDuplicate :: SqlError -> IO ErrorType +handleDuplicate e = case constraintViolation e of + Just (UniqueViolation _) -> pure AUTH + _ -> E.throwIO e + +-- The orphan instances below are copy-pasted, but here they are defined specifically for PostgreSQL + +instance ToField EntityId where toField (EntityId s) = toField $ Binary s + +deriving newtype instance FromField EntityId + +instance ToField (C.DhSecret 'C.X25519) where toField = toField . Binary . C.dhBytes' + +instance FromField (C.DhSecret 'C.X25519) where fromField = blobFieldDecoder strDecode + +instance ToField C.APublicAuthKey where toField = toField . Binary . C.encodePubKey + +instance FromField C.APublicAuthKey where fromField = blobFieldDecoder C.decodePubKey diff --git a/src/Simplex/Messaging/Server/QueueStore/Postgres/Migrations.hs b/src/Simplex/Messaging/Server/QueueStore/Postgres/Migrations.hs new file mode 100644 index 000000000..98027b5b6 --- /dev/null +++ b/src/Simplex/Messaging/Server/QueueStore/Postgres/Migrations.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE QuasiQuotes #-} + +module Simplex.Messaging.Server.QueueStore.Postgres.Migrations where + +import Data.List (sortOn) +import Data.Text (Text) +import qualified Data.Text as T +import Simplex.Messaging.Agent.Store.Shared +import Text.RawString.QQ (r) + +serverSchemaMigrations :: [(String, Text, Maybe Text)] +serverSchemaMigrations = + [ ("20250207_initial", m20250207_initial, Nothing) + ] + +-- | The list of migrations in ascending order by date +serverMigrations :: [Migration] +serverMigrations = sortOn name $ map migration serverSchemaMigrations + where + migration (name, up, down) = Migration {name, up, down = down} + +m20250207_initial :: Text +m20250207_initial = + T.pack + [r| +CREATE TABLE msg_queues( + recipient_id BYTEA NOT NULL, + recipient_key BYTEA NOT NULL, + rcv_dh_secret BYTEA NOT NULL, + sender_id BYTEA NOT NULL, + sender_key BYTEA, + snd_secure BOOLEAN NOT NULL, + status TEXT NOT NULL, + updated_at BIGINT, + PRIMARY KEY (recipient_id) +); + +CREATE TABLE msg_notifiers( + notifier_id BYTEA NOT NULL, + recipient_id BYTEA NOT NULL REFERENCES msg_queues(recipient_id) ON DELETE CASCADE ON UPDATE RESTRICT, + notifier_key BYTEA NOT NULL, + rcv_ntf_dh_secret BYTEA NOT NULL, + PRIMARY KEY (notifier_id) +); + +CREATE UNIQUE INDEX idx_msg_queues_sender_id ON msg_queues(sender_id); +CREATE UNIQUE INDEX idx_msg_notifiers_recipient_id ON msg_notifiers(recipient_id); + |] diff --git a/src/Simplex/Messaging/Server/QueueStore/STM.hs b/src/Simplex/Messaging/Server/QueueStore/STM.hs index 2fd3e9912..bebadf7c5 100644 --- a/src/Simplex/Messaging/Server/QueueStore/STM.hs +++ b/src/Simplex/Messaging/Server/QueueStore/STM.hs @@ -3,7 +3,7 @@ {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE InstanceSigs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} @@ -11,177 +11,186 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} module Simplex.Messaging.Server.QueueStore.STM - ( addQueue, - getQueue, - getQueueRec, - secureQueue, - addQueueNotifier, - deleteQueueNotifier, - suspendQueue, - blockQueue, - unblockQueue, - updateQueueTime, - deleteQueue', - newQueueStore, - readQueueStore, + ( STMQueueStore (..), + setStoreLog, withLog', + withQueueRec, + readQueueRecIO, + setStatus, ) where import qualified Control.Exception as E import Control.Logger.Simple import Control.Monad -import Control.Monad.IO.Class -import Control.Monad.Trans.Except import Data.Bitraversable (bimapM) -import qualified Data.ByteString.Char8 as B import Data.Functor (($>)) +import qualified Data.Map.Strict as M import qualified Data.Text as T -import Data.Text.Encoding (decodeLatin1) -import Simplex.Messaging.Encoding.String import Simplex.Messaging.Protocol -import Simplex.Messaging.Server.MsgStore.Types import Simplex.Messaging.Server.QueueStore +import Simplex.Messaging.Server.QueueStore.Types import Simplex.Messaging.Server.StoreLog +import Simplex.Messaging.TMap (TMap) import qualified Simplex.Messaging.TMap as TM -import Simplex.Messaging.Util (ifM, safeDecodeUtf8, tshow, ($>>=), (<$$)) -import System.Exit (exitFailure) +import Simplex.Messaging.Util (anyM, ifM, ($>>), ($>>=), (<$$)) import System.IO import UnliftIO.STM -newQueueStore :: IO (STMQueueStore q) -newQueueStore = do - queues <- TM.emptyIO - senders <- TM.emptyIO - notifiers <- TM.emptyIO - storeLog <- newTVarIO Nothing - pure STMQueueStore {queues, senders, notifiers, storeLog} +data STMQueueStore q = STMQueueStore + { queues :: TMap RecipientId q, + senders :: TMap SenderId RecipientId, + notifiers :: TMap NotifierId RecipientId, + storeLog :: TVar (Maybe (StoreLog 'WriteMode)) + } -addQueue :: STMStoreClass s => s -> RecipientId -> QueueRec -> IO (Either ErrorType (StoreQueue s)) -addQueue st rId qr@QueueRec {senderId = sId, notifier}= - atomically add - $>>= \q -> q <$$ withLog "addQueue" st (\s -> logCreateQueue s rId qr) - where - STMQueueStore {queues, senders, notifiers} = stmQueueStore st - add = ifM hasId (pure $ Left DUPLICATE_) $ do - q <- mkQueue st rId qr - TM.insert rId q queues - TM.insert sId rId senders - forM_ notifier $ \NtfCreds {notifierId} -> TM.insert notifierId rId notifiers - pure $ Right q - hasId = or <$> sequence [TM.member rId queues, TM.member sId senders, hasNotifier] - hasNotifier = maybe (pure False) (\NtfCreds {notifierId} -> TM.member notifierId notifiers) notifier +setStoreLog :: STMQueueStore q -> StoreLog 'WriteMode -> IO () +setStoreLog st sl = atomically $ writeTVar (storeLog st) (Just sl) -getQueue :: (STMStoreClass s, DirectParty p) => s -> SParty p -> QueueId -> IO (Either ErrorType (StoreQueue s)) -getQueue st party qId = - maybe (Left AUTH) Right <$> case party of - SRecipient -> TM.lookupIO qId queues - SSender -> TM.lookupIO qId senders $>>= (`TM.lookupIO` queues) - SNotifier -> TM.lookupIO qId notifiers $>>= (`TM.lookupIO` queues) - where - STMQueueStore {queues, senders, notifiers} = stmQueueStore st +instance StoreQueueClass q => QueueStoreClass q (STMQueueStore q) where + type QueueStoreCfg (STMQueueStore q) = () -getQueueRec :: (STMStoreClass s, DirectParty p) => s -> SParty p -> QueueId -> IO (Either ErrorType (StoreQueue s, QueueRec)) -getQueueRec st party qId = - getQueue st party qId - $>>= (\q -> maybe (Left AUTH) (Right . (q,)) <$> readTVarIO (queueRec' q)) + newQueueStore :: () -> IO (STMQueueStore q) + newQueueStore _ = do + queues <- TM.emptyIO + senders <- TM.emptyIO + notifiers <- TM.emptyIO + storeLog <- newTVarIO Nothing + pure STMQueueStore {queues, senders, notifiers, storeLog} -secureQueue :: STMStoreClass s => s -> StoreQueue s -> SndPublicAuthKey -> IO (Either ErrorType ()) -secureQueue st sq sKey = - atomically (readQueueRec qr $>>= secure) - $>>= \_ -> withLog "secureQueue" st $ \s -> logSecureQueue s (recipientId' sq) sKey - where - qr = queueRec' sq - secure q = case senderKey q of - Just k -> pure $ if sKey == k then Right () else Left AUTH - Nothing -> do - writeTVar qr $ Just q {senderKey = Just sKey} - pure $ Right () + loadedQueues = queues + {-# INLINE loadedQueues #-} + -- foldAllQueues = withLoadedQueues + -- {-# INLINE foldAllQueues #-} -addQueueNotifier :: STMStoreClass s => s -> StoreQueue s -> NtfCreds -> IO (Either ErrorType (Maybe NotifierId)) -addQueueNotifier st sq ntfCreds@NtfCreds {notifierId = nId} = - atomically (readQueueRec qr $>>= add) - $>>= \nId_ -> nId_ <$$ withLog "addQueueNotifier" st (\s -> logAddNotifier s rId ntfCreds) - where - rId = recipientId' sq - qr = queueRec' sq - STMQueueStore {notifiers} = stmQueueStore st - add q = ifM (TM.member nId notifiers) (pure $ Left DUPLICATE_) $ do - nId_ <- forM (notifier q) $ \NtfCreds {notifierId} -> TM.delete notifierId notifiers $> notifierId - let !q' = q {notifier = Just ntfCreds} - writeTVar qr $ Just q' - TM.insert nId rId notifiers - pure $ Right nId_ + queueCounts :: STMQueueStore q -> IO QueueCounts + queueCounts st = do + queueCount <- M.size <$> readTVarIO (queues st) + notifierCount <- M.size <$> readTVarIO (notifiers st) + pure QueueCounts {queueCount, notifierCount} -deleteQueueNotifier :: STMStoreClass s => s -> StoreQueue s -> IO (Either ErrorType (Maybe NotifierId)) -deleteQueueNotifier st sq = - atomically (readQueueRec qr >>= mapM delete) - $>>= \nId_ -> nId_ <$$ withLog "deleteQueueNotifier" st (`logDeleteNotifier` recipientId' sq) - where - qr = queueRec' sq - delete q = forM (notifier q) $ \NtfCreds {notifierId} -> do - TM.delete notifierId $ notifiers $ stmQueueStore st - writeTVar qr $! Just q {notifier = Nothing} - pure notifierId + addQueue_ :: STMQueueStore q -> (RecipientId -> QueueRec -> IO q) -> RecipientId -> QueueRec -> IO (Either ErrorType q) + addQueue_ st mkQ rId qr@QueueRec {senderId = sId, notifier} = do + sq <- mkQ rId qr + add sq $>> withLog "addStoreQueue" st (\s -> logCreateQueue s rId qr) $> Right sq + where + STMQueueStore {queues, senders, notifiers} = st + add q = atomically $ ifM hasId (pure $ Left DUPLICATE_) $ Right () <$ do + TM.insert rId q queues + TM.insert sId rId senders + forM_ notifier $ \NtfCreds {notifierId} -> TM.insert notifierId rId notifiers + hasId = anyM [TM.member rId queues, TM.member sId senders, hasNotifier] + hasNotifier = maybe (pure False) (\NtfCreds {notifierId} -> TM.member notifierId notifiers) notifier -suspendQueue :: STMStoreClass s => s -> StoreQueue s -> IO (Either ErrorType ()) -suspendQueue st sq = - atomically (readQueueRec qr >>= mapM suspend) - $>>= \_ -> withLog "suspendQueue" st (`logSuspendQueue` recipientId' sq) - where - qr = queueRec' sq - suspend q = writeTVar qr $! Just q {status = EntityOff} + getQueue_ :: DirectParty 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 + SSender -> TM.lookupIO qId senders $>>= (`TM.lookupIO` queues) + SNotifier -> TM.lookupIO qId notifiers $>>= (`TM.lookupIO` queues) + where + STMQueueStore {queues, senders, notifiers} = st -blockQueue :: STMStoreClass s => s -> StoreQueue s -> BlockingInfo -> IO (Either ErrorType ()) -blockQueue st sq info = - atomically (readQueueRec qr >>= mapM block) - $>>= \_ -> withLog "blockQueue" st (\sl -> logBlockQueue sl (recipientId' sq) info) - where - qr = queueRec' sq - block q = writeTVar qr $ Just q {status = EntityBlocked info} + secureQueue :: STMQueueStore q -> q -> SndPublicAuthKey -> IO (Either ErrorType ()) + secureQueue st sq sKey = + atomically (readQueueRec qr $>>= secure) + $>> withLog "secureQueue" st (\s -> logSecureQueue s (recipientId sq) sKey) + where + qr = queueRec sq + secure q = case senderKey q of + Just k -> pure $ if sKey == k then Right () else Left AUTH + Nothing -> do + writeTVar qr $ Just q {senderKey = Just sKey} + pure $ Right () -unblockQueue :: STMStoreClass s => s -> StoreQueue s -> IO (Either ErrorType ()) -unblockQueue st sq = - atomically (readQueueRec qr >>= mapM unblock) - $>>= \_ -> withLog "unblockQueue" st (`logUnblockQueue` recipientId' sq) - where - qr = queueRec' sq - unblock q = writeTVar qr $ Just q {status = EntityActive} + addQueueNotifier :: STMQueueStore q -> q -> NtfCreds -> IO (Either ErrorType (Maybe NotifierId)) + addQueueNotifier st sq ntfCreds@NtfCreds {notifierId = nId} = + atomically (readQueueRec qr $>>= add) + $>>= \nId_ -> nId_ <$$ withLog "addQueueNotifier" st (\s -> logAddNotifier s rId ntfCreds) + where + rId = recipientId sq + qr = queueRec sq + STMQueueStore {notifiers} = st + add q = ifM (TM.member nId notifiers) (pure $ Left DUPLICATE_) $ do + nId_ <- forM (notifier q) $ \NtfCreds {notifierId} -> TM.delete notifierId notifiers $> notifierId + let !q' = q {notifier = Just ntfCreds} + writeTVar qr $ Just q' + TM.insert nId rId notifiers + pure $ Right nId_ -updateQueueTime :: STMStoreClass s => s -> StoreQueue s -> RoundedSystemTime -> IO (Either ErrorType QueueRec) -updateQueueTime st sq t = atomically (readQueueRec qr >>= mapM update) $>>= log' - where - qr = queueRec' sq - update q@QueueRec {updatedAt} - | updatedAt == Just t = pure (q, False) - | otherwise = - let !q' = q {updatedAt = Just t} - in (writeTVar qr $! Just q') $> (q', True) - log' (q, changed) - | changed = q <$$ withLog "updateQueueTime" st (\sl -> logUpdateQueueTime sl (recipientId' sq) t) - | otherwise = pure $ Right q + deleteQueueNotifier :: STMQueueStore q -> q -> IO (Either ErrorType (Maybe NotifierId)) + deleteQueueNotifier st sq = + withQueueRec qr delete + $>>= \nId_ -> nId_ <$$ withLog "deleteQueueNotifier" st (`logDeleteNotifier` recipientId sq) + where + qr = queueRec sq + delete q = forM (notifier q) $ \NtfCreds {notifierId} -> do + TM.delete notifierId $ notifiers st + writeTVar qr $ Just q {notifier = Nothing} + pure notifierId -deleteQueue' :: STMStoreClass s => s -> StoreQueue s -> IO (Either ErrorType (QueueRec, Maybe (MsgQueue s))) -deleteQueue' st sq = - atomically (readQueueRec qr >>= mapM delete) - $>>= \q -> withLog "deleteQueue" st (`logDeleteQueue` recipientId' sq) - >>= bimapM pure (\_ -> (q,) <$> atomically (swapTVar (msgQueue_' sq) Nothing)) - where - qr = queueRec' sq - STMQueueStore {senders, notifiers} = stmQueueStore st - delete q = do - writeTVar qr Nothing - TM.delete (senderId q) senders - forM_ (notifier q) $ \NtfCreds {notifierId} -> TM.delete notifierId notifiers - pure q + suspendQueue :: STMQueueStore q -> q -> IO (Either ErrorType ()) + suspendQueue st sq = + setStatus (queueRec sq) EntityOff + $>> withLog "suspendQueue" st (`logSuspendQueue` recipientId sq) + + blockQueue :: STMQueueStore q -> q -> BlockingInfo -> IO (Either ErrorType ()) + blockQueue st sq info = + setStatus (queueRec sq) (EntityBlocked info) + $>> withLog "blockQueue" st (\sl -> logBlockQueue sl (recipientId sq) info) + + unblockQueue :: STMQueueStore q -> q -> IO (Either ErrorType ()) + unblockQueue st sq = + setStatus (queueRec sq) EntityActive + $>> withLog "unblockQueue" st (`logUnblockQueue` recipientId sq) + + updateQueueTime :: STMQueueStore q -> q -> RoundedSystemTime -> IO (Either ErrorType QueueRec) + updateQueueTime st sq t = withQueueRec qr update $>>= log' + where + qr = queueRec sq + update q@QueueRec {updatedAt} + | updatedAt == Just t = pure (q, False) + | otherwise = + let !q' = q {updatedAt = Just t} + in writeTVar qr (Just q') $> (q', True) + log' (q, changed) + | changed = q <$$ withLog "updateQueueTime" st (\sl -> logUpdateQueueTime sl (recipientId sq) t) + | otherwise = pure $ Right q + + deleteStoreQueue :: STMQueueStore q -> q -> IO (Either ErrorType (QueueRec, Maybe (MsgQueue q))) + deleteStoreQueue st sq = + withQueueRec qr delete + $>>= \q -> withLog "deleteStoreQueue" st (`logDeleteQueue` recipientId sq) + >>= mapM (\_ -> (q,) <$> atomically (swapTVar (msgQueue sq) Nothing)) + where + qr = queueRec sq + delete q = do + writeTVar qr Nothing + TM.delete (senderId q) $ senders st + forM_ (notifier q) $ \NtfCreds {notifierId} -> TM.delete notifierId $ notifiers st + pure q + +withQueueRec :: TVar (Maybe QueueRec) -> (QueueRec -> STM a) -> IO (Either ErrorType a) +withQueueRec qr a = atomically $ readQueueRec qr >>= mapM a + +setStatus :: TVar (Maybe QueueRec) -> ServerEntityStatus -> IO (Either ErrorType ()) +setStatus qr status = + atomically $ stateTVar qr $ \case + Just q -> (Right (), Just q {status}) + Nothing -> (Left AUTH, Nothing) readQueueRec :: TVar (Maybe QueueRec) -> STM (Either ErrorType QueueRec) readQueueRec qr = maybe (Left AUTH) Right <$> readTVar qr {-# INLINE readQueueRec #-} +readQueueRecIO :: TVar (Maybe QueueRec) -> IO (Either ErrorType QueueRec) +readQueueRecIO qr = maybe (Left AUTH) Right <$> readTVarIO qr +{-# INLINE readQueueRecIO #-} + withLog' :: String -> TVar (Maybe (StoreLog 'WriteMode)) -> (StoreLog 'WriteMode -> IO ()) -> IO (Either ErrorType ()) withLog' name sl action = readTVarIO sl @@ -192,41 +201,6 @@ withLog' name sl action = where err = name <> ", withLog, " <> show e -withLog :: STMStoreClass s => String -> s -> (StoreLog 'WriteMode -> IO ()) -> IO (Either ErrorType ()) -withLog name = withLog' name . storeLog . stmQueueStore - -readQueueStore :: forall s. STMStoreClass s => FilePath -> s -> IO () -readQueueStore f st = readLogLines False f processLine - where - processLine :: Bool -> B.ByteString -> IO () - processLine eof s = either printError procLogRecord (strDecode s) - where - procLogRecord :: StoreLogRecord -> IO () - procLogRecord = \case - CreateQueue rId q -> addQueue st rId q >>= qError rId "CreateQueue" - SecureQueue qId sKey -> withQueue qId "SecureQueue" $ \q -> secureQueue st q sKey - AddNotifier qId ntfCreds -> withQueue qId "AddNotifier" $ \q -> addQueueNotifier st q ntfCreds - SuspendQueue qId -> withQueue qId "SuspendQueue" $ suspendQueue st - BlockQueue qId info -> withQueue qId "BlockQueue" $ \q -> blockQueue st q info - UnblockQueue qId -> withQueue qId "UnblockQueue" $ unblockQueue st - DeleteQueue qId -> withQueue qId "DeleteQueue" $ deleteQueue st - DeleteNotifier qId -> withQueue qId "DeleteNotifier" $ deleteQueueNotifier st - UpdateTime qId t -> withQueue qId "UpdateTime" $ \q -> updateQueueTime st q t - printError :: String -> IO () - printError e - | eof = logWarn err - | otherwise = logError err >> exitFailure - where - err = "Error parsing log: " <> T.pack e <> " - " <> safeDecodeUtf8 s - withQueue :: forall a. RecipientId -> T.Text -> (StoreQueue s -> IO (Either ErrorType a)) -> IO () - withQueue qId op a = runExceptT go >>= qError qId op - where - go = do - q <- ExceptT $ getQueue st SRecipient qId - liftIO (readTVarIO $ queueRec' q) >>= \case - Nothing -> logWarn $ logPfx qId op <> "already deleted" - Just _ -> void $ ExceptT $ a q - qError qId op = \case - Left e -> logError $ logPfx qId op <> tshow e - Right _ -> pure () - logPfx qId op = "STORE: " <> op <> ", stored queue " <> decodeLatin1 (strEncode qId) <> ", " +withLog :: String -> STMQueueStore q -> (StoreLog 'WriteMode -> IO ()) -> IO (Either ErrorType ()) +withLog name = withLog' name . storeLog +{-# INLINE withLog #-} diff --git a/src/Simplex/Messaging/Server/QueueStore/Types.hs b/src/Simplex/Messaging/Server/QueueStore/Types.hs new file mode 100644 index 000000000..47283ac7c --- /dev/null +++ b/src/Simplex/Messaging/Server/QueueStore/Types.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeFamilyDependencies #-} + +module Simplex.Messaging.Server.QueueStore.Types where + +import Control.Concurrent.STM +import Control.Monad +import Simplex.Messaging.Protocol +import Simplex.Messaging.Server.QueueStore +import Simplex.Messaging.TMap (TMap) + +class StoreQueueClass q where + type MsgQueue q = mq | mq -> q + recipientId :: q -> RecipientId + queueRec :: q -> TVar (Maybe QueueRec) + msgQueue :: q -> TVar (Maybe (MsgQueue q)) + withQueueLock :: q -> String -> IO a -> IO a + +class StoreQueueClass q => QueueStoreClass q s where + type QueueStoreCfg s + newQueueStore :: QueueStoreCfg s -> IO s + queueCounts :: s -> IO QueueCounts + loadedQueues :: s -> TMap RecipientId q + -- foldAllQueues :: Monoid a => s -> (q -> IO a) -> IO a + addQueue_ :: s -> (RecipientId -> QueueRec -> IO q) -> RecipientId -> QueueRec -> IO (Either ErrorType q) + getQueue_ :: DirectParty p => s -> (RecipientId -> QueueRec -> IO q) -> SParty p -> QueueId -> IO (Either ErrorType q) + secureQueue :: s -> q -> SndPublicAuthKey -> IO (Either ErrorType ()) + addQueueNotifier :: s -> q -> NtfCreds -> IO (Either ErrorType (Maybe NotifierId)) + deleteQueueNotifier :: s -> q -> IO (Either ErrorType (Maybe NotifierId)) + suspendQueue :: s -> q -> IO (Either ErrorType ()) + blockQueue :: s -> q -> BlockingInfo -> IO (Either ErrorType ()) + unblockQueue :: s -> q -> IO (Either ErrorType ()) + updateQueueTime :: s -> q -> RoundedSystemTime -> IO (Either ErrorType QueueRec) + deleteStoreQueue :: s -> q -> IO (Either ErrorType (QueueRec, Maybe (MsgQueue q))) + +data QueueCounts = QueueCounts + { queueCount :: Int, + notifierCount :: Int + } + +withLoadedQueues :: (Monoid a, QueueStoreClass q s) => s -> (q -> IO a) -> IO a +withLoadedQueues st f = readTVarIO (loadedQueues st) >>= foldM run mempty + where + run !acc = fmap (acc <>) . f diff --git a/src/Simplex/Messaging/Server/StoreLog.hs b/src/Simplex/Messaging/Server/StoreLog.hs index 2d82014f7..c16b5a95e 100644 --- a/src/Simplex/Messaging/Server/StoreLog.hs +++ b/src/Simplex/Messaging/Server/StoreLog.hs @@ -27,31 +27,27 @@ module Simplex.Messaging.Server.StoreLog logDeleteNotifier, logUpdateQueueTime, readWriteStoreLog, - writeQueueStore, readLogLines, foldLogLines, ) where import Control.Applicative (optional, (<|>)) -import Control.Concurrent.STM import qualified Control.Exception as E import Control.Logger.Simple import Control.Monad (when) import qualified Data.Attoparsec.ByteString.Char8 as A import qualified Data.ByteString.Char8 as B import Data.Functor (($>)) -import qualified Data.Map.Strict as M import qualified Data.Text as T import Data.Time.Clock (getCurrentTime) import Data.Time.Format.ISO8601 (iso8601Show) import GHC.IO (catchAny) import Simplex.Messaging.Encoding.String import Simplex.Messaging.Protocol -import Simplex.Messaging.Server.MsgStore.Types +-- import Simplex.Messaging.Server.MsgStore.Types import Simplex.Messaging.Server.QueueStore import Simplex.Messaging.Server.StoreLog.Types -import qualified Simplex.Messaging.TMap as TM import Simplex.Messaging.Util (ifM, tshow, unlessM, whenM) import System.Directory (doesFileExist, renameFile) import System.IO @@ -249,15 +245,6 @@ readWriteStoreLog readStore writeStore f st = renameFile tempBackup timedBackup logInfo $ "original state preserved as " <> T.pack timedBackup -writeQueueStore :: STMStoreClass s => StoreLog 'WriteMode -> s -> IO () -writeQueueStore s st = readTVarIO qs >>= mapM_ writeQueue . M.assocs - where - qs = queues $ stmQueueStore st - writeQueue (rId, q) = - readTVarIO (queueRec' q) >>= \case - Just q' -> logCreateQueue s rId q' - Nothing -> atomically $ TM.delete rId qs - readLogLines :: Bool -> FilePath -> (Bool -> B.ByteString -> IO ()) -> IO () readLogLines tty f action = foldLogLines tty f (const action) () @@ -267,11 +254,11 @@ foldLogLines tty f action initValue = do putStrLn $ progress count pure acc where - loop h i acc = do + loop h !i !acc = do s <- B.hGetLine h eof <- hIsEOF h acc' <- action acc eof s let i' = i + 1 when (tty && i' `mod` 100000 == 0) $ putStr (progress i' <> "\r") >> hFlush stdout if eof then pure (i', acc') else loop h i' acc' - progress i = "Processed: " <> show i <> " lines" + progress i = "Processed: " <> show i <> " log lines" diff --git a/src/Simplex/Messaging/Server/StoreLog/ReadWrite.hs b/src/Simplex/Messaging/Server/StoreLog/ReadWrite.hs new file mode 100644 index 000000000..fd4da85ab --- /dev/null +++ b/src/Simplex/Messaging/Server/StoreLog/ReadWrite.hs @@ -0,0 +1,66 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Simplex.Messaging.Server.StoreLog.ReadWrite where + +import Control.Concurrent.STM +import Control.Logger.Simple +import Control.Monad +import Control.Monad.IO.Class +import Control.Monad.Trans.Except +import qualified Data.ByteString.Char8 as B +import qualified Data.Text as T +import Data.Text.Encoding (decodeLatin1) +import Simplex.Messaging.Encoding.String +import Simplex.Messaging.Protocol +import Simplex.Messaging.Server.QueueStore (QueueRec) +import Simplex.Messaging.Server.QueueStore.Types +import Simplex.Messaging.Server.StoreLog +import Simplex.Messaging.Util (tshow) +import System.IO + +writeQueueStore :: forall q s. QueueStoreClass q s => StoreLog 'WriteMode -> s -> IO () +writeQueueStore s st = withLoadedQueues st $ writeQueue + where + writeQueue :: q -> IO () + writeQueue q = do + let rId = recipientId q + readTVarIO (queueRec q) >>= \case + Just q' -> logCreateQueue s rId q' + Nothing -> pure () + +readQueueStore :: forall q s. QueueStoreClass q s => Bool -> (RecipientId -> QueueRec -> IO q) -> FilePath -> s -> IO () +readQueueStore tty mkQ f st = readLogLines tty f $ \_ -> processLine + where + processLine :: B.ByteString -> IO () + processLine s = either printError procLogRecord (strDecode s) + where + procLogRecord :: StoreLogRecord -> IO () + procLogRecord = \case + CreateQueue rId qr -> addQueue_ st mkQ rId qr >>= qError rId "CreateQueue" + SecureQueue qId sKey -> withQueue qId "SecureQueue" $ \q -> secureQueue st q sKey + AddNotifier qId ntfCreds -> withQueue qId "AddNotifier" $ \q -> addQueueNotifier st q ntfCreds + SuspendQueue qId -> withQueue qId "SuspendQueue" $ suspendQueue st + BlockQueue qId info -> withQueue qId "BlockQueue" $ \q -> blockQueue st q info + UnblockQueue qId -> withQueue qId "UnblockQueue" $ unblockQueue st + DeleteQueue qId -> withQueue qId "DeleteQueue" $ deleteStoreQueue st + DeleteNotifier qId -> withQueue qId "DeleteNotifier" $ deleteQueueNotifier st + UpdateTime qId t -> withQueue qId "UpdateTime" $ \q -> updateQueueTime st q t + 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 = runExceptT go >>= qError qId op + where + go = do + q <- ExceptT $ getQueue_ st mkQ SRecipient qId + liftIO (readTVarIO $ queueRec q) >>= \case + Nothing -> logWarn $ logPfx qId op <> "already deleted" + Just _ -> void $ ExceptT $ a q + qError qId op = \case + Left e -> logError $ logPfx qId op <> tshow e + Right _ -> pure () + logPfx qId op = "STORE: " <> op <> ", stored queue " <> decodeLatin1 (strEncode qId) <> ", " diff --git a/src/Simplex/Messaging/Util.hs b/src/Simplex/Messaging/Util.hs index 1fdc33577..240a6ba5a 100644 --- a/src/Simplex/Messaging/Util.hs +++ b/src/Simplex/Messaging/Util.hs @@ -12,7 +12,7 @@ import Control.Monad.Trans.Except import Control.Monad.Trans.State.Strict (StateT (..)) import Data.Aeson (FromJSON, ToJSON) import qualified Data.Aeson as J -import Data.Bifunctor (first) +import Data.Bifunctor (first, second) import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Lazy.Char8 as LB @@ -21,6 +21,7 @@ import Data.Int (Int64) import Data.List (groupBy, sortOn) import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.List.NonEmpty as L +import Data.Maybe (listToMaybe) import Data.Map.Strict (Map) import qualified Data.Map.Strict as M import Data.Text (Text) @@ -88,8 +89,19 @@ unlessM :: Monad m => m Bool -> m () -> m () unlessM b = ifM b $ pure () {-# INLINE unlessM #-} +anyM :: Monad m => [m Bool] -> m Bool +anyM = foldM (\r a -> if r then pure r else (r ||) <$!> a) False +{-# INLINE anyM #-} + +infixl 1 $>>, $>>= + ($>>=) :: (Monad m, Monad f, Traversable f) => m (f a) -> (a -> m (f b)) -> m (f b) f $>>= g = f >>= fmap join . mapM g +{-# INLINE ($>>=) #-} + +($>>) :: (Monad m, Monad f, Traversable f) => m (f a) -> m (f b) -> m (f b) +f $>> g = f $>>= \_ -> g +{-# INLINE ($>>) #-} mapME :: (Monad m, Traversable t) => (a -> m (Either e b)) -> t (Either e a) -> m (t (Either e b)) mapME f = mapM (bindRight f) @@ -180,6 +192,19 @@ eitherToMaybe :: Either a b -> Maybe b eitherToMaybe = either (const Nothing) Just {-# INLINE eitherToMaybe #-} +listToEither :: e -> [a] -> Either e a +listToEither _ (x : _) = Right x +listToEither e _ = Left e + +firstRow :: (a -> b) -> e -> IO [a] -> IO (Either e b) +firstRow f e a = second f . listToEither e <$> a + +maybeFirstRow :: Functor f => (a -> b) -> f [a] -> f (Maybe b) +maybeFirstRow f q = fmap f . listToMaybe <$> q + +firstRow' :: (a -> Either e b) -> e -> IO [a] -> IO (Either e b) +firstRow' f e a = (f <=< listToEither e) <$> a + groupOn :: Eq k => (a -> k) -> [a] -> [[a]] groupOn = groupBy . eqOn where diff --git a/tests/AgentTests/FunctionalAPITests.hs b/tests/AgentTests/FunctionalAPITests.hs index 027b4cff3..97ced934e 100644 --- a/tests/AgentTests/FunctionalAPITests.hs +++ b/tests/AgentTests/FunctionalAPITests.hs @@ -77,7 +77,7 @@ import Data.Type.Equality (testEquality, (:~:) (Refl)) import Data.Word (Word16) import GHC.Stack (withFrozenCallStack) import SMPAgentClient -import SMPClient (cfg, prevRange, prevVersion, testPort, testPort2, testStoreLogFile2, testStoreMsgsDir2, withSmpServer, withSmpServerConfigOn, withSmpServerProxy, withSmpServerStoreLogOn, withSmpServerStoreMsgLogOn) +import SMPClient (cfg, cfgJ2, prevRange, prevVersion, testPort, testPort2, testStoreLogFile, withSmpServer, withSmpServerConfigOn, withSmpServerProxy, withSmpServerStoreLogOn, withSmpServerStoreMsgLogOn) import Simplex.Messaging.Agent hiding (createConnection, joinConnection, sendMessage) import qualified Simplex.Messaging.Agent as A import Simplex.Messaging.Agent.Client (ProtocolTestFailure (..), ProtocolTestStep (..), ServerQueueInfo (..), UserNetworkInfo (..), UserNetworkType (..), waitForUserNetwork) @@ -96,9 +96,9 @@ import Simplex.Messaging.Encoding.String import Simplex.Messaging.Notifications.Transport (NTFVersion, pattern VersionNTF) import Simplex.Messaging.Protocol (BasicAuth, ErrorType (..), MsgBody, ProtocolServer (..), SubscriptionMode (..), supportedSMPClientVRange) import qualified Simplex.Messaging.Protocol as SMP -import Simplex.Messaging.Server.Env.STM (ServerConfig (..)) +import Simplex.Messaging.Server.Env.STM (AServerStoreCfg (..), ServerConfig (..), ServerStoreCfg (..), StorePaths (..)) import Simplex.Messaging.Server.Expiration -import Simplex.Messaging.Server.MsgStore.Types (AMSType (..), SMSType (..)) +import Simplex.Messaging.Server.MsgStore.Types (SMSType (..), SQSType (..)) import Simplex.Messaging.Server.QueueStore.QueueInfo import Simplex.Messaging.Transport (ATransport (..), SMPVersion, VersionSMP, authCmdsSMPVersion, currentServerSMPRelayVersion, minClientSMPRelayVersion, minServerSMPRelayVersion, sndAuthKeySMPVersion, supportedSMPHandshakes) import Simplex.Messaging.Util (bshow, diffToMicroseconds) @@ -530,7 +530,7 @@ testRatchetMatrix2 t runTest = do testServerMatrix2 :: HasCallStack => ATransport -> (InitialAgentServers -> IO ()) -> Spec testServerMatrix2 t runTest = do it "1 server" $ withSmpServer t $ runTest initAgentServers - it "2 servers" $ withSmpServer t $ withSmpServerConfigOn t cfg {storeLogFile = Just testStoreLogFile2, storeMsgsFile = Just testStoreMsgsDir2} testPort2 $ \_ -> runTest initAgentServers2 + it "2 servers" $ withSmpServer t $ withSmpServerConfigOn t cfgJ2 testPort2 $ \_ -> runTest initAgentServers2 testPQMatrix2 :: HasCallStack => ATransport -> (HasCallStack => (AgentClient, InitialKeys) -> (AgentClient, PQSupport) -> AgentMsgId -> IO ()) -> Spec testPQMatrix2 = pqMatrix2_ True @@ -1041,7 +1041,7 @@ testAllowConnectionClientRestart t = do bob <- getSMPAgentClient' 2 agentCfg initAgentServersSrv2 testDB2 withSmpServerStoreLogOn t testPort $ \_ -> do (aliceId, bobId, confId) <- - withSmpServerConfigOn t cfg {storeLogFile = Just testStoreLogFile2, storeMsgsFile = Just testStoreMsgsDir2} testPort2 $ \_ -> do + withSmpServerConfigOn t cfgJ2 testPort2 $ \_ -> do runRight $ do (bobId, qInfo) <- createConnection alice 1 True SCMInvitation Nothing SMSubscribe (aliceId, sqSecured) <- joinConnection bob 1 True qInfo "bob's connInfo" SMSubscribe @@ -1063,7 +1063,7 @@ testAllowConnectionClientRestart t = do alice2 <- getSMPAgentClient' 3 agentCfg initAgentServers testDB runRight_ $ subscribeConnection alice2 bobId threadDelay 500000 - withSmpServerConfigOn t cfg {storeLogFile = Just testStoreLogFile2, storeMsgsFile = Just testStoreMsgsDir2} testPort2 $ \_ -> do + withSmpServerConfigOn t cfgJ2 testPort2 $ \_ -> do runRight $ do ("", "", UP _ _) <- nGet bob get alice2 ##> ("", bobId, CON) @@ -1326,7 +1326,7 @@ testSkippedMessages t = do disposeAgentClient alice2 disposeAgentClient bob2 where - cfg' = cfg {msgStoreType = AMSType SMSMemory, storeMsgsFile = Nothing} + cfg' = cfg {serverStoreCfg = ASSCfg SQSMemory SMSMemory $ SSCMemory $ Just $ StorePaths testStoreLogFile Nothing} testDeliveryAfterSubscriptionError :: HasCallStack => ATransport -> IO () testDeliveryAfterSubscriptionError t = do @@ -1945,7 +1945,7 @@ testBatchedSubscriptions nCreate nDel t = runServers :: ExceptT AgentErrorType IO a -> IO a runServers a = do withSmpServerStoreLogOn t testPort $ \t1 -> do - res <- withSmpServerConfigOn t cfg {storeLogFile = Just testStoreLogFile2, storeMsgsFile = Just testStoreMsgsDir2} testPort2 $ \t2 -> + res <- withSmpServerConfigOn t cfgJ2 testPort2 $ \t2 -> runRight a `finally` killThread t2 killThread t1 pure res @@ -2371,7 +2371,7 @@ testJoinConnectionAsyncReplyErrorV8 t = do ConnectionStats {rcvQueuesInfo = [], sndQueuesInfo = [SndQueueInfo {}]} <- getConnectionServers b aId pure (aId, bId) nGet a =##> \case ("", "", DOWN _ [c]) -> c == bId; _ -> False - withSmpServerConfigOn t cfg {storeLogFile = Just testStoreLogFile2, storeMsgsFile = Just testStoreMsgsDir2} testPort2 $ \_ -> do + withSmpServerConfigOn t cfgJ2 testPort2 $ \_ -> do get b =##> \case ("2", c, JOINED sqSecured) -> c == aId && not sqSecured; _ -> False confId <- withSmpServerStoreLogOn t testPort $ \_ -> do pGet a >>= \case @@ -2410,7 +2410,7 @@ testJoinConnectionAsyncReplyError t = do ConnectionStats {rcvQueuesInfo = [], sndQueuesInfo = [SndQueueInfo {}]} <- getConnectionServers b aId pure (aId, bId) nGet a =##> \case ("", "", DOWN _ [c]) -> c == bId; _ -> False - withSmpServerConfigOn t cfg {storeLogFile = Just testStoreLogFile2, storeMsgsFile = Just testStoreMsgsDir2} testPort2 $ \_ -> do + withSmpServerConfigOn t cfgJ2 testPort2 $ \_ -> do confId <- withSmpServerStoreLogOn t 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 diff --git a/tests/AgentTests/NotificationTests.hs b/tests/AgentTests/NotificationTests.hs index cbca52df1..1fb2e83cb 100644 --- a/tests/AgentTests/NotificationTests.hs +++ b/tests/AgentTests/NotificationTests.hs @@ -59,7 +59,7 @@ import Data.Text.Encoding (encodeUtf8) import qualified Data.Text.IO as TIO import NtfClient import SMPAgentClient (agentCfg, initAgentServers, initAgentServers2, testDB, testDB2, testNtfServer, testNtfServer2) -import SMPClient (cfg, cfgVPrev, testPort, testPort2, testStoreLogFile2, testStoreMsgsDir2, withSmpServer, withSmpServerConfigOn, withSmpServerStoreLogOn, withSmpServerStoreMsgLogOn, xit'') +import SMPClient (cfg, cfgJ2, cfgVPrev, testPort, testPort2, withSmpServer, withSmpServerConfigOn, withSmpServerStoreLogOn, withSmpServerStoreMsgLogOn, xit'') import Simplex.Messaging.Agent hiding (createConnection, joinConnection, sendMessage) import Simplex.Messaging.Agent.Client (ProtocolTestFailure (..), ProtocolTestStep (..), withStore') import Simplex.Messaging.Agent.Env.SQLite (AgentConfig, Env (..), InitialAgentServers) @@ -852,7 +852,7 @@ testNotificationsSMPRestartBatch n t apns = runServers :: ExceptT AgentErrorType IO a -> IO a runServers a = do withSmpServerStoreLogOn t testPort $ \t1 -> do - res <- withSmpServerConfigOn t (cfg :: ServerConfig) {storeLogFile = Just testStoreLogFile2, storeMsgsFile = Just testStoreMsgsDir2} testPort2 $ \t2 -> + res <- withSmpServerConfigOn t cfgJ2 testPort2 $ \t2 -> runRight a `finally` killThread t2 killThread t1 pure res diff --git a/tests/CoreTests/MsgStoreTests.hs b/tests/CoreTests/MsgStoreTests.hs index 3484fceb4..ccd8ea66d 100644 --- a/tests/CoreTests/MsgStoreTests.hs +++ b/tests/CoreTests/MsgStoreTests.hs @@ -39,7 +39,7 @@ import Simplex.Messaging.Server.MsgStore.Journal import Simplex.Messaging.Server.MsgStore.STM import Simplex.Messaging.Server.MsgStore.Types import Simplex.Messaging.Server.QueueStore -import Simplex.Messaging.Server.QueueStore.STM +import Simplex.Messaging.Server.QueueStore.Types import Simplex.Messaging.Server.StoreLog (closeStoreLog, logCreateQueue) import SMPClient (testStoreLogFile, testStoreMsgsDir, testStoreMsgsDir2, testStoreMsgsFile, testStoreMsgsFile2) import System.Directory (copyFile, createDirectoryIfMissing, listDirectory, removeFile, renameFile) @@ -50,7 +50,7 @@ import Test.Hspec msgStoreTests :: Spec msgStoreTests = do around (withMsgStore testSMTStoreConfig) $ describe "STM message store" someMsgStoreTests - around (withMsgStore testJournalStoreCfg) $ describe "Journal message store" $ do + around (withMsgStore $ testJournalStoreCfg MQStoreCfg) $ describe "Journal message store" $ do someMsgStoreTests it "should export and import journal store" testExportImportStore describe "queue state" $ do @@ -66,22 +66,24 @@ msgStoreTests = do it "should remove old queue state backups" testRemoveQueueStateBackups it "should expire messages in idle queues" testExpireIdleQueues where - someMsgStoreTests :: STMStoreClass s => SpecWith s + someMsgStoreTests :: MsgStoreClass s => SpecWith s someMsgStoreTests = do it "should get queue and store/read messages" testGetQueue it "should not fail on EOF when changing read journal" testChangeReadJournal -withMsgStore :: STMStoreClass s => MsgStoreConfig s -> (s -> IO ()) -> IO () +-- TODO constrain to STM stores? +withMsgStore :: MsgStoreClass s => MsgStoreConfig s -> (s -> IO ()) -> IO () withMsgStore cfg = bracket (newMsgStore cfg) closeMsgStore testSMTStoreConfig :: STMStoreConfig testSMTStoreConfig = STMStoreConfig {storePath = Nothing, quota = 3} -testJournalStoreCfg :: JournalStoreConfig -testJournalStoreCfg = +testJournalStoreCfg :: QStoreCfg s -> JournalStoreConfig s +testJournalStoreCfg queueStoreCfg = JournalStoreConfig { storePath = testStoreMsgsDir, pathParts = journalMsgStoreDepth, + queueStoreCfg, quota = 3, maxMsgCount = 4, maxStateLines = 2, @@ -126,7 +128,8 @@ testNewQueueRec g sndSecure = do } pure (rId, qr) -testGetQueue :: STMStoreClass s => s -> IO () +-- TODO constrain to STM stores +testGetQueue :: MsgStoreClass s => s -> IO () testGetQueue ms = do g <- C.newRandom (rId, qr) <- testNewQueueRec g True @@ -168,7 +171,8 @@ testGetQueue ms = do (Nothing, Nothing) <- tryDelPeekMsg ms q mId8 void $ ExceptT $ deleteQueue ms q -testChangeReadJournal :: STMStoreClass s => s -> IO () +-- TODO constrain to STM stores +testChangeReadJournal :: MsgStoreClass s => s -> IO () testChangeReadJournal ms = do g <- C.newRandom (rId, qr) <- testNewQueueRec g True @@ -187,12 +191,12 @@ testChangeReadJournal ms = do (Msg "message 5", Nothing) <- tryDelPeekMsg ms q mId5 void $ ExceptT $ deleteQueue ms q -testExportImportStore :: JournalMsgStore -> IO () +testExportImportStore :: JournalMsgStore 'QSMemory -> IO () testExportImportStore ms = do g <- C.newRandom (rId1, qr1) <- testNewQueueRec g True (rId2, qr2) <- testNewQueueRec g True - sl <- readWriteQueueStore testStoreLogFile ms + sl <- readWriteQueueStore True (mkQueue ms) testStoreLogFile $ queueStore ms runRight_ $ do let write q s = writeMsg ms q True =<< mkMessage s q1 <- ExceptT $ addQueue ms rId1 qr1 @@ -218,9 +222,9 @@ testExportImportStore ms = do closeStoreLog sl exportMessages False ms testStoreMsgsFile False (B.readFile testStoreMsgsFile `shouldReturn`) =<< B.readFile (testStoreMsgsFile <> ".copy") - let cfg = (testJournalStoreCfg :: JournalStoreConfig) {storePath = testStoreMsgsDir2} + let cfg = (testJournalStoreCfg MQStoreCfg :: JournalStoreConfig 'QSMemory) {storePath = testStoreMsgsDir2} ms' <- newMsgStore cfg - readWriteQueueStore testStoreLogFile ms' >>= closeStoreLog + readWriteQueueStore True (mkQueue ms') testStoreLogFile (queueStore ms') >>= closeStoreLog stats@MessageStats {storedMsgsCount = 5, expiredMsgsCount = 0, storedQueues = 2} <- importMessages False ms' testStoreMsgsFile Nothing False printMessageStats "Messages" stats @@ -229,13 +233,13 @@ testExportImportStore ms = do exportMessages False ms' testStoreMsgsFile2 False (B.readFile testStoreMsgsFile2 `shouldReturn`) =<< B.readFile (testStoreMsgsFile <> ".bak") stmStore <- newMsgStore testSMTStoreConfig - readWriteQueueStore testStoreLogFile stmStore >>= closeStoreLog + readWriteQueueStore True (mkQueue stmStore) testStoreLogFile (queueStore stmStore) >>= closeStoreLog MessageStats {storedMsgsCount = 5, expiredMsgsCount = 0, storedQueues = 2} <- importMessages False stmStore testStoreMsgsFile2 Nothing False exportMessages False stmStore testStoreMsgsFile False (B.sort <$> B.readFile testStoreMsgsFile `shouldReturn`) =<< (B.sort <$> B.readFile (testStoreMsgsFile2 <> ".bak")) -testQueueState :: JournalMsgStore -> IO () +testQueueState :: JournalMsgStore s -> IO () testQueueState ms = do g <- C.newRandom rId <- EntityId <$> atomically (C.randomBytes 24 g) @@ -298,7 +302,7 @@ testQueueState ms = do let f = dir name in unless (f == keep) $ removeFile f -testMessageState :: JournalMsgStore -> IO () +testMessageState :: JournalMsgStore s -> IO () testMessageState ms = do g <- C.newRandom (rId, qr) <- testNewQueueRec g True @@ -323,7 +327,7 @@ testMessageState ms = do (Msg "message 3", Nothing) <- tryDelPeekMsg ms q mId3 liftIO $ closeMsgQueue q -testRemoveJournals :: JournalMsgStore -> IO () +testRemoveJournals :: JournalMsgStore s -> IO () testRemoveJournals ms = do g <- C.newRandom (rId, qr) <- testNewQueueRec g True @@ -394,7 +398,7 @@ testRemoveQueueStateBackups = do g <- C.newRandom (rId, qr) <- testNewQueueRec g True - ms' <- newMsgStore testJournalStoreCfg {maxStateLines = 1, expireBackupsAfter = 0, keepMinBackups = 0} + ms' <- newMsgStore (testJournalStoreCfg MQStoreCfg) {maxStateLines = 1, expireBackupsAfter = 0, keepMinBackups = 0} -- set expiration time 1 second ahead let ms = ms' {expireBackupsBefore = addUTCTime 1 $ expireBackupsBefore ms'} @@ -430,7 +434,7 @@ testExpireIdleQueues = do g <- C.newRandom (rId, qr) <- testNewQueueRec g True - ms <- newMsgStore testJournalStoreCfg {idleInterval = 0} + ms <- newMsgStore (testJournalStoreCfg MQStoreCfg) {idleInterval = 0} let dir = msgQueueDirectory ms rId statePath = msgQueueStatePath dir $ B.unpack (B64.encode $ unEntityId rId) @@ -458,7 +462,7 @@ testExpireIdleQueues = do (Nothing, False) <- readQueueState ms statePath pure () -testReadFileMissing :: JournalMsgStore -> IO () +testReadFileMissing :: JournalMsgStore s -> IO () testReadFileMissing ms = do g <- C.newRandom (rId, qr) <- testNewQueueRec g True @@ -469,7 +473,7 @@ testReadFileMissing ms = do Msg "message 1" <- tryPeekMsg ms q pure q - mq <- fromJust <$> readTVarIO (msgQueue_' q) + mq <- fromJust <$> readTVarIO (msgQueue q) MsgQueueState {readState = rs} <- readTVarIO $ state mq closeMsgStore ms let path = journalFilePath (queueDirectory $ queue mq) $ journalId rs @@ -482,13 +486,13 @@ testReadFileMissing ms = do Msg "message 2" <- tryPeekMsg ms q' pure () -testReadFileMissingSwitch :: JournalMsgStore -> IO () +testReadFileMissingSwitch :: JournalMsgStore s -> IO () testReadFileMissingSwitch ms = do g <- C.newRandom (rId, qr) <- testNewQueueRec g True q <- writeMessages ms rId qr - mq <- fromJust <$> readTVarIO (msgQueue_' q) + mq <- fromJust <$> readTVarIO (msgQueue q) MsgQueueState {readState = rs} <- readTVarIO $ state mq closeMsgStore ms let path = journalFilePath (queueDirectory $ queue mq) $ journalId rs @@ -500,13 +504,13 @@ testReadFileMissingSwitch ms = do Msg "message 5" <- tryPeekMsg ms q' pure () -testWriteFileMissing :: JournalMsgStore -> IO () +testWriteFileMissing :: JournalMsgStore s -> IO () testWriteFileMissing ms = do g <- C.newRandom (rId, qr) <- testNewQueueRec g True q <- writeMessages ms rId qr - mq <- fromJust <$> readTVarIO (msgQueue_' q) + mq <- fromJust <$> readTVarIO (msgQueue q) MsgQueueState {writeState = ws} <- readTVarIO $ state mq closeMsgStore ms let path = journalFilePath (queueDirectory $ queue mq) $ journalId ws @@ -523,13 +527,13 @@ testWriteFileMissing ms = do Msg "message 6" <- tryPeekMsg ms q' pure () -testReadAndWriteFilesMissing :: JournalMsgStore -> IO () +testReadAndWriteFilesMissing :: JournalMsgStore s -> IO () testReadAndWriteFilesMissing ms = do g <- C.newRandom (rId, qr) <- testNewQueueRec g True q <- writeMessages ms rId qr - mq <- fromJust <$> readTVarIO (msgQueue_' q) + mq <- fromJust <$> readTVarIO (msgQueue q) MsgQueueState {readState = rs, writeState = ws} <- readTVarIO $ state mq closeMsgStore ms removeFile $ journalFilePath (queueDirectory $ queue mq) $ journalId rs @@ -542,7 +546,7 @@ testReadAndWriteFilesMissing ms = do Msg "message 6" <- tryPeekMsg ms q' pure () -writeMessages :: JournalMsgStore -> RecipientId -> QueueRec -> IO JournalQueue +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 diff --git a/tests/CoreTests/StoreLogTests.hs b/tests/CoreTests/StoreLogTests.hs index f62fb808f..ec2d07039 100644 --- a/tests/CoreTests/StoreLogTests.hs +++ b/tests/CoreTests/StoreLogTests.hs @@ -23,6 +23,8 @@ import Simplex.Messaging.Server.Env.STM (readWriteQueueStore) import Simplex.Messaging.Server.MsgStore.Journal import Simplex.Messaging.Server.MsgStore.Types import Simplex.Messaging.Server.QueueStore +import Simplex.Messaging.Server.QueueStore.STM (STMQueueStore (..)) +import Simplex.Messaging.Server.QueueStore.Types import Simplex.Messaging.Server.StoreLog import Test.Hspec @@ -105,11 +107,11 @@ testSMPStoreLog testSuite tests = replicateM_ 3 $ testReadWrite t where testReadWrite SLTC {compacted, state} = do - st <- newMsgStore testJournalStoreCfg - l <- readWriteQueueStore testStoreLogFile st + st <- newMsgStore $ testJournalStoreCfg MQStoreCfg + 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 -> IO (M.Map RecipientId QueueRec) - storeState st = M.mapMaybe id <$> (readTVarIO (queues $ stmQueueStore st) >>= mapM (readTVarIO . queueRec')) + storeState :: JournalMsgStore 'QSMemory -> IO (M.Map RecipientId QueueRec) + storeState st = M.mapMaybe id <$> (readTVarIO (queues $ stmQueueStore st) >>= mapM (readTVarIO . queueRec)) diff --git a/tests/SMPClient.hs b/tests/SMPClient.hs index 3c732b7a5..e19d81f76 100644 --- a/tests/SMPClient.hs +++ b/tests/SMPClient.hs @@ -16,7 +16,10 @@ module SMPClient where import Control.Monad.Except (runExceptT) import Data.ByteString.Char8 (ByteString) import Data.List.NonEmpty (NonEmpty) +import Database.PostgreSQL.Simple (ConnectInfo (..), defaultConnectInfo) import Network.Socket +import Simplex.Messaging.Agent.Store.Postgres.Common (DBOpts (..)) +import Simplex.Messaging.Agent.Store.Shared (MigrationConfirmation (..)) import Simplex.Messaging.Client (ProtocolClientConfig (..), chooseTransportHost, defaultNetworkConfig) import Simplex.Messaging.Client.Agent (SMPClientAgentConfig (..), defaultSMPClientAgentConfig) import qualified Simplex.Messaging.Crypto as C @@ -24,7 +27,7 @@ import Simplex.Messaging.Encoding import Simplex.Messaging.Protocol import Simplex.Messaging.Server (runSMPServerBlocking) import Simplex.Messaging.Server.Env.STM -import Simplex.Messaging.Server.MsgStore.Types (AMSType (..), SMSType (..)) +import Simplex.Messaging.Server.MsgStore.Types (SMSType (..), SQSType (..)) import Simplex.Messaging.Transport import Simplex.Messaging.Transport.Client import qualified Simplex.Messaging.Transport.Client as Client @@ -61,6 +64,27 @@ testStoreLogFile = "tests/tmp/smp-server-store.log" testStoreLogFile2 :: FilePath testStoreLogFile2 = "tests/tmp/smp-server-store.log.2" +testStoreDBOpts :: DBOpts +testStoreDBOpts = + DBOpts + { connstr = testServerDBConnstr, + schema = "smp_server", + createSchema = True + } + +testStoreDBOpts2 :: DBOpts +testStoreDBOpts2 = testStoreDBOpts {schema = "smp_server2"} + +testServerDBConnstr :: ByteString +testServerDBConnstr = "postgresql://test_server_user@/test_server_db" + +testServerDBConnectInfo :: ConnectInfo +testServerDBConnectInfo = + defaultConnectInfo { + connectUser = "test_server_user", + connectDatabase = "test_server_db" + } + testStoreMsgsFile :: FilePath testStoreMsgsFile = "tests/tmp/smp-server-messages.log" @@ -89,9 +113,13 @@ xit' :: (HasCallStack, Example a) => String -> a -> SpecWith (Arg a) xit' d = if os == "linux" then skip "skipped on Linux" . it d else it d xit'' :: (HasCallStack, Example a) => String -> a -> SpecWith (Arg a) -xit'' d t = do - ci <- runIO $ lookupEnv "CI" - (if ci == Just "true" then skip "skipped on CI" . it d else it d) t +xit'' d = skipOnCI . it d + +skipOnCI :: SpecWith a -> SpecWith a +skipOnCI t = + runIO (lookupEnv "CI") >>= \case + Just "true" -> skip "skipped on CI" t + _ -> t testSMPClient :: Transport c => (THandleSMP c 'TClient -> IO a) -> IO a testSMPClient = testSMPClientVR supportedClientSMPRelayVRange @@ -114,24 +142,44 @@ testSMPClient_ host port vr client = do | otherwise = Nothing cfg :: ServerConfig -cfg = cfgMS (AMSType SMSJournal) +cfg = cfgMS (ASType SQSMemory SMSJournal) -cfgMS :: AMSType -> ServerConfig +-- TODO [postgres] +-- cfg :: ServerConfig +-- cfg = cfgMS (ASType SQSPostgres SMSJournal) + +cfgJ2 :: ServerConfig +cfgJ2 = journalCfg cfg testStoreLogFile2 testStoreMsgsDir2 + +-- TODO [postgres] +-- cfgJ2 :: ServerConfig +-- cfgJ2 = journalCfg cfg testStoreDBOpts2 testStoreMsgsDir2 + +journalCfg :: ServerConfig -> FilePath -> FilePath -> ServerConfig +journalCfg cfg' storeLogFile storeMsgsPath = cfg' {serverStoreCfg = ASSCfg SQSMemory SMSJournal SSCMemoryJournal {storeLogFile, storeMsgsPath}} + +-- TODO [postgres] +-- journalCfg :: ServerConfig -> DBOpts -> FilePath -> ServerConfig +-- journalCfg cfg' storeDBOpts storeMsgsPath' = cfg' {serverStoreCfg = ASSCfg SQSPostgres SMSJournal SSCDatabaseJournal {storeDBOpts, storeMsgsPath'}} + +cfgMS :: AStoreType -> ServerConfig cfgMS msType = ServerConfig { transports = [], smpHandshakeTimeout = 60000000, tbqSize = 1, - msgStoreType = msType, msgQueueQuota = 4, maxJournalMsgCount = 5, maxJournalStateLines = 2, queueIdBytes = 24, msgIdBytes = 24, - storeLogFile = Just testStoreLogFile, - storeMsgsFile = Just $ case msType of - AMSType SMSJournal -> testStoreMsgsDir - AMSType SMSMemory -> testStoreMsgsFile, + serverStoreCfg = case msType of + 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 {storeDBOpts = testStoreDBOpts, confirmMigrations = MCYesUp, storeMsgsPath' = testStoreMsgsDir}, storeNtfsFile = Nothing, allowNewQueues = True, newQueueBasicAuth = Nothing, @@ -164,7 +212,7 @@ cfgMS msType = allowSMPProxy = False, serverClientConcurrency = 2, information = Nothing, - startOptions = StartOptions {maintenance = False, skipWarnings = False} + startOptions = StartOptions {maintenance = False, skipWarnings = False, confirmMigrations = MCYesUp} } cfgV7 :: ServerConfig @@ -191,20 +239,27 @@ proxyCfg = where smpAgentCfg' = smpAgentCfg cfg +proxyCfgJ2 :: ServerConfig +proxyCfgJ2 = journalCfg proxyCfg testStoreLogFile2 testStoreMsgsDir2 + +-- TODO [postgres] +-- proxyCfgJ2 :: ServerConfig +-- proxyCfgJ2 = journalCfg proxyCfg testStoreDBOpts2 testStoreMsgsDir2 + proxyVRangeV8 :: VersionRangeSMP proxyVRangeV8 = mkVersionRange minServerSMPRelayVersion sendingProxySMPVersion withSmpServerStoreMsgLogOn :: HasCallStack => ATransport -> ServiceName -> (HasCallStack => ThreadId -> IO a) -> IO a -withSmpServerStoreMsgLogOn = (`withSmpServerStoreMsgLogOnMS` AMSType SMSJournal) +withSmpServerStoreMsgLogOn = (`withSmpServerStoreMsgLogOnMS` ASType SQSMemory SMSJournal) -withSmpServerStoreMsgLogOnMS :: HasCallStack => ATransport -> AMSType -> ServiceName -> (HasCallStack => ThreadId -> IO a) -> IO a +withSmpServerStoreMsgLogOnMS :: HasCallStack => ATransport -> AStoreType -> ServiceName -> (HasCallStack => ThreadId -> IO a) -> IO a withSmpServerStoreMsgLogOnMS t msType = withSmpServerConfigOn t (cfgMS msType) {storeNtfsFile = Just testStoreNtfsFile, serverStatsBackupFile = Just testServerStatsBackupFile} withSmpServerStoreLogOn :: HasCallStack => ATransport -> ServiceName -> (HasCallStack => ThreadId -> IO a) -> IO a -withSmpServerStoreLogOn = (`withSmpServerStoreLogOnMS` AMSType SMSJournal) +withSmpServerStoreLogOn = (`withSmpServerStoreLogOnMS` ASType SQSMemory SMSJournal) -withSmpServerStoreLogOnMS :: HasCallStack => ATransport -> AMSType -> ServiceName -> (HasCallStack => ThreadId -> IO a) -> IO a +withSmpServerStoreLogOnMS :: HasCallStack => ATransport -> AStoreType -> ServiceName -> (HasCallStack => ThreadId -> IO a) -> IO a withSmpServerStoreLogOnMS t msType = withSmpServerConfigOn t (cfgMS msType) {serverStatsBackupFile = Just testServerStatsBackupFile} withSmpServerConfigOn :: HasCallStack => ATransport -> ServerConfig -> ServiceName -> (HasCallStack => ThreadId -> IO a) -> IO a @@ -238,10 +293,10 @@ withSmpServer t = withSmpServerOn t testPort withSmpServerProxy :: HasCallStack => ATransport -> IO a -> IO a withSmpServerProxy t = withSmpServerConfigOn t proxyCfg testPort . const -runSmpTest :: forall c a. (HasCallStack, Transport c) => AMSType -> (HasCallStack => THandleSMP c 'TClient -> IO a) -> IO a +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 -runSmpTestN :: forall c a. (HasCallStack, Transport c) => AMSType -> Int -> (HasCallStack => [THandleSMP c 'TClient] -> IO a) -> IO a +runSmpTestN :: forall c a. (HasCallStack, Transport c) => AStoreType -> Int -> (HasCallStack => [THandleSMP c 'TClient] -> IO a) -> IO a runSmpTestN msType = runSmpTestNCfg (cfgMS msType) supportedClientSMPRelayVRange runSmpTestNCfg :: forall c a. (HasCallStack, Transport c) => ServerConfig -> VersionRangeSMP -> Int -> (HasCallStack => [THandleSMP c 'TClient] -> IO a) -> IO a @@ -257,7 +312,7 @@ smpServerTest :: TProxy c -> (Maybe TransmissionAuth, ByteString, ByteString, smp) -> IO (Maybe TransmissionAuth, ByteString, ByteString, BrokerMsg) -smpServerTest _ t = runSmpTest (AMSType SMSJournal) $ \h -> tPut' h t >> tGet' h +smpServerTest _ t = runSmpTest (ASType SQSMemory SMSJournal) $ \h -> tPut' h t >> tGet' h where tPut' :: THandleSMP c 'TClient -> (Maybe TransmissionAuth, ByteString, ByteString, smp) -> IO () tPut' h@THandle {params = THandleParams {sessionId, implySessId}} (sig, corrId, queueId, smp) = do @@ -268,16 +323,16 @@ smpServerTest _ t = runSmpTest (AMSType SMSJournal) $ \h -> tPut' h t >> tGet' h [(Nothing, _, (CorrId corrId, EntityId qId, Right cmd))] <- tGet h pure (Nothing, corrId, qId, cmd) -smpTest :: (HasCallStack, Transport c) => TProxy c -> AMSType -> (HasCallStack => THandleSMP c 'TClient -> IO ()) -> Expectation +smpTest :: (HasCallStack, Transport c) => TProxy c -> AStoreType -> (HasCallStack => THandleSMP c 'TClient -> IO ()) -> Expectation smpTest _ msType test' = runSmpTest msType test' `shouldReturn` () -smpTestN :: (HasCallStack, Transport c) => AMSType -> Int -> (HasCallStack => [THandleSMP c 'TClient] -> IO ()) -> Expectation +smpTestN :: (HasCallStack, Transport c) => AStoreType -> Int -> (HasCallStack => [THandleSMP c 'TClient] -> IO ()) -> Expectation smpTestN msType n test' = runSmpTestN msType n test' `shouldReturn` () smpTest2' :: forall c. (HasCallStack, Transport c) => TProxy c -> (HasCallStack => THandleSMP c 'TClient -> THandleSMP c 'TClient -> IO ()) -> Expectation -smpTest2' = (`smpTest2` AMSType SMSJournal) +smpTest2' = (`smpTest2` ASType SQSMemory SMSJournal) -smpTest2 :: forall c. (HasCallStack, Transport c) => TProxy c -> AMSType -> (HasCallStack => THandleSMP c 'TClient -> THandleSMP c 'TClient -> IO ()) -> Expectation +smpTest2 :: forall c. (HasCallStack, Transport c) => TProxy c -> AStoreType -> (HasCallStack => THandleSMP c 'TClient -> THandleSMP c 'TClient -> IO ()) -> Expectation smpTest2 t msType = smpTest2Cfg (cfgMS msType) supportedClientSMPRelayVRange t smpTest2Cfg :: forall c. (HasCallStack, Transport c) => ServerConfig -> VersionRangeSMP -> TProxy c -> (HasCallStack => THandleSMP c 'TClient -> THandleSMP c 'TClient -> IO ()) -> Expectation @@ -287,14 +342,14 @@ smpTest2Cfg srvCfg clntVR _ test' = runSmpTestNCfg srvCfg clntVR 2 _test `should _test [h1, h2] = test' h1 h2 _test _ = error "expected 2 handles" -smpTest3 :: forall c. (HasCallStack, Transport c) => TProxy c -> AMSType -> (HasCallStack => THandleSMP c 'TClient -> THandleSMP c 'TClient -> THandleSMP c 'TClient -> IO ()) -> Expectation +smpTest3 :: forall c. (HasCallStack, Transport c) => TProxy c -> AStoreType -> (HasCallStack => THandleSMP c 'TClient -> THandleSMP c 'TClient -> THandleSMP c 'TClient -> IO ()) -> Expectation smpTest3 _ msType test' = smpTestN msType 3 _test where _test :: HasCallStack => [THandleSMP c 'TClient] -> IO () _test [h1, h2, h3] = test' h1 h2 h3 _test _ = error "expected 3 handles" -smpTest4 :: forall c. (HasCallStack, Transport c) => TProxy c -> AMSType -> (HasCallStack => THandleSMP c 'TClient -> THandleSMP c 'TClient -> THandleSMP c 'TClient -> THandleSMP c 'TClient -> IO ()) -> Expectation +smpTest4 :: forall c. (HasCallStack, Transport c) => TProxy c -> AStoreType -> (HasCallStack => THandleSMP c 'TClient -> THandleSMP c 'TClient -> THandleSMP c 'TClient -> THandleSMP c 'TClient -> IO ()) -> Expectation smpTest4 _ msType test' = smpTestN msType 4 _test where _test :: HasCallStack => [THandleSMP c 'TClient] -> IO () diff --git a/tests/SMPProxyTests.hs b/tests/SMPProxyTests.hs index 61b7c1670..04ba953da 100644 --- a/tests/SMPProxyTests.hs +++ b/tests/SMPProxyTests.hs @@ -151,7 +151,9 @@ smpProxyTests = do twoServersNoConc = twoServers_ proxyCfg {serverClientConcurrency = 1} cfgV8 {msgQueueQuota = 128, maxJournalMsgCount = 256} twoServers_ cfg1 cfg2 runTest = withSmpServerConfigOn (transport @TLS) cfg1 testPort $ \_ -> - let cfg2' = cfg2 {storeLogFile = Just testStoreLogFile2, storeMsgsFile = Just testStoreMsgsDir2} + let cfg2' = journalCfg cfg2 testStoreLogFile2 testStoreMsgsDir2 + -- TODO [postgres] + -- let cfg2' = journalCfg cfg2 testStoreDBOpts2 testStoreMsgsDir2 in withSmpServerConfigOn (transport @TLS) cfg2' testPort2 $ const runTest deliverMessageViaProxy :: (C.AlgorithmI a, C.AuthAlgorithm a) => SMPServer -> SMPServer -> C.SAlgorithm a -> ByteString -> ByteString -> IO () @@ -390,10 +392,14 @@ agentViaProxyRetryOffline = do where withServer :: (ThreadId -> IO a) -> IO a withServer = withServer_ testStoreLogFile testStoreMsgsDir testStoreNtfsFile testPort + -- TODO [postgres] + -- withServer = withServer_ testStoreDBOpts testStoreMsgsDir testStoreNtfsFile testPort withServer2 :: (ThreadId -> IO a) -> IO a withServer2 = withServer_ testStoreLogFile2 testStoreMsgsDir2 testStoreNtfsFile2 testPort2 + -- TODO [postgres] + -- withServer2 = withServer_ testStoreDBOpts2 testStoreMsgsDir2 testStoreNtfsFile2 testPort2 withServer_ storeLog storeMsgs storeNtfs = - withSmpServerConfigOn (transport @TLS) proxyCfg {storeLogFile = Just storeLog, storeMsgsFile = Just storeMsgs, storeNtfsFile = Just storeNtfs} + withSmpServerConfigOn (transport @TLS) (journalCfg proxyCfg storeLog storeMsgs) {storeNtfsFile = Just storeNtfs} a `up` cId = nGet a =##> \case ("", "", UP _ [c]) -> c == cId; _ -> False a `down` cId = nGet a =##> \case ("", "", DOWN _ [c]) -> c == cId; _ -> False aCfg = agentCfg {messageRetryInterval = fastMessageRetryInterval} @@ -418,7 +424,7 @@ agentViaProxyRetryNoSession = do _ <- runRight $ makeConnection b a pure () where - withServer2 = withSmpServerConfigOn (transport @TLS) proxyCfg {storeLogFile = Just testStoreLogFile2, storeMsgsFile = Just testStoreMsgsFile2} testPort2 + withServer2 = withSmpServerConfigOn (transport @TLS) proxyCfgJ2 testPort2 servers srv = (initAgentServersProxy SPMAlways SPFProhibit) {smp = userServers [srv]} testNoProxy :: IO () diff --git a/tests/ServerTests.hs b/tests/ServerTests.hs index 088a7b977..6c2199795 100644 --- a/tests/ServerTests.hs +++ b/tests/ServerTests.hs @@ -36,10 +36,10 @@ import Simplex.Messaging.Encoding.String import Simplex.Messaging.Parsers (parseAll) import Simplex.Messaging.Protocol import Simplex.Messaging.Server (exportMessages) -import Simplex.Messaging.Server.Env.STM (ServerConfig (..), readWriteQueueStore) +import Simplex.Messaging.Server.Env.STM (AServerStoreCfg (..), AStoreType (..), ServerConfig (..), ServerStoreCfg (..), readWriteQueueStore) import Simplex.Messaging.Server.Expiration -import Simplex.Messaging.Server.MsgStore.Journal (JournalStoreConfig (..)) -import Simplex.Messaging.Server.MsgStore.Types (AMSType (..), SMSType (..), newMsgStore) +import Simplex.Messaging.Server.MsgStore.Journal (JournalStoreConfig (..), QStoreCfg (..)) +import Simplex.Messaging.Server.MsgStore.Types (MsgStoreClass (..), SQSType (..), SMSType (..), newMsgStore) import Simplex.Messaging.Server.Stats (PeriodStatsData (..), ServerStatsData (..)) import Simplex.Messaging.Server.StoreLog (StoreLogRecord (..), closeStoreLog) import Simplex.Messaging.Transport @@ -53,7 +53,7 @@ import Test.HUnit import Test.Hspec import Util (removeFileIfExists) -serverTests :: SpecWith (ATransport, AMSType) +serverTests :: SpecWith (ATransport, AStoreType) serverTests = do describe "SMP queues" $ do describe "NEW and KEY commands, SEND messages" testCreateSecure @@ -70,8 +70,8 @@ serverTests = do describe "GET & SUB commands" testGetSubCommands describe "Exceeding queue quota" testExceedQueueQuota describe "Store log" testWithStoreLog - describe "Restore messages" testRestoreMessages - describe "Restore messages (old / v2)" testRestoreExpireMessages + xdescribe "Restore messages" testRestoreMessages -- TODO [postgres] + xdescribe "Restore messages (old / v2)" testRestoreExpireMessages -- TODO [postgres] describe "Save prometheus metrics" testPrometheusMetrics describe "Timing of AUTH error" testTiming describe "Message notifications" testMessageNotifications @@ -139,7 +139,7 @@ decryptMsgV3 dhShared nonce body = Right ClientRcvMsgQuota {} -> Left "ClientRcvMsgQuota" Left e -> Left e -testCreateSecure :: SpecWith (ATransport, AMSType) +testCreateSecure :: SpecWith (ATransport, AStoreType) testCreateSecure = it "should create (NEW) and secure (KEY) queue" $ \(ATransport t, msType) -> smpTest2 t msType $ \r s -> do @@ -204,7 +204,7 @@ testCreateSecure = Resp "bcda" _ (ERR LARGE_MSG) <- signSendRecv s sKey ("bcda", sId, _SEND biggerMessage) pure () -testCreateSndSecure :: SpecWith (ATransport, AMSType) +testCreateSndSecure :: SpecWith (ATransport, AStoreType) testCreateSndSecure = it "should create (NEW) and secure (SKEY) queue by sender" $ \(ATransport t, msType) -> smpTest2 t msType $ \r s -> do @@ -251,7 +251,7 @@ testCreateSndSecure = Resp "bcda" _ (ERR LARGE_MSG) <- signSendRecv s sKey ("bcda", sId, _SEND biggerMessage) pure () -testSndSecureProhibited :: SpecWith (ATransport, AMSType) +testSndSecureProhibited :: SpecWith (ATransport, AStoreType) testSndSecureProhibited = it "should create (NEW) without allowing sndSecure and fail to and secure queue by sender (SKEY)" $ \(ATransport t, msType) -> smpTest2 t msType $ \r s -> do @@ -266,7 +266,7 @@ testSndSecureProhibited = (sId2, sId) #== "secures queue, same queue ID in response" (err, ERR AUTH) #== "rejects SKEY when not allowed in NEW command" -testCreateDelete :: SpecWith (ATransport, AMSType) +testCreateDelete :: SpecWith (ATransport, AStoreType) testCreateDelete = it "should create (NEW), suspend (OFF) and delete (DEL) queue" $ \(ATransport t, msType) -> smpTest2 t msType $ \rh sh -> do @@ -337,7 +337,7 @@ testCreateDelete = Resp "cdab" _ err10 <- signSendRecv rh rKey ("cdab", rId, SUB) (err10, ERR AUTH) #== "rejects SUB when deleted" -stressTest :: SpecWith (ATransport, AMSType) +stressTest :: SpecWith (ATransport, AStoreType) stressTest = it "should create many queues, disconnect and re-connect" $ \(ATransport t, msType) -> smpTest3 t msType $ \h1 h2 h3 -> do @@ -355,7 +355,7 @@ stressTest = closeConnection $ connection h2 subscribeQueues h3 -testAllowNewQueues :: SpecWith (ATransport, AMSType) +testAllowNewQueues :: SpecWith (ATransport, AStoreType) testAllowNewQueues = it "should prohibit creating new queues with allowNewQueues = False" $ \(ATransport (t :: TProxy c), msType) -> withSmpServerConfigOn (ATransport t) (cfgMS msType) {allowNewQueues = False} testPort $ \_ -> @@ -366,7 +366,7 @@ testAllowNewQueues = Resp "abcd" NoEntity (ERR AUTH) <- signSendRecv h rKey ("abcd", NoEntity, NEW rPub dhPub Nothing SMSubscribe False) pure () -testDuplex :: SpecWith (ATransport, AMSType) +testDuplex :: SpecWith (ATransport, AStoreType) testDuplex = it "should create 2 simplex connections and exchange messages" $ \(ATransport t, msType) -> smpTest2 t msType $ \alice bob -> do @@ -421,7 +421,7 @@ testDuplex = Resp "bcda" _ OK <- signSendRecv bob brKey ("bcda", bRcv, ACK mId5) (bDec mId5 msg5, Right "how are you bob") #== "message received from alice" -testSwitchSub :: SpecWith (ATransport, AMSType) +testSwitchSub :: SpecWith (ATransport, AStoreType) testSwitchSub = it "should create simplex connections and switch subscription to another TCP connection" $ \(ATransport t, msType) -> smpTest3 t msType $ \rh1 rh2 sh -> do @@ -466,7 +466,7 @@ testSwitchSub = Nothing -> return () Just _ -> error "nothing else is delivered to the 1st TCP connection" -testGetCommand :: SpecWith (ATransport, AMSType) +testGetCommand :: SpecWith (ATransport, AStoreType) testGetCommand = it "should retrieve messages from the queue using GET command" $ \(ATransport (t :: TProxy c), msType) -> do g <- C.newRandom @@ -485,7 +485,7 @@ testGetCommand = Resp "4" _ OK <- signSendRecv rh rKey ("4", rId, GET) pure () -testGetSubCommands :: SpecWith (ATransport, AMSType) +testGetSubCommands :: SpecWith (ATransport, AStoreType) testGetSubCommands = it "should retrieve messages with GET and receive with SUB, only one ACK would work" $ \(ATransport t, msType) -> do g <- C.newRandom @@ -535,7 +535,7 @@ testGetSubCommands = Resp "12" _ OK <- signSendRecv rh2 rKey ("12", rId, GET) pure () -testExceedQueueQuota :: SpecWith (ATransport, AMSType) +testExceedQueueQuota :: SpecWith (ATransport, AStoreType) testExceedQueueQuota = it "should reply with ERR QUOTA to sender and send QUOTA message to the recipient" $ \(ATransport (t :: TProxy c), msType) -> do withSmpServerConfigOn (ATransport t) (cfgMS msType) {msgQueueQuota = 2} testPort $ \_ -> @@ -562,9 +562,9 @@ testExceedQueueQuota = Resp "10" _ OK <- signSendRecv rh rKey ("10", rId, ACK mId4) pure () -testWithStoreLog :: SpecWith (ATransport, AMSType) +testWithStoreLog :: SpecWith (ATransport, AStoreType) testWithStoreLog = - it "should store simplex queues to log and restore them after server restart" $ \(at@(ATransport t), msType) -> do + xit "should store simplex queues to log and restore them after server restart" $ \(at@(ATransport t), msType) -> do g <- C.newRandom (sPub1, sKey1) <- atomically $ C.generateAuthKeyPair C.SEd25519 g (sPub2, sKey2) <- atomically $ C.generateAuthKeyPair C.SEd25519 g @@ -609,7 +609,7 @@ testWithStoreLog = logSize testStoreLogFile `shouldReturn` 6 - let cfg' = (cfgMS msType) {msgStoreType = AMSType SMSMemory, storeLogFile = Nothing, storeMsgsFile = Nothing} + let cfg' = cfg {serverStoreCfg = ASSCfg SQSMemory SMSMemory $ SSCMemory Nothing} withSmpServerConfigOn at cfg' testPort . runTest t $ \h -> do sId1 <- readTVarIO senderId1 -- fails if store log is disabled @@ -650,7 +650,7 @@ logSize f = Right l -> pure l Left (_ :: SomeException) -> logSize f -testRestoreMessages :: SpecWith (ATransport, AMSType) +testRestoreMessages :: SpecWith (ATransport, AStoreType) testRestoreMessages = it "should store messages on exit and restore on start" $ \(at@(ATransport t), msType) -> do removeFileIfExists testStoreLogFile @@ -759,7 +759,7 @@ checkStats s qs sent received = do IS.toList _week `shouldBe` map (hash . unEntityId) qs IS.toList _month `shouldBe` map (hash . unEntityId) qs -testRestoreExpireMessages :: SpecWith (ATransport, AMSType) +testRestoreExpireMessages :: SpecWith (ATransport, AStoreType) testRestoreExpireMessages = it "should store messages on exit and restore on start" $ \(at@(ATransport t), msType) -> do g <- C.newRandom @@ -812,14 +812,16 @@ testRestoreExpireMessages = Right ServerStatsData {_msgExpired} <- strDecode <$> B.readFile testServerStatsBackupFile _msgExpired `shouldBe` 2 where - exportStoreMessages :: AMSType -> IO () + exportStoreMessages :: AStoreType -> IO () exportStoreMessages = \case - AMSType SMSJournal -> do - ms <- newMsgStore testJournalStoreCfg {quota = 4} - readWriteQueueStore testStoreLogFile ms >>= closeStoreLog - removeFileIfExists testStoreMsgsFile - exportMessages False ms testStoreMsgsFile False - AMSType SMSMemory -> pure () + ASType _ SMSJournal -> export + ASType _ SMSMemory -> pure () + where + export = do + ms <- newMsgStore (testJournalStoreCfg MQStoreCfg) {quota = 4} + readWriteQueueStore True (mkQueue ms) testStoreLogFile (queueStore ms) >>= closeStoreLog + removeFileIfExists testStoreMsgsFile + exportMessages False ms testStoreMsgsFile False runTest :: Transport c => TProxy c -> (THandleSMP c 'TClient -> IO ()) -> ThreadId -> Expectation runTest _ test' server = do testSMPClient test' `shouldReturn` () @@ -828,7 +830,7 @@ testRestoreExpireMessages = runClient :: Transport c => TProxy c -> (THandleSMP c 'TClient -> IO ()) -> Expectation runClient _ test' = testSMPClient test' `shouldReturn` () -testPrometheusMetrics :: SpecWith (ATransport, AMSType) +testPrometheusMetrics :: SpecWith (ATransport, AStoreType) testPrometheusMetrics = it "should save Prometheus metrics" $ \(at, msType) -> do let cfg' = (cfgMS msType) {prometheusInterval = Just 1} @@ -846,7 +848,7 @@ createAndSecureQueue h sPub = do (rId', rId) #== "same queue ID" pure (sId, rId, rKey, dhShared) -testTiming :: SpecWith (ATransport, AMSType) +testTiming :: SpecWith (ATransport, AStoreType) testTiming = describe "should have similar time for auth error, whether queue exists or not, for all key types" $ forM_ timingTests $ \tst -> @@ -916,7 +918,7 @@ testTiming = ] ok `shouldBe` True -testMessageNotifications :: SpecWith (ATransport, AMSType) +testMessageNotifications :: SpecWith (ATransport, AStoreType) testMessageNotifications = it "should create simplex connection, subscribe notifier and deliver notifications" $ \(ATransport t, msType) -> do g <- C.newRandom @@ -956,7 +958,7 @@ testMessageNotifications = Nothing -> pure () Just _ -> error "nothing else should be delivered to the 2nd notifier's TCP connection" -testMsgExpireOnSend :: SpecWith (ATransport, AMSType) +testMsgExpireOnSend :: SpecWith (ATransport, AStoreType) testMsgExpireOnSend = it "should expire messages that are not received before messageTTL on SEND" $ \(ATransport (t :: TProxy c), msType) -> do g <- C.newRandom @@ -976,7 +978,7 @@ testMsgExpireOnSend = Nothing -> return () Just _ -> error "nothing else should be delivered" -testMsgExpireOnInterval :: SpecWith (ATransport, AMSType) +testMsgExpireOnInterval :: SpecWith (ATransport, AStoreType) testMsgExpireOnInterval = -- fails on ubuntu xit' "should expire messages that are not received before messageTTL after expiry interval" $ \(ATransport (t :: TProxy c), msType) -> do @@ -996,7 +998,7 @@ testMsgExpireOnInterval = Nothing -> return () Just _ -> error "nothing should be delivered" -testMsgNOTExpireOnInterval :: SpecWith (ATransport, AMSType) +testMsgNOTExpireOnInterval :: SpecWith (ATransport, AStoreType) testMsgNOTExpireOnInterval = it "should block and unblock message queues" $ \(ATransport (t :: TProxy c), msType) -> do g <- C.newRandom @@ -1015,7 +1017,7 @@ testMsgNOTExpireOnInterval = Nothing -> return () Just _ -> error "nothing else should be delivered" -testBlockMessageQueue :: SpecWith (ATransport, AMSType) +testBlockMessageQueue :: SpecWith (ATransport, AStoreType) testBlockMessageQueue = it "should return BLOCKED error when queue is blocked" $ \(at@(ATransport (t :: TProxy c)), msType) -> do g <- C.newRandom diff --git a/tests/Test.hs b/tests/Test.hs index 09fb856fd..bfcae0e08 100644 --- a/tests/Test.hs +++ b/tests/Test.hs @@ -23,9 +23,12 @@ import GHC.IO.Exception (IOException (..)) import qualified GHC.IO.Exception as IOException import NtfServerTests (ntfServerTests) import RemoteControl (remoteControlTests) +import SMPClient (testServerDBConnectInfo) import SMPProxyTests (smpProxyTests) import ServerTests -import Simplex.Messaging.Server.MsgStore.Types (AMSType (..), SMSType (..)) +import Simplex.Messaging.Agent.Store.Postgres.Util (createDBAndUserIfNotExists, dropDatabaseAndUser) +import Simplex.Messaging.Server.Env.STM (AStoreType (..)) +import Simplex.Messaging.Server.MsgStore.Types (SMSType (..), SQSType (..)) import Simplex.Messaging.Transport (TLS, Transport (..)) -- import Simplex.Messaging.Transport.WebSockets (WS) import System.Directory (createDirectoryIfMissing, removeDirectoryRecursive) @@ -51,6 +54,7 @@ main = do setEnv "APNS_KEY_ID" "H82WD9K9AQ" setEnv "APNS_KEY_FILE" "./tests/fixtures/AuthKey_H82WD9K9AQ.p8" hspec + -- TODO [postgres] run tests with postgres server locally and maybe in CI #if defined(dbPostgres) . beforeAll_ (dropDatabaseAndUser testDBConnectInfo >> createDBAndUserIfNotExists testDBConnectInfo) . afterAll_ (dropDatabaseAndUser testDBConnectInfo) @@ -74,14 +78,20 @@ main = do describe "Store log tests" storeLogTests describe "TRcvQueues tests" tRcvQueuesTests describe "Util tests" utilTests + beforeAll_ (dropDatabaseAndUser testServerDBConnectInfo >> createDBAndUserIfNotExists testServerDBConnectInfo) + $ afterAll_ (dropDatabaseAndUser testServerDBConnectInfo) + -- TODO [postgres] fix store log tests + $ describe "SMP server via TLS, postgres+jornal message store" $ do + describe "SMP syntax" $ serverSyntaxTests (transport @TLS) + before (pure (transport @TLS, ASType SQSPostgres SMSJournal)) serverTests describe "SMP server via TLS, jornal message store" $ do describe "SMP syntax" $ serverSyntaxTests (transport @TLS) - before (pure (transport @TLS, AMSType SMSJournal)) serverTests + before (pure (transport @TLS, ASType SQSMemory SMSJournal)) serverTests describe "SMP server via TLS, memory message store" $ - before (pure (transport @TLS, AMSType SMSMemory)) serverTests + before (pure (transport @TLS, ASType SQSMemory SMSMemory)) serverTests -- xdescribe "SMP server via WebSockets" $ do -- describe "SMP syntax" $ serverSyntaxTests (transport @WS) - -- before (pure (transport @WS, AMSType SMSJournal)) serverTests + -- before (pure (transport @WS, ASType SQSMemory SMSJournal)) serverTests describe "Notifications server" $ ntfServerTests (transport @TLS) describe "SMP client agent" $ agentTests (transport @TLS) describe "SMP proxy" smpProxyTests From 172540984ca663750154eccf4ba1202c4b100533 Mon Sep 17 00:00:00 2001 From: Evgeny Date: Tue, 25 Feb 2025 15:33:54 +0000 Subject: [PATCH 02/14] agent, smp server: PostgreSQL connection pool (#1468) * agent, smp server: PostgreSQL connection pool * simplify, create all connections before start * rename * remove imports --- src/Simplex/Messaging/Agent/Store/Postgres.hs | 56 ++++++++++--------- .../Messaging/Agent/Store/Postgres/Common.hs | 25 ++++++--- src/Simplex/Messaging/Client.hs | 4 +- src/Simplex/Messaging/Server.hs | 2 +- src/Simplex/Messaging/Server/Main.hs | 36 ++++++++++-- .../Messaging/Server/QueueStore/Postgres.hs | 12 +++- src/Simplex/Messaging/Util.hs | 7 +++ tests/SMPClient.hs | 1 + tests/ServerTests.hs | 4 +- 9 files changed, 100 insertions(+), 47 deletions(-) diff --git a/src/Simplex/Messaging/Agent/Store/Postgres.hs b/src/Simplex/Messaging/Agent/Store/Postgres.hs index 1c7abb701..3f5c14b26 100644 --- a/src/Simplex/Messaging/Agent/Store/Postgres.hs +++ b/src/Simplex/Messaging/Agent/Store/Postgres.hs @@ -16,9 +16,9 @@ module Simplex.Messaging.Agent.Store.Postgres where import Control.Concurrent.STM -import Control.Exception (bracketOnError, finally, onException, throwIO) +import Control.Exception (finally, onException, throwIO, uninterruptibleMask_) import Control.Logger.Simple (logError) -import Control.Monad (void, when) +import Control.Monad import Data.ByteString (ByteString) import Data.Functor (($>)) import Data.Text (Text) @@ -53,11 +53,24 @@ createDBStore opts migrations confirmMigrations = do in sharedMigrateSchema dbm (dbNew st) migrations confirmMigrations connectPostgresStore :: DBOpts -> IO DBStore -connectPostgresStore DBOpts {connstr, schema, createSchema} = do - (dbConn, dbNew) <- connectDB connstr schema createSchema -- TODO [postgres] analogue for dbBusyLoop? - dbConnection <- newMVar dbConn - dbClosed <- newTVarIO False - pure DBStore {dbConnstr = connstr, dbSchema = schema, dbConnection, dbNew, dbClosed} +connectPostgresStore DBOpts {connstr, schema, poolSize, createSchema} = do + dbSem <- newMVar () + dbPool <- newTBQueueIO poolSize + dbClosed <- newTVarIO True + let st = DBStore {dbConnstr = connstr, dbSchema = schema, dbPoolSize = fromIntegral poolSize, dbPool, dbSem, dbNew = False, dbClosed} + dbNew <- connectPool st createSchema + pure st {dbNew} + +-- uninterruptibleMask_ here and below is used here so that it is not interrupted half-way, +-- it relies on the assumption that when dbClosed = True, the queue is empty, +-- and when it is False, the queue is full (or will have connections returned to it by the threads that use them). +connectPool :: DBStore -> Bool -> IO Bool +connectPool DBStore {dbConnstr, dbSchema, dbPoolSize, dbPool, dbClosed} createSchema = uninterruptibleMask_ $ do + (conn, dbNew) <- connectDB dbConnstr dbSchema createSchema -- TODO [postgres] analogue for dbBusyLoop? + conns <- replicateM (dbPoolSize - 1) $ fst <$> connectDB dbConnstr dbSchema False + mapM_ (atomically . writeTBQueue dbPool) (conn : conns) + atomically $ writeTVar dbClosed False + pure dbNew connectDB :: ByteString -> ByteString -> Bool -> IO (DB.Connection, Bool) connectDB connstr schema createSchema = do @@ -97,29 +110,18 @@ doesSchemaExist db schema = do (Only schema) pure schemaExists --- can share with SQLite closeDBStore :: DBStore -> IO () -closeDBStore st@DBStore {dbClosed} = - ifM (readTVarIO dbClosed) (putStrLn "closeDBStore: already closed") $ - withConnection st $ \conn -> do - DB.close conn - atomically $ writeTVar dbClosed True - -openPostgresStore_ :: DBStore -> IO () -openPostgresStore_ DBStore {dbConnstr, dbSchema, dbConnection, dbClosed} = - bracketOnError - (takeMVar dbConnection) - (tryPutMVar dbConnection) - $ \_dbConn -> do - (dbConn, _dbNew) <- connectDB dbConnstr dbSchema False - atomically $ writeTVar dbClosed False - putMVar dbConnection dbConn +closeDBStore DBStore {dbPool, dbPoolSize, dbClosed} = + ifM (readTVarIO dbClosed) (putStrLn "closeDBStore: already closed") $ uninterruptibleMask_ $ do + replicateM_ dbPoolSize $ atomically $ readTBQueue dbPool + atomically $ writeTVar dbClosed True reopenDBStore :: DBStore -> IO () -reopenDBStore st@DBStore {dbClosed} = - ifM (readTVarIO dbClosed) open (putStrLn "reopenDBStore: already opened") - where - open = openPostgresStore_ st +reopenDBStore st = + ifM + (readTVarIO $ dbClosed st) + (void $ connectPool st False) + (putStrLn "reopenDBStore: already opened") -- not used with postgres client (used for ExecAgentStoreSQL, ExecChatStoreSQL) execSQL :: PSQL.Connection -> Text -> IO [Text] diff --git a/src/Simplex/Messaging/Agent/Store/Postgres/Common.hs b/src/Simplex/Messaging/Agent/Store/Postgres/Common.hs index be14d1a5b..ee94825a4 100644 --- a/src/Simplex/Messaging/Agent/Store/Postgres/Common.hs +++ b/src/Simplex/Messaging/Agent/Store/Postgres/Common.hs @@ -1,4 +1,8 @@ +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TupleSections #-} module Simplex.Messaging.Agent.Store.Postgres.Common ( DBStore (..), @@ -11,16 +15,22 @@ module Simplex.Messaging.Agent.Store.Postgres.Common ) where +import Control.Concurrent.MVar +import Control.Concurrent.STM +import Control.Exception (bracket) import Data.ByteString (ByteString) import qualified Database.PostgreSQL.Simple as PSQL -import UnliftIO.MVar -import UnliftIO.STM +import Numeric.Natural -- TODO [postgres] use log_min_duration_statement instead of custom slow queries (SQLite's Connection type) data DBStore = DBStore { dbConnstr :: ByteString, dbSchema :: ByteString, - dbConnection :: MVar PSQL.Connection, + dbPoolSize :: Int, + dbPool :: TBQueue PSQL.Connection, + -- MVar is needed for fair pool distribution, without STM retry contention. + -- Only one thread can be blocked on STM read. + dbSem :: MVar (), dbClosed :: TVar Bool, dbNew :: Bool } @@ -28,15 +38,16 @@ data DBStore = DBStore data DBOpts = DBOpts { connstr :: ByteString, schema :: ByteString, + poolSize :: Natural, createSchema :: Bool } deriving (Show) --- TODO [postgres] connection pool withConnectionPriority :: DBStore -> Bool -> (PSQL.Connection -> IO a) -> IO a -withConnectionPriority DBStore {dbConnection} _priority action = - withMVar dbConnection action -{-# INLINE withConnectionPriority #-} +withConnectionPriority DBStore {dbPool, dbSem} _priority = + bracket + (withMVar dbSem $ \_ -> atomically $ readTBQueue dbPool) + (atomically . writeTBQueue dbPool) withConnection :: DBStore -> (PSQL.Connection -> IO a) -> IO a withConnection st = withConnectionPriority st False diff --git a/src/Simplex/Messaging/Client.hs b/src/Simplex/Messaging/Client.hs index b1b5bfa53..df12e5fce 100644 --- a/src/Simplex/Messaging/Client.hs +++ b/src/Simplex/Messaging/Client.hs @@ -145,7 +145,7 @@ import qualified Simplex.Messaging.TMap as TM import Simplex.Messaging.Transport import Simplex.Messaging.Transport.Client (SocksAuth (..), SocksProxyWithAuth (..), TransportClientConfig (..), TransportHost (..), defaultSMPPort, defaultTcpConnectTimeout, runTransportClient) import Simplex.Messaging.Transport.KeepAlive -import Simplex.Messaging.Util (bshow, diffToMicroseconds, ifM, liftEitherWith, raceAny_, threadDelay', tshow, whenM) +import Simplex.Messaging.Util (bshow, diffToMicroseconds, ifM, liftEitherWith, raceAny_, threadDelay', tryWriteTBQueue, tshow, whenM) import Simplex.Messaging.Version import System.Mem.Weak (Weak, deRefWeak) import System.Timeout (timeout) @@ -1121,7 +1121,7 @@ sendProtocolCommand_ c@ProtocolClient {client_ = PClient {sndQ}, thParams = THan nonBlockingWriteTBQueue :: TBQueue a -> a -> IO () nonBlockingWriteTBQueue q x = do - sent <- atomically $ ifM (isFullTBQueue q) (pure False) (writeTBQueue q x $> True) + sent <- atomically $ tryWriteTBQueue q x unless sent $ void $ forkIO $ atomically $ writeTBQueue q x getResponse :: ProtocolClient v err msg -> Maybe Int -> Request err msg -> IO (Response err msg) diff --git a/src/Simplex/Messaging/Server.hs b/src/Simplex/Messaging/Server.hs index e1d4d7861..67e8e227e 100644 --- a/src/Simplex/Messaging/Server.hs +++ b/src/Simplex/Messaging/Server.hs @@ -354,7 +354,7 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg, startOpt mapM_ (queueEvts qEvts) . join . IM.lookup cId =<< readTVarIO cls queueEvts qEvts (AClient _ _ c@Client {connected, sndQ = q}) = whenM (readTVarIO connected) $ do - sent <- atomically $ ifM (isFullTBQueue q) (pure False) (writeTBQueue q ts $> True) + sent <- atomically $ tryWriteTBQueue q ts if sent then updateEndStats else -- if queue is full it can block diff --git a/src/Simplex/Messaging/Server/Main.hs b/src/Simplex/Messaging/Server/Main.hs index 56f6cc414..4be4594d4 100644 --- a/src/Simplex/Messaging/Server/Main.hs +++ b/src/Simplex/Messaging/Server/Main.hs @@ -33,6 +33,7 @@ import qualified Data.Text as T import Data.Text.Encoding (decodeLatin1, encodeUtf8) import qualified Data.Text.IO as T import Network.Socket (HostName) +import Numeric.Natural (Natural) import Options.Applicative import Simplex.Messaging.Agent.Protocol (connReqUriP') import Simplex.Messaging.Agent.Store.Postgres (checkSchemaExists) @@ -236,8 +237,14 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath = DBOpts { connstr = either (const defaultDBConnStr) encodeUtf8 $ lookupValue "STORE_LOG" "db_connection" ini, schema = either (const defaultDBSchema) encodeUtf8 $ lookupValue "STORE_LOG" "db_schema" ini, + poolSize = either (const defaultDBPoolSize) (read . T.unpack) $ lookupValue "STORE_LOG" "db_pool_size" ini, createSchema = False } + dbOptsIniContent :: DBOpts -> Text + dbOptsIniContent DBOpts {connstr, schema, poolSize } = + (optDisabled' (connstr == defaultDBConnStr) <> "db_connection: " <> safeDecodeUtf8 connstr <> "\n") + <> (optDisabled' (schema == defaultDBSchema) <> "db_schema: " <> safeDecodeUtf8 schema <> "\n") + <> (optDisabled' (poolSize == defaultDBPoolSize) <> "db_pool_size: " <> tshow poolSize <> "\n\n") httpsCertFile = combine cfgPath "web.crt" httpsKeyFile = combine cfgPath "web.key" defaultStaticPath = combine logPath "www" @@ -320,8 +327,7 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath = \# `database`- PostgreSQL databass (requires `store_messages: journal`).\n\ \store_queues: memory\n\n\ \# Database connection settings for PostgreSQL database (`store_queues: database`).\n" - <> (optDisabled dbOptions <> "db_connection: " <> safeDecodeUtf8 (maybe defaultDBConnStr connstr dbOptions) <> "\n") - <> (optDisabled dbOptions <> "db_schema: " <> safeDecodeUtf8 (maybe defaultDBSchema schema dbOptions) <> "\n\n") + <> dbOptsIniContent dbOptions <> "# Message storage mode: `memory` or `journal`.\n\ \store_messages: memory\n\n\ \# When store_messages is `memory`, undelivered messages are optionally saved and restored\n\ @@ -626,6 +632,9 @@ defaultDBConnStr = "postgresql://smp@/smp_server_store" defaultDBSchema :: ByteString defaultDBSchema = "smp_server" +defaultDBPoolSize :: Natural +defaultDBPoolSize = 10 + defaultControlPort :: Int defaultControlPort = 5224 @@ -712,7 +721,12 @@ serverPublicInfo ini = serverInfo <$!> infoValue "source_code" (_, _, pkURI, pkFingerprint) -> Just ServerContactAddress {simplex, email, pgp = PGPKey <$> pkURI <*> pkFingerprint} optDisabled :: Maybe a -> Text -optDisabled p = if isNothing p then "# " else "" +optDisabled = optDisabled' . isNothing +{-# INLINE optDisabled #-} + +optDisabled' :: Bool -> Text +optDisabled' cond = if cond then "# " else "" +{-# INLINE optDisabled' #-} validCountryValue :: String -> String -> Either String Text validCountryValue field s @@ -738,7 +752,7 @@ data StoreCmd = SCImport | SCExport | SCDelete data InitOptions = InitOptions { enableStoreLog :: Bool, - dbOptions :: Maybe DBOpts, + dbOptions :: DBOpts, dbMigrateUp :: Bool, logStats :: Bool, signAlgorithm :: SignAlgorithm, @@ -780,7 +794,8 @@ cliCommandP cfgPath logPath iniFile = <> short 'l' <> help "Enable store log for persistence" ) - dbOptions <- optional dbOptsP + dbOptions <- dbOptsP + -- TODO [postgresql] remove dbMigrateUp <- switch ( long "db-migrate-up" @@ -963,7 +978,16 @@ cliCommandP cfgPath logPath iniFile = <> value defaultDBSchema <> showDefault ) - pure DBOpts {connstr, schema, createSchema = False} + poolSize <- + option + auto + ( long "pool-size" + <> metavar "POOL_SIZE" + <> help "Database pool size" + <> value defaultDBPoolSize + <> showDefault + ) + pure DBOpts {connstr, schema, poolSize, createSchema = False} parseConfirmMigrations :: ReadM MigrationConfirmation parseConfirmMigrations = eitherReader $ \case "up" -> Right MCYesUp diff --git a/src/Simplex/Messaging/Server/QueueStore/Postgres.hs b/src/Simplex/Messaging/Server/QueueStore/Postgres.hs index edb9f3dc0..376858ce5 100644 --- a/src/Simplex/Messaging/Server/QueueStore/Postgres.hs +++ b/src/Simplex/Messaging/Server/QueueStore/Postgres.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DerivingStrategies #-} @@ -37,11 +38,9 @@ import Simplex.Messaging.Agent.Client (withLockMap) import Simplex.Messaging.Agent.Lock (Lock) import Simplex.Messaging.Agent.Store.Postgres (createDBStore) import Simplex.Messaging.Agent.Store.Postgres.Common -import Simplex.Messaging.Agent.Store.Postgres.DB (FromField (..), ToField (..), blobFieldDecoder) +import Simplex.Messaging.Agent.Store.Postgres.DB (FromField (..), ToField (..)) import qualified Simplex.Messaging.Agent.Store.Postgres.DB as DB import Simplex.Messaging.Agent.Store.Shared (MigrationConfirmation) -import qualified Simplex.Messaging.Crypto as C -import Simplex.Messaging.Encoding.String import Simplex.Messaging.Protocol import Simplex.Messaging.Server.QueueStore import Simplex.Messaging.Server.QueueStore.Postgres.Migrations (serverMigrations) @@ -52,6 +51,11 @@ import qualified Simplex.Messaging.TMap as TM import Simplex.Messaging.Util (firstRow, ifM, tshow, ($>>), ($>>=), (<$$), (<$$>)) import System.Exit (exitFailure) import System.IO (hFlush, stdout) +#if !defined(dbPostgres) +import Simplex.Messaging.Agent.Store.Postgres.DB (blobFieldDecoder) +import qualified Simplex.Messaging.Crypto as C +import Simplex.Messaging.Encoding.String +#endif data PostgresQueueStore q = PostgresQueueStore { dbStore :: DBStore, @@ -367,6 +371,7 @@ instance ToField EntityId where toField (EntityId s) = toField $ Binary s deriving newtype instance FromField EntityId +#if !defined(dbPostgres) instance ToField (C.DhSecret 'C.X25519) where toField = toField . Binary . C.dhBytes' instance FromField (C.DhSecret 'C.X25519) where fromField = blobFieldDecoder strDecode @@ -374,3 +379,4 @@ instance FromField (C.DhSecret 'C.X25519) where fromField = blobFieldDecoder str instance ToField C.APublicAuthKey where toField = toField . Binary . C.encodePubKey instance FromField C.APublicAuthKey where fromField = blobFieldDecoder C.decodePubKey +#endif diff --git a/src/Simplex/Messaging/Util.hs b/src/Simplex/Messaging/Util.hs index 240a6ba5a..2d92b4b5e 100644 --- a/src/Simplex/Messaging/Util.hs +++ b/src/Simplex/Messaging/Util.hs @@ -156,6 +156,13 @@ mapAccumLM_NonEmpty mapAccumLM_NonEmpty f s (x :| xs) = [(s2, x' :| xs') | (s1, x') <- f s x, (s2, xs') <- mapAccumLM_List f s1 xs] +tryWriteTBQueue :: TBQueue a -> a -> STM Bool +tryWriteTBQueue q a = do + full <- isFullTBQueue q + unless full $ writeTBQueue q a + pure $ not full +{-# INLINE tryWriteTBQueue #-} + catchAll :: IO a -> (E.SomeException -> IO a) -> IO a catchAll = E.catch {-# INLINE catchAll #-} diff --git a/tests/SMPClient.hs b/tests/SMPClient.hs index e19d81f76..28639b0a5 100644 --- a/tests/SMPClient.hs +++ b/tests/SMPClient.hs @@ -69,6 +69,7 @@ testStoreDBOpts = DBOpts { connstr = testServerDBConnstr, schema = "smp_server", + poolSize = 3, createSchema = True } diff --git a/tests/ServerTests.hs b/tests/ServerTests.hs index 6c2199795..5160070f0 100644 --- a/tests/ServerTests.hs +++ b/tests/ServerTests.hs @@ -1019,7 +1019,8 @@ testMsgNOTExpireOnInterval = testBlockMessageQueue :: SpecWith (ATransport, AStoreType) testBlockMessageQueue = - it "should return BLOCKED error when queue is blocked" $ \(at@(ATransport (t :: TProxy c)), msType) -> do + -- TODO [postgres] + xit "should return BLOCKED error when queue is blocked" $ \(at@(ATransport (t :: TProxy c)), msType) -> do g <- C.newRandom (rId, sId) <- withSmpServerStoreLogOnMS at msType testPort $ runTest t $ \h -> do (rPub, rKey) <- atomically $ C.generateAuthKeyPair C.SEd448 g @@ -1028,6 +1029,7 @@ testBlockMessageQueue = (rId1, NoEntity) #== "creates queue" pure (rId, sId) + -- TODO [postgres] block via control port withFile testStoreLogFile AppendMode $ \h -> B.hPutStrLn h $ strEncode $ BlockQueue rId $ BlockingInfo BRContent withSmpServerStoreLogOnMS at msType testPort $ runTest t $ \h -> do From 80a070a8ea83da53174cd94b3438a6b0532b3670 Mon Sep 17 00:00:00 2001 From: Evgeny Date: Wed, 26 Feb 2025 11:43:08 +0000 Subject: [PATCH 03/14] smp server: update STM cache only after PostgreSQL update (#1470) * refactor journal store * update postgres store methods to update STM cache only after DB update * todos * drop Co-authored-by: spaced4ndy <8711996+spaced4ndy@users.noreply.github.com> * fix GHC 8.10.7 --------- Co-authored-by: spaced4ndy <8711996+spaced4ndy@users.noreply.github.com> --- src/Simplex/Messaging/Server.hs | 2 - src/Simplex/Messaging/Server/CLI.hs | 23 +- src/Simplex/Messaging/Server/Env/STM.hs | 4 + src/Simplex/Messaging/Server/Main.hs | 9 +- .../Messaging/Server/MsgStore/Journal.hs | 77 ++---- .../Messaging/Server/QueueStore/Postgres.hs | 243 ++++++++---------- 6 files changed, 162 insertions(+), 196 deletions(-) diff --git a/src/Simplex/Messaging/Server.hs b/src/Simplex/Messaging/Server.hs index 67e8e227e..b0edfa2dd 100644 --- a/src/Simplex/Messaging/Server.hs +++ b/src/Simplex/Messaging/Server.hs @@ -1829,8 +1829,6 @@ processServerMessages StartOptions {skipWarnings} = do Just f -> ifM (doesFileExist f) (Just <$> importMessages False ms f old_ skipWarnings) (pure Nothing) Nothing -> pure Nothing AMS _ SMSJournal ms -> processJournalMessages old_ expire ms - -- TODO [postgres] is it needed? - -- AMS (SType SQSPostgres SMSJournal) ms -> processJournalMessages old_ expire ms processJournalMessages :: forall s. Maybe Int64 -> Bool -> JournalMsgStore s -> IO (Maybe MessageStats) processJournalMessages old_ expire ms | expire = Just <$> case old_ of diff --git a/src/Simplex/Messaging/Server/CLI.hs b/src/Simplex/Messaging/Server/CLI.hs index 6dd7d184a..3e52d2001 100644 --- a/src/Simplex/Messaging/Server/CLI.hs +++ b/src/Simplex/Messaging/Server/CLI.hs @@ -27,6 +27,7 @@ import qualified Data.X509.File as XF import Data.X509.Validation (Fingerprint (..)) import Network.Socket (HostName, ServiceName) import Options.Applicative +import Simplex.Messaging.Agent.Store.Postgres.Common (DBOpts (..)) import Simplex.Messaging.Encoding.String import Simplex.Messaging.Protocol (ProtoServerWithAuth (..), ProtocolServer (..), ProtocolTypeI) import Simplex.Messaging.Server.Env.STM (AServerStoreCfg (..), ServerStoreCfg (..), StorePaths (..)) @@ -297,17 +298,21 @@ printServerConfig transports logFile = do putStrLn $ case logFile of Just f -> "Store log: " <> f _ -> "Store log disabled." - forM_ transports $ \(p, ATransport t, addHTTP) -> do - let descr = p <> " (" <> transportName t <> ")..." - putStrLn $ "Serving SMP protocol on port " <> descr - when addHTTP $ putStrLn $ "Serving static site on port " <> descr + printServerTransports transports + +printServerTransports :: [(ServiceName, ATransport, AddHTTP)] -> IO () +printServerTransports = mapM_ $ \(p, ATransport t, addHTTP) -> do + let descr = p <> " (" <> transportName t <> ")..." + putStrLn $ "Serving SMP protocol on port " <> descr + when addHTTP $ putStrLn $ "Serving static site on port " <> descr --- TODO [postgres] printSMPServerConfig :: [(ServiceName, ATransport, AddHTTP)] -> AServerStoreCfg -> IO () -printSMPServerConfig transports (ASSCfg _ _ cfg) = printServerConfig transports $ case cfg of - SSCMemory sp_ -> (\StorePaths {storeLogFile} -> storeLogFile) <$> sp_ - SSCMemoryJournal {storeLogFile} -> Just storeLogFile - SSCDatabaseJournal {} -> Just "postgres database" +printSMPServerConfig transports (ASSCfg _ _ cfg) = case cfg of + SSCMemory sp_ -> printServerConfig transports $ (\StorePaths {storeLogFile} -> storeLogFile) <$> sp_ + SSCMemoryJournal {storeLogFile} -> printServerConfig transports $ Just storeLogFile + SSCDatabaseJournal {storeDBOpts = DBOpts {connstr, schema}} -> do + B.putStrLn $ "PostgreSQL database: " <> connstr <> ", schema: " <> schema + printServerTransports transports deleteDirIfExists :: FilePath -> IO () deleteDirIfExists path = whenM (doesDirectoryExist path) $ removeDirectoryRecursive path diff --git a/src/Simplex/Messaging/Server/Env/STM.hs b/src/Simplex/Messaging/Server/Env/STM.hs index b09e0549c..da8c22b1a 100644 --- a/src/Simplex/Messaging/Server/Env/STM.hs +++ b/src/Simplex/Messaging/Server/Env/STM.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DuplicateRecordFields #-} @@ -12,6 +13,9 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeOperators #-} +#if __GLASGOW_HASKELL__ == 810 +{-# LANGUAGE UndecidableInstances #-} +#endif module Simplex.Messaging.Server.Env.STM where diff --git a/src/Simplex/Messaging/Server/Main.hs b/src/Simplex/Messaging/Server/Main.hs index 4be4594d4..388a6a069 100644 --- a/src/Simplex/Messaging/Server/Main.hs +++ b/src/Simplex/Messaging/Server/Main.hs @@ -126,7 +126,6 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath = confirmOrExit ("WARNING: journal directory " <> storeMsgsJournalDir <> " will be exported to message log file " <> storeMsgsFilePath) "Journal not exported" - -- TODO [postgres] ms <- newJournalMsgStore MQStoreCfg readQueueStore True (mkQueue ms) storeLogFile $ stmQueueStore ms exportMessages True ms storeMsgsFilePath False @@ -195,7 +194,13 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath = Right (ASType SQSPostgres SMSJournal) -> "store_queues set to `database`, update it to `memory` in INI file." Right (ASType SQSMemory _) -> "store_queues set to `memory`, start the server" Left e -> e <> ", configure storage correctly" - SCDelete -> undefined -- TODO [postgres] + SCDelete + | not schemaExists -> do + putStrLn $ "Schema " <> B.unpack schema <> " does not exist in PostrgreSQL database: " <> B.unpack connstr + exitFailure + | otherwise -> do + putStrLn $ "Open database: psql " <> B.unpack connstr + putStrLn $ "Delete schema: DROP SCHEMA " <> B.unpack schema <> " CASCADE;" where withIniFile a = doesFileExist iniFile >>= \case diff --git a/src/Simplex/Messaging/Server/MsgStore/Journal.hs b/src/Simplex/Messaging/Server/MsgStore/Journal.hs index 8ad63e162..32fefb386 100644 --- a/src/Simplex/Messaging/Server/MsgStore/Journal.hs +++ b/src/Simplex/Messaging/Server/MsgStore/Journal.hs @@ -2,6 +2,7 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} @@ -11,6 +12,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeApplications #-} @@ -94,8 +96,18 @@ data JournalMsgStore s = JournalMsgStore } data QStore (s :: QSType) where - MQStore :: STMQueueStore (JournalQueue 'QSMemory) -> QStore 'QSMemory - PQStore :: PostgresQueueStore (JournalQueue 'QSPostgres) -> QStore 'QSPostgres + MQStore :: QStoreType 'QSMemory -> QStore 'QSMemory + PQStore :: QStoreType 'QSPostgres -> QStore 'QSPostgres + +type family QStoreType s where + QStoreType 'QSMemory = STMQueueStore (JournalQueue 'QSMemory) + QStoreType 'QSPostgres = PostgresQueueStore (JournalQueue 'QSPostgres) + +withQS :: (QueueStoreClass (JournalQueue s) (QStoreType s) => QStoreType s -> r) -> QStore s -> r +withQS f = \case + MQStore st -> f st + PQStore st -> f st +{-# INLINE withQS #-} stmQueueStore :: JournalMsgStore 'QSMemory -> STMQueueStore (JournalQueue 'QSMemory) stmQueueStore st = case queueStore_ st of @@ -279,68 +291,31 @@ instance QueueStoreClass (JournalQueue s) (QStore s) where MQStoreCfg -> MQStore <$> newQueueStore @(JournalQueue s) () PQStoreCfg dbOpts confirmMigrations -> PQStore <$> newQueueStore @(JournalQueue s) (dbOpts, confirmMigrations) - loadedQueues = \case - MQStore st -> loadedQueues st - PQStore st -> loadedQueues st + loadedQueues = withQS loadedQueues {-# INLINE loadedQueues #-} - - queueCounts = \case - -- TODO [postgres] combine these functions - MQStore st -> queueCounts @(JournalQueue s) st - PQStore st -> queueCounts @(JournalQueue s) st + queueCounts = withQS (queueCounts @(JournalQueue s)) {-# INLINE queueCounts #-} - - addQueue_ = \case - MQStore st -> addQueue_ st - PQStore st -> addQueue_ st + addQueue_ = withQS addQueue_ {-# INLINE addQueue_ #-} - - getQueue_ = \case - MQStore st -> getQueue_ st - PQStore st -> getQueue_ st + getQueue_ = withQS getQueue_ {-# INLINE getQueue_ #-} - - secureQueue = \case - MQStore st -> secureQueue st - PQStore st -> secureQueue st + secureQueue = withQS secureQueue {-# INLINE secureQueue #-} - - addQueueNotifier = \case - MQStore st -> addQueueNotifier st - PQStore st -> addQueueNotifier st + addQueueNotifier = withQS addQueueNotifier {-# INLINE addQueueNotifier #-} - - deleteQueueNotifier = \case - MQStore st -> deleteQueueNotifier st - PQStore st -> deleteQueueNotifier st + deleteQueueNotifier = withQS deleteQueueNotifier {-# INLINE deleteQueueNotifier #-} - - suspendQueue = \case - MQStore st -> suspendQueue st - PQStore st -> suspendQueue st + suspendQueue = withQS suspendQueue {-# INLINE suspendQueue #-} - - blockQueue = \case - MQStore st -> blockQueue st - PQStore st -> blockQueue st + blockQueue = withQS blockQueue {-# INLINE blockQueue #-} - - unblockQueue = \case - MQStore st -> unblockQueue st - PQStore st -> unblockQueue st + unblockQueue = withQS unblockQueue {-# INLINE unblockQueue #-} - - updateQueueTime = \case - MQStore st -> updateQueueTime st - PQStore st -> updateQueueTime st + updateQueueTime = withQS updateQueueTime {-# INLINE updateQueueTime #-} - - deleteStoreQueue = \case - MQStore st -> deleteStoreQueue st - PQStore st -> deleteStoreQueue st + deleteStoreQueue = withQS deleteStoreQueue {-# INLINE deleteStoreQueue #-} - instance MsgStoreClass (JournalMsgStore s) where type StoreMonad (JournalMsgStore s) = StoreIO s type QueueStore (JournalMsgStore s) = QStore s diff --git a/src/Simplex/Messaging/Server/QueueStore/Postgres.hs b/src/Simplex/Messaging/Server/QueueStore/Postgres.hs index 376858ce5..8988cb3f3 100644 --- a/src/Simplex/Messaging/Server/QueueStore/Postgres.hs +++ b/src/Simplex/Messaging/Server/QueueStore/Postgres.hs @@ -18,12 +18,19 @@ {-# LANGUAGE TypeOperators #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -module Simplex.Messaging.Server.QueueStore.Postgres where +module Simplex.Messaging.Server.QueueStore.Postgres + ( PostgresQueueStore (..), + batchInsertQueues, + foldQueueRecs, + ) +where -import Control.Concurrent.STM import qualified Control.Exception as E import Control.Logger.Simple import Control.Monad +import Control.Monad.Except +import Control.Monad.IO.Class +import Control.Monad.Trans.Except import Data.Bitraversable (bimapM) import Data.Functor (($>)) import Data.Int (Int64) @@ -44,13 +51,14 @@ import Simplex.Messaging.Agent.Store.Shared (MigrationConfirmation) import Simplex.Messaging.Protocol import Simplex.Messaging.Server.QueueStore import Simplex.Messaging.Server.QueueStore.Postgres.Migrations (serverMigrations) -import Simplex.Messaging.Server.QueueStore.STM (readQueueRecIO, setStatus, withQueueRec) +import Simplex.Messaging.Server.QueueStore.STM (readQueueRecIO) import Simplex.Messaging.Server.QueueStore.Types import Simplex.Messaging.TMap (TMap) import qualified Simplex.Messaging.TMap as TM -import Simplex.Messaging.Util (firstRow, ifM, tshow, ($>>), ($>>=), (<$$), (<$$>)) +import Simplex.Messaging.Util (firstRow, ifM, tshow, (<$$>)) import System.Exit (exitFailure) import System.IO (hFlush, stdout) +import UnliftIO.STM #if !defined(dbPostgres) import Simplex.Messaging.Agent.Store.Postgres.DB (blobFieldDecoder) import qualified Simplex.Messaging.Crypto as C @@ -105,17 +113,14 @@ instance StoreQueueClass q => QueueStoreClass q (PostgresQueueStore q) where addQueue_ :: PostgresQueueStore q -> (RecipientId -> QueueRec -> IO q) -> RecipientId -> QueueRec -> IO (Either ErrorType q) addQueue_ st mkQ rId qr = do sq <- mkQ rId qr - withQueueLock sq "addQueue_" $ - addDB $>> add sq + withQueueLock sq "addQueue_" $ runExceptT $ do + withDB "addQueue_" st $ \db -> + E.try (insertQueueDB db rId qr) >>= bimapM handleDuplicate pure + atomically $ TM.insert rId sq queues + atomically $ TM.insert (senderId qr) rId senders + pure sq where PostgresQueueStore {queues, senders} = st - addDB = - withDB "addQueue_" st $ \db -> - E.try (insertQueueDB db rId qr) >>= bimapM handleDuplicate pure - add sq = do - atomically $ TM.insert rId sq queues - atomically $ TM.insert (senderId qr) rId senders - pure $ Right sq -- 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] @@ -132,17 +137,18 @@ instance StoreQueueClass q => QueueStoreClass q (PostgresQueueStore q) where loadRcvQueue = loadQueue " WHERE q.recipient_id = ?" $ \_ -> pure () loadSndQueue = loadQueue " WHERE q.sender_id = ?" $ \rId -> TM.insert qId rId senders loadNtfQueue = loadQueue " WHERE n.notifier_id = ?" $ \_ -> pure () -- do NOT cache ref - ntf subscriptions are rare - loadQueue condition insertRef = - loadQueueRec $>>= \(rId, qRec) -> do - sq <- mkQ rId qRec - atomically $ - -- checking the cache again for concurrent reads - TM.lookup rId queues >>= \case - Just sq' -> pure $ Right sq' - Nothing -> do - insertRef rId - TM.insert rId sq queues - pure $ Right sq + loadQueue condition insertRef = runExceptT $ do + (rId, qRec) <- loadQueueRec + sq <- liftIO $ mkQ rId qRec + 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 + insertRef rId + TM.insert rId sq queues + pure sq where loadQueueRec = withDB "getQueue_" st $ \db -> firstRow rowToQueueRec AUTH $ @@ -150,125 +156,90 @@ instance StoreQueueClass q => QueueStoreClass q (PostgresQueueStore q) where secureQueue :: PostgresQueueStore q -> q -> SndPublicAuthKey -> IO (Either ErrorType ()) secureQueue st sq sKey = - withQueueLock sq "secureQueue" $ - readQueueRecIO qr - $>>= \q -> verify q - $>> secureDB - $>> secure q + withQueueDB sq "secureQueue" $ \q -> do + verify q + withDB' "secureQueue" st $ \db -> + DB.execute db "UPDATE msg_queues SET sender_key = ? WHERE recipient_id = ?" (sKey, recipientId sq) + atomically $ writeTVar (queueRec sq) $ Just q {senderKey = Just sKey} where - qr = queueRec sq - verify q = pure $ case senderKey q of - Just k | sKey /= k -> Left AUTH - _ -> Right () - secureDB = - withDB' "secureQueue" st $ \db -> - DB.execute db "UPDATE msg_queues SET sender_key = ? WHERE recipient_id = ?" (sKey, recipientId sq) - secure q = do - atomically $ writeTVar qr $ Just q {senderKey = Just sKey} - pure $ Right () + verify q = case senderKey q of + Just k | sKey /= k -> throwE AUTH + _ -> pure () addQueueNotifier :: PostgresQueueStore q -> q -> NtfCreds -> IO (Either ErrorType (Maybe NotifierId)) addQueueNotifier st sq ntfCreds@NtfCreds {notifierId = nId, notifierKey, rcvNtfDhSecret} = - withQueueLock sq "addQueueNotifier" $ - readQueueRecIO qr $>>= add + withQueueDB sq "addQueueNotifier" $ \q -> + ExceptT $ withLockMap (notifierLocks st) nId "addQueueNotifier" $ + ifM (TM.memberIO nId notifiers) (pure $ Left DUPLICATE_) $ runExceptT $ do + withDB "addQueueNotifier" st $ \db -> + E.try (insert db) >>= bimapM handleDuplicate pure + nId_ <- forM (notifier q) $ \NtfCreds {notifierId} -> atomically (TM.delete notifierId notifiers) $> notifierId + let !q' = q {notifier = Just ntfCreds} + atomically $ writeTVar (queueRec sq) $ Just q' + -- cache queue notifier ID – after notifier is added ntf server will likely subscribe + atomically $ TM.insert nId rId notifiers + pure nId_ where PostgresQueueStore {notifiers} = st rId = recipientId sq - qr = queueRec sq - add q = - withLockMap (notifierLocks st) nId "addQueueNotifier" $ - ifM (TM.memberIO nId notifiers) (pure $ Left DUPLICATE_) $ - addDB $>> do - nId_ <- forM (notifier q) $ \NtfCreds {notifierId} -> atomically (TM.delete notifierId notifiers) $> notifierId - let !q' = q {notifier = Just ntfCreds} - atomically $ writeTVar qr $ Just q' - -- cache queue notifier ID – after notifier is added ntf server will likely subscribe - atomically $ TM.insert nId rId notifiers - pure $ Right nId_ - addDB = - withDB "addQueueNotifier" st $ \db -> - E.try (insert db) >>= bimapM handleDuplicate pure - where - -- TODO [postgres] test how this query works with duplicate recipient_id (updates) and notifier_id (fails) - insert db = - DB.execute - db - [sql| - INSERT INTO msg_notifiers (recipient_id, notifier_id, notifier_key, rcv_ntf_dh_secret) - VALUES (?, ?, ?, ?) - ON CONFLICT (recipient_id) DO UPDATE - SET notifier_id = EXCLUDED.notifier_id, - notifier_key = EXCLUDED.notifier_key, - rcv_ntf_dh_secret = EXCLUDED.rcv_ntf_dh_secret - |] - (rId, nId, notifierKey, rcvNtfDhSecret) + -- TODO [postgres] test how this query works with duplicate recipient_id (updates) and notifier_id (fails) + insert db = + DB.execute + db + [sql| + INSERT INTO msg_notifiers (recipient_id, notifier_id, notifier_key, rcv_ntf_dh_secret) + VALUES (?, ?, ?, ?) + ON CONFLICT (recipient_id) DO UPDATE + SET notifier_id = EXCLUDED.notifier_id, + notifier_key = EXCLUDED.notifier_key, + rcv_ntf_dh_secret = EXCLUDED.rcv_ntf_dh_secret + |] + (rId, nId, notifierKey, rcvNtfDhSecret) deleteQueueNotifier :: PostgresQueueStore q -> q -> IO (Either ErrorType (Maybe NotifierId)) deleteQueueNotifier st sq = - withQueueLock sq "deleteQueueNotifier" $ - readQueueRecIO qr $>>= fmap sequence . delete - where - qr = queueRec sq - delete :: QueueRec -> IO (Maybe (Either ErrorType NotifierId)) - delete q = forM (notifier q) $ \NtfCreds {notifierId = nId} -> - withLockMap (notifierLocks st) nId "deleteQueueNotifier" $ do - deleteDB nId $>> do - atomically $ TM.delete nId $ notifiers st - atomically $ writeTVar qr $! Just q {notifier = Nothing} - pure $ Right nId - deleteDB nId = - withDB' "deleteQueueNotifier" st $ \db -> - DB.execute db "DELETE FROM msg_notifiers WHERE notifier_id = ?" (Only nId) + withQueueDB sq "deleteQueueNotifier" $ \q -> + ExceptT $ fmap sequence $ forM (notifier q) $ \NtfCreds {notifierId = nId} -> + withLockMap (notifierLocks st) nId "deleteQueueNotifier" $ runExceptT $ do + withDB' "deleteQueueNotifier" st $ \db -> + DB.execute db "DELETE FROM msg_notifiers WHERE notifier_id = ?" (Only nId) + atomically $ TM.delete nId $ notifiers st + atomically $ writeTVar (queueRec sq) $ Just q {notifier = Nothing} + pure nId - -- TODO [postgres] only update STM on DB success suspendQueue :: PostgresQueueStore q -> q -> IO (Either ErrorType ()) - suspendQueue st sq = - setStatus (queueRec sq) EntityOff - $>> setStatusDB "suspendQueue" st (recipientId sq) EntityOff + suspendQueue st sq = setStatusDB "suspendQueue" st sq EntityOff - -- TODO [postgres] only update STM on DB success blockQueue :: PostgresQueueStore q -> q -> BlockingInfo -> IO (Either ErrorType ()) - blockQueue st sq info = - setStatus (queueRec sq) (EntityBlocked info) - $>> setStatusDB "blockQueue" st (recipientId sq) (EntityBlocked info) + blockQueue st sq info = setStatusDB "blockQueue" st sq (EntityBlocked info) - -- TODO [postgres] only update STM on DB success unblockQueue :: PostgresQueueStore q -> q -> IO (Either ErrorType ()) - unblockQueue st sq = - setStatus (queueRec sq) EntityActive - $>> setStatusDB "unblockQueue" st (recipientId sq) EntityActive - - -- TODO [postgres] only update STM on DB success + unblockQueue st sq = setStatusDB "unblockQueue" st sq EntityActive + updateQueueTime :: PostgresQueueStore q -> q -> RoundedSystemTime -> IO (Either ErrorType QueueRec) - updateQueueTime st sq t = withQueueRec qr update $>>= updateDB - where - qr = queueRec sq - update q@QueueRec {updatedAt} - | updatedAt == Just t = pure (q, False) - | otherwise = - let !q' = q {updatedAt = Just t} - in (writeTVar qr $! Just q') $> (q', True) - updateDB (q, changed) - | changed = q <$$ withDB' "updateQueueTime" st (\db -> DB.execute db "UPDATE msg_queues SET updated_at = ? WHERE recipient_id = ?" (t, Binary $ unEntityId $ recipientId sq)) - | otherwise = pure $ Right q + updateQueueTime st sq t = + withQueueDB sq "updateQueueTime" $ \q@QueueRec {updatedAt} -> + if updatedAt == Just t + then pure q + else do + withDB' "updateQueueTime" st $ \db -> + DB.execute db "UPDATE msg_queues SET updated_at = ? WHERE recipient_id = ?" (t, recipientId sq) + let !q' = q {updatedAt = Just t} + atomically $ writeTVar (queueRec sq) $ Just q' + pure q' - -- TODO [postgres] only update STM on DB success + -- this method is called from JournalMsgStore deleteQueue that already locks the queue deleteStoreQueue :: PostgresQueueStore q -> q -> IO (Either ErrorType (QueueRec, Maybe (MsgQueue q))) - deleteStoreQueue st sq = - withQueueRec qr delete - $>>= \q -> deleteDB - >>= mapM (\_ -> (q,) <$> atomically (swapTVar (msgQueue sq) Nothing)) + deleteStoreQueue st sq = runExceptT $ do + q <- ExceptT $ readQueueRecIO qr + withDB' "deleteStoreQueue" st $ \db -> + DB.execute db "DELETE FROM msg_queues WHERE recipient_id = ?" (Only $ Binary $ unEntityId $ recipientId sq) + atomically $ writeTVar qr Nothing + atomically $ TM.delete (senderId q) $ senders st + forM_ (notifier q) $ \NtfCreds {notifierId} -> atomically $ TM.delete notifierId $ notifiers st + (q,) <$> atomically (swapTVar (msgQueue sq) Nothing) where qr = queueRec sq - delete q = do - writeTVar qr Nothing - TM.delete (senderId q) $ senders st - -- TODO [postgres] probably we should delete it? - -- forM_ (notifier q) $ \NtfCreds {notifierId} -> TM.delete notifierId $ notifiers st - pure q - deleteDB = - withDB' "deleteStoreQueue" st $ \db -> - DB.execute db "DELETE FROM msg_queues WHERE recipient_id = ?" (Only $ Binary $ unEntityId $ recipientId sq) insertQueueDB :: DB.Connection -> RecipientId -> QueueRec -> IO () insertQueueDB db rId QueueRec {recipientKey, rcvDhSecret, senderId, senderKey, sndSecure, notifier, status, updatedAt} = do @@ -342,23 +313,31 @@ rowToQueueRec ((rId, recipientKey, rcvDhSecret, senderId, senderKey, sndSecure, let notifier = NtfCreds <$> notifierId_ <*> notifierKey_ <*> rcvNtfDhSecret_ in (rId, QueueRec {recipientKey, rcvDhSecret, senderId, senderKey, sndSecure, notifier, status, updatedAt}) -setStatusDB :: String -> PostgresQueueStore q -> RecipientId -> ServerEntityStatus -> IO (Either ErrorType ()) -setStatusDB name st rId status = - withDB' name st $ \db -> - DB.execute db "UPDATE msg_queues SET status = ? WHERE recipient_id = ?" (status, rId) +setStatusDB :: StoreQueueClass q => String -> PostgresQueueStore q -> q -> ServerEntityStatus -> IO (Either ErrorType ()) +setStatusDB op st sq status = + withQueueDB sq op $ \q -> do + withDB' op st $ \db -> + DB.execute db "UPDATE msg_queues SET status = ? WHERE recipient_id = ?" (status, recipientId sq) + atomically $ writeTVar (queueRec sq) $ Just q {status} -withDB' :: String -> PostgresQueueStore q -> (DB.Connection -> IO a) -> IO (Either ErrorType a) -withDB' name st' action = withDB name st' $ fmap Right . action +withQueueDB :: StoreQueueClass q => q -> String -> (QueueRec -> ExceptT ErrorType IO a) -> IO (Either ErrorType a) +withQueueDB sq op action = + withQueueLock sq op $ runExceptT $ do + q <- ExceptT $ readQueueRecIO $ queueRec sq + action q + +withDB' :: String -> PostgresQueueStore q -> (DB.Connection -> IO a) -> ExceptT ErrorType IO a +withDB' op st' action = withDB op st' $ fmap Right . action -- TODO [postgres] possibly, use with connection if queries in addQueue_ are combined -withDB :: forall a q. String -> PostgresQueueStore q -> (DB.Connection -> IO (Either ErrorType a)) -> IO (Either ErrorType a) -withDB name st' action = - E.try (withTransaction (dbStore st') action) >>= either logErr pure +withDB :: forall a q. String -> PostgresQueueStore q -> (DB.Connection -> IO (Either ErrorType a)) -> ExceptT ErrorType IO a +withDB op st' action = + ExceptT $ E.try (withTransaction (dbStore st') action) >>= either logErr pure where logErr :: E.SomeException -> IO (Either ErrorType a) logErr e = logError ("STORE: " <> T.pack err) $> Left (STORE err) where - err = name <> ", withLog, " <> show e + err = op <> ", withLog, " <> show e handleDuplicate :: SqlError -> IO ErrorType handleDuplicate e = case constraintViolation e of From 7b42aaa13207d4077cbd3acec0b6cd54f402491e Mon Sep 17 00:00:00 2001 From: Evgeny Date: Mon, 10 Mar 2025 09:31:50 +0000 Subject: [PATCH 04/14] smp server: expire messages in postgres database, mark queues as deleted, combine tables (#1471) * smp server: expire messages in postgres database * tty * fail if nothing updated in db * remove old deleted queues * index * fix tests --- src/Simplex/Messaging/Server.hs | 22 +- src/Simplex/Messaging/Server/CLI.hs | 3 +- src/Simplex/Messaging/Server/Env/STM.hs | 9 +- src/Simplex/Messaging/Server/Main.hs | 29 ++- .../Messaging/Server/MsgStore/Journal.hs | 65 +----- .../Messaging/Server/MsgStore/Types.hs | 2 +- .../Messaging/Server/QueueStore/Postgres.hs | 214 ++++++++++-------- .../Server/QueueStore/Postgres/Migrations.hs | 15 +- .../Messaging/Server/QueueStore/STM.hs | 4 +- .../Messaging/Server/QueueStore/Types.hs | 3 +- tests/CoreTests/MsgStoreTests.hs | 5 +- tests/SMPClient.hs | 4 +- 12 files changed, 184 insertions(+), 191 deletions(-) diff --git a/src/Simplex/Messaging/Server.hs b/src/Simplex/Messaging/Server.hs index b0edfa2dd..f0b97529a 100644 --- a/src/Simplex/Messaging/Server.hs +++ b/src/Simplex/Messaging/Server.hs @@ -394,16 +394,20 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg, startOpt let interval = checkInterval expCfg * 1000000 stats <- asks serverStats labelMyThread "expireMessagesThread" - liftIO $ forever $ do - threadDelay' interval - old <- expireBeforeEpoch expCfg - now <- systemSeconds <$> getSystemTime - msgStats@MessageStats {storedMsgsCount = stored, expiredMsgsCount = expired} <- - withActiveMsgQueues ms $ expireQueueMsgs now ms old - atomicWriteIORef (msgCount stats) stored - atomicModifyIORef'_ (msgExpired stats) (+ expired) - printMessageStats "STORE: messages" msgStats + liftIO $ forever $ expire ms stats interval where + expire :: forall s. MsgStoreClass s => s -> ServerStats -> Int64 -> IO () + expire ms stats interval = do + threadDelay' interval + n <- compactQueues @(StoreQueue s) $ queueStore ms + when (n > 0) $ logInfo $ "Removed " <> tshow n <> " old deleted queues from the database." + old <- expireBeforeEpoch expCfg + now <- systemSeconds <$> getSystemTime + msgStats@MessageStats {storedMsgsCount = stored, expiredMsgsCount = expired} <- + withAllMsgQueues False ms $ expireQueueMsgs now ms old + atomicWriteIORef (msgCount stats) stored + atomicModifyIORef'_ (msgExpired stats) (+ expired) + printMessageStats "STORE: messages" msgStats expireQueueMsgs now ms old q = fmap (fromRight newMessageStats) . runExceptT $ do (expired_, stored) <- idleDeleteExpiredMsgs now ms q old pure MessageStats {storedMsgsCount = stored, expiredMsgsCount = fromMaybe 0 expired_, storedQueues = 1} diff --git a/src/Simplex/Messaging/Server/CLI.hs b/src/Simplex/Messaging/Server/CLI.hs index 3e52d2001..a1e9f8d83 100644 --- a/src/Simplex/Messaging/Server/CLI.hs +++ b/src/Simplex/Messaging/Server/CLI.hs @@ -31,6 +31,7 @@ import Simplex.Messaging.Agent.Store.Postgres.Common (DBOpts (..)) import Simplex.Messaging.Encoding.String import Simplex.Messaging.Protocol (ProtoServerWithAuth (..), ProtocolServer (..), ProtocolTypeI) import Simplex.Messaging.Server.Env.STM (AServerStoreCfg (..), ServerStoreCfg (..), StorePaths (..)) +import Simplex.Messaging.Server.QueueStore.Postgres (PostgresStoreCfg (..)) import Simplex.Messaging.Transport (ATransport (..), TLS, Transport (..)) import Simplex.Messaging.Transport.Server (AddHTTP, loadFileFingerprint) import Simplex.Messaging.Transport.WebSockets (WS) @@ -310,7 +311,7 @@ printSMPServerConfig :: [(ServiceName, ATransport, AddHTTP)] -> AServerStoreCfg printSMPServerConfig transports (ASSCfg _ _ cfg) = case cfg of SSCMemory sp_ -> printServerConfig transports $ (\StorePaths {storeLogFile} -> storeLogFile) <$> sp_ SSCMemoryJournal {storeLogFile} -> printServerConfig transports $ Just storeLogFile - SSCDatabaseJournal {storeDBOpts = DBOpts {connstr, schema}} -> do + SSCDatabaseJournal {storeCfg = PostgresStoreCfg {dbOpts = DBOpts {connstr, schema}}} -> do B.putStrLn $ "PostgreSQL database: " <> connstr <> ", schema: " <> schema printServerTransports transports diff --git a/src/Simplex/Messaging/Server/Env/STM.hs b/src/Simplex/Messaging/Server/Env/STM.hs index da8c22b1a..3e890c236 100644 --- a/src/Simplex/Messaging/Server/Env/STM.hs +++ b/src/Simplex/Messaging/Server/Env/STM.hs @@ -16,6 +16,7 @@ #if __GLASGOW_HASKELL__ == 810 {-# LANGUAGE UndecidableInstances #-} #endif +{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-} module Simplex.Messaging.Server.Env.STM where @@ -43,7 +44,6 @@ import Network.Socket (ServiceName) import qualified Network.TLS as T import Numeric.Natural import Simplex.Messaging.Agent.Lock -import Simplex.Messaging.Agent.Store.Postgres.Common (DBOpts) import Simplex.Messaging.Agent.Store.Shared (MigrationConfirmation (..)) import Simplex.Messaging.Client.Agent (SMPClientAgent, SMPClientAgentConfig, newSMPClientAgent) import Simplex.Messaging.Crypto (KeyHash (..)) @@ -56,6 +56,7 @@ import Simplex.Messaging.Server.MsgStore.STM import Simplex.Messaging.Server.MsgStore.Types import Simplex.Messaging.Server.NtfStore import Simplex.Messaging.Server.QueueStore +import Simplex.Messaging.Server.QueueStore.Postgres (PostgresStoreCfg (..)) import Simplex.Messaging.Server.QueueStore.STM (STMQueueStore, setStoreLog) import Simplex.Messaging.Server.QueueStore.Types import Simplex.Messaging.Server.Stats @@ -216,7 +217,7 @@ data AStoreType = forall qs ms. SupportedStore qs ms => ASType (SQSType qs) (SMS data ServerStoreCfg qs ms where SSCMemory :: Maybe StorePaths -> ServerStoreCfg 'QSMemory 'MSMemory SSCMemoryJournal :: {storeLogFile :: FilePath, storeMsgsPath :: FilePath} -> ServerStoreCfg 'QSMemory 'MSJournal - SSCDatabaseJournal :: {storeDBOpts :: DBOpts, confirmMigrations :: MigrationConfirmation, storeMsgsPath' :: FilePath} -> ServerStoreCfg 'QSPostgres 'MSJournal + SSCDatabaseJournal :: {storeCfg :: PostgresStoreCfg, storeMsgsPath' :: FilePath} -> ServerStoreCfg 'QSPostgres 'MSJournal data StorePaths = StorePaths {storeLogFile :: FilePath, storeMsgsFile :: Maybe FilePath} @@ -338,9 +339,9 @@ newEnv config@ServerConfig {smpCredentials, httpCredentials, serverStoreCfg, smp ms <- newMsgStore cfg loadStoreLog (mkQueue ms) storeLogFile $ stmQueueStore ms pure $ AMS qt mt ms - ASSCfg qt mt SSCDatabaseJournal {storeDBOpts, storeMsgsPath'} -> do + ASSCfg qt mt SSCDatabaseJournal {storeCfg, storeMsgsPath'} -> do let StartOptions {confirmMigrations} = startOptions - qsCfg = PQStoreCfg storeDBOpts confirmMigrations + qsCfg = PQStoreCfg (storeCfg {confirmMigrations} :: PostgresStoreCfg) cfg = mkJournalStoreConfig qsCfg storeMsgsPath' msgQueueQuota maxJournalMsgCount maxJournalStateLines idleQueueInterval ms <- newMsgStore cfg pure $ AMS qt mt ms diff --git a/src/Simplex/Messaging/Server/Main.hs b/src/Simplex/Messaging/Server/Main.hs index 388a6a069..66dfba70b 100644 --- a/src/Simplex/Messaging/Server/Main.hs +++ b/src/Simplex/Messaging/Server/Main.hs @@ -24,6 +24,7 @@ import Data.Char (isAlpha, isAscii, toUpper) import Data.Either (fromRight) import Data.Functor (($>)) import Data.Ini (Ini, lookupValue, readIniFile) +import Data.Int (Int64) import Data.List (find, isPrefixOf) import qualified Data.List.NonEmpty as L import Data.Maybe (fromMaybe, isJust, isNothing) @@ -52,7 +53,7 @@ import Simplex.Messaging.Server.Expiration import Simplex.Messaging.Server.Information import Simplex.Messaging.Server.MsgStore.Journal (JournalMsgStore (..), JournalQueue, QStoreCfg (..), postgresQueueStore, stmQueueStore) import Simplex.Messaging.Server.MsgStore.Types (MsgStoreClass (..), QSType (..), SQSType (..), SMSType (..), newMsgStore) -import Simplex.Messaging.Server.QueueStore.Postgres (batchInsertQueues, foldQueueRecs) +import Simplex.Messaging.Server.QueueStore.Postgres (PostgresStoreCfg (..), batchInsertQueues, foldQueueRecs) import Simplex.Messaging.Server.QueueStore.Types import Simplex.Messaging.Server.StoreLog (logCreateQueue, openWriteStoreLog) import Simplex.Messaging.Server.StoreLog.ReadWrite (readQueueStore) @@ -165,10 +166,11 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath = ms <- newJournalMsgStore MQStoreCfg readQueueStore True (mkQueue ms) storeLogFile (queueStore ms) queues <- readTVarIO $ loadedQueues $ stmQueueStore ms - ps <- newJournalMsgStore $ PQStoreCfg dbOpts {createSchema = True} MCConsole - (qCnt, nCnt) <- batchInsertQueues @(JournalQueue 'QSMemory) True queues $ postgresQueueStore ps + let storeCfg = PostgresStoreCfg {dbOpts = dbOpts {createSchema = True}, confirmMigrations = MCConsole, deletedTTL = iniDeletedTTL ini} + ps <- newJournalMsgStore $ PQStoreCfg storeCfg + qCnt <- batchInsertQueues @(JournalQueue 'QSMemory) True queues $ postgresQueueStore ps renameFile storeLogFile $ storeLogFile <> ".bak" - putStrLn $ "Import completed: " <> show qCnt <> " queues, " <> show nCnt <> " notifiers" + putStrLn $ "Import completed: " <> show qCnt <> " queues" putStrLn $ case readStoreType ini of Right (ASType SQSMemory SMSMemory) -> "store_messages set to `memory`.\nImport messages to journal to use PostgreSQL database for queues (`smp-server journal import`)" Right (ASType SQSMemory SMSJournal) -> "store_queues set to `memory`, update it to `database` in INI file" @@ -186,9 +188,10 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath = confirmOrExit ("WARNING: PostrgreSQL database schema " <> B.unpack schema <> " (database: " <> B.unpack connstr <> ") will be exported to store log file " <> storeLogFilePath) "Queue records not exported" - ps <- newJournalMsgStore $ PQStoreCfg dbOpts MCConsole + let storeCfg = PostgresStoreCfg {dbOpts, confirmMigrations = MCConsole, deletedTTL = iniDeletedTTL ini} + ps <- newJournalMsgStore $ PQStoreCfg storeCfg sl <- openWriteStoreLog storeLogFilePath - Sum qCnt <- foldQueueRecs True (postgresQueueStore ps) $ \rId qr -> logCreateQueue sl rId qr $> Sum (1 :: Int) + Sum qCnt <- foldQueueRecs True (postgresQueueStore ps) $ \(rId, qr) -> logCreateQueue sl rId qr $> Sum (1 :: Int) putStrLn $ "Export completed: " <> show qCnt <> " queues" putStrLn $ case readStoreType ini of Right (ASType SQSPostgres SMSJournal) -> "store_queues set to `database`, update it to `memory` in INI file." @@ -242,14 +245,15 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath = DBOpts { connstr = either (const defaultDBConnStr) encodeUtf8 $ lookupValue "STORE_LOG" "db_connection" ini, schema = either (const defaultDBSchema) encodeUtf8 $ lookupValue "STORE_LOG" "db_schema" ini, - poolSize = either (const defaultDBPoolSize) (read . T.unpack) $ lookupValue "STORE_LOG" "db_pool_size" ini, + poolSize = readIniDefault defaultDBPoolSize "STORE_LOG" "db_pool_size" ini, createSchema = False } dbOptsIniContent :: DBOpts -> Text - dbOptsIniContent DBOpts {connstr, schema, poolSize } = + dbOptsIniContent DBOpts {connstr, schema, poolSize} = (optDisabled' (connstr == defaultDBConnStr) <> "db_connection: " <> safeDecodeUtf8 connstr <> "\n") <> (optDisabled' (schema == defaultDBSchema) <> "db_schema: " <> safeDecodeUtf8 schema <> "\n") <> (optDisabled' (poolSize == defaultDBPoolSize) <> "db_pool_size: " <> tshow poolSize <> "\n\n") + iniDeletedTTL ini = readIniDefault (86400 * defaultDeletedTTL) "STORE_LOG" "db_deleted_ttl" ini httpsCertFile = combine cfgPath "web.crt" httpsKeyFile = combine cfgPath "web.key" defaultStaticPath = combine logPath "www" @@ -333,6 +337,8 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath = \store_queues: memory\n\n\ \# Database connection settings for PostgreSQL database (`store_queues: database`).\n" <> dbOptsIniContent dbOptions + <> "# Time to retain deleted queues in the database, days.\n" + <> ("db_deleted_ttl: " <> tshow defaultDeletedTTL <> "\n\n") <> "# Message storage mode: `memory` or `journal`.\n\ \store_messages: memory\n\n\ \# When store_messages is `memory`, undelivered messages are optionally saved and restored\n\ @@ -498,7 +504,8 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath = ASType SQSMemory SMSJournal -> ASSCfg SQSMemory SMSJournal $ SSCMemoryJournal {storeLogFile = storeLogFilePath, storeMsgsPath = storeMsgsJournalDir} ASType SQSPostgres SMSJournal -> - ASSCfg SQSPostgres SMSJournal $ SSCDatabaseJournal {storeDBOpts = iniDBOptions ini, confirmMigrations = MCYesUp, storeMsgsPath' = storeMsgsJournalDir}, + let storeCfg = PostgresStoreCfg {dbOpts = iniDBOptions ini, confirmMigrations = MCYesUp, deletedTTL = iniDeletedTTL ini} + in ASSCfg SQSPostgres SMSJournal $ SSCDatabaseJournal {storeCfg, storeMsgsPath' = storeMsgsJournalDir}, storeNtfsFile = restoreMessagesFile storeNtfsFilePath, -- allow creating new queues by default allowNewQueues = fromMaybe True $ iniOnOff "AUTH" "new_queues" ini, @@ -640,6 +647,10 @@ defaultDBSchema = "smp_server" defaultDBPoolSize :: Natural defaultDBPoolSize = 10 +-- time to retain deleted queues in the database (days), for debugging +defaultDeletedTTL :: Int64 +defaultDeletedTTL = 21 + defaultControlPort :: Int defaultControlPort = 5224 diff --git a/src/Simplex/Messaging/Server/MsgStore/Journal.hs b/src/Simplex/Messaging/Server/MsgStore/Journal.hs index 32fefb386..f7a65488d 100644 --- a/src/Simplex/Messaging/Server/MsgStore/Journal.hs +++ b/src/Simplex/Messaging/Server/MsgStore/Journal.hs @@ -58,7 +58,7 @@ import qualified Data.ByteString.Char8 as B import Data.Functor (($>)) import Data.Int (Int64) import Data.List (intercalate, sort) -import Data.Maybe (catMaybes, fromMaybe, isNothing, mapMaybe) +import Data.Maybe (fromMaybe, isNothing, mapMaybe) import Data.Text (Text) import qualified Data.Text as T import Data.Time.Clock (NominalDiffTime, UTCTime, addUTCTime, getCurrentTime) @@ -67,8 +67,6 @@ import Data.Time.Format.ISO8601 (iso8601Show, iso8601ParseM) import GHC.IO (catchAny) import Simplex.Messaging.Agent.Client (getMapLock, withLockMap) import Simplex.Messaging.Agent.Lock -import Simplex.Messaging.Agent.Store.Postgres.Common (DBOpts) -import Simplex.Messaging.Agent.Store.Shared (MigrationConfirmation) import Simplex.Messaging.Encoding.String import Simplex.Messaging.Protocol import Simplex.Messaging.Server.MsgStore.Types @@ -81,9 +79,8 @@ import qualified Simplex.Messaging.TMap as TM import Simplex.Messaging.Server.StoreLog import Simplex.Messaging.Util (ifM, tshow, whenM, ($>>=), (<$$>)) import System.Directory -import System.Exit import System.FilePath (takeFileName, ()) -import System.IO (BufferMode (..), Handle, IOMode (..), SeekMode (..), stdout) +import System.IO (BufferMode (..), Handle, IOMode (..), SeekMode (..)) import qualified System.IO as IO import System.Random (StdGen, genByteString, newStdGen) @@ -137,7 +134,7 @@ data JournalStoreConfig s = JournalStoreConfig data QStoreCfg s where MQStoreCfg :: QStoreCfg 'QSMemory - PQStoreCfg :: DBOpts -> MigrationConfirmation -> QStoreCfg 'QSPostgres + PQStoreCfg :: PostgresStoreCfg -> QStoreCfg 'QSPostgres data JournalQueue (s :: QSType) = JournalQueue { recipientId' :: RecipientId, @@ -289,10 +286,12 @@ instance QueueStoreClass (JournalQueue s) (QStore s) where newQueueStore :: QStoreCfg s -> IO (QStore s) newQueueStore = \case MQStoreCfg -> MQStore <$> newQueueStore @(JournalQueue s) () - PQStoreCfg dbOpts confirmMigrations -> PQStore <$> newQueueStore @(JournalQueue s) (dbOpts, confirmMigrations) + PQStoreCfg cfg -> PQStore <$> newQueueStore @(JournalQueue s) cfg loadedQueues = withQS loadedQueues {-# INLINE loadedQueues #-} + compactQueues = withQS (compactQueues @(JournalQueue s)) + {-# INLINE compactQueues #-} queueCounts = withQS (queueCounts @(JournalQueue s)) {-# INLINE queueCounts #-} addQueue_ = withQS addQueue_ @@ -341,54 +340,12 @@ instance MsgStoreClass (JournalMsgStore s) where closeQueues qs = readTVarIO qs >>= mapM_ closeMsgQueue withActiveMsgQueues :: Monoid a => JournalMsgStore s -> (JournalQueue s -> IO a) -> IO a - withActiveMsgQueues ms f = case queueStore_ ms of - MQStore st -> withLoadedQueues st f - PQStore st -> withLoadedQueues st f + withActiveMsgQueues = withQS withLoadedQueues . queueStore_ - -- This function is a "foldr" that opens and closes all queues, processes them as defined by action and accumulates the result. - -- It is used to export storage to a single file and also to expire messages and validate all queues when server is started. - -- TODO this function requires case-sensitive file system, because it uses queue directory as recipient ID. - -- It can be made to support case-insensite FS by supporting more than one queue per directory, by getting recipient ID from state file name. - -- TODO [postgres] this should simply load all known queues and process them - withAllMsgQueues :: forall a. Monoid a => Bool -> JournalMsgStore s -> (JournalQueue s -> IO a) -> IO a - withAllMsgQueues tty ms@JournalMsgStore {config} action = ifM (doesDirectoryExist storePath) processStore (pure mempty) - where - processStore = do - (!count, !res) <- foldQueues 0 processQueue (0, mempty) ("", storePath) - putStrLn $ progress count - pure res - JournalStoreConfig {storePath, pathParts} = config - processQueue :: (Int, a) -> (String, FilePath) -> IO (Int, a) - processQueue (!i, !r) (queueId, dir) = do - when (tty && i `mod` 100 == 0) $ putStr (progress i <> "\r") >> IO.hFlush stdout - r' <- case strDecode $ B.pack queueId of - Right rId -> - getQueue ms SRecipient rId >>= \case - Right q -> unStoreIO (getMsgQueue ms q False) *> action q <* closeMsgQueue q - Left AUTH -> do - logWarn $ "STORE: processQueue, queue " <> T.pack queueId <> " was removed, removing " <> T.pack dir - removeQueueDirectory_ dir - pure mempty - Left e -> do - logError $ "STORE: processQueue, error getting queue " <> T.pack queueId <> ", " <> tshow e - exitFailure - Left e -> do - logError $ "STORE: processQueue, message queue directory " <> T.pack dir <> " is invalid, " <> tshow e - exitFailure - pure (i + 1, r <> r') - progress i = "Processed: " <> show i <> " queues" - foldQueues depth f acc (queueId, path) = do - let f' = if depth == pathParts - 1 then f else foldQueues (depth + 1) f - listDirs >>= foldM f' acc - where - listDirs = fmap catMaybes . mapM queuePath =<< listDirectory path - queuePath dir = do - let !path' = path dir - !queueId' = queueId <> dir - ifM - (doesDirectoryExist path') - (pure $ Just (queueId', path')) - (Nothing <$ putStrLn ("Error: path " <> path' <> " is not a directory, skipping")) + withAllMsgQueues :: Monoid a => Bool -> JournalMsgStore s -> (JournalQueue s -> IO a) -> IO a + withAllMsgQueues tty ms action = case queueStore_ ms of + MQStore st -> withLoadedQueues st action + PQStore st -> foldQueues tty st (mkQueue ms) action logQueueStates :: JournalMsgStore s -> IO () logQueueStates ms = withActiveMsgQueues ms $ unStoreIO . logQueueState diff --git a/src/Simplex/Messaging/Server/MsgStore/Types.hs b/src/Simplex/Messaging/Server/MsgStore/Types.hs index 2aa741a8f..420517ac4 100644 --- a/src/Simplex/Messaging/Server/MsgStore/Types.hs +++ b/src/Simplex/Messaging/Server/MsgStore/Types.hs @@ -83,7 +83,7 @@ getQueueRec st party qId = $>>= (\q -> maybe (Left AUTH) (Right . (q,)) <$> readTVarIO (queueRec q)) getQueueMessages :: MsgStoreClass s => Bool -> s -> StoreQueue s -> ExceptT ErrorType IO [Message] -getQueueMessages drainMsgs st q = withPeekMsgQueue st q "getQueueSize" $ maybe (pure []) (getQueueMessages_ drainMsgs q . fst) +getQueueMessages drainMsgs st q = withPeekMsgQueue st q "getQueueMessages" $ maybe (pure []) (getQueueMessages_ drainMsgs q . fst) {-# INLINE getQueueMessages #-} getQueueSize :: MsgStoreClass s => s -> StoreQueue s -> ExceptT ErrorType IO Int diff --git a/src/Simplex/Messaging/Server/QueueStore/Postgres.hs b/src/Simplex/Messaging/Server/QueueStore/Postgres.hs index 8988cb3f3..0923ab244 100644 --- a/src/Simplex/Messaging/Server/QueueStore/Postgres.hs +++ b/src/Simplex/Messaging/Server/QueueStore/Postgres.hs @@ -20,8 +20,10 @@ module Simplex.Messaging.Server.QueueStore.Postgres ( PostgresQueueStore (..), + PostgresStoreCfg (..), batchInsertQueues, foldQueueRecs, + foldQueues, ) where @@ -32,21 +34,23 @@ import Control.Monad.Except import Control.Monad.IO.Class import Control.Monad.Trans.Except import Data.Bitraversable (bimapM) +import Data.Either (fromRight) import Data.Functor (($>)) import Data.Int (Int64) import qualified Data.Map.Strict as M -import Data.Maybe (catMaybes, mapMaybe) +import Data.Maybe (catMaybes) import qualified Data.Text as T -import Database.PostgreSQL.Simple (Binary (..), Only (..), Query, SqlError, (:.) (..)) -import qualified Database.PostgreSQL.Simple as PSQL +import Data.Time.Clock.System (SystemTime (..), getSystemTime) +import Database.PostgreSQL.Simple (Binary (..), Only (..), Query, SqlError) +import qualified Database.PostgreSQL.Simple as DB +import Database.PostgreSQL.Simple.FromField (FromField (..)) +import Database.PostgreSQL.Simple.ToField (ToField (..)) import Database.PostgreSQL.Simple.Errors (ConstraintViolation (..), constraintViolation) import Database.PostgreSQL.Simple.SqlQQ (sql) import Simplex.Messaging.Agent.Client (withLockMap) import Simplex.Messaging.Agent.Lock (Lock) import Simplex.Messaging.Agent.Store.Postgres (createDBStore) import Simplex.Messaging.Agent.Store.Postgres.Common -import Simplex.Messaging.Agent.Store.Postgres.DB (FromField (..), ToField (..)) -import qualified Simplex.Messaging.Agent.Store.Postgres.DB as DB import Simplex.Messaging.Agent.Store.Shared (MigrationConfirmation) import Simplex.Messaging.Protocol import Simplex.Messaging.Server.QueueStore @@ -73,20 +77,27 @@ data PostgresQueueStore q = PostgresQueueStore 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 + notifierLocks :: TMap NotifierId Lock, + deletedTTL :: Int64 + } + +data PostgresStoreCfg = PostgresStoreCfg + { dbOpts :: DBOpts, + confirmMigrations :: MigrationConfirmation, + deletedTTL :: Int64 } instance StoreQueueClass q => QueueStoreClass q (PostgresQueueStore q) where - type QueueStoreCfg (PostgresQueueStore q) = (DBOpts, MigrationConfirmation) + type QueueStoreCfg (PostgresQueueStore q) = PostgresStoreCfg - newQueueStore :: (DBOpts, MigrationConfirmation) -> IO (PostgresQueueStore q) - newQueueStore (dbOpts, confirmMigrations) = do + newQueueStore :: PostgresStoreCfg -> IO (PostgresQueueStore q) + newQueueStore PostgresStoreCfg {dbOpts, confirmMigrations, deletedTTL} = do dbStore <- either err pure =<< createDBStore dbOpts serverMigrations confirmMigrations queues <- TM.emptyIO senders <- TM.emptyIO notifiers <- TM.emptyIO notifierLocks <- TM.emptyIO - pure PostgresQueueStore {dbStore, queues, senders, notifiers, notifierLocks} + pure PostgresQueueStore {dbStore, queues, senders, notifiers, notifierLocks, deletedTTL} where err e = do logError $ "STORE: newQueueStore, error opening PostgreSQL database, " <> tshow e @@ -95,6 +106,12 @@ instance StoreQueueClass q => QueueStoreClass q (PostgresQueueStore q) where loadedQueues = queues {-# INLINE loadedQueues #-} + compactQueues :: PostgresQueueStore q -> IO Int64 + compactQueues st@PostgresQueueStore {deletedTTL} = do + old <- subtract deletedTTL . systemSeconds <$> liftIO getSystemTime + fmap (fromRight 0) $ runExceptT $ withDB' "removeDeletedQueues" st $ \db -> + DB.execute db "DELETE FROM msg_queues WHERE deleted_at < ?" (Only old) + queueCounts :: PostgresQueueStore q -> IO QueueCounts queueCounts st = withConnection (dbStore st) $ \db -> do @@ -103,8 +120,8 @@ instance StoreQueueClass q => QueueStoreClass q (PostgresQueueStore q) where db [sql| SELECT - (SELECT COUNT(1) FROM msg_queues) AS queue_count, - (SELECT COUNT(1) FROM msg_notifiers) AS notifier_count + (SELECT COUNT(1) FROM msg_queues WHERE deleted_at IS NULL) AS queue_count, + (SELECT COUNT(1) FROM msg_queues WHERE deleted_at IS NULL AND notifier_id IS NOT NULL) AS notifier_count |] pure QueueCounts {queueCount, notifierCount} @@ -114,8 +131,9 @@ instance StoreQueueClass q => QueueStoreClass q (PostgresQueueStore q) where addQueue_ st mkQ rId qr = do sq <- mkQ rId qr withQueueLock sq "addQueue_" $ runExceptT $ do - withDB "addQueue_" st $ \db -> - E.try (insertQueueDB db rId qr) >>= bimapM handleDuplicate pure + void $ withDB "addQueue_" st $ \db -> + E.try (DB.execute db insertQueueQuery $ queueRecToRow (rId, qr)) + >>= bimapM handleDuplicate pure atomically $ TM.insert rId sq queues atomically $ TM.insert (senderId qr) rId senders pure sq @@ -134,32 +152,21 @@ instance StoreQueueClass q => QueueStoreClass q (PostgresQueueStore q) where where PostgresQueueStore {queues, senders, notifiers} = st getRcvQueue rId = TM.lookupIO rId queues >>= maybe loadRcvQueue (pure . Right) - loadRcvQueue = loadQueue " WHERE q.recipient_id = ?" $ \_ -> pure () - loadSndQueue = loadQueue " WHERE q.sender_id = ?" $ \rId -> TM.insert qId rId senders - loadNtfQueue = loadQueue " WHERE n.notifier_id = ?" $ \_ -> pure () -- do NOT cache ref - ntf subscriptions are rare - loadQueue condition insertRef = runExceptT $ do - (rId, qRec) <- loadQueueRec - sq <- liftIO $ mkQ rId qRec - 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 - insertRef rId - TM.insert rId sq queues - pure sq + loadRcvQueue = loadQueue " WHERE recipient_id = ?" $ \_ -> pure () + loadSndQueue = loadQueue " WHERE sender_id = ?" $ \rId -> TM.insert qId rId senders + loadNtfQueue = loadQueue " WHERE notifier_id = ?" $ \_ -> pure () -- do NOT cache ref - ntf subscriptions are rare + loadQueue condition insertRef = runExceptT $ loadQueueRec >>= liftIO . cachedOrLoadedQueue st mkQ insertRef where loadQueueRec = withDB "getQueue_" st $ \db -> firstRow rowToQueueRec AUTH $ - DB.query db (queueRecQuery <> condition) (Only qId) + DB.query db (queueRecQuery <> condition <> " AND deleted_at IS NULL") (Only qId) secureQueue :: PostgresQueueStore q -> q -> SndPublicAuthKey -> IO (Either ErrorType ()) secureQueue st sq sKey = withQueueDB sq "secureQueue" $ \q -> do verify q - withDB' "secureQueue" st $ \db -> - DB.execute db "UPDATE msg_queues SET sender_key = ? WHERE recipient_id = ?" (sKey, recipientId sq) + assertUpdated $ withDB' "secureQueue" st $ \db -> + DB.execute db "UPDATE msg_queues SET sender_key = ? WHERE recipient_id = ? AND deleted_at IS NULL" (sKey, recipientId sq) atomically $ writeTVar (queueRec sq) $ Just q {senderKey = Just sKey} where verify q = case senderKey q of @@ -171,8 +178,8 @@ instance StoreQueueClass q => QueueStoreClass q (PostgresQueueStore q) where withQueueDB sq "addQueueNotifier" $ \q -> ExceptT $ withLockMap (notifierLocks st) nId "addQueueNotifier" $ ifM (TM.memberIO nId notifiers) (pure $ Left DUPLICATE_) $ runExceptT $ do - withDB "addQueueNotifier" st $ \db -> - E.try (insert db) >>= bimapM handleDuplicate pure + assertUpdated $ withDB "addQueueNotifier" st $ \db -> + E.try (update db) >>= bimapM handleDuplicate pure nId_ <- forM (notifier q) $ \NtfCreds {notifierId} -> atomically (TM.delete notifierId notifiers) $> notifierId let !q' = q {notifier = Just ntfCreds} atomically $ writeTVar (queueRec sq) $ Just q' @@ -183,29 +190,35 @@ instance StoreQueueClass q => QueueStoreClass q (PostgresQueueStore q) where PostgresQueueStore {notifiers} = st rId = recipientId sq -- TODO [postgres] test how this query works with duplicate recipient_id (updates) and notifier_id (fails) - insert db = + update db = DB.execute db [sql| - INSERT INTO msg_notifiers (recipient_id, notifier_id, notifier_key, rcv_ntf_dh_secret) - VALUES (?, ?, ?, ?) - ON CONFLICT (recipient_id) DO UPDATE - SET notifier_id = EXCLUDED.notifier_id, - notifier_key = EXCLUDED.notifier_key, - rcv_ntf_dh_secret = EXCLUDED.rcv_ntf_dh_secret + UPDATE msg_queues + SET notifier_id = ?, notifier_key = ?, rcv_ntf_dh_secret = ? + WHERE recipient_id = ? AND deleted_at IS NULL |] - (rId, nId, notifierKey, rcvNtfDhSecret) + (nId, notifierKey, rcvNtfDhSecret, rId) deleteQueueNotifier :: PostgresQueueStore q -> q -> IO (Either ErrorType (Maybe NotifierId)) deleteQueueNotifier st sq = withQueueDB sq "deleteQueueNotifier" $ \q -> ExceptT $ fmap sequence $ forM (notifier q) $ \NtfCreds {notifierId = nId} -> withLockMap (notifierLocks st) nId "deleteQueueNotifier" $ runExceptT $ do - withDB' "deleteQueueNotifier" st $ \db -> - DB.execute db "DELETE FROM msg_notifiers WHERE notifier_id = ?" (Only nId) + assertUpdated $ withDB' "deleteQueueNotifier" st update atomically $ TM.delete nId $ notifiers st atomically $ writeTVar (queueRec sq) $ Just q {notifier = Nothing} pure nId + where + update db = + DB.execute + db + [sql| + UPDATE msg_queues + SET notifier_id = NULL, notifier_key = NULL, rcv_ntf_dh_secret = NULL + WHERE recipient_id = ? AND deleted_at IS NULL + |] + (Only $ recipientId sq) suspendQueue :: PostgresQueueStore q -> q -> IO (Either ErrorType ()) suspendQueue st sq = setStatusDB "suspendQueue" st sq EntityOff @@ -222,8 +235,8 @@ instance StoreQueueClass q => QueueStoreClass q (PostgresQueueStore q) where if updatedAt == Just t then pure q else do - withDB' "updateQueueTime" st $ \db -> - DB.execute db "UPDATE msg_queues SET updated_at = ? WHERE recipient_id = ?" (t, recipientId sq) + assertUpdated $ withDB' "updateQueueTime" st $ \db -> + DB.execute db "UPDATE msg_queues SET updated_at = ? WHERE recipient_id = ? AND deleted_at IS NULL" (t, recipientId sq) let !q' = q {updatedAt = Just t} atomically $ writeTVar (queueRec sq) $ Just q' pure q' @@ -232,8 +245,9 @@ instance StoreQueueClass q => QueueStoreClass q (PostgresQueueStore q) where deleteStoreQueue :: PostgresQueueStore q -> q -> IO (Either ErrorType (QueueRec, Maybe (MsgQueue q))) deleteStoreQueue st sq = runExceptT $ do q <- ExceptT $ readQueueRecIO qr - withDB' "deleteStoreQueue" st $ \db -> - DB.execute db "DELETE FROM msg_queues WHERE recipient_id = ?" (Only $ Binary $ unEntityId $ recipientId sq) + RoundedSystemTime ts <- liftIO getSystemDate + assertUpdated $ withDB' "deleteStoreQueue" st $ \db -> + DB.execute db "UPDATE msg_queues SET deleted_at = ? WHERE recipient_id = ? AND deleted_at IS NULL" (ts, recipientId sq) atomically $ writeTVar qr Nothing atomically $ TM.delete (senderId q) $ senders st forM_ (notifier q) $ \NtfCreds {notifierId} -> atomically $ TM.delete notifierId $ notifiers st @@ -241,32 +255,21 @@ instance StoreQueueClass q => QueueStoreClass q (PostgresQueueStore q) where where qr = queueRec sq -insertQueueDB :: DB.Connection -> RecipientId -> QueueRec -> IO () -insertQueueDB db rId QueueRec {recipientKey, rcvDhSecret, senderId, senderKey, sndSecure, notifier, status, updatedAt} = do - DB.execute db insertQueueQuery (rId, recipientKey, rcvDhSecret, senderId, senderKey, sndSecure, status, updatedAt) - forM_ notifier $ \NtfCreds {notifierId, notifierKey, rcvNtfDhSecret} -> - DB.execute db insertNotifierQuery (rId, notifierId, notifierKey, rcvNtfDhSecret) - -batchInsertQueues :: StoreQueueClass q => Bool -> M.Map RecipientId q -> PostgresQueueStore q' -> IO (Int64, Int64) +batchInsertQueues :: StoreQueueClass q => Bool -> M.Map RecipientId q -> PostgresQueueStore q' -> IO Int64 batchInsertQueues tty queues toStore = do qs <- catMaybes <$> mapM (\(rId, q) -> (rId,) <$$> readTVarIO (queueRec q)) (M.assocs queues) putStrLn $ "Importing " <> show (length qs) <> " queues..." let st = dbStore toStore - (ns, count) <- foldM (processChunk st) ((0, 0), 0) $ toChunks 1000000 qs + (qCnt, count) <- foldM (processChunk st) (0, 0) $ toChunks 1000000 qs putStrLn $ progress count - pure ns + pure qCnt where - processChunk st ((qCnt, nCnt), i) qs = do - qCnt' <- withConnection st $ \db -> PSQL.executeMany db insertQueueQuery $ map toQueueRow qs - nCnt' <- withConnection st $ \db -> PSQL.executeMany db insertNotifierQuery $ mapMaybe toNotifierRow qs + processChunk st (qCnt, i) qs = do + qCnt' <- withConnection st $ \db -> DB.executeMany db insertQueueQuery $ map queueRecToRow qs let i' = i + length qs when tty $ putStr (progress i' <> "\r") >> hFlush stdout - pure ((qCnt + qCnt', nCnt + nCnt'), i') + pure (qCnt + qCnt', i') progress i = "Imported: " <> show i <> " queues" - toQueueRow (rId, QueueRec {recipientKey, rcvDhSecret, senderId, senderKey, sndSecure, status, updatedAt}) = - (rId, recipientKey, rcvDhSecret, senderId, senderKey, sndSecure, status, updatedAt) - toNotifierRow (rId, QueueRec {notifier}) = - (\NtfCreds {notifierId, notifierKey, rcvNtfDhSecret} -> (rId, notifierId, notifierKey, rcvNtfDhSecret)) <$> notifier toChunks :: Int -> [a] -> [[a]] toChunks _ [] = [] toChunks n xs = @@ -277,62 +280,81 @@ insertQueueQuery :: Query insertQueueQuery = [sql| INSERT INTO msg_queues - (recipient_id, recipient_key, rcv_dh_secret, sender_id, sender_key, snd_secure, status, updated_at) - VALUES (?,?,?,?,?,?,?,?) + (recipient_id, recipient_key, rcv_dh_secret, sender_id, sender_key, snd_secure, notifier_id, notifier_key, rcv_ntf_dh_secret, status, updated_at) + VALUES (?,?,?,?,?,?,?,?,?,?,?) |] -insertNotifierQuery :: Query -insertNotifierQuery = - [sql| - INSERT INTO msg_notifiers (recipient_id, notifier_id, notifier_key, rcv_ntf_dh_secret) - VALUES (?, ?, ?, ?) - |] +foldQueues :: Monoid a => Bool -> PostgresQueueStore q -> (RecipientId -> QueueRec -> IO q) -> (q -> IO a) -> IO a +foldQueues tty st mkQ f = + foldQueueRecs tty st $ cachedOrLoadedQueue st mkQ (\_ -> pure ()) >=> f -foldQueueRecs :: Monoid a => Bool -> PostgresQueueStore q -> (RecipientId -> QueueRec -> IO a) -> IO a +foldQueueRecs :: Monoid a => Bool -> PostgresQueueStore q -> ((RecipientId, QueueRec) -> IO a) -> IO a foldQueueRecs tty st f = do - fmap snd $ withConnection (dbStore st) $ \db -> - PSQL.fold_ db queueRecQuery (0 :: Int, mempty) $ \(!i, !acc) row -> do - r <- uncurry f (rowToQueueRec row) + (n, r) <- withConnection (dbStore st) $ \db -> + DB.fold_ db (queueRecQuery <> " WHERE deleted_at IS NULL") (0 :: Int, mempty) $ \(!i, !acc) row -> do + r <- f $ rowToQueueRec row let i' = i + 1 - when (tty && i' `mod` 100000 == 0) $ putStr ("Processed: " <> show i <> " records\r") >> hFlush stdout + when (tty && i' `mod` 100000 == 0) $ putStr (progress i <> "\r") >> hFlush stdout pure (i', acc <> r) + when tty $ putStrLn $ progress n + pure r + where + progress i = "Processed: " <> show i <> " records" queueRecQuery :: Query queueRecQuery = [sql| - SELECT q.recipient_id, q.recipient_key, q.rcv_dh_secret, q.sender_id, q.sender_key, q.snd_secure, q.status, q.updated_at, - n.notifier_id, n.notifier_key, n.rcv_ntf_dh_secret - FROM msg_queues q - LEFT JOIN msg_notifiers n ON q.recipient_id = n.recipient_id + SELECT recipient_id, recipient_key, rcv_dh_secret, + sender_id, sender_key, snd_secure, + notifier_id, notifier_key, rcv_ntf_dh_secret, + status, updated_at + FROM msg_queues |] -rowToQueueRec :: ( (RecipientId, RcvPublicAuthKey, RcvDhSecret, SenderId, Maybe SndPublicAuthKey, SenderCanSecure, ServerEntityStatus, Maybe RoundedSystemTime) - :. (Maybe NotifierId, Maybe NtfPublicAuthKey, Maybe RcvNtfDhSecret) - ) -> (RecipientId, QueueRec) -rowToQueueRec ((rId, recipientKey, rcvDhSecret, senderId, senderKey, sndSecure, status, updatedAt) :. (notifierId_, notifierKey_, rcvNtfDhSecret_)) = +cachedOrLoadedQueue :: PostgresQueueStore q -> (RecipientId -> QueueRec -> IO q) -> (RecipientId -> STM ()) -> (RecipientId, QueueRec) -> IO q +cachedOrLoadedQueue PostgresQueueStore {queues} mkQ insertRef (rId, qRec) = do + sq <- liftIO $ mkQ rId qRec -- loaded queue + 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 + insertRef rId + TM.insert rId sq queues + pure sq + +type QueueRecRow = (RecipientId, RcvPublicAuthKey, RcvDhSecret, SenderId, Maybe SndPublicAuthKey, SenderCanSecure, Maybe NotifierId, Maybe NtfPublicAuthKey, Maybe RcvNtfDhSecret, ServerEntityStatus, Maybe RoundedSystemTime) + +queueRecToRow :: (RecipientId, QueueRec) -> QueueRecRow +queueRecToRow (rId, QueueRec {recipientKey, rcvDhSecret, senderId, senderKey, sndSecure, notifier = n, status, updatedAt}) = + (rId, recipientKey, rcvDhSecret, senderId, senderKey, sndSecure, notifierId <$> n, notifierKey <$> n, rcvNtfDhSecret <$> n, status, updatedAt) + +rowToQueueRec :: QueueRecRow -> (RecipientId, QueueRec) +rowToQueueRec (rId, recipientKey, rcvDhSecret, senderId, senderKey, sndSecure, notifierId_, notifierKey_, rcvNtfDhSecret_, status, updatedAt) = let notifier = NtfCreds <$> notifierId_ <*> notifierKey_ <*> rcvNtfDhSecret_ - in (rId, QueueRec {recipientKey, rcvDhSecret, senderId, senderKey, sndSecure, notifier, status, updatedAt}) + in (rId, QueueRec {recipientKey, rcvDhSecret, senderId, senderKey, sndSecure, notifier, status, updatedAt}) setStatusDB :: StoreQueueClass q => String -> PostgresQueueStore q -> q -> ServerEntityStatus -> IO (Either ErrorType ()) setStatusDB op st sq status = withQueueDB sq op $ \q -> do - withDB' op st $ \db -> - DB.execute db "UPDATE msg_queues SET status = ? WHERE recipient_id = ?" (status, recipientId sq) + 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} withQueueDB :: StoreQueueClass q => q -> String -> (QueueRec -> ExceptT ErrorType IO a) -> IO (Either ErrorType a) withQueueDB sq op action = - withQueueLock sq op $ runExceptT $ do - q <- ExceptT $ readQueueRecIO $ queueRec sq - action q + withQueueLock sq op $ runExceptT $ ExceptT (readQueueRecIO $ queueRec sq) >>= action + +assertUpdated :: ExceptT ErrorType IO Int64 -> ExceptT ErrorType IO () +assertUpdated = (>>= \n -> when (n == 0) (throwE AUTH)) withDB' :: String -> PostgresQueueStore q -> (DB.Connection -> IO a) -> ExceptT ErrorType IO a -withDB' op st' action = withDB op st' $ fmap Right . action +withDB' op st action = withDB op st $ fmap Right . action --- TODO [postgres] possibly, use with connection if queries in addQueue_ are combined withDB :: forall a q. String -> PostgresQueueStore q -> (DB.Connection -> IO (Either ErrorType a)) -> ExceptT ErrorType IO a -withDB op st' action = - ExceptT $ E.try (withTransaction (dbStore st') action) >>= either logErr pure +withDB op st action = + ExceptT $ E.try (withConnection (dbStore st) action) >>= either logErr pure where logErr :: E.SomeException -> IO (Either ErrorType a) logErr e = logError ("STORE: " <> T.pack err) $> Left (STORE err) diff --git a/src/Simplex/Messaging/Server/QueueStore/Postgres/Migrations.hs b/src/Simplex/Messaging/Server/QueueStore/Postgres/Migrations.hs index 98027b5b6..03b6fecf6 100644 --- a/src/Simplex/Messaging/Server/QueueStore/Postgres/Migrations.hs +++ b/src/Simplex/Messaging/Server/QueueStore/Postgres/Migrations.hs @@ -31,19 +31,16 @@ CREATE TABLE msg_queues( sender_id BYTEA NOT NULL, sender_key BYTEA, snd_secure BOOLEAN NOT NULL, + notifier_id BYTEA, + notifier_key BYTEA, + rcv_ntf_dh_secret BYTEA, status TEXT NOT NULL, updated_at BIGINT, + deleted_at BIGINT, PRIMARY KEY (recipient_id) ); -CREATE TABLE msg_notifiers( - notifier_id BYTEA NOT NULL, - recipient_id BYTEA NOT NULL REFERENCES msg_queues(recipient_id) ON DELETE CASCADE ON UPDATE RESTRICT, - notifier_key BYTEA NOT NULL, - rcv_ntf_dh_secret BYTEA NOT NULL, - PRIMARY KEY (notifier_id) -); - CREATE UNIQUE INDEX idx_msg_queues_sender_id ON msg_queues(sender_id); -CREATE UNIQUE INDEX idx_msg_notifiers_recipient_id ON msg_notifiers(recipient_id); +CREATE UNIQUE INDEX idx_msg_queues_notifier_id ON msg_queues(notifier_id); +CREATE INDEX idx_msg_queues_deleted_at ON msg_queues (deleted_at); |] diff --git a/src/Simplex/Messaging/Server/QueueStore/STM.hs b/src/Simplex/Messaging/Server/QueueStore/STM.hs index bebadf7c5..648748162 100644 --- a/src/Simplex/Messaging/Server/QueueStore/STM.hs +++ b/src/Simplex/Messaging/Server/QueueStore/STM.hs @@ -64,8 +64,8 @@ instance StoreQueueClass q => QueueStoreClass q (STMQueueStore q) where loadedQueues = queues {-# INLINE loadedQueues #-} - -- foldAllQueues = withLoadedQueues - -- {-# INLINE foldAllQueues #-} + compactQueues _ = pure 0 + {-# INLINE compactQueues #-} queueCounts :: STMQueueStore q -> IO QueueCounts queueCounts st = do diff --git a/src/Simplex/Messaging/Server/QueueStore/Types.hs b/src/Simplex/Messaging/Server/QueueStore/Types.hs index 47283ac7c..2951e4038 100644 --- a/src/Simplex/Messaging/Server/QueueStore/Types.hs +++ b/src/Simplex/Messaging/Server/QueueStore/Types.hs @@ -9,6 +9,7 @@ module Simplex.Messaging.Server.QueueStore.Types where import Control.Concurrent.STM import Control.Monad +import Data.Int (Int64) import Simplex.Messaging.Protocol import Simplex.Messaging.Server.QueueStore import Simplex.Messaging.TMap (TMap) @@ -25,7 +26,7 @@ class StoreQueueClass q => QueueStoreClass q s where newQueueStore :: QueueStoreCfg s -> IO s queueCounts :: s -> IO QueueCounts loadedQueues :: s -> TMap RecipientId q - -- foldAllQueues :: Monoid a => s -> (q -> IO a) -> IO a + compactQueues :: s -> IO Int64 addQueue_ :: s -> (RecipientId -> QueueRec -> IO q) -> RecipientId -> QueueRec -> IO (Either ErrorType q) getQueue_ :: DirectParty p => s -> (RecipientId -> QueueRec -> IO q) -> SParty p -> QueueId -> IO (Either ErrorType q) secureQueue :: s -> q -> SndPublicAuthKey -> IO (Either ErrorType ()) diff --git a/tests/CoreTests/MsgStoreTests.hs b/tests/CoreTests/MsgStoreTests.hs index ccd8ea66d..bbb7a7e8c 100644 --- a/tests/CoreTests/MsgStoreTests.hs +++ b/tests/CoreTests/MsgStoreTests.hs @@ -217,11 +217,8 @@ testExportImportStore ms = do length <$> listDirectory (msgQueueDirectory ms rId1) `shouldReturn` 2 length <$> listDirectory (msgQueueDirectory ms rId2) `shouldReturn` 3 exportMessages False ms testStoreMsgsFile False - renameFile testStoreMsgsFile (testStoreMsgsFile <> ".copy") closeMsgStore ms closeStoreLog sl - exportMessages False ms testStoreMsgsFile False - (B.readFile testStoreMsgsFile `shouldReturn`) =<< B.readFile (testStoreMsgsFile <> ".copy") let cfg = (testJournalStoreCfg MQStoreCfg :: JournalStoreConfig 'QSMemory) {storePath = testStoreMsgsDir2} ms' <- newMsgStore cfg readWriteQueueStore True (mkQueue ms') testStoreLogFile (queueStore ms') >>= closeStoreLog @@ -229,7 +226,7 @@ testExportImportStore ms = do importMessages False ms' testStoreMsgsFile Nothing False printMessageStats "Messages" stats length <$> listDirectory (msgQueueDirectory ms rId1) `shouldReturn` 2 - length <$> listDirectory (msgQueueDirectory ms rId2) `shouldReturn` 4 -- state file is backed up, 2 message files + length <$> listDirectory (msgQueueDirectory ms rId2) `shouldReturn` 3 -- 2 message files exportMessages False ms' testStoreMsgsFile2 False (B.readFile testStoreMsgsFile2 `shouldReturn`) =<< B.readFile (testStoreMsgsFile <> ".bak") stmStore <- newMsgStore testSMTStoreConfig diff --git a/tests/SMPClient.hs b/tests/SMPClient.hs index 28639b0a5..4bae8215a 100644 --- a/tests/SMPClient.hs +++ b/tests/SMPClient.hs @@ -28,6 +28,7 @@ import Simplex.Messaging.Protocol import Simplex.Messaging.Server (runSMPServerBlocking) import Simplex.Messaging.Server.Env.STM import Simplex.Messaging.Server.MsgStore.Types (SMSType (..), SQSType (..)) +import Simplex.Messaging.Server.QueueStore.Postgres (PostgresStoreCfg (..)) import Simplex.Messaging.Transport import Simplex.Messaging.Transport.Client import qualified Simplex.Messaging.Transport.Client as Client @@ -180,7 +181,8 @@ cfgMS msType = ASType SQSMemory SMSJournal -> ASSCfg SQSMemory SMSJournal $ SSCMemoryJournal {storeLogFile = testStoreLogFile, storeMsgsPath = testStoreMsgsDir} ASType SQSPostgres SMSJournal -> - ASSCfg SQSPostgres SMSJournal $ SSCDatabaseJournal {storeDBOpts = testStoreDBOpts, confirmMigrations = MCYesUp, storeMsgsPath' = testStoreMsgsDir}, + let storeCfg = PostgresStoreCfg {dbOpts = testStoreDBOpts, confirmMigrations = MCYesUp, deletedTTL = 86400} + in ASSCfg SQSPostgres SMSJournal SSCDatabaseJournal {storeCfg, storeMsgsPath' = testStoreMsgsDir}, storeNtfsFile = Nothing, allowNewQueues = True, newQueueBasicAuth = Nothing, From 9410fb6f168e3b5130258a54e17a9b0c54db78be Mon Sep 17 00:00:00 2001 From: shum Date: Mon, 10 Mar 2025 10:03:44 +0000 Subject: [PATCH 05/14] docker: add libpq dep --- Dockerfile.build | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Dockerfile.build b/Dockerfile.build index fb7678f44..c7ddea11d 100644 --- a/Dockerfile.build +++ b/Dockerfile.build @@ -8,7 +8,7 @@ ARG GHC=9.6.3 ARG CABAL=3.14.1.1 # Install curl, git and and simplexmq dependencies -RUN apt-get update && apt-get install -y curl git sqlite3 libsqlite3-dev build-essential libgmp3-dev zlib1g-dev llvm llvm-dev libnuma-dev libssl-dev +RUN apt-get update && apt-get install -y curl libpq-dev git sqlite3 libsqlite3-dev build-essential libgmp3-dev zlib1g-dev llvm llvm-dev libnuma-dev libssl-dev # Specify bootstrap Haskell versions ENV BOOTSTRAP_HASKELL_GHC_VERSION=${GHC} From 6b5de2c51bee62668dd7388a782bb5e7ec9f659f Mon Sep 17 00:00:00 2001 From: Evgeny Date: Mon, 10 Mar 2025 17:28:26 +0000 Subject: [PATCH 06/14] smp server: exception on invalid migration, check queue storage settings on server start (#1478) * smp server: check queue storage settings on server start * fix incorrect postgres migration not throwing exception --- .../Agent/Store/Postgres/Migrations.hs | 7 +++- src/Simplex/Messaging/Server/Main.hs | 33 +++++++++++++++---- tests/SMPClient.hs | 9 +++-- 3 files changed, 39 insertions(+), 10 deletions(-) diff --git a/src/Simplex/Messaging/Agent/Store/Postgres/Migrations.hs b/src/Simplex/Messaging/Agent/Store/Postgres/Migrations.hs index daa0c73f1..d6f552937 100644 --- a/src/Simplex/Messaging/Agent/Store/Postgres/Migrations.hs +++ b/src/Simplex/Messaging/Agent/Store/Postgres/Migrations.hs @@ -11,7 +11,9 @@ module Simplex.Messaging.Agent.Store.Postgres.Migrations ) where +import Control.Exception (throwIO) import Control.Monad (void) +import qualified Data.ByteString.Char8 as B import qualified Data.Text as T import qualified Data.Text.Encoding as TE import Data.Time.Clock (getCurrentTime) @@ -22,6 +24,7 @@ import Database.PostgreSQL.Simple.Internal (Connection (..)) import Database.PostgreSQL.Simple.SqlQQ (sql) import Simplex.Messaging.Agent.Store.Postgres.Common import Simplex.Messaging.Agent.Store.Shared +import Simplex.Messaging.Util (($>>=)) import UnliftIO.MVar initialize :: DBStore -> IO () @@ -55,7 +58,9 @@ run st = \case void $ PSQL.execute db "DELETE FROM migrations WHERE name = ?" (Only downName) execSQL db query = withMVar (connectionHandle db) $ \pqConn -> - void $ LibPQ.exec pqConn (TE.encodeUtf8 query) + LibPQ.exec pqConn (TE.encodeUtf8 query) $>>= LibPQ.resultErrorMessage >>= \case + Just e | not (B.null e) -> throwIO $ userError $ B.unpack e + _ -> pure () getCurrentMigrations :: PSQL.Connection -> IO [Migration] getCurrentMigrations db = map toMigration <$> PSQL.query_ db "SELECT name, down FROM migrations ORDER BY name ASC;" diff --git a/src/Simplex/Messaging/Server/Main.hs b/src/Simplex/Messaging/Server/Main.hs index 66dfba70b..806c7fc34 100644 --- a/src/Simplex/Messaging/Server/Main.hs +++ b/src/Simplex/Messaging/Server/Main.hs @@ -3,6 +3,7 @@ {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedStrings #-} @@ -431,7 +432,7 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath = printServiceInfo serverVersion srv printSourceCode sourceCode' printSMPServerConfig transports serverStoreCfg - checkMsgStoreMode iniStoreType + checkMsgStoreMode ini iniStoreType putStrLn $ case messageExpiration of Just ExpirationConfig {ttl} -> "expiring messages after " <> showTTL ttl _ -> "not expiring messages" @@ -586,25 +587,43 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath = pure WebHttpsParams {port, cert, key} webStaticPath' = eitherToMaybe $ T.unpack <$> lookupValue "WEB" "static_path" ini - checkMsgStoreMode :: AStoreType -> IO () - checkMsgStoreMode mode = do + checkMsgStoreMode :: Ini -> AStoreType -> IO () + checkMsgStoreMode ini mode = do msgsDirExists <- doesDirectoryExist storeMsgsJournalDir msgsFileExists <- doesFileExist storeMsgsFilePath + storeLogExists <- doesFileExist storeLogFilePath case mode of - _ | msgsFileExists && msgsDirExists -> exitConfigureMsgStorage - ASType _ SMSJournal -- TODO [postgres] + 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." - ASType _ SMSMemory + | otherwise -> case qs of + SQSMemory -> + unless (storeLogExists) $ putStrLn $ "store_queues is `memory`, " <> storeLogFilePath <> " file will be created." + SQSPostgres -> do + let DBOpts {connstr, schema} = iniDBOptions ini + schemaExists <- checkSchemaExists connstr schema + if + | storeLogExists && schemaExists -> exitConfigureQueueStore connstr schema + | storeLogExists -> do + putStrLn $ "Error: store_queues is `database` with " <> storeLogFilePath <> " file present." + putStrLn "Set store_queues to `memory` or use `smp-server database import` to migrate." + exitFailure + | not schemaExists -> do + putStrLn $ "Error: store_queues is `database`, create schema " <> B.unpack schema <> " in PostgreSQL database " <> B.unpack connstr + exitFailure + | otherwise -> pure () + 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 - _ -> pure () + | otherwise -> pure () exitConfigureMsgStorage = do putStrLn $ "Error: both " <> storeMsgsFilePath <> " file and " <> storeMsgsJournalDir <> " directory are present." diff --git a/tests/SMPClient.hs b/tests/SMPClient.hs index 4bae8215a..a1527b78a 100644 --- a/tests/SMPClient.hs +++ b/tests/SMPClient.hs @@ -40,7 +40,7 @@ import System.Info (os) import Test.Hspec import UnliftIO.Concurrent import qualified UnliftIO.Exception as E -import UnliftIO.STM (TMVar, atomically, newEmptyTMVarIO, takeTMVar) +import UnliftIO.STM (TMVar, atomically, newEmptyTMVarIO, putTMVar, takeTMVar) import UnliftIO.Timeout (timeout) import Util @@ -278,10 +278,15 @@ serverBracket :: HasCallStack => (TMVar Bool -> IO ()) -> IO () -> (HasCallStack serverBracket process afterProcess f = do started <- newEmptyTMVarIO E.bracket - (forkIOWithUnmask ($ process started)) + (forkIOWithUnmask (\unmask -> unmask (process started) `E.catchAny` handleStartError started)) (\t -> killThread t >> afterProcess >> waitFor started "stop") (\t -> waitFor started "start" >> f t >>= \r -> r <$ threadDelay 100000) where + -- it putTMVar is called twise to unlock both parts of the bracket in case of start failure + handleStartError started e = do + atomically $ putTMVar started False + atomically $ putTMVar started False + E.throwIO e waitFor started s = 5_000_000 `timeout` atomically (takeTMVar started) >>= \case Nothing -> error $ "server did not " <> s From d44f09d1112f2de6eaacd83268a7abe17efd11b7 Mon Sep 17 00:00:00 2001 From: Evgeny Date: Wed, 12 Mar 2025 21:47:44 +0000 Subject: [PATCH 07/14] tests: pass AStoreType to agent test as a parameter (#1479) * tests: run agent tests with PostgreSQL SMP servers * agent tests with postgres database * enable tests * fix store log tests * fix test --- src/Simplex/Messaging/Agent/Store/Postgres.hs | 2 +- src/Simplex/Messaging/Server/StoreLog.hs | 1 - tests/AgentTests.hs | 9 +- tests/AgentTests/FunctionalAPITests.hs | 572 +++++++++--------- tests/AgentTests/MigrationTests.hs | 5 +- tests/AgentTests/NotificationTests.hs | 82 +-- tests/SMPClient.hs | 83 +-- tests/SMPProxyTests.hs | 50 +- tests/ServerTests.hs | 110 ++-- tests/Test.hs | 19 +- tests/Util.hs | 9 + 11 files changed, 485 insertions(+), 457 deletions(-) diff --git a/src/Simplex/Messaging/Agent/Store/Postgres.hs b/src/Simplex/Messaging/Agent/Store/Postgres.hs index 3f5c14b26..50494e781 100644 --- a/src/Simplex/Messaging/Agent/Store/Postgres.hs +++ b/src/Simplex/Messaging/Agent/Store/Postgres.hs @@ -113,7 +113,7 @@ doesSchemaExist db schema = do closeDBStore :: DBStore -> IO () closeDBStore DBStore {dbPool, dbPoolSize, dbClosed} = ifM (readTVarIO dbClosed) (putStrLn "closeDBStore: already closed") $ uninterruptibleMask_ $ do - replicateM_ dbPoolSize $ atomically $ readTBQueue dbPool + replicateM_ dbPoolSize $ atomically (readTBQueue dbPool) >>= DB.close atomically $ writeTVar dbClosed True reopenDBStore :: DBStore -> IO () diff --git a/src/Simplex/Messaging/Server/StoreLog.hs b/src/Simplex/Messaging/Server/StoreLog.hs index df144c7e9..d82062ec3 100644 --- a/src/Simplex/Messaging/Server/StoreLog.hs +++ b/src/Simplex/Messaging/Server/StoreLog.hs @@ -40,7 +40,6 @@ import qualified Data.Attoparsec.ByteString.Char8 as A import qualified Data.ByteString.Char8 as B import Data.Functor (($>)) import Data.List (sort, stripPrefix) -import qualified Data.Map.Strict as M import Data.Maybe (mapMaybe) import qualified Data.Text as T import Data.Time.Clock (UTCTime, addUTCTime, getCurrentTime, nominalDay) diff --git a/tests/AgentTests.hs b/tests/AgentTests.hs index 1c0a69d8d..a9a64e5c7 100644 --- a/tests/AgentTests.hs +++ b/tests/AgentTests.hs @@ -14,6 +14,7 @@ import AgentTests.FunctionalAPITests (functionalAPITests) import AgentTests.MigrationTests (migrationTests) import AgentTests.NotificationTests (notificationTests) import AgentTests.ServerChoice (serverChoiceTests) +import Simplex.Messaging.Server.Env.STM (AStoreType (..)) import Simplex.Messaging.Transport (ATransport (..)) import Test.Hspec #if defined(dbPostgres) @@ -23,8 +24,8 @@ import Simplex.Messaging.Agent.Store.Postgres.Util (dropAllSchemasExceptSystem) import AgentTests.SQLiteTests (storeTests) #endif -agentTests :: ATransport -> Spec -agentTests (ATransport t) = do +agentTests :: (ATransport, AStoreType) -> Spec +agentTests ps = do describe "Migration tests" migrationTests describe "Connection request" connectionRequestTests describe "Double ratchet tests" doubleRatchetTests @@ -33,9 +34,9 @@ agentTests (ATransport t) = do #else do #endif - describe "Functional API" $ functionalAPITests (ATransport t) + describe "Functional API" $ functionalAPITests ps describe "Chosen servers" serverChoiceTests - describe "Notification tests" $ notificationTests (ATransport t) + describe "Notification tests" $ notificationTests ps #if !defined(dbPostgres) describe "SQLite store" storeTests #endif diff --git a/tests/AgentTests/FunctionalAPITests.hs b/tests/AgentTests/FunctionalAPITests.hs index 97ced934e..cbe1c47bc 100644 --- a/tests/AgentTests/FunctionalAPITests.hs +++ b/tests/AgentTests/FunctionalAPITests.hs @@ -77,7 +77,7 @@ import Data.Type.Equality (testEquality, (:~:) (Refl)) import Data.Word (Word16) import GHC.Stack (withFrozenCallStack) import SMPAgentClient -import SMPClient (cfg, cfgJ2, prevRange, prevVersion, testPort, testPort2, testStoreLogFile, withSmpServer, withSmpServerConfigOn, withSmpServerProxy, withSmpServerStoreLogOn, withSmpServerStoreMsgLogOn) +import SMPClient (cfgMS, cfgJ2QS, prevRange, prevVersion, testPort, testPort2, testStoreLogFile, withSmpServer, withSmpServerConfigOn, withSmpServerProxy, withSmpServerStoreLogOn, withSmpServerStoreMsgLogOn) import Simplex.Messaging.Agent hiding (createConnection, joinConnection, sendMessage) import qualified Simplex.Messaging.Agent as A import Simplex.Messaging.Agent.Client (ProtocolTestFailure (..), ProtocolTestStep (..), ServerQueueInfo (..), UserNetworkInfo (..), UserNetworkType (..), waitForUserNetwork) @@ -96,7 +96,7 @@ import Simplex.Messaging.Encoding.String import Simplex.Messaging.Notifications.Transport (NTFVersion, pattern VersionNTF) import Simplex.Messaging.Protocol (BasicAuth, ErrorType (..), MsgBody, ProtocolServer (..), SubscriptionMode (..), supportedSMPClientVRange) import qualified Simplex.Messaging.Protocol as SMP -import Simplex.Messaging.Server.Env.STM (AServerStoreCfg (..), ServerConfig (..), ServerStoreCfg (..), StorePaths (..)) +import Simplex.Messaging.Server.Env.STM (AServerStoreCfg (..), AStoreType (..), ServerConfig (..), ServerStoreCfg (..), StorePaths (..)) import Simplex.Messaging.Server.Expiration import Simplex.Messaging.Server.MsgStore.Types (SMSType (..), SQSType (..)) import Simplex.Messaging.Server.QueueStore.QueueInfo @@ -263,218 +263,218 @@ sendMessage c connId msgFlags msgBody = do liftIO $ pqEnc `shouldBe` PQEncOn pure msgId -functionalAPITests :: ATransport -> Spec -functionalAPITests t = do +functionalAPITests :: (ATransport, AStoreType) -> Spec +functionalAPITests ps = do describe "Establishing duplex connection" $ do - testMatrix2 t runAgentClientTest + testMatrix2 ps runAgentClientTest it "should connect when server with multiple identities is stored" $ - withSmpServer t testServerMultipleIdentities + withSmpServer ps testServerMultipleIdentities it "should connect with two peers" $ - withSmpServer t testAgentClient3 + withSmpServer ps testAgentClient3 it "should establish connection without PQ encryption and enable it" $ - withSmpServer t testEnablePQEncryption + withSmpServer ps testEnablePQEncryption describe "Duplex connection - delivery stress test" $ do - describe "one way (50)" $ testMatrix2Stress t $ runAgentClientStressTestOneWay 50 - xdescribe "one way (1000)" $ testMatrix2Stress t $ runAgentClientStressTestOneWay 1000 - describe "two way concurrently (50)" $ testMatrix2Stress t $ runAgentClientStressTestConc 25 - xdescribe "two way concurrently (1000)" $ testMatrix2Stress t $ runAgentClientStressTestConc 500 + describe "one way (50)" $ testMatrix2Stress ps $ runAgentClientStressTestOneWay 50 + xdescribe "one way (1000)" $ testMatrix2Stress ps $ runAgentClientStressTestOneWay 1000 + describe "two way concurrently (50)" $ testMatrix2Stress ps $ runAgentClientStressTestConc 25 + xdescribe "two way concurrently (1000)" $ testMatrix2Stress ps $ runAgentClientStressTestConc 500 describe "Establishing duplex connection, different PQ settings" $ do - testPQMatrix2 t $ runAgentClientTestPQ False True + testPQMatrix2 ps $ runAgentClientTestPQ False True describe "Establishing duplex connection v2, different Ratchet versions" $ - testRatchetMatrix2 t runAgentClientTest + testRatchetMatrix2 ps runAgentClientTest describe "Establish duplex connection via contact address" $ - testMatrix2 t runAgentClientContactTest + testMatrix2 ps runAgentClientContactTest describe "Establish duplex connection via contact address, different PQ settings" $ do - testPQMatrix2NoInv t $ runAgentClientContactTestPQ False True PQSupportOn + testPQMatrix2NoInv ps $ runAgentClientContactTestPQ False True PQSupportOn describe "Establish duplex connection via contact address v2, different Ratchet versions" $ - testRatchetMatrix2 t runAgentClientContactTest + testRatchetMatrix2 ps runAgentClientContactTest describe "Establish duplex connection via contact address, different PQ settings" $ do - testPQMatrix3 t $ runAgentClientContactTestPQ3 True + testPQMatrix3 ps $ runAgentClientContactTestPQ3 True it "should support rejecting contact request" $ - withSmpServer t testRejectContactRequest + withSmpServer ps testRejectContactRequest describe "Changing connection user id" $ do it "should change user id for new connections" $ do - withSmpServer t testUpdateConnectionUserId + withSmpServer ps testUpdateConnectionUserId describe "Establishing connection asynchronously" $ do it "should connect with initiating client going offline" $ - withSmpServer t testAsyncInitiatingOffline + withSmpServer ps testAsyncInitiatingOffline it "should connect with joining client going offline before its queue activation" $ - withSmpServer t testAsyncJoiningOfflineBeforeActivation + withSmpServer ps testAsyncJoiningOfflineBeforeActivation it "should connect with both clients going offline" $ - withSmpServer t testAsyncBothOffline + withSmpServer ps testAsyncBothOffline it "should connect on the second attempt if server was offline" $ - testAsyncServerOffline t + testAsyncServerOffline ps it "should restore confirmation after client restart" $ - testAllowConnectionClientRestart t + testAllowConnectionClientRestart ps describe "Message delivery" $ do describe "update connection agent version on received messages" $ do - it "should increase if compatible, shouldn't decrease" $ - testIncreaseConnAgentVersion t + it "should increase if compatible, shouldn'ps decrease" $ + testIncreaseConnAgentVersion ps it "should increase to max compatible version" $ - testIncreaseConnAgentVersionMaxCompatible t + testIncreaseConnAgentVersionMaxCompatible ps it "should increase when connection was negotiated on different versions" $ - testIncreaseConnAgentVersionStartDifferentVersion t + testIncreaseConnAgentVersionStartDifferentVersion ps -- TODO PQ tests for upgrading connection to PQ encryption it "should deliver message after client restart" $ - testDeliverClientRestart t + testDeliverClientRestart ps it "should deliver messages to the user once, even if repeat delivery is made by the server (no ACK)" $ - testDuplicateMessage t + testDuplicateMessage ps it "should report error via msg integrity on skipped messages" $ - testSkippedMessages t + testSkippedMessages ps it "should connect to the server when server goes up if it initially was down" $ - testDeliveryAfterSubscriptionError t + testDeliveryAfterSubscriptionError ps it "should deliver messages if one of connections has quota exceeded" $ - testMsgDeliveryQuotaExceeded t + testMsgDeliveryQuotaExceeded ps describe "message expiration" $ do - it "should expire one message" $ testExpireMessage t - it "should expire multiple messages" $ testExpireManyMessages t - it "should expire one message if quota is exceeded" $ testExpireMessageQuota t - it "should expire multiple messages if quota is exceeded" $ testExpireManyMessagesQuota t + it "should expire one message" $ testExpireMessage ps + it "should expire multiple messages" $ testExpireManyMessages ps + it "should expire one message if quota is exceeded" $ testExpireMessageQuota ps + it "should expire multiple messages if quota is exceeded" $ testExpireManyMessagesQuota ps #if !defined(dbPostgres) -- TODO [postgres] restore from outdated db backup (we use copyFile/renameFile for sqlite) describe "Ratchet synchronization" $ do it "should report ratchet de-synchronization, synchronize ratchets" $ - testRatchetSync t + testRatchetSync ps it "should synchronize ratchets after server being offline" $ - testRatchetSyncServerOffline t + testRatchetSyncServerOffline ps it "should synchronize ratchets after client restart" $ - testRatchetSyncClientRestart t + testRatchetSyncClientRestart ps it "should synchronize ratchets after suspend/foreground" $ - testRatchetSyncSuspendForeground t + testRatchetSyncSuspendForeground ps it "should synchronize ratchets when clients start synchronization simultaneously" $ - testRatchetSyncSimultaneous t + testRatchetSyncSimultaneous ps #endif describe "Subscription mode OnlyCreate" $ do it "messages delivered only when polled (v8 - slow handshake)" $ - withSmpServer t testOnlyCreatePullSlowHandshake + withSmpServer ps testOnlyCreatePullSlowHandshake it "messages delivered only when polled" $ - withSmpServer t testOnlyCreatePull + withSmpServer ps testOnlyCreatePull describe "Inactive client disconnection" $ do it "should disconnect clients without subs if they were inactive longer than TTL" $ - testInactiveNoSubs t + testInactiveNoSubs ps it "should NOT disconnect inactive clients when they have subscriptions" $ - testInactiveWithSubs t + testInactiveWithSubs ps it "should NOT disconnect active clients" $ - testActiveClientNotDisconnected t + testActiveClientNotDisconnected ps describe "Suspending agent" $ do it "should update client when agent is suspended" $ - withSmpServer t testSuspendingAgent + withSmpServer ps testSuspendingAgent it "should complete sending messages when agent is suspended" $ - testSuspendingAgentCompleteSending t + testSuspendingAgentCompleteSending ps it "should suspend agent on timeout, even if pending messages not sent" $ - testSuspendingAgentTimeout t + testSuspendingAgentTimeout ps describe "Batching SMP commands" $ do -- disable this and enable the following test to run tests with coverage it "should subscribe to multiple (200) subscriptions with batching" $ - testBatchedSubscriptions 200 10 t + testBatchedSubscriptions 200 10 ps skip "faster version of the previous test (200 subscriptions gets very slow with test coverage)" $ it "should subscribe to multiple (6) subscriptions with batching" $ - testBatchedSubscriptions 6 3 t + testBatchedSubscriptions 6 3 ps it "should subscribe to multiple connections with pending messages" $ - withSmpServer t $ + withSmpServer ps $ testBatchedPendingMessages 10 5 describe "Batch send messages" $ do - it "should send multiple messages to the same connection" $ withSmpServer t testSendMessagesB - it "should send messages to the 2 connections" $ withSmpServer t testSendMessagesB2 + it "should send multiple messages to the same connection" $ withSmpServer ps testSendMessagesB + it "should send messages to the 2 connections" $ withSmpServer ps testSendMessagesB2 describe "Async agent commands" $ do describe "connect using async agent commands" $ - testBasicMatrix2 t testAsyncCommands + testBasicMatrix2 ps testAsyncCommands it "should restore and complete async commands on restart" $ - testAsyncCommandsRestore t + testAsyncCommandsRestore ps describe "accept connection using async command" $ - testBasicMatrix2 t testAcceptContactAsync + testBasicMatrix2 ps testAcceptContactAsync it "should delete connections using async command when server connection fails" $ - testDeleteConnectionAsync t + testDeleteConnectionAsync ps it "join connection when reply queue creation fails (v8 - slow handshake)" $ - testJoinConnectionAsyncReplyErrorV8 t + testJoinConnectionAsyncReplyErrorV8 ps it "join connection when reply queue creation fails" $ - testJoinConnectionAsyncReplyError t + testJoinConnectionAsyncReplyError ps describe "delete connection waiting for delivery" $ do it "should delete connection immediately if there are no pending messages" $ - testWaitDeliveryNoPending t + testWaitDeliveryNoPending ps it "should delete connection after waiting for delivery to complete" $ - testWaitDelivery t - it "should delete connection if message can't be delivered due to AUTH error" $ - testWaitDeliveryAUTHErr t - it "should delete connection by timeout even if message wasn't delivered" $ - testWaitDeliveryTimeout t + testWaitDelivery ps + it "should delete connection if message can'ps be delivered due to AUTH error" $ + testWaitDeliveryAUTHErr ps + it "should delete connection by timeout even if message wasn'ps delivered" $ + testWaitDeliveryTimeout ps it "should delete connection by timeout, message in progress can be delivered" $ - testWaitDeliveryTimeout2 t + testWaitDeliveryTimeout2 ps describe "Users" $ do it "should create and delete user with connections" $ - withSmpServer t testUsers + withSmpServer ps testUsers it "should create and delete user without connections" $ - withSmpServer t testDeleteUserQuietly + withSmpServer ps testDeleteUserQuietly it "should create and delete user with connections when server connection fails" $ - testUsersNoServer t + testUsersNoServer ps it "should connect two users and switch session mode" $ - withSmpServer t testTwoUsers + withSmpServer ps testTwoUsers describe "Connection switch" $ do describe "should switch delivery to the new queue" $ - testServerMatrix2 t testSwitchConnection + testServerMatrix2 ps testSwitchConnection describe "should switch to new queue asynchronously" $ - testServerMatrix2 t testSwitchAsync + testServerMatrix2 ps testSwitchAsync describe "should delete connection during switch" $ - testServerMatrix2 t testSwitchDelete + testServerMatrix2 ps testSwitchDelete describe "should abort switch in Started phase" $ - testServerMatrix2 t testAbortSwitchStarted + testServerMatrix2 ps testAbortSwitchStarted describe "should abort switch in Started phase, reinitiate immediately" $ - testServerMatrix2 t testAbortSwitchStartedReinitiate + testServerMatrix2 ps testAbortSwitchStartedReinitiate describe "should prohibit to abort switch in Secured phase" $ - testServerMatrix2 t testCannotAbortSwitchSecured + testServerMatrix2 ps testCannotAbortSwitchSecured describe "should switch two connections simultaneously" $ - testServerMatrix2 t testSwitch2Connections + testServerMatrix2 ps testSwitch2Connections describe "should switch two connections simultaneously, abort one" $ - testServerMatrix2 t testSwitch2ConnectionsAbort1 + testServerMatrix2 ps testSwitch2ConnectionsAbort1 describe "SMP basic auth" $ do forM_ (nub [prevVersion authCmdsSMPVersion, authCmdsSMPVersion, currentServerSMPRelayVersion]) $ \v -> do let baseId = if v >= sndAuthKeySMPVersion then 1 else 3 sqSecured = if v >= sndAuthKeySMPVersion then True else False describe ("v" <> show v <> ": with server auth") $ do -- allow NEW | server auth, v | clnt1 auth, v | clnt2 auth, v | 2 - success, 1 - JOIN fail, 0 - NEW fail - it "success " $ testBasicAuth t True (Just "abcd", v) (Just "abcd", v) (Just "abcd", v) sqSecured baseId `shouldReturn` 2 - it "disabled " $ testBasicAuth t False (Just "abcd", v) (Just "abcd", v) (Just "abcd", v) sqSecured baseId `shouldReturn` 0 - it "NEW fail, no auth " $ testBasicAuth t True (Just "abcd", v) (Nothing, v) (Just "abcd", v) sqSecured baseId `shouldReturn` 0 - it "NEW fail, bad auth " $ testBasicAuth t True (Just "abcd", v) (Just "wrong", v) (Just "abcd", v) sqSecured baseId `shouldReturn` 0 - it "JOIN fail, no auth " $ testBasicAuth t True (Just "abcd", v) (Just "abcd", v) (Nothing, v) sqSecured baseId `shouldReturn` 1 - it "JOIN fail, bad auth " $ testBasicAuth t True (Just "abcd", v) (Just "abcd", v) (Just "wrong", v) sqSecured baseId `shouldReturn` 1 + it "success " $ testBasicAuth ps True (Just "abcd", v) (Just "abcd", v) (Just "abcd", v) sqSecured baseId `shouldReturn` 2 + it "disabled " $ testBasicAuth ps False (Just "abcd", v) (Just "abcd", v) (Just "abcd", v) sqSecured baseId `shouldReturn` 0 + it "NEW fail, no auth " $ testBasicAuth ps True (Just "abcd", v) (Nothing, v) (Just "abcd", v) sqSecured baseId `shouldReturn` 0 + it "NEW fail, bad auth " $ testBasicAuth ps True (Just "abcd", v) (Just "wrong", v) (Just "abcd", v) sqSecured baseId `shouldReturn` 0 + it "JOIN fail, no auth " $ testBasicAuth ps True (Just "abcd", v) (Just "abcd", v) (Nothing, v) sqSecured baseId `shouldReturn` 1 + it "JOIN fail, bad auth " $ testBasicAuth ps True (Just "abcd", v) (Just "abcd", v) (Just "wrong", v) sqSecured baseId `shouldReturn` 1 describe ("v" <> show v <> ": no server auth") $ do - it "success " $ testBasicAuth t True (Nothing, v) (Nothing, v) (Nothing, v) sqSecured baseId `shouldReturn` 2 - it "srv disabled" $ testBasicAuth t False (Nothing, v) (Nothing, v) (Nothing, v) sqSecured baseId `shouldReturn` 0 - it "auth fst " $ testBasicAuth t True (Nothing, v) (Just "abcd", v) (Nothing, v) sqSecured baseId `shouldReturn` 2 - it "auth snd " $ testBasicAuth t True (Nothing, v) (Nothing, v) (Just "abcd", v) sqSecured baseId `shouldReturn` 2 - it "auth both " $ testBasicAuth t True (Nothing, v) (Just "abcd", v) (Just "abcd", v) sqSecured baseId `shouldReturn` 2 - it "auth, disabled" $ testBasicAuth t False (Nothing, v) (Just "abcd", v) (Just "abcd", v) sqSecured baseId `shouldReturn` 0 + it "success " $ testBasicAuth ps True (Nothing, v) (Nothing, v) (Nothing, v) sqSecured baseId `shouldReturn` 2 + it "srv disabled" $ testBasicAuth ps False (Nothing, v) (Nothing, v) (Nothing, v) sqSecured baseId `shouldReturn` 0 + it "auth fst " $ testBasicAuth ps True (Nothing, v) (Just "abcd", v) (Nothing, v) sqSecured baseId `shouldReturn` 2 + it "auth snd " $ testBasicAuth ps True (Nothing, v) (Nothing, v) (Just "abcd", v) sqSecured baseId `shouldReturn` 2 + it "auth both " $ testBasicAuth ps True (Nothing, v) (Just "abcd", v) (Just "abcd", v) sqSecured baseId `shouldReturn` 2 + it "auth, disabled" $ testBasicAuth ps False (Nothing, v) (Just "abcd", v) (Just "abcd", v) sqSecured baseId `shouldReturn` 0 describe "SMP server test via agent API" $ do - it "should pass without basic auth" $ testSMPServerConnectionTest t Nothing (noAuthSrv testSMPServer2) `shouldReturn` Nothing + it "should pass without basic auth" $ testSMPServerConnectionTest ps Nothing (noAuthSrv testSMPServer2) `shouldReturn` Nothing let srv1 = testSMPServer2 {keyHash = "1234"} it "should fail with incorrect fingerprint" $ do - testSMPServerConnectionTest t Nothing (noAuthSrv srv1) `shouldReturn` Just (ProtocolTestFailure TSConnect $ BROKER (B.unpack $ strEncode srv1) NETWORK) + testSMPServerConnectionTest ps Nothing (noAuthSrv srv1) `shouldReturn` Just (ProtocolTestFailure TSConnect $ BROKER (B.unpack $ strEncode srv1) NETWORK) describe "server with password" $ do let auth = Just "abcd" srv = ProtoServerWithAuth testSMPServer2 authErr = Just (ProtocolTestFailure TSCreateQueue $ SMP (B.unpack $ strEncode testSMPServer2) AUTH) - it "should pass with correct password" $ testSMPServerConnectionTest t auth (srv auth) `shouldReturn` Nothing - it "should fail without password" $ testSMPServerConnectionTest t auth (srv Nothing) `shouldReturn` authErr - it "should fail with incorrect password" $ testSMPServerConnectionTest t auth (srv $ Just "wrong") `shouldReturn` authErr + it "should pass with correct password" $ testSMPServerConnectionTest ps auth (srv auth) `shouldReturn` Nothing + it "should fail without password" $ testSMPServerConnectionTest ps auth (srv Nothing) `shouldReturn` authErr + it "should fail with incorrect password" $ testSMPServerConnectionTest ps auth (srv $ Just "wrong") `shouldReturn` authErr describe "getRatchetAdHash" $ it "should return the same data for both peers" $ - withSmpServer t testRatchetAdHash + withSmpServer ps testRatchetAdHash describe "Delivery receipts" $ do - it "should send and receive delivery receipt" $ withSmpServer t testDeliveryReceipts - it "should send delivery receipt only in connection v3+" $ testDeliveryReceiptsVersion t - it "send delivery receipts concurrently with messages" $ testDeliveryReceiptsConcurrent t + it "should send and receive delivery receipt" $ withSmpServer ps testDeliveryReceipts + it "should send delivery receipt only in connection v3+" $ testDeliveryReceiptsVersion ps + it "send delivery receipts concurrently with messages" $ testDeliveryReceiptsConcurrent ps describe "user network info" $ do it "should wait for user network" testWaitForUserNetwork it "should not reset online to offline if happens too quickly" testDoNotResetOnlineToOffline it "should resume multiple threads" testResumeMultipleThreads describe "SMP queue info" $ do it "server should respond with queue and subscription information" $ - withSmpServer t testServerQueueInfo + withSmpServer ps testServerQueueInfo -testBasicAuth :: ATransport -> Bool -> (Maybe BasicAuth, VersionSMP) -> (Maybe BasicAuth, VersionSMP) -> (Maybe BasicAuth, VersionSMP) -> SndQueueSecured -> AgentMsgId -> IO Int -testBasicAuth t allowNewQueues srv@(srvAuth, srvVersion) clnt1 clnt2 sqSecured baseId = do - let testCfg = cfg {allowNewQueues, newQueueBasicAuth = srvAuth, smpServerVRange = V.mkVersionRange minServerSMPRelayVersion srvVersion} +testBasicAuth :: (ATransport, AStoreType) -> Bool -> (Maybe BasicAuth, VersionSMP) -> (Maybe BasicAuth, VersionSMP) -> (Maybe BasicAuth, VersionSMP) -> SndQueueSecured -> AgentMsgId -> IO Int +testBasicAuth (t, msType) allowNewQueues srv@(srvAuth, srvVersion) clnt1 clnt2 sqSecured baseId = do + let testCfg = (cfgMS msType) {allowNewQueues, newQueueBasicAuth = srvAuth, smpServerVRange = V.mkVersionRange minServerSMPRelayVersion srvVersion} canCreate1 = canCreateQueue allowNewQueues srv clnt1 canCreate2 = canCreateQueue allowNewQueues srv clnt2 expected @@ -489,57 +489,57 @@ canCreateQueue :: Bool -> (Maybe BasicAuth, VersionSMP) -> (Maybe BasicAuth, Ver canCreateQueue allowNew (srvAuth, _) (clntAuth, _) = allowNew && (isNothing srvAuth || srvAuth == clntAuth) -testMatrix2 :: HasCallStack => ATransport -> (PQSupport -> SndQueueSecured -> Bool -> AgentClient -> AgentClient -> AgentMsgId -> IO ()) -> Spec -testMatrix2 t runTest = do - it "current, via proxy" $ withSmpServerProxy t $ runTestCfgServers2 agentCfg agentCfg (initAgentServersProxy SPMAlways SPFProhibit) 1 $ runTest PQSupportOn True True - it "v8, via proxy" $ withSmpServerProxy t $ runTestCfgServers2 agentProxyCfgV8 agentProxyCfgV8 (initAgentServersProxy SPMAlways SPFProhibit) 3 $ runTest PQSupportOn False True - it "current" $ withSmpServer t $ runTestCfg2 agentCfg agentCfg 1 $ runTest PQSupportOn True False - it "prev" $ withSmpServer t $ runTestCfg2 agentCfgVPrev agentCfgVPrev 3 $ runTest PQSupportOff False False - it "prev to current" $ withSmpServer t $ runTestCfg2 agentCfgVPrev agentCfg 3 $ runTest PQSupportOff False False - it "current to prev" $ withSmpServer t $ runTestCfg2 agentCfg agentCfgVPrev 3 $ runTest PQSupportOff False False +testMatrix2 :: HasCallStack => (ATransport, AStoreType) -> (PQSupport -> SndQueueSecured -> Bool -> AgentClient -> AgentClient -> AgentMsgId -> IO ()) -> Spec +testMatrix2 ps runTest = do + it "current, via proxy" $ withSmpServerProxy ps $ runTestCfgServers2 agentCfg agentCfg (initAgentServersProxy SPMAlways SPFProhibit) 1 $ runTest PQSupportOn True True + it "v8, via proxy" $ withSmpServerProxy ps $ runTestCfgServers2 agentProxyCfgV8 agentProxyCfgV8 (initAgentServersProxy SPMAlways SPFProhibit) 3 $ runTest PQSupportOn False True + it "current" $ withSmpServer ps $ runTestCfg2 agentCfg agentCfg 1 $ runTest PQSupportOn True False + it "prev" $ withSmpServer ps $ runTestCfg2 agentCfgVPrev agentCfgVPrev 3 $ runTest PQSupportOff False False + it "prev to current" $ withSmpServer ps $ runTestCfg2 agentCfgVPrev agentCfg 3 $ runTest PQSupportOff False False + it "current to prev" $ withSmpServer ps $ runTestCfg2 agentCfg agentCfgVPrev 3 $ runTest PQSupportOff False False -testMatrix2Stress :: HasCallStack => ATransport -> (PQSupport -> SndQueueSecured -> Bool -> AgentClient -> AgentClient -> AgentMsgId -> IO ()) -> Spec -testMatrix2Stress t runTest = do - it "current, via proxy" $ withSmpServerProxy t $ runTestCfgServers2 aCfg aCfg (initAgentServersProxy SPMAlways SPFProhibit) 1 $ runTest PQSupportOn True True - it "v8, via proxy" $ withSmpServerProxy t $ runTestCfgServers2 aProxyCfgV8 aProxyCfgV8 (initAgentServersProxy SPMAlways SPFProhibit) 3 $ runTest PQSupportOn False True - it "current" $ withSmpServer t $ runTestCfg2 aCfg aCfg 1 $ runTest PQSupportOn True False - it "prev" $ withSmpServer t $ runTestCfg2 aCfgVPrev aCfgVPrev 3 $ runTest PQSupportOff False False - it "prev to current" $ withSmpServer t $ runTestCfg2 aCfgVPrev aCfg 3 $ runTest PQSupportOff False False - it "current to prev" $ withSmpServer t $ runTestCfg2 aCfg aCfgVPrev 3 $ runTest PQSupportOff False False +testMatrix2Stress :: HasCallStack => (ATransport, AStoreType) -> (PQSupport -> SndQueueSecured -> Bool -> AgentClient -> AgentClient -> AgentMsgId -> IO ()) -> Spec +testMatrix2Stress ps runTest = do + it "current, via proxy" $ withSmpServerProxy ps $ runTestCfgServers2 aCfg aCfg (initAgentServersProxy SPMAlways SPFProhibit) 1 $ runTest PQSupportOn True True + it "v8, via proxy" $ withSmpServerProxy ps $ runTestCfgServers2 aProxyCfgV8 aProxyCfgV8 (initAgentServersProxy SPMAlways SPFProhibit) 3 $ runTest PQSupportOn False True + it "current" $ withSmpServer ps $ runTestCfg2 aCfg aCfg 1 $ runTest PQSupportOn True False + it "prev" $ withSmpServer ps $ runTestCfg2 aCfgVPrev aCfgVPrev 3 $ runTest PQSupportOff False False + it "prev to current" $ withSmpServer ps $ runTestCfg2 aCfgVPrev aCfg 3 $ runTest PQSupportOff False False + it "current to prev" $ withSmpServer ps $ runTestCfg2 aCfg aCfgVPrev 3 $ runTest PQSupportOff False False where aCfg = agentCfg {messageRetryInterval = fastMessageRetryInterval} aProxyCfgV8 = agentProxyCfgV8 {messageRetryInterval = fastMessageRetryInterval} aCfgVPrev = agentCfgVPrev {messageRetryInterval = fastMessageRetryInterval} -testBasicMatrix2 :: HasCallStack => ATransport -> (SndQueueSecured -> AgentClient -> AgentClient -> AgentMsgId -> IO ()) -> Spec -testBasicMatrix2 t runTest = do - it "current" $ withSmpServer t $ runTestCfg2 agentCfg agentCfg 1 $ runTest True - it "prev" $ withSmpServer t $ runTestCfg2 agentCfgVPrevPQ agentCfgVPrevPQ 3 $ runTest False - it "prev to current" $ withSmpServer t $ runTestCfg2 agentCfgVPrevPQ agentCfg 3 $ runTest False - it "current to prev" $ withSmpServer t $ runTestCfg2 agentCfg agentCfgVPrevPQ 3 $ runTest False +testBasicMatrix2 :: HasCallStack => (ATransport, AStoreType) -> (SndQueueSecured -> AgentClient -> AgentClient -> AgentMsgId -> IO ()) -> Spec +testBasicMatrix2 ps runTest = do + it "current" $ withSmpServer ps $ runTestCfg2 agentCfg agentCfg 1 $ runTest True + it "prev" $ withSmpServer ps $ runTestCfg2 agentCfgVPrevPQ agentCfgVPrevPQ 3 $ runTest False + it "prev to current" $ withSmpServer ps $ runTestCfg2 agentCfgVPrevPQ agentCfg 3 $ runTest False + it "current to prev" $ withSmpServer ps $ runTestCfg2 agentCfg agentCfgVPrevPQ 3 $ runTest False -testRatchetMatrix2 :: HasCallStack => ATransport -> (PQSupport -> SndQueueSecured -> Bool -> AgentClient -> AgentClient -> AgentMsgId -> IO ()) -> Spec -testRatchetMatrix2 t runTest = do - it "current, via proxy" $ withSmpServerProxy t $ runTestCfgServers2 agentCfg agentCfg (initAgentServersProxy SPMAlways SPFProhibit) 1 $ runTest PQSupportOn True True - it "v8, via proxy" $ withSmpServerProxy t $ runTestCfgServers2 agentProxyCfgV8 agentProxyCfgV8 (initAgentServersProxy SPMAlways SPFProhibit) 3 $ runTest PQSupportOn False True - it "ratchet current" $ withSmpServer t $ runTestCfg2 agentCfg agentCfg 1 $ runTest PQSupportOn True False - it "ratchet prev" $ withSmpServer t $ runTestCfg2 agentCfgRatchetVPrev agentCfgRatchetVPrev 1 $ runTest PQSupportOff True False - it "ratchets prev to current" $ withSmpServer t $ runTestCfg2 agentCfgRatchetVPrev agentCfg 1 $ runTest PQSupportOff True False - it "ratchets current to prev" $ withSmpServer t $ runTestCfg2 agentCfg agentCfgRatchetVPrev 1 $ runTest PQSupportOff True False +testRatchetMatrix2 :: HasCallStack => (ATransport, AStoreType) -> (PQSupport -> SndQueueSecured -> Bool -> AgentClient -> AgentClient -> AgentMsgId -> IO ()) -> Spec +testRatchetMatrix2 ps runTest = do + it "current, via proxy" $ withSmpServerProxy ps $ runTestCfgServers2 agentCfg agentCfg (initAgentServersProxy SPMAlways SPFProhibit) 1 $ runTest PQSupportOn True True + it "v8, via proxy" $ withSmpServerProxy ps $ runTestCfgServers2 agentProxyCfgV8 agentProxyCfgV8 (initAgentServersProxy SPMAlways SPFProhibit) 3 $ runTest PQSupportOn False True + it "ratchet current" $ withSmpServer ps $ runTestCfg2 agentCfg agentCfg 1 $ runTest PQSupportOn True False + it "ratchet prev" $ withSmpServer ps $ runTestCfg2 agentCfgRatchetVPrev agentCfgRatchetVPrev 1 $ runTest PQSupportOff True False + it "ratchets prev to current" $ withSmpServer ps $ runTestCfg2 agentCfgRatchetVPrev agentCfg 1 $ runTest PQSupportOff True False + it "ratchets current to prev" $ withSmpServer ps $ runTestCfg2 agentCfg agentCfgRatchetVPrev 1 $ runTest PQSupportOff True False -testServerMatrix2 :: HasCallStack => ATransport -> (InitialAgentServers -> IO ()) -> Spec -testServerMatrix2 t runTest = do - it "1 server" $ withSmpServer t $ runTest initAgentServers - it "2 servers" $ withSmpServer t $ withSmpServerConfigOn t cfgJ2 testPort2 $ \_ -> runTest initAgentServers2 +testServerMatrix2 :: HasCallStack => (ATransport, AStoreType) -> (InitialAgentServers -> IO ()) -> Spec +testServerMatrix2 ps@(t, ASType qs _ms) runTest = do + it "1 server" $ withSmpServer ps $ runTest initAgentServers + it "2 servers" $ withSmpServer ps $ withSmpServerConfigOn t (cfgJ2QS qs) testPort2 $ \_ -> runTest initAgentServers2 -testPQMatrix2 :: HasCallStack => ATransport -> (HasCallStack => (AgentClient, InitialKeys) -> (AgentClient, PQSupport) -> AgentMsgId -> IO ()) -> Spec +testPQMatrix2 :: HasCallStack => (ATransport, AStoreType) -> (HasCallStack => (AgentClient, InitialKeys) -> (AgentClient, PQSupport) -> AgentMsgId -> IO ()) -> Spec testPQMatrix2 = pqMatrix2_ True -testPQMatrix2NoInv :: HasCallStack => ATransport -> (HasCallStack => (AgentClient, InitialKeys) -> (AgentClient, PQSupport) -> AgentMsgId -> IO ()) -> Spec +testPQMatrix2NoInv :: HasCallStack => (ATransport, AStoreType) -> (HasCallStack => (AgentClient, InitialKeys) -> (AgentClient, PQSupport) -> AgentMsgId -> IO ()) -> Spec testPQMatrix2NoInv = pqMatrix2_ False -pqMatrix2_ :: HasCallStack => Bool -> ATransport -> (HasCallStack => (AgentClient, InitialKeys) -> (AgentClient, PQSupport) -> AgentMsgId -> IO ()) -> Spec -pqMatrix2_ pqInv t test = do +pqMatrix2_ :: HasCallStack => Bool -> (ATransport, AStoreType) -> (HasCallStack => (AgentClient, InitialKeys) -> (AgentClient, PQSupport) -> AgentMsgId -> IO ()) -> Spec +pqMatrix2_ pqInv ps test = do it "dh/dh handshake" $ runTest $ \a b -> test (a, IKPQOff) (b, PQSupportOff) it "dh/pq handshake" $ runTest $ \a b -> test (a, IKPQOff) (b, PQSupportOn) it "pq/dh handshake" $ runTest $ \a b -> test (a, IKPQOn) (b, PQSupportOff) @@ -548,14 +548,14 @@ pqMatrix2_ pqInv t test = do it "pq-inv/dh handshake" $ runTest $ \a b -> test (a, IKUsePQ) (b, PQSupportOff) it "pq-inv/pq handshake" $ runTest $ \a b -> test (a, IKUsePQ) (b, PQSupportOn) where - runTest = withSmpServerProxy t . runTestCfgServers2 agentProxyCfgV8 agentProxyCfgV8 (initAgentServersProxy SPMAlways SPFProhibit) 3 + runTest = withSmpServerProxy ps . runTestCfgServers2 agentProxyCfgV8 agentProxyCfgV8 (initAgentServersProxy SPMAlways SPFProhibit) 3 testPQMatrix3 :: HasCallStack => - ATransport -> + (ATransport, AStoreType) -> (HasCallStack => (AgentClient, InitialKeys) -> (AgentClient, PQSupport) -> (AgentClient, PQSupport) -> AgentMsgId -> IO ()) -> Spec -testPQMatrix3 t test = do +testPQMatrix3 ps test = do it "dh" $ runTest $ \a b c -> test (a, IKPQOff) (b, PQSupportOff) (c, PQSupportOff) it "dh/dh/pq" $ runTest $ \a b c -> test (a, IKPQOff) (b, PQSupportOff) (c, PQSupportOn) it "dh/pq/dh" $ runTest $ \a b c -> test (a, IKPQOff) (b, PQSupportOn) (c, PQSupportOff) @@ -566,7 +566,7 @@ testPQMatrix3 t test = do it "pq" $ runTest $ \a b c -> test (a, IKPQOn) (b, PQSupportOn) (c, PQSupportOn) where runTest test' = - withSmpServerProxy t $ + withSmpServerProxy ps $ runTestCfgServers2 agentProxyCfgV8 agentProxyCfgV8 servers 3 $ \a b baseMsgId -> withAgent 3 agentProxyCfgV8 servers testDB3 $ \c -> test' a b c baseMsgId servers = initAgentServersProxy SPMAlways SPFProhibit @@ -1009,10 +1009,10 @@ testAsyncBothOffline = do liftIO $ disposeAgentClient alice' liftIO $ disposeAgentClient bob' -testAsyncServerOffline :: HasCallStack => ATransport -> IO () -testAsyncServerOffline t = withAgentClients2 $ \alice bob -> do +testAsyncServerOffline :: HasCallStack => (ATransport, AStoreType) -> IO () +testAsyncServerOffline ps = withAgentClients2 $ \alice bob -> do -- create connection and shutdown the server - (bobId, cReq) <- withSmpServerStoreLogOn t testPort $ \_ -> + (bobId, cReq) <- withSmpServerStoreLogOn ps testPort $ \_ -> runRight $ createConnection alice 1 True SCMInvitation Nothing SMSubscribe -- connection fails Left (BROKER _ NETWORK) <- runExceptT $ joinConnection bob 1 True cReq "bob's connInfo" SMSubscribe @@ -1020,7 +1020,7 @@ testAsyncServerOffline t = withAgentClients2 $ \alice bob -> do srv `shouldBe` testSMPServer conns `shouldBe` [bobId] -- connection succeeds after server start - withSmpServerStoreLogOn t testPort $ \_ -> runRight_ $ do + withSmpServerStoreLogOn ps testPort $ \_ -> runRight_ $ do ("", "", UP srv1 conns1) <- nGet alice liftIO $ do srv1 `shouldBe` testSMPServer @@ -1034,14 +1034,14 @@ testAsyncServerOffline t = withAgentClients2 $ \alice bob -> do get bob ##> ("", aliceId, CON) exchangeGreetings alice bobId bob aliceId -testAllowConnectionClientRestart :: HasCallStack => ATransport -> IO () -testAllowConnectionClientRestart t = do +testAllowConnectionClientRestart :: HasCallStack => (ATransport, AStoreType) -> IO () +testAllowConnectionClientRestart ps@(t, ASType qsType _) = do let initAgentServersSrv2 = initAgentServers {smp = userServers [testSMPServer2]} alice <- getSMPAgentClient' 1 agentCfg initAgentServers testDB bob <- getSMPAgentClient' 2 agentCfg initAgentServersSrv2 testDB2 - withSmpServerStoreLogOn t testPort $ \_ -> do + withSmpServerStoreLogOn ps testPort $ \_ -> do (aliceId, bobId, confId) <- - withSmpServerConfigOn t cfgJ2 testPort2 $ \_ -> do + withSmpServerConfigOn t (cfgJ2QS 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 @@ -1063,7 +1063,7 @@ testAllowConnectionClientRestart t = do alice2 <- getSMPAgentClient' 3 agentCfg initAgentServers testDB runRight_ $ subscribeConnection alice2 bobId threadDelay 500000 - withSmpServerConfigOn t cfgJ2 testPort2 $ \_ -> do + withSmpServerConfigOn t (cfgJ2QS qsType) testPort2 $ \_ -> do runRight $ do ("", "", UP _ _) <- nGet bob get alice2 ##> ("", bobId, CON) @@ -1073,11 +1073,11 @@ testAllowConnectionClientRestart t = do disposeAgentClient alice2 disposeAgentClient bob -testIncreaseConnAgentVersion :: HasCallStack => ATransport -> IO () -testIncreaseConnAgentVersion t = do +testIncreaseConnAgentVersion :: HasCallStack => (ATransport, AStoreType) -> IO () +testIncreaseConnAgentVersion ps = do alice <- getSMPAgentClient' 1 agentCfg {smpAgentVRange = mkVersionRange 1 2} initAgentServers testDB bob <- getSMPAgentClient' 2 agentCfg {smpAgentVRange = mkVersionRange 1 2} initAgentServers testDB2 - withSmpServerStoreMsgLogOn t testPort $ \_ -> do + withSmpServerStoreMsgLogOn ps testPort $ \_ -> do (aliceId, bobId) <- runRight $ do (aliceId, bobId) <- makeConnection_ PQSupportOff False alice bob exchangeGreetingsMsgId_ PQEncOff 2 alice bobId bob aliceId @@ -1138,11 +1138,11 @@ checkVersion c connId v = do ConnectionStats {connAgentVersion} <- getConnectionServers c connId liftIO $ connAgentVersion `shouldBe` VersionSMPA v -testIncreaseConnAgentVersionMaxCompatible :: HasCallStack => ATransport -> IO () -testIncreaseConnAgentVersionMaxCompatible t = do +testIncreaseConnAgentVersionMaxCompatible :: HasCallStack => (ATransport, AStoreType) -> IO () +testIncreaseConnAgentVersionMaxCompatible ps = do alice <- getSMPAgentClient' 1 agentCfg {smpAgentVRange = mkVersionRange 1 2} initAgentServers testDB bob <- getSMPAgentClient' 2 agentCfg {smpAgentVRange = mkVersionRange 1 2} initAgentServers testDB2 - withSmpServerStoreMsgLogOn t testPort $ \_ -> do + withSmpServerStoreMsgLogOn ps testPort $ \_ -> do (aliceId, bobId) <- runRight $ do (aliceId, bobId) <- makeConnection_ PQSupportOff False alice bob exchangeGreetingsMsgId_ PQEncOff 2 alice bobId bob aliceId @@ -1168,11 +1168,11 @@ testIncreaseConnAgentVersionMaxCompatible t = do disposeAgentClient alice2 disposeAgentClient bob2 -testIncreaseConnAgentVersionStartDifferentVersion :: HasCallStack => ATransport -> IO () -testIncreaseConnAgentVersionStartDifferentVersion t = do +testIncreaseConnAgentVersionStartDifferentVersion :: HasCallStack => (ATransport, AStoreType) -> IO () +testIncreaseConnAgentVersionStartDifferentVersion ps = do alice <- getSMPAgentClient' 1 agentCfg {smpAgentVRange = mkVersionRange 1 2} initAgentServers testDB bob <- getSMPAgentClient' 2 agentCfg {smpAgentVRange = mkVersionRange 1 3} initAgentServers testDB2 - withSmpServerStoreMsgLogOn t testPort $ \_ -> do + withSmpServerStoreMsgLogOn ps testPort $ \_ -> do (aliceId, bobId) <- runRight $ do (aliceId, bobId) <- makeConnection_ PQSupportOff False alice bob exchangeGreetingsMsgId_ PQEncOff 2 alice bobId bob aliceId @@ -1194,12 +1194,12 @@ testIncreaseConnAgentVersionStartDifferentVersion t = do disposeAgentClient alice2 disposeAgentClient bob -testDeliverClientRestart :: HasCallStack => ATransport -> IO () -testDeliverClientRestart t = do +testDeliverClientRestart :: HasCallStack => (ATransport, AStoreType) -> IO () +testDeliverClientRestart ps = do alice <- getSMPAgentClient' 1 agentCfg initAgentServers testDB bob <- getSMPAgentClient' 2 agentCfg initAgentServers testDB2 - (aliceId, bobId) <- withSmpServerStoreMsgLogOn t testPort $ \_ -> do + (aliceId, bobId) <- withSmpServerStoreMsgLogOn ps testPort $ \_ -> do runRight $ do (aliceId, bobId) <- makeConnection alice bob exchangeGreetings alice bobId bob aliceId @@ -1214,7 +1214,7 @@ testDeliverClientRestart t = do bob2 <- getSMPAgentClient' 3 agentCfg initAgentServers testDB2 - withSmpServerStoreMsgLogOn t testPort $ \_ -> do + withSmpServerStoreMsgLogOn ps testPort $ \_ -> do runRight_ $ do ("", "", UP _ _) <- nGet alice @@ -1225,11 +1225,11 @@ testDeliverClientRestart t = do disposeAgentClient alice disposeAgentClient bob2 -testDuplicateMessage :: HasCallStack => ATransport -> IO () -testDuplicateMessage t = do +testDuplicateMessage :: HasCallStack => (ATransport, AStoreType) -> IO () +testDuplicateMessage ps = do alice <- getSMPAgentClient' 1 agentCfg initAgentServers testDB bob <- getSMPAgentClient' 2 agentCfg initAgentServers testDB2 - (aliceId, bobId, bob1) <- withSmpServerStoreMsgLogOn t testPort $ \_ -> do + (aliceId, bobId, bob1) <- withSmpServerStoreMsgLogOn ps testPort $ \_ -> do (aliceId, bobId) <- runRight $ makeConnection alice bob runRight_ $ do 2 <- sendMessage alice bobId SMP.noMsgFlags "hello" @@ -1264,7 +1264,7 @@ testDuplicateMessage t = do alice2 <- getSMPAgentClient' 4 agentCfg initAgentServers testDB bob2 <- getSMPAgentClient' 5 agentCfg initAgentServers testDB2 - withSmpServerStoreMsgLogOn t testPort $ \_ -> do + withSmpServerStoreMsgLogOn ps testPort $ \_ -> do runRight_ $ do subscribeConnection bob2 aliceId subscribeConnection alice2 bobId @@ -1277,8 +1277,8 @@ testDuplicateMessage t = do disposeAgentClient alice2 disposeAgentClient bob2 -testSkippedMessages :: HasCallStack => ATransport -> IO () -testSkippedMessages t = do +testSkippedMessages :: HasCallStack => (ATransport, AStoreType) -> IO () +testSkippedMessages (t, msType) = do alice <- getSMPAgentClient' 1 agentCfg initAgentServers testDB bob <- getSMPAgentClient' 2 agentCfg initAgentServers testDB2 (aliceId, bobId) <- withSmpServerConfigOn t cfg' testPort $ \_ -> do @@ -1326,12 +1326,12 @@ testSkippedMessages t = do disposeAgentClient alice2 disposeAgentClient bob2 where - cfg' = cfg {serverStoreCfg = ASSCfg SQSMemory SMSMemory $ SSCMemory $ Just $ StorePaths testStoreLogFile Nothing} + cfg' = (cfgMS msType) {serverStoreCfg = ASSCfg SQSMemory SMSMemory $ SSCMemory $ Just $ StorePaths testStoreLogFile Nothing} -testDeliveryAfterSubscriptionError :: HasCallStack => ATransport -> IO () -testDeliveryAfterSubscriptionError t = do +testDeliveryAfterSubscriptionError :: HasCallStack => (ATransport, AStoreType) -> IO () +testDeliveryAfterSubscriptionError ps = do (aId, bId) <- withAgentClients2 $ \a b -> do - (aId, bId) <- withSmpServerStoreLogOn t testPort $ \_ -> runRight $ makeConnection a b + (aId, bId) <- withSmpServerStoreLogOn ps testPort $ \_ -> runRight $ makeConnection a b nGet a =##> \case ("", "", DOWN _ [c]) -> c == bId; _ -> False nGet b =##> \case ("", "", DOWN _ [c]) -> c == aId; _ -> False 2 <- runRight $ sendMessage a bId SMP.noMsgFlags "hello" @@ -1341,14 +1341,14 @@ testDeliveryAfterSubscriptionError t = do withAgentClients2 $ \a b -> do Left (BROKER _ NETWORK) <- runExceptT $ subscribeConnection a bId Left (BROKER _ NETWORK) <- runExceptT $ subscribeConnection b aId - withSmpServerStoreLogOn t testPort $ \_ -> runRight $ do + withSmpServerStoreLogOn ps testPort $ \_ -> runRight $ do withUP a bId $ \case ("", c, SENT 2) -> c == bId; _ -> False withUP b aId $ \case ("", c, Msg "hello") -> c == aId; _ -> False ackMessage b aId 2 Nothing -testMsgDeliveryQuotaExceeded :: HasCallStack => ATransport -> IO () -testMsgDeliveryQuotaExceeded t = - withAgentClients2 $ \a b -> withSmpServerStoreLogOn t testPort $ \_ -> runRight_ $ do +testMsgDeliveryQuotaExceeded :: HasCallStack => (ATransport, AStoreType) -> IO () +testMsgDeliveryQuotaExceeded ps = + withAgentClients2 $ \a b -> withSmpServerStoreLogOn ps testPort $ \_ -> runRight_ $ do (aId, bId) <- makeConnection a b (aId', bId') <- makeConnection a b forM_ ([1 .. 4] :: [Int]) $ \i -> do @@ -1374,27 +1374,27 @@ testMsgDeliveryQuotaExceeded t = get a =##> \case ("", c, SENT 6) -> bId == c; _ -> False liftIO $ concurrently_ (noMessages a "no more events") (noMessages b "no more events") -testExpireMessage :: HasCallStack => ATransport -> IO () -testExpireMessage t = +testExpireMessage :: HasCallStack => (ATransport, AStoreType) -> IO () +testExpireMessage ps = withAgent 1 agentCfg {messageTimeout = 1.5, messageRetryInterval = fastMessageRetryInterval} initAgentServers testDB $ \a -> withAgent 2 agentCfg initAgentServers testDB2 $ \b -> do - (aId, bId) <- withSmpServerStoreLogOn t testPort $ \_ -> runRight $ makeConnection a b + (aId, bId) <- withSmpServerStoreLogOn ps testPort $ \_ -> runRight $ makeConnection a b nGet a =##> \case ("", "", DOWN _ [c]) -> c == bId; _ -> False nGet b =##> \case ("", "", DOWN _ [c]) -> c == aId; _ -> False 2 <- runRight $ sendMessage a bId SMP.noMsgFlags "1" threadDelay 1500000 3 <- runRight $ sendMessage a bId SMP.noMsgFlags "2" -- this won't expire get a =##> \case ("", c, MERR 2 (BROKER _ e)) -> bId == c && (e == TIMEOUT || e == NETWORK); _ -> False - withSmpServerStoreLogOn t testPort $ \_ -> runRight_ $ do + withSmpServerStoreLogOn ps testPort $ \_ -> runRight_ $ do withUP a bId $ \case ("", _, SENT 3) -> True; _ -> False withUP b aId $ \case ("", _, MsgErr 2 (MsgSkipped 2 2) "2") -> True; _ -> False ackMessage b aId 2 Nothing -testExpireManyMessages :: HasCallStack => ATransport -> IO () -testExpireManyMessages t = +testExpireManyMessages :: HasCallStack => (ATransport, AStoreType) -> IO () +testExpireManyMessages ps = withAgent 1 agentCfg {messageTimeout = 2, messageRetryInterval = fastMessageRetryInterval} initAgentServers testDB $ \a -> withAgent 2 agentCfg initAgentServers testDB2 $ \b -> do - (aId, bId) <- withSmpServerStoreLogOn t testPort $ \_ -> runRight $ makeConnection a b + (aId, bId) <- withSmpServerStoreLogOn ps testPort $ \_ -> runRight $ makeConnection a b runRight_ $ do nGet a =##> \case ("", "", DOWN _ [c]) -> c == bId; _ -> False nGet b =##> \case ("", "", DOWN _ [c]) -> c == aId; _ -> False @@ -1415,7 +1415,7 @@ testExpireManyMessages t = ("", c, MERRS [3, 4] (BROKER _ e)) -> liftIO $ expected c e `shouldBe` True r -> error $ show r - withSmpServerStoreLogOn t testPort $ \_ -> runRight_ $ do + withSmpServerStoreLogOn ps testPort $ \_ -> runRight_ $ do withUP a bId $ \case ("", _, SENT 5) -> True; _ -> False withUP b aId $ \case ("", _, MsgErr 2 (MsgSkipped 2 4) "4") -> True; _ -> False ackMessage b aId 2 Nothing @@ -1429,8 +1429,8 @@ withUP a bId p = \case (corrId, c, AEvt SAEConn cmd) -> c == bId && p (corrId, c, cmd); _ -> False ] -testExpireMessageQuota :: HasCallStack => ATransport -> IO () -testExpireMessageQuota t = withSmpServerConfigOn t cfg {msgQueueQuota = 1, maxJournalMsgCount = 2} testPort $ \_ -> do +testExpireMessageQuota :: HasCallStack => (ATransport, AStoreType) -> IO () +testExpireMessageQuota (t, msType) = withSmpServerConfigOn t (cfgMS msType) {msgQueueQuota = 1, maxJournalMsgCount = 2} testPort $ \_ -> do a <- getSMPAgentClient' 1 agentCfg {quotaExceededTimeout = 1, messageRetryInterval = fastMessageRetryInterval} initAgentServers testDB b <- getSMPAgentClient' 2 agentCfg initAgentServers testDB2 (aId, bId) <- runRight $ do @@ -1455,8 +1455,8 @@ testExpireMessageQuota t = withSmpServerConfigOn t cfg {msgQueueQuota = 1, maxJo ackMessage b' aId 4 Nothing disposeAgentClient a -testExpireManyMessagesQuota :: ATransport -> IO () -testExpireManyMessagesQuota t = withSmpServerConfigOn t cfg {msgQueueQuota = 1, maxJournalMsgCount = 2} testPort $ \_ -> do +testExpireManyMessagesQuota :: (ATransport, AStoreType) -> IO () +testExpireManyMessagesQuota (t, msType) = withSmpServerConfigOn t (cfgMS msType) {msgQueueQuota = 1, maxJournalMsgCount = 2} testPort $ \_ -> do a <- getSMPAgentClient' 1 agentCfg {quotaExceededTimeout = 2, messageRetryInterval = fastMessageRetryInterval} initAgentServers testDB b <- getSMPAgentClient' 2 agentCfg initAgentServers testDB2 (aId, bId) <- runRight $ do @@ -1492,9 +1492,9 @@ testExpireManyMessagesQuota t = withSmpServerConfigOn t cfg {msgQueueQuota = 1, ackMessage b' aId 4 Nothing disposeAgentClient a -testRatchetSync :: HasCallStack => ATransport -> IO () -testRatchetSync t = withAgentClients2 $ \alice bob -> - withSmpServerStoreMsgLogOn t testPort $ \_ -> do +testRatchetSync :: HasCallStack => (ATransport, AStoreType) -> IO () +testRatchetSync ps = withAgentClients2 $ \alice bob -> + withSmpServerStoreMsgLogOn ps testPort $ \_ -> do (aliceId, bobId, bob2) <- setupDesynchronizedRatchet alice bob runRight $ do ConnectionStats {ratchetSyncState} <- synchronizeRatchet bob2 aliceId PQSupportOn False @@ -1566,9 +1566,9 @@ ratchetSyncP' cId rss = \case cId' == cId && rss' == rss && ratchetSyncState == rss _ -> False -testRatchetSyncServerOffline :: HasCallStack => ATransport -> IO () -testRatchetSyncServerOffline t = withAgentClients2 $ \alice bob -> do - (aliceId, bobId, bob2) <- withSmpServerStoreMsgLogOn t testPort $ \_ -> +testRatchetSyncServerOffline :: HasCallStack => (ATransport, AStoreType) -> IO () +testRatchetSyncServerOffline ps = withAgentClients2 $ \alice bob -> do + (aliceId, bobId, bob2) <- withSmpServerStoreMsgLogOn ps testPort $ \_ -> setupDesynchronizedRatchet alice bob ("", "", DOWN _ _) <- nGet alice @@ -1577,7 +1577,7 @@ testRatchetSyncServerOffline t = withAgentClients2 $ \alice bob -> do ConnectionStats {ratchetSyncState} <- runRight $ synchronizeRatchet bob2 aliceId PQSupportOn False liftIO $ ratchetSyncState `shouldBe` RSStarted - withSmpServerStoreMsgLogOn t testPort $ \_ -> do + withSmpServerStoreMsgLogOn ps testPort $ \_ -> do concurrently_ (getInAnyOrder alice [ratchetSyncP' bobId RSAgreed, serverUpP]) (getInAnyOrder bob2 [ratchetSyncP' aliceId RSAgreed, serverUpP]) @@ -1592,11 +1592,11 @@ serverUpP = \case ("", "", AEvt SAENone (UP _ _)) -> True _ -> False -testRatchetSyncClientRestart :: HasCallStack => ATransport -> IO () -testRatchetSyncClientRestart t = do +testRatchetSyncClientRestart :: HasCallStack => (ATransport, AStoreType) -> IO () +testRatchetSyncClientRestart ps = do alice <- getSMPAgentClient' 1 agentCfg initAgentServers testDB bob <- getSMPAgentClient' 2 agentCfg initAgentServers testDB2 - (aliceId, bobId, bob2) <- withSmpServerStoreMsgLogOn t testPort $ \_ -> + (aliceId, bobId, bob2) <- withSmpServerStoreMsgLogOn ps testPort $ \_ -> setupDesynchronizedRatchet alice bob ("", "", DOWN _ _) <- nGet alice ("", "", DOWN _ _) <- nGet bob2 @@ -1604,7 +1604,7 @@ testRatchetSyncClientRestart t = do ratchetSyncState `shouldBe` RSStarted disposeAgentClient bob2 bob3 <- getSMPAgentClient' 3 agentCfg initAgentServers testDB2 - withSmpServerStoreMsgLogOn t testPort $ \_ -> do + withSmpServerStoreMsgLogOn ps testPort $ \_ -> do runRight_ $ do ("", "", UP _ _) <- nGet alice subscribeConnection bob3 aliceId @@ -1617,11 +1617,11 @@ testRatchetSyncClientRestart t = do disposeAgentClient bob disposeAgentClient bob3 -testRatchetSyncSuspendForeground :: HasCallStack => ATransport -> IO () -testRatchetSyncSuspendForeground t = do +testRatchetSyncSuspendForeground :: HasCallStack => (ATransport, AStoreType) -> IO () +testRatchetSyncSuspendForeground ps = do alice <- getSMPAgentClient' 1 agentCfg initAgentServers testDB bob <- getSMPAgentClient' 2 agentCfg initAgentServers testDB2 - (aliceId, bobId, bob2) <- withSmpServerStoreMsgLogOn t testPort $ \_ -> + (aliceId, bobId, bob2) <- withSmpServerStoreMsgLogOn ps testPort $ \_ -> setupDesynchronizedRatchet alice bob ("", "", DOWN _ _) <- nGet alice @@ -1634,7 +1634,7 @@ testRatchetSyncSuspendForeground t = do threadDelay 100000 foregroundAgent bob2 - withSmpServerStoreMsgLogOn t testPort $ \_ -> do + withSmpServerStoreMsgLogOn ps testPort $ \_ -> do concurrently_ (getInAnyOrder alice [ratchetSyncP' bobId RSAgreed, serverUpP]) (getInAnyOrder bob2 [ratchetSyncP' aliceId RSAgreed, serverUpP]) @@ -1646,11 +1646,11 @@ testRatchetSyncSuspendForeground t = do disposeAgentClient bob disposeAgentClient bob2 -testRatchetSyncSimultaneous :: HasCallStack => ATransport -> IO () -testRatchetSyncSimultaneous t = do +testRatchetSyncSimultaneous :: HasCallStack => (ATransport, AStoreType) -> IO () +testRatchetSyncSimultaneous ps = do alice <- getSMPAgentClient' 1 agentCfg initAgentServers testDB bob <- getSMPAgentClient' 2 agentCfg initAgentServers testDB2 - (aliceId, bobId, bob2) <- withSmpServerStoreMsgLogOn t testPort $ \_ -> + (aliceId, bobId, bob2) <- withSmpServerStoreMsgLogOn ps testPort $ \_ -> setupDesynchronizedRatchet alice bob ("", "", DOWN _ _) <- nGet alice @@ -1662,7 +1662,7 @@ testRatchetSyncSimultaneous t = do ConnectionStats {ratchetSyncState = aRSS} <- runRight $ synchronizeRatchet alice bobId PQSupportOn True liftIO $ aRSS `shouldBe` RSStarted - withSmpServerStoreMsgLogOn t testPort $ \_ -> do + withSmpServerStoreMsgLogOn ps testPort $ \_ -> do concurrently_ (getInAnyOrder alice [ratchetSyncP' bobId RSAgreed, serverUpP]) (getInAnyOrder bob2 [ratchetSyncP' aliceId RSAgreed, serverUpP]) @@ -1773,9 +1773,9 @@ makeConnectionForUsers_ pqSupport sqSecured alice aliceUserId bob bobUserId = do get bob ##> ("", aliceId, A.CON pqEnc) pure (aliceId, bobId) -testInactiveNoSubs :: ATransport -> IO () -testInactiveNoSubs t = do - let cfg' = cfg {inactiveClientExpiration = Just ExpirationConfig {ttl = 1, checkInterval = 1}} +testInactiveNoSubs :: (ATransport, AStoreType) -> IO () +testInactiveNoSubs (t, msType) = do + let cfg' = (cfgMS msType) {inactiveClientExpiration = Just ExpirationConfig {ttl = 1, checkInterval = 1}} withSmpServerConfigOn t cfg' testPort $ \_ -> withAgent 1 agentCfg initAgentServers testDB $ \alice -> do runRight_ . void $ createConnection alice 1 True SCMInvitation Nothing SMOnlyCreate -- do not subscribe to pass noSubscriptions check @@ -1783,9 +1783,9 @@ testInactiveNoSubs t = do Just (_, _, AEvt SAENone (DISCONNECT _ _)) <- timeout 5000000 $ atomically (readTBQueue $ subQ alice) pure () -testInactiveWithSubs :: ATransport -> IO () -testInactiveWithSubs t = do - let cfg' = cfg {inactiveClientExpiration = Just ExpirationConfig {ttl = 1, checkInterval = 1}} +testInactiveWithSubs :: (ATransport, AStoreType) -> IO () +testInactiveWithSubs (t, msType) = do + let cfg' = (cfgMS msType) {inactiveClientExpiration = Just ExpirationConfig {ttl = 1, checkInterval = 1}} withSmpServerConfigOn t cfg' testPort $ \_ -> withAgent 1 agentCfg initAgentServers testDB $ \alice -> do runRight_ . void $ createConnection alice 1 True SCMInvitation Nothing SMSubscribe @@ -1794,9 +1794,9 @@ testInactiveWithSubs t = do -- and after 2 sec of inactivity no DOWN is sent as we have a live subscription liftIO $ timeout 1200000 (get alice) `shouldReturn` Nothing -testActiveClientNotDisconnected :: ATransport -> IO () -testActiveClientNotDisconnected t = do - let cfg' = cfg {inactiveClientExpiration = Just ExpirationConfig {ttl = 1, checkInterval = 1}} +testActiveClientNotDisconnected :: (ATransport, AStoreType) -> IO () +testActiveClientNotDisconnected (t, msType) = do + let cfg' = (cfgMS msType) {inactiveClientExpiration = Just ExpirationConfig {ttl = 1, checkInterval = 1}} withSmpServerConfigOn t cfg' testPort $ \_ -> withAgent 1 agentCfg initAgentServers testDB $ \alice -> do ts <- getSystemTime @@ -1837,9 +1837,9 @@ testSuspendingAgent = liftIO $ foregroundAgent b get b =##> \case ("", c, Msg "hello 2") -> c == aId; _ -> False -testSuspendingAgentCompleteSending :: ATransport -> IO () -testSuspendingAgentCompleteSending t = withAgentClients2 $ \a b -> do - (aId, bId) <- withSmpServerStoreLogOn t testPort $ \_ -> runRight $ do +testSuspendingAgentCompleteSending :: (ATransport, AStoreType) -> IO () +testSuspendingAgentCompleteSending ps = withAgentClients2 $ \a b -> do + (aId, bId) <- withSmpServerStoreLogOn ps testPort $ \_ -> runRight $ do (aId, bId) <- makeConnection a b 2 <- sendMessage a bId SMP.noMsgFlags "hello" get a ##> ("", bId, SENT 2) @@ -1853,7 +1853,7 @@ testSuspendingAgentCompleteSending t = withAgentClients2 $ \a b -> do 4 <- sendMessage b aId SMP.noMsgFlags "how are you?" liftIO $ threadDelay 100000 liftIO $ suspendAgent b 5000000 - withSmpServerStoreLogOn t testPort $ \_ -> runRight_ @AgentErrorType $ do + withSmpServerStoreLogOn ps testPort $ \_ -> runRight_ @AgentErrorType $ do -- there will be no UP event for b, because re-subscriptions are suspended until the agent is in foreground get b =##> \case ("", c, SENT 3) -> c == aId; _ -> False get b =##> \case ("", c, SENT 4) -> c == aId; _ -> False @@ -1868,9 +1868,9 @@ testSuspendingAgentCompleteSending t = withAgentClients2 $ \a b -> do get a =##> \case ("", c, Msg "how are you?") -> c == bId; _ -> False ackMessage a bId 4 Nothing -testSuspendingAgentTimeout :: ATransport -> IO () -testSuspendingAgentTimeout t = withAgentClients2 $ \a b -> do - (aId, _) <- withSmpServer t . runRight $ do +testSuspendingAgentTimeout :: (ATransport, AStoreType) -> IO () +testSuspendingAgentTimeout ps = withAgentClients2 $ \a b -> do + (aId, _) <- withSmpServer ps . runRight $ do (aId, bId) <- makeConnection a b 2 <- sendMessage a bId SMP.noMsgFlags "hello" get a ##> ("", bId, SENT 2) @@ -1887,8 +1887,8 @@ testSuspendingAgentTimeout t = withAgentClients2 $ \a b -> do ("", "", SUSPENDED) <- nGet b pure () -testBatchedSubscriptions :: Int -> Int -> ATransport -> IO () -testBatchedSubscriptions nCreate nDel t = +testBatchedSubscriptions :: Int -> Int -> (ATransport, AStoreType) -> IO () +testBatchedSubscriptions nCreate nDel ps@(t, ASType qsType _) = withAgentClientsCfgServers2 agentCfg agentCfg initAgentServers2 $ \a b -> do conns <- runServers $ do conns <- replicateM nCreate $ makeConnection_ PQSupportOff True a b @@ -1944,8 +1944,8 @@ testBatchedSubscriptions nCreate nDel t = M.keys r `shouldMatchList` cs runServers :: ExceptT AgentErrorType IO a -> IO a runServers a = do - withSmpServerStoreLogOn t testPort $ \t1 -> do - res <- withSmpServerConfigOn t cfgJ2 testPort2 $ \t2 -> + withSmpServerStoreLogOn ps testPort $ \t1 -> do + res <- withSmpServerConfigOn t (cfgJ2QS qsType) testPort2 $ \t2 -> runRight a `finally` killThread t2 killThread t1 pure res @@ -2079,14 +2079,14 @@ testAsyncCommands sqSecured alice bob baseId = where msgId = subtract baseId -testAsyncCommandsRestore :: ATransport -> IO () -testAsyncCommandsRestore t = do +testAsyncCommandsRestore :: (ATransport, AStoreType) -> IO () +testAsyncCommandsRestore ps = do alice <- getSMPAgentClient' 1 agentCfg initAgentServers testDB bobId <- runRight $ createConnectionAsync alice 1 "1" True SCMInvitation (IKNoPQ PQSupportOn) SMSubscribe liftIO $ noMessages alice "alice doesn't receive INV because server is down" disposeAgentClient alice withAgent 2 agentCfg initAgentServers testDB $ \alice' -> - withSmpServerStoreLogOn t testPort $ \_ -> runRight_ $ do + withSmpServerStoreLogOn ps testPort $ \_ -> runRight_ $ do subscribeConnection alice' bobId get alice' =##> \case ("1", _, INV _) -> True; _ -> False pure () @@ -2130,10 +2130,10 @@ testAcceptContactAsync sqSecured alice bob baseId = where msgId = subtract baseId -testDeleteConnectionAsync :: ATransport -> IO () -testDeleteConnectionAsync t = +testDeleteConnectionAsync :: (ATransport, AStoreType) -> IO () +testDeleteConnectionAsync ps = withAgent 1 agentCfg {initialCleanupDelay = 10000, cleanupInterval = 10000, deleteErrorCount = 3} initAgentServers testDB $ \a -> do - connIds <- withSmpServerStoreLogOn t testPort $ \_ -> runRight $ do + connIds <- withSmpServerStoreLogOn ps testPort $ \_ -> runRight $ do (bId1, _inv) <- createConnection a 1 True SCMInvitation Nothing SMSubscribe (bId2, _inv) <- createConnection a 1 True SCMInvitation Nothing SMSubscribe (bId3, _inv) <- createConnection a 1 True SCMInvitation Nothing SMSubscribe @@ -2146,9 +2146,9 @@ testDeleteConnectionAsync t = get a =##> \case ("", "", DEL_CONNS cs) -> length cs == 3 && all (`elem` connIds) cs; _ -> False liftIO $ noMessages a "nothing else should be delivered to alice" -testWaitDeliveryNoPending :: ATransport -> IO () -testWaitDeliveryNoPending t = withAgentClients2 $ \alice bob -> - withSmpServerStoreLogOn t testPort $ \_ -> runRight_ $ do +testWaitDeliveryNoPending :: (ATransport, AStoreType) -> IO () +testWaitDeliveryNoPending ps = withAgentClients2 $ \alice bob -> + withSmpServerStoreLogOn ps testPort $ \_ -> runRight_ $ do (aliceId, bobId) <- makeConnection alice bob 1 <- msgId <$> sendMessage alice bobId SMP.noMsgFlags "hello" @@ -2174,11 +2174,11 @@ testWaitDeliveryNoPending t = withAgentClients2 $ \alice bob -> baseId = 1 msgId = subtract baseId -testWaitDelivery :: ATransport -> IO () -testWaitDelivery t = +testWaitDelivery :: (ATransport, AStoreType) -> IO () +testWaitDelivery ps = withAgent 1 agentCfg {initialCleanupDelay = 10000, cleanupInterval = 10000, deleteErrorCount = 3} initAgentServers testDB $ \alice -> withAgent 2 agentCfg initAgentServers testDB2 $ \bob -> do - (aliceId, bobId) <- withSmpServerStoreLogOn t testPort $ \_ -> runRight $ do + (aliceId, bobId) <- withSmpServerStoreLogOn ps testPort $ \_ -> runRight $ do (aliceId, bobId) <- makeConnection alice bob 1 <- msgId <$> sendMessage alice bobId SMP.noMsgFlags "hello" @@ -2203,7 +2203,7 @@ testWaitDelivery t = liftIO $ noMessages alice "nothing else should be delivered to alice" liftIO $ noMessages bob "nothing else should be delivered to bob" - withSmpServerStoreLogOn t testPort $ \_ -> runRight_ $ do + withSmpServerStoreLogOn ps testPort $ \_ -> runRight_ $ do get alice ##> ("", bobId, SENT $ baseId + 3) get alice ##> ("", bobId, SENT $ baseId + 4) get alice =##> \case ("", "", DEL_CONNS [cId]) -> cId == bobId; _ -> False @@ -2228,11 +2228,11 @@ testWaitDelivery t = baseId = 1 msgId = subtract baseId -testWaitDeliveryAUTHErr :: ATransport -> IO () -testWaitDeliveryAUTHErr t = +testWaitDeliveryAUTHErr :: (ATransport, AStoreType) -> IO () +testWaitDeliveryAUTHErr ps = withAgent 1 agentCfg {initialCleanupDelay = 10000, cleanupInterval = 10000, deleteErrorCount = 3} initAgentServers testDB $ \alice -> withAgent 2 agentCfg initAgentServers testDB2 $ \bob -> do - (_aliceId, bobId) <- withSmpServerStoreLogOn t testPort $ \_ -> runRight $ do + (_aliceId, bobId) <- withSmpServerStoreLogOn ps testPort $ \_ -> runRight $ do (aliceId, bobId) <- makeConnection alice bob 1 <- msgId <$> sendMessage alice bobId SMP.noMsgFlags "hello" @@ -2260,7 +2260,7 @@ testWaitDeliveryAUTHErr t = liftIO $ noMessages alice "nothing else should be delivered to alice" liftIO $ noMessages bob "nothing else should be delivered to bob" - withSmpServerStoreLogOn t testPort $ \_ -> do + withSmpServerStoreLogOn ps testPort $ \_ -> do get alice =##> \case ("", cId, MERR mId (SMP _ AUTH)) -> cId == bobId && mId == (baseId + 3); _ -> False get alice =##> \case ("", cId, MERR mId (SMP _ AUTH)) -> cId == bobId && mId == (baseId + 4); _ -> False get alice =##> \case ("", "", DEL_CONNS [cId]) -> cId == bobId; _ -> False @@ -2271,11 +2271,11 @@ testWaitDeliveryAUTHErr t = baseId = 1 msgId = subtract baseId -testWaitDeliveryTimeout :: ATransport -> IO () -testWaitDeliveryTimeout t = +testWaitDeliveryTimeout :: (ATransport, AStoreType) -> IO () +testWaitDeliveryTimeout ps = withAgent 1 agentCfg {connDeleteDeliveryTimeout = 1, initialCleanupDelay = 10000, cleanupInterval = 10000, deleteErrorCount = 3} initAgentServers testDB $ \alice -> withAgent 2 agentCfg initAgentServers testDB2 $ \bob -> do - (aliceId, bobId) <- withSmpServerStoreLogOn t testPort $ \_ -> runRight $ do + (aliceId, bobId) <- withSmpServerStoreLogOn ps testPort $ \_ -> runRight $ do (aliceId, bobId) <- makeConnection alice bob 1 <- msgId <$> sendMessage alice bobId SMP.noMsgFlags "hello" @@ -2303,7 +2303,7 @@ testWaitDeliveryTimeout t = liftIO $ threadDelay 100000 - withSmpServerStoreLogOn t testPort $ \_ -> do + withSmpServerStoreLogOn ps testPort $ \_ -> do nGet bob =##> \case ("", "", UP _ [cId]) -> cId == aliceId; _ -> False liftIO $ noMessages alice "nothing else should be delivered to alice" liftIO $ noMessages bob "nothing else should be delivered to bob" @@ -2311,11 +2311,11 @@ testWaitDeliveryTimeout t = baseId = 1 msgId = subtract baseId -testWaitDeliveryTimeout2 :: ATransport -> IO () -testWaitDeliveryTimeout2 t = +testWaitDeliveryTimeout2 :: (ATransport, AStoreType) -> IO () +testWaitDeliveryTimeout2 ps = withAgent 1 agentCfg {connDeleteDeliveryTimeout = 2, messageRetryInterval = fastMessageRetryInterval, initialCleanupDelay = 10000, cleanupInterval = 10000, deleteErrorCount = 3} initAgentServers testDB $ \alice -> withAgent 2 agentCfg initAgentServers testDB2 $ \bob -> do - (aliceId, bobId) <- withSmpServerStoreLogOn t testPort $ \_ -> runRight $ do + (aliceId, bobId) <- withSmpServerStoreLogOn ps testPort $ \_ -> runRight $ do (aliceId, bobId) <- makeConnection alice bob 1 <- msgId <$> sendMessage alice bobId SMP.noMsgFlags "hello" @@ -2341,7 +2341,7 @@ testWaitDeliveryTimeout2 t = liftIO $ noMessages alice "nothing else should be delivered to alice" liftIO $ noMessages bob "nothing else should be delivered to bob" - withSmpServerStoreLogOn t testPort $ \_ -> do + withSmpServerStoreLogOn ps testPort $ \_ -> do get alice ##> ("", bobId, SENT $ baseId + 3) -- "message 1" not delivered @@ -2357,12 +2357,12 @@ testWaitDeliveryTimeout2 t = baseId = 1 msgId = subtract baseId -testJoinConnectionAsyncReplyErrorV8 :: HasCallStack => ATransport -> IO () -testJoinConnectionAsyncReplyErrorV8 t = do +testJoinConnectionAsyncReplyErrorV8 :: HasCallStack => (ATransport, AStoreType) -> IO () +testJoinConnectionAsyncReplyErrorV8 ps@(t, ASType qsType _) = do let initAgentServersSrv2 = initAgentServers {smp = userServers [testSMPServer2]} withAgent 1 agentCfgVPrevPQ initAgentServers testDB $ \a -> withAgent 2 agentCfgVPrevPQ initAgentServersSrv2 testDB2 $ \b -> do - (aId, bId) <- withSmpServerStoreLogOn t testPort $ \_ -> runRight $ do + (aId, bId) <- withSmpServerStoreLogOn ps testPort $ \_ -> runRight $ do bId <- createConnectionAsync a 1 "1" True SCMInvitation (IKNoPQ PQSupportOn) SMSubscribe ("1", bId', INV (ACR _ qInfo)) <- get a liftIO $ bId' `shouldBe` bId @@ -2371,9 +2371,9 @@ testJoinConnectionAsyncReplyErrorV8 t = do ConnectionStats {rcvQueuesInfo = [], sndQueuesInfo = [SndQueueInfo {}]} <- getConnectionServers b aId pure (aId, bId) nGet a =##> \case ("", "", DOWN _ [c]) -> c == bId; _ -> False - withSmpServerConfigOn t cfgJ2 testPort2 $ \_ -> do + withSmpServerConfigOn t (cfgJ2QS qsType) testPort2 $ \_ -> do get b =##> \case ("2", c, JOINED sqSecured) -> c == aId && not sqSecured; _ -> False - confId <- withSmpServerStoreLogOn t testPort $ \_ -> do + confId <- withSmpServerStoreLogOn ps testPort $ \_ -> do pGet a >>= \case ("", "", AEvt _ (UP _ [_])) -> do ("", _, CONF confId _ "bob's connInfo") <- get a @@ -2389,19 +2389,19 @@ testJoinConnectionAsyncReplyErrorV8 t = do liftIO $ threadDelay 500000 ConnectionStats {rcvQueuesInfo = [RcvQueueInfo {}], sndQueuesInfo = [SndQueueInfo {}]} <- getConnectionServers b aId pure () - withSmpServerStoreLogOn t testPort $ \_ -> runRight_ $ do + withSmpServerStoreLogOn ps testPort $ \_ -> runRight_ $ do nGet a =##> \case ("", "", UP _ [c]) -> c == bId; _ -> False get a ##> ("", bId, CON) get b ##> ("", aId, INFO "alice's connInfo") get b ##> ("", aId, CON) exchangeGreetingsMsgId 4 a bId b aId -testJoinConnectionAsyncReplyError :: HasCallStack => ATransport -> IO () -testJoinConnectionAsyncReplyError t = do +testJoinConnectionAsyncReplyError :: HasCallStack => (ATransport, AStoreType) -> IO () +testJoinConnectionAsyncReplyError ps@(t, ASType qsType _) = do let initAgentServersSrv2 = initAgentServers {smp = userServers [testSMPServer2]} withAgent 1 agentCfg initAgentServers testDB $ \a -> withAgent 2 agentCfg initAgentServersSrv2 testDB2 $ \b -> do - (aId, bId) <- withSmpServerStoreLogOn t testPort $ \_ -> runRight $ do + (aId, bId) <- withSmpServerStoreLogOn ps testPort $ \_ -> runRight $ do bId <- createConnectionAsync a 1 "1" True SCMInvitation (IKNoPQ PQSupportOn) SMSubscribe ("1", bId', INV (ACR _ qInfo)) <- get a liftIO $ bId' `shouldBe` bId @@ -2410,8 +2410,8 @@ testJoinConnectionAsyncReplyError t = do ConnectionStats {rcvQueuesInfo = [], sndQueuesInfo = [SndQueueInfo {}]} <- getConnectionServers b aId pure (aId, bId) nGet a =##> \case ("", "", DOWN _ [c]) -> c == bId; _ -> False - withSmpServerConfigOn t cfgJ2 testPort2 $ \_ -> do - confId <- withSmpServerStoreLogOn t testPort $ \_ -> do + withSmpServerConfigOn t (cfgJ2QS 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 pGet a >>= \case @@ -2430,7 +2430,7 @@ testJoinConnectionAsyncReplyError t = do liftIO $ threadDelay 500000 ConnectionStats {rcvQueuesInfo = [RcvQueueInfo {}], sndQueuesInfo = [SndQueueInfo {}]} <- getConnectionServers b aId pure () - withSmpServerStoreLogOn t testPort $ \_ -> runRight_ $ do + withSmpServerStoreLogOn ps testPort $ \_ -> runRight_ $ do nGet a =##> \case ("", "", UP _ [c]) -> c == bId; _ -> False get b ##> ("", aId, INFO "alice's connInfo") get b ##> ("", aId, CON) @@ -2463,9 +2463,9 @@ testDeleteUserQuietly = exchangeGreetingsMsgId 4 a bId b aId liftIO $ noMessages a "nothing else should be delivered to alice" -testUsersNoServer :: HasCallStack => ATransport -> IO () -testUsersNoServer t = withAgentClientsCfg2 aCfg agentCfg $ \a b -> do - (aId, bId, auId, _aId', bId') <- withSmpServerStoreLogOn t testPort $ \_ -> runRight $ do +testUsersNoServer :: HasCallStack => (ATransport, AStoreType) -> IO () +testUsersNoServer ps = withAgentClientsCfg2 aCfg agentCfg $ \a b -> do + (aId, bId, auId, _aId', bId') <- withSmpServerStoreLogOn ps testPort $ \_ -> runRight $ do (aId, bId) <- makeConnection a b exchangeGreetings a bId b aId auId <- createUser a [noAuthSrvCfg testSMPServer] [noAuthSrvCfg testXFTPServer] @@ -2481,7 +2481,7 @@ testUsersNoServer t = withAgentClientsCfg2 aCfg agentCfg $ \a b -> do get a =##> \case ("", "", DEL_CONNS [c]) -> c == bId'; _ -> False nGet a =##> \case ("", "", DEL_USER u) -> u == auId; _ -> False liftIO $ noMessages a "nothing else should be delivered to alice" - withSmpServerStoreLogOn t testPort $ \_ -> runRight_ $ do + withSmpServerStoreLogOn ps testPort $ \_ -> runRight_ $ do nGet a =##> \case ("", "", UP _ [c]) -> c == bId; _ -> False nGet b =##> \case ("", "", UP _ cs) -> length cs == 2; _ -> False exchangeGreetingsMsgId 4 a bId b aId @@ -2898,9 +2898,9 @@ testCreateQueueAuth srvVersion clnt1 clnt2 sqSecured baseId = do sndAuthAlg = if srvVersion >= authCmdsSMPVersion && clntVersion >= authCmdsSMPVersion then C.AuthAlg C.SX25519 else C.AuthAlg C.SEd25519 in getSMPAgentClient' clientId agentCfg {smpCfg, sndAuthAlg} servers db -testSMPServerConnectionTest :: ATransport -> Maybe BasicAuth -> SMPServerWithAuth -> IO (Maybe ProtocolTestFailure) -testSMPServerConnectionTest t newQueueBasicAuth srv = - withSmpServerConfigOn t cfg {newQueueBasicAuth} testPort2 $ \_ -> do +testSMPServerConnectionTest :: (ATransport, AStoreType) -> Maybe BasicAuth -> SMPServerWithAuth -> IO (Maybe ProtocolTestFailure) +testSMPServerConnectionTest (t, msType) newQueueBasicAuth srv = + withSmpServerConfigOn t (cfgMS msType) {newQueueBasicAuth} testPort2 $ \_ -> do -- initially passed server is not running withAgent 1 agentCfg initAgentServers testDB $ \a -> testProtocolServer a 1 srv @@ -2933,11 +2933,11 @@ testDeliveryReceipts = ackMessage b aId 5 (Just "") `catchError` \case (A.CMD PROHIBITED _) -> pure (); e -> liftIO $ expectationFailure ("unexpected error " <> show e) ackMessage b aId 5 Nothing -testDeliveryReceiptsVersion :: HasCallStack => ATransport -> IO () -testDeliveryReceiptsVersion t = do +testDeliveryReceiptsVersion :: HasCallStack => (ATransport, AStoreType) -> IO () +testDeliveryReceiptsVersion ps = do a <- getSMPAgentClient' 1 agentCfg {smpAgentVRange = mkVersionRange 1 3} initAgentServers testDB b <- getSMPAgentClient' 2 agentCfg {smpAgentVRange = mkVersionRange 1 3} initAgentServers testDB2 - withSmpServerStoreMsgLogOn t testPort $ \_ -> do + withSmpServerStoreMsgLogOn ps testPort $ \_ -> do (aId, bId) <- runRight $ do (aId, bId) <- makeConnection_ PQSupportOff False a b checkVersion a bId 3 @@ -2986,9 +2986,9 @@ testDeliveryReceiptsVersion t = do disposeAgentClient a' disposeAgentClient b' -testDeliveryReceiptsConcurrent :: HasCallStack => ATransport -> IO () -testDeliveryReceiptsConcurrent t = - withSmpServerConfigOn t cfg {msgQueueQuota = 256, maxJournalMsgCount = 512} testPort $ \_ -> do +testDeliveryReceiptsConcurrent :: HasCallStack => (ATransport, AStoreType) -> IO () +testDeliveryReceiptsConcurrent (t, msType) = + withSmpServerConfigOn t (cfgMS msType) {msgQueueQuota = 256, maxJournalMsgCount = 512} testPort $ \_ -> do withAgentClients2 $ \a b -> do (aId, bId) <- runRight $ makeConnection a b t1 <- liftIO getCurrentTime @@ -3112,7 +3112,7 @@ getSMPAgentClient' clientId cfg' initServers dbPath = do #if defined(dbPostgres) createStore :: String -> IO (Either MigrationError DBStore) -createStore schema = createAgentStore (DBOpts testDBConnstr schema) MCError +createStore schema = createAgentStore (DBOpts testDBConnstr (B.pack schema) 1 True) MCError insertUser :: DBStore -> IO () insertUser st = withTransaction st (`DB.execute_` "INSERT INTO users DEFAULT VALUES") diff --git a/tests/AgentTests/MigrationTests.hs b/tests/AgentTests/MigrationTests.hs index 1a879eca7..ae90944f4 100644 --- a/tests/AgentTests/MigrationTests.hs +++ b/tests/AgentTests/MigrationTests.hs @@ -13,6 +13,7 @@ import Simplex.Messaging.Agent.Store.Shared import System.Random (randomIO) import Test.Hspec #if defined(dbPostgres) +import qualified Data.ByteString.Char8 as B import Database.PostgreSQL.Simple (fromOnly) import Fixtures import Simplex.Messaging.Agent.Store.Postgres.Util (dropSchema) @@ -206,7 +207,9 @@ createStore randSuffix migrations confirmMigrations = do let dbOpts = DBOpts { connstr = testDBConnstr, - schema = testSchema randSuffix + schema = B.pack $ testSchema randSuffix, + poolSize = 1, + createSchema = True } createDBStore dbOpts migrations confirmMigrations diff --git a/tests/AgentTests/NotificationTests.hs b/tests/AgentTests/NotificationTests.hs index 1fb2e83cb..da85d25aa 100644 --- a/tests/AgentTests/NotificationTests.hs +++ b/tests/AgentTests/NotificationTests.hs @@ -59,7 +59,7 @@ import Data.Text.Encoding (encodeUtf8) import qualified Data.Text.IO as TIO import NtfClient import SMPAgentClient (agentCfg, initAgentServers, initAgentServers2, testDB, testDB2, testNtfServer, testNtfServer2) -import SMPClient (cfg, cfgJ2, cfgVPrev, testPort, testPort2, withSmpServer, withSmpServerConfigOn, withSmpServerStoreLogOn, withSmpServerStoreMsgLogOn, xit'') +import SMPClient (cfgMS, cfgJ2QS, cfgVPrev, serverStoreConfig, testPort, testPort2, withSmpServer, withSmpServerConfigOn, withSmpServerStoreLogOn, withSmpServerStoreMsgLogOn, xit'') import Simplex.Messaging.Agent hiding (createConnection, joinConnection, sendMessage) import Simplex.Messaging.Agent.Client (ProtocolTestFailure (..), ProtocolTestStep (..), withStore') import Simplex.Messaging.Agent.Env.SQLite (AgentConfig, Env (..), InitialAgentServers) @@ -77,7 +77,7 @@ import Simplex.Messaging.Notifications.Types (NtfTknAction (..), NtfToken (..)) import Simplex.Messaging.Parsers (parseAll) import Simplex.Messaging.Protocol (ErrorType (AUTH), MsgFlags (MsgFlags), NtfServer, ProtocolServer (..), SMPMsgMeta (..), SubscriptionMode (..)) import qualified Simplex.Messaging.Protocol as SMP -import Simplex.Messaging.Server.Env.STM (ServerConfig (..)) +import Simplex.Messaging.Server.Env.STM (AStoreType (..), ServerConfig (..)) import Simplex.Messaging.Transport (ATransport) import Test.Hspec import UnliftIO @@ -87,8 +87,8 @@ import Database.PostgreSQL.Simple.SqlQQ (sql) import Database.SQLite.Simple.QQ (sql) #endif -notificationTests :: ATransport -> Spec -notificationTests t = do +notificationTests :: (ATransport, AStoreType) -> Spec +notificationTests ps@(t, _) = do describe "Managing notification tokens" $ do it "should register and verify notification token" $ withAPNSMockServer $ \apns -> @@ -133,61 +133,65 @@ notificationTests t = do testRunNTFServerTests t srv1 `shouldReturn` Just (ProtocolTestFailure TSConnect $ BROKER (B.unpack $ strEncode srv1) NETWORK) describe "Managing notification subscriptions" $ do describe "should create notification subscription for existing connection" $ - testNtfMatrix t testNotificationSubscriptionExistingConnection + testNtfMatrix ps testNotificationSubscriptionExistingConnection describe "should create notification subscription for new connection" $ - testNtfMatrix t testNotificationSubscriptionNewConnection + testNtfMatrix ps testNotificationSubscriptionNewConnection it "should change notifications mode" $ - withSmpServer t $ + withSmpServer ps $ withAPNSMockServer $ \apns -> withNtfServer t $ testChangeNotificationsMode apns it "should change token" $ - withSmpServer t $ + withSmpServer ps $ withAPNSMockServer $ \apns -> withNtfServer t $ testChangeToken apns describe "Notifications server store log" $ it "should save and restore tokens and subscriptions" $ withAPNSMockServer $ \apns -> - testNotificationsStoreLog t apns + testNotificationsStoreLog ps apns describe "Notifications after SMP server restart" $ it "should resume subscriptions after SMP server is restarted" $ withAPNSMockServer $ \apns -> - withNtfServer t $ testNotificationsSMPRestart t apns + withNtfServer t $ testNotificationsSMPRestart ps apns describe "Notifications after SMP server restart" $ it "should resume batched subscriptions after SMP server is restarted" $ withAPNSMockServer $ \apns -> - withNtfServer t $ testNotificationsSMPRestartBatch 100 t apns + withNtfServer t $ testNotificationsSMPRestartBatch 100 ps apns describe "should switch notifications to the new queue" $ - testServerMatrix2 t $ \servers -> + testServerMatrix2 ps $ \servers -> withAPNSMockServer $ \apns -> withNtfServer t $ testSwitchNotifications servers apns it "should keep sending notifications for old token" $ - withSmpServer t $ + withSmpServer ps $ withAPNSMockServer $ \apns -> withNtfServerOn t ntfTestPort $ testNotificationsOldToken apns it "should update server from new token" $ - withSmpServer t $ + withSmpServer ps $ withAPNSMockServer $ \apns -> withNtfServerOn t ntfTestPort2 . withNtfServerThreadOn t ntfTestPort $ \ntf -> testNotificationsNewToken apns ntf -testNtfMatrix :: HasCallStack => ATransport -> (APNSMockServer -> AgentMsgId -> AgentClient -> AgentClient -> IO ()) -> Spec -testNtfMatrix t runTest = do +testNtfMatrix :: HasCallStack => (ATransport, AStoreType) -> (APNSMockServer -> AgentMsgId -> AgentClient -> AgentClient -> IO ()) -> Spec +testNtfMatrix ps@(_, msType) runTest = do describe "next and current" $ do - it "curr servers; curr clients" $ runNtfTestCfg t 1 cfg ntfServerCfg agentCfg agentCfg runTest - it "curr servers; prev clients" $ runNtfTestCfg t 3 cfg ntfServerCfg agentCfgVPrevPQ agentCfgVPrevPQ runTest - it "prev servers; prev clients" $ runNtfTestCfg t 3 cfgVPrev ntfServerCfgVPrev agentCfgVPrevPQ agentCfgVPrevPQ runTest - it "prev servers; curr clients" $ runNtfTestCfg t 1 cfgVPrev ntfServerCfgVPrev agentCfg agentCfg runTest + it "curr servers; curr clients" $ runNtfTestCfg ps 1 cfg' ntfServerCfg agentCfg agentCfg runTest + it "curr servers; prev clients" $ runNtfTestCfg ps 3 cfg' ntfServerCfg agentCfgVPrevPQ agentCfgVPrevPQ runTest + it "prev servers; prev clients" $ runNtfTestCfg ps 3 cfgVPrev' ntfServerCfgVPrev agentCfgVPrevPQ agentCfgVPrevPQ runTest + it "prev servers; curr clients" $ runNtfTestCfg ps 1 cfgVPrev' ntfServerCfgVPrev agentCfg agentCfg runTest -- servers can be upgraded in any order - it "servers: curr SMP, prev NTF; prev clients" $ runNtfTestCfg t 3 cfg ntfServerCfgVPrev agentCfgVPrevPQ agentCfgVPrevPQ runTest - it "servers: prev SMP, curr NTF; prev clients" $ runNtfTestCfg t 3 cfgVPrev ntfServerCfg agentCfgVPrevPQ agentCfgVPrevPQ runTest + it "servers: curr SMP, prev NTF; prev clients" $ runNtfTestCfg ps 3 cfg' ntfServerCfgVPrev agentCfgVPrevPQ agentCfgVPrevPQ runTest + it "servers: prev SMP, curr NTF; prev clients" $ runNtfTestCfg ps 3 cfgVPrev' ntfServerCfg agentCfgVPrevPQ agentCfgVPrevPQ runTest -- one of two clients can be upgraded - it "servers: curr SMP, curr NTF; clients: curr/prev" $ runNtfTestCfg t 3 cfg ntfServerCfg agentCfg agentCfgVPrevPQ runTest - it "servers: curr SMP, curr NTF; clients: prev/curr" $ runNtfTestCfg t 3 cfg ntfServerCfg agentCfgVPrevPQ agentCfg runTest + it "servers: curr SMP, curr NTF; clients: curr/prev" $ runNtfTestCfg ps 3 cfg' ntfServerCfg agentCfg agentCfgVPrevPQ runTest + it "servers: curr SMP, curr NTF; clients: prev/curr" $ runNtfTestCfg ps 3 cfg' ntfServerCfg agentCfgVPrevPQ agentCfg runTest + where + cfg' = cfgMS msType + cfgVPrev' = cfgVPrev msType -runNtfTestCfg :: HasCallStack => ATransport -> AgentMsgId -> ServerConfig -> NtfServerConfig -> AgentConfig -> AgentConfig -> (APNSMockServer -> AgentMsgId -> AgentClient -> AgentClient -> IO ()) -> IO () -runNtfTestCfg t baseId smpCfg ntfCfg aCfg bCfg runTest = do - withSmpServerConfigOn t smpCfg testPort $ \_ -> +runNtfTestCfg :: HasCallStack => (ATransport, AStoreType) -> AgentMsgId -> ServerConfig -> NtfServerConfig -> AgentConfig -> AgentConfig -> (APNSMockServer -> AgentMsgId -> AgentClient -> AgentClient -> IO ()) -> IO () +runNtfTestCfg (t, msType) baseId smpCfg ntfCfg aCfg bCfg runTest = do + let smpCfg' = smpCfg {serverStoreCfg = serverStoreConfig msType} + withSmpServerConfigOn t smpCfg' testPort $ \_ -> withAPNSMockServer $ \apns -> withNtfServerCfg ntfCfg {transports = [(ntfTestPort, t, False)]} $ \_ -> withAgentClientsCfg2 aCfg bCfg $ runTest apns baseId @@ -746,9 +750,9 @@ testChangeToken apns = withAgent 1 agentCfg initAgentServers testDB2 $ \bob -> d baseId = 1 msgId = subtract baseId -testNotificationsStoreLog :: ATransport -> APNSMockServer -> IO () -testNotificationsStoreLog t apns = withAgentClients2 $ \alice bob -> do - withSmpServerStoreMsgLogOn t testPort $ \_ -> do +testNotificationsStoreLog :: (ATransport, AStoreType) -> APNSMockServer -> IO () +testNotificationsStoreLog ps@(t, _) apns = withAgentClients2 $ \alice bob -> do + withSmpServerStoreMsgLogOn ps testPort $ \_ -> do (aliceId, bobId) <- withNtfServerStoreLog t $ \threadId -> runRight $ do (aliceId, bobId) <- makeConnection alice bob _ <- registerTestToken alice "abcd" NMInstant apns @@ -779,13 +783,13 @@ testNotificationsStoreLog t apns = withAgentClients2 $ \alice bob -> do ackMessage alice bobId 4 Nothing noNotifications apns - withSmpServerStoreMsgLogOn t testPort $ \_ -> + withSmpServerStoreMsgLogOn ps testPort $ \_ -> withNtfServerStoreLog t $ \_ -> runRight_ $ do void $ messageNotificationData alice apns -testNotificationsSMPRestart :: ATransport -> APNSMockServer -> IO () -testNotificationsSMPRestart t apns = withAgentClients2 $ \alice bob -> do - (aliceId, bobId) <- withSmpServerStoreLogOn t testPort $ \threadId -> runRight $ do +testNotificationsSMPRestart :: (ATransport, AStoreType) -> APNSMockServer -> IO () +testNotificationsSMPRestart ps apns = withAgentClients2 $ \alice bob -> do + (aliceId, bobId) <- withSmpServerStoreLogOn ps testPort $ \threadId -> runRight $ do (aliceId, bobId) <- makeConnection alice bob _ <- registerTestToken alice "abcd" NMInstant apns liftIO $ threadDelay 250000 @@ -801,7 +805,7 @@ testNotificationsSMPRestart t apns = withAgentClients2 $ \alice bob -> do nGet alice =##> \case ("", "", DOWN _ [c]) -> c == bobId; _ -> False nGet bob =##> \case ("", "", DOWN _ [c]) -> c == aliceId; _ -> False - withSmpServerStoreLogOn t testPort $ \threadId -> runRight_ $ do + withSmpServerStoreLogOn ps testPort $ \threadId -> runRight_ $ do nGet alice =##> \case ("", "", UP _ [c]) -> c == bobId; _ -> False nGet bob =##> \case ("", "", UP _ [c]) -> c == aliceId; _ -> False liftIO $ threadDelay 1000000 @@ -811,8 +815,8 @@ testNotificationsSMPRestart t apns = withAgentClients2 $ \alice bob -> do get alice =##> \case ("", c, Msg "hello again") -> c == bobId; _ -> False liftIO $ killThread threadId -testNotificationsSMPRestartBatch :: Int -> ATransport -> APNSMockServer -> IO () -testNotificationsSMPRestartBatch n t apns = +testNotificationsSMPRestartBatch :: Int -> (ATransport, AStoreType) -> APNSMockServer -> IO () +testNotificationsSMPRestartBatch n ps@(t, ASType qsType _) apns = withAgentClientsCfgServers2 agentCfg agentCfg initAgentServers2 $ \a b -> do threadDelay 1000000 conns <- runServers $ do @@ -851,8 +855,8 @@ testNotificationsSMPRestartBatch n t apns = where runServers :: ExceptT AgentErrorType IO a -> IO a runServers a = do - withSmpServerStoreLogOn t testPort $ \t1 -> do - res <- withSmpServerConfigOn t cfgJ2 testPort2 $ \t2 -> + withSmpServerStoreLogOn ps testPort $ \t1 -> do + res <- withSmpServerConfigOn t (cfgJ2QS qsType) testPort2 $ \t2 -> runRight a `finally` killThread t2 killThread t1 pure res diff --git a/tests/SMPClient.hs b/tests/SMPClient.hs index a1527b78a..653a03b84 100644 --- a/tests/SMPClient.hs +++ b/tests/SMPClient.hs @@ -146,23 +146,24 @@ testSMPClient_ host port vr client = do cfg :: ServerConfig cfg = cfgMS (ASType SQSMemory SMSJournal) --- TODO [postgres] --- cfg :: ServerConfig --- cfg = cfgMS (ASType SQSPostgres SMSJournal) +cfgDB :: ServerConfig +cfgDB = cfgMS (ASType SQSPostgres SMSJournal) cfgJ2 :: ServerConfig cfgJ2 = journalCfg cfg testStoreLogFile2 testStoreMsgsDir2 --- TODO [postgres] --- cfgJ2 :: ServerConfig --- cfgJ2 = journalCfg cfg testStoreDBOpts2 testStoreMsgsDir2 +cfgJ2QS :: SQSType s -> ServerConfig +cfgJ2QS = \case + SQSMemory -> journalCfg (cfgMS $ ASType SQSMemory SMSJournal) testStoreLogFile2 testStoreMsgsDir2 + SQSPostgres -> journalCfgDB (cfgMS $ ASType SQSPostgres SMSJournal) testStoreDBOpts2 testStoreMsgsDir2 journalCfg :: ServerConfig -> FilePath -> FilePath -> ServerConfig journalCfg cfg' storeLogFile storeMsgsPath = cfg' {serverStoreCfg = ASSCfg SQSMemory SMSJournal SSCMemoryJournal {storeLogFile, storeMsgsPath}} --- TODO [postgres] --- journalCfg :: ServerConfig -> DBOpts -> FilePath -> ServerConfig --- journalCfg cfg' storeDBOpts storeMsgsPath' = cfg' {serverStoreCfg = ASSCfg SQSPostgres SMSJournal SSCDatabaseJournal {storeDBOpts, storeMsgsPath'}} +journalCfgDB :: ServerConfig -> DBOpts -> FilePath -> ServerConfig +journalCfgDB cfg' dbOpts storeMsgsPath' = + let storeCfg = PostgresStoreCfg {dbOpts, confirmMigrations = MCYesUp, deletedTTL = 86400} + in cfg' {serverStoreCfg = ASSCfg SQSPostgres SMSJournal SSCDatabaseJournal {storeCfg, storeMsgsPath'}} cfgMS :: AStoreType -> ServerConfig cfgMS msType = @@ -175,14 +176,7 @@ cfgMS msType = maxJournalStateLines = 2, queueIdBytes = 24, msgIdBytes = 24, - serverStoreCfg = case msType of - 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 -> - let storeCfg = PostgresStoreCfg {dbOpts = testStoreDBOpts, confirmMigrations = MCYesUp, deletedTTL = 86400} - in ASSCfg SQSPostgres SMSJournal SSCDatabaseJournal {storeCfg, storeMsgsPath' = testStoreMsgsDir}, + serverStoreCfg = serverStoreConfig msType, storeNtfsFile = Nothing, allowNewQueues = True, newQueueBasicAuth = Nothing, @@ -218,14 +212,24 @@ cfgMS msType = startOptions = StartOptions {maintenance = False, skipWarnings = False, confirmMigrations = MCYesUp} } +serverStoreConfig :: AStoreType -> AServerStoreCfg +serverStoreConfig = \case + 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 -> + let storeCfg = PostgresStoreCfg {dbOpts = testStoreDBOpts, confirmMigrations = MCYesUp, deletedTTL = 86400} + in ASSCfg SQSPostgres SMSJournal SSCDatabaseJournal {storeCfg, storeMsgsPath' = testStoreMsgsDir} + cfgV7 :: ServerConfig cfgV7 = cfg {smpServerVRange = mkVersionRange minServerSMPRelayVersion authCmdsSMPVersion} -cfgV8 :: ServerConfig -cfgV8 = cfg {smpServerVRange = mkVersionRange minServerSMPRelayVersion sendingProxySMPVersion} +cfgV8 :: AStoreType -> ServerConfig +cfgV8 msType = (cfgMS msType) {smpServerVRange = mkVersionRange minServerSMPRelayVersion sendingProxySMPVersion} -cfgVPrev :: ServerConfig -cfgVPrev = cfg {smpServerVRange = prevRange $ smpServerVRange cfg} +cfgVPrev :: AStoreType -> ServerConfig +cfgVPrev msType = (cfgMS msType) {smpServerVRange = prevRange $ smpServerVRange cfg} prevRange :: VersionRange v -> VersionRange v prevRange vr = vr {maxVersion = max (minVersion vr) (prevVersion $ maxVersion vr)} @@ -234,8 +238,11 @@ prevVersion :: Version v -> Version v prevVersion (Version v) = Version (v - 1) proxyCfg :: ServerConfig -proxyCfg = - cfg +proxyCfg = proxyCfgMS (ASType SQSMemory SMSJournal) + +proxyCfgMS :: AStoreType -> ServerConfig +proxyCfgMS msType = + (cfgMS msType) { allowSMPProxy = True, smpAgentCfg = smpAgentCfg' {smpCfg = (smpCfg smpAgentCfg') {agreeSecret = True, proxyServer = True, serverVRange = supportedProxyClientSMPRelayVRange}} } @@ -252,18 +259,12 @@ proxyCfgJ2 = journalCfg proxyCfg testStoreLogFile2 testStoreMsgsDir2 proxyVRangeV8 :: VersionRangeSMP proxyVRangeV8 = mkVersionRange minServerSMPRelayVersion sendingProxySMPVersion -withSmpServerStoreMsgLogOn :: HasCallStack => ATransport -> ServiceName -> (HasCallStack => ThreadId -> IO a) -> IO a -withSmpServerStoreMsgLogOn = (`withSmpServerStoreMsgLogOnMS` ASType SQSMemory SMSJournal) - -withSmpServerStoreMsgLogOnMS :: HasCallStack => ATransport -> AStoreType -> ServiceName -> (HasCallStack => ThreadId -> IO a) -> IO a -withSmpServerStoreMsgLogOnMS t msType = +withSmpServerStoreMsgLogOn :: HasCallStack => (ATransport, AStoreType) -> ServiceName -> (HasCallStack => ThreadId -> IO a) -> IO a +withSmpServerStoreMsgLogOn (t, msType) = withSmpServerConfigOn t (cfgMS msType) {storeNtfsFile = Just testStoreNtfsFile, serverStatsBackupFile = Just testServerStatsBackupFile} -withSmpServerStoreLogOn :: HasCallStack => ATransport -> ServiceName -> (HasCallStack => ThreadId -> IO a) -> IO a -withSmpServerStoreLogOn = (`withSmpServerStoreLogOnMS` ASType SQSMemory SMSJournal) - -withSmpServerStoreLogOnMS :: HasCallStack => ATransport -> AStoreType -> ServiceName -> (HasCallStack => ThreadId -> IO a) -> IO a -withSmpServerStoreLogOnMS t msType = withSmpServerConfigOn t (cfgMS msType) {serverStatsBackupFile = Just testServerStatsBackupFile} +withSmpServerStoreLogOn :: HasCallStack => (ATransport, AStoreType) -> ServiceName -> (HasCallStack => ThreadId -> IO a) -> IO a +withSmpServerStoreLogOn (t, msType) = withSmpServerConfigOn t (cfgMS msType) {serverStatsBackupFile = Just testServerStatsBackupFile} withSmpServerConfigOn :: HasCallStack => ATransport -> ServerConfig -> ServiceName -> (HasCallStack => ThreadId -> IO a) -> IO a withSmpServerConfigOn t cfg' port' = @@ -271,8 +272,8 @@ withSmpServerConfigOn t cfg' port' = (\started -> runSMPServerBlocking started cfg' {transports = [(port', t, False)]} Nothing) (threadDelay 10000) -withSmpServerThreadOn :: HasCallStack => ATransport -> ServiceName -> (HasCallStack => ThreadId -> IO a) -> IO a -withSmpServerThreadOn t = withSmpServerConfigOn t cfg +withSmpServerThreadOn :: HasCallStack => (ATransport, AStoreType) -> ServiceName -> (HasCallStack => ThreadId -> IO a) -> IO a +withSmpServerThreadOn (t, msType) = withSmpServerConfigOn t (cfgMS msType) serverBracket :: HasCallStack => (TMVar Bool -> IO ()) -> IO () -> (HasCallStack => ThreadId -> IO a) -> IO a serverBracket process afterProcess f = do @@ -292,14 +293,14 @@ serverBracket process afterProcess f = do Nothing -> error $ "server did not " <> s _ -> pure () -withSmpServerOn :: HasCallStack => ATransport -> ServiceName -> IO a -> IO a -withSmpServerOn t port' = withSmpServerThreadOn t port' . const +withSmpServerOn :: HasCallStack => (ATransport, AStoreType) -> ServiceName -> IO a -> IO a +withSmpServerOn ps port' = withSmpServerThreadOn ps port' . const -withSmpServer :: HasCallStack => ATransport -> IO a -> IO a -withSmpServer t = withSmpServerOn t testPort +withSmpServer :: HasCallStack => (ATransport, AStoreType) -> IO a -> IO a +withSmpServer ps = withSmpServerOn ps testPort -withSmpServerProxy :: HasCallStack => ATransport -> IO a -> IO a -withSmpServerProxy t = withSmpServerConfigOn t proxyCfg testPort . const +withSmpServerProxy :: HasCallStack => (ATransport, AStoreType) -> IO a -> IO a +withSmpServerProxy (t, msType) = withSmpServerConfigOn t (proxyCfgMS msType) testPort . 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 diff --git a/tests/SMPProxyTests.hs b/tests/SMPProxyTests.hs index 04ba953da..4be81aedc 100644 --- a/tests/SMPProxyTests.hs +++ b/tests/SMPProxyTests.hs @@ -38,7 +38,8 @@ import Simplex.Messaging.Crypto.Ratchet (pattern PQSupportOn) import qualified Simplex.Messaging.Crypto.Ratchet as CR import Simplex.Messaging.Protocol (EncRcvMsgBody (..), MsgBody, RcvMessage (..), SubscriptionMode (..), maxMessageLength, noMsgFlags, pattern NoEntity) import qualified Simplex.Messaging.Protocol as SMP -import Simplex.Messaging.Server.Env.STM (ServerConfig (..)) +import Simplex.Messaging.Server.Env.STM (AStoreType (..), ServerConfig (..)) +import Simplex.Messaging.Server.MsgStore.Types (SQSType (..)) import Simplex.Messaging.Transport import Simplex.Messaging.Util (bshow, tshow) import Simplex.Messaging.Version (mkVersionRange) @@ -52,7 +53,7 @@ import Fixtures import Simplex.Messaging.Agent.Store.Postgres.Util (dropAllSchemasExceptSystem) #endif -smpProxyTests :: Spec +smpProxyTests :: SpecWith AStoreType smpProxyTests = do describe "server configuration" $ do it "refuses proxy handshake unless enabled" testNoProxy @@ -117,8 +118,9 @@ smpProxyTests = do it "without proxy" . oneServer $ agentDeliverMessageViaProxy ([srv1], SPMNever, False) ([srv1], SPMNever, False) C.SEd448 "hello 1" "hello 2" 1 describe "two servers" $ do - it "always via proxy" . twoServers $ - agentDeliverMessageViaProxy ([srv1], SPMAlways, True) ([srv2], SPMAlways, True) C.SEd448 "hello 1" "hello 2" 1 + it "always via proxy" $ \msType -> twoServers + (agentDeliverMessageViaProxy ([srv1], SPMAlways, True) ([srv2], SPMAlways, True) C.SEd448 "hello 1" "hello 2" 1) + msType it "both via proxy" . twoServers $ agentDeliverMessageViaProxy ([srv1], SPMUnknown, True) ([srv2], SPMUnknown, True) C.SEd448 "hello 1" "hello 2" 1 it "first via proxy" . twoServers $ @@ -131,9 +133,9 @@ smpProxyTests = do agentDeliverMessageViaProxy ([srv1], SPMUnknown, False) ([srv2], SPMUnknown, False) C.SEd448 "hello 1" "hello 2" 3 it "fails when fallback is prohibited" . twoServers_ proxyCfg cfgV7 $ agentViaProxyVersionError - it "retries sending when destination or proxy relay is offline" $ + it "retries sending when destination or proxy relay is offline" $ \_ -> agentViaProxyRetryOffline - it "retries sending when destination relay session disconnects in proxy" $ + it "retries sending when destination relay session disconnects in proxy" $ \_ -> agentViaProxyRetryNoSession describe "stress test 1k" $ do let deliver nAgents nMsgs = agentDeliverMessagesViaProxyConc (replicate nAgents [srv1]) (map bshow [1 :: Int .. nMsgs]) @@ -144,16 +146,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 = withSmpServerConfigOn (transport @TLS) proxyCfg {msgQueueQuota = 128, maxJournalMsgCount = 256} testPort . const - twoServers = twoServers_ proxyCfg proxyCfg - twoServersFirstProxy = twoServers_ proxyCfg cfgV8 {msgQueueQuota = 128, maxJournalMsgCount = 256} - twoServersMoreConc = twoServers_ proxyCfg {serverClientConcurrency = 128} cfgV8 {msgQueueQuota = 128, maxJournalMsgCount = 256} - twoServersNoConc = twoServers_ proxyCfg {serverClientConcurrency = 1} cfgV8 {msgQueueQuota = 128, maxJournalMsgCount = 256} - twoServers_ cfg1 cfg2 runTest = + oneServer test msType = withSmpServerConfigOn (transport @TLS) (proxyCfgMS msType) {msgQueueQuota = 128, maxJournalMsgCount = 256} testPort $ const test + twoServers test msType = twoServers_ (proxyCfgMS msType) (proxyCfgMS msType) test msType + twoServersFirstProxy test msType = twoServers_ (proxyCfgMS msType) (cfgV8 msType) {msgQueueQuota = 128, maxJournalMsgCount = 256} test msType + twoServersMoreConc test msType = twoServers_ (proxyCfgMS msType) {serverClientConcurrency = 128} (cfgV8 msType) {msgQueueQuota = 128, maxJournalMsgCount = 256} test msType + twoServersNoConc test msType = twoServers_ (proxyCfgMS msType) {serverClientConcurrency = 1} (cfgV8 msType) {msgQueueQuota = 128, maxJournalMsgCount = 256} test msType + twoServers_ :: ServerConfig -> ServerConfig -> IO () -> AStoreType -> IO () + twoServers_ cfg1 cfg2 runTest (ASType qsType _) = withSmpServerConfigOn (transport @TLS) cfg1 testPort $ \_ -> - let cfg2' = journalCfg cfg2 testStoreLogFile2 testStoreMsgsDir2 - -- TODO [postgres] - -- let cfg2' = journalCfg cfg2 testStoreDBOpts2 testStoreMsgsDir2 + let cfg2' = case qsType of + SQSMemory -> journalCfg cfg2 testStoreLogFile2 testStoreMsgsDir2 + SQSPostgres -> journalCfgDB cfg2 testStoreDBOpts2 testStoreMsgsDir2 in withSmpServerConfigOn (transport @TLS) cfg2' testPort2 $ const runTest deliverMessageViaProxy :: (C.AlgorithmI a, C.AuthAlgorithm a) => SMPServer -> SMPServer -> C.SAlgorithm a -> ByteString -> ByteString -> IO () @@ -427,25 +430,24 @@ agentViaProxyRetryNoSession = do withServer2 = withSmpServerConfigOn (transport @TLS) proxyCfgJ2 testPort2 servers srv = (initAgentServersProxy SPMAlways SPFProhibit) {smp = userServers [srv]} -testNoProxy :: IO () -testNoProxy = do - withSmpServerConfigOn (transport @TLS) cfg testPort2 $ \_ -> do +testNoProxy :: AStoreType -> IO () +testNoProxy msType = do + withSmpServerConfigOn (transport @TLS) (cfgMS msType) testPort2 $ \_ -> do testSMPClient_ "127.0.0.1" testPort2 proxyVRangeV8 $ \(th :: THandleSMP TLS 'TClient) -> do (_, _, (_corrId, _entityId, reply)) <- sendRecv th (Nothing, "0", NoEntity, SMP.PRXY testSMPServer Nothing) reply `shouldBe` Right (SMP.ERR $ SMP.PROXY SMP.BASIC_AUTH) -testProxyAuth :: IO () -testProxyAuth = do +testProxyAuth :: AStoreType -> IO () +testProxyAuth msType = do withSmpServerConfigOn (transport @TLS) proxyCfgAuth testPort $ \_ -> do testSMPClient_ "127.0.0.1" testPort proxyVRangeV8 $ \(th :: THandleSMP TLS 'TClient) -> do (_, _s, (_corrId, _entityId, reply)) <- sendRecv th (Nothing, "0", NoEntity, SMP.PRXY testSMPServer2 $ Just "wrong") reply `shouldBe` Right (SMP.ERR $ SMP.PROXY SMP.BASIC_AUTH) where - proxyCfgAuth = proxyCfg {newQueueBasicAuth = Just "correct"} + proxyCfgAuth = (proxyCfgMS msType) {newQueueBasicAuth = Just "correct"} -todo :: IO () -todo = do - fail "TODO" +todo :: AStoreType -> IO () +todo _ = fail "TODO" runExceptT' :: Exception e => ExceptT e IO a -> IO a runExceptT' a = runExceptT a >>= either throwIO pure diff --git a/tests/ServerTests.hs b/tests/ServerTests.hs index c0232ec0f..fcf1943ad 100644 --- a/tests/ServerTests.hs +++ b/tests/ServerTests.hs @@ -17,7 +17,7 @@ module ServerTests where import Control.Concurrent (ThreadId, killThread, threadDelay) import Control.Concurrent.STM -import Control.Exception (SomeException, try) +import Control.Exception (SomeException, try, throwIO) import Control.Monad import Control.Monad.IO.Class import CoreTests.MsgStoreTests (testJournalStoreCfg) @@ -70,8 +70,8 @@ serverTests = do describe "GET & SUB commands" testGetSubCommands describe "Exceeding queue quota" testExceedQueueQuota describe "Store log" testWithStoreLog - xdescribe "Restore messages" testRestoreMessages -- TODO [postgres] - xdescribe "Restore messages (old / v2)" testRestoreExpireMessages -- TODO [postgres] + describe "Restore messages" testRestoreMessages + describe "Restore messages (old / v2)" testRestoreExpireMessages describe "Save prometheus metrics" testPrometheusMetrics describe "Timing of AUTH error" testTiming describe "Message notifications" testMessageNotifications @@ -564,7 +564,7 @@ testExceedQueueQuota = testWithStoreLog :: SpecWith (ATransport, AStoreType) testWithStoreLog = - xit "should store simplex queues to log and restore them after server restart" $ \(at@(ATransport t), msType) -> do + it "should store simplex queues to log and restore them after server restart" $ \ps@(at@(ATransport t), _) -> do g <- C.newRandom (sPub1, sKey1) <- atomically $ C.generateAuthKeyPair C.SEd25519 g (sPub2, sKey2) <- atomically $ C.generateAuthKeyPair C.SEd25519 g @@ -576,7 +576,7 @@ testWithStoreLog = senderId2 <- newTVarIO NoEntity notifierId <- newTVarIO NoEntity - withSmpServerStoreLogOnMS at msType testPort . runTest t $ \h -> runClient t $ \h1 -> do + withSmpServerStoreLogOn ps testPort . runTest t $ \h -> runClient t $ \h1 -> do (sId1, rId1, rKey1, dhShared) <- createAndSecureQueue h sPub1 (rcvNtfPubDhKey, _) <- atomically $ C.generateKeyPair g Resp "abcd" _ (NID nId _) <- signSendRecv h rKey1 ("abcd", rId1, NKEY nPub rcvNtfPubDhKey) @@ -607,7 +607,7 @@ testWithStoreLog = Resp "dabc" _ OK <- signSendRecv h rKey2 ("dabc", rId2, DEL) pure () - logSize testStoreLogFile `shouldReturn` 6 + when (usesStoreLog ps) $ logSize testStoreLogFile `shouldReturn` 6 let cfg' = cfg {serverStoreCfg = ASSCfg SQSMemory SMSMemory $ SSCMemory Nothing} withSmpServerConfigOn at cfg' testPort . runTest t $ \h -> do @@ -616,7 +616,7 @@ testWithStoreLog = Resp "bcda" _ (ERR AUTH) <- signSendRecv h sKey1 ("bcda", sId1, _SEND "hello") pure () - withSmpServerStoreLogOnMS at msType testPort . runTest t $ \h -> runClient t $ \h1 -> do + withSmpServerStoreLogOn ps testPort . runTest t $ \h -> runClient t $ \h1 -> do -- this queue is restored rId1 <- readTVarIO recipientId1 Just rKey1 <- readTVarIO recipientKey1 @@ -633,8 +633,9 @@ testWithStoreLog = Resp "cdab" _ (ERR AUTH) <- signSendRecv h sKey2 ("cdab", sId2, _SEND "hello too") pure () - logSize testStoreLogFile `shouldReturn` 1 - removeFile testStoreLogFile + when (usesStoreLog ps) $ do + logSize testStoreLogFile `shouldReturn` 1 + removeFile testStoreLogFile where runTest :: Transport c => TProxy c -> (THandleSMP c 'TClient -> IO ()) -> ThreadId -> Expectation runTest _ test' server = do @@ -644,15 +645,24 @@ testWithStoreLog = runClient :: Transport c => TProxy c -> (THandleSMP c 'TClient -> IO ()) -> Expectation runClient _ test' = testSMPClient test' `shouldReturn` () +usesStoreLog :: (ATransport, AStoreType) -> Bool +usesStoreLog (_, ASType qsType _) = case qsType of + SQSMemory -> True + SQSPostgres -> False + logSize :: FilePath -> IO Int -logSize f = - try (length . B.lines <$> B.readFile f) >>= \case - Right l -> pure l - Left (_ :: SomeException) -> logSize f +logSize f = go (10 :: Int) + where + go n = + try (length . B.lines <$> B.readFile f) >>= \case + Right l -> pure l + Left (e :: SomeException) + | n > 0 -> threadDelay 100000 >> go (n - 1) + | otherwise -> throwIO e testRestoreMessages :: SpecWith (ATransport, AStoreType) testRestoreMessages = - it "should store messages on exit and restore on start" $ \(at@(ATransport t), msType) -> do + it "should store messages on exit and restore on start" $ \ps@(ATransport t, _) -> do removeFileIfExists testStoreLogFile removeFileIfExists testStoreMsgsFile whenM (doesDirectoryExist testStoreMsgsDir) $ removeDirectoryRecursive testStoreMsgsDir @@ -664,8 +674,7 @@ testRestoreMessages = recipientKey <- newTVarIO Nothing dhShared <- newTVarIO Nothing senderId <- newTVarIO NoEntity - - withSmpServerStoreMsgLogOnMS at msType testPort . runTest t $ \h -> do + withSmpServerStoreMsgLogOn ps testPort . runTest t $ \h -> do runClient t $ \h1 -> do (sId, rId, rKey, dh) <- createAndSecureQueue h1 sPub atomically $ do @@ -685,16 +694,12 @@ testRestoreMessages = Resp "5" _ OK <- signSendRecv h sKey ("5", sId, _SEND "hello 5") Resp "6" _ (ERR QUOTA) <- signSendRecv h sKey ("6", sId, _SEND "hello 6") pure () - rId <- readTVarIO recipientId - - logSize testStoreLogFile `shouldReturn` 2 - -- logSize testStoreMsgsFile `shouldReturn` 5 + when (usesStoreLog ps) $ logSize testStoreLogFile `shouldReturn` 2 logSize testServerStatsBackupFile `shouldReturn` 76 Right stats1 <- strDecode <$> B.readFile testServerStatsBackupFile checkStats stats1 [rId] 5 1 - - withSmpServerStoreMsgLogOnMS at msType testPort . runTest t $ \h -> do + withSmpServerStoreMsgLogOn ps testPort . runTest t $ \h -> do Just rKey <- readTVarIO recipientKey Just dh <- readTVarIO dhShared let dec = decryptMsgV3 dh @@ -704,15 +709,14 @@ testRestoreMessages = (dec mId3 msg3, Right "hello 3") #== "restored message delivered" Resp "4" _ (Msg mId4 msg4) <- signSendRecv h rKey ("4", rId, ACK mId3) (dec mId4 msg4, Right "hello 4") #== "restored message delivered" - - logSize testStoreLogFile `shouldReturn` 1 + when (usesStoreLog ps) $ logSize testStoreLogFile `shouldReturn` 1 -- the last message is not removed because it was not ACK'd -- logSize testStoreMsgsFile `shouldReturn` 3 logSize testServerStatsBackupFile `shouldReturn` 76 Right stats2 <- strDecode <$> B.readFile testServerStatsBackupFile checkStats stats2 [rId] 5 3 - withSmpServerStoreMsgLogOnMS at msType testPort . runTest t $ \h -> do + withSmpServerStoreMsgLogOn ps testPort . runTest t $ \h -> do Just rKey <- readTVarIO recipientKey Just dh <- readTVarIO dhShared let dec = decryptMsgV3 dh @@ -724,13 +728,12 @@ testRestoreMessages = (dec mId6 msg6, Left "ClientRcvMsgQuota") #== "restored message delivered" Resp "7" _ OK <- signSendRecv h rKey ("7", rId, ACK mId6) pure () - logSize testStoreLogFile `shouldReturn` 1 - -- logSize testStoreMsgsFile `shouldReturn` 0 + when (usesStoreLog ps) $ do + logSize testStoreLogFile `shouldReturn` 1 + removeFile testStoreLogFile logSize testServerStatsBackupFile `shouldReturn` 76 Right stats3 <- strDecode <$> B.readFile testServerStatsBackupFile checkStats stats3 [rId] 5 5 - - removeFile testStoreLogFile removeFileIfExists testStoreMsgsFile whenM (doesDirectoryExist testStoreMsgsDir) $ removeDirectoryRecursive testStoreMsgsDir removeFile testServerStatsBackupFile @@ -761,15 +764,14 @@ checkStats s qs sent received = do testRestoreExpireMessages :: SpecWith (ATransport, AStoreType) testRestoreExpireMessages = - it "should store messages on exit and restore on start" $ \(at@(ATransport t), msType) -> do + it "should store messages on exit and restore on start (old / v2)" $ \ps@(at@(ATransport t), msType) -> do g <- C.newRandom (sPub, sKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g recipientId <- newTVarIO NoEntity recipientKey <- newTVarIO Nothing dhShared <- newTVarIO Nothing senderId <- newTVarIO NoEntity - - withSmpServerStoreMsgLogOnMS at msType testPort . runTest t $ \h -> do + withSmpServerStoreMsgLogOn ps testPort . runTest t $ \h -> do runClient t $ \h1 -> do (sId, rId, rKey, dh) <- createAndSecureQueue h1 sPub atomically $ do @@ -784,31 +786,36 @@ testRestoreExpireMessages = Resp "3" _ OK <- signSendRecv h sKey ("3", sId, _SEND "hello 3") Resp "4" _ OK <- signSendRecv h sKey ("4", sId, _SEND "hello 4") pure () - - logSize testStoreLogFile `shouldReturn` 2 - exportStoreMessages msType - msgs <- B.readFile testStoreMsgsFile - length (B.lines msgs) `shouldBe` 4 + msgs <- + if usesStoreLog ps + then do + logSize testStoreLogFile `shouldReturn` 2 + exportStoreMessages msType + msgs <- B.readFile testStoreMsgsFile + length (B.lines msgs) `shouldBe` 4 + pure msgs + else pure [] let expCfg1 = Just ExpirationConfig {ttl = 86400, checkInterval = 43200} cfg1 = (cfgMS msType) {messageExpiration = expCfg1, serverStatsBackupFile = Just testServerStatsBackupFile} withSmpServerConfigOn at cfg1 testPort . runTest t $ \_ -> pure () - logSize testStoreLogFile `shouldReturn` 1 - exportStoreMessages msType - msgs' <- B.readFile testStoreMsgsFile - msgs' `shouldBe` msgs - + when (usesStoreLog ps) $ do + logSize testStoreLogFile `shouldReturn` 1 + exportStoreMessages msType + msgs' <- B.readFile testStoreMsgsFile + msgs' `shouldBe` msgs let expCfg2 = Just ExpirationConfig {ttl = 2, checkInterval = 43200} cfg2 = (cfgMS msType) {messageExpiration = expCfg2, serverStatsBackupFile = Just testServerStatsBackupFile} withSmpServerConfigOn at cfg2 testPort . runTest t $ \_ -> pure () - logSize testStoreLogFile `shouldReturn` 1 - -- two messages expired - exportStoreMessages msType - msgs'' <- B.readFile testStoreMsgsFile - length (B.lines msgs'') `shouldBe` 2 - B.lines msgs'' `shouldBe` drop 2 (B.lines msgs) + when (usesStoreLog ps) $ do + logSize testStoreLogFile `shouldReturn` 1 + -- two messages expired + exportStoreMessages msType + msgs'' <- B.readFile testStoreMsgsFile + length (B.lines msgs'') `shouldBe` 2 + B.lines msgs'' `shouldBe` drop 2 (B.lines msgs) Right ServerStatsData {_msgExpired} <- strDecode <$> B.readFile testServerStatsBackupFile _msgExpired `shouldBe` 2 where @@ -822,6 +829,7 @@ testRestoreExpireMessages = readWriteQueueStore True (mkQueue ms) testStoreLogFile (queueStore ms) >>= closeStoreLog removeFileIfExists testStoreMsgsFile exportMessages False ms testStoreMsgsFile False + closeMsgStore ms runTest :: Transport c => TProxy c -> (THandleSMP c 'TClient -> IO ()) -> ThreadId -> Expectation runTest _ test' server = do testSMPClient test' `shouldReturn` () @@ -1020,9 +1028,9 @@ testMsgNOTExpireOnInterval = testBlockMessageQueue :: SpecWith (ATransport, AStoreType) testBlockMessageQueue = -- TODO [postgres] - xit "should return BLOCKED error when queue is blocked" $ \(at@(ATransport (t :: TProxy c)), msType) -> do + xit "should return BLOCKED error when queue is blocked" $ \ps@(ATransport (t :: TProxy c), _) -> do g <- C.newRandom - (rId, sId) <- withSmpServerStoreLogOnMS at msType testPort $ runTest t $ \h -> do + (rId, sId) <- withSmpServerStoreLogOn ps testPort $ runTest t $ \h -> do (rPub, rKey) <- atomically $ C.generateAuthKeyPair C.SEd448 g (dhPub, _dhPriv :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g Resp "abcd" rId1 (Ids rId sId _srvDh) <- signSendRecv h rKey ("abcd", NoEntity, NEW rPub dhPub Nothing SMSubscribe True) @@ -1032,7 +1040,7 @@ testBlockMessageQueue = -- TODO [postgres] block via control port withFile testStoreLogFile AppendMode $ \h -> B.hPutStrLn h $ strEncode $ BlockQueue rId $ BlockingInfo BRContent - withSmpServerStoreLogOnMS at msType testPort $ runTest t $ \h -> do + withSmpServerStoreLogOn ps testPort $ runTest t $ \h -> do (sPub, sKey) <- atomically $ C.generateAuthKeyPair C.SEd448 g Resp "dabc" sId2 (ERR (BLOCKED (BlockingInfo BRContent))) <- signSendRecv h sKey ("dabc", sId, SKEY sPub) (sId2, sId) #== "same queue ID in response" diff --git a/tests/Test.hs b/tests/Test.hs index bfcae0e08..c3322b24e 100644 --- a/tests/Test.hs +++ b/tests/Test.hs @@ -26,7 +26,6 @@ import RemoteControl (remoteControlTests) import SMPClient (testServerDBConnectInfo) import SMPProxyTests (smpProxyTests) import ServerTests -import Simplex.Messaging.Agent.Store.Postgres.Util (createDBAndUserIfNotExists, dropDatabaseAndUser) import Simplex.Messaging.Server.Env.STM (AStoreType (..)) import Simplex.Messaging.Server.MsgStore.Types (SMSType (..), SQSType (..)) import Simplex.Messaging.Transport (TLS, Transport (..)) @@ -34,12 +33,12 @@ import Simplex.Messaging.Transport (TLS, Transport (..)) import System.Directory (createDirectoryIfMissing, removeDirectoryRecursive) import System.Environment (setEnv) import Test.Hspec +import Util (postgressBracket) import XFTPAgent import XFTPCLI import XFTPServerTests (xftpServerTests) #if defined(dbPostgres) import Fixtures -import Simplex.Messaging.Agent.Store.Postgres.Util (createDBAndUserIfNotExists, dropDatabaseAndUser) #else import AgentTests.SchemaDump (schemaDumpTest) #endif @@ -54,10 +53,8 @@ main = do setEnv "APNS_KEY_ID" "H82WD9K9AQ" setEnv "APNS_KEY_FILE" "./tests/fixtures/AuthKey_H82WD9K9AQ.p8" hspec - -- TODO [postgres] run tests with postgres server locally and maybe in CI #if defined(dbPostgres) - . beforeAll_ (dropDatabaseAndUser testDBConnectInfo >> createDBAndUserIfNotExists testDBConnectInfo) - . afterAll_ (dropDatabaseAndUser testDBConnectInfo) + . aroundAll_ (postgressBracket testDBConnectInfo) #endif . before_ (createDirectoryIfMissing False "tests/tmp") . after_ (eventuallyRemove "tests/tmp" 3) @@ -78,8 +75,7 @@ main = do describe "Store log tests" storeLogTests describe "TRcvQueues tests" tRcvQueuesTests describe "Util tests" utilTests - beforeAll_ (dropDatabaseAndUser testServerDBConnectInfo >> createDBAndUserIfNotExists testServerDBConnectInfo) - $ afterAll_ (dropDatabaseAndUser testServerDBConnectInfo) + aroundAll_ (postgressBracket testServerDBConnectInfo) -- TODO [postgres] fix store log tests $ describe "SMP server via TLS, postgres+jornal message store" $ do describe "SMP syntax" $ serverSyntaxTests (transport @TLS) @@ -93,8 +89,13 @@ main = do -- describe "SMP syntax" $ serverSyntaxTests (transport @WS) -- before (pure (transport @WS, ASType SQSMemory SMSJournal)) serverTests describe "Notifications server" $ ntfServerTests (transport @TLS) - describe "SMP client agent" $ agentTests (transport @TLS) - describe "SMP proxy" smpProxyTests + aroundAll_ (postgressBracket testServerDBConnectInfo) $ do + describe "SMP client agent, postgres+jornal message store" $ agentTests (transport @TLS, ASType SQSPostgres SMSJournal) + describe "SMP proxy, postgres+jornal message store" $ + before (pure $ ASType SQSPostgres SMSJournal) smpProxyTests + describe "SMP client agent, jornal message store" $ agentTests (transport @TLS, ASType SQSMemory SMSJournal) + describe "SMP proxy, jornal message store" $ + before (pure $ ASType SQSMemory SMSJournal) smpProxyTests describe "XFTP" $ do describe "XFTP server" xftpServerTests describe "XFTP file description" fileDescriptionTests diff --git a/tests/Util.hs b/tests/Util.hs index 0ad371b69..2d2c7b089 100644 --- a/tests/Util.hs +++ b/tests/Util.hs @@ -1,9 +1,12 @@ module Util where +import qualified Control.Exception as E import Control.Monad (replicateM, when) import Data.Either (partitionEithers) import Data.List (tails) +import Database.PostgreSQL.Simple (ConnectInfo (..)) import GHC.Conc (getNumCapabilities, getNumProcessors, setNumCapabilities) +import Simplex.Messaging.Agent.Store.Postgres.Util (createDBAndUserIfNotExists, dropDatabaseAndUser) import System.Directory (doesFileExist, removeFile) import Test.Hspec import UnliftIO @@ -32,3 +35,9 @@ removeFileIfExists :: FilePath -> IO () removeFileIfExists filePath = do fileExists <- doesFileExist filePath when fileExists $ removeFile filePath + +postgressBracket :: ConnectInfo -> IO a -> IO a +postgressBracket connInfo = + E.bracket_ + (dropDatabaseAndUser connInfo >> createDBAndUserIfNotExists connInfo) + (dropDatabaseAndUser connInfo) From 019a32a62390d3beaa0f269d9a92bfa5ca4dd675 Mon Sep 17 00:00:00 2001 From: Evgeny Date: Thu, 13 Mar 2025 10:25:56 +0000 Subject: [PATCH 08/14] smp server: optionally append store log with postgres storage (without loading and compacting, for debugging during migration) (#1480) * smp server: optionally maintain store log with postgres storage (without loading and compacting, for debugging during migration) * refactor * remove comment --- src/Simplex/Messaging/Server/Main.hs | 52 +++++++---- .../Messaging/Server/MsgStore/Journal.hs | 13 ++- src/Simplex/Messaging/Server/MsgStore/STM.hs | 5 +- .../Messaging/Server/QueueStore/Postgres.hs | 62 ++++++++++--- .../Messaging/Server/QueueStore/STM.hs | 5 +- .../Messaging/Server/QueueStore/Types.hs | 1 + src/Simplex/Messaging/Server/StoreLog.hs | 8 +- tests/CoreTests/StoreLogTests.hs | 2 +- tests/SMPClient.hs | 10 +- tests/ServerTests.hs | 93 +++++++++---------- 10 files changed, 151 insertions(+), 100 deletions(-) diff --git a/src/Simplex/Messaging/Server/Main.hs b/src/Simplex/Messaging/Server/Main.hs index 806c7fc34..e3db02259 100644 --- a/src/Simplex/Messaging/Server/Main.hs +++ b/src/Simplex/Messaging/Server/Main.hs @@ -167,7 +167,7 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath = ms <- newJournalMsgStore MQStoreCfg readQueueStore True (mkQueue ms) storeLogFile (queueStore ms) queues <- readTVarIO $ loadedQueues $ stmQueueStore ms - let storeCfg = PostgresStoreCfg {dbOpts = dbOpts {createSchema = True}, confirmMigrations = MCConsole, deletedTTL = iniDeletedTTL ini} + let storeCfg = PostgresStoreCfg {dbOpts = dbOpts {createSchema = True}, dbStoreLogPath = Nothing, confirmMigrations = MCConsole, deletedTTL = iniDeletedTTL ini} ps <- newJournalMsgStore $ PQStoreCfg storeCfg qCnt <- batchInsertQueues @(JournalQueue 'QSMemory) True queues $ postgresQueueStore ps renameFile storeLogFile $ storeLogFile <> ".bak" @@ -189,9 +189,9 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath = confirmOrExit ("WARNING: PostrgreSQL database schema " <> B.unpack schema <> " (database: " <> B.unpack connstr <> ") will be exported to store log file " <> storeLogFilePath) "Queue records not exported" - let storeCfg = PostgresStoreCfg {dbOpts, confirmMigrations = MCConsole, deletedTTL = iniDeletedTTL ini} + let storeCfg = PostgresStoreCfg {dbOpts, dbStoreLogPath = Nothing, confirmMigrations = MCConsole, deletedTTL = iniDeletedTTL ini} ps <- newJournalMsgStore $ PQStoreCfg storeCfg - sl <- openWriteStoreLog storeLogFilePath + sl <- openWriteStoreLog False storeLogFilePath Sum qCnt <- foldQueueRecs True (postgresQueueStore ps) $ \(rId, qr) -> logCreateQueue sl rId qr $> Sum (1 :: Int) putStrLn $ "Export completed: " <> show qCnt <> " queues" putStrLn $ case readStoreType ini of @@ -211,8 +211,7 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath = True -> readIniFile iniFile >>= either exitError a _ -> exitError $ "Error: server is not initialized (" <> iniFile <> " does not exist).\nRun `" <> executableName <> " init`." getRequiredStoreLogFile ini = do - let enableStoreLog = settingIsOn "STORE_LOG" "enable" ini - case enableStoreLog $> storeLogFilePath of + case enableStoreLog' ini $> storeLogFilePath of Just storeLogFile -> do ifM (doesFileExist storeLogFile) @@ -258,6 +257,8 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath = httpsCertFile = combine cfgPath "web.crt" httpsKeyFile = combine cfgPath "web.key" defaultStaticPath = combine logPath "www" + enableStoreLog' = settingIsOn "STORE_LOG" "enable" + enableDbStoreLog' = settingIsOn "STORE_LOG" "db_store_log" initializeServer opts@InitOptions {ip, fqdn, sourceCode = src', webStaticPath = sp', disableWeb = noWeb', scripted} | scripted = initialize opts | otherwise = do @@ -338,7 +339,9 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath = \store_queues: memory\n\n\ \# Database connection settings for PostgreSQL database (`store_queues: database`).\n" <> dbOptsIniContent dbOptions - <> "# Time to retain deleted queues in the database, days.\n" + <> "# Write database changes to store log file\n\ + \# 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\ \store_messages: memory\n\n\ @@ -471,14 +474,13 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath = runSMPServer cfg Nothing logDebug "Bye" where - enableStoreLog = settingIsOn "STORE_LOG" "enable" ini logStats = settingIsOn "STORE_LOG" "log_stats" ini c = combine cfgPath . ($ defaultX509Config) restoreMessagesFile path = case iniOnOff "STORE_LOG" "restore_messages" ini of Just True -> Just path Just False -> Nothing -- if the setting is not set, it is enabled when store log is enabled - _ -> enableStoreLog $> path + _ -> enableStoreLog' ini $> path transports = iniTransports ini sharedHTTP = any (\(_, _, addHTTP) -> addHTTP) transports iniStoreType = either error id $! readStoreType ini @@ -501,11 +503,12 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath = httpCredentials = (\WebHttpsParams {key, cert} -> ServerCredentials {caCertificateFile = Nothing, privateKeyFile = key, certificateFile = cert}) <$> webHttpsParams', serverStoreCfg = case iniStoreType of ASType SQSMemory SMSMemory -> - ASSCfg SQSMemory SMSMemory $ SSCMemory $ enableStoreLog $> StorePaths {storeLogFile = storeLogFilePath, storeMsgsFile = restoreMessagesFile storeMsgsFilePath} + ASSCfg SQSMemory SMSMemory $ SSCMemory $ enableStoreLog' ini $> StorePaths {storeLogFile = storeLogFilePath, storeMsgsFile = restoreMessagesFile storeMsgsFilePath} ASType SQSMemory SMSJournal -> ASSCfg SQSMemory SMSJournal $ SSCMemoryJournal {storeLogFile = storeLogFilePath, storeMsgsPath = storeMsgsJournalDir} ASType SQSPostgres SMSJournal -> - let storeCfg = PostgresStoreCfg {dbOpts = iniDBOptions ini, confirmMigrations = MCYesUp, deletedTTL = iniDeletedTTL ini} + let dbStoreLogPath = enableDbStoreLog' ini $> storeLogFilePath + storeCfg = PostgresStoreCfg {dbOpts = iniDBOptions ini, dbStoreLogPath, confirmMigrations = MCYesUp, deletedTTL = iniDeletedTTL ini} in ASSCfg SQSPostgres SMSJournal $ SSCDatabaseJournal {storeCfg, storeMsgsPath' = storeMsgsJournalDir}, storeNtfsFile = restoreMessagesFile storeNtfsFilePath, -- allow creating new queues by default @@ -607,16 +610,25 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath = SQSPostgres -> do let DBOpts {connstr, schema} = iniDBOptions ini schemaExists <- checkSchemaExists connstr schema - if - | storeLogExists && schemaExists -> exitConfigureQueueStore connstr schema - | storeLogExists -> do - putStrLn $ "Error: store_queues is `database` with " <> storeLogFilePath <> " file present." - putStrLn "Set store_queues to `memory` or use `smp-server database import` to migrate." - exitFailure - | not schemaExists -> do - putStrLn $ "Error: store_queues is `database`, create schema " <> B.unpack schema <> " in PostgreSQL database " <> B.unpack connstr - exitFailure - | otherwise -> pure () + case enableDbStoreLog' ini of + Just () + | not schemaExists -> noDatabaseSchema connstr schema + | not storeLogExists -> do + putStrLn $ "Error: db_store_log is `on`, " <> storeLogFilePath <> " does not exist" + exitFailure + | otherwise -> pure () + Nothing + | storeLogExists && schemaExists -> exitConfigureQueueStore connstr schema + | storeLogExists -> do + putStrLn $ "Error: store_queues is `database` with " <> storeLogFilePath <> " file present." + putStrLn "Set store_queues to `memory` or use `smp-server database import` to migrate." + exitFailure + | not schemaExists -> noDatabaseSchema connstr schema + | otherwise -> pure () + where + noDatabaseSchema connstr schema = do + putStrLn $ "Error: store_queues is `database`, create schema " <> B.unpack schema <> " in PostgreSQL database " <> B.unpack connstr + exitFailure ASType SQSMemory SMSMemory | msgsFileExists && msgsDirExists -> exitConfigureMsgStorage | msgsDirExists -> do diff --git a/src/Simplex/Messaging/Server/MsgStore/Journal.hs b/src/Simplex/Messaging/Server/MsgStore/Journal.hs index f7a65488d..74ebac2d3 100644 --- a/src/Simplex/Messaging/Server/MsgStore/Journal.hs +++ b/src/Simplex/Messaging/Server/MsgStore/Journal.hs @@ -76,7 +76,6 @@ import Simplex.Messaging.Server.QueueStore.STM import Simplex.Messaging.Server.QueueStore.Types import Simplex.Messaging.TMap (TMap) import qualified Simplex.Messaging.TMap as TM -import Simplex.Messaging.Server.StoreLog import Simplex.Messaging.Util (ifM, tshow, whenM, ($>>=), (<$$>)) import System.Directory import System.FilePath (takeFileName, ()) @@ -288,6 +287,8 @@ instance QueueStoreClass (JournalQueue s) (QStore s) where MQStoreCfg -> MQStore <$> newQueueStore @(JournalQueue s) () PQStoreCfg cfg -> PQStore <$> newQueueStore @(JournalQueue s) cfg + closeQueueStore = withQS (closeQueueStore @(JournalQueue s)) + {-# INLINE closeQueueStore #-} loadedQueues = withQS loadedQueues {-# INLINE loadedQueues #-} compactQueues = withQS (compactQueues @(JournalQueue s)) @@ -330,12 +331,10 @@ instance MsgStoreClass (JournalMsgStore s) where pure JournalMsgStore {config, random, queueLocks, queueStore_, expireBackupsBefore} closeMsgStore :: JournalMsgStore s -> IO () - closeMsgStore ms = case queueStore_ ms of - MQStore st -> do - readTVarIO (storeLog st) >>= mapM_ closeStoreLog - closeQueues $ loadedQueues @(JournalQueue s) st - PQStore st -> - closeQueues $ loadedQueues @(JournalQueue s) st + closeMsgStore ms = do + let st = queueStore_ ms + closeQueues $ loadedQueues @(JournalQueue s) st + closeQueueStore @(JournalQueue s) st where closeQueues qs = readTVarIO qs >>= mapM_ closeMsgQueue diff --git a/src/Simplex/Messaging/Server/MsgStore/STM.hs b/src/Simplex/Messaging/Server/MsgStore/STM.hs index d2a31d3d2..ff7a93db8 100644 --- a/src/Simplex/Messaging/Server/MsgStore/STM.hs +++ b/src/Simplex/Messaging/Server/MsgStore/STM.hs @@ -28,7 +28,6 @@ import Simplex.Messaging.Server.MsgStore.Types import Simplex.Messaging.Server.QueueStore import Simplex.Messaging.Server.QueueStore.STM import Simplex.Messaging.Server.QueueStore.Types -import Simplex.Messaging.Server.StoreLog import Simplex.Messaging.Util ((<$$>), ($>>=)) data STMMsgStore = STMMsgStore @@ -77,8 +76,8 @@ instance MsgStoreClass STMMsgStore where queueStore_ <- newQueueStore @STMQueue () pure STMMsgStore {storeConfig, queueStore_} - closeMsgStore st = readTVarIO (storeLog $ queueStore_ st) >>= mapM_ closeStoreLog - + closeMsgStore = closeQueueStore @STMQueue . queueStore_ + {-# INLINE closeMsgStore #-} withActiveMsgQueues = withLoadedQueues . queueStore_ {-# INLINE withActiveMsgQueues #-} withAllMsgQueues _ = withLoadedQueues . queueStore_ diff --git a/src/Simplex/Messaging/Server/QueueStore/Postgres.hs b/src/Simplex/Messaging/Server/QueueStore/Postgres.hs index 0923ab244..0e30ed66d 100644 --- a/src/Simplex/Messaging/Server/QueueStore/Postgres.hs +++ b/src/Simplex/Messaging/Server/QueueStore/Postgres.hs @@ -47,9 +47,10 @@ import Database.PostgreSQL.Simple.FromField (FromField (..)) import Database.PostgreSQL.Simple.ToField (ToField (..)) import Database.PostgreSQL.Simple.Errors (ConstraintViolation (..), constraintViolation) import Database.PostgreSQL.Simple.SqlQQ (sql) +import GHC.IO (catchAny) import Simplex.Messaging.Agent.Client (withLockMap) import Simplex.Messaging.Agent.Lock (Lock) -import Simplex.Messaging.Agent.Store.Postgres (createDBStore) +import Simplex.Messaging.Agent.Store.Postgres (createDBStore, closeDBStore) import Simplex.Messaging.Agent.Store.Postgres.Common import Simplex.Messaging.Agent.Store.Shared (MigrationConfirmation) import Simplex.Messaging.Protocol @@ -57,11 +58,12 @@ import Simplex.Messaging.Server.QueueStore import Simplex.Messaging.Server.QueueStore.Postgres.Migrations (serverMigrations) import Simplex.Messaging.Server.QueueStore.STM (readQueueRecIO) import Simplex.Messaging.Server.QueueStore.Types +import Simplex.Messaging.Server.StoreLog import Simplex.Messaging.TMap (TMap) import qualified Simplex.Messaging.TMap as TM import Simplex.Messaging.Util (firstRow, ifM, tshow, (<$$>)) import System.Exit (exitFailure) -import System.IO (hFlush, stdout) +import System.IO (IOMode (..), hFlush, stdout) import UnliftIO.STM #if !defined(dbPostgres) import Simplex.Messaging.Agent.Store.Postgres.DB (blobFieldDecoder) @@ -71,6 +73,7 @@ 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, @@ -83,6 +86,7 @@ data PostgresQueueStore q = PostgresQueueStore data PostgresStoreCfg = PostgresStoreCfg { dbOpts :: DBOpts, + dbStoreLogPath :: Maybe FilePath, confirmMigrations :: MigrationConfirmation, deletedTTL :: Int64 } @@ -91,18 +95,24 @@ instance StoreQueueClass q => QueueStoreClass q (PostgresQueueStore q) where type QueueStoreCfg (PostgresQueueStore q) = PostgresStoreCfg newQueueStore :: PostgresStoreCfg -> IO (PostgresQueueStore q) - newQueueStore PostgresStoreCfg {dbOpts, confirmMigrations, deletedTTL} = do + newQueueStore PostgresStoreCfg {dbOpts, dbStoreLogPath, confirmMigrations, deletedTTL} = do dbStore <- either err pure =<< createDBStore dbOpts serverMigrations confirmMigrations + dbStoreLog <- mapM (openWriteStoreLog True) dbStoreLogPath queues <- TM.emptyIO senders <- TM.emptyIO notifiers <- TM.emptyIO notifierLocks <- TM.emptyIO - pure PostgresQueueStore {dbStore, queues, senders, notifiers, notifierLocks, deletedTTL} + pure PostgresQueueStore {dbStore, dbStoreLog, queues, senders, notifiers, notifierLocks, deletedTTL} where err e = do logError $ "STORE: newQueueStore, error opening PostgreSQL database, " <> tshow e exitFailure + closeQueueStore :: PostgresQueueStore q -> IO () + closeQueueStore PostgresQueueStore {dbStore, dbStoreLog} = do + closeDBStore dbStore + mapM_ closeStoreLog dbStoreLog + loadedQueues = queues {-# INLINE loadedQueues #-} @@ -136,6 +146,7 @@ instance StoreQueueClass q => QueueStoreClass q (PostgresQueueStore q) where >>= bimapM handleDuplicate pure atomically $ TM.insert rId sq queues atomically $ TM.insert (senderId qr) rId senders + withLog "addStoreQueue" st $ \s -> logCreateQueue s rId qr pure sq where PostgresQueueStore {queues, senders} = st @@ -166,9 +177,11 @@ instance StoreQueueClass q => QueueStoreClass q (PostgresQueueStore q) where withQueueDB sq "secureQueue" $ \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" (sKey, recipientId sq) + DB.execute db "UPDATE msg_queues SET sender_key = ? WHERE recipient_id = ? AND deleted_at IS NULL" (sKey, rId) atomically $ writeTVar (queueRec sq) $ Just q {senderKey = Just sKey} + withLog "secureQueue" st $ \s -> logSecureQueue s rId sKey where + rId = recipientId sq verify q = case senderKey q of Just k | sKey /= k -> throwE AUTH _ -> pure () @@ -185,6 +198,7 @@ instance StoreQueueClass q => QueueStoreClass q (PostgresQueueStore q) where atomically $ writeTVar (queueRec sq) $ Just q' -- cache queue notifier ID – after notifier is added ntf server will likely subscribe atomically $ TM.insert nId rId notifiers + withLog "addQueueNotifier" st $ \s -> logAddNotifier s rId ntfCreds pure nId_ where PostgresQueueStore {notifiers} = st @@ -208,8 +222,10 @@ instance StoreQueueClass q => QueueStoreClass q (PostgresQueueStore q) where assertUpdated $ withDB' "deleteQueueNotifier" st update atomically $ TM.delete nId $ notifiers st atomically $ writeTVar (queueRec sq) $ Just q {notifier = Nothing} + withLog "deleteQueueNotifier" st (`logDeleteNotifier` rId) pure nId where + rId = recipientId sq update db = DB.execute db @@ -218,16 +234,22 @@ instance StoreQueueClass q => QueueStoreClass q (PostgresQueueStore q) where SET notifier_id = NULL, notifier_key = NULL, rcv_ntf_dh_secret = NULL WHERE recipient_id = ? AND deleted_at IS NULL |] - (Only $ recipientId sq) + (Only rId) suspendQueue :: PostgresQueueStore q -> q -> IO (Either ErrorType ()) - suspendQueue st sq = setStatusDB "suspendQueue" st sq EntityOff + suspendQueue st sq = + setStatusDB "suspendQueue" st sq EntityOff $ + withLog "suspendQueue" st (`logSuspendQueue` recipientId sq) blockQueue :: PostgresQueueStore q -> q -> BlockingInfo -> IO (Either ErrorType ()) - blockQueue st sq info = setStatusDB "blockQueue" st sq (EntityBlocked info) + blockQueue st sq info = + setStatusDB "blockQueue" st sq (EntityBlocked info) $ + withLog "blockQueue" st $ \sl -> logBlockQueue sl (recipientId sq) info unblockQueue :: PostgresQueueStore q -> q -> IO (Either ErrorType ()) - unblockQueue st sq = setStatusDB "unblockQueue" st sq EntityActive + unblockQueue st sq = + setStatusDB "unblockQueue" st sq EntityActive $ + withLog "unblockQueue" st (`logUnblockQueue` recipientId sq) updateQueueTime :: PostgresQueueStore q -> q -> RoundedSystemTime -> IO (Either ErrorType QueueRec) updateQueueTime st sq t = @@ -236,10 +258,13 @@ instance StoreQueueClass q => QueueStoreClass q (PostgresQueueStore q) where then pure q else do assertUpdated $ withDB' "updateQueueTime" st $ \db -> - DB.execute db "UPDATE msg_queues SET updated_at = ? WHERE recipient_id = ? AND deleted_at IS NULL" (t, recipientId sq) + DB.execute db "UPDATE msg_queues SET updated_at = ? WHERE recipient_id = ? AND deleted_at IS NULL" (t, rId) let !q' = q {updatedAt = Just t} atomically $ writeTVar (queueRec sq) $ Just q' + withLog "updateQueueTime" st $ \sl -> logUpdateQueueTime sl rId t pure q' + where + rId = recipientId sq -- this method is called from JournalMsgStore deleteQueue that already locks the queue deleteStoreQueue :: PostgresQueueStore q -> q -> IO (Either ErrorType (QueueRec, Maybe (MsgQueue q))) @@ -247,12 +272,15 @@ instance StoreQueueClass q => QueueStoreClass q (PostgresQueueStore q) where q <- ExceptT $ readQueueRecIO qr RoundedSystemTime ts <- liftIO getSystemDate assertUpdated $ withDB' "deleteStoreQueue" st $ \db -> - DB.execute db "UPDATE msg_queues SET deleted_at = ? WHERE recipient_id = ? AND deleted_at IS NULL" (ts, recipientId sq) + DB.execute db "UPDATE msg_queues SET deleted_at = ? WHERE recipient_id = ? AND deleted_at IS NULL" (ts, rId) atomically $ writeTVar qr Nothing atomically $ TM.delete (senderId q) $ senders st forM_ (notifier q) $ \NtfCreds {notifierId} -> atomically $ TM.delete notifierId $ notifiers st - (q,) <$> atomically (swapTVar (msgQueue sq) Nothing) + mq_ <- atomically $ swapTVar (msgQueue sq) Nothing + withLog "deleteStoreQueue" st (`logDeleteQueue` rId) + pure (q, mq_) where + rId = recipientId sq qr = queueRec sq batchInsertQueues :: StoreQueueClass q => Bool -> M.Map RecipientId q -> PostgresQueueStore q' -> IO Int64 @@ -335,12 +363,13 @@ rowToQueueRec (rId, recipientKey, rcvDhSecret, senderId, senderKey, sndSecure, n let notifier = NtfCreds <$> notifierId_ <*> notifierKey_ <*> rcvNtfDhSecret_ in (rId, QueueRec {recipientKey, rcvDhSecret, senderId, senderKey, sndSecure, notifier, status, updatedAt}) -setStatusDB :: StoreQueueClass q => String -> PostgresQueueStore q -> q -> ServerEntityStatus -> IO (Either ErrorType ()) -setStatusDB op st sq status = +setStatusDB :: StoreQueueClass q => String -> PostgresQueueStore q -> q -> ServerEntityStatus -> ExceptT ErrorType IO () -> IO (Either ErrorType ()) +setStatusDB op st sq status writeLog = withQueueDB sq op $ \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 withQueueDB :: StoreQueueClass q => q -> String -> (QueueRec -> ExceptT ErrorType IO a) -> IO (Either ErrorType a) withQueueDB sq op action = @@ -361,6 +390,11 @@ withDB op st action = where err = op <> ", withLog, " <> show e +withLog :: MonadIO m => String -> PostgresQueueStore q -> (StoreLog 'WriteMode -> IO ()) -> m () +withLog op PostgresQueueStore {dbStoreLog} action = + forM_ dbStoreLog $ \sl -> liftIO $ E.uninterruptibleMask_ (action sl) `catchAny` \e -> + logWarn $ "STORE: " <> T.pack (op <> ", withLog, " <> show e) + handleDuplicate :: SqlError -> IO ErrorType handleDuplicate e = case constraintViolation e of Just (UniqueViolation _) -> pure AUTH diff --git a/src/Simplex/Messaging/Server/QueueStore/STM.hs b/src/Simplex/Messaging/Server/QueueStore/STM.hs index 648748162..db415e297 100644 --- a/src/Simplex/Messaging/Server/QueueStore/STM.hs +++ b/src/Simplex/Messaging/Server/QueueStore/STM.hs @@ -62,6 +62,9 @@ instance StoreQueueClass q => QueueStoreClass q (STMQueueStore q) where storeLog <- newTVarIO Nothing pure STMQueueStore {queues, senders, notifiers, storeLog} + closeQueueStore :: STMQueueStore q -> IO () + closeQueueStore st = readTVarIO (storeLog st) >>= mapM_ closeStoreLog + loadedQueues = queues {-# INLINE loadedQueues #-} compactQueues _ = pure 0 @@ -194,7 +197,7 @@ readQueueRecIO qr = maybe (Left AUTH) Right <$> readTVarIO qr withLog' :: String -> TVar (Maybe (StoreLog 'WriteMode)) -> (StoreLog 'WriteMode -> IO ()) -> IO (Either ErrorType ()) withLog' name sl action = readTVarIO sl - >>= maybe (pure $ Right ()) (E.try . action >=> bimapM logErr pure) + >>= maybe (pure $ Right ()) (E.try . E.uninterruptibleMask_ . action >=> bimapM logErr pure) where logErr :: E.SomeException -> IO ErrorType logErr e = logError ("STORE: " <> T.pack err) $> STORE err diff --git a/src/Simplex/Messaging/Server/QueueStore/Types.hs b/src/Simplex/Messaging/Server/QueueStore/Types.hs index 2951e4038..8af65a335 100644 --- a/src/Simplex/Messaging/Server/QueueStore/Types.hs +++ b/src/Simplex/Messaging/Server/QueueStore/Types.hs @@ -24,6 +24,7 @@ class StoreQueueClass q where class StoreQueueClass q => QueueStoreClass q s where type QueueStoreCfg s newQueueStore :: QueueStoreCfg s -> IO s + closeQueueStore :: s -> IO () queueCounts :: s -> IO QueueCounts loadedQueues :: s -> TMap RecipientId q compactQueues :: s -> IO Int64 diff --git a/src/Simplex/Messaging/Server/StoreLog.hs b/src/Simplex/Messaging/Server/StoreLog.hs index d82062ec3..1e0565a61 100644 --- a/src/Simplex/Messaging/Server/StoreLog.hs +++ b/src/Simplex/Messaging/Server/StoreLog.hs @@ -158,9 +158,9 @@ instance StrEncoding StoreLogRecord where DeleteNotifier_ -> DeleteNotifier <$> strP UpdateTime_ -> UpdateTime <$> strP_ <*> strP -openWriteStoreLog :: FilePath -> IO (StoreLog 'WriteMode) -openWriteStoreLog f = do - h <- openFile f WriteMode +openWriteStoreLog :: Bool -> FilePath -> IO (StoreLog 'WriteMode) +openWriteStoreLog append f = do + h <- openFile f $ if append then AppendMode else WriteMode hSetBuffering h LineBuffering pure $ WriteStoreLog f h @@ -239,7 +239,7 @@ readWriteStoreLog readStore writeStore f st = removeStoreLogBackups f pure s writeLog msg = do - s <- openWriteStoreLog f + s <- openWriteStoreLog False f logInfo msg writeStore s st pure s diff --git a/tests/CoreTests/StoreLogTests.hs b/tests/CoreTests/StoreLogTests.hs index ec2d07039..d871f5b0a 100644 --- a/tests/CoreTests/StoreLogTests.hs +++ b/tests/CoreTests/StoreLogTests.hs @@ -101,7 +101,7 @@ storeLogTests = testSMPStoreLog :: String -> [SMPStoreLogTestCase] -> Spec testSMPStoreLog testSuite tests = describe testSuite $ forM_ tests $ \t@SLTC {name, saved} -> it name $ do - l <- openWriteStoreLog testStoreLogFile + l <- openWriteStoreLog False testStoreLogFile mapM_ (writeStoreLogRecord l) saved closeStoreLog l replicateM_ 3 $ testReadWrite t diff --git a/tests/SMPClient.hs b/tests/SMPClient.hs index 653a03b84..2eb3fe17b 100644 --- a/tests/SMPClient.hs +++ b/tests/SMPClient.hs @@ -162,7 +162,7 @@ journalCfg cfg' storeLogFile storeMsgsPath = cfg' {serverStoreCfg = ASSCfg SQSMe journalCfgDB :: ServerConfig -> DBOpts -> FilePath -> ServerConfig journalCfgDB cfg' dbOpts storeMsgsPath' = - let storeCfg = PostgresStoreCfg {dbOpts, confirmMigrations = MCYesUp, deletedTTL = 86400} + let storeCfg = PostgresStoreCfg {dbOpts, dbStoreLogPath = Nothing, confirmMigrations = MCYesUp, deletedTTL = 86400} in cfg' {serverStoreCfg = ASSCfg SQSPostgres SMSJournal SSCDatabaseJournal {storeCfg, storeMsgsPath'}} cfgMS :: AStoreType -> ServerConfig @@ -213,13 +213,17 @@ cfgMS msType = } serverStoreConfig :: AStoreType -> AServerStoreCfg -serverStoreConfig = \case +serverStoreConfig = serverStoreConfig_ False + +serverStoreConfig_ :: Bool -> AStoreType -> AServerStoreCfg +serverStoreConfig_ useDbStoreLog = \case 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 -> - let storeCfg = PostgresStoreCfg {dbOpts = testStoreDBOpts, confirmMigrations = MCYesUp, deletedTTL = 86400} + let dbStoreLogPath = if useDbStoreLog then Just testStoreLogFile else Nothing + storeCfg = PostgresStoreCfg {dbOpts = testStoreDBOpts, dbStoreLogPath, confirmMigrations = MCYesUp, deletedTTL = 86400} in ASSCfg SQSPostgres SMSJournal SSCDatabaseJournal {storeCfg, storeMsgsPath' = testStoreMsgsDir} cfgV7 :: ServerConfig diff --git a/tests/ServerTests.hs b/tests/ServerTests.hs index fcf1943ad..824338452 100644 --- a/tests/ServerTests.hs +++ b/tests/ServerTests.hs @@ -564,7 +564,7 @@ testExceedQueueQuota = testWithStoreLog :: SpecWith (ATransport, AStoreType) testWithStoreLog = - it "should store simplex queues to log and restore them after server restart" $ \ps@(at@(ATransport t), _) -> do + it "should store simplex queues to log and restore them after server restart" $ \(at@(ATransport t), msType) -> do g <- C.newRandom (sPub1, sKey1) <- atomically $ C.generateAuthKeyPair C.SEd25519 g (sPub2, sKey2) <- atomically $ C.generateAuthKeyPair C.SEd25519 g @@ -576,7 +576,8 @@ testWithStoreLog = senderId2 <- newTVarIO NoEntity notifierId <- newTVarIO NoEntity - withSmpServerStoreLogOn ps testPort . runTest t $ \h -> runClient t $ \h1 -> do + let (cfg', compacting) = serverStoreLogCfg msType + withSmpServerConfigOn at cfg' testPort . runTest t $ \h -> runClient t $ \h1 -> do (sId1, rId1, rKey1, dhShared) <- createAndSecureQueue h sPub1 (rcvNtfPubDhKey, _) <- atomically $ C.generateKeyPair g Resp "abcd" _ (NID nId _) <- signSendRecv h rKey1 ("abcd", rId1, NKEY nPub rcvNtfPubDhKey) @@ -607,16 +608,16 @@ testWithStoreLog = Resp "dabc" _ OK <- signSendRecv h rKey2 ("dabc", rId2, DEL) pure () - when (usesStoreLog ps) $ logSize testStoreLogFile `shouldReturn` 6 + logSize testStoreLogFile `shouldReturn` 6 - let cfg' = cfg {serverStoreCfg = ASSCfg SQSMemory SMSMemory $ SSCMemory Nothing} - withSmpServerConfigOn at cfg' testPort . runTest t $ \h -> do + let cfg'' = cfg {serverStoreCfg = ASSCfg SQSMemory SMSMemory $ SSCMemory Nothing} + withSmpServerConfigOn at cfg'' testPort . runTest t $ \h -> do sId1 <- readTVarIO senderId1 -- fails if store log is disabled Resp "bcda" _ (ERR AUTH) <- signSendRecv h sKey1 ("bcda", sId1, _SEND "hello") pure () - withSmpServerStoreLogOn ps testPort . runTest t $ \h -> runClient t $ \h1 -> do + withSmpServerConfigOn at cfg' testPort . runTest t $ \h -> runClient t $ \h1 -> do -- this queue is restored rId1 <- readTVarIO recipientId1 Just rKey1 <- readTVarIO recipientKey1 @@ -633,9 +634,9 @@ testWithStoreLog = Resp "cdab" _ (ERR AUTH) <- signSendRecv h sKey2 ("cdab", sId2, _SEND "hello too") pure () - when (usesStoreLog ps) $ do - logSize testStoreLogFile `shouldReturn` 1 - removeFile testStoreLogFile + -- when (usesStoreLog ps) $ do + logSize testStoreLogFile `shouldReturn` (if compacting then 1 else 6) + removeFile testStoreLogFile where runTest :: Transport c => TProxy c -> (THandleSMP c 'TClient -> IO ()) -> ThreadId -> Expectation runTest _ test' server = do @@ -645,10 +646,14 @@ testWithStoreLog = runClient :: Transport c => TProxy c -> (THandleSMP c 'TClient -> IO ()) -> Expectation runClient _ test' = testSMPClient test' `shouldReturn` () -usesStoreLog :: (ATransport, AStoreType) -> Bool -usesStoreLog (_, ASType qsType _) = case qsType of - SQSMemory -> True - SQSPostgres -> False +serverStoreLogCfg :: AStoreType -> (ServerConfig, Bool) +serverStoreLogCfg msType = + let serverStoreCfg = serverStoreConfig_ True msType + cfg' = (cfgMS msType) {serverStoreCfg, storeNtfsFile = Just testStoreNtfsFile, serverStatsBackupFile = Just testServerStatsBackupFile} + compacting = case msType of + ASType SQSPostgres _ -> False + _ -> True + in (cfg', compacting) logSize :: FilePath -> IO Int logSize f = go (10 :: Int) @@ -662,7 +667,7 @@ logSize f = go (10 :: Int) testRestoreMessages :: SpecWith (ATransport, AStoreType) testRestoreMessages = - it "should store messages on exit and restore on start" $ \ps@(ATransport t, _) -> do + it "should store messages on exit and restore on start" $ \(at@(ATransport t), msType) -> do removeFileIfExists testStoreLogFile removeFileIfExists testStoreMsgsFile whenM (doesDirectoryExist testStoreMsgsDir) $ removeDirectoryRecursive testStoreMsgsDir @@ -674,7 +679,8 @@ testRestoreMessages = recipientKey <- newTVarIO Nothing dhShared <- newTVarIO Nothing senderId <- newTVarIO NoEntity - withSmpServerStoreMsgLogOn ps testPort . runTest t $ \h -> do + let (cfg', compacting) = serverStoreLogCfg msType + withSmpServerConfigOn at cfg' testPort . runTest t $ \h -> do runClient t $ \h1 -> do (sId, rId, rKey, dh) <- createAndSecureQueue h1 sPub atomically $ do @@ -695,11 +701,11 @@ testRestoreMessages = Resp "6" _ (ERR QUOTA) <- signSendRecv h sKey ("6", sId, _SEND "hello 6") pure () rId <- readTVarIO recipientId - when (usesStoreLog ps) $ logSize testStoreLogFile `shouldReturn` 2 + logSize testStoreLogFile `shouldReturn` 2 logSize testServerStatsBackupFile `shouldReturn` 76 Right stats1 <- strDecode <$> B.readFile testServerStatsBackupFile checkStats stats1 [rId] 5 1 - withSmpServerStoreMsgLogOn ps testPort . runTest t $ \h -> do + withSmpServerConfigOn at cfg' testPort . runTest t $ \h -> do Just rKey <- readTVarIO recipientKey Just dh <- readTVarIO dhShared let dec = decryptMsgV3 dh @@ -709,14 +715,14 @@ testRestoreMessages = (dec mId3 msg3, Right "hello 3") #== "restored message delivered" Resp "4" _ (Msg mId4 msg4) <- signSendRecv h rKey ("4", rId, ACK mId3) (dec mId4 msg4, Right "hello 4") #== "restored message delivered" - when (usesStoreLog ps) $ logSize testStoreLogFile `shouldReturn` 1 + logSize testStoreLogFile `shouldReturn` (if compacting then 1 else 2) -- the last message is not removed because it was not ACK'd -- logSize testStoreMsgsFile `shouldReturn` 3 logSize testServerStatsBackupFile `shouldReturn` 76 Right stats2 <- strDecode <$> B.readFile testServerStatsBackupFile checkStats stats2 [rId] 5 3 - withSmpServerStoreMsgLogOn ps testPort . runTest t $ \h -> do + withSmpServerConfigOn at cfg' testPort . runTest t $ \h -> do Just rKey <- readTVarIO recipientKey Just dh <- readTVarIO dhShared let dec = decryptMsgV3 dh @@ -728,9 +734,8 @@ testRestoreMessages = (dec mId6 msg6, Left "ClientRcvMsgQuota") #== "restored message delivered" Resp "7" _ OK <- signSendRecv h rKey ("7", rId, ACK mId6) pure () - when (usesStoreLog ps) $ do - logSize testStoreLogFile `shouldReturn` 1 - removeFile testStoreLogFile + logSize testStoreLogFile `shouldReturn` (if compacting then 1 else 2) + removeFile testStoreLogFile logSize testServerStatsBackupFile `shouldReturn` 76 Right stats3 <- strDecode <$> B.readFile testServerStatsBackupFile checkStats stats3 [rId] 5 5 @@ -764,14 +769,15 @@ checkStats s qs sent received = do testRestoreExpireMessages :: SpecWith (ATransport, AStoreType) testRestoreExpireMessages = - it "should store messages on exit and restore on start (old / v2)" $ \ps@(at@(ATransport t), msType) -> do + it "should store messages on exit and restore on start (old / v2)" $ \(at@(ATransport t), msType) -> do g <- C.newRandom (sPub, sKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g recipientId <- newTVarIO NoEntity recipientKey <- newTVarIO Nothing dhShared <- newTVarIO Nothing senderId <- newTVarIO NoEntity - withSmpServerStoreMsgLogOn ps testPort . runTest t $ \h -> do + let (cfg', _compacting) = serverStoreLogCfg msType + withSmpServerConfigOn at cfg' testPort . runTest t $ \h -> do runClient t $ \h1 -> do (sId, rId, rKey, dh) <- createAndSecureQueue h1 sPub atomically $ do @@ -786,36 +792,29 @@ testRestoreExpireMessages = Resp "3" _ OK <- signSendRecv h sKey ("3", sId, _SEND "hello 3") Resp "4" _ OK <- signSendRecv h sKey ("4", sId, _SEND "hello 4") pure () - msgs <- - if usesStoreLog ps - then do - logSize testStoreLogFile `shouldReturn` 2 - exportStoreMessages msType - msgs <- B.readFile testStoreMsgsFile - length (B.lines msgs) `shouldBe` 4 - pure msgs - else pure [] + logSize testStoreLogFile `shouldReturn` 2 + exportStoreMessages msType + msgs <- B.readFile testStoreMsgsFile + length (B.lines msgs) `shouldBe` 4 let expCfg1 = Just ExpirationConfig {ttl = 86400, checkInterval = 43200} - cfg1 = (cfgMS msType) {messageExpiration = expCfg1, serverStatsBackupFile = Just testServerStatsBackupFile} + cfg1 = cfg' {messageExpiration = expCfg1, serverStatsBackupFile = Just testServerStatsBackupFile} withSmpServerConfigOn at cfg1 testPort . runTest t $ \_ -> pure () - when (usesStoreLog ps) $ do - logSize testStoreLogFile `shouldReturn` 1 - exportStoreMessages msType - msgs' <- B.readFile testStoreMsgsFile - msgs' `shouldBe` msgs + logSize testStoreLogFile `shouldReturn` 1 + exportStoreMessages msType + msgs' <- B.readFile testStoreMsgsFile + msgs' `shouldBe` msgs let expCfg2 = Just ExpirationConfig {ttl = 2, checkInterval = 43200} - cfg2 = (cfgMS msType) {messageExpiration = expCfg2, serverStatsBackupFile = Just testServerStatsBackupFile} + cfg2 = cfg' {messageExpiration = expCfg2, serverStatsBackupFile = Just testServerStatsBackupFile} withSmpServerConfigOn at cfg2 testPort . runTest t $ \_ -> pure () - when (usesStoreLog ps) $ do - logSize testStoreLogFile `shouldReturn` 1 - -- two messages expired - exportStoreMessages msType - msgs'' <- B.readFile testStoreMsgsFile - length (B.lines msgs'') `shouldBe` 2 - B.lines msgs'' `shouldBe` drop 2 (B.lines msgs) + logSize testStoreLogFile `shouldReturn` 1 + -- two messages expired + exportStoreMessages msType + msgs'' <- B.readFile testStoreMsgsFile + length (B.lines msgs'') `shouldBe` 2 + B.lines msgs'' `shouldBe` drop 2 (B.lines msgs) Right ServerStatsData {_msgExpired} <- strDecode <$> B.readFile testServerStatsBackupFile _msgExpired `shouldBe` 2 where From fdf8bd7ee2b7d090c13df3e210d7739a7e49c6ae Mon Sep 17 00:00:00 2001 From: Evgeny Date: Thu, 13 Mar 2025 13:57:46 +0000 Subject: [PATCH 09/14] smp server: mask database store operations from async exception for state consistency (#1481) * smp server: mask database store operations from async exception for state consistency * remove unused, comments --- src/Simplex/Messaging/Server/Main.hs | 8 -------- src/Simplex/Messaging/Server/QueueStore/Postgres.hs | 9 ++++----- 2 files changed, 4 insertions(+), 13 deletions(-) diff --git a/src/Simplex/Messaging/Server/Main.hs b/src/Simplex/Messaging/Server/Main.hs index e3db02259..1c6dc38b5 100644 --- a/src/Simplex/Messaging/Server/Main.hs +++ b/src/Simplex/Messaging/Server/Main.hs @@ -800,7 +800,6 @@ data StoreCmd = SCImport | SCExport | SCDelete data InitOptions = InitOptions { enableStoreLog :: Bool, dbOptions :: DBOpts, - dbMigrateUp :: Bool, logStats :: Bool, signAlgorithm :: SignAlgorithm, ip :: HostName, @@ -842,12 +841,6 @@ cliCommandP cfgPath logPath iniFile = <> help "Enable store log for persistence" ) dbOptions <- dbOptsP - -- TODO [postgresql] remove - dbMigrateUp <- - switch - ( long "db-migrate-up" - <> help "Automatically confirm \"up\" database migrations" - ) logStats <- switch ( long "daily-stats" @@ -951,7 +944,6 @@ cliCommandP cfgPath logPath iniFile = InitOptions { enableStoreLog, dbOptions, - dbMigrateUp, logStats, signAlgorithm, ip, diff --git a/src/Simplex/Messaging/Server/QueueStore/Postgres.hs b/src/Simplex/Messaging/Server/QueueStore/Postgres.hs index 0e30ed66d..0d5796298 100644 --- a/src/Simplex/Messaging/Server/QueueStore/Postgres.hs +++ b/src/Simplex/Messaging/Server/QueueStore/Postgres.hs @@ -140,7 +140,7 @@ instance StoreQueueClass q => QueueStoreClass q (PostgresQueueStore q) where addQueue_ :: PostgresQueueStore q -> (RecipientId -> QueueRec -> IO q) -> RecipientId -> QueueRec -> IO (Either ErrorType q) addQueue_ st mkQ rId qr = do sq <- mkQ rId qr - withQueueLock sq "addQueue_" $ runExceptT $ do + withQueueLock sq "addQueue_" $ E.uninterruptibleMask_ $ runExceptT $ do void $ withDB "addQueue_" st $ \db -> E.try (DB.execute db insertQueueQuery $ queueRecToRow (rId, qr)) >>= bimapM handleDuplicate pure @@ -203,7 +203,6 @@ instance StoreQueueClass q => QueueStoreClass q (PostgresQueueStore q) where where PostgresQueueStore {notifiers} = st rId = recipientId sq - -- TODO [postgres] test how this query works with duplicate recipient_id (updates) and notifier_id (fails) update db = DB.execute db @@ -268,7 +267,7 @@ instance StoreQueueClass q => QueueStoreClass q (PostgresQueueStore q) where -- this method is called from JournalMsgStore deleteQueue that already locks the queue deleteStoreQueue :: PostgresQueueStore q -> q -> IO (Either ErrorType (QueueRec, Maybe (MsgQueue q))) - deleteStoreQueue st sq = runExceptT $ do + deleteStoreQueue st sq = E.uninterruptibleMask_ $ runExceptT $ do q <- ExceptT $ readQueueRecIO qr RoundedSystemTime ts <- liftIO getSystemDate assertUpdated $ withDB' "deleteStoreQueue" st $ \db -> @@ -373,7 +372,7 @@ setStatusDB op st sq status writeLog = withQueueDB :: StoreQueueClass q => q -> String -> (QueueRec -> ExceptT ErrorType IO a) -> IO (Either ErrorType a) withQueueDB sq op action = - withQueueLock sq op $ runExceptT $ ExceptT (readQueueRecIO $ queueRec sq) >>= action + withQueueLock sq op $ E.uninterruptibleMask_ $ runExceptT $ ExceptT (readQueueRecIO $ queueRec sq) >>= action assertUpdated :: ExceptT ErrorType IO Int64 -> ExceptT ErrorType IO () assertUpdated = (>>= \n -> when (n == 0) (throwE AUTH)) @@ -392,7 +391,7 @@ withDB op st action = withLog :: MonadIO m => String -> PostgresQueueStore q -> (StoreLog 'WriteMode -> IO ()) -> m () withLog op PostgresQueueStore {dbStoreLog} action = - forM_ dbStoreLog $ \sl -> liftIO $ E.uninterruptibleMask_ (action sl) `catchAny` \e -> + forM_ dbStoreLog $ \sl -> liftIO $ action sl `catchAny` \e -> logWarn $ "STORE: " <> T.pack (op <> ", withLog, " <> show e) handleDuplicate :: SqlError -> IO ErrorType From 1b5a9f3b0ca82e0fe729c10c213ca1d76473febb Mon Sep 17 00:00:00 2001 From: Evgeny Date: Sat, 15 Mar 2025 20:11:30 +0000 Subject: [PATCH 10/14] smp server: do not cache all queues from database while processing expirations (#1483) * smp server: expire only active queues * version * do not cache all queues while processing expirations * refactor * foldWithOptions_ * version * use shared lock when expiring all queues * use TMVar * comment * rename * remove fold options * do not create locks in the Map for temporarily loaded queues * fix * revert version --- simplexmq.cabal | 1 + src/Simplex/Messaging/Agent/Lock.hs | 1 + src/Simplex/Messaging/Server.hs | 51 ++++----- .../Messaging/Server/MsgStore/Journal.hs | 104 +++++++++++++----- .../Server/MsgStore/Journal/SharedLock.hs | 43 ++++++++ src/Simplex/Messaging/Server/MsgStore/STM.hs | 13 ++- .../Messaging/Server/MsgStore/Types.hs | 20 ++-- .../Messaging/Server/QueueStore/Postgres.hs | 48 ++++---- tests/CoreTests/MsgStoreTests.hs | 2 +- 9 files changed, 186 insertions(+), 97 deletions(-) create mode 100644 src/Simplex/Messaging/Server/MsgStore/Journal/SharedLock.hs diff --git a/simplexmq.cabal b/simplexmq.cabal index 457394f72..e081f67ca 100644 --- a/simplexmq.cabal +++ b/simplexmq.cabal @@ -228,6 +228,7 @@ library Simplex.Messaging.Server.Main 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.NtfStore diff --git a/src/Simplex/Messaging/Agent/Lock.hs b/src/Simplex/Messaging/Agent/Lock.hs index 3c087499c..43b2358fd 100644 --- a/src/Simplex/Messaging/Agent/Lock.hs +++ b/src/Simplex/Messaging/Agent/Lock.hs @@ -6,6 +6,7 @@ module Simplex.Messaging.Agent.Lock withLock', withGetLock, withGetLocks, + getPutLock, ) where diff --git a/src/Simplex/Messaging/Server.hs b/src/Simplex/Messaging/Server.hs index f0b97529a..d816118d5 100644 --- a/src/Simplex/Messaging/Server.hs +++ b/src/Simplex/Messaging/Server.hs @@ -97,7 +97,7 @@ 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, closeMsgQueue) +import Simplex.Messaging.Server.MsgStore.Journal (JournalMsgStore, JournalQueue) import Simplex.Messaging.Server.MsgStore.STM import Simplex.Messaging.Server.MsgStore.Types import Simplex.Messaging.Server.NtfStore @@ -404,11 +404,11 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg, startOpt old <- expireBeforeEpoch expCfg now <- systemSeconds <$> getSystemTime msgStats@MessageStats {storedMsgsCount = stored, expiredMsgsCount = expired} <- - withAllMsgQueues False ms $ expireQueueMsgs now ms old + withAllMsgQueues False "idleDeleteExpiredMsgs" ms $ expireQueueMsgs now ms old atomicWriteIORef (msgCount stats) stored atomicModifyIORef'_ (msgExpired stats) (+ expired) printMessageStats "STORE: messages" msgStats - expireQueueMsgs now ms old q = fmap (fromRight newMessageStats) . runExceptT $ do + expireQueueMsgs now ms old q = do (expired_, stored) <- idleDeleteExpiredMsgs now ms q old pure MessageStats {storedMsgsCount = stored, expiredMsgsCount = fromMaybe 0 expired_, storedQueues = 1} @@ -1806,19 +1806,18 @@ exportMessages :: MsgStoreClass s => Bool -> s -> FilePath -> Bool -> IO () exportMessages tty ms f drainMsgs = do logInfo $ "saving messages to file " <> T.pack f liftIO $ withFile f WriteMode $ \h -> - tryAny (withAllMsgQueues tty ms $ saveQueueMsgs h) >>= \case + tryAny (unsafeWithAllMsgQueues tty ms $ saveQueueMsgs h) >>= \case Right (Sum total) -> logInfo $ "messages saved: " <> tshow total Left e -> do logError $ "error exporting messages: " <> tshow e exitFailure where saveQueueMsgs h q = do - let rId = recipientId q - runExceptT (getQueueMessages drainMsgs ms q) >>= \case - Right msgs -> Sum (length msgs) <$ BLD.hPutBuilder h (encodeMessages rId msgs) - Left e -> do - logError $ "STORE: saveQueueMsgs, error exporting messages from queue " <> decodeLatin1 (strEncode rId) <> ", " <> tshow e - exitFailure + msgs <- + unsafeRunStore q "saveQueueMsgs" $ + getQueueMessages_ drainMsgs q =<< getMsgQueue ms q False + 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') processServerMessages :: StartOptions -> M (Maybe MessageStats) @@ -1838,33 +1837,23 @@ processServerMessages StartOptions {skipWarnings} = do | expire = Just <$> case old_ of Just old -> do logInfo "expiring journal store messages..." - withAllMsgQueues False ms $ processExpireQueue old + run $ processExpireQueue old Nothing -> do logInfo "validating journal store messages..." - withAllMsgQueues False ms $ processValidateQueue + 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 = - runExceptT expireQueue >>= \case - Right (storedMsgsCount, expiredMsgsCount) -> - pure MessageStats {storedMsgsCount, expiredMsgsCount, storedQueues = 1} - Left e -> do - logError $ "STORE: processExpireQueue, failed expiring messages in queue, " <> tshow e - exitFailure - where - expireQueue = do - expired'' <- deleteExpiredMsgs ms q old - stored'' <- getQueueSize ms q - liftIO $ closeMsgQueue q - pure (stored'', expired'') + 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 = - runExceptT (getQueueSize ms q) >>= \case - Right storedMsgsCount -> pure newMessageStats {storedMsgsCount, storedQueues = 1} - Left e -> do - logError $ "STORE: processValidateQueue, failed opening message queue, " <> tshow e - exitFailure + processValidateQueue q = unsafeRunStore q "processValidateQueue" $ do + storedMsgsCount <- getQueueSize_ =<< getMsgQueue ms q False + pure newMessageStats {storedMsgsCount, storedQueues = 1} importMessages :: forall s. MsgStoreClass s => Bool -> s -> FilePath -> Maybe Int64 -> Bool -> IO MessageStats importMessages tty ms f old_ skipWarnings = do diff --git a/src/Simplex/Messaging/Server/MsgStore/Journal.hs b/src/Simplex/Messaging/Server/MsgStore/Journal.hs index 74ebac2d3..369194030 100644 --- a/src/Simplex/Messaging/Server/MsgStore/Journal.hs +++ b/src/Simplex/Messaging/Server/MsgStore/Journal.hs @@ -55,6 +55,7 @@ import Control.Monad.Trans.Except import qualified Data.Attoparsec.ByteString.Char8 as A import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B +import Data.Either (fromRight) import Data.Functor (($>)) import Data.Int (Int64) import Data.List (intercalate, sort) @@ -65,10 +66,11 @@ import Data.Time.Clock (NominalDiffTime, UTCTime, addUTCTime, getCurrentTime) import Data.Time.Clock.System (SystemTime (..), getSystemTime) import Data.Time.Format.ISO8601 (iso8601Show, iso8601ParseM) import GHC.IO (catchAny) -import Simplex.Messaging.Agent.Client (getMapLock, withLockMap) +import Simplex.Messaging.Agent.Client (getMapLock) import Simplex.Messaging.Agent.Lock import Simplex.Messaging.Encoding.String import Simplex.Messaging.Protocol +import Simplex.Messaging.Server.MsgStore.Journal.SharedLock import Simplex.Messaging.Server.MsgStore.Types import Simplex.Messaging.Server.QueueStore import Simplex.Messaging.Server.QueueStore.Postgres @@ -87,6 +89,7 @@ data JournalMsgStore s = JournalMsgStore { config :: JournalStoreConfig s, random :: TVar StdGen, queueLocks :: TMap RecipientId Lock, + sharedLock :: TMVar RecipientId, queueStore_ :: QStore s, expireBackupsBefore :: UTCTime } @@ -138,6 +141,7 @@ data QStoreCfg s where data JournalQueue (s :: QSType) = JournalQueue { recipientId' :: RecipientId, queueLock :: Lock, + sharedLock :: TMVar RecipientId, -- To avoid race conditions and errors when restoring queues, -- Nothing is written to TVar when queue is deleted. queueRec' :: TVar (Maybe QueueRec), @@ -276,7 +280,8 @@ instance StoreQueueClass (JournalQueue s) where msgQueue = msgQueue' {-# INLINE msgQueue #-} withQueueLock :: JournalQueue s -> String -> IO a -> IO a - withQueueLock = withLock' . queueLock + withQueueLock JournalQueue {recipientId', queueLock, sharedLock} = + withLockWaitShared recipientId' queueLock sharedLock {-# INLINE withQueueLock #-} instance QueueStoreClass (JournalQueue s) (QStore s) where @@ -316,6 +321,27 @@ instance QueueStoreClass (JournalQueue s) (QStore s) where deleteStoreQueue = withQS deleteStoreQueue {-# INLINE deleteStoreQueue #-} +mkTempQueue :: JournalMsgStore s -> RecipientId -> QueueRec -> IO (JournalQueue s) +mkTempQueue ms rId qr = createLockIO >>= makeQueue_ ms rId qr +{-# INLINE mkTempQueue #-} + +makeQueue_ :: JournalMsgStore s -> RecipientId -> QueueRec -> Lock -> IO (JournalQueue s) +makeQueue_ JournalMsgStore {sharedLock} rId qr queueLock = do + queueRec' <- newTVarIO $ Just qr + msgQueue' <- newTVarIO Nothing + activeAt <- newTVarIO 0 + queueState <- newTVarIO Nothing + pure $ + JournalQueue + { recipientId' = rId, + queueLock, + sharedLock, + queueRec', + msgQueue', + activeAt, + queueState + } + instance MsgStoreClass (JournalMsgStore s) where type StoreMonad (JournalMsgStore s) = StoreIO s type QueueStore (JournalMsgStore s) = QStore s @@ -326,9 +352,10 @@ instance MsgStoreClass (JournalMsgStore s) where newMsgStore config@JournalStoreConfig {queueStoreCfg} = do random <- newTVarIO =<< newStdGen queueLocks <- TM.emptyIO + sharedLock <- newEmptyTMVarIO queueStore_ <- newQueueStore @(JournalQueue s) queueStoreCfg expireBackupsBefore <- addUTCTime (- expireBackupsAfter config) <$> getCurrentTime - pure JournalMsgStore {config, random, queueLocks, queueStore_, expireBackupsBefore} + pure JournalMsgStore {config, random, queueLocks, sharedLock, queueStore_, expireBackupsBefore} closeMsgStore :: JournalMsgStore s -> IO () closeMsgStore ms = do @@ -341,10 +368,32 @@ instance MsgStoreClass (JournalMsgStore s) where withActiveMsgQueues :: Monoid a => JournalMsgStore s -> (JournalQueue s -> IO a) -> IO a withActiveMsgQueues = withQS withLoadedQueues . queueStore_ - withAllMsgQueues :: Monoid a => Bool -> JournalMsgStore s -> (JournalQueue s -> IO a) -> IO a - withAllMsgQueues tty ms action = case queueStore_ ms of - MQStore st -> withLoadedQueues st action - PQStore st -> foldQueues tty st (mkQueue ms) action + -- This function can only be used in server CLI commands or before server is started. + -- It does not cache queues and is NOT concurrency safe. + unsafeWithAllMsgQueues :: Monoid a => Bool -> JournalMsgStore s -> (JournalQueue s -> IO a) -> IO a + unsafeWithAllMsgQueues tty ms action = case queueStore_ ms of + MQStore st -> withLoadedQueues st run + PQStore st -> foldQueueRecs tty st $ uncurry (mkTempQueue ms) >=> run + where + run q = do + r <- action q + closeMsgQueue q + pure r + + -- This function is concurrency safe, it is used to expire queues. + withAllMsgQueues :: forall a. Monoid a => Bool -> String -> JournalMsgStore s -> (JournalQueue s -> StoreIO s a) -> IO a + withAllMsgQueues tty op ms@JournalMsgStore {queueLocks, sharedLock} action = case queueStore_ ms of + MQStore st -> + withLoadedQueues st $ \q -> + run $ isolateQueue q op $ action q + PQStore st -> + foldQueueRecs tty st $ \(rId, qr) -> do + q <- mkTempQueue ms rId qr + withSharedWaitLock rId queueLocks sharedLock $ + run $ tryStore' op rId $ unStoreIO $ action q + where + run :: ExceptT ErrorType IO a -> IO a + run = fmap (fromRight mempty) . runExceptT logQueueStates :: JournalMsgStore s -> IO () logQueueStates ms = withActiveMsgQueues ms $ unStoreIO . logQueueState @@ -361,20 +410,11 @@ instance MsgStoreClass (JournalMsgStore s) where mkQueue :: JournalMsgStore s -> RecipientId -> QueueRec -> IO (JournalQueue s) mkQueue ms rId qr = do - queueLock <- atomically $ getMapLock (queueLocks ms) rId - queueRec' <- newTVarIO $ Just qr - msgQueue' <- newTVarIO Nothing - activeAt <- newTVarIO 0 - queueState <- newTVarIO Nothing - pure $ - JournalQueue - { recipientId' = rId, - queueLock, - queueRec', - msgQueue', - activeAt, - queueState - } + lock <- atomically $ getMapLock (queueLocks ms) rId + makeQueue_ ms rId qr lock + + getLoadedQueue :: JournalMsgStore s -> JournalQueue s -> StoreIO s (JournalQueue s) + getLoadedQueue ms sq = StoreIO $ fromMaybe sq <$> TM.lookupIO (recipientId sq) (loadedQueues $ queueStore_ ms) getMsgQueue :: JournalMsgStore s -> JournalQueue s -> Bool -> StoreIO s (JournalMsgQueue s) getMsgQueue ms@JournalMsgStore {random} q'@JournalQueue {recipientId' = rId, msgQueue'} forWrite = @@ -546,8 +586,11 @@ instance MsgStoreClass (JournalMsgStore s) where $>>= \hs -> updateReadPos q mq logState len hs $> Just () isolateQueue :: JournalQueue s -> String -> StoreIO s a -> ExceptT ErrorType IO a - isolateQueue JournalQueue {recipientId' = rId, queueLock} op a = - tryStore' op rId $ withLock' queueLock op $ unStoreIO a + isolateQueue sq op = tryStore' op (recipientId' sq) . withQueueLock sq op . unStoreIO + + unsafeRunStore :: JournalQueue s -> String -> StoreIO s a -> IO a + unsafeRunStore sq op a = + unStoreIO a `E.catch` \e -> storeError op (recipientId' sq) e >> E.throwIO e updateActiveAt :: JournalQueue s -> IO () updateActiveAt q = atomically . writeTVar (activeAt q) . systemSeconds =<< getSystemTime @@ -556,15 +599,16 @@ tryStore' :: String -> RecipientId -> IO a -> ExceptT ErrorType IO a tryStore' op rId = tryStore op rId . fmap Right tryStore :: forall a. String -> RecipientId -> IO (Either ErrorType a) -> ExceptT ErrorType IO a -tryStore op rId a = ExceptT $ E.mask_ $ E.try a >>= either storeErr pure - where - storeErr :: E.SomeException -> IO (Either ErrorType a) - storeErr e = - let e' = intercalate ", " [op, B.unpack $ strEncode rId, show e] - in logError ("STORE: " <> T.pack e') $> Left (STORE e') +tryStore op rId a = ExceptT $ E.mask_ $ a `E.catch` storeError op rId + +storeError :: String -> RecipientId -> E.SomeException -> IO (Either ErrorType a) +storeError op rId e = + let e' = intercalate ", " [op, B.unpack $ strEncode rId, show e] + in logError ("STORE: " <> T.pack e') $> Left (STORE e') isolateQueueId :: String -> JournalMsgStore s -> RecipientId -> IO (Either ErrorType a) -> ExceptT ErrorType IO a -isolateQueueId op ms rId = tryStore op rId . withLockMap (queueLocks ms) rId op +isolateQueueId op JournalMsgStore {queueLocks, sharedLock} rId = + tryStore op rId . withLockMapWaitShared rId queueLocks sharedLock op openMsgQueue :: JournalMsgStore s -> JMQueue -> Bool -> IO (JournalMsgQueue s) openMsgQueue ms@JournalMsgStore {config} q@JMQueue {queueDirectory = dir, statePath} forWrite = do diff --git a/src/Simplex/Messaging/Server/MsgStore/Journal/SharedLock.hs b/src/Simplex/Messaging/Server/MsgStore/Journal/SharedLock.hs new file mode 100644 index 000000000..4e09f3895 --- /dev/null +++ b/src/Simplex/Messaging/Server/MsgStore/Journal/SharedLock.hs @@ -0,0 +1,43 @@ +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 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 -> String -> 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 -> String -> IO a -> IO a +withLockMapWaitShared rId locks shared name a = + E.bracket + (atomically $ waitShared rId shared >> getPutLock (getMapLock locks) rId name) + (atomically . takeTMVar) + (const a) + +waitShared :: RecipientId -> TMVar RecipientId -> STM () +waitShared rId shared = tryReadTMVar shared >>= mapM_ (\rId' -> when (rId == rId') retry) + +-- wait until lock with passed ID in Map is released and take shared lock for this ID +withSharedWaitLock :: RecipientId -> TMap RecipientId Lock -> TMVar RecipientId -> IO a -> IO a +withSharedWaitLock rId locks shared = + E.bracket_ + (atomically $ waitLock >> putTMVar shared rId) + (atomically $ takeTMVar shared) + where + waitLock = TM.lookup rId locks $>>= tryReadTMVar $>> retry diff --git a/src/Simplex/Messaging/Server/MsgStore/STM.hs b/src/Simplex/Messaging/Server/MsgStore/STM.hs index ff7a93db8..43a41d7ca 100644 --- a/src/Simplex/Messaging/Server/MsgStore/STM.hs +++ b/src/Simplex/Messaging/Server/MsgStore/STM.hs @@ -80,7 +80,9 @@ instance MsgStoreClass STMMsgStore where {-# INLINE closeMsgStore #-} withActiveMsgQueues = withLoadedQueues . queueStore_ {-# INLINE withActiveMsgQueues #-} - withAllMsgQueues _ = withLoadedQueues . queueStore_ + unsafeWithAllMsgQueues _ = withLoadedQueues . queueStore_ + {-# INLINE unsafeWithAllMsgQueues #-} + withAllMsgQueues _tty _op ms action = withLoadedQueues (queueStore_ ms) $ atomically . action {-# INLINE withAllMsgQueues #-} logQueueStates _ = pure () {-# INLINE logQueueStates #-} @@ -92,6 +94,10 @@ instance MsgStoreClass STMMsgStore where mkQueue _ rId qr = STMQueue rId <$> newTVarIO (Just qr) <*> newTVarIO Nothing {-# INLINE mkQueue #-} + getLoadedQueue :: STMMsgStore -> STMQueue -> STM STMQueue + getLoadedQueue _ = pure + {-# INLINE getLoadedQueue #-} + getMsgQueue :: STMMsgStore -> STMQueue -> Bool -> STM STMMsgQueue getMsgQueue _ STMQueue {msgQueue'} _ = readTVar msgQueue' >>= maybe newQ pure where @@ -168,3 +174,8 @@ instance MsgStoreClass STMMsgStore where isolateQueue :: STMQueue -> String -> STM a -> ExceptT ErrorType IO a isolateQueue _ _ = liftIO . atomically + {-# INLINE isolateQueue #-} + + unsafeRunStore :: STMQueue -> String -> STM a -> IO a + unsafeRunStore _ _ = atomically + {-# INLINE unsafeRunStore #-} diff --git a/src/Simplex/Messaging/Server/MsgStore/Types.hs b/src/Simplex/Messaging/Server/MsgStore/Types.hs index 420517ac4..514b67d7b 100644 --- a/src/Simplex/Messaging/Server/MsgStore/Types.hs +++ b/src/Simplex/Messaging/Server/MsgStore/Types.hs @@ -35,13 +35,16 @@ class (Monad (StoreMonad s), QueueStoreClass (StoreQueue s) (QueueStore s)) => M newMsgStore :: MsgStoreConfig s -> IO s closeMsgStore :: s -> IO () withActiveMsgQueues :: Monoid a => s -> (StoreQueue s -> IO a) -> IO a - withAllMsgQueues :: Monoid a => Bool -> s -> (StoreQueue s -> IO a) -> IO a + -- This function can only be used in server CLI commands or before server is started. + unsafeWithAllMsgQueues :: Monoid a => Bool -> s -> (StoreQueue s -> IO a) -> IO a + withAllMsgQueues :: Monoid a => Bool -> String -> s -> (StoreQueue s -> StoreMonad s a) -> IO a logQueueStates :: s -> IO () logQueueState :: StoreQueue s -> StoreMonad s () queueStore :: s -> QueueStore s -- message store methods mkQueue :: s -> RecipientId -> QueueRec -> IO (StoreQueue s) + getLoadedQueue :: s -> StoreQueue s -> StoreMonad s (StoreQueue s) getMsgQueue :: s -> StoreQueue s -> Bool -> StoreMonad s (MsgQueue (StoreQueue s)) getPeekMsgQueue :: s -> StoreQueue s -> StoreMonad s (Maybe (MsgQueue (StoreQueue s), Message)) @@ -56,6 +59,7 @@ class (Monad (StoreMonad s), QueueStoreClass (StoreQueue s) (QueueStore s)) => M tryPeekMsg_ :: StoreQueue s -> MsgQueue (StoreQueue s) -> StoreMonad s (Maybe Message) tryDeleteMsg_ :: StoreQueue s -> MsgQueue (StoreQueue s) -> Bool -> StoreMonad s () isolateQueue :: StoreQueue s -> String -> StoreMonad s a -> ExceptT ErrorType IO a + unsafeRunStore :: StoreQueue s -> String -> StoreMonad s a -> IO a data MSType = MSMemory | MSJournal @@ -82,10 +86,6 @@ getQueueRec st party qId = getQueue st party qId $>>= (\q -> maybe (Left AUTH) (Right . (q,)) <$> readTVarIO (queueRec q)) -getQueueMessages :: MsgStoreClass s => Bool -> s -> StoreQueue s -> ExceptT ErrorType IO [Message] -getQueueMessages drainMsgs st q = withPeekMsgQueue st q "getQueueMessages" $ maybe (pure []) (getQueueMessages_ drainMsgs q . fst) -{-# INLINE getQueueMessages #-} - getQueueSize :: MsgStoreClass s => s -> StoreQueue s -> ExceptT ErrorType IO Int getQueueSize st q = withPeekMsgQueue st q "getQueueSize" $ maybe (pure 0) (getQueueSize_ . fst) {-# INLINE getQueueSize #-} @@ -124,10 +124,12 @@ deleteExpiredMsgs st q old = -- closed and idle queues will be closed after expiration -- returns (expired count, queue size after expiration) -idleDeleteExpiredMsgs :: MsgStoreClass s => Int64 -> s -> StoreQueue s -> Int64 -> ExceptT ErrorType IO (Maybe Int, Int) -idleDeleteExpiredMsgs now st q old = - isolateQueue q "idleDeleteExpiredMsgs" $ - withIdleMsgQueue now st q (deleteExpireMsgs_ old q) +idleDeleteExpiredMsgs :: MsgStoreClass s => Int64 -> s -> StoreQueue s -> Int64 -> StoreMonad s (Maybe Int, Int) +idleDeleteExpiredMsgs now st q old = do + -- Use cached queue if available. + -- Also see the comment in loadQueue in PostgresQueueStore + q' <- getLoadedQueue st q + withIdleMsgQueue now st q' $ deleteExpireMsgs_ old q' deleteExpireMsgs_ :: MsgStoreClass s => Int64 -> StoreQueue s -> MsgQueue (StoreQueue s) -> StoreMonad s Int deleteExpireMsgs_ old q mq = do diff --git a/src/Simplex/Messaging/Server/QueueStore/Postgres.hs b/src/Simplex/Messaging/Server/QueueStore/Postgres.hs index 0d5796298..0b6216b35 100644 --- a/src/Simplex/Messaging/Server/QueueStore/Postgres.hs +++ b/src/Simplex/Messaging/Server/QueueStore/Postgres.hs @@ -23,7 +23,6 @@ module Simplex.Messaging.Server.QueueStore.Postgres PostgresStoreCfg (..), batchInsertQueues, foldQueueRecs, - foldQueues, ) where @@ -166,11 +165,26 @@ instance StoreQueueClass q => QueueStoreClass q (PostgresQueueStore q) where loadRcvQueue = loadQueue " WHERE recipient_id = ?" $ \_ -> pure () loadSndQueue = loadQueue " WHERE sender_id = ?" $ \rId -> TM.insert qId rId senders loadNtfQueue = loadQueue " WHERE notifier_id = ?" $ \_ -> pure () -- do NOT cache ref - ntf subscriptions are rare - loadQueue condition insertRef = runExceptT $ loadQueueRec >>= liftIO . cachedOrLoadedQueue st mkQ insertRef - where - loadQueueRec = + loadQueue condition insertRef = + runExceptT $ do + (rId, qRec) <- withDB "getQueue_" st $ \db -> firstRow rowToQueueRec AUTH $ DB.query db (queueRecQuery <> condition <> " AND deleted_at IS NULL") (Only qId) + liftIO $ do + sq <- mkQ 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. + 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 -> do + insertRef rId + TM.insert rId sq queues + pure sq secureQueue :: PostgresQueueStore q -> q -> SndPublicAuthKey -> IO (Either ErrorType ()) secureQueue st sq sKey = @@ -311,18 +325,15 @@ insertQueueQuery = VALUES (?,?,?,?,?,?,?,?,?,?,?) |] -foldQueues :: Monoid a => Bool -> PostgresQueueStore q -> (RecipientId -> QueueRec -> IO q) -> (q -> IO a) -> IO a -foldQueues tty st mkQ f = - foldQueueRecs tty st $ cachedOrLoadedQueue st mkQ (\_ -> pure ()) >=> f - foldQueueRecs :: Monoid a => Bool -> PostgresQueueStore q -> ((RecipientId, QueueRec) -> IO a) -> IO a foldQueueRecs tty st f = do (n, r) <- withConnection (dbStore st) $ \db -> - DB.fold_ db (queueRecQuery <> " WHERE deleted_at IS NULL") (0 :: Int, mempty) $ \(!i, !acc) row -> do + DB.fold_ db (queueRecQuery <> " WHERE deleted_at IS NULL") (0 :: Int, mempty) $ \(i, acc) row -> do r <- f $ rowToQueueRec row - let i' = i + 1 - when (tty && i' `mod` 100000 == 0) $ putStr (progress i <> "\r") >> hFlush stdout - pure (i', acc <> r) + let !i' = i + 1 + !acc' = acc <> r + when (tty && i' `mod` 100000 == 0) $ putStr (progress i' <> "\r") >> hFlush stdout + pure (i', acc') when tty $ putStrLn $ progress n pure r where @@ -338,19 +349,6 @@ queueRecQuery = FROM msg_queues |] -cachedOrLoadedQueue :: PostgresQueueStore q -> (RecipientId -> QueueRec -> IO q) -> (RecipientId -> STM ()) -> (RecipientId, QueueRec) -> IO q -cachedOrLoadedQueue PostgresQueueStore {queues} mkQ insertRef (rId, qRec) = do - sq <- liftIO $ mkQ rId qRec -- loaded queue - 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 - insertRef rId - TM.insert rId sq queues - pure sq - type QueueRecRow = (RecipientId, RcvPublicAuthKey, RcvDhSecret, SenderId, Maybe SndPublicAuthKey, SenderCanSecure, Maybe NotifierId, Maybe NtfPublicAuthKey, Maybe RcvNtfDhSecret, ServerEntityStatus, Maybe RoundedSystemTime) queueRecToRow :: (RecipientId, QueueRec) -> QueueRecRow diff --git a/tests/CoreTests/MsgStoreTests.hs b/tests/CoreTests/MsgStoreTests.hs index bbb7a7e8c..e73527ad4 100644 --- a/tests/CoreTests/MsgStoreTests.hs +++ b/tests/CoreTests/MsgStoreTests.hs @@ -453,7 +453,7 @@ testExpireIdleQueues = do old <- expireBeforeEpoch ExpirationConfig {ttl = 1, checkInterval = 1} -- no old messages now <- systemSeconds <$> getSystemTime - (expired_, stored) <- runRight $ idleDeleteExpiredMsgs now ms q old + (expired_, stored) <- runRight $ isolateQueue q "" $ idleDeleteExpiredMsgs now ms q old expired_ `shouldBe` Just 0 stored `shouldBe` 0 (Nothing, False) <- readQueueState ms statePath From fe64d42db1dcc5fad225648e6dcc6089c607ca6f Mon Sep 17 00:00:00 2001 From: Evgeny Date: Sun, 16 Mar 2025 11:37:25 +0000 Subject: [PATCH 11/14] smp server: split postgres support to a separate executable, to not require postgres library in the main binary (#1482) * smp server: split postgres support to a separate executable, to not require postgres library in the main binary * comments * enable server_postgres flag by default, add CPP option to test * refactor * change default for server_postgres to False * diff --- .github/workflows/build.yml | 2 +- simplexmq.cabal | 58 ++-- .../Messaging/Agent/Store/Postgres/Common.hs | 10 +- .../Messaging/Agent/Store/Postgres/Options.hs | 12 + src/Simplex/Messaging/Server/CLI.hs | 4 +- src/Simplex/Messaging/Server/Env/STM.hs | 16 +- src/Simplex/Messaging/Server/Main.hs | 274 +++--------------- src/Simplex/Messaging/Server/Main/Init.hs | 230 +++++++++++++++ .../Messaging/Server/MsgStore/Journal.hs | 28 +- src/Simplex/Messaging/Server/QueueStore.hs | 13 +- .../Messaging/Server/QueueStore/Postgres.hs | 10 +- .../Server/QueueStore/Postgres/Config.hs | 12 + tests/Fixtures.hs | 5 - tests/SMPClient.hs | 15 +- tests/Test.hs | 25 +- tests/Util.hs | 9 - 16 files changed, 425 insertions(+), 298 deletions(-) create mode 100644 src/Simplex/Messaging/Agent/Store/Postgres/Options.hs create mode 100644 src/Simplex/Messaging/Server/Main/Init.hs create mode 100644 src/Simplex/Messaging/Server/QueueStore/Postgres/Config.hs diff --git a/.github/workflows/build.yml b/.github/workflows/build.yml index 3eca8742f..7747bebc8 100644 --- a/.github/workflows/build.yml +++ b/.github/workflows/build.yml @@ -58,7 +58,7 @@ jobs: - name: Build binaries shell: bash - run: docker exec -t -e apps="$apps" builder sh -c 'cabal build --enable-tests && mkdir /out && for i in $apps; do bin=$(find /project/dist-newstyle -name "$i" -type f -executable); strip "$bin"; chmod +x "$bin"; mv "$bin" /out/; done' + run: docker exec -t -e apps="$apps" builder sh -c 'cabal build --enable-tests -fserver_postgres && mkdir /out && for i in $apps; do bin=$(find /project/dist-newstyle -name "$i" -type f -executable); strip "$bin"; chmod +x "$bin"; mv "$bin" /out/; done' - name: Copy binaries from container and prepare them if: startsWith(github.ref, 'refs/tags/v') diff --git a/simplexmq.cabal b/simplexmq.cabal index e081f67ca..6bbf363bb 100644 --- a/simplexmq.cabal +++ b/simplexmq.cabal @@ -72,6 +72,11 @@ flag client_postgres manual: True default: False +flag server_postgres + description: Build server with support of PostgreSQL. + manual: True + default: False + library exposed-modules: Simplex.FileTransfer.Agent @@ -101,6 +106,7 @@ library Simplex.Messaging.Agent.Store.Interface Simplex.Messaging.Agent.Store.Migrations Simplex.Messaging.Agent.Store.Migrations.App + Simplex.Messaging.Agent.Store.Postgres.Options Simplex.Messaging.Agent.Store.Shared Simplex.Messaging.Agent.TRcvQueues Simplex.Messaging.Client @@ -124,6 +130,7 @@ library Simplex.Messaging.Parsers Simplex.Messaging.Protocol Simplex.Messaging.Server.Expiration + Simplex.Messaging.Server.QueueStore.Postgres.Config Simplex.Messaging.Server.QueueStore.QueueInfo Simplex.Messaging.ServiceScheme Simplex.Messaging.Session @@ -206,11 +213,6 @@ library Simplex.FileTransfer.Server.Stats Simplex.FileTransfer.Server.Store Simplex.FileTransfer.Server.StoreLog - Simplex.Messaging.Agent.Store.Postgres - Simplex.Messaging.Agent.Store.Postgres.Common - Simplex.Messaging.Agent.Store.Postgres.DB - Simplex.Messaging.Agent.Store.Postgres.Migrations - Simplex.Messaging.Agent.Store.Postgres.Util Simplex.Messaging.Notifications.Server Simplex.Messaging.Notifications.Server.Control Simplex.Messaging.Notifications.Server.Env @@ -226,6 +228,7 @@ library Simplex.Messaging.Server.Env.STM Simplex.Messaging.Server.Information Simplex.Messaging.Server.Main + Simplex.Messaging.Server.Main.Init Simplex.Messaging.Server.MsgStore Simplex.Messaging.Server.MsgStore.Journal Simplex.Messaging.Server.MsgStore.Journal.SharedLock @@ -235,14 +238,24 @@ library Simplex.Messaging.Server.Prometheus Simplex.Messaging.Server.QueueStore Simplex.Messaging.Server.QueueStore.STM - Simplex.Messaging.Server.QueueStore.Postgres - Simplex.Messaging.Server.QueueStore.Postgres.Migrations Simplex.Messaging.Server.QueueStore.Types Simplex.Messaging.Server.Stats Simplex.Messaging.Server.StoreLog Simplex.Messaging.Server.StoreLog.ReadWrite Simplex.Messaging.Server.StoreLog.Types Simplex.Messaging.Transport.WebSockets + if flag(client_postgres) || flag(server_postgres) + exposed-modules: + Simplex.Messaging.Agent.Store.Postgres + Simplex.Messaging.Agent.Store.Postgres.Common + Simplex.Messaging.Agent.Store.Postgres.DB + Simplex.Messaging.Agent.Store.Postgres.Migrations + Simplex.Messaging.Agent.Store.Postgres.Util + + if flag(server_postgres) + exposed-modules: + Simplex.Messaging.Server.QueueStore.Postgres + Simplex.Messaging.Server.QueueStore.Postgres.Migrations other-modules: Paths_simplexmq hs-source-dirs: @@ -307,21 +320,23 @@ library case-insensitive ==1.2.* , hashable ==1.4.* , ini ==0.4.1 - , postgresql-simple ==0.7.* , optparse-applicative >=0.15 && <0.17 , process ==1.6.* - , raw-strings-qq ==1.1.* , temporary ==1.3.* , websockets ==0.12.* - if flag(client_postgres) || !flag(client_library) + if flag(client_postgres) || flag(server_postgres) build-depends: postgresql-libpq >=0.10.0.0 + , postgresql-simple ==0.7.* + , raw-strings-qq ==1.1.* if flag(client_postgres) cpp-options: -DdbPostgres else build-depends: direct-sqlcipher ==2.3.* , sqlcipher-simple ==0.4.* + if flag(server_postgres) + cpp-options: -DdbServerPostgres if impl(ghc >= 9.6.2) build-depends: bytestring ==0.11.* @@ -439,7 +454,6 @@ test-suite simplexmq-test CoreTests.UtilTests CoreTests.VersionRangeTests FileDescriptionTests - Fixtures NtfClient NtfServerTests RemoteControl @@ -455,7 +469,10 @@ test-suite simplexmq-test Static Static.Embedded Paths_simplexmq - if !flag(client_postgres) + if flag(client_postgres) + other-modules: + Fixtures + else other-modules: AgentTests.SchemaDump AgentTests.SQLiteTests @@ -477,7 +494,6 @@ test-suite simplexmq-test , crypton-x509 , crypton-x509-store , crypton-x509-validation - , deepseq ==1.4.* , directory , file-embed , filepath @@ -491,11 +507,8 @@ test-suite simplexmq-test , ini , iso8601-time , main-tester ==0.2.* - , memory , mtl , network - , postgresql-simple ==0.7.* - , process , QuickCheck ==2.14.* , random , silently ==1.2.* @@ -516,10 +529,15 @@ test-suite simplexmq-test , yaml default-language: Haskell2010 if flag(client_postgres) - build-depends: - postgresql-libpq >=0.10.0.0 - , raw-strings-qq ==1.1.* cpp-options: -DdbPostgres else build-depends: - sqlcipher-simple + deepseq ==1.4.* + , memory + , process + , sqlcipher-simple + if flag(client_postgres) || flag(server_postgres) + build-depends: + postgresql-simple ==0.7.* + if flag(server_postgres) + cpp-options: -DdbServerPostgres diff --git a/src/Simplex/Messaging/Agent/Store/Postgres/Common.hs b/src/Simplex/Messaging/Agent/Store/Postgres/Common.hs index ee94825a4..a71376a20 100644 --- a/src/Simplex/Messaging/Agent/Store/Postgres/Common.hs +++ b/src/Simplex/Messaging/Agent/Store/Postgres/Common.hs @@ -20,7 +20,7 @@ import Control.Concurrent.STM import Control.Exception (bracket) import Data.ByteString (ByteString) import qualified Database.PostgreSQL.Simple as PSQL -import Numeric.Natural +import Simplex.Messaging.Agent.Store.Postgres.Options -- TODO [postgres] use log_min_duration_statement instead of custom slow queries (SQLite's Connection type) data DBStore = DBStore @@ -35,14 +35,6 @@ data DBStore = DBStore dbNew :: Bool } -data DBOpts = DBOpts - { connstr :: ByteString, - schema :: ByteString, - poolSize :: Natural, - createSchema :: Bool - } - deriving (Show) - withConnectionPriority :: DBStore -> Bool -> (PSQL.Connection -> IO a) -> IO a withConnectionPriority DBStore {dbPool, dbSem} _priority = bracket diff --git a/src/Simplex/Messaging/Agent/Store/Postgres/Options.hs b/src/Simplex/Messaging/Agent/Store/Postgres/Options.hs new file mode 100644 index 000000000..62ab89265 --- /dev/null +++ b/src/Simplex/Messaging/Agent/Store/Postgres/Options.hs @@ -0,0 +1,12 @@ +module Simplex.Messaging.Agent.Store.Postgres.Options where + +import Data.ByteString (ByteString) +import Numeric.Natural + +data DBOpts = DBOpts + { connstr :: ByteString, + schema :: ByteString, + poolSize :: Natural, + createSchema :: Bool + } + deriving (Show) diff --git a/src/Simplex/Messaging/Server/CLI.hs b/src/Simplex/Messaging/Server/CLI.hs index a1e9f8d83..d7660cd0b 100644 --- a/src/Simplex/Messaging/Server/CLI.hs +++ b/src/Simplex/Messaging/Server/CLI.hs @@ -27,11 +27,11 @@ import qualified Data.X509.File as XF import Data.X509.Validation (Fingerprint (..)) import Network.Socket (HostName, ServiceName) import Options.Applicative -import Simplex.Messaging.Agent.Store.Postgres.Common (DBOpts (..)) +import Simplex.Messaging.Agent.Store.Postgres.Options (DBOpts (..)) import Simplex.Messaging.Encoding.String import Simplex.Messaging.Protocol (ProtoServerWithAuth (..), ProtocolServer (..), ProtocolTypeI) import Simplex.Messaging.Server.Env.STM (AServerStoreCfg (..), ServerStoreCfg (..), StorePaths (..)) -import Simplex.Messaging.Server.QueueStore.Postgres (PostgresStoreCfg (..)) +import Simplex.Messaging.Server.QueueStore.Postgres.Config (PostgresStoreCfg (..)) import Simplex.Messaging.Transport (ATransport (..), TLS, Transport (..)) import Simplex.Messaging.Transport.Server (AddHTTP, loadFileFingerprint) import Simplex.Messaging.Transport.WebSockets (WS) diff --git a/src/Simplex/Messaging/Server/Env/STM.hs b/src/Simplex/Messaging/Server/Env/STM.hs index 3e890c236..929ea7e64 100644 --- a/src/Simplex/Messaging/Server/Env/STM.hs +++ b/src/Simplex/Messaging/Server/Env/STM.hs @@ -56,7 +56,7 @@ import Simplex.Messaging.Server.MsgStore.STM import Simplex.Messaging.Server.MsgStore.Types import Simplex.Messaging.Server.NtfStore import Simplex.Messaging.Server.QueueStore -import Simplex.Messaging.Server.QueueStore.Postgres (PostgresStoreCfg (..)) +import Simplex.Messaging.Server.QueueStore.Postgres.Config import Simplex.Messaging.Server.QueueStore.STM (STMQueueStore, setStoreLog) import Simplex.Messaging.Server.QueueStore.Types import Simplex.Messaging.Server.Stats @@ -324,7 +324,7 @@ newProhibitedSub = do return Sub {subThread = ProhibitSub, delivered} newEnv :: ServerConfig -> IO Env -newEnv config@ServerConfig {smpCredentials, httpCredentials, serverStoreCfg, smpAgentCfg, information, messageExpiration, idleQueueInterval, msgQueueQuota, maxJournalMsgCount, maxJournalStateLines, startOptions} = do +newEnv config@ServerConfig {smpCredentials, httpCredentials, serverStoreCfg, smpAgentCfg, information, messageExpiration, idleQueueInterval, msgQueueQuota, maxJournalMsgCount, maxJournalStateLines} = do serverActive <- newTVarIO True server <- newServer msgStore <- case serverStoreCfg of @@ -339,12 +339,16 @@ newEnv config@ServerConfig {smpCredentials, httpCredentials, serverStoreCfg, smp ms <- newMsgStore cfg loadStoreLog (mkQueue ms) storeLogFile $ stmQueueStore ms pure $ AMS qt mt ms +#if defined(dbServerPostgres) ASSCfg qt mt SSCDatabaseJournal {storeCfg, storeMsgsPath'} -> do - let StartOptions {confirmMigrations} = startOptions + let StartOptions {confirmMigrations} = startOptions config qsCfg = PQStoreCfg (storeCfg {confirmMigrations} :: PostgresStoreCfg) cfg = mkJournalStoreConfig qsCfg storeMsgsPath' msgQueueQuota maxJournalMsgCount maxJournalStateLines idleQueueInterval ms <- newMsgStore cfg pure $ AMS qt mt ms +#else + ASSCfg _ _ SSCDatabaseJournal {} -> noPostgresExit +#endif ntfStore <- NtfStore <$> TM.emptyIO random <- C.newRandom tlsServerCreds <- getCredentials "SMP" smpCredentials @@ -404,6 +408,12 @@ newEnv config@ServerConfig {smpCredentials, httpCredentials, serverStoreCfg, smp _ -> SPMQueues _ -> SPMMessages +noPostgresExit :: IO a +noPostgresExit = do + putStrLn "Error: server binary is compiled without support for PostgreSQL database." + putStrLn "Please download `smp-server-postgres` or re-compile with `cabal build -fserver_postgres`." + exitFailure + mkJournalStoreConfig :: QStoreCfg s -> FilePath -> Int -> Int -> Int -> Int64 -> JournalStoreConfig s mkJournalStoreConfig queueStoreCfg storePath msgQueueQuota maxJournalMsgCount maxJournalStateLines idleQueueInterval = JournalStoreConfig diff --git a/src/Simplex/Messaging/Server/Main.hs b/src/Simplex/Messaging/Server/Main.hs index 1c6dc38b5..e986906a5 100644 --- a/src/Simplex/Messaging/Server/Main.hs +++ b/src/Simplex/Messaging/Server/Main.hs @@ -1,4 +1,5 @@ {-# LANGUAGE ApplicativeDo #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE GADTs #-} @@ -25,21 +26,16 @@ import Data.Char (isAlpha, isAscii, toUpper) import Data.Either (fromRight) import Data.Functor (($>)) import Data.Ini (Ini, lookupValue, readIniFile) -import Data.Int (Int64) import Data.List (find, isPrefixOf) import qualified Data.List.NonEmpty as L import Data.Maybe (fromMaybe, isJust, isNothing) -import Data.Semigroup (Sum (..)) import Data.Text (Text) import qualified Data.Text as T import Data.Text.Encoding (decodeLatin1, encodeUtf8) import qualified Data.Text.IO as T -import Network.Socket (HostName) -import Numeric.Natural (Natural) import Options.Applicative import Simplex.Messaging.Agent.Protocol (connReqUriP') -import Simplex.Messaging.Agent.Store.Postgres (checkSchemaExists) -import Simplex.Messaging.Agent.Store.Postgres.Common (DBOpts (..)) +import Simplex.Messaging.Agent.Store.Postgres.Options (DBOpts (..)) import Simplex.Messaging.Agent.Store.Shared (MigrationConfirmation (..)) import Simplex.Messaging.Client (HostMode (..), NetworkConfig (..), ProtocolClientConfig (..), SocksMode (..), defaultNetworkConfig, textToHostMode) import Simplex.Messaging.Client.Agent (SMPClientAgentConfig (..), defaultSMPClientAgentConfig) @@ -52,22 +48,33 @@ import Simplex.Messaging.Server.CLI import Simplex.Messaging.Server.Env.STM import Simplex.Messaging.Server.Expiration import Simplex.Messaging.Server.Information -import Simplex.Messaging.Server.MsgStore.Journal (JournalMsgStore (..), JournalQueue, QStoreCfg (..), postgresQueueStore, stmQueueStore) -import Simplex.Messaging.Server.MsgStore.Types (MsgStoreClass (..), QSType (..), SQSType (..), SMSType (..), newMsgStore) -import Simplex.Messaging.Server.QueueStore.Postgres (PostgresStoreCfg (..), batchInsertQueues, foldQueueRecs) -import Simplex.Messaging.Server.QueueStore.Types -import Simplex.Messaging.Server.StoreLog (logCreateQueue, openWriteStoreLog) +import Simplex.Messaging.Server.Main.Init +import Simplex.Messaging.Server.MsgStore.Journal (JournalMsgStore (..), QStoreCfg (..), stmQueueStore) +import Simplex.Messaging.Server.MsgStore.Types (MsgStoreClass (..), SQSType (..), SMSType (..), newMsgStore) +import Simplex.Messaging.Server.QueueStore.Postgres.Config import Simplex.Messaging.Server.StoreLog.ReadWrite (readQueueStore) import Simplex.Messaging.Transport (simplexMQVersion, supportedProxyClientSMPRelayVRange, supportedServerSMPRelayVRange) -import Simplex.Messaging.Transport.Client (SocksProxy, TransportHost (..), defaultSocksProxy) +import Simplex.Messaging.Transport.Client (TransportHost (..), defaultSocksProxy) import Simplex.Messaging.Transport.Server (ServerCredentials (..), TransportServerConfig (..), defaultTransportServerConfig) -import Simplex.Messaging.Util (eitherToMaybe, ifM, safeDecodeUtf8, tshow) -import System.Directory (createDirectoryIfMissing, doesDirectoryExist, doesFileExist, renameFile) +import Simplex.Messaging.Util (eitherToMaybe, ifM) +import System.Directory (createDirectoryIfMissing, doesDirectoryExist, doesFileExist) import System.Exit (exitFailure) import System.FilePath (combine) import System.IO (BufferMode (..), hSetBuffering, stderr, stdout) import Text.Read (readMaybe) +#if defined(dbServerPostgres) +import Data.Semigroup (Sum (..)) +import Simplex.Messaging.Agent.Store.Postgres (checkSchemaExists) +import Simplex.Messaging.Server.MsgStore.Journal (JournalQueue) +import Simplex.Messaging.Server.MsgStore.Types (QSType (..)) +import Simplex.Messaging.Server.MsgStore.Journal (postgresQueueStore) +import Simplex.Messaging.Server.QueueStore.Postgres (batchInsertQueues, foldQueueRecs) +import Simplex.Messaging.Server.QueueStore.Types +import Simplex.Messaging.Server.StoreLog (logCreateQueue, openWriteStoreLog) +import System.Directory (renameFile) +#endif + smpServerCLI :: FilePath -> FilePath -> IO () smpServerCLI = smpServerCLI_ (\_ _ _ -> pure ()) (\_ -> pure ()) (\_ -> error "attachStaticFiles not available") @@ -129,14 +136,20 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath = ("WARNING: journal directory " <> storeMsgsJournalDir <> " will be exported to message log file " <> storeMsgsFilePath) "Journal not exported" ms <- newJournalMsgStore MQStoreCfg + -- TODO [postgres] in case postgres configured, queues must be read from database readQueueStore True (mkQueue ms) storeLogFile $ stmQueueStore ms exportMessages True ms storeMsgsFilePath False putStrLn "Export completed" - putStrLn $ case readStoreType ini of - Right (ASType SQSMemory SMSMemory) -> "store_messages set to `memory`, start the server." - Right (ASType SQSMemory SMSJournal) -> "store_messages set to `journal`, update it to `memory` in INI file" - Right (ASType SQSPostgres SMSJournal) -> "store_messages set to `journal`, store_queues is set to `database`.\nExport queues to store log to use memory storage for messages (`smp-server database export`)." - Left e -> e <> ", configure storage correctly" + case readStoreType ini of + Right (ASType SQSMemory SMSMemory) -> putStrLn "store_messages set to `memory`, start the server." + Right (ASType SQSMemory SMSJournal) -> putStrLn "store_messages set to `journal`, update it to `memory` in INI file" + Right (ASType SQSPostgres SMSJournal) -> +#if defined(dbServerPostgres) + 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`)." +#else + noPostgresExit +#endif + Left e -> putStrLn $ e <> ", configure storage correctly" SCDelete | not msgsDirExists -> do putStrLn $ storeMsgsJournalDir <> " directory does not exists." @@ -147,6 +160,7 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath = "Messages NOT deleted" deleteDirIfExists storeMsgsJournalDir putStrLn $ "Deleted all messages in journal " <> storeMsgsJournalDir +#if defined(dbServerPostgres) Database cmd dbOpts@DBOpts {connstr, schema} -> withIniFile $ \ini -> do schemaExists <- checkSchemaExists connstr schema storeLogExists <- doesFileExist storeLogFilePath @@ -205,6 +219,9 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath = | otherwise -> do putStrLn $ "Open database: psql " <> B.unpack connstr putStrLn $ "Delete schema: DROP SCHEMA " <> B.unpack schema <> " CASCADE;" +#else + Database {} -> noPostgresExit +#endif where withIniFile a = doesFileExist iniFile >>= \case @@ -224,7 +241,6 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath = in newMsgStore cfg iniFile = combine cfgPath "smp-server.ini" serverVersion = "SMP server v" <> simplexMQVersion - defaultServerPorts = "5223,443" executableName = "smp-server" storeLogFilePath = combine logPath "smp-server-store.log" storeMsgsFilePath = combine logPath "smp-server-messages.log" @@ -240,7 +256,6 @@ 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 - iniDBOptions :: Ini -> DBOpts iniDBOptions ini = DBOpts { connstr = either (const defaultDBConnStr) encodeUtf8 $ lookupValue "STORE_LOG" "db_connection" ini, @@ -248,20 +263,14 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath = poolSize = readIniDefault defaultDBPoolSize "STORE_LOG" "db_pool_size" ini, createSchema = False } - dbOptsIniContent :: DBOpts -> Text - dbOptsIniContent DBOpts {connstr, schema, poolSize} = - (optDisabled' (connstr == defaultDBConnStr) <> "db_connection: " <> safeDecodeUtf8 connstr <> "\n") - <> (optDisabled' (schema == defaultDBSchema) <> "db_schema: " <> safeDecodeUtf8 schema <> "\n") - <> (optDisabled' (poolSize == defaultDBPoolSize) <> "db_pool_size: " <> tshow poolSize <> "\n\n") iniDeletedTTL ini = readIniDefault (86400 * defaultDeletedTTL) "STORE_LOG" "db_deleted_ttl" ini - httpsCertFile = combine cfgPath "web.crt" - httpsKeyFile = combine cfgPath "web.key" defaultStaticPath = combine logPath "www" enableStoreLog' = settingIsOn "STORE_LOG" "enable" enableDbStoreLog' = settingIsOn "STORE_LOG" "db_store_log" - initializeServer opts@InitOptions {ip, fqdn, sourceCode = src', webStaticPath = sp', disableWeb = noWeb', scripted} - | scripted = initialize opts + initializeServer opts + | scripted opts = initialize opts | otherwise = do + let InitOptions {ip, fqdn, sourceCode = src', webStaticPath = sp', disableWeb = noWeb'} = opts putStrLn "Use `smp-server init -h` for available options." checkInitOptions opts void $ withPrompt "SMP server will be initialized (press Enter)" getLine @@ -303,7 +312,7 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath = Just "Error: passing --hosting-country requires passing --hosting" | otherwise = Nothing forM_ err_ $ \err -> putStrLn err >> exitFailure - initialize opts'@InitOptions {enableStoreLog, dbOptions, logStats, signAlgorithm, password, controlPort, socksProxy, ownDomains, sourceCode, webStaticPath, disableWeb} = do + initialize opts'@InitOptions {ip, fqdn, signAlgorithm, password, controlPort, sourceCode} = do checkInitOptions opts' clearDirIfExists cfgPath clearDirIfExists logPath @@ -315,7 +324,7 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath = controlPortPwds <- forM controlPort $ \_ -> let pwd = decodeLatin1 <$> randomBase64 18 in (,) <$> pwd <*> pwd let host = fromMaybe (if ip == "127.0.0.1" then "" else ip) fqdn srv = ProtoServerWithAuth (SMPServer [THDomainName host] "" (C.KeyHash fp)) basicAuth - T.writeFile iniFile $ iniFileContent host basicAuth controlPortPwds + T.writeFile iniFile $ iniFileContent cfgPath logPath opts' host basicAuth controlPortPwds putStrLn $ "Server initialized, please provide additional server information in " <> iniFile <> "." putStrLn $ "Run `" <> executableName <> " start` to start server." warnCAPrivateKeyFile cfgPath x509cfg @@ -326,103 +335,6 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath = ServerPassword s -> pure s SPRandom -> BasicAuth <$> randomBase64 32 randomBase64 n = strEncode <$> (atomically . C.randomBytes n =<< C.newRandom) - iniFileContent host basicAuth controlPortPwds = - informationIniContent opts' - <> "[STORE_LOG]\n\ - \# The server uses memory or PostgreSQL database for persisting queue records.\n\ - \# Use `enable: on` to use append-only log to preserve and restore queue records on restart.\n\ - \# Log is compacted on start (deleted objects are removed).\n" - <> ("enable: " <> onOff enableStoreLog <> "\n\n") - <> "# Queue storage mode: `memory` or `database` (to store queue records in PostgreSQL database).\n\ - \# `memory` - in-memory persistence, with optional append-only log (`enable: on`).\n\ - \# `database`- PostgreSQL databass (requires `store_messages: journal`).\n\ - \store_queues: memory\n\n\ - \# Database connection settings for PostgreSQL database (`store_queues: database`).\n" - <> dbOptsIniContent dbOptions - <> "# Write database changes to store log file\n\ - \# 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\ - \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" - <> ("restore_messages: " <> onOff enableStoreLog <> "\n\n") - <> "# Messages and notifications expiration periods.\n" - <> ("expire_messages_days: " <> tshow defMsgExpirationDays <> "\n") - <> "expire_messages_on_start: on\n" - <> ("expire_ntfs_hours: " <> tshow defNtfExpirationHours <> "\n\n") - <> "# Log daily server statistics to CSV file\n" - <> ("log_stats: " <> onOff logStats <> "\n\n") - <> "# Log interval for real-time Prometheus metrics\n\ - \# prometheus_interval: 300\n\n\ - \[AUTH]\n\ - \# Set new_queues option to off to completely prohibit creating new messaging queues.\n\ - \# This can be useful when you want to decommission the server, but not all connections are switched yet.\n\ - \new_queues: on\n\n\ - \# Use create_password option to enable basic auth to create new messaging queues.\n\ - \# The password should be used as part of server address in client configuration:\n\ - \# smp://fingerprint:password@host1,host2\n\ - \# The password will not be shared with the connecting contacts, you must share it only\n\ - \# with the users who you want to allow creating messaging queues on your server.\n" - <> ( let noPassword = "password to create new queues and forward messages (any printable ASCII characters without whitespace, '@', ':' and '/')" - in optDisabled basicAuth <> "create_password: " <> maybe noPassword (safeDecodeUtf8 . strEncode) basicAuth - ) - <> "\n\n" - <> (optDisabled controlPortPwds <> "control_port_admin_password: " <> maybe "" fst controlPortPwds <> "\n") - <> (optDisabled controlPortPwds <> "control_port_user_password: " <> maybe "" snd controlPortPwds <> "\n") - <> "\n\ - \[TRANSPORT]\n\ - \# Host is only used to print server address on start.\n\ - \# You can specify multiple server ports.\n" - <> ("host: " <> T.pack host <> "\n") - <> ("port: " <> T.pack defaultServerPorts <> "\n") - <> "log_tls_errors: off\n\n\ - \# Use `websockets: 443` to run websockets server in addition to plain TLS.\n\ - \# This option is deprecated and should be used for testing only.\n\ - \# , port 443 should be specified in port above\n\ - \websockets: off\n" - <> (optDisabled controlPort <> "control_port: " <> tshow (fromMaybe defaultControlPort controlPort)) - <> "\n\n\ - \[PROXY]\n\ - \# Network configuration for SMP proxy client.\n\ - \# `host_mode` can be 'public' (default) or 'onion'.\n\ - \# It defines prefferred hostname for destination servers with multiple hostnames.\n\ - \# host_mode: public\n\ - \# required_host_mode: off\n\n\ - \# The domain suffixes of the relays you operate (space-separated) to count as separate proxy statistics.\n" - <> (optDisabled ownDomains <> "own_server_domains: " <> maybe "" (safeDecodeUtf8 . strEncode) ownDomains) - <> "\n\n\ - \# SOCKS proxy port for forwarding messages to destination servers.\n\ - \# You may need a separate instance of SOCKS proxy for incoming single-hop requests.\n" - <> (optDisabled socksProxy <> "socks_proxy: " <> maybe "localhost:9050" (safeDecodeUtf8 . strEncode) socksProxy) - <> "\n\n\ - \# `socks_mode` can be 'onion' for SOCKS proxy to be used for .onion destination hosts only (default)\n\ - \# or 'always' to be used for all destination hosts (can be used if it is an .onion server).\n\ - \# socks_mode: onion\n\n\ - \# Limit number of threads a client can spawn to process proxy commands in parrallel.\n" - <> ("# client_concurrency: " <> tshow defaultProxyClientConcurrency) - <> "\n\n\ - \[INACTIVE_CLIENTS]\n\ - \# TTL and interval to check inactive clients\n\ - \disconnect: on\n" - <> ("ttl: " <> tshow (ttl defaultInactiveClientExpiration) <> "\n") - <> ("check_interval: " <> tshow (checkInterval defaultInactiveClientExpiration)) - <> "\n\n\ - \[WEB]\n\ - \# Set path to generate static mini-site for server information and qr codes/links\n" - <> ("static_path: " <> T.pack (fromMaybe defaultStaticPath webStaticPath) <> "\n\n") - <> "# Run an embedded server on this port\n\ - \# Onion sites can use any port and register it in the hidden service config.\n\ - \# Running on a port 80 may require setting process capabilities.\n\ - \# http: 8000\n\n\ - \# You can run an embedded TLS web server too if you provide port and cert and key files.\n\ - \# Not required for running relay on onion address.\n" - <> (webDisabled <> "https: 443\n") - <> (webDisabled <> "cert: " <> T.pack httpsCertFile <> "\n") - <> (webDisabled <> "key: " <> T.pack httpsKeyFile <> "\n") - where - webDisabled = if disableWeb then "# " else "" runServer startOptions ini = do hSetBuffering stdout LineBuffering hSetBuffering stderr LineBuffering @@ -607,6 +519,7 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath = | otherwise -> case qs of SQSMemory -> unless (storeLogExists) $ putStrLn $ "store_queues is `memory`, " <> storeLogFilePath <> " file will be created." +#if defined(dbServerPostgres) SQSPostgres -> do let DBOpts {connstr, schema} = iniDBOptions ini schemaExists <- checkSchemaExists connstr schema @@ -629,6 +542,9 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath = noDatabaseSchema connstr schema = do putStrLn $ "Error: store_queues is `database`, create schema " <> B.unpack schema <> " in PostgreSQL database " <> B.unpack connstr exitFailure +#else + SQSPostgres -> noPostgresExit +#endif ASType SQSMemory SMSMemory | msgsFileExists && msgsDirExists -> exitConfigureMsgStorage | msgsDirExists -> do @@ -642,10 +558,12 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath = putStrLn "Configure memory storage." exitFailure +#if defined(dbServerPostgres) exitConfigureQueueStore connstr schema = do putStrLn $ "Error: both " <> storeLogFilePath <> " file and " <> B.unpack schema <> " schema are present (database: " <> B.unpack connstr <> ")." putStrLn "Configure queue storage." exitFailure +#endif data EmbeddedWebParams = EmbeddedWebParams { webStaticPath :: FilePath, @@ -669,72 +587,6 @@ getServerSourceCode = simplexmqSource :: String simplexmqSource = "https://github.com/simplex-chat/simplexmq" -defaultDBConnStr :: ByteString -defaultDBConnStr = "postgresql://smp@/smp_server_store" - -defaultDBSchema :: ByteString -defaultDBSchema = "smp_server" - -defaultDBPoolSize :: Natural -defaultDBPoolSize = 10 - --- time to retain deleted queues in the database (days), for debugging -defaultDeletedTTL :: Int64 -defaultDeletedTTL = 21 - -defaultControlPort :: Int -defaultControlPort = 5224 - -informationIniContent :: InitOptions -> Text -informationIniContent InitOptions {sourceCode, serverInfo} = - "[INFORMATION]\n\ - \# AGPLv3 license requires that you make any source code modifications\n\ - \# available to the end users of the server.\n\ - \# LICENSE: https://github.com/simplex-chat/simplexmq/blob/stable/LICENSE\n\ - \# Include correct source code URI in case the server source code is modified in any way.\n\ - \# If any other information fields are present, source code property also MUST be present.\n\n" - <> (optDisabled sourceCode <> "source_code: " <> fromMaybe "URI" sourceCode) - <> "\n\n\ - \# Declaring all below information is optional, any of these fields can be omitted.\n\ - \\n\ - \# Server usage conditions and amendments.\n\ - \# It is recommended to use standard conditions with any amendments in a separate document.\n\ - \# usage_conditions: https://github.com/simplex-chat/simplex-chat/blob/stable/PRIVACY.md\n\ - \# condition_amendments: link\n\ - \\n\ - \# Server location and operator.\n" - <> countryStr "server" serverCountry - <> enitiyStrs "operator" operator - <> (optDisabled website <> "website: " <> fromMaybe "" website) - <> "\n\n\ - \# Administrative contacts.\n\ - \# admin_simplex: SimpleX address\n\ - \# admin_email:\n\ - \# admin_pgp:\n\ - \# admin_pgp_fingerprint:\n\ - \\n\ - \# Contacts for complaints and feedback.\n\ - \# complaints_simplex: SimpleX address\n\ - \# complaints_email:\n\ - \# complaints_pgp:\n\ - \# complaints_pgp_fingerprint:\n\ - \\n\ - \# Hosting provider.\n" - <> enitiyStrs "hosting" hosting - <> "\n\ - \# Hosting type can be `virtual`, `dedicated`, `colocation`, `owned`\n" - <> ("hosting_type: " <> maybe "virtual" (decodeLatin1 . strEncode) hostingType <> "\n\n") - where - ServerPublicInfo {operator, website, hosting, hostingType, serverCountry} = serverInfo - countryStr optName country = optDisabled country <> optName <> "_country: " <> fromMaybe "ISO-3166 2-letter code" country <> "\n" - enitiyStrs optName entity = - optDisabled entity - <> optName - <> ": " - <> maybe "entity (organization or person name)" name entity - <> "\n" - <> countryStr optName (country =<< entity) - serverPublicInfo :: Ini -> Maybe ServerPublicInfo serverPublicInfo ini = serverInfo <$!> infoValue "source_code" where @@ -767,14 +619,6 @@ serverPublicInfo ini = serverInfo <$!> infoValue "source_code" (Nothing, Nothing, _, Nothing) -> Nothing (_, _, pkURI, pkFingerprint) -> Just ServerContactAddress {simplex, email, pgp = PGPKey <$> pkURI <*> pkFingerprint} -optDisabled :: Maybe a -> Text -optDisabled = optDisabled' . isNothing -{-# INLINE optDisabled #-} - -optDisabled' :: Bool -> Text -optDisabled' cond = if cond then "# " else "" -{-# INLINE optDisabled' #-} - validCountryValue :: String -> String -> Either String Text validCountryValue field s | length s == 2 && all (\c -> isAscii c && isAlpha c) s = Right $ T.pack $ map toUpper s @@ -797,30 +641,6 @@ data CliCommand data StoreCmd = SCImport | SCExport | SCDelete -data InitOptions = InitOptions - { enableStoreLog :: Bool, - dbOptions :: DBOpts, - logStats :: Bool, - signAlgorithm :: SignAlgorithm, - ip :: HostName, - fqdn :: Maybe HostName, - password :: Maybe ServerPassword, - controlPort :: Maybe Int, - socksProxy :: Maybe SocksProxy, - ownDomains :: Maybe (L.NonEmpty TransportHost), - sourceCode :: Maybe Text, - serverInfo :: ServerPublicInfo, - operatorCountry :: Maybe Text, - hostingCountry :: Maybe Text, - webStaticPath :: Maybe FilePath, - disableWeb :: Bool, - scripted :: Bool - } - deriving (Show) - -data ServerPassword = ServerPassword BasicAuth | SPRandom - deriving (Show) - cliCommandP :: FilePath -> FilePath -> FilePath -> Parser CliCommand cliCommandP cfgPath logPath iniFile = hsubparser diff --git a/src/Simplex/Messaging/Server/Main/Init.hs b/src/Simplex/Messaging/Server/Main/Init.hs new file mode 100644 index 000000000..4c218c5cc --- /dev/null +++ b/src/Simplex/Messaging/Server/Main/Init.hs @@ -0,0 +1,230 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} + +module Simplex.Messaging.Server.Main.Init where + +import Data.ByteString.Char8 (ByteString) +import Data.Int (Int64) +import qualified Data.List.NonEmpty as L +import Data.Maybe (fromMaybe, isNothing) +import Numeric.Natural (Natural) +import Data.Text (Text) +import qualified Data.Text as T +import Data.Text.Encoding (decodeLatin1) +import Network.Socket (HostName) +import Simplex.Messaging.Agent.Store.Postgres.Options (DBOpts (..)) +import Simplex.Messaging.Encoding.String +import Simplex.Messaging.Protocol (BasicAuth) +import Simplex.Messaging.Server.CLI (SignAlgorithm, onOff) +import Simplex.Messaging.Server.Env.STM +import Simplex.Messaging.Server.Expiration (ExpirationConfig (..)) +import Simplex.Messaging.Server.Information (Entity (..), ServerPublicInfo (..)) +import Simplex.Messaging.Transport.Client (SocksProxy, TransportHost) +import Simplex.Messaging.Util (safeDecodeUtf8, tshow) +import System.FilePath (()) + +defaultControlPort :: Int +defaultControlPort = 5224 + +defaultDBConnStr :: ByteString +defaultDBConnStr = "postgresql://smp@/smp_server_store" + +defaultDBSchema :: ByteString +defaultDBSchema = "smp_server" + +defaultDBPoolSize :: Natural +defaultDBPoolSize = 10 + +-- time to retain deleted queues in the database (days), for debugging +defaultDeletedTTL :: Int64 +defaultDeletedTTL = 21 + +data InitOptions = InitOptions + { enableStoreLog :: Bool, + dbOptions :: DBOpts, + logStats :: Bool, + signAlgorithm :: SignAlgorithm, + ip :: HostName, + fqdn :: Maybe HostName, + password :: Maybe ServerPassword, + controlPort :: Maybe Int, + socksProxy :: Maybe SocksProxy, + ownDomains :: Maybe (L.NonEmpty TransportHost), + sourceCode :: Maybe Text, + serverInfo :: ServerPublicInfo, + operatorCountry :: Maybe Text, + hostingCountry :: Maybe Text, + webStaticPath :: Maybe FilePath, + disableWeb :: Bool, + scripted :: Bool + } + deriving (Show) + +data ServerPassword = ServerPassword BasicAuth | SPRandom + deriving (Show) + +iniFileContent :: FilePath -> FilePath -> InitOptions -> HostName -> Maybe BasicAuth -> Maybe (Text, Text) -> Text +iniFileContent cfgPath logPath opts host basicAuth controlPortPwds = + informationIniContent opts + <> "[STORE_LOG]\n\ + \# The server uses memory or PostgreSQL database for persisting queue records.\n\ + \# Use `enable: on` to use append-only log to preserve and restore queue records on restart.\n\ + \# Log is compacted on start (deleted objects are removed).\n" + <> ("enable: " <> onOff enableStoreLog <> "\n\n") + <> "# Queue storage mode: `memory` or `database` (to store queue records in PostgreSQL database).\n\ + \# `memory` - in-memory persistence, with optional append-only log (`enable: on`).\n\ + \# `database`- PostgreSQL databass (requires `store_messages: journal`).\n\ + \store_queues: memory\n\n\ + \# Database connection settings for PostgreSQL database (`store_queues: database`).\n" + <> (optDisabled' (connstr == defaultDBConnStr) <> "db_connection: " <> safeDecodeUtf8 connstr <> "\n") + <> (optDisabled' (schema == defaultDBSchema) <> "db_schema: " <> safeDecodeUtf8 schema <> "\n") + <> (optDisabled' (poolSize == defaultDBPoolSize) <> "db_pool_size: " <> tshow poolSize <> "\n\n") + <> "# Write database changes to store log file\n\ + \# 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\ + \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" + <> ("restore_messages: " <> onOff enableStoreLog <> "\n\n") + <> "# Messages and notifications expiration periods.\n" + <> ("expire_messages_days: " <> tshow defMsgExpirationDays <> "\n") + <> "expire_messages_on_start: on\n" + <> ("expire_ntfs_hours: " <> tshow defNtfExpirationHours <> "\n\n") + <> "# Log daily server statistics to CSV file\n" + <> ("log_stats: " <> onOff logStats <> "\n\n") + <> "# Log interval for real-time Prometheus metrics\n\ + \# prometheus_interval: 300\n\n\ + \[AUTH]\n\ + \# Set new_queues option to off to completely prohibit creating new messaging queues.\n\ + \# This can be useful when you want to decommission the server, but not all connections are switched yet.\n\ + \new_queues: on\n\n\ + \# Use create_password option to enable basic auth to create new messaging queues.\n\ + \# The password should be used as part of server address in client configuration:\n\ + \# smp://fingerprint:password@host1,host2\n\ + \# The password will not be shared with the connecting contacts, you must share it only\n\ + \# with the users who you want to allow creating messaging queues on your server.\n" + <> ( let noPassword = "password to create new queues and forward messages (any printable ASCII characters without whitespace, '@', ':' and '/')" + in optDisabled basicAuth <> "create_password: " <> maybe noPassword (safeDecodeUtf8 . strEncode) basicAuth + ) + <> "\n\n" + <> (optDisabled controlPortPwds <> "control_port_admin_password: " <> maybe "" fst controlPortPwds <> "\n") + <> (optDisabled controlPortPwds <> "control_port_user_password: " <> maybe "" snd controlPortPwds <> "\n") + <> "\n\ + \[TRANSPORT]\n\ + \# Host is only used to print server address on start.\n\ + \# You can specify multiple server ports.\n" + <> ("host: " <> T.pack host <> "\n") + <> ("port: " <> defaultServerPorts <> "\n") + <> "log_tls_errors: off\n\n\ + \# Use `websockets: 443` to run websockets server in addition to plain TLS.\n\ + \# This option is deprecated and should be used for testing only.\n\ + \# , port 443 should be specified in port above\n\ + \websockets: off\n" + <> (optDisabled controlPort <> "control_port: " <> tshow (fromMaybe defaultControlPort controlPort)) + <> "\n\n\ + \[PROXY]\n\ + \# Network configuration for SMP proxy client.\n\ + \# `host_mode` can be 'public' (default) or 'onion'.\n\ + \# It defines prefferred hostname for destination servers with multiple hostnames.\n\ + \# host_mode: public\n\ + \# required_host_mode: off\n\n\ + \# The domain suffixes of the relays you operate (space-separated) to count as separate proxy statistics.\n" + <> (optDisabled ownDomains <> "own_server_domains: " <> maybe "" (safeDecodeUtf8 . strEncode) ownDomains) + <> "\n\n\ + \# SOCKS proxy port for forwarding messages to destination servers.\n\ + \# You may need a separate instance of SOCKS proxy for incoming single-hop requests.\n" + <> (optDisabled socksProxy <> "socks_proxy: " <> maybe "localhost:9050" (safeDecodeUtf8 . strEncode) socksProxy) + <> "\n\n\ + \# `socks_mode` can be 'onion' for SOCKS proxy to be used for .onion destination hosts only (default)\n\ + \# or 'always' to be used for all destination hosts (can be used if it is an .onion server).\n\ + \# socks_mode: onion\n\n\ + \# Limit number of threads a client can spawn to process proxy commands in parrallel.\n" + <> ("# client_concurrency: " <> tshow defaultProxyClientConcurrency) + <> "\n\n\ + \[INACTIVE_CLIENTS]\n\ + \# TTL and interval to check inactive clients\n\ + \disconnect: on\n" + <> ("ttl: " <> tshow (ttl defaultInactiveClientExpiration) <> "\n") + <> ("check_interval: " <> tshow (checkInterval defaultInactiveClientExpiration)) + <> "\n\n\ + \[WEB]\n\ + \# Set path to generate static mini-site for server information and qr codes/links\n" + <> ("static_path: " <> T.pack (fromMaybe defaultStaticPath webStaticPath) <> "\n\n") + <> "# Run an embedded server on this port\n\ + \# Onion sites can use any port and register it in the hidden service config.\n\ + \# Running on a port 80 may require setting process capabilities.\n\ + \# http: 8000\n\n\ + \# You can run an embedded TLS web server too if you provide port and cert and key files.\n\ + \# Not required for running relay on onion address.\n" + <> (webDisabled <> "https: 443\n") + <> (webDisabled <> "cert: " <> T.pack httpsCertFile <> "\n") + <> (webDisabled <> "key: " <> T.pack httpsKeyFile <> "\n") + where + InitOptions {enableStoreLog, dbOptions, socksProxy, ownDomains, controlPort, webStaticPath, disableWeb, logStats} = opts + DBOpts {connstr, schema, poolSize} = dbOptions + defaultServerPorts = "5223,443" + defaultStaticPath = logPath "www" + httpsCertFile = cfgPath "web.crt" + httpsKeyFile = cfgPath "web.key" + webDisabled = if disableWeb then "# " else "" + +informationIniContent :: InitOptions -> Text +informationIniContent InitOptions {sourceCode, serverInfo} = + "[INFORMATION]\n\ + \# AGPLv3 license requires that you make any source code modifications\n\ + \# available to the end users of the server.\n\ + \# LICENSE: https://github.com/simplex-chat/simplexmq/blob/stable/LICENSE\n\ + \# Include correct source code URI in case the server source code is modified in any way.\n\ + \# If any other information fields are present, source code property also MUST be present.\n\n" + <> (optDisabled sourceCode <> "source_code: " <> fromMaybe "URI" sourceCode) + <> "\n\n\ + \# Declaring all below information is optional, any of these fields can be omitted.\n\ + \\n\ + \# Server usage conditions and amendments.\n\ + \# It is recommended to use standard conditions with any amendments in a separate document.\n\ + \# usage_conditions: https://github.com/simplex-chat/simplex-chat/blob/stable/PRIVACY.md\n\ + \# condition_amendments: link\n\ + \\n\ + \# Server location and operator.\n" + <> countryStr "server" serverCountry + <> enitiyStrs "operator" operator + <> (optDisabled website <> "website: " <> fromMaybe "" website) + <> "\n\n\ + \# Administrative contacts.\n\ + \# admin_simplex: SimpleX address\n\ + \# admin_email:\n\ + \# admin_pgp:\n\ + \# admin_pgp_fingerprint:\n\ + \\n\ + \# Contacts for complaints and feedback.\n\ + \# complaints_simplex: SimpleX address\n\ + \# complaints_email:\n\ + \# complaints_pgp:\n\ + \# complaints_pgp_fingerprint:\n\ + \\n\ + \# Hosting provider.\n" + <> enitiyStrs "hosting" hosting + <> "\n\ + \# Hosting type can be `virtual`, `dedicated`, `colocation`, `owned`\n" + <> ("hosting_type: " <> maybe "virtual" (decodeLatin1 . strEncode) hostingType <> "\n\n") + where + ServerPublicInfo {operator, website, hosting, hostingType, serverCountry} = serverInfo + countryStr optName country = optDisabled country <> optName <> "_country: " <> fromMaybe "ISO-3166 2-letter code" country <> "\n" + enitiyStrs optName entity = + optDisabled entity + <> optName + <> ": " + <> maybe "entity (organization or person name)" name entity + <> "\n" + <> countryStr optName (country =<< entity) + +optDisabled :: Maybe a -> Text +optDisabled = optDisabled' . isNothing +{-# INLINE optDisabled #-} + +optDisabled' :: Bool -> Text +optDisabled' cond = if cond then "# " else "" +{-# INLINE optDisabled' #-} diff --git a/src/Simplex/Messaging/Server/MsgStore/Journal.hs b/src/Simplex/Messaging/Server/MsgStore/Journal.hs index 369194030..0382089a8 100644 --- a/src/Simplex/Messaging/Server/MsgStore/Journal.hs +++ b/src/Simplex/Messaging/Server/MsgStore/Journal.hs @@ -1,4 +1,5 @@ {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE DuplicateRecordFields #-} @@ -43,7 +44,9 @@ module Simplex.Messaging.Server.MsgStore.Journal journalFilePath, logFileExt, stmQueueStore, +#if defined(dbServerPostgres) postgresQueueStore, +#endif ) where @@ -73,7 +76,9 @@ import Simplex.Messaging.Protocol import Simplex.Messaging.Server.MsgStore.Journal.SharedLock import Simplex.Messaging.Server.MsgStore.Types import Simplex.Messaging.Server.QueueStore +#if defined(dbServerPostgres) import Simplex.Messaging.Server.QueueStore.Postgres +#endif import Simplex.Messaging.Server.QueueStore.STM import Simplex.Messaging.Server.QueueStore.Types import Simplex.Messaging.TMap (TMap) @@ -96,25 +101,33 @@ data JournalMsgStore s = JournalMsgStore data QStore (s :: QSType) where MQStore :: QStoreType 'QSMemory -> QStore 'QSMemory +#if defined(dbServerPostgres) PQStore :: QStoreType 'QSPostgres -> QStore 'QSPostgres +#endif type family QStoreType s where QStoreType 'QSMemory = STMQueueStore (JournalQueue 'QSMemory) +#if defined(dbServerPostgres) QStoreType 'QSPostgres = PostgresQueueStore (JournalQueue 'QSPostgres) +#endif withQS :: (QueueStoreClass (JournalQueue s) (QStoreType s) => QStoreType s -> r) -> QStore s -> r withQS f = \case MQStore st -> f st +#if defined(dbServerPostgres) PQStore st -> f st +#endif {-# INLINE withQS #-} stmQueueStore :: JournalMsgStore 'QSMemory -> STMQueueStore (JournalQueue 'QSMemory) stmQueueStore st = case queueStore_ st of MQStore st' -> st' +#if defined(dbServerPostgres) postgresQueueStore :: JournalMsgStore 'QSPostgres -> PostgresQueueStore (JournalQueue 'QSPostgres) postgresQueueStore st = case queueStore_ st of PQStore st' -> st' +#endif data JournalStoreConfig s = JournalStoreConfig { storePath :: FilePath, @@ -136,7 +149,9 @@ data JournalStoreConfig s = JournalStoreConfig data QStoreCfg s where MQStoreCfg :: QStoreCfg 'QSMemory +#if defined(dbServerPostgres) PQStoreCfg :: PostgresStoreCfg -> QStoreCfg 'QSPostgres +#endif data JournalQueue (s :: QSType) = JournalQueue { recipientId' :: RecipientId, @@ -290,7 +305,9 @@ instance QueueStoreClass (JournalQueue s) (QStore s) where newQueueStore :: QStoreCfg s -> IO (QStore s) newQueueStore = \case MQStoreCfg -> MQStore <$> newQueueStore @(JournalQueue s) () +#if defined(dbServerPostgres) PQStoreCfg cfg -> PQStore <$> newQueueStore @(JournalQueue s) cfg +#endif closeQueueStore = withQS (closeQueueStore @(JournalQueue s)) {-# INLINE closeQueueStore #-} @@ -321,9 +338,11 @@ instance QueueStoreClass (JournalQueue s) (QStore s) where deleteStoreQueue = withQS deleteStoreQueue {-# INLINE deleteStoreQueue #-} +#if defined(dbServerPostgres) mkTempQueue :: JournalMsgStore s -> RecipientId -> QueueRec -> IO (JournalQueue s) mkTempQueue ms rId qr = createLockIO >>= makeQueue_ ms rId qr {-# INLINE mkTempQueue #-} +#endif makeQueue_ :: JournalMsgStore s -> RecipientId -> QueueRec -> Lock -> IO (JournalQueue s) makeQueue_ JournalMsgStore {sharedLock} rId qr queueLock = do @@ -373,7 +392,9 @@ instance MsgStoreClass (JournalMsgStore s) where unsafeWithAllMsgQueues :: Monoid a => Bool -> JournalMsgStore s -> (JournalQueue s -> IO a) -> IO a unsafeWithAllMsgQueues tty ms action = case queueStore_ ms of MQStore st -> withLoadedQueues st run +#if defined(dbServerPostgres) PQStore st -> foldQueueRecs tty st $ uncurry (mkTempQueue ms) >=> run +#endif where run q = do r <- action q @@ -382,15 +403,18 @@ instance MsgStoreClass (JournalMsgStore s) where -- This function is concurrency safe, it is used to expire queues. withAllMsgQueues :: forall a. Monoid a => Bool -> String -> JournalMsgStore s -> (JournalQueue s -> StoreIO s a) -> IO a - withAllMsgQueues tty op ms@JournalMsgStore {queueLocks, sharedLock} action = case queueStore_ ms of + withAllMsgQueues tty op ms action = case queueStore_ ms of MQStore st -> withLoadedQueues st $ \q -> run $ isolateQueue q op $ action q - PQStore st -> +#if defined(dbServerPostgres) + PQStore st -> do + let JournalMsgStore {queueLocks, sharedLock} = ms foldQueueRecs tty st $ \(rId, qr) -> do q <- mkTempQueue ms rId qr withSharedWaitLock rId queueLocks sharedLock $ run $ tryStore' op rId $ unStoreIO $ action q +#endif where run :: ExceptT ErrorType IO a -> IO a run = fmap (fromRight mempty) . runExceptT diff --git a/src/Simplex/Messaging/Server/QueueStore.hs b/src/Simplex/Messaging/Server/QueueStore.hs index 476f4936b..f4c2f108e 100644 --- a/src/Simplex/Messaging/Server/QueueStore.hs +++ b/src/Simplex/Messaging/Server/QueueStore.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} @@ -12,14 +13,16 @@ module Simplex.Messaging.Server.QueueStore where import Control.Applicative ((<|>)) import Data.Functor (($>)) import Data.Int (Int64) -import Data.Text.Encoding (decodeLatin1, encodeUtf8) import Data.Time.Clock.System (SystemTime (..), getSystemTime) +import Simplex.Messaging.Encoding.String +import Simplex.Messaging.Protocol +#if defined(dbServerPostgres) +import Data.Text.Encoding (decodeLatin1, encodeUtf8) import Database.PostgreSQL.Simple.FromField (FromField (..)) import Database.PostgreSQL.Simple.ToField (ToField (..)) import Simplex.Messaging.Agent.Store.Postgres.DB (fromTextField_) -import Simplex.Messaging.Encoding.String -import Simplex.Messaging.Protocol import Simplex.Messaging.Util (eitherToMaybe) +#endif data QueueRec = QueueRec { recipientKey :: !RcvPublicAuthKey, @@ -62,13 +65,17 @@ instance StrEncoding ServerEntityStatus where <|> "blocked," *> (EntityBlocked <$> strP) <|> "off" $> EntityOff +#if defined(dbServerPostgres) instance FromField ServerEntityStatus where fromField = fromTextField_ $ eitherToMaybe . strDecode . encodeUtf8 instance ToField ServerEntityStatus where toField = toField . decodeLatin1 . strEncode +#endif newtype RoundedSystemTime = RoundedSystemTime Int64 deriving (Eq, Ord, Show) +#if defined(dbServerPostgres) deriving newtype (FromField, ToField) +#endif instance StrEncoding RoundedSystemTime where strEncode (RoundedSystemTime t) = strEncode t diff --git a/src/Simplex/Messaging/Server/QueueStore/Postgres.hs b/src/Simplex/Messaging/Server/QueueStore/Postgres.hs index 0b6216b35..3c9bbbcd8 100644 --- a/src/Simplex/Messaging/Server/QueueStore/Postgres.hs +++ b/src/Simplex/Messaging/Server/QueueStore/Postgres.hs @@ -51,9 +51,9 @@ import Simplex.Messaging.Agent.Client (withLockMap) import Simplex.Messaging.Agent.Lock (Lock) import Simplex.Messaging.Agent.Store.Postgres (createDBStore, closeDBStore) import Simplex.Messaging.Agent.Store.Postgres.Common -import Simplex.Messaging.Agent.Store.Shared (MigrationConfirmation) import Simplex.Messaging.Protocol import Simplex.Messaging.Server.QueueStore +import Simplex.Messaging.Server.QueueStore.Postgres.Config import Simplex.Messaging.Server.QueueStore.Postgres.Migrations (serverMigrations) import Simplex.Messaging.Server.QueueStore.STM (readQueueRecIO) import Simplex.Messaging.Server.QueueStore.Types @@ -64,6 +64,7 @@ import Simplex.Messaging.Util (firstRow, ifM, tshow, (<$$>)) import System.Exit (exitFailure) import System.IO (IOMode (..), hFlush, stdout) import UnliftIO.STM + #if !defined(dbPostgres) import Simplex.Messaging.Agent.Store.Postgres.DB (blobFieldDecoder) import qualified Simplex.Messaging.Crypto as C @@ -83,13 +84,6 @@ data PostgresQueueStore q = PostgresQueueStore deletedTTL :: Int64 } -data PostgresStoreCfg = PostgresStoreCfg - { dbOpts :: DBOpts, - dbStoreLogPath :: Maybe FilePath, - confirmMigrations :: MigrationConfirmation, - deletedTTL :: Int64 - } - instance StoreQueueClass q => QueueStoreClass q (PostgresQueueStore q) where type QueueStoreCfg (PostgresQueueStore q) = PostgresStoreCfg diff --git a/src/Simplex/Messaging/Server/QueueStore/Postgres/Config.hs b/src/Simplex/Messaging/Server/QueueStore/Postgres/Config.hs new file mode 100644 index 000000000..55b740220 --- /dev/null +++ b/src/Simplex/Messaging/Server/QueueStore/Postgres/Config.hs @@ -0,0 +1,12 @@ +module Simplex.Messaging.Server.QueueStore.Postgres.Config where + +import Data.Int (Int64) +import Simplex.Messaging.Agent.Store.Postgres.Options (DBOpts) +import Simplex.Messaging.Agent.Store.Shared (MigrationConfirmation) + +data PostgresStoreCfg = PostgresStoreCfg + { dbOpts :: DBOpts, + dbStoreLogPath :: Maybe FilePath, + confirmMigrations :: MigrationConfirmation, + deletedTTL :: Int64 + } diff --git a/tests/Fixtures.hs b/tests/Fixtures.hs index d8c7c5cc1..2360a7ba6 100644 --- a/tests/Fixtures.hs +++ b/tests/Fixtures.hs @@ -1,14 +1,10 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} module Fixtures where -#if defined(dbPostgres) import Data.ByteString (ByteString) import Database.PostgreSQL.Simple (ConnectInfo (..), defaultConnectInfo) -#endif -#if defined(dbPostgres) testDBConnstr :: ByteString testDBConnstr = "postgresql://test_agent_user@/test_agent_db" @@ -18,4 +14,3 @@ testDBConnectInfo = connectUser = "test_agent_user", connectDatabase = "test_agent_db" } -#endif diff --git a/tests/SMPClient.hs b/tests/SMPClient.hs index 2eb3fe17b..e03aa051b 100644 --- a/tests/SMPClient.hs +++ b/tests/SMPClient.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} @@ -16,9 +17,8 @@ module SMPClient where import Control.Monad.Except (runExceptT) import Data.ByteString.Char8 (ByteString) import Data.List.NonEmpty (NonEmpty) -import Database.PostgreSQL.Simple (ConnectInfo (..), defaultConnectInfo) import Network.Socket -import Simplex.Messaging.Agent.Store.Postgres.Common (DBOpts (..)) +import Simplex.Messaging.Agent.Store.Postgres.Options (DBOpts (..)) import Simplex.Messaging.Agent.Store.Shared (MigrationConfirmation (..)) import Simplex.Messaging.Client (ProtocolClientConfig (..), chooseTransportHost, defaultNetworkConfig) import Simplex.Messaging.Client.Agent (SMPClientAgentConfig (..), defaultSMPClientAgentConfig) @@ -28,7 +28,7 @@ import Simplex.Messaging.Protocol import Simplex.Messaging.Server (runSMPServerBlocking) import Simplex.Messaging.Server.Env.STM import Simplex.Messaging.Server.MsgStore.Types (SMSType (..), SQSType (..)) -import Simplex.Messaging.Server.QueueStore.Postgres (PostgresStoreCfg (..)) +import Simplex.Messaging.Server.QueueStore.Postgres.Config (PostgresStoreCfg (..)) import Simplex.Messaging.Transport import Simplex.Messaging.Transport.Client import qualified Simplex.Messaging.Transport.Client as Client @@ -44,6 +44,10 @@ import UnliftIO.STM (TMVar, atomically, newEmptyTMVarIO, putTMVar, takeTMVar) import UnliftIO.Timeout (timeout) import Util +#if defined(dbServerPostgres) +import Database.PostgreSQL.Simple (ConnectInfo (..), defaultConnectInfo) +#endif + testHost :: NonEmpty TransportHost testHost = "localhost" @@ -80,12 +84,14 @@ testStoreDBOpts2 = testStoreDBOpts {schema = "smp_server2"} testServerDBConnstr :: ByteString testServerDBConnstr = "postgresql://test_server_user@/test_server_db" +#if defined(dbServerPostgres) testServerDBConnectInfo :: ConnectInfo testServerDBConnectInfo = defaultConnectInfo { connectUser = "test_server_user", connectDatabase = "test_server_db" } +#endif testStoreMsgsFile :: FilePath testStoreMsgsFile = "tests/tmp/smp-server-messages.log" @@ -146,9 +152,6 @@ testSMPClient_ host port vr client = do cfg :: ServerConfig cfg = cfgMS (ASType SQSMemory SMSJournal) -cfgDB :: ServerConfig -cfgDB = cfgMS (ASType SQSPostgres SMSJournal) - cfgJ2 :: ServerConfig cfgJ2 = journalCfg cfg testStoreLogFile2 testStoreMsgsDir2 diff --git a/tests/Test.hs b/tests/Test.hs index c3322b24e..14007eed8 100644 --- a/tests/Test.hs +++ b/tests/Test.hs @@ -23,7 +23,6 @@ import GHC.IO.Exception (IOException (..)) import qualified GHC.IO.Exception as IOException import NtfServerTests (ntfServerTests) import RemoteControl (remoteControlTests) -import SMPClient (testServerDBConnectInfo) import SMPProxyTests (smpProxyTests) import ServerTests import Simplex.Messaging.Server.Env.STM (AStoreType (..)) @@ -33,16 +32,25 @@ import Simplex.Messaging.Transport (TLS, Transport (..)) import System.Directory (createDirectoryIfMissing, removeDirectoryRecursive) import System.Environment (setEnv) import Test.Hspec -import Util (postgressBracket) import XFTPAgent import XFTPCLI import XFTPServerTests (xftpServerTests) + #if defined(dbPostgres) import Fixtures #else import AgentTests.SchemaDump (schemaDumpTest) #endif +#if defined(dbServerPostgres) +import SMPClient (testServerDBConnectInfo) +#endif + +#if defined(dbPostgres) || defined(dbServerPostgres) +import Database.PostgreSQL.Simple (ConnectInfo (..)) +import Simplex.Messaging.Agent.Store.Postgres.Util (createDBAndUserIfNotExists, dropDatabaseAndUser) +#endif + logCfg :: LogConfig logCfg = LogConfig {lc_file = Nothing, lc_stderr = True} @@ -75,11 +83,12 @@ main = do describe "Store log tests" storeLogTests describe "TRcvQueues tests" tRcvQueuesTests describe "Util tests" utilTests +#if defined(dbServerPostgres) aroundAll_ (postgressBracket testServerDBConnectInfo) - -- TODO [postgres] fix store log tests $ describe "SMP server via TLS, postgres+jornal message store" $ do describe "SMP syntax" $ serverSyntaxTests (transport @TLS) before (pure (transport @TLS, ASType SQSPostgres SMSJournal)) serverTests +#endif describe "SMP server via TLS, jornal message store" $ do describe "SMP syntax" $ serverSyntaxTests (transport @TLS) before (pure (transport @TLS, ASType SQSMemory SMSJournal)) serverTests @@ -89,10 +98,12 @@ main = do -- describe "SMP syntax" $ serverSyntaxTests (transport @WS) -- before (pure (transport @WS, ASType SQSMemory SMSJournal)) serverTests describe "Notifications server" $ ntfServerTests (transport @TLS) +#if defined(dbServerPostgres) aroundAll_ (postgressBracket testServerDBConnectInfo) $ do describe "SMP client agent, postgres+jornal message store" $ agentTests (transport @TLS, ASType SQSPostgres SMSJournal) describe "SMP proxy, postgres+jornal message store" $ before (pure $ ASType SQSPostgres SMSJournal) smpProxyTests +#endif describe "SMP client agent, jornal message store" $ agentTests (transport @TLS, ASType SQSMemory SMSJournal) describe "SMP proxy, jornal message store" $ before (pure $ ASType SQSMemory SMSJournal) smpProxyTests @@ -113,3 +124,11 @@ eventuallyRemove path retries = case retries of _ -> E.throwIO ioe where action = removeDirectoryRecursive path + +#if defined(dbPostgres) || defined(dbServerPostgres) +postgressBracket :: ConnectInfo -> IO a -> IO a +postgressBracket connInfo = + E.bracket_ + (dropDatabaseAndUser connInfo >> createDBAndUserIfNotExists connInfo) + (dropDatabaseAndUser connInfo) +#endif diff --git a/tests/Util.hs b/tests/Util.hs index 2d2c7b089..0ad371b69 100644 --- a/tests/Util.hs +++ b/tests/Util.hs @@ -1,12 +1,9 @@ module Util where -import qualified Control.Exception as E import Control.Monad (replicateM, when) import Data.Either (partitionEithers) import Data.List (tails) -import Database.PostgreSQL.Simple (ConnectInfo (..)) import GHC.Conc (getNumCapabilities, getNumProcessors, setNumCapabilities) -import Simplex.Messaging.Agent.Store.Postgres.Util (createDBAndUserIfNotExists, dropDatabaseAndUser) import System.Directory (doesFileExist, removeFile) import Test.Hspec import UnliftIO @@ -35,9 +32,3 @@ removeFileIfExists :: FilePath -> IO () removeFileIfExists filePath = do fileExists <- doesFileExist filePath when fileExists $ removeFile filePath - -postgressBracket :: ConnectInfo -> IO a -> IO a -postgressBracket connInfo = - E.bracket_ - (dropDatabaseAndUser connInfo >> createDBAndUserIfNotExists connInfo) - (dropDatabaseAndUser connInfo) From f4b55bfc0c6cb3e10a02d4403602843d573f31df Mon Sep 17 00:00:00 2001 From: Evgeny Date: Sun, 16 Mar 2025 18:47:02 +0000 Subject: [PATCH 12/14] smp server: CLI option to compact store log with PostgreSQL database (#1484) * smp server: CLI option to compact store log with PostgreSQL database * version * fix test --- simplexmq.cabal | 2 +- src/Simplex/Messaging/Server/Env/STM.hs | 16 ++++++++++++++-- src/Simplex/Messaging/Server/Main.hs | 8 +++++++- src/Simplex/Messaging/Server/QueueStore/STM.hs | 6 +++++- tests/CoreTests/MsgStoreTests.hs | 8 ++++---- tests/SMPClient.hs | 2 +- 6 files changed, 32 insertions(+), 10 deletions(-) diff --git a/simplexmq.cabal b/simplexmq.cabal index 6bbf363bb..5cd28a1f1 100644 --- a/simplexmq.cabal +++ b/simplexmq.cabal @@ -1,7 +1,7 @@ cabal-version: 1.12 name: simplexmq -version: 6.3.0.8 +version: 6.3.0.805 synopsis: SimpleXMQ message broker description: This package includes <./docs/Simplex-Messaging-Server.html server>, <./docs/Simplex-Messaging-Client.html client> and diff --git a/src/Simplex/Messaging/Server/Env/STM.hs b/src/Simplex/Messaging/Server/Env/STM.hs index 929ea7e64..160697feb 100644 --- a/src/Simplex/Messaging/Server/Env/STM.hs +++ b/src/Simplex/Messaging/Server/Env/STM.hs @@ -135,6 +135,7 @@ data ServerConfig = ServerConfig data StartOptions = StartOptions { maintenance :: Bool, + compactLog :: Bool, skipWarnings :: Bool, confirmMigrations :: MigrationConfirmation } @@ -331,7 +332,7 @@ newEnv config@ServerConfig {smpCredentials, httpCredentials, serverStoreCfg, smp ASSCfg qt mt (SSCMemory storePaths_) -> do let storePath = storeMsgsFile =<< storePaths_ ms <- newMsgStore STMStoreConfig {storePath, quota = msgQueueQuota} - forM_ storePaths_ $ \StorePaths {storeLogFile = f} -> loadStoreLog (mkQueue ms) f $ queueStore ms + forM_ storePaths_ $ \StorePaths {storeLogFile = f} -> loadStoreLog (mkQueue ms) f $ queueStore ms pure $ AMS qt mt ms ASSCfg qt mt SSCMemoryJournal {storeLogFile, storeMsgsPath} -> do let qsCfg = MQStoreCfg @@ -341,9 +342,10 @@ newEnv config@ServerConfig {smpCredentials, httpCredentials, serverStoreCfg, smp pure $ AMS qt mt ms #if defined(dbServerPostgres) ASSCfg qt mt SSCDatabaseJournal {storeCfg, storeMsgsPath'} -> do - let StartOptions {confirmMigrations} = startOptions config + let StartOptions {compactLog, confirmMigrations} = startOptions config qsCfg = PQStoreCfg (storeCfg {confirmMigrations} :: PostgresStoreCfg) cfg = mkJournalStoreConfig qsCfg storeMsgsPath' msgQueueQuota maxJournalMsgCount maxJournalStateLines idleQueueInterval + when compactLog $ compactDbStoreLog $ dbStoreLogPath storeCfg ms <- newMsgStore cfg pure $ AMS qt mt ms #else @@ -368,6 +370,16 @@ newEnv config@ServerConfig {smpCredentials, httpCredentials, serverStoreCfg, smp logInfo $ "restoring queues from file " <> T.pack f sl <- readWriteQueueStore False mkQ f st setStoreLog st sl + compactDbStoreLog = \case + Just f -> do + logInfo $ "compacting queues in file " <> T.pack f + st <- newMsgStore STMStoreConfig {storePath = Nothing, quota = msgQueueQuota} + sl <- readWriteQueueStore False (mkQueue st) f (queueStore st) + setStoreLog (queueStore st) sl + closeMsgStore st + Nothing -> do + logError "Error: `--compact-log` used without `db_store_log` INI option" + exitFailure getCredentials protocol creds = do files <- missingCreds unless (null files) $ do diff --git a/src/Simplex/Messaging/Server/Main.hs b/src/Simplex/Messaging/Server/Main.hs index e986906a5..14ea6fe9e 100644 --- a/src/Simplex/Messaging/Server/Main.hs +++ b/src/Simplex/Messaging/Server/Main.hs @@ -795,8 +795,14 @@ cliCommandP cfgPath logPath iniFile = maintenance <- switch ( long "maintenance" + <> short 'm' <> help "Do not start the server, only perform start and stop tasks" ) + compactLog <- + switch + ( long "compact-log" + <> help "Compact store log (always enabled with `memory` storage for queues)" + ) skipWarnings <- switch ( long "skip-warnings" @@ -810,7 +816,7 @@ cliCommandP cfgPath logPath iniFile = <> help "Confirm PostgreSQL database migration: up, down (default is manual confirmation)" <> value MCConsole ) - pure StartOptions {maintenance, skipWarnings, confirmMigrations} + pure StartOptions {maintenance, compactLog, skipWarnings, confirmMigrations} journalCmdP = storeCmdP "message log file" "journal storage" databaseCmdP = storeCmdP "queue store log file" "PostgreSQL database schema" storeCmdP src dest = diff --git a/src/Simplex/Messaging/Server/QueueStore/STM.hs b/src/Simplex/Messaging/Server/QueueStore/STM.hs index db415e297..c119beb23 100644 --- a/src/Simplex/Messaging/Server/QueueStore/STM.hs +++ b/src/Simplex/Messaging/Server/QueueStore/STM.hs @@ -63,7 +63,11 @@ instance StoreQueueClass q => QueueStoreClass q (STMQueueStore q) where pure STMQueueStore {queues, senders, notifiers, storeLog} closeQueueStore :: STMQueueStore q -> IO () - closeQueueStore st = readTVarIO (storeLog st) >>= mapM_ closeStoreLog + closeQueueStore STMQueueStore {queues, senders, notifiers, storeLog} = do + readTVarIO storeLog >>= mapM_ closeStoreLog + atomically $ TM.clear queues + atomically $ TM.clear senders + atomically $ TM.clear notifiers loadedQueues = queues {-# INLINE loadedQueues #-} diff --git a/tests/CoreTests/MsgStoreTests.hs b/tests/CoreTests/MsgStoreTests.hs index e73527ad4..adde9ae2b 100644 --- a/tests/CoreTests/MsgStoreTests.hs +++ b/tests/CoreTests/MsgStoreTests.hs @@ -472,7 +472,7 @@ testReadFileMissing ms = do mq <- fromJust <$> readTVarIO (msgQueue q) MsgQueueState {readState = rs} <- readTVarIO $ state mq - closeMsgStore ms + closeMsgQueue q let path = journalFilePath (queueDirectory $ queue mq) $ journalId rs removeFile path @@ -491,7 +491,7 @@ testReadFileMissingSwitch ms = do mq <- fromJust <$> readTVarIO (msgQueue q) MsgQueueState {readState = rs} <- readTVarIO $ state mq - closeMsgStore ms + closeMsgQueue q let path = journalFilePath (queueDirectory $ queue mq) $ journalId rs removeFile path @@ -509,7 +509,7 @@ testWriteFileMissing ms = do mq <- fromJust <$> readTVarIO (msgQueue q) MsgQueueState {writeState = ws} <- readTVarIO $ state mq - closeMsgStore ms + closeMsgQueue q let path = journalFilePath (queueDirectory $ queue mq) $ journalId ws print path removeFile path @@ -532,7 +532,7 @@ testReadAndWriteFilesMissing ms = do mq <- fromJust <$> readTVarIO (msgQueue q) MsgQueueState {readState = rs, writeState = ws} <- readTVarIO $ state mq - closeMsgStore ms + closeMsgQueue q removeFile $ journalFilePath (queueDirectory $ queue mq) $ journalId rs removeFile $ journalFilePath (queueDirectory $ queue mq) $ journalId ws diff --git a/tests/SMPClient.hs b/tests/SMPClient.hs index e03aa051b..602055b82 100644 --- a/tests/SMPClient.hs +++ b/tests/SMPClient.hs @@ -212,7 +212,7 @@ cfgMS msType = allowSMPProxy = False, serverClientConcurrency = 2, information = Nothing, - startOptions = StartOptions {maintenance = False, skipWarnings = False, confirmMigrations = MCYesUp} + startOptions = StartOptions {maintenance = False, compactLog = False, skipWarnings = False, confirmMigrations = MCYesUp} } serverStoreConfig :: AStoreType -> AServerStoreCfg From 6db79808aa31b1c719c9d3c3d73e6181711a08f7 Mon Sep 17 00:00:00 2001 From: Evgeny Date: Tue, 18 Mar 2025 09:40:22 +0000 Subject: [PATCH 13/14] smp server: use COPY to import store log to postgres db, improve concurrency and error handling (#1487) * smp server: use COPY to import store log to postgres db * compact queues when importing to postgres * mempty * version * handle errors while expiring, mask async exceptions while getting queue * whitespace * version --- simplexmq.cabal | 2 +- src/Simplex/Messaging/Server.hs | 12 +-- src/Simplex/Messaging/Server/Main.hs | 14 ++-- .../Messaging/Server/QueueStore/Postgres.hs | 75 +++++++++++++------ .../Messaging/Server/QueueStore/STM.hs | 1 - src/Simplex/Messaging/Server/StoreLog.hs | 5 +- 6 files changed, 74 insertions(+), 35 deletions(-) diff --git a/simplexmq.cabal b/simplexmq.cabal index 5cd28a1f1..6bbf363bb 100644 --- a/simplexmq.cabal +++ b/simplexmq.cabal @@ -1,7 +1,7 @@ cabal-version: 1.12 name: simplexmq -version: 6.3.0.805 +version: 6.3.0.8 synopsis: SimpleXMQ message broker description: This package includes <./docs/Simplex-Messaging-Server.html server>, <./docs/Simplex-Messaging-Client.html client> and diff --git a/src/Simplex/Messaging/Server.hs b/src/Simplex/Messaging/Server.hs index d816118d5..00dc7cba7 100644 --- a/src/Simplex/Messaging/Server.hs +++ b/src/Simplex/Messaging/Server.hs @@ -399,15 +399,17 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg, startOpt expire :: forall s. MsgStoreClass s => s -> ServerStats -> Int64 -> IO () expire ms stats interval = do threadDelay' interval + logInfo "Started expiring messages..." n <- compactQueues @(StoreQueue s) $ queueStore ms when (n > 0) $ logInfo $ "Removed " <> tshow n <> " old deleted queues from the database." old <- expireBeforeEpoch expCfg now <- systemSeconds <$> getSystemTime - msgStats@MessageStats {storedMsgsCount = stored, expiredMsgsCount = expired} <- - withAllMsgQueues False "idleDeleteExpiredMsgs" ms $ expireQueueMsgs now ms old - atomicWriteIORef (msgCount stats) stored - atomicModifyIORef'_ (msgExpired stats) (+ expired) - printMessageStats "STORE: messages" msgStats + tryAny (withAllMsgQueues False "idleDeleteExpiredMsgs" ms $ expireQueueMsgs now ms old) >>= \case + Right msgStats@MessageStats {storedMsgsCount = stored, expiredMsgsCount = expired} -> do + atomicWriteIORef (msgCount stats) stored + atomicModifyIORef'_ (msgExpired stats) (+ expired) + printMessageStats "STORE: messages" msgStats + Left e -> logError $ "STORE: withAllMsgQueues, error expiring messages, " <> tshow e expireQueueMsgs now ms old q = do (expired_, stored) <- idleDeleteExpiredMsgs now ms q old pure MessageStats {storedMsgsCount = stored, expiredMsgsCount = fromMaybe 0 expired_, storedQueues = 1} diff --git a/src/Simplex/Messaging/Server/Main.hs b/src/Simplex/Messaging/Server/Main.hs index 14ea6fe9e..6c930ba0b 100644 --- a/src/Simplex/Messaging/Server/Main.hs +++ b/src/Simplex/Messaging/Server/Main.hs @@ -71,7 +71,7 @@ import Simplex.Messaging.Server.MsgStore.Types (QSType (..)) import Simplex.Messaging.Server.MsgStore.Journal (postgresQueueStore) import Simplex.Messaging.Server.QueueStore.Postgres (batchInsertQueues, foldQueueRecs) import Simplex.Messaging.Server.QueueStore.Types -import Simplex.Messaging.Server.StoreLog (logCreateQueue, openWriteStoreLog) +import Simplex.Messaging.Server.StoreLog (closeStoreLog, logCreateQueue, openWriteStoreLog) import System.Directory (renameFile) #endif @@ -176,10 +176,11 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath = | otherwise -> do storeLogFile <- getRequiredStoreLogFile ini confirmOrExit - ("WARNING: store log file " <> storeLogFile <> " will be imported to PostrgreSQL database: " <> B.unpack connstr <> ", schema: " <> B.unpack schema) + ("WARNING: store log file " <> storeLogFile <> " will be compacted and imported to PostrgreSQL database: " <> B.unpack connstr <> ", schema: " <> B.unpack schema) "Queue records not imported" ms <- newJournalMsgStore MQStoreCfg - readQueueStore True (mkQueue ms) storeLogFile (queueStore ms) + sl <- readWriteQueueStore True (mkQueue ms) storeLogFile (queueStore ms) + closeStoreLog sl queues <- readTVarIO $ loadedQueues $ stmQueueStore ms let storeCfg = PostgresStoreCfg {dbOpts = dbOpts {createSchema = True}, dbStoreLogPath = Nothing, confirmMigrations = MCConsole, deletedTTL = iniDeletedTTL ini} ps <- newJournalMsgStore $ PQStoreCfg storeCfg @@ -187,10 +188,13 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath = renameFile storeLogFile $ storeLogFile <> ".bak" putStrLn $ "Import completed: " <> show qCnt <> " queues" putStrLn $ case readStoreType ini of - Right (ASType SQSMemory SMSMemory) -> "store_messages set to `memory`.\nImport messages to journal to use PostgreSQL database for queues (`smp-server journal import`)" - Right (ASType SQSMemory SMSJournal) -> "store_queues set to `memory`, update it to `database` in INI file" + Right (ASType SQSMemory SMSMemory) -> setToDbStr <> "\nstore_messages set to `memory`, import messages to journal to use PostgreSQL database for queues (`smp-server journal import`)" + Right (ASType SQSMemory SMSJournal) -> setToDbStr Right (ASType SQSPostgres SMSJournal) -> "store_queues set to `database`, start the server." Left e -> e <> ", configure storage correctly" + where + setToDbStr :: String + setToDbStr = "store_queues set to `memory`, update it to `database` in INI file" SCExport | schemaExists && storeLogExists -> exitConfigureQueueStore connstr schema | not schemaExists -> do diff --git a/src/Simplex/Messaging/Server/QueueStore/Postgres.hs b/src/Simplex/Messaging/Server/QueueStore/Postgres.hs index 3c9bbbcd8..3062e2313 100644 --- a/src/Simplex/Messaging/Server/QueueStore/Postgres.hs +++ b/src/Simplex/Messaging/Server/QueueStore/Postgres.hs @@ -32,18 +32,25 @@ import Control.Monad import Control.Monad.Except import Control.Monad.IO.Class import Control.Monad.Trans.Except +import Data.ByteString.Builder (Builder) +import qualified Data.ByteString.Builder as BB +import Data.ByteString.Char8 (ByteString) +import qualified Data.ByteString.Char8 as B +import qualified Data.ByteString.Lazy as LB import Data.Bitraversable (bimapM) import Data.Either (fromRight) import Data.Functor (($>)) import Data.Int (Int64) +import Data.List (intersperse) import qualified Data.Map.Strict as M import Data.Maybe (catMaybes) import qualified Data.Text as T import Data.Time.Clock.System (SystemTime (..), getSystemTime) import Database.PostgreSQL.Simple (Binary (..), Only (..), Query, SqlError) import qualified Database.PostgreSQL.Simple as DB +import qualified Database.PostgreSQL.Simple.Copy as DB import Database.PostgreSQL.Simple.FromField (FromField (..)) -import Database.PostgreSQL.Simple.ToField (ToField (..)) +import Database.PostgreSQL.Simple.ToField (Action (..), ToField (..)) import Database.PostgreSQL.Simple.Errors (ConstraintViolation (..), constraintViolation) import Database.PostgreSQL.Simple.SqlQQ (sql) import GHC.IO (catchAny) @@ -160,7 +167,7 @@ instance StoreQueueClass q => QueueStoreClass q (PostgresQueueStore q) where loadSndQueue = loadQueue " WHERE sender_id = ?" $ \rId -> TM.insert qId rId senders loadNtfQueue = loadQueue " WHERE notifier_id = ?" $ \_ -> pure () -- do NOT cache ref - ntf subscriptions are rare loadQueue condition insertRef = - runExceptT $ do + 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) @@ -182,7 +189,7 @@ instance StoreQueueClass q => QueueStoreClass q (PostgresQueueStore q) where secureQueue :: PostgresQueueStore q -> q -> SndPublicAuthKey -> IO (Either ErrorType ()) secureQueue st sq sKey = - withQueueDB sq "secureQueue" $ \q -> do + withQueueRec sq "secureQueue" $ \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" (sKey, rId) @@ -196,7 +203,7 @@ instance StoreQueueClass q => QueueStoreClass q (PostgresQueueStore q) where addQueueNotifier :: PostgresQueueStore q -> q -> NtfCreds -> IO (Either ErrorType (Maybe NotifierId)) addQueueNotifier st sq ntfCreds@NtfCreds {notifierId = nId, notifierKey, rcvNtfDhSecret} = - withQueueDB sq "addQueueNotifier" $ \q -> + withQueueRec sq "addQueueNotifier" $ \q -> ExceptT $ withLockMap (notifierLocks st) nId "addQueueNotifier" $ ifM (TM.memberIO nId notifiers) (pure $ Left DUPLICATE_) $ runExceptT $ do assertUpdated $ withDB "addQueueNotifier" st $ \db -> @@ -223,7 +230,7 @@ instance StoreQueueClass q => QueueStoreClass q (PostgresQueueStore q) where deleteQueueNotifier :: PostgresQueueStore q -> q -> IO (Either ErrorType (Maybe NotifierId)) deleteQueueNotifier st sq = - withQueueDB sq "deleteQueueNotifier" $ \q -> + withQueueRec sq "deleteQueueNotifier" $ \q -> ExceptT $ fmap sequence $ forM (notifier q) $ \NtfCreds {notifierId = nId} -> withLockMap (notifierLocks st) nId "deleteQueueNotifier" $ runExceptT $ do assertUpdated $ withDB' "deleteQueueNotifier" st update @@ -260,7 +267,7 @@ instance StoreQueueClass q => QueueStoreClass q (PostgresQueueStore q) where updateQueueTime :: PostgresQueueStore q -> q -> RoundedSystemTime -> IO (Either ErrorType QueueRec) updateQueueTime st sq t = - withQueueDB sq "updateQueueTime" $ \q@QueueRec {updatedAt} -> + withQueueRec sq "updateQueueTime" $ \q@QueueRec {updatedAt} -> if updatedAt == Just t then pure q else do @@ -295,21 +302,19 @@ batchInsertQueues tty queues toStore = do qs <- catMaybes <$> mapM (\(rId, q) -> (rId,) <$$> readTVarIO (queueRec q)) (M.assocs queues) putStrLn $ "Importing " <> show (length qs) <> " queues..." let st = dbStore toStore - (qCnt, count) <- foldM (processChunk st) (0, 0) $ toChunks 1000000 qs + count <- + withConnection st $ \db -> do + DB.copy_ db "COPY msg_queues (recipient_id, recipient_key, rcv_dh_secret, sender_id, sender_key, snd_secure, notifier_id, notifier_key, rcv_ntf_dh_secret, status, updated_at) FROM STDIN WITH (FORMAT CSV)" + mapM_ (putQueue db) (zip [1..] qs) + DB.putCopyEnd db + Only qCnt : _ <- withConnection st (`DB.query_` "SELECT count(*) FROM msg_queues") putStrLn $ progress count pure qCnt where - processChunk st (qCnt, i) qs = do - qCnt' <- withConnection st $ \db -> DB.executeMany db insertQueueQuery $ map queueRecToRow qs - let i' = i + length qs - when tty $ putStr (progress i' <> "\r") >> hFlush stdout - pure (qCnt + qCnt', i') + putQueue db (i :: Int, q) = do + DB.putCopyData db $ queueRecToText q + when (tty && i `mod` 100000 == 0) $ putStr (progress i <> "\r") >> hFlush stdout progress i = "Imported: " <> show i <> " queues" - toChunks :: Int -> [a] -> [[a]] - toChunks _ [] = [] - toChunks n xs = - let (ys, xs') = splitAt n xs - in ys : toChunks n xs' insertQueueQuery :: Query insertQueueQuery = @@ -349,6 +354,34 @@ queueRecToRow :: (RecipientId, QueueRec) -> QueueRecRow queueRecToRow (rId, QueueRec {recipientKey, rcvDhSecret, senderId, senderKey, sndSecure, notifier = n, status, updatedAt}) = (rId, recipientKey, rcvDhSecret, senderId, senderKey, sndSecure, notifierId <$> n, notifierKey <$> n, rcvNtfDhSecret <$> n, status, updatedAt) +queueRecToText :: (RecipientId, QueueRec) -> ByteString +queueRecToText (rId, QueueRec {recipientKey, rcvDhSecret, senderId, senderKey, sndSecure, notifier = n, status, updatedAt}) = + LB.toStrict $ BB.toLazyByteString $ mconcat tabFields <> BB.char7 '\n' + where + tabFields = BB.char7 ',' `intersperse` fields + fields = + [ renderField (toField rId), + renderField (toField recipientKey), + renderField (toField rcvDhSecret), + renderField (toField senderId), + nullable senderKey, + renderField (toField sndSecure), + nullable (notifierId <$> n), + nullable (notifierKey <$> n), + nullable (rcvNtfDhSecret <$> n), + BB.char7 '"' <> renderField (toField status) <> BB.char7 '"', + nullable updatedAt + ] + nullable :: ToField a => Maybe a -> Builder + nullable = maybe mempty (renderField . toField) + renderField :: Action -> Builder + renderField = \case + Plain bld -> bld + Escape s -> BB.byteString s + EscapeByteA s -> BB.string7 "\\x" <> BB.byteStringHex s + EscapeIdentifier s -> BB.byteString s -- Not used in COPY data + Many as -> mconcat (map renderField as) + rowToQueueRec :: QueueRecRow -> (RecipientId, QueueRec) rowToQueueRec (rId, recipientKey, rcvDhSecret, senderId, senderKey, sndSecure, notifierId_, notifierKey_, rcvNtfDhSecret_, status, updatedAt) = let notifier = NtfCreds <$> notifierId_ <*> notifierKey_ <*> rcvNtfDhSecret_ @@ -356,14 +389,14 @@ rowToQueueRec (rId, recipientKey, rcvDhSecret, senderId, senderKey, sndSecure, n setStatusDB :: StoreQueueClass q => String -> PostgresQueueStore q -> q -> ServerEntityStatus -> ExceptT ErrorType IO () -> IO (Either ErrorType ()) setStatusDB op st sq status writeLog = - withQueueDB sq op $ \q -> do + withQueueRec sq op $ \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 -withQueueDB :: StoreQueueClass q => q -> String -> (QueueRec -> ExceptT ErrorType IO a) -> IO (Either ErrorType a) -withQueueDB sq op action = +withQueueRec :: StoreQueueClass q => q -> String -> (QueueRec -> ExceptT ErrorType IO a) -> IO (Either ErrorType a) +withQueueRec sq op action = withQueueLock sq op $ E.uninterruptibleMask_ $ runExceptT $ ExceptT (readQueueRecIO $ queueRec sq) >>= action assertUpdated :: ExceptT ErrorType IO Int64 -> ExceptT ErrorType IO () @@ -379,7 +412,7 @@ withDB op st action = logErr :: E.SomeException -> IO (Either ErrorType a) logErr e = logError ("STORE: " <> T.pack err) $> Left (STORE err) where - err = op <> ", withLog, " <> show e + err = op <> ", withDB, " <> show e withLog :: MonadIO m => String -> PostgresQueueStore q -> (StoreLog 'WriteMode -> IO ()) -> m () withLog op PostgresQueueStore {dbStoreLog} action = diff --git a/src/Simplex/Messaging/Server/QueueStore/STM.hs b/src/Simplex/Messaging/Server/QueueStore/STM.hs index c119beb23..8a360c3a0 100644 --- a/src/Simplex/Messaging/Server/QueueStore/STM.hs +++ b/src/Simplex/Messaging/Server/QueueStore/STM.hs @@ -18,7 +18,6 @@ module Simplex.Messaging.Server.QueueStore.STM ( STMQueueStore (..), setStoreLog, withLog', - withQueueRec, readQueueRecIO, setStatus, ) diff --git a/src/Simplex/Messaging/Server/StoreLog.hs b/src/Simplex/Messaging/Server/StoreLog.hs index 1e0565a61..1cc8ebd6c 100644 --- a/src/Simplex/Messaging/Server/StoreLog.hs +++ b/src/Simplex/Messaging/Server/StoreLog.hs @@ -259,8 +259,9 @@ removeStoreLogBackups f = do times2 = take (length times1 - minOldBackups) times1 -- keep 3 backups older than 24 hours toDelete = filter (< old) times2 -- remove all backups older than 21 day mapM_ (removeFile . backupPath) toDelete - putStrLn $ "Removed " <> show (length toDelete) <> " backups:" - mapM_ (putStrLn . backupPath) toDelete + when (length toDelete > 0) $ do + putStrLn $ "Removed " <> show (length toDelete) <> " backups:" + mapM_ (putStrLn . backupPath) toDelete where backupPathTime :: FilePath -> Maybe UTCTime backupPathTime = iso8601ParseM <=< stripPrefix backupPathPfx From b2f16eeff46c45f2a1b448bf2430a5f5ede8d3d0 Mon Sep 17 00:00:00 2001 From: sh <37271604+shumvgolove@users.noreply.github.com> Date: Tue, 18 Mar 2025 09:42:53 +0000 Subject: [PATCH 14/14] ci: seperate builds (pg/standard) (#1486) --- .github/workflows/build.yml | 22 ++++++++++++++++++---- 1 file changed, 18 insertions(+), 4 deletions(-) diff --git a/.github/workflows/build.yml b/.github/workflows/build.yml index 7747bebc8..a0cfeed81 100644 --- a/.github/workflows/build.yml +++ b/.github/workflows/build.yml @@ -56,9 +56,24 @@ jobs: shell: bash run: docker run -t -d --name builder local - - name: Build binaries + - name: Build smp-server (postgresql) and tests shell: bash - run: docker exec -t -e apps="$apps" builder sh -c 'cabal build --enable-tests -fserver_postgres && mkdir /out && for i in $apps; do bin=$(find /project/dist-newstyle -name "$i" -type f -executable); strip "$bin"; chmod +x "$bin"; mv "$bin" /out/; done' + run: docker exec -t builder sh -c 'cabal build --enable-tests -fserver_postgres && mkdir -p /out && for i in smp-server simplexmq-test; do bin=$(find /project/dist-newstyle -name "$i" -type f -executable); chmod +x "$bin"; mv "$bin" /out/; done; strip /out/smp-server' + + - name: Copy simplexmq-test from container + shell: bash + run: | + docker cp builder:/out/simplexmq-test . + + - name: Copy smp-server (postgresql) from container and prepare it + if: startsWith(github.ref, 'refs/tags/v') + shell: bash + run: | + docker cp builder:/out/smp-server ./smp-server-postgres-ubuntu-${{ matrix.platform_name }} + + - name: Build everything else (standard) + shell: bash + run: docker exec -t -e apps="$apps" builder sh -c 'cabal build && mkdir -p /out && for i in $apps; do bin=$(find /project/dist-newstyle -name "$i" -type f -executable); strip "$bin"; chmod +x "$bin"; mv "$bin" /out/; done' - name: Copy binaries from container and prepare them if: startsWith(github.ref, 'refs/tags/v') @@ -92,6 +107,7 @@ jobs: files: | LICENSE smp-server-ubuntu-${{ matrix.platform_name }} + smp-server-postgres-ubuntu-${{ matrix.platform_name }} ntf-server-ubuntu-${{ matrix.platform_name }} xftp-server-ubuntu-${{ matrix.platform_name }} xftp-ubuntu-${{ matrix.platform_name }} @@ -104,6 +120,4 @@ jobs: env: PGHOST: localhost run: | - docker exec -t builder sh -c 'mv $(find /project/dist-newstyle -name "simplexmq-test" -type f -executable) /out/' - docker cp builder:/out/simplexmq-test . ./simplexmq-test