diff --git a/.github/workflows/build.yml b/.github/workflows/build.yml index 4da30d59b..a0cfeed81 100644 --- a/.github/workflows/build.yml +++ b/.github/workflows/build.yml @@ -15,6 +15,19 @@ jobs: env: apps: "smp-server xftp-server ntf-server xftp" runs-on: ubuntu-${{ 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: @@ -43,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 && 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') @@ -79,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 }} @@ -88,7 +117,7 @@ jobs: - name: Test shell: bash + 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 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} diff --git a/simplexmq.cabal b/simplexmq.cabal index 5dddd71af..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 @@ -148,16 +155,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 @@ -228,18 +228,34 @@ 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 Simplex.Messaging.Server.MsgStore.STM Simplex.Messaging.Server.MsgStore.Types Simplex.Messaging.Server.NtfStore Simplex.Messaging.Server.Prometheus Simplex.Messaging.Server.QueueStore Simplex.Messaging.Server.QueueStore.STM + 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: @@ -308,16 +324,19 @@ library , process ==1.6.* , temporary ==1.3.* , websockets ==0.12.* - if flag(client_postgres) + 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.* @@ -435,7 +454,6 @@ test-suite simplexmq-test CoreTests.UtilTests CoreTests.VersionRangeTests FileDescriptionTests - Fixtures NtfClient NtfServerTests RemoteControl @@ -451,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 @@ -473,7 +494,6 @@ test-suite simplexmq-test , crypton-x509 , crypton-x509-store , crypton-x509-validation - , deepseq ==1.4.* , directory , file-embed , filepath @@ -487,10 +507,8 @@ test-suite simplexmq-test , ini , iso8601-time , main-tester ==0.2.* - , memory , mtl , network - , process , QuickCheck ==2.14.* , random , silently ==1.2.* @@ -511,11 +529,15 @@ test-suite simplexmq-test , yaml default-language: Haskell2010 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 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/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/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/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..50494e781 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 (finally, onException, throwIO, uninterruptibleMask_) +import Control.Logger.Simple (logError) +import Control.Monad 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,60 +52,77 @@ 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? - dbConnection <- newMVar dbConn - dbClosed <- newTVarIO False - pure DBStore {dbConnstr, dbSchema, dbConnection, dbNew, dbClosed} +connectPostgresStore :: DBOpts -> IO DBStore +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} -connectDB :: ByteString -> String -> IO (DB.Connection, Bool) -connectDB connstr schema = do +-- 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 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 () -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 - 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) >>= DB.close + 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") --- 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..a71376a20 100644 --- a/src/Simplex/Messaging/Agent/Store/Postgres/Common.hs +++ b/src/Simplex/Messaging/Agent/Store/Postgres/Common.hs @@ -1,7 +1,12 @@ +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TupleSections #-} module Simplex.Messaging.Agent.Store.Postgres.Common ( DBStore (..), + DBOpts (..), withConnection, withConnection', withTransaction, @@ -10,33 +15,43 @@ 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 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 { dbConnstr :: ByteString, - dbSchema :: String, - dbConnection :: MVar PSQL.Connection, + dbSchema :: ByteString, + 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 } --- TODO [postgres] connection pool withConnectionPriority :: DBStore -> Bool -> (PSQL.Connection -> IO a) -> IO a -withConnectionPriority DBStore {dbConnection} _priority action = - withMVar dbConnection action +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 +{-# 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/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/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/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/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/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..00dc7cba7 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) 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,9 +352,9 @@ 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) + sent <- atomically $ tryWriteTBQueue q ts if sent then updateEndStats else -- if queue is full it can block @@ -389,21 +390,27 @@ 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" - 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 - expireQueueMsgs now ms old q = fmap (fromRight newMessageStats) . runExceptT $ do + 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 + 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} @@ -434,9 +441,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 +496,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 +548,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 +580,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 +591,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 +673,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 +683,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 +722,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 +823,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 +836,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 +856,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 +866,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 +918,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 +968,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 +978,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 +1078,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 +1155,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 +1326,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 +1344,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 +1354,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 +1367,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 +1384,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 +1448,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 +1545,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 +1576,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 +1600,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,28 +1799,27 @@ 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 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) @@ -1830,41 +1830,34 @@ 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 + 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..." + run $ processExpireQueue old + Nothing -> do + logInfo "validating journal store messages..." + run processValidateQueue + | otherwise = logWarn "skipping message expiration" $> Nothing + where + run a = unsafeWithAllMsgQueues False ms a `catchAny` \_ -> exitFailure + processExpireQueue :: Int64 -> JournalQueue s -> IO MessageStats + processExpireQueue old q = unsafeRunStore q "processExpireQueue" $ do + mq <- getMsgQueue ms q False + expiredMsgsCount <- deleteExpireMsgs_ old q mq + storedMsgsCount <- getQueueSize_ mq + pure MessageStats {storedMsgsCount, expiredMsgsCount, storedQueues = 1} + processValidateQueue :: JournalQueue s -> IO MessageStats + processValidateQueue q = unsafeRunStore q "processValidateQueue" $ do + storedMsgsCount <- getQueueSize_ =<< getMsgQueue ms q False + pure newMessageStats {storedMsgsCount, storedQueues = 1} -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 +1865,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 +1992,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..d7660cd0b 100644 --- a/src/Simplex/Messaging/Server/CLI.hs +++ b/src/Simplex/Messaging/Server/CLI.hs @@ -27,8 +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.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.Config (PostgresStoreCfg (..)) import Simplex.Messaging.Transport (ATransport (..), TLS, Transport (..)) import Simplex.Messaging.Transport.Server (AddHTTP, loadFileFingerprint) import Simplex.Messaging.Transport.WebSockets (WS) @@ -296,10 +299,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 + +printSMPServerConfig :: [(ServiceName, ATransport, AddHTTP)] -> AServerStoreCfg -> IO () +printSMPServerConfig transports (ASSCfg _ _ cfg) = case cfg of + SSCMemory sp_ -> printServerConfig transports $ (\StorePaths {storeLogFile} -> storeLogFile) <$> sp_ + SSCMemoryJournal {storeLogFile} -> printServerConfig transports $ Just storeLogFile + SSCDatabaseJournal {storeCfg = PostgresStoreCfg {dbOpts = 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 005ce6d9b..160697feb 100644 --- a/src/Simplex/Messaging/Server/Env/STM.hs +++ b/src/Simplex/Messaging/Server/Env/STM.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} @@ -9,6 +11,12 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StrictData #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} +#if __GLASGOW_HASKELL__ == 810 +{-# LANGUAGE UndecidableInstances #-} +#endif +{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-} module Simplex.Messaging.Server.Env.STM where @@ -21,18 +29,22 @@ 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.Shared (MigrationConfirmation (..)) import Simplex.Messaging.Client.Agent (SMPClientAgent, SMPClientAgentConfig, newSMPClientAgent) import Simplex.Messaging.Crypto (KeyHash (..)) import qualified Simplex.Messaging.Crypto as C @@ -44,9 +56,12 @@ 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.Postgres.Config +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 +76,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 +135,9 @@ data ServerConfig = ServerConfig data StartOptions = StartOptions { maintenance :: Bool, - skipWarnings :: Bool + compactLog :: Bool, + skipWarnings :: Bool, + confirmMigrations :: MigrationConfirmation } defMsgExpirationDays :: Int64 @@ -191,19 +206,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 :: {storeCfg :: PostgresStoreCfg, 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 +252,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 +298,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 +325,34 @@ 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} = 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 +#if defined(dbServerPostgres) + ASSCfg qt mt SSCDatabaseJournal {storeCfg, storeMsgsPath'} -> do + let StartOptions {compactLog, confirmMigrations} = startOptions config + qsCfg = PQStoreCfg (storeCfg {confirmMigrations} :: PostgresStoreCfg) + cfg = mkJournalStoreConfig qsCfg storeMsgsPath' msgQueueQuota maxJournalMsgCount maxJournalStateLines idleQueueInterval + when compactLog $ compactDbStoreLog $ dbStoreLogPath storeCfg + ms <- newMsgStore cfg + pure $ AMS qt mt ms +#else + ASSCfg _ _ SSCDatabaseJournal {} -> noPostgresExit +#endif 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 +365,21 @@ 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 + 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 @@ -358,17 +413,26 @@ 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 = +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 { storePath, quota = msgQueueQuota, pathParts = journalMsgStoreDepth, + queueStoreCfg, maxMsgCount = maxJournalMsgCount, maxStateLines = maxJournalStateLines, stateTailSize = defaultStateTailSize, @@ -382,5 +446,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..6c930ba0b 100644 --- a/src/Simplex/Messaging/Server/Main.hs +++ b/src/Simplex/Messaging/Server/Main.hs @@ -1,7 +1,10 @@ {-# LANGUAGE ApplicativeDo #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedStrings #-} @@ -30,9 +33,10 @@ 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 Options.Applicative import Simplex.Messaging.Agent.Protocol (connReqUriP') +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) import qualified Simplex.Messaging.Crypto as C @@ -44,18 +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.Types (AMSType (..), SMSType (..), newMsgStore) -import Simplex.Messaging.Server.QueueStore.STM (readQueueStore) +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 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 (closeStoreLog, logCreateQueue, openWriteStoreLog) +import System.Directory (renameFile) +#endif + smpServerCLI :: FilePath -> FilePath -> IO () smpServerCLI = smpServerCLI_ (\_ _ _ -> pure ()) (\_ -> pure ()) (\_ -> error "attachStaticFiles not available") @@ -84,37 +103,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 +135,22 @@ 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 + 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 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 + 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." exitFailure @@ -141,34 +160,121 @@ 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 + 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 compacted and imported to PostrgreSQL database: " <> B.unpack connstr <> ", schema: " <> B.unpack schema) + "Queue records not imported" + ms <- newJournalMsgStore MQStoreCfg + 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 + qCnt <- batchInsertQueues @(JournalQueue 'QSMemory) True queues $ postgresQueueStore ps + renameFile storeLogFile $ storeLogFile <> ".bak" + putStrLn $ "Import completed: " <> show qCnt <> " queues" + putStrLn $ case readStoreType ini of + Right (ASType SQSMemory SMSMemory) -> setToDbStr <> "\nstore_messages set to `memory`, import messages to journal to use PostgreSQL database for queues (`smp-server journal import`)" + Right (ASType SQSMemory SMSJournal) -> setToDbStr + Right (ASType 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 + 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" + let storeCfg = PostgresStoreCfg {dbOpts, dbStoreLogPath = Nothing, confirmMigrations = MCConsole, deletedTTL = iniDeletedTTL ini} + ps <- newJournalMsgStore $ PQStoreCfg storeCfg + 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 + 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 + | 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;" +#else + Database {} -> noPostgresExit +#endif 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 + case enableStoreLog' ini $> 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 - defaultServerPorts = "5223,443" executableName = "smp-server" storeLogFilePath = combine logPath "smp-server-store.log" 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 - httpsCertFile = combine cfgPath "web.crt" - httpsKeyFile = combine cfgPath "web.key" + 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 + { connstr = either (const defaultDBConnStr) encodeUtf8 $ lookupValue "STORE_LOG" "db_connection" ini, + schema = either (const defaultDBSchema) encodeUtf8 $ lookupValue "STORE_LOG" "db_schema" ini, + poolSize = readIniDefault defaultDBPoolSize "STORE_LOG" "db_pool_size" ini, + createSchema = False + } + iniDeletedTTL ini = readIniDefault (86400 * defaultDeletedTTL) "STORE_LOG" "db_deleted_ttl" ini defaultStaticPath = combine logPath "www" - initializeServer opts@InitOptions {ip, fqdn, sourceCode = src', webStaticPath = sp', disableWeb = noWeb', scripted} - | scripted = initialize opts + enableStoreLog' = settingIsOn "STORE_LOG" "enable" + enableDbStoreLog' = settingIsOn "STORE_LOG" "db_store_log" + 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 @@ -210,7 +316,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 {ip, fqdn, signAlgorithm, password, controlPort, sourceCode} = do checkInitOptions opts' clearDirIfExists cfgPath clearDirIfExists logPath @@ -222,7 +328,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 @@ -233,108 +339,19 @@ 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 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\ - \# Log is compacted on start (deleted objects are removed).\n" - <> ("enable: " <> onOff enableStoreLog <> "\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 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 ini iniStoreType putStrLn $ case messageExpiration of Just ExpirationConfig {ttl} -> "expiring messages after " <> showTTL ttl _ -> "not expiring messages" @@ -347,10 +364,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, @@ -373,23 +390,21 @@ 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 - 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 +417,15 @@ 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' ini $> StorePaths {storeLogFile = storeLogFilePath, storeMsgsFile = restoreMessagesFile storeMsgsFilePath} + ASType SQSMemory SMSJournal -> + ASSCfg SQSMemory SMSJournal $ SSCMemoryJournal {storeLogFile = storeLogFilePath, storeMsgsPath = storeMsgsJournalDir} + ASType SQSPostgres SMSJournal -> + 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 allowNewQueues = fromMaybe True $ iniOnOff "AUTH" "new_queues" ini, @@ -486,31 +506,69 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath = pure WebHttpsParams {port, cert, key} webStaticPath' = eitherToMaybe $ T.unpack <$> lookupValue "WEB" "static_path" ini - checkMsgStoreMode :: AMSType -> 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 - AMSType SMSJournal + 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." - AMSType SMSMemory + | 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 + 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 +#else + SQSPostgres -> noPostgresExit +#endif + ASType SQSMemory SMSMemory + | msgsFileExists && msgsDirExists -> exitConfigureMsgStorage | msgsDirExists -> do putStrLn $ "Error: store_messages is `memory` with " <> storeMsgsJournalDir <> " directory present." putStrLn "Set store_messages to `journal` or use `smp-server journal import` to migrate." exitFailure - _ -> pure () + | otherwise -> pure () exitConfigureMsgStorage = do putStrLn $ "Error: both " <> storeMsgsFilePath <> " file and " <> storeMsgsJournalDir <> " directory are present." 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, webHttpPort :: Maybe Int, @@ -533,59 +591,6 @@ getServerSourceCode = simplexmqSource :: String simplexmqSource = "https://github.com/simplex-chat/simplexmq" -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 @@ -618,9 +623,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 p = if isNothing p then "# " else "" - 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 @@ -638,32 +640,10 @@ data CliCommand | OnlineCert CertOptions | Start StartOptions | Delete - | Journal JournalCmd + | Journal StoreCmd + | Database StoreCmd DBOpts -data JournalCmd = JCImport | JCExport | JCDelete - -data InitOptions = InitOptions - { enableStoreLog :: Bool, - 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) +data StoreCmd = SCImport | SCExport | SCDelete cliCommandP :: FilePath -> FilePath -> FilePath -> Parser CliCommand cliCommandP cfgPath logPath iniFile = @@ -673,6 +653,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 +664,7 @@ cliCommandP cfgPath logPath iniFile = <> short 'l' <> help "Enable store log for persistence" ) + dbOptions <- dbOptsP logStats <- switch ( long "daily-stats" @@ -785,6 +767,7 @@ cliCommandP cfgPath logPath iniFile = pure InitOptions { enableStoreLog, + dbOptions, logStats, signAlgorithm, ip, @@ -816,21 +799,69 @@ 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" <> 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, compactLog, 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 + ) + 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 + "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/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 4498677af..0382089a8 100644 --- a/src/Simplex/Messaging/Server/MsgStore/Journal.hs +++ b/src/Simplex/Messaging/Server/MsgStore/Journal.hs @@ -1,21 +1,29 @@ {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE InstanceSigs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TupleSections #-} module Simplex.Messaging.Server.MsgStore.Journal - ( JournalMsgStore (queueStore, random, expireBackupsBefore), + ( JournalMsgStore (random, expireBackupsBefore), + QStore (..), + QStoreCfg (..), JournalQueue, JournalMsgQueue (queue, state), JMQueue (queueDirectory, statePath), @@ -35,6 +43,10 @@ module Simplex.Messaging.Server.MsgStore.Journal queueLogFileName, journalFilePath, logFileExt, + stmQueueStore, +#if defined(dbServerPostgres) + postgresQueueStore, +#endif ) where @@ -46,45 +58,81 @@ 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) -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) 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 +#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) 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) -data JournalMsgStore = JournalMsgStore - { config :: JournalStoreConfig, +data JournalMsgStore s = JournalMsgStore + { config :: JournalStoreConfig s, random :: TVar StdGen, queueLocks :: TMap RecipientId Lock, - queueStore :: STMQueueStore JournalQueue, + sharedLock :: TMVar RecipientId, + queueStore_ :: QStore s, expireBackupsBefore :: UTCTime } -data JournalStoreConfig = JournalStoreConfig +data QStore (s :: QSType) where + MQStore :: QStoreType 'QSMemory -> QStore 'QSMemory +#if defined(dbServerPostgres) + PQStore :: QStoreType 'QSPostgres -> QStore 'QSPostgres +#endif + +type family QStoreType s where + QStoreType 'QSMemory = STMQueueStore (JournalQueue 'QSMemory) +#if defined(dbServerPostgres) + QStoreType 'QSPostgres = PostgresQueueStore (JournalQueue 'QSPostgres) +#endif + +withQS :: (QueueStoreClass (JournalQueue s) (QStoreType s) => QStoreType s -> r) -> QStore s -> r +withQS f = \case + MQStore st -> f st +#if defined(dbServerPostgres) + PQStore st -> f st +#endif +{-# INLINE withQS #-} + +stmQueueStore :: JournalMsgStore 'QSMemory -> STMQueueStore (JournalQueue 'QSMemory) +stmQueueStore st = case queueStore_ st of + MQStore st' -> st' + +#if defined(dbServerPostgres) +postgresQueueStore :: JournalMsgStore 'QSPostgres -> PostgresQueueStore (JournalQueue 'QSPostgres) +postgresQueueStore st = case queueStore_ st of + PQStore st' -> st' +#endif + +data JournalStoreConfig s = JournalStoreConfig { storePath :: FilePath, pathParts :: Int, + queueStoreCfg :: QStoreCfg s, quota :: Int, -- Max number of messages per journal file - ignored in STM store. -- When this limit is reached, the file will be changed. @@ -99,13 +147,20 @@ data JournalStoreConfig = JournalStoreConfig keepMinBackups :: Int } -data JournalQueue = JournalQueue - { recipientId :: RecipientId, +data QStoreCfg s where + MQStoreCfg :: QStoreCfg 'QSMemory +#if defined(dbServerPostgres) + PQStoreCfg :: PostgresStoreCfg -> QStoreCfg 'QSPostgres +#endif + +data JournalQueue (s :: QSType) = JournalQueue + { recipientId' :: RecipientId, queueLock :: Lock, + sharedLock :: TMVar RecipientId, -- To avoid race conditions and errors when restoring queues, -- Nothing is written to TVar when queue is deleted. - queueRec :: TVar (Maybe QueueRec), - msgQueue_ :: TVar (Maybe JournalMsgQueue), + 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 +176,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,131 +283,185 @@ 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 JournalQueue {recipientId', queueLock, sharedLock} = + withLockWaitShared recipientId' queueLock sharedLock + {-# 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) () +#if defined(dbServerPostgres) + PQStoreCfg cfg -> PQStore <$> newQueueStore @(JournalQueue s) cfg +#endif + + closeQueueStore = withQS (closeQueueStore @(JournalQueue s)) + {-# INLINE closeQueueStore #-} + loadedQueues = withQS loadedQueues + {-# INLINE loadedQueues #-} + compactQueues = withQS (compactQueues @(JournalQueue s)) + {-# INLINE compactQueues #-} + queueCounts = withQS (queueCounts @(JournalQueue s)) + {-# INLINE queueCounts #-} + addQueue_ = withQS addQueue_ + {-# INLINE addQueue_ #-} + getQueue_ = withQS getQueue_ + {-# INLINE getQueue_ #-} + secureQueue = withQS secureQueue + {-# INLINE secureQueue #-} + addQueueNotifier = withQS addQueueNotifier + {-# INLINE addQueueNotifier #-} + deleteQueueNotifier = withQS deleteQueueNotifier + {-# INLINE deleteQueueNotifier #-} + suspendQueue = withQS suspendQueue + {-# INLINE suspendQueue #-} + blockQueue = withQS blockQueue + {-# INLINE blockQueue #-} + unblockQueue = withQS unblockQueue + {-# INLINE unblockQueue #-} + updateQueueTime = withQS updateQueueTime + {-# INLINE updateQueueTime #-} + deleteStoreQueue = withQS deleteStoreQueue + {-# INLINE deleteStoreQueue #-} + +#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 + 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 + 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 + 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} - setStoreLog :: JournalMsgStore -> StoreLog 'WriteMode -> IO () - setStoreLog st sl = atomically $ writeTVar (storeLog $ queueStore st) (Just sl) - - closeMsgStore JournalMsgStore {queueStore = st} = do - readTVarIO (storeLog st) >>= mapM_ closeStoreLog - readTVarIO (queues st) >>= mapM_ closeMsgQueue - - -- 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 - withAllMsgQueues tty ms@JournalMsgStore {config} action = ifM (doesDirectoryExist storePath) processStore (pure mempty) + closeMsgStore :: JournalMsgStore s -> IO () + closeMsgStore ms = do + let st = queueStore_ ms + closeQueues $ loadedQueues @(JournalQueue s) st + closeQueueStore @(JournalQueue s) st 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")) + closeQueues qs = readTVarIO qs >>= mapM_ closeMsgQueue - logQueueStates :: JournalMsgStore -> IO () + withActiveMsgQueues :: Monoid a => JournalMsgStore s -> (JournalQueue s -> IO a) -> IO a + withActiveMsgQueues = withQS withLoadedQueues . queueStore_ + + -- This function can only be used in server CLI commands or before server is started. + -- It does not cache queues and is NOT concurrency safe. + unsafeWithAllMsgQueues :: Monoid a => Bool -> JournalMsgStore s -> (JournalQueue s -> IO a) -> IO a + unsafeWithAllMsgQueues tty ms action = case queueStore_ ms of + MQStore st -> withLoadedQueues st run +#if defined(dbServerPostgres) + PQStore st -> foldQueueRecs tty st $ uncurry (mkTempQueue ms) >=> run +#endif + 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 action = case queueStore_ ms of + MQStore st -> + withLoadedQueues st $ \q -> + run $ isolateQueue q op $ action q +#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 + + 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 + lock <- atomically $ getMapLock (queueLocks ms) rId + makeQueue_ ms rId qr lock - getMsgQueue :: JournalMsgStore -> JournalQueue -> Bool -> StoreIO JournalMsgQueue - getMsgQueue ms@JournalMsgStore {random} q'@JournalQueue {recipientId = rId, msgQueue_} forWrite = - StoreIO $ readTVarIO msgQueue_ >>= maybe newQ pure + 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 = + 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 +480,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 +501,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 +514,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 +535,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 +582,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 +601,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,28 +609,32 @@ 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 sq op = tryStore' op (recipientId' sq) . withQueueLock sq op . unStoreIO -updateActiveAt :: JournalQueue -> IO () + 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 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 -isolateQueueId :: String -> JournalMsgStore -> RecipientId -> IO (Either ErrorType a) -> ExceptT ErrorType IO a -isolateQueueId op ms rId = tryStore op rId . withLockMap (queueLocks ms) rId op +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') -openMsgQueue :: JournalMsgStore -> JMQueue -> Bool -> IO JournalMsgQueue +isolateQueueId :: String -> JournalMsgStore s -> RecipientId -> IO (Either ErrorType a) -> ExceptT ErrorType IO a +isolateQueueId op JournalMsgStore {queueLocks, sharedLock} rId = + tryStore op rId . withLockMapWaitShared rId queueLocks sharedLock op + +openMsgQueue :: JournalMsgStore s -> JMQueue -> Bool -> IO (JournalMsgQueue s) openMsgQueue ms@JournalMsgStore {config} q@JMQueue {queueDirectory = dir, statePath} forWrite = do (st_, shouldBackup) <- readQueueState ms statePath case st_ of @@ -581,7 +694,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 +703,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 +719,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 +733,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 +742,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 +765,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 +850,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 +914,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 +926,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 +937,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/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 ac462a71a..43a41d7ca 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,24 @@ 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.StoreLog +import Simplex.Messaging.Server.QueueStore.Types 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 +54,67 @@ 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 - - withAllMsgQueues _ = withActiveMsgQueues + closeMsgStore = closeQueueStore @STMQueue . queueStore_ + {-# INLINE closeMsgStore #-} + withActiveMsgQueues = withLoadedQueues . queueStore_ + {-# INLINE withActiveMsgQueues #-} + unsafeWithAllMsgQueues _ = withLoadedQueues . queueStore_ + {-# INLINE unsafeWithAllMsgQueues #-} + withAllMsgQueues _tty _op ms action = withLoadedQueues (queueStore_ ms) $ atomically . action {-# INLINE withAllMsgQueues #-} - logQueueStates _ = pure () {-# INLINE logQueueStates #-} - logQueueState _ = pure () {-# INLINE logQueueState #-} + queueStore = queueStore_ + {-# INLINE queueStore #-} - recipientId' = recipientId - {-# INLINE recipientId' #-} + mkQueue _ rId qr = STMQueue rId <$> newTVarIO (Just qr) <*> newTVarIO Nothing + {-# INLINE mkQueue #-} - queueRec' = queueRec - {-# INLINE queueRec' #-} + getLoadedQueue :: STMMsgStore -> STMQueue -> STM STMQueue + getLoadedQueue _ = pure + {-# INLINE getLoadedQueue #-} 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 +122,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 +140,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,20 +157,25 @@ 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 () 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 ada1ca333..514b67d7b 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,67 +24,67 @@ 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 () - withAllMsgQueues :: Monoid a => Bool -> s -> (StoreQueue s -> IO a) -> IO a + withActiveMsgQueues :: Monoid a => s -> (StoreQueue s -> IO a) -> IO a + -- This function can only be used in server CLI commands or before server is started. + 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 () - 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) + 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)) -- 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 + unsafeRunStore :: StoreQueue s -> String -> StoreMonad s a -> 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 #-} -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) -{-# INLINE getQueueMessages #-} +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)) getQueueSize :: MsgStoreClass s => s -> StoreQueue s -> ExceptT ErrorType IO Int getQueueSize st q = withPeekMsgQueue st q "getQueueSize" $ maybe (pure 0) (getQueueSize_ . 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 #-} @@ -123,12 +124,14 @@ 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 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..f4c2f108e 100644 --- a/src/Simplex/Messaging/Server/QueueStore.hs +++ b/src/Simplex/Messaging/Server/QueueStore.hs @@ -1,4 +1,6 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE LambdaCase #-} @@ -14,6 +16,13 @@ import Data.Int (Int64) 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.Util (eitherToMaybe) +#endif data QueueRec = QueueRec { recipientKey :: !RcvPublicAuthKey, @@ -56,8 +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 new file mode 100644 index 000000000..3062e2313 --- /dev/null +++ b/src/Simplex/Messaging/Server/QueueStore/Postgres.hs @@ -0,0 +1,441 @@ +{-# LANGUAGE CPP #-} +{-# 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 + ( PostgresQueueStore (..), + PostgresStoreCfg (..), + batchInsertQueues, + foldQueueRecs, + ) +where + +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.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 (Action (..), 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, closeDBStore) +import Simplex.Messaging.Agent.Store.Postgres.Common +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 +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 (IOMode (..), hFlush, stdout) +import UnliftIO.STM + +#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, + dbStoreLog :: Maybe (StoreLog 'WriteMode), + -- this map caches all created and opened queues + queues :: TMap RecipientId q, + -- this map only cashes the queues that were attempted to send messages to, + senders :: TMap SenderId RecipientId, + -- this map only cashes the queues that were attempted to be subscribed to, + notifiers :: TMap NotifierId RecipientId, + notifierLocks :: TMap NotifierId Lock, + deletedTTL :: Int64 + } + +instance StoreQueueClass q => QueueStoreClass q (PostgresQueueStore q) where + type QueueStoreCfg (PostgresQueueStore q) = PostgresStoreCfg + + newQueueStore :: PostgresStoreCfg -> IO (PostgresQueueStore q) + 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, 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 #-} + + 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 + (queueCount, notifierCount) : _ <- + DB.query_ + db + [sql| + SELECT + (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} + + -- 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_" $ E.uninterruptibleMask_ $ runExceptT $ do + 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 + withLog "addStoreQueue" st $ \s -> logCreateQueue s rId qr + pure sq + where + PostgresQueueStore {queues, senders} = st + -- 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 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 = + E.uninterruptibleMask_ $ runExceptT $ do + (rId, qRec) <- + withDB "getQueue_" st $ \db -> firstRow rowToQueueRec AUTH $ + DB.query db (queueRecQuery <> condition <> " AND deleted_at IS NULL") (Only qId) + liftIO $ 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 = + 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) + 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 () + + addQueueNotifier :: PostgresQueueStore q -> q -> NtfCreds -> IO (Either ErrorType (Maybe NotifierId)) + addQueueNotifier st sq ntfCreds@NtfCreds {notifierId = nId, notifierKey, rcvNtfDhSecret} = + 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 -> + 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' + -- 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 + rId = recipientId sq + update db = + DB.execute + db + [sql| + UPDATE msg_queues + SET notifier_id = ?, notifier_key = ?, rcv_ntf_dh_secret = ? + WHERE recipient_id = ? AND deleted_at IS NULL + |] + (nId, notifierKey, rcvNtfDhSecret, rId) + + deleteQueueNotifier :: PostgresQueueStore q -> q -> IO (Either ErrorType (Maybe NotifierId)) + deleteQueueNotifier st sq = + 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 + 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 + [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 rId) + + suspendQueue :: PostgresQueueStore q -> q -> IO (Either ErrorType ()) + 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) $ + withLog "blockQueue" st $ \sl -> logBlockQueue sl (recipientId sq) info + + unblockQueue :: PostgresQueueStore q -> q -> IO (Either ErrorType ()) + 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 = + withQueueRec sq "updateQueueTime" $ \q@QueueRec {updatedAt} -> + if updatedAt == Just t + 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, 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))) + deleteStoreQueue st sq = E.uninterruptibleMask_ $ runExceptT $ do + 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, rId) + atomically $ writeTVar qr Nothing + atomically $ TM.delete (senderId q) $ senders st + forM_ (notifier q) $ \NtfCreds {notifierId} -> atomically $ TM.delete notifierId $ notifiers st + 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 +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 + 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 + 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" + +insertQueueQuery :: Query +insertQueueQuery = + [sql| + INSERT INTO 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) + VALUES (?,?,?,?,?,?,?,?,?,?,?) + |] + +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 + r <- f $ rowToQueueRec row + 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 + progress i = "Processed: " <> show i <> " records" + +queueRecQuery :: Query +queueRecQuery = + [sql| + 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 + |] + +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) + +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_ + in (rId, QueueRec {recipientKey, rcvDhSecret, senderId, senderKey, sndSecure, notifier, status, updatedAt}) + +setStatusDB :: StoreQueueClass q => String -> PostgresQueueStore q -> q -> ServerEntityStatus -> ExceptT ErrorType IO () -> IO (Either ErrorType ()) +setStatusDB op st sq status writeLog = + 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 + +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 () +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 :: forall a q. String -> PostgresQueueStore q -> (DB.Connection -> IO (Either ErrorType a)) -> ExceptT ErrorType IO a +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) + where + err = op <> ", withDB, " <> show e + +withLog :: MonadIO m => String -> PostgresQueueStore q -> (StoreLog 'WriteMode -> IO ()) -> m () +withLog op PostgresQueueStore {dbStoreLog} action = + forM_ dbStoreLog $ \sl -> liftIO $ 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 + _ -> 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 + +#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 + +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/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/src/Simplex/Messaging/Server/QueueStore/Postgres/Migrations.hs b/src/Simplex/Messaging/Server/QueueStore/Postgres/Migrations.hs new file mode 100644 index 000000000..03b6fecf6 --- /dev/null +++ b/src/Simplex/Messaging/Server/QueueStore/Postgres/Migrations.hs @@ -0,0 +1,46 @@ +{-# 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, + 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 UNIQUE INDEX idx_msg_queues_sender_id ON msg_queues(sender_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 2fd3e9912..8a360c3a0 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,222 +11,202 @@ {-# 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', + 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 () + closeQueueStore :: STMQueueStore q -> IO () + closeQueueStore STMQueueStore {queues, senders, notifiers, storeLog} = do + readTVarIO storeLog >>= mapM_ closeStoreLog + atomically $ TM.clear queues + atomically $ TM.clear senders + atomically $ TM.clear notifiers -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_ + loadedQueues = queues + {-# INLINE loadedQueues #-} + compactQueues _ = pure 0 + {-# INLINE compactQueues #-} -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 + queueCounts :: STMQueueStore q -> IO QueueCounts + queueCounts st = do + queueCount <- M.size <$> readTVarIO (queues st) + notifierCount <- M.size <$> readTVarIO (notifiers st) + pure QueueCounts {queueCount, notifierCount} -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} + 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 -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} + 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 -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} + 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 () -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 + 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_ -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 + 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 + + 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 - >>= 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 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..8af65a335 --- /dev/null +++ b/src/Simplex/Messaging/Server/QueueStore/Types.hs @@ -0,0 +1,50 @@ +{-# 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 Data.Int (Int64) +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 + closeQueueStore :: s -> IO () + queueCounts :: s -> IO QueueCounts + loadedQueues :: s -> TMap RecipientId q + 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 ()) + 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 5f38d6b3f..1cc8ebd6c 100644 --- a/src/Simplex/Messaging/Server/StoreLog.hs +++ b/src/Simplex/Messaging/Server/StoreLog.hs @@ -27,14 +27,12 @@ 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 @@ -42,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) @@ -50,10 +47,9 @@ import Data.Time.Format.ISO8601 (iso8601Show, iso8601ParseM) 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, listDirectory, removeFile, renameFile) import System.IO @@ -162,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 @@ -243,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 @@ -253,15 +249,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 - removeStoreLogBackups :: FilePath -> IO () removeStoreLogBackups f = do ts <- getCurrentTime @@ -272,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 @@ -292,11 +280,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..2d92b4b5e 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) @@ -144,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 #-} @@ -180,6 +199,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.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 027b4cff3..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, prevRange, prevVersion, testPort, testPort2, testStoreLogFile2, testStoreMsgsDir2, 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,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 (..), AStoreType (..), 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) @@ -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 cfg {storeLogFile = Just testStoreLogFile2, storeMsgsFile = Just testStoreMsgsDir2} 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 cfg {storeLogFile = Just testStoreLogFile2, storeMsgsFile = Just testStoreMsgsDir2} 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 cfg {storeLogFile = Just testStoreLogFile2, storeMsgsFile = Just testStoreMsgsDir2} 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 {msgStoreType = AMSType SMSMemory, storeMsgsFile = 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 cfg {storeLogFile = Just testStoreLogFile2, storeMsgsFile = Just testStoreMsgsDir2} 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 cfg {storeLogFile = Just testStoreLogFile2, storeMsgsFile = Just testStoreMsgsDir2} 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 cfg {storeLogFile = Just testStoreLogFile2, storeMsgsFile = Just testStoreMsgsDir2} 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 cbca52df1..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, cfgVPrev, testPort, testPort2, testStoreLogFile2, testStoreMsgsDir2, 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 (cfg :: ServerConfig) {storeLogFile = Just testStoreLogFile2, storeMsgsFile = Just testStoreMsgsDir2} 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/CoreTests/MsgStoreTests.hs b/tests/CoreTests/MsgStoreTests.hs index 3484fceb4..adde9ae2b 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 @@ -213,29 +217,26 @@ 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 :: 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 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 - 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 +299,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 +324,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 +395,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 +431,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) @@ -452,13 +453,13 @@ 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 pure () -testReadFileMissing :: JournalMsgStore -> IO () +testReadFileMissing :: JournalMsgStore s -> IO () testReadFileMissing ms = do g <- C.newRandom (rId, qr) <- testNewQueueRec g True @@ -469,9 +470,9 @@ 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 + closeMsgQueue q let path = journalFilePath (queueDirectory $ queue mq) $ journalId rs removeFile path @@ -482,15 +483,15 @@ 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 + closeMsgQueue q let path = journalFilePath (queueDirectory $ queue mq) $ journalId rs removeFile path @@ -500,15 +501,15 @@ 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 + closeMsgQueue q let path = journalFilePath (queueDirectory $ queue mq) $ journalId ws print path removeFile path @@ -523,15 +524,15 @@ 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 + closeMsgQueue q removeFile $ journalFilePath (queueDirectory $ queue mq) $ journalId rs removeFile $ journalFilePath (queueDirectory $ queue mq) $ journalId ws @@ -542,7 +543,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..d871f5b0a 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 @@ -99,17 +101,17 @@ 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 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/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 3c732b7a5..602055b82 100644 --- a/tests/SMPClient.hs +++ b/tests/SMPClient.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} @@ -17,6 +18,8 @@ import Control.Monad.Except (runExceptT) import Data.ByteString.Char8 (ByteString) import Data.List.NonEmpty (NonEmpty) import Network.Socket +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) import qualified Simplex.Messaging.Crypto as C @@ -24,7 +27,8 @@ 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.Server.QueueStore.Postgres.Config (PostgresStoreCfg (..)) import Simplex.Messaging.Transport import Simplex.Messaging.Transport.Client import qualified Simplex.Messaging.Transport.Client as Client @@ -36,10 +40,14 @@ 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 +#if defined(dbServerPostgres) +import Database.PostgreSQL.Simple (ConnectInfo (..), defaultConnectInfo) +#endif + testHost :: NonEmpty TransportHost testHost = "localhost" @@ -61,6 +69,30 @@ 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", + poolSize = 3, + createSchema = True + } + +testStoreDBOpts2 :: DBOpts +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" @@ -89,9 +121,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 +150,36 @@ testSMPClient_ host port vr client = do | otherwise = Nothing cfg :: ServerConfig -cfg = cfgMS (AMSType SMSJournal) +cfg = cfgMS (ASType SQSMemory SMSJournal) -cfgMS :: AMSType -> ServerConfig +cfgJ2 :: ServerConfig +cfgJ2 = journalCfg cfg testStoreLogFile2 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}} + +journalCfgDB :: ServerConfig -> DBOpts -> FilePath -> ServerConfig +journalCfgDB cfg' dbOpts storeMsgsPath' = + let storeCfg = PostgresStoreCfg {dbOpts, dbStoreLogPath = Nothing, confirmMigrations = MCYesUp, deletedTTL = 86400} + in cfg' {serverStoreCfg = ASSCfg SQSPostgres SMSJournal SSCDatabaseJournal {storeCfg, 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 = serverStoreConfig msType, storeNtfsFile = Nothing, allowNewQueues = True, newQueueBasicAuth = Nothing, @@ -164,17 +212,31 @@ cfgMS msType = allowSMPProxy = False, serverClientConcurrency = 2, information = Nothing, - startOptions = StartOptions {maintenance = False, skipWarnings = False} + startOptions = StartOptions {maintenance = False, compactLog = False, skipWarnings = False, confirmMigrations = MCYesUp} } +serverStoreConfig :: AStoreType -> AServerStoreCfg +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 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 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)} @@ -183,29 +245,33 @@ 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}} } 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) - -withSmpServerStoreMsgLogOnMS :: HasCallStack => ATransport -> AMSType -> 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` AMSType SMSJournal) - -withSmpServerStoreLogOnMS :: HasCallStack => ATransport -> AMSType -> 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' = @@ -213,35 +279,40 @@ 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 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 _ -> 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) => 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 +328,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 +339,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 +358,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..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,14 +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' = cfg2 {storeLogFile = Just testStoreLogFile2, storeMsgsFile = Just 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 () @@ -390,10 +395,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,28 +427,27 @@ 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 () -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 986a214d7..824338452 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) @@ -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 @@ -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,7 +562,7 @@ 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 g <- C.newRandom @@ -576,7 +576,8 @@ testWithStoreLog = senderId2 <- newTVarIO NoEntity notifierId <- newTVarIO NoEntity - withSmpServerStoreLogOnMS at msType 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) @@ -609,14 +610,14 @@ testWithStoreLog = logSize testStoreLogFile `shouldReturn` 6 - let cfg' = (cfgMS msType) {msgStoreType = AMSType SMSMemory, storeLogFile = Nothing, storeMsgsFile = 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 () - withSmpServerStoreLogOnMS at msType 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,7 +634,8 @@ testWithStoreLog = Resp "cdab" _ (ERR AUTH) <- signSendRecv h sKey2 ("cdab", sId2, _SEND "hello too") pure () - logSize testStoreLogFile `shouldReturn` 1 + -- 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 @@ -644,13 +646,26 @@ testWithStoreLog = runClient :: Transport c => TProxy c -> (THandleSMP c 'TClient -> IO ()) -> Expectation runClient _ test' = testSMPClient test' `shouldReturn` () -logSize :: FilePath -> IO Int -logSize f = - try (length . B.lines <$> B.readFile f) >>= \case - Right l -> pure l - Left (_ :: SomeException) -> logSize f +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) -testRestoreMessages :: SpecWith (ATransport, AMSType) +logSize :: FilePath -> IO Int +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 removeFileIfExists testStoreLogFile @@ -664,8 +679,8 @@ testRestoreMessages = recipientKey <- newTVarIO Nothing dhShared <- newTVarIO Nothing senderId <- newTVarIO NoEntity - - withSmpServerStoreMsgLogOnMS at msType 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 @@ -685,16 +700,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 logSize testServerStatsBackupFile `shouldReturn` 76 Right stats1 <- strDecode <$> B.readFile testServerStatsBackupFile checkStats stats1 [rId] 5 1 - - withSmpServerStoreMsgLogOnMS at msType 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 @@ -704,15 +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" - - 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 - withSmpServerStoreMsgLogOnMS at msType 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 @@ -724,13 +734,11 @@ 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 + 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 - - removeFile testStoreLogFile removeFileIfExists testStoreMsgsFile whenM (doesDirectoryExist testStoreMsgsDir) $ removeDirectoryRecursive testStoreMsgsDir removeFile testServerStatsBackupFile @@ -759,17 +767,17 @@ 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 + 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 - - withSmpServerStoreMsgLogOnMS at msType 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 @@ -784,23 +792,21 @@ 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 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 () 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 () logSize testStoreLogFile `shouldReturn` 1 @@ -812,14 +818,17 @@ 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 + closeMsgStore ms runTest :: Transport c => TProxy c -> (THandleSMP c 'TClient -> IO ()) -> ThreadId -> Expectation runTest _ test' server = do testSMPClient test' `shouldReturn` () @@ -828,7 +837,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 +855,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 +925,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 +965,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 +985,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 +1005,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,20 +1024,22 @@ 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 + -- TODO [postgres] + 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) (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 + 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 09fb856fd..14007eed8 100644 --- a/tests/Test.hs +++ b/tests/Test.hs @@ -25,7 +25,8 @@ import NtfServerTests (ntfServerTests) import RemoteControl (remoteControlTests) import SMPProxyTests (smpProxyTests) import ServerTests -import Simplex.Messaging.Server.MsgStore.Types (AMSType (..), SMSType (..)) +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) @@ -34,13 +35,22 @@ import Test.Hspec 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 +#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} @@ -52,8 +62,7 @@ main = do setEnv "APNS_KEY_FILE" "./tests/fixtures/AuthKey_H82WD9K9AQ.p8" hspec #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) @@ -74,17 +83,30 @@ main = do describe "Store log tests" storeLogTests describe "TRcvQueues tests" tRcvQueuesTests describe "Util tests" utilTests +#if defined(dbServerPostgres) + aroundAll_ (postgressBracket testServerDBConnectInfo) + $ 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, 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 +#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 describe "XFTP" $ do describe "XFTP server" xftpServerTests describe "XFTP file description" fileDescriptionTests @@ -102,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