smp server: PostgreSQL queue store (#1448)

* smp server: queue store typeclass

* parameterize JournalMsgStore

* typeclass for queue store

* postgres WIP

* compiles, passes tests

* remove StoreType

* split migrations

* progress

* addQueueRec

* reduce type spaghetti

* remove addQueue from typeclass definition

* getQueue

* test postgres storage in SMP server

* fix schema

* comment

* import queues to postgresql

* import queues to postgresql

* log

* fix test

* counts

* ci: test smp server with postgres backend (#1463)

* ci: test smp server with postgres backend

* postgres service

* attempt

* attempt

* empty

* empty

* PGHOST attempt

* PGHOST + softlink attempt

* only softlink attempt

* working attempt (PGHOST)

* remove env var

* empty

* do not start server without DB schema, do not import when schema exists

* export database

* enable all tests, disable two tests

* option for migration confirmation

* comments

---------

Co-authored-by: spaced4ndy <8711996+spaced4ndy@users.noreply.github.com>

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
 

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} =

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

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

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

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
-

src/Simplex/Messaging/Agent/Store/Postgres.hs

@@ -7,6 +7,7 @@
 module Simplex.Messaging.Agent.Store.Postgres
   ( DBOpts (..),
     Migrations.getCurrentMigrations,
+    checkSchemaExists,
     createDBStore,
     closeDBStore,
     reopenDBStore,
@@ -14,13 +15,15 @@ module Simplex.Messaging.Agent.Store.Postgres
   )
 where
 
-import Control.Exception (throwIO)
-import Control.Monad (unless, void)
+import Control.Concurrent.STM
+import Control.Exception (bracketOnError, finally, onException, throwIO)
+import Control.Logger.Simple (logError)
+import Control.Monad (void, when)
 import Data.ByteString (ByteString)
 import Data.Functor (($>))
-import Data.String (fromString)
 import Data.Text (Text)
 import Database.PostgreSQL.Simple (Only (..))
+import Database.PostgreSQL.Simple.Types (Query (..))
 import qualified Database.PostgreSQL.Simple as PSQL
 import Database.PostgreSQL.Simple.SqlQQ (sql)
 import Simplex.Messaging.Agent.Store.Migrations (DBMigrate (..), sharedMigrateSchema)
@@ -28,23 +31,16 @@ import qualified Simplex.Messaging.Agent.Store.Postgres.Migrations as Migrations
 import Simplex.Messaging.Agent.Store.Postgres.Common
 import qualified Simplex.Messaging.Agent.Store.Postgres.DB as DB
 import Simplex.Messaging.Agent.Store.Shared (Migration (..), MigrationConfirmation (..), MigrationError (..))
-import Simplex.Messaging.Util (ifM)
-import UnliftIO.Exception (bracketOnError, onException)
+import Simplex.Messaging.Util (ifM, safeDecodeUtf8)
+import System.Exit (exitFailure)
 import UnliftIO.MVar
-import UnliftIO.STM
-
-data DBOpts = DBOpts
-  { connstr :: ByteString,
-    schema :: String
-  }
 
 -- | Create a new Postgres DBStore with the given connection string, schema name and migrations.
 -- If passed schema does not exist in connectInfo database, it will be created.
 -- Applies necessary migrations to schema.
--- TODO [postgres] authentication / user password, db encryption (?)
 createDBStore :: DBOpts -> [Migration] -> MigrationConfirmation -> IO (Either MigrationError DBStore)
-createDBStore DBOpts {connstr, schema} migrations confirmMigrations = do
-  st <- connectPostgresStore connstr schema
+createDBStore opts migrations confirmMigrations = do
+  st <- connectPostgresStore opts
   r <- migrateSchema st `onException` closeDBStore st
   case r of
     Right () -> pure $ Right st
@@ -56,35 +52,50 @@ createDBStore DBOpts {connstr, schema} migrations confirmMigrations = do
           dbm = DBMigrate {initialize, getCurrent, run = Migrations.run st, backup = pure ()}
        in sharedMigrateSchema dbm (dbNew st) migrations confirmMigrations
 
-connectPostgresStore :: ByteString -> String -> IO DBStore
-connectPostgresStore dbConnstr dbSchema = do
-  (dbConn, dbNew) <- connectDB dbConnstr dbSchema -- TODO [postgres] analogue for dbBusyLoop?
+connectPostgresStore :: DBOpts -> IO DBStore
+connectPostgresStore DBOpts {connstr, schema, createSchema} = do
+  (dbConn, dbNew) <- connectDB connstr schema createSchema -- TODO [postgres] analogue for dbBusyLoop?
   dbConnection <- newMVar dbConn
   dbClosed <- newTVarIO False
-  pure DBStore {dbConnstr, dbSchema, dbConnection, dbNew, dbClosed}
+  pure DBStore {dbConnstr = connstr, dbSchema = schema, dbConnection, dbNew, dbClosed}
 
-connectDB :: ByteString -> String -> IO (DB.Connection, Bool)
-connectDB connstr schema = do
+connectDB :: ByteString -> ByteString -> Bool -> IO (DB.Connection, Bool)
+connectDB connstr schema createSchema = do
   db <- PSQL.connectPostgreSQL connstr
-  schemaExists <- prepare db `onException` PSQL.close db
-  let dbNew = not schemaExists
+  dbNew <- prepare db `onException` PSQL.close db
   pure (db, dbNew)
   where
     prepare db = do
       void $ PSQL.execute_ db "SET client_min_messages TO WARNING"
-      [Only schemaExists] <-
-        PSQL.query
-          db
-          [sql|
-            SELECT EXISTS (
-              SELECT 1 FROM pg_catalog.pg_namespace
-              WHERE nspname = ?
-            )
-          |]
-          (Only schema)
-      unless schemaExists $ void $ PSQL.execute_ db (fromString $ "CREATE SCHEMA " <> schema)
-      void $ PSQL.execute_ db (fromString $ "SET search_path TO " <> schema)
-      pure schemaExists
+      dbNew <- not <$> doesSchemaExist db schema
+      when dbNew $
+        if createSchema
+          then void $ PSQL.execute_ db $ Query $ "CREATE SCHEMA " <> schema
+          else do
+            logError $ "connectPostgresStore, schema " <> safeDecodeUtf8 schema <> " does not exist, exiting."
+            PSQL.close db
+            exitFailure
+      void $ PSQL.execute_ db $ Query $ "SET search_path TO " <> schema
+      pure dbNew
+
+checkSchemaExists :: ByteString -> ByteString -> IO Bool
+checkSchemaExists connstr schema = do
+  db <- PSQL.connectPostgreSQL connstr
+  doesSchemaExist db schema `finally` DB.close db
+
+doesSchemaExist :: DB.Connection -> ByteString -> IO Bool
+doesSchemaExist db schema = do
+  [Only schemaExists] <-
+    PSQL.query
+      db
+      [sql|
+        SELECT EXISTS (
+          SELECT 1 FROM pg_catalog.pg_namespace
+          WHERE nspname = ?
+        )
+      |]
+      (Only schema)
+  pure schemaExists
 
 -- can share with SQLite
 closeDBStore :: DBStore -> IO ()
@@ -100,7 +111,7 @@ openPostgresStore_ DBStore {dbConnstr, dbSchema, dbConnection, dbClosed} =
     (takeMVar dbConnection)
     (tryPutMVar dbConnection)
     $ \_dbConn -> do
-      (dbConn, _dbNew) <- connectDB dbConnstr dbSchema
+      (dbConn, _dbNew) <- connectDB dbConnstr dbSchema False
       atomically $ writeTVar dbClosed False
       putMVar dbConnection dbConn
 
@@ -110,6 +121,6 @@ reopenDBStore st@DBStore {dbClosed} =
   where
     open = openPostgresStore_ st
 
--- TODO [postgres] not necessary for postgres (used for ExecAgentStoreSQL, ExecChatStoreSQL)
+-- not used with postgres client (used for ExecAgentStoreSQL, ExecChatStoreSQL)
 execSQL :: PSQL.Connection -> Text -> IO [Text]
 execSQL _db _query = throwIO (userError "not implemented")

src/Simplex/Messaging/Agent/Store/Postgres/Common.hs

@@ -2,6 +2,7 @@
 
 module Simplex.Messaging.Agent.Store.Postgres.Common
   ( DBStore (..),
+    DBOpts (..),
     withConnection,
     withConnection',
     withTransaction,
@@ -18,25 +19,36 @@ import UnliftIO.STM
 -- TODO [postgres] use log_min_duration_statement instead of custom slow queries (SQLite's Connection type)
 data DBStore = DBStore
   { dbConnstr :: ByteString,
-    dbSchema :: String,
+    dbSchema :: ByteString,
     dbConnection :: MVar PSQL.Connection,
     dbClosed :: TVar Bool,
     dbNew :: Bool
   }
 
+data DBOpts = DBOpts
+  { connstr :: ByteString,
+    schema :: ByteString,
+    createSchema :: Bool
+  }
+  deriving (Show)
+
 -- TODO [postgres] connection pool
 withConnectionPriority :: DBStore -> Bool -> (PSQL.Connection -> IO a) -> IO a
 withConnectionPriority DBStore {dbConnection} _priority action =
   withMVar dbConnection action
+{-# INLINE withConnectionPriority #-}
 
 withConnection :: DBStore -> (PSQL.Connection -> IO a) -> IO a
 withConnection st = withConnectionPriority st False
+{-# INLINE withConnection #-}
 
 withConnection' :: DBStore -> (PSQL.Connection -> IO a) -> IO a
 withConnection' = withConnection
+{-# INLINE withConnection' #-}
 
 withTransaction' :: DBStore -> (PSQL.Connection -> IO a) -> IO a
 withTransaction' = withTransaction
+{-# INLINE withTransaction' #-}
 
 withTransaction :: DBStore -> (PSQL.Connection -> IO a) -> IO a
 withTransaction st = withTransactionPriority st False

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"

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

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

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)

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.

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

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, (<$?>))
 

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

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

src/Simplex/Messaging/Server.hs

@@ -13,6 +13,7 @@
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TupleSections #-}
+{-# LANGUAGE TypeApplications #-}
 
 -- |
 -- Module      : Simplex.Messaging.Server
@@ -96,14 +97,14 @@ import Simplex.Messaging.Server.Control
 import Simplex.Messaging.Server.Env.STM as Env
 import Simplex.Messaging.Server.Expiration
 import Simplex.Messaging.Server.MsgStore
-import Simplex.Messaging.Server.MsgStore.Journal (JournalQueue, closeMsgQueue)
+import Simplex.Messaging.Server.MsgStore.Journal (JournalMsgStore, JournalQueue, closeMsgQueue)
 import Simplex.Messaging.Server.MsgStore.STM
 import Simplex.Messaging.Server.MsgStore.Types
 import Simplex.Messaging.Server.NtfStore
 import Simplex.Messaging.Server.Prometheus
 import Simplex.Messaging.Server.QueueStore
 import Simplex.Messaging.Server.QueueStore.QueueInfo
-import Simplex.Messaging.Server.QueueStore.STM
+import Simplex.Messaging.Server.QueueStore.Types
 import Simplex.Messaging.Server.Stats
 import Simplex.Messaging.Server.StoreLog (foldLogLines)
 import Simplex.Messaging.TMap (TMap)
@@ -234,7 +235,7 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg, startOpt
 
     saveServer :: Bool -> M ()
     saveServer drainMsgs = do
-      ams@(AMS _ ms) <- asks msgStore
+      ams@(AMS _ _ ms) <- asks msgStore
       liftIO $ saveServerMessages drainMsgs ams >> closeMsgStore ms
       saveServerNtfs
       saveServerStats
@@ -284,17 +285,17 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg, startOpt
               -- This case catches Just Nothing - it cannot happen here.
               -- Nothing is there only before client thread is started.
               _ -> TM.lookup qId ss >>= mapM readTVar -- do not insert client if it is already disconnected, but send END to any other client
-            clientToBeNotified ac@(AClient _ c')
+            clientToBeNotified ac@(AClient _ _ c')
               | clntId == clientId c' = pure Nothing
               | otherwise = (\yes -> if yes then Just ((qId, subscribed), ac) else Nothing) <$> readTVar (connected c')
         endPreviousSubscriptions :: ((QueueId, Subscribed), AClient) -> IO (Maybe s)
-        endPreviousSubscriptions (qEvt@(qId, _), ac@(AClient _ c)) = do
+        endPreviousSubscriptions (qEvt@(qId, _), ac@(AClient _ _ c)) = do
           atomically $ modifyTVar' (pendingEvts s) $ IM.alter (Just . maybe [qEvt] (qEvt <|)) (clientId c)
           atomically $ do
             sub <- TM.lookupDelete qId (clientSubs c)
             removeWhenNoSubs ac $> sub
         -- remove client from server's subscribed cients
-        removeWhenNoSubs (AClient _ c) = whenM (null <$> readTVar (clientSubs c)) $ modifyTVar' (subClnts s) $ IM.delete (clientId c)
+        removeWhenNoSubs (AClient _ _ c) = whenM (null <$> readTVar (clientSubs c)) $ modifyTVar' (subClnts s) $ IM.delete (clientId c)
 
     deliverNtfsThread :: Server -> M ()
     deliverNtfsThread Server {ntfSubClients} = do
@@ -305,7 +306,7 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg, startOpt
         threadDelay ntfInt
         readTVarIO ntfSubClients >>= mapM_ (deliverNtfs ns stats)
       where
-        deliverNtfs ns stats (AClient _ Client {clientId, ntfSubscriptions, sndQ, connected}) =
+        deliverNtfs ns stats (AClient _ _ Client {clientId, ntfSubscriptions, sndQ, connected}) =
           whenM (currentClient readTVarIO) $ do
             subs <- readTVarIO ntfSubscriptions
             ntfQs <- M.assocs . M.filterWithKey (\nId _ -> M.member nId subs) <$> readTVarIO ns
@@ -351,7 +352,7 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg, startOpt
           ends <- atomically $ swapTVar ref IM.empty
           unless (null ends) $ forM_ (IM.assocs ends) $ \(cId, qEvts) ->
             mapM_ (queueEvts qEvts) . join . IM.lookup cId =<< readTVarIO cls
-        queueEvts qEvts (AClient _ c@Client {connected, sndQ = q}) =
+        queueEvts qEvts (AClient _ _ c@Client {connected, sndQ = q}) =
           whenM (readTVarIO connected) $ do
             sent <- atomically $ ifM (isFullTBQueue q) (pure False) (writeTBQueue q ts $> True)
             if sent
@@ -389,7 +390,7 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg, startOpt
 
     expireMessagesThread :: ExpirationConfig -> M ()
     expireMessagesThread expCfg = do
-      AMS _ ms <- asks msgStore
+      AMS _ _ ms <- asks msgStore
       let interval = checkInterval expCfg * 1000000
       stats <- asks serverStats
       labelMyThread "expireMessagesThread"
@@ -434,9 +435,9 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg, startOpt
       liftIO $ threadDelay' $ 1000000 * (initialDelay + if initialDelay < 0 then 86400 else 0)
       ss@ServerStats {fromTime, qCreated, qSecured, qDeletedAll, qDeletedAllB, qDeletedNew, qDeletedSecured, qSub, qSubAllB, qSubAuth, qSubDuplicate, qSubProhibited, qSubEnd, qSubEndB, ntfCreated, ntfDeleted, ntfDeletedB, ntfSub, ntfSubB, ntfSubAuth, ntfSubDuplicate, msgSent, msgSentAuth, msgSentQuota, msgSentLarge, msgRecv, msgRecvGet, msgGet, msgGetNoMsg, msgGetAuth, msgGetDuplicate, msgGetProhibited, msgExpired, activeQueues, msgSentNtf, msgRecvNtf, activeQueuesNtf, qCount, msgCount, ntfCount, pRelays, pRelaysOwn, pMsgFwds, pMsgFwdsOwn, pMsgFwdsRecv}
         <- asks serverStats
-      AMS _ st <- asks msgStore
-      let STMQueueStore {queues, notifiers} = stmQueueStore st
-          interval = 1000000 * logInterval
+      AMS _ _ (st :: s) <- asks msgStore
+      QueueCounts {queueCount, notifierCount} <- liftIO $ queueCounts @(StoreQueue s) $ queueStore st
+      let interval = 1000000 * logInterval
       forever $ do
         withFile statsFilePath AppendMode $ \h -> liftIO $ do
           hSetBuffering h LineBuffering
@@ -489,8 +490,6 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg, startOpt
           pMsgFwdsOwn' <- getResetProxyStatsData pMsgFwdsOwn
           pMsgFwdsRecv' <- atomicSwapIORef pMsgFwdsRecv 0
           qCount' <- readIORef qCount
-          qCount'' <- M.size <$> readTVarIO queues
-          notifierCount' <- M.size <$> readTVarIO notifiers
           msgCount' <- readIORef msgCount
           ntfCount' <- readIORef ntfCount
           hPutStrLn h $
@@ -543,13 +542,13 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg, startOpt
                        "0", -- dayCount psSub; psSub is removed to reduce memory usage
                        "0", -- weekCount psSub
                        "0", -- monthCount psSub
-                       show qCount'',
+                       show queueCount,
                        show ntfCreated',
                        show ntfDeleted',
                        show ntfSub',
                        show ntfSubAuth',
                        show ntfSubDuplicate',
-                       show notifierCount',
+                       show notifierCount,
                        show qDeletedAllB',
                        show qSubAllB',
                        show qSubEnd',
@@ -575,7 +574,7 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg, startOpt
     savePrometheusMetrics saveInterval metricsFile = do
       labelMyThread "savePrometheusMetrics"
       liftIO $ putStrLn $ "Prometheus metrics saved every " <> show saveInterval <> " seconds to " <> metricsFile
-      AMS _ st <- asks msgStore
+      AMS _ _ st <- asks msgStore
       ss <- asks serverStats
       env <- ask
       let interval = 1000000 * saveInterval
@@ -586,14 +585,12 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg, startOpt
         rtm <- getRealTimeMetrics env
         T.writeFile metricsFile $ prometheusMetrics sm rtm ts
 
-    getServerMetrics :: STMStoreClass s => s -> ServerStats -> IO ServerMetrics
+    getServerMetrics :: forall s. MsgStoreClass s => s -> ServerStats -> IO ServerMetrics
     getServerMetrics st ss = do
       d <- getServerStatsData ss
       let ps = periodStatDataCounts $ _activeQueues d
           psNtf = periodStatDataCounts $ _activeQueuesNtf d
-          STMQueueStore {queues, notifiers} = stmQueueStore st
-      queueCount <- M.size <$> readTVarIO queues
-      notifierCount <- M.size <$> readTVarIO notifiers
+      QueueCounts {queueCount, notifierCount} <- queueCounts @(StoreQueue s) $ queueStore st
       pure ServerMetrics {statsData = d, activeQueueCounts = ps, activeNtfCounts = psNtf, queueCount, notifierCount}
 
     getRealTimeMetrics :: Env -> IO RealTimeMetrics
@@ -670,7 +667,7 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg, startOpt
               CPClients -> withAdminRole $ do
                 active <- unliftIO u (asks clients) >>= readTVarIO
                 hPutStrLn h "clientId,sessionId,connected,createdAt,rcvActiveAt,sndActiveAt,age,subscriptions"
-                forM_ (IM.toList active) $ \(cid, cl) -> forM_ cl $ \(AClient _ Client {sessionId, connected, createdAt, rcvActiveAt, sndActiveAt, subscriptions}) -> do
+                forM_ (IM.toList active) $ \(cid, cl) -> forM_ cl $ \(AClient _ _ Client {sessionId, connected, createdAt, rcvActiveAt, sndActiveAt, subscriptions}) -> do
                   connected' <- bshow <$> readTVarIO connected
                   rcvActiveAt' <- strEncode <$> readTVarIO rcvActiveAt
                   sndActiveAt' <- strEncode <$> readTVarIO sndActiveAt
@@ -680,9 +677,9 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg, startOpt
                   hPutStrLn h . B.unpack $ B.intercalate "," [bshow cid, encode sessionId, connected', strEncode createdAt, rcvActiveAt', sndActiveAt', bshow age, subscriptions']
               CPStats -> withUserRole $ do
                 ss <- unliftIO u $ asks serverStats
-                AMS _ st <- unliftIO u $ asks msgStore
-                let STMQueueStore {queues, notifiers} = stmQueueStore st
-                    getStat :: (ServerStats -> IORef a) -> IO a
+                AMS _ _ (st :: s) <- unliftIO u $ asks msgStore
+                QueueCounts {queueCount, notifierCount} <- queueCounts @(StoreQueue s) $ queueStore st
+                let getStat :: (ServerStats -> IORef a) -> IO a
                     getStat var = readIORef (var ss)
                     putStat :: Show a => String -> (ServerStats -> IORef a) -> IO ()
                     putStat label var = getStat var >>= \v -> hPutStrLn h $ label <> ": " <> show v
@@ -719,9 +716,7 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg, startOpt
                 putStat "msgNtfsB" msgNtfsB
                 putStat "msgNtfExpired" msgNtfExpired
                 putStat "qCount" qCount
-                qCount2 <- M.size <$> readTVarIO queues
-                hPutStrLn h $ "qCount 2: " <> show qCount2
-                notifierCount <- M.size <$> readTVarIO notifiers
+                hPutStrLn h $ "qCount 2: " <> show queueCount
                 hPutStrLn h $ "notifiers: " <> show notifierCount
                 putStat "msgCount" msgCount
                 putStat "ntfCount" ntfCount
@@ -822,7 +817,7 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg, startOpt
                       where
                         addSubs :: (Int, (Int, Int, Int, Int), Int, (Natural, Natural, Natural)) -> Maybe AClient -> IO (Int, (Int, Int, Int, Int), Int, (Natural, Natural, Natural))
                         addSubs acc Nothing = pure acc
-                        addSubs (!subCnt, cnts@(!c1, !c2, !c3, !c4), !clCnt, !qs) (Just acl@(AClient _ cl)) = do
+                        addSubs (!subCnt, cnts@(!c1, !c2, !c3, !c4), !clCnt, !qs) (Just acl@(AClient _ _ cl)) = do
                           subs <- readTVarIO $ subSel cl
                           cnts' <- case countSubs_ of
                             Nothing -> pure cnts
@@ -835,7 +830,7 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg, startOpt
                           pure (subCnt + cnt, cnts', clCnt', qs')
                     clientTBQueueLengths' :: Foldable t => t (Maybe AClient) -> IO (Natural, Natural, Natural)
                     clientTBQueueLengths' = foldM (\acc -> maybe (pure acc) (addQueueLengths acc)) (0, 0, 0)
-                    addQueueLengths (!rl, !sl, !ml) (AClient _ cl) = do
+                    addQueueLengths (!rl, !sl, !ml) (AClient _ _ cl) = do
                       (rl', sl', ml') <- queueLengths cl
                       pure (rl + rl', sl + sl', ml + ml')
                     queueLengths Client {rcvQ, sndQ, msgQ} = do
@@ -855,7 +850,7 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg, startOpt
                               SubThread _ -> (c1, c2, c3 + 1, c4)
                           ProhibitSub -> pure (c1, c2, c3, c4 + 1)
               CPDelete sId -> withUserRole $ unliftIO u $ do
-                AMS _ st <- asks msgStore
+                AMS _ _ st <- asks msgStore
                 r <- liftIO $ runExceptT $ do
                   q <- ExceptT $ getQueue st SSender sId
                   ExceptT $ deleteQueueSize st q
@@ -865,27 +860,27 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg, startOpt
                     updateDeletedStats qr
                     liftIO $ hPutStrLn h $ "ok, " <> show numDeleted <> " messages deleted"
               CPStatus sId -> withUserRole $ unliftIO u $ do
-                AMS _ st <- asks msgStore
+                AMS _ _ st <- asks msgStore
                 q <- liftIO $ getQueueRec st SSender sId
                 liftIO $ hPutStrLn h $ case q of
                   Left e -> "error: " <> show e
                   Right (_, QueueRec {sndSecure, status, updatedAt}) ->
                     "status: " <> show status <> ", updatedAt: " <> show updatedAt <> ", sndSecure: " <> show sndSecure
               CPBlock sId info -> withUserRole $ unliftIO u $ do
-                AMS _ st <- asks msgStore
+                AMS _ _ (st :: s) <- asks msgStore
                 r <- liftIO $ runExceptT $ do
                   q <- ExceptT $ getQueue st SSender sId
-                  ExceptT $ blockQueue st q info
+                  ExceptT $ blockQueue (queueStore st) q info
                 case r of
                   Left e -> liftIO $ hPutStrLn h $ "error: " <> show e
                   Right () -> do
                     incStat . qBlocked =<< asks serverStats
                     liftIO $ hPutStrLn h "ok"
               CPUnblock sId -> withUserRole $ unliftIO u $ do
-                AMS _ st <- asks msgStore
+                AMS _ _ (st :: s) <- asks msgStore
                 r <- liftIO $ runExceptT $ do
                   q <- ExceptT $ getQueue st SSender sId
-                  ExceptT $ unblockQueue st q
+                  ExceptT $ unblockQueue (queueStore st) q
                 liftIO $ hPutStrLn h $ case r of
                   Left e -> "error: " <> show e
                   Right () -> "ok"
@@ -917,13 +912,13 @@ runClientTransport h@THandle {params = thParams@THandleParams {thVersion, sessio
   nextClientId <- asks clientSeq
   clientId <- atomically $ stateTVar nextClientId $ \next -> (next, next + 1)
   atomically $ modifyTVar' active $ IM.insert clientId Nothing
-  AMS msType ms <- asks msgStore
-  c <- liftIO $ newClient msType clientId q thVersion sessionId ts
-  runClientThreads msType ms active c clientId `finally` clientDisconnected c
+  AMS qt mt ms <- asks msgStore
+  c <- liftIO $ newClient qt mt clientId q thVersion sessionId ts
+  runClientThreads qt mt ms active c clientId `finally` clientDisconnected c
   where
-    runClientThreads :: STMStoreClass (MsgStore s) => SMSType s -> MsgStore s -> TVar (IM.IntMap (Maybe AClient)) -> Client (MsgStore s) -> IS.Key -> M ()
-    runClientThreads msType ms active c clientId = do
-      atomically $ modifyTVar' active $ IM.insert clientId $ Just (AClient msType c)
+    runClientThreads :: MsgStoreClass (MsgStore qs ms) => SQSType qs -> SMSType ms -> MsgStore qs ms -> TVar (IM.IntMap (Maybe AClient)) -> Client (MsgStore qs ms) -> IS.Key -> M ()
+    runClientThreads qt mt ms active c clientId = do
+      atomically $ modifyTVar' active $ IM.insert clientId $ Just (AClient qt mt c)
       s <- asks server
       expCfg <- asks $ inactiveClientExpiration . config
       th <- newMVar h -- put TH under a fair lock to interleave messages and command responses
@@ -967,7 +962,7 @@ clientDisconnected c@Client {clientId, subscriptions, ntfSubscriptions, connecte
           mapM_ (\c' -> atomically $ whenM (sameClientId c <$> readTVar c') $ TM.delete qId srvSubs)
 
 sameClientId :: Client s -> AClient -> Bool
-sameClientId Client {clientId} (AClient _ Client {clientId = cId'}) = clientId == cId'
+sameClientId Client {clientId} ac = clientId == clientId' ac
 
 cancelSub :: Sub -> IO ()
 cancelSub s = case subThread s of
@@ -977,7 +972,7 @@ cancelSub s = case subThread s of
       _ -> pure ()
   ProhibitSub -> pure ()
 
-receive :: forall c s. (Transport c, STMStoreClass s) => THandleSMP c 'TServer -> s -> Client s -> M ()
+receive :: forall c s. (Transport c, MsgStoreClass s) => THandleSMP c 'TServer -> s -> Client s -> M ()
 receive h@THandle {params = THandleParams {thAuth}} ms Client {rcvQ, sndQ, rcvActiveAt, sessionId} = do
   labelMyThread . B.unpack $ "client $" <> encode sessionId <> " receive"
   sa <- asks serverActive
@@ -1077,7 +1072,7 @@ data VerificationResult s = VRVerified (Maybe (StoreQueue s, QueueRec)) | VRFail
 -- - the queue or party key do not exist.
 -- In all cases, the time of the verification should depend only on the provided authorization type,
 -- a dummy key is used to run verification in the last two cases, and failure is returned irrespective of the result.
-verifyTransmission :: forall s. STMStoreClass s => s -> Maybe (THandleAuth 'TServer, C.CbNonce) -> Maybe TransmissionAuth -> ByteString -> QueueId -> Cmd -> M (VerificationResult s)
+verifyTransmission :: forall s. MsgStoreClass s => s -> Maybe (THandleAuth 'TServer, C.CbNonce) -> Maybe TransmissionAuth -> ByteString -> QueueId -> Cmd -> M (VerificationResult s)
 verifyTransmission ms auth_ tAuth authorized queueId cmd =
   case cmd of
     Cmd SRecipient (NEW k _ _ _ _) -> pure $ Nothing `verifiedWith` k
@@ -1154,7 +1149,7 @@ forkClient Client {endThreads, endThreadSeq} label action = do
     action `finally` atomically (modifyTVar' endThreads $ IM.delete tId)
   mkWeakThreadId t >>= atomically . modifyTVar' endThreads . IM.insert tId
 
-client :: forall s. STMStoreClass s => THandleParams SMPVersion 'TServer -> Server -> s -> Client s -> M ()
+client :: forall s. MsgStoreClass s => THandleParams SMPVersion 'TServer -> Server -> s -> Client s -> M ()
 client
   thParams'
   Server {subscribedQ, ntfSubscribedQ, subscribers}
@@ -1325,7 +1320,7 @@ client
 
         secureQueue_ :: StoreQueue s -> SndPublicAuthKey -> M BrokerMsg
         secureQueue_ q sKey = do
-          liftIO (secureQueue ms q sKey) >>= \case
+          liftIO (secureQueue (queueStore ms) q sKey) >>= \case
             Left e -> pure $ ERR e
             Right () -> do
               stats <- asks serverStats
@@ -1343,7 +1338,7 @@ client
             addNotifierRetry n rcvPublicDhKey rcvNtfDhSecret = do
               notifierId <- randomId =<< asks (queueIdBytes . config)
               let ntfCreds = NtfCreds {notifierId, notifierKey, rcvNtfDhSecret}
-              liftIO (addQueueNotifier ms q ntfCreds) >>= \case
+              liftIO (addQueueNotifier (queueStore ms) q ntfCreds) >>= \case
                 Left DUPLICATE_ -> addNotifierRetry (n - 1) rcvPublicDhKey rcvNtfDhSecret
                 Left e -> pure $ ERR e
                 Right nId_ -> do
@@ -1353,7 +1348,7 @@ client
 
         deleteQueueNotifier_ :: StoreQueue s -> M (Transmission BrokerMsg)
         deleteQueueNotifier_ q =
-          liftIO (deleteQueueNotifier ms q) >>= \case
+          liftIO (deleteQueueNotifier (queueStore ms) q) >>= \case
             Right (Just nId) -> do
               -- Possibly, the same should be done if the queue is suspended, but currently we do not use it
               stats <- asks serverStats
@@ -1366,7 +1361,7 @@ client
             Left e -> pure $ err e
 
         suspendQueue_ :: (StoreQueue s, QueueRec) -> M (Transmission BrokerMsg)
-        suspendQueue_ (q, _) = liftIO $ either err (const ok) <$> suspendQueue ms q
+        suspendQueue_ (q, _) = liftIO $ either err (const ok) <$> suspendQueue (queueStore ms) q
 
         subscribeQueue :: StoreQueue s -> QueueRec -> M (Transmission BrokerMsg)
         subscribeQueue q qr =
@@ -1383,7 +1378,7 @@ client
                   incStat $ qSubDuplicate stats
                   atomically (tryTakeTMVar $ delivered s) >> deliver False s
           where
-            rId = recipientId' q
+            rId = recipientId q
             newSub :: M Sub
             newSub = time "SUB newSub" . atomically $ do
               writeTQueue subscribedQ (rId, clientId, True)
@@ -1447,7 +1442,7 @@ client
               t <- liftIO getSystemDate
               if updatedAt == Just t
                 then action q qr
-                else liftIO (updateQueueTime ms q t) >>= either (pure . err) (action q)
+                else liftIO (updateQueueTime (queueStore ms) q t) >>= either (pure . err) (action q)
 
         subscribeNotifications :: M (Transmission BrokerMsg)
         subscribeNotifications = do
@@ -1544,10 +1539,10 @@ client
                           when (notification msgFlags) $ do
                             mapM_ (`enqueueNotification` msg) (notifier qr)
                             incStat $ msgSentNtf stats
-                            liftIO $ updatePeriodStats (activeQueuesNtf stats) (recipientId' q)
+                            liftIO $ updatePeriodStats (activeQueuesNtf stats) (recipientId q)
                           incStat $ msgSent stats
                           incStat $ msgCount stats
-                          liftIO $ updatePeriodStats (activeQueues stats) (recipientId' q)
+                          liftIO $ updatePeriodStats (activeQueues stats) (recipientId q)
                           pure ok
           where
             mkMessage :: MsgId -> C.MaxLenBS MaxMessageLen -> IO Message
@@ -1575,14 +1570,14 @@ client
               whenM (TM.memberIO rId subscribers) $
                 atomically deliverToSub >>= mapM_ forkDeliver
               where
-                rId = recipientId' q
+                rId = recipientId q
                 deliverToSub =
                   -- lookup has ot be in the same transaction,
                   -- so that if subscription ends, it re-evalutates
                   -- and delivery is cancelled -
                   -- the new client will receive message in response to SUB.
                   (TM.lookup rId subscribers >>= mapM readTVar)
-                    $>>= \rc@(AClient _ Client {subscriptions = subs, sndQ = sndQ'}) -> TM.lookup rId subs
+                    $>>= \rc@(AClient _ _ Client {subscriptions = subs, sndQ = sndQ'}) -> TM.lookup rId subs
                     $>>= \s@Sub {subThread, delivered} -> case subThread of
                       ProhibitSub -> pure Nothing
                       ServerSub st -> readTVar st >>= \case
@@ -1599,7 +1594,7 @@ client
                   let encMsg = encryptMsg qr msg
                   writeTBQueue sndQ' [(CorrId "", rId, MSG encMsg)]
                   void $ setDelivered s msg
-                forkDeliver ((AClient _ rc@Client {sndQ = sndQ'}), s@Sub {delivered}, st) = do
+                forkDeliver ((AClient _ _ rc@Client {sndQ = sndQ'}), s@Sub {delivered}, st) = do
                   t <- mkWeakThreadId =<< forkIO deliverThread
                   atomically $ modifyTVar' st $ \case
                     -- this case is needed because deliverThread can exit before it
@@ -1798,10 +1793,10 @@ randomId = fmap EntityId . randomId'
 
 saveServerMessages :: Bool -> AMsgStore -> IO ()
 saveServerMessages drainMsgs = \case
-  AMS SMSMemory ms@STMMsgStore {storeConfig = STMStoreConfig {storePath}} -> case storePath of
+  AMS SQSMemory SMSMemory ms@STMMsgStore {storeConfig = STMStoreConfig {storePath}} -> case storePath of
     Just f -> exportMessages False ms f drainMsgs
     Nothing -> logInfo "undelivered messages are not saved"
-  AMS SMSJournal _ -> logInfo "closed journal message storage"
+  AMS _ SMSJournal _ -> logInfo "closed journal message storage"
 
 exportMessages :: MsgStoreClass s => Bool -> s -> FilePath -> Bool -> IO ()
 exportMessages tty ms f drainMsgs = do
@@ -1814,7 +1809,7 @@ exportMessages tty ms f drainMsgs = do
         exitFailure
   where
     saveQueueMsgs h q = do
-      let rId = recipientId' q
+      let rId = recipientId q
       runExceptT (getQueueMessages drainMsgs ms q) >>= \case
         Right msgs -> Sum (length msgs) <$ BLD.hPutBuilder h (encodeMessages rId msgs)
         Left e -> do
@@ -1830,41 +1825,46 @@ processServerMessages StartOptions {skipWarnings} = do
     where
       processMessages :: Maybe Int64 -> Bool -> AMsgStore -> IO (Maybe MessageStats)
       processMessages old_ expire = \case
-        AMS SMSMemory ms@STMMsgStore {storeConfig = STMStoreConfig {storePath}} -> case storePath of
+        AMS SQSMemory SMSMemory ms@STMMsgStore {storeConfig = STMStoreConfig {storePath}} -> case storePath of
           Just f -> ifM (doesFileExist f) (Just <$> importMessages False ms f old_ skipWarnings) (pure Nothing)
           Nothing -> pure Nothing
-        AMS SMSJournal ms
-          | expire -> Just <$> case old_ of
-              Just old -> do
-                logInfo "expiring journal store messages..."
-                withAllMsgQueues False ms $ processExpireQueue old
-              Nothing -> do
-                logInfo "validating journal store messages..."
-                withAllMsgQueues False ms $ processValidateQueue
-          | otherwise -> logWarn "skipping message expiration" $> Nothing
-          where
-            processExpireQueue old q =
-              runExceptT expireQueue >>= \case
-                Right (storedMsgsCount, expiredMsgsCount) ->
-                  pure MessageStats {storedMsgsCount, expiredMsgsCount, storedQueues = 1}
-                Left e -> do
-                  logError $ "STORE: processExpireQueue, failed expiring messages in queue, " <> tshow e
-                  exitFailure
-              where
-                expireQueue = do
-                  expired'' <- deleteExpiredMsgs ms q old
-                  stored'' <- getQueueSize ms q
-                  liftIO $ closeMsgQueue q
-                  pure (stored'', expired'')
-            processValidateQueue :: JournalQueue -> IO MessageStats
-            processValidateQueue q =
-              runExceptT (getQueueSize ms q) >>= \case
-                Right storedMsgsCount -> pure newMessageStats {storedMsgsCount, storedQueues = 1}
-                Left e -> do
-                  logError $ "STORE: processValidateQueue, failed opening message queue, " <> tshow e
-                  exitFailure
+        AMS _ SMSJournal ms -> processJournalMessages old_ expire ms
+        -- TODO [postgres] is it needed?
+        -- AMS (SType SQSPostgres SMSJournal) ms -> processJournalMessages old_ expire ms
+      processJournalMessages :: forall s. Maybe Int64 -> Bool -> JournalMsgStore s -> IO (Maybe MessageStats)
+      processJournalMessages old_ expire ms
+        | expire = Just <$> case old_ of
+            Just old -> do
+              logInfo "expiring journal store messages..."
+              withAllMsgQueues False ms $ processExpireQueue old
+            Nothing -> do
+              logInfo "validating journal store messages..."
+              withAllMsgQueues False ms $ processValidateQueue
+        | otherwise = logWarn "skipping message expiration" $> Nothing
+        where
+          processExpireQueue :: Int64 -> JournalQueue s -> IO MessageStats
+          processExpireQueue old q =
+            runExceptT expireQueue >>= \case
+              Right (storedMsgsCount, expiredMsgsCount) ->
+                pure MessageStats {storedMsgsCount, expiredMsgsCount, storedQueues = 1}
+              Left e -> do
+                logError $ "STORE: processExpireQueue, failed expiring messages in queue, " <> tshow e
+                exitFailure
+            where
+              expireQueue = do
+                expired'' <- deleteExpiredMsgs ms q old
+                stored'' <- getQueueSize ms q
+                liftIO $ closeMsgQueue q
+                pure (stored'', expired'')
+          processValidateQueue :: JournalQueue s -> IO MessageStats
+          processValidateQueue q =
+            runExceptT (getQueueSize ms q) >>= \case
+              Right storedMsgsCount -> pure newMessageStats {storedMsgsCount, storedQueues = 1}
+              Left e -> do
+                logError $ "STORE: processValidateQueue, failed opening message queue, " <> tshow e
+                exitFailure
 
-importMessages :: forall s. STMStoreClass s => Bool -> s -> FilePath -> Maybe Int64 -> Bool -> IO MessageStats
+importMessages :: forall s. MsgStoreClass s => Bool -> s -> FilePath -> Maybe Int64 -> Bool -> IO MessageStats
 importMessages tty ms f old_ skipWarnings  = do
   logInfo $ "restoring messages from file " <> T.pack f
   (_, (storedMsgsCount, expiredMsgsCount, overQuota)) <-
@@ -1872,8 +1872,8 @@ importMessages tty ms f old_ skipWarnings  = do
   renameFile f $ f <> ".bak"
   mapM_ setOverQuota_ overQuota
   logQueueStates ms
-  storedQueues <- M.size <$> readTVarIO (queues $ stmQueueStore ms)
-  pure MessageStats {storedMsgsCount, expiredMsgsCount, storedQueues}
+  QueueCounts {queueCount} <- liftIO $ queueCounts @(StoreQueue s) $ queueStore ms
+  pure MessageStats {storedMsgsCount, expiredMsgsCount, storedQueues = queueCount}
   where
     restoreMsg :: (Maybe (RecipientId, StoreQueue s), (Int, Int, M.Map RecipientId (StoreQueue s))) -> Bool -> ByteString -> IO (Maybe (RecipientId, StoreQueue s), (Int, Int, M.Map RecipientId (StoreQueue s)))
     restoreMsg (q_, counts@(!stored, !expired, !overQuota)) eof s = case strDecode s of
@@ -1999,8 +1999,8 @@ restoreServerStats msgStats_ ntfStats = asks (serverStatsBackupFile . config) >>
       liftIO (strDecode <$> B.readFile f) >>= \case
         Right d@ServerStatsData {_qCount = statsQCount, _msgCount = statsMsgCount, _ntfCount = statsNtfCount} -> do
           s <- asks serverStats
-          AMS _ st <- asks msgStore
-          _qCount <- M.size <$> readTVarIO (queues $ stmQueueStore st)
+          AMS _ _ (st :: s) <- asks msgStore
+          QueueCounts {queueCount = _qCount} <- liftIO $ queueCounts @(StoreQueue s) $ queueStore st
           let _msgCount = maybe statsMsgCount storedMsgsCount msgStats_
               _ntfCount = storedMsgsCount ntfStats
               _msgExpired' = _msgExpired d + maybe 0 expiredMsgsCount msgStats_

src/Simplex/Messaging/Server/CLI.hs

@@ -29,6 +29,7 @@ import Network.Socket (HostName, ServiceName)
 import Options.Applicative
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Protocol (ProtoServerWithAuth (..), ProtocolServer (..), ProtocolTypeI)
+import Simplex.Messaging.Server.Env.STM (AServerStoreCfg (..), ServerStoreCfg (..), StorePaths (..))
 import Simplex.Messaging.Transport (ATransport (..), TLS, Transport (..))
 import Simplex.Messaging.Transport.Server (AddHTTP, loadFileFingerprint)
 import Simplex.Messaging.Transport.WebSockets (WS)
@@ -301,6 +302,13 @@ printServerConfig transports logFile = do
     putStrLn $ "Serving SMP protocol on port " <> descr
     when addHTTP $ putStrLn $ "Serving static site on port " <> descr
 
+-- TODO [postgres]
+printSMPServerConfig :: [(ServiceName, ATransport, AddHTTP)] -> AServerStoreCfg -> IO ()
+printSMPServerConfig transports (ASSCfg _ _ cfg) = printServerConfig transports $ case cfg of
+  SSCMemory sp_ -> (\StorePaths {storeLogFile} -> storeLogFile) <$> sp_
+  SSCMemoryJournal {storeLogFile} -> Just storeLogFile
+  SSCDatabaseJournal {} -> Just "postgres database"
+
 deleteDirIfExists :: FilePath -> IO ()
 deleteDirIfExists path = whenM (doesDirectoryExist path) $ removeDirectoryRecursive path
 

src/Simplex/Messaging/Server/Env/STM.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE AllowAmbiguousTypes #-}
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE FlexibleContexts #-}
@@ -9,6 +10,8 @@
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE StrictData #-}
 {-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeOperators #-}
 
 module Simplex.Messaging.Server.Env.STM where
 
@@ -21,18 +24,23 @@ import Data.ByteString.Char8 (ByteString)
 import Data.Int (Int64)
 import Data.IntMap.Strict (IntMap)
 import qualified Data.IntMap.Strict as IM
+import Data.Kind (Constraint)
 import Data.List (intercalate)
 import Data.List.NonEmpty (NonEmpty)
-import Data.Maybe (isJust, isNothing)
+import Data.Maybe (isJust)
 import qualified Data.Text as T
 import Data.Time.Clock (getCurrentTime, nominalDay)
 import Data.Time.Clock.System (SystemTime)
 import qualified Data.X509 as X
 import Data.X509.Validation (Fingerprint (..))
+import GHC.TypeLits (TypeError)
+import qualified GHC.TypeLits as TE
 import Network.Socket (ServiceName)
 import qualified Network.TLS as T
 import Numeric.Natural
 import Simplex.Messaging.Agent.Lock
+import Simplex.Messaging.Agent.Store.Postgres.Common (DBOpts)
+import Simplex.Messaging.Agent.Store.Shared (MigrationConfirmation (..))
 import Simplex.Messaging.Client.Agent (SMPClientAgent, SMPClientAgentConfig, newSMPClientAgent)
 import Simplex.Messaging.Crypto (KeyHash (..))
 import qualified Simplex.Messaging.Crypto as C
@@ -44,9 +52,11 @@ import Simplex.Messaging.Server.MsgStore.STM
 import Simplex.Messaging.Server.MsgStore.Types
 import Simplex.Messaging.Server.NtfStore
 import Simplex.Messaging.Server.QueueStore
-import Simplex.Messaging.Server.QueueStore.STM
+import Simplex.Messaging.Server.QueueStore.STM (STMQueueStore, setStoreLog)
+import Simplex.Messaging.Server.QueueStore.Types
 import Simplex.Messaging.Server.Stats
 import Simplex.Messaging.Server.StoreLog
+import Simplex.Messaging.Server.StoreLog.ReadWrite
 import Simplex.Messaging.TMap (TMap)
 import qualified Simplex.Messaging.TMap as TM
 import Simplex.Messaging.Transport (ATransport, VersionRangeSMP, VersionSMP)
@@ -61,14 +71,12 @@ data ServerConfig = ServerConfig
   { transports :: [(ServiceName, ATransport, AddHTTP)],
     smpHandshakeTimeout :: Int,
     tbqSize :: Natural,
-    msgStoreType :: AMSType,
     msgQueueQuota :: Int,
     maxJournalMsgCount :: Int,
     maxJournalStateLines :: Int,
     queueIdBytes :: Int,
     msgIdBytes :: Int,
-    storeLogFile :: Maybe FilePath,
-    storeMsgsFile :: Maybe FilePath,
+    serverStoreCfg :: AServerStoreCfg,
     storeNtfsFile :: Maybe FilePath,
     -- | set to False to prohibit creating new queues
     allowNewQueues :: Bool,
@@ -122,7 +130,8 @@ data ServerConfig = ServerConfig
 
 data StartOptions = StartOptions
   { maintenance :: Bool,
-    skipWarnings :: Bool
+    skipWarnings :: Bool,
+    confirmMigrations :: MigrationConfirmation
   }
 
 defMsgExpirationDays :: Int64
@@ -191,19 +200,31 @@ data Env = Env
     proxyAgent :: ProxyAgent -- senders served on this proxy
   }
 
-type family MsgStore s where
-  MsgStore 'MSMemory = STMMsgStore
-  MsgStore 'MSJournal = JournalMsgStore
+type family SupportedStore (qs :: QSType) (ms :: MSType) :: Constraint where
+  SupportedStore 'QSMemory 'MSMemory = ()
+  SupportedStore 'QSMemory 'MSJournal = ()
+  SupportedStore 'QSPostgres 'MSJournal = ()
+  SupportedStore 'QSPostgres 'MSMemory =
+    (Int ~ Bool, TypeError ('TE.Text "Storing messages in memory with Postgres DB is not supported"))
 
-data AMsgStore = forall s. (STMStoreClass (MsgStore s), MsgStoreClass (MsgStore s)) => AMS (SMSType s) (MsgStore s)
+data AStoreType = forall qs ms. SupportedStore qs ms => ASType (SQSType qs) (SMSType ms)
 
-data AStoreQueue = forall s. MsgStoreClass (MsgStore s) => ASQ (SMSType s) (StoreQueue (MsgStore s))
+data ServerStoreCfg qs ms where
+  SSCMemory :: Maybe StorePaths -> ServerStoreCfg 'QSMemory 'MSMemory
+  SSCMemoryJournal :: {storeLogFile :: FilePath, storeMsgsPath :: FilePath} -> ServerStoreCfg 'QSMemory 'MSJournal
+  SSCDatabaseJournal :: {storeDBOpts :: DBOpts, confirmMigrations :: MigrationConfirmation, storeMsgsPath' :: FilePath} -> ServerStoreCfg 'QSPostgres 'MSJournal
 
-data AMsgStoreCfg = forall s. MsgStoreClass (MsgStore s) => AMSC (SMSType s) (MsgStoreConfig (MsgStore s))
+data StorePaths = StorePaths {storeLogFile :: FilePath, storeMsgsFile :: Maybe FilePath}
 
-msgPersistence :: AMsgStoreCfg -> Bool
-msgPersistence (AMSC SMSMemory (STMStoreConfig {storePath})) = isJust storePath
-msgPersistence (AMSC SMSJournal _) = True
+data AServerStoreCfg = forall qs ms. SupportedStore qs ms => ASSCfg (SQSType qs) (SMSType ms) (ServerStoreCfg qs ms)
+
+type family MsgStore (qs :: QSType) (ms :: MSType) where
+  MsgStore 'QSMemory 'MSMemory = STMMsgStore
+  MsgStore qs 'MSJournal = JournalMsgStore qs
+
+data AMsgStore =
+  forall qs ms. (SupportedStore qs ms, MsgStoreClass (MsgStore qs ms)) =>
+  AMS (SQSType qs) (SMSType ms) (MsgStore qs ms)
 
 type Subscribed = Bool
 
@@ -225,10 +246,11 @@ newtype ProxyAgent = ProxyAgent
 
 type ClientId = Int
 
-data AClient = forall s. MsgStoreClass (MsgStore s) => AClient (SMSType s) (Client (MsgStore s))
+data AClient = forall qs ms. MsgStoreClass (MsgStore qs ms) => AClient (SQSType qs) (SMSType ms) (Client (MsgStore qs ms))
 
 clientId' :: AClient -> ClientId
-clientId' (AClient _ Client {clientId}) = clientId
+clientId' (AClient _ _ Client {clientId}) = clientId
+{-# INLINE clientId' #-}
 
 data Client s = Client
   { clientId :: ClientId,
@@ -270,8 +292,8 @@ newServer = do
   savingLock <- createLockIO
   return Server {subscribedQ, subscribers, ntfSubscribedQ, notifiers, subClients, ntfSubClients, pendingSubEvents, pendingNtfSubEvents, savingLock}
 
-newClient :: SMSType s -> ClientId -> Natural -> VersionSMP -> ByteString -> SystemTime -> IO (Client (MsgStore s))
-newClient _msType clientId qSize thVersion sessionId createdAt = do
+newClient :: SQSType qs -> SMSType ms -> ClientId -> Natural -> VersionSMP -> ByteString -> SystemTime -> IO (Client (MsgStore qs ms))
+newClient _ _ clientId qSize thVersion sessionId createdAt = do
   subscriptions <- TM.emptyIO
   ntfSubscriptions <- TM.emptyIO
   rcvQ <- newTBQueueIO qSize
@@ -297,22 +319,29 @@ newProhibitedSub = do
   return Sub {subThread = ProhibitSub, delivered}
 
 newEnv :: ServerConfig -> IO Env
-newEnv config@ServerConfig {smpCredentials, httpCredentials, storeLogFile, msgStoreType, storeMsgsFile, smpAgentCfg, information, messageExpiration, idleQueueInterval, msgQueueQuota, maxJournalMsgCount, maxJournalStateLines} = do
+newEnv config@ServerConfig {smpCredentials, httpCredentials, serverStoreCfg, smpAgentCfg, information, messageExpiration, idleQueueInterval, msgQueueQuota, maxJournalMsgCount, maxJournalStateLines, startOptions} = do
   serverActive <- newTVarIO True
   server <- newServer
-  msgStore@(AMS _ store) <- case msgStoreType of
-    AMSType SMSMemory -> AMS SMSMemory <$> newMsgStore STMStoreConfig {storePath = storeMsgsFile, quota = msgQueueQuota}
-    AMSType SMSJournal -> case storeMsgsFile of
-      Just storePath ->
-        let cfg = mkJournalStoreConfig storePath msgQueueQuota maxJournalMsgCount maxJournalStateLines idleQueueInterval
-         in AMS SMSJournal <$> newMsgStore cfg
-      Nothing -> putStrLn "Error: journal msg store require path in [STORE_LOG], restore_messages" >> exitFailure
+  msgStore <- case serverStoreCfg of
+    ASSCfg qt mt (SSCMemory storePaths_) -> do
+      let storePath = storeMsgsFile =<< storePaths_
+      ms <- newMsgStore STMStoreConfig {storePath, quota = msgQueueQuota}
+      forM_ storePaths_ $ \StorePaths {storeLogFile = f} ->  loadStoreLog (mkQueue ms) f $ queueStore ms
+      pure $ AMS qt mt ms
+    ASSCfg qt mt SSCMemoryJournal {storeLogFile, storeMsgsPath} -> do
+      let qsCfg = MQStoreCfg
+          cfg = mkJournalStoreConfig qsCfg storeMsgsPath msgQueueQuota maxJournalMsgCount maxJournalStateLines idleQueueInterval
+      ms <- newMsgStore cfg
+      loadStoreLog (mkQueue ms) storeLogFile $ stmQueueStore ms
+      pure $ AMS qt mt ms
+    ASSCfg qt mt SSCDatabaseJournal {storeDBOpts, storeMsgsPath'} -> do
+      let StartOptions {confirmMigrations} = startOptions
+          qsCfg = PQStoreCfg storeDBOpts confirmMigrations
+          cfg = mkJournalStoreConfig qsCfg storeMsgsPath' msgQueueQuota maxJournalMsgCount maxJournalStateLines idleQueueInterval
+      ms <- newMsgStore cfg
+      pure $ AMS qt mt ms
   ntfStore <- NtfStore <$> TM.emptyIO
   random <- C.newRandom
-  forM_ storeLogFile $ \f -> do
-    logInfo $ "restoring queues from file " <> T.pack f
-    sl <- readWriteQueueStore f store
-    setStoreLog store sl
   tlsServerCreds <- getCredentials "SMP" smpCredentials
   httpServerCreds <- mapM (getCredentials "HTTPS") httpCredentials
   mapM_ checkHTTPSCredentials httpServerCreds
@@ -325,6 +354,11 @@ newEnv config@ServerConfig {smpCredentials, httpCredentials, storeLogFile, msgSt
   proxyAgent <- newSMPProxyAgent smpAgentCfg random
   pure Env {serverActive, config, serverInfo, server, serverIdentity, msgStore, ntfStore, random, tlsServerCreds, httpServerCreds, serverStats, sockets, clientSeq, clients, proxyAgent}
   where
+    loadStoreLog :: StoreQueueClass q => (RecipientId -> QueueRec -> IO q) -> FilePath -> STMQueueStore q -> IO ()
+    loadStoreLog mkQ f st = do
+      logInfo $ "restoring queues from file " <> T.pack f
+      sl <- readWriteQueueStore False mkQ f st
+      setStoreLog st sl
     getCredentials protocol creds = do
       files <- missingCreds
       unless (null files) $ do
@@ -358,17 +392,20 @@ newEnv config@ServerConfig {smpCredentials, httpCredentials, storeLogFile, msgSt
               }
         }
       where
-        persistence
-          | isNothing storeLogFile = SPMMemoryOnly
-          | isJust storeMsgsFile = SPMMessages
-          | otherwise = SPMQueues
+        persistence = case serverStoreCfg of
+          ASSCfg _ _ (SSCMemory sp_) -> case sp_ of
+            Nothing -> SPMMemoryOnly
+            Just StorePaths {storeMsgsFile = Just _} -> SPMMessages
+            _ -> SPMQueues
+          _ -> SPMMessages
 
-mkJournalStoreConfig :: FilePath -> Int -> Int -> Int -> Int64 -> JournalStoreConfig
-mkJournalStoreConfig storePath msgQueueQuota maxJournalMsgCount maxJournalStateLines idleQueueInterval =
+mkJournalStoreConfig :: QStoreCfg s -> FilePath -> Int -> Int -> Int -> Int64 -> JournalStoreConfig s
+mkJournalStoreConfig queueStoreCfg storePath msgQueueQuota maxJournalMsgCount maxJournalStateLines idleQueueInterval =
   JournalStoreConfig
     { storePath,
       quota = msgQueueQuota,
       pathParts = journalMsgStoreDepth,
+      queueStoreCfg,
       maxMsgCount = maxJournalMsgCount,
       maxStateLines = maxJournalStateLines,
       stateTailSize = defaultStateTailSize,
@@ -382,5 +419,5 @@ newSMPProxyAgent smpAgentCfg random = do
   smpAgent <- newSMPClientAgent smpAgentCfg random
   pure ProxyAgent {smpAgent}
 
-readWriteQueueStore :: STMStoreClass s => FilePath -> s -> IO (StoreLog 'WriteMode)
-readWriteQueueStore = readWriteStoreLog readQueueStore writeQueueStore
+readWriteQueueStore :: forall q s. QueueStoreClass q s => Bool -> (RecipientId -> QueueRec -> IO q) -> FilePath -> s -> IO (StoreLog 'WriteMode)
+readWriteQueueStore tty mkQ = readWriteStoreLog (readQueueStore tty mkQ) (writeQueueStore @q)

src/Simplex/Messaging/Server/Main.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE ApplicativeDo #-}
+{-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE LambdaCase #-}
@@ -26,6 +27,7 @@ import Data.Ini (Ini, lookupValue, readIniFile)
 import Data.List (find, isPrefixOf)
 import qualified Data.List.NonEmpty as L
 import Data.Maybe (fromMaybe, isJust, isNothing)
+import Data.Semigroup (Sum (..))
 import Data.Text (Text)
 import qualified Data.Text as T
 import Data.Text.Encoding (decodeLatin1, encodeUtf8)
@@ -33,6 +35,9 @@ import qualified Data.Text.IO as T
 import Network.Socket (HostName)
 import Options.Applicative
 import Simplex.Messaging.Agent.Protocol (connReqUriP')
+import Simplex.Messaging.Agent.Store.Postgres (checkSchemaExists)
+import Simplex.Messaging.Agent.Store.Postgres.Common (DBOpts (..))
+import Simplex.Messaging.Agent.Store.Shared (MigrationConfirmation (..))
 import Simplex.Messaging.Client (HostMode (..), NetworkConfig (..), ProtocolClientConfig (..), SocksMode (..), defaultNetworkConfig, textToHostMode)
 import Simplex.Messaging.Client.Agent (SMPClientAgentConfig (..), defaultSMPClientAgentConfig)
 import qualified Simplex.Messaging.Crypto as C
@@ -44,13 +49,17 @@ import Simplex.Messaging.Server.CLI
 import Simplex.Messaging.Server.Env.STM
 import Simplex.Messaging.Server.Expiration
 import Simplex.Messaging.Server.Information
-import Simplex.Messaging.Server.MsgStore.Types (AMSType (..), SMSType (..), newMsgStore)
-import Simplex.Messaging.Server.QueueStore.STM (readQueueStore)
+import Simplex.Messaging.Server.MsgStore.Journal (JournalMsgStore (..), JournalQueue, QStoreCfg (..), postgresQueueStore, stmQueueStore)
+import Simplex.Messaging.Server.MsgStore.Types (MsgStoreClass (..), QSType (..), SQSType (..), SMSType (..), newMsgStore)
+import Simplex.Messaging.Server.QueueStore.Postgres (batchInsertQueues, foldQueueRecs)
+import Simplex.Messaging.Server.QueueStore.Types
+import Simplex.Messaging.Server.StoreLog (logCreateQueue, openWriteStoreLog)
+import Simplex.Messaging.Server.StoreLog.ReadWrite (readQueueStore)
 import Simplex.Messaging.Transport (simplexMQVersion, supportedProxyClientSMPRelayVRange, supportedServerSMPRelayVRange)
 import Simplex.Messaging.Transport.Client (SocksProxy, TransportHost (..), defaultSocksProxy)
 import Simplex.Messaging.Transport.Server (ServerCredentials (..), TransportServerConfig (..), defaultTransportServerConfig)
 import Simplex.Messaging.Util (eitherToMaybe, ifM, safeDecodeUtf8, tshow)
-import System.Directory (createDirectoryIfMissing, doesDirectoryExist, doesFileExist)
+import System.Directory (createDirectoryIfMissing, doesDirectoryExist, doesFileExist, renameFile)
 import System.Exit (exitFailure)
 import System.FilePath (combine)
 import System.IO (BufferMode (..), hSetBuffering, stderr, stdout)
@@ -84,37 +93,30 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath =
     Journal cmd -> withIniFile $ \ini -> do
       msgsDirExists <- doesDirectoryExist storeMsgsJournalDir
       msgsFileExists <- doesFileExist storeMsgsFilePath
-      let enableStoreLog = settingIsOn "STORE_LOG" "enable" ini
-      storeLogFile <- case enableStoreLog $> storeLogFilePath of
-        Just storeLogFile -> do
-          ifM
-            (doesFileExist storeLogFile)
-            (pure storeLogFile)
-            (putStrLn ("Store log file " <> storeLogFile <> " not found") >> exitFailure)
-        Nothing -> putStrLn "Store log disabled, see `[STORE_LOG] enable`" >> exitFailure
+      storeLogFile <- getRequiredStoreLogFile ini
       case cmd of
-        JCImport
+        SCImport
           | msgsFileExists && msgsDirExists -> exitConfigureMsgStorage
           | msgsDirExists -> do
               putStrLn $ storeMsgsJournalDir <> " directory already exists."
               exitFailure
           | not msgsFileExists -> do
-              putStrLn $ storeMsgsFilePath <> " file does not exists."
+              putStrLn $ storeMsgsFilePath <> " file does not exist."
               exitFailure
           | otherwise -> do
               confirmOrExit
                 ("WARNING: message log file " <> storeMsgsFilePath <> " will be imported to journal directory " <> storeMsgsJournalDir)
                 "Messages not imported"
-              ms <- newJournalMsgStore
-              readQueueStore storeLogFile ms
+              ms <- newJournalMsgStore MQStoreCfg
+              readQueueStore True (mkQueue ms) storeLogFile $ stmQueueStore ms
               msgStats <- importMessages True ms storeMsgsFilePath Nothing False -- no expiration
               putStrLn "Import completed"
               printMessageStats "Messages" msgStats
-              putStrLn $ case readMsgStoreType ini of
-                Right (AMSType SMSMemory) -> "store_messages set to `memory`, update it to `journal` in INI file"
-                Right (AMSType SMSJournal) -> "store_messages set to `journal`"
-                Left e -> e <> ", update it to `journal` in INI file"
-        JCExport
+              putStrLn $ case readStoreType ini of
+                Right (ASType SQSMemory SMSMemory) -> "store_messages set to `memory`, update it to `journal` in INI file"
+                Right (ASType _ SMSJournal) -> "store_messages set to `journal`"
+                Left e -> e <> ", configure storage correctly"
+        SCExport
           | msgsFileExists && msgsDirExists -> exitConfigureMsgStorage
           | msgsFileExists -> do
               putStrLn $ storeMsgsFilePath <> " file already exists."
@@ -123,15 +125,17 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath =
               confirmOrExit
                 ("WARNING: journal directory " <> storeMsgsJournalDir <> " will be exported to message log file " <> storeMsgsFilePath)
                 "Journal not exported"
-              ms <- newJournalMsgStore
-              readQueueStore storeLogFile ms
+              -- TODO [postgres]
+              ms <- newJournalMsgStore MQStoreCfg
+              readQueueStore True (mkQueue ms) storeLogFile $ stmQueueStore ms
               exportMessages True ms storeMsgsFilePath False
               putStrLn "Export completed"
-              putStrLn $ case readMsgStoreType ini of
-                Right (AMSType SMSMemory) -> "store_messages set to `memory`"
-                Right (AMSType SMSJournal) -> "store_messages set to `journal`, update it to `memory` in INI file"
-                Left e -> e <> ", update it to `memory` in INI file"
-        JCDelete
+              putStrLn $ case readStoreType ini of
+                Right (ASType SQSMemory SMSMemory) -> "store_messages set to `memory`, start the server."
+                Right (ASType SQSMemory SMSJournal) -> "store_messages set to `journal`, update it to `memory` in INI file"
+                Right (ASType SQSPostgres SMSJournal) -> "store_messages set to `journal`, store_queues is set to `database`.\nExport queues to store log to use memory storage for messages (`smp-server database export`)."
+                Left e -> e <> ", configure storage correctly"
+        SCDelete
           | not msgsDirExists -> do
               putStrLn $ storeMsgsJournalDir <> " directory does not exists."
               exitFailure
@@ -141,13 +145,73 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath =
                 "Messages NOT deleted"
               deleteDirIfExists storeMsgsJournalDir
               putStrLn $ "Deleted all messages in journal " <> storeMsgsJournalDir
+    Database cmd dbOpts@DBOpts {connstr, schema} -> withIniFile $ \ini -> do
+      schemaExists <- checkSchemaExists connstr schema
+      storeLogExists <- doesFileExist storeLogFilePath
+      case cmd of
+        SCImport
+          | schemaExists && storeLogExists -> exitConfigureQueueStore connstr schema
+          | schemaExists -> do
+              putStrLn $ "Schema " <> B.unpack schema <> " already exists in PostrgreSQL database: " <> B.unpack connstr
+              exitFailure
+          | not storeLogExists -> do
+              putStrLn $ storeLogFilePath <> " file does not exist."
+              exitFailure
+          | otherwise -> do
+              storeLogFile <- getRequiredStoreLogFile ini
+              confirmOrExit
+                ("WARNING: store log file " <> storeLogFile <> " will be imported to PostrgreSQL database: " <> B.unpack connstr <> ", schema: " <> B.unpack schema)
+                "Queue records not imported"
+              ms <- newJournalMsgStore MQStoreCfg
+              readQueueStore True (mkQueue ms) storeLogFile (queueStore ms)
+              queues <- readTVarIO $ loadedQueues $ stmQueueStore ms
+              ps <- newJournalMsgStore $ PQStoreCfg dbOpts {createSchema = True} MCConsole
+              (qCnt, nCnt) <- batchInsertQueues @(JournalQueue 'QSMemory) True queues $ postgresQueueStore ps
+              renameFile storeLogFile $ storeLogFile <> ".bak"
+              putStrLn $ "Import completed: " <> show qCnt <> " queues, " <> show nCnt <> " notifiers"
+              putStrLn $ case readStoreType ini of
+                Right (ASType SQSMemory SMSMemory) -> "store_messages set to `memory`.\nImport messages to journal to use PostgreSQL database for queues (`smp-server journal import`)"
+                Right (ASType SQSMemory SMSJournal) -> "store_queues set to `memory`, update it to `database` in INI file"
+                Right (ASType SQSPostgres SMSJournal) -> "store_queues set to `database`, start the server."
+                Left e -> e <> ", configure storage correctly"
+        SCExport
+          | schemaExists && storeLogExists -> exitConfigureQueueStore connstr schema
+          | not schemaExists -> do
+              putStrLn $ "Schema " <> B.unpack schema <> " does not exist in PostrgreSQL database: " <> B.unpack connstr
+              exitFailure
+          | storeLogExists -> do
+              putStrLn $ storeLogFilePath <> " file already exists."
+              exitFailure
+          | otherwise -> do
+              confirmOrExit
+                ("WARNING: PostrgreSQL database schema " <> B.unpack schema <> " (database: " <> B.unpack connstr <> ") will be exported to store log file " <> storeLogFilePath)
+                "Queue records not exported"
+              ps <- newJournalMsgStore $ PQStoreCfg dbOpts MCConsole
+              sl <- openWriteStoreLog storeLogFilePath
+              Sum qCnt <- foldQueueRecs True (postgresQueueStore ps) $ \rId qr -> logCreateQueue sl rId qr $> Sum (1 :: Int)
+              putStrLn $ "Export completed: " <> show qCnt <> " queues"
+              putStrLn $ case readStoreType ini of
+                Right (ASType SQSPostgres SMSJournal) -> "store_queues set to `database`, update it to `memory` in INI file."
+                Right (ASType SQSMemory _) -> "store_queues set to `memory`, start the server"
+                Left e -> e <> ", configure storage correctly"
+        SCDelete -> undefined -- TODO [postgres]
   where
     withIniFile a =
       doesFileExist iniFile >>= \case
         True -> readIniFile iniFile >>= either exitError a
         _ -> exitError $ "Error: server is not initialized (" <> iniFile <> " does not exist).\nRun `" <> executableName <> " init`."
-    newJournalMsgStore =
-      let cfg = mkJournalStoreConfig storeMsgsJournalDir defaultMsgQueueQuota defaultMaxJournalMsgCount defaultMaxJournalStateLines $ checkInterval defaultMessageExpiration
+    getRequiredStoreLogFile ini = do
+      let enableStoreLog = settingIsOn "STORE_LOG" "enable" ini
+      case enableStoreLog $> storeLogFilePath of
+        Just storeLogFile -> do
+          ifM
+            (doesFileExist storeLogFile)
+            (pure storeLogFile)
+            (putStrLn ("Store log file " <> storeLogFile <> " not found") >> exitFailure)
+        Nothing -> putStrLn "Store log disabled, see `[STORE_LOG] enable`" >> exitFailure
+    newJournalMsgStore :: QStoreCfg s -> IO (JournalMsgStore s)
+    newJournalMsgStore qsCfg =
+      let cfg = mkJournalStoreConfig qsCfg storeMsgsJournalDir defaultMsgQueueQuota defaultMaxJournalMsgCount defaultMaxJournalStateLines $ checkInterval defaultMessageExpiration
        in newMsgStore cfg
     iniFile = combine cfgPath "smp-server.ini"
     serverVersion = "SMP server v" <> simplexMQVersion
@@ -157,12 +221,23 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath =
     storeMsgsFilePath = combine logPath "smp-server-messages.log"
     storeMsgsJournalDir = combine logPath "messages"
     storeNtfsFilePath = combine logPath "smp-server-ntfs.log"
-    readMsgStoreType :: Ini -> Either String AMSType
-    readMsgStoreType = textToMsgStoreType . fromRight "memory" . lookupValue "STORE_LOG" "store_messages"
-    textToMsgStoreType = \case
-      "memory" -> Right $ AMSType SMSMemory
-      "journal" -> Right $ AMSType SMSJournal
-      s -> Left $ "invalid store_messages: " <> T.unpack s
+    readStoreType :: Ini -> Either String AStoreType
+    readStoreType ini = case (iniStoreQueues, iniStoreMessage) of
+      ("memory", "memory") -> Right $ ASType SQSMemory SMSMemory
+      ("memory", "journal") -> Right $ ASType SQSMemory SMSJournal
+      ("database", "journal") -> Right $ ASType SQSPostgres SMSJournal
+      ("database", "memory") -> Left "Using PostgreSQL database requires journal memory storage."
+      (q, m) -> Left $ T.unpack $ "Invalid storage settings: store_queues: " <> q <> ", store_messages: " <> m
+      where
+        iniStoreQueues = fromRight "memory" $ lookupValue "STORE_LOG" "store_queues" ini
+        iniStoreMessage = fromRight "memory" $ lookupValue "STORE_LOG" "store_messages" ini
+    iniDBOptions :: Ini -> DBOpts
+    iniDBOptions ini =
+      DBOpts
+        { connstr = either (const defaultDBConnStr) encodeUtf8 $ lookupValue "STORE_LOG" "db_connection" ini,
+          schema = either (const defaultDBSchema) encodeUtf8 $ lookupValue "STORE_LOG" "db_schema" ini,
+          createSchema = False
+        }
     httpsCertFile = combine cfgPath "web.crt"
     httpsKeyFile = combine cfgPath "web.key"
     defaultStaticPath = combine logPath "www"
@@ -210,7 +285,7 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath =
                     Just "Error: passing --hosting-country requires passing --hosting"
                 | otherwise = Nothing
           forM_ err_ $ \err -> putStrLn err >> exitFailure
-        initialize opts'@InitOptions {enableStoreLog, logStats, signAlgorithm, password, controlPort, socksProxy, ownDomains, sourceCode, webStaticPath, disableWeb} = do
+        initialize opts'@InitOptions {enableStoreLog, dbOptions, logStats, signAlgorithm, password, controlPort, socksProxy, ownDomains, sourceCode, webStaticPath, disableWeb} = do
           checkInitOptions opts'
           clearDirIfExists cfgPath
           clearDirIfExists logPath
@@ -236,12 +311,17 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath =
             iniFileContent host basicAuth controlPortPwds =
               informationIniContent opts'
                 <> "[STORE_LOG]\n\
-                   \# The server uses STM memory for persistence,\n\
-                   \# that will be lost on restart (e.g., as with redis).\n\
-                   \# This option enables saving memory to append only log,\n\
-                   \# and restoring it when the server is started.\n\
+                   \# The server uses memory or PostgreSQL database for persisting queue records.\n\
+                   \# Use `enable: on` to use append-only log to preserve and restore queue records on restart.\n\
                    \# Log is compacted on start (deleted objects are removed).\n"
                 <> ("enable: " <> onOff enableStoreLog <> "\n\n")
+                <> "# Queue storage mode: `memory` or `database` (to store queue records in PostgreSQL database).\n\
+                   \# `memory` - in-memory persistence, with optional append-only log (`enable: on`).\n\
+                   \# `database`- PostgreSQL databass (requires `store_messages: journal`).\n\
+                   \store_queues: memory\n\n\
+                   \# Database connection settings for PostgreSQL database (`store_queues: database`).\n"
+                <> (optDisabled dbOptions <> "db_connection: " <> safeDecodeUtf8 (maybe defaultDBConnStr connstr dbOptions) <> "\n")
+                <> (optDisabled dbOptions <> "db_schema: " <> safeDecodeUtf8 (maybe defaultDBSchema schema dbOptions) <> "\n\n")
                 <> "# Message storage mode: `memory` or `journal`.\n\
                    \store_messages: memory\n\n\
                    \# When store_messages is `memory`, undelivered messages are optionally saved and restored\n\
@@ -328,13 +408,13 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath =
       fp <- checkSavedFingerprint cfgPath defaultX509Config
       let host = either (const "<hostnames>") T.unpack $ lookupValue "TRANSPORT" "host" ini
           port = T.unpack $ strictIni "TRANSPORT" "port" ini
-          cfg@ServerConfig {information, storeLogFile, msgStoreType, newQueueBasicAuth, messageExpiration, inactiveClientExpiration} = serverConfig
+          cfg@ServerConfig {information, serverStoreCfg, newQueueBasicAuth, messageExpiration, inactiveClientExpiration} = serverConfig
           sourceCode' = (\ServerPublicInfo {sourceCode} -> sourceCode) <$> information
           srv = ProtoServerWithAuth (SMPServer [THDomainName host] (if port == "5223" then "" else port) (C.KeyHash fp)) newQueueBasicAuth
       printServiceInfo serverVersion srv
       printSourceCode sourceCode'
-      printServerConfig transports storeLogFile
-      checkMsgStoreMode msgStoreType
+      printSMPServerConfig transports serverStoreCfg
+      checkMsgStoreMode iniStoreType
       putStrLn $ case messageExpiration of
         Just ExpirationConfig {ttl} -> "expiring messages after " <> showTTL ttl
         _ -> "not expiring messages"
@@ -347,10 +427,10 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath =
             then maybe "allowed" (const "requires password") newQueueBasicAuth
             else "NOT allowed"
       -- print information
-      let persistence
-            | isNothing storeLogFile = SPMMemoryOnly
-            | isJust (storeMsgsFile cfg) = SPMMessages
-            | otherwise = SPMQueues
+      let persistence = case serverStoreCfg of
+            ASSCfg _ _ (SSCMemory Nothing) -> SPMMemoryOnly
+            ASSCfg _ _ (SSCMemory (Just StorePaths {storeMsgsFile})) | isNothing storeMsgsFile -> SPMQueues
+            _ -> SPMMessages
       let config =
             ServerPublicConfig
               { persistence,
@@ -383,13 +463,12 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath =
           _ -> enableStoreLog $> path
         transports = iniTransports ini
         sharedHTTP = any (\(_, _, addHTTP) -> addHTTP) transports
-        iniMsgStoreType = either error id $! readMsgStoreType ini
+        iniStoreType = either error id $! readStoreType ini
         serverConfig =
           ServerConfig
             { transports,
               smpHandshakeTimeout = 120000000,
               tbqSize = 128,
-              msgStoreType = iniMsgStoreType,
               msgQueueQuota = defaultMsgQueueQuota,
               maxJournalMsgCount = defaultMaxJournalMsgCount,
               maxJournalStateLines = defaultMaxJournalStateLines,
@@ -402,10 +481,13 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath =
                     certificateFile = c serverCrtFile
                   },
               httpCredentials = (\WebHttpsParams {key, cert} -> ServerCredentials {caCertificateFile = Nothing, privateKeyFile = key, certificateFile = cert}) <$> webHttpsParams',
-              storeLogFile = enableStoreLog $> storeLogFilePath,
-              storeMsgsFile = case iniMsgStoreType of
-                AMSType SMSMemory -> restoreMessagesFile storeMsgsFilePath
-                AMSType SMSJournal -> Just storeMsgsJournalDir,
+              serverStoreCfg = case iniStoreType of
+                ASType SQSMemory SMSMemory ->
+                  ASSCfg SQSMemory SMSMemory $ SSCMemory $ enableStoreLog $> StorePaths {storeLogFile = storeLogFilePath, storeMsgsFile = restoreMessagesFile storeMsgsFilePath}
+                ASType SQSMemory SMSJournal ->
+                  ASSCfg SQSMemory SMSJournal $ SSCMemoryJournal {storeLogFile = storeLogFilePath, storeMsgsPath = storeMsgsJournalDir}
+                ASType SQSPostgres SMSJournal ->
+                  ASSCfg SQSPostgres SMSJournal $ SSCDatabaseJournal {storeDBOpts = iniDBOptions ini, confirmMigrations = MCYesUp, storeMsgsPath' = storeMsgsJournalDir},
               storeNtfsFile = restoreMessagesFile storeNtfsFilePath,
               -- allow creating new queues by default
               allowNewQueues = fromMaybe True $ iniOnOff "AUTH" "new_queues" ini,
@@ -486,20 +568,20 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath =
             pure WebHttpsParams {port, cert, key}
         webStaticPath' = eitherToMaybe $ T.unpack <$> lookupValue "WEB" "static_path" ini
 
-    checkMsgStoreMode :: AMSType -> IO ()
+    checkMsgStoreMode :: AStoreType -> IO ()
     checkMsgStoreMode mode = do
       msgsDirExists <- doesDirectoryExist storeMsgsJournalDir
       msgsFileExists <- doesFileExist storeMsgsFilePath
       case mode of
         _ | msgsFileExists && msgsDirExists -> exitConfigureMsgStorage
-        AMSType SMSJournal
+        ASType _ SMSJournal -- TODO [postgres]
           | msgsFileExists -> do
               putStrLn $ "Error: store_messages is `journal` with " <> storeMsgsFilePath <> " file present."
               putStrLn "Set store_messages to `memory` or use `smp-server journal export` to migrate."
               exitFailure
           | not msgsDirExists ->
               putStrLn $ "store_messages is `journal`, " <> storeMsgsJournalDir <> " directory will be created."
-        AMSType SMSMemory
+        ASType _ SMSMemory
           | msgsDirExists -> do
               putStrLn $ "Error: store_messages is `memory` with " <> storeMsgsJournalDir <> " directory present."
               putStrLn "Set store_messages to `journal` or use `smp-server journal import` to migrate."
@@ -511,6 +593,11 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath =
       putStrLn "Configure memory storage."
       exitFailure
 
+    exitConfigureQueueStore connstr schema = do
+      putStrLn $ "Error: both " <> storeLogFilePath <> " file and " <> B.unpack schema <> " schema are present (database: " <> B.unpack connstr <> ")."
+      putStrLn "Configure queue storage."
+      exitFailure
+
 data EmbeddedWebParams = EmbeddedWebParams
   { webStaticPath :: FilePath,
     webHttpPort :: Maybe Int,
@@ -533,6 +620,12 @@ getServerSourceCode =
 simplexmqSource :: String
 simplexmqSource = "https://github.com/simplex-chat/simplexmq"
 
+defaultDBConnStr :: ByteString
+defaultDBConnStr = "postgresql://smp@/smp_server_store"
+
+defaultDBSchema :: ByteString
+defaultDBSchema = "smp_server"
+
 defaultControlPort :: Int
 defaultControlPort = 5224
 
@@ -638,12 +731,15 @@ data CliCommand
   | OnlineCert CertOptions
   | Start StartOptions
   | Delete
-  | Journal JournalCmd
+  | Journal StoreCmd
+  | Database StoreCmd DBOpts
 
-data JournalCmd = JCImport | JCExport | JCDelete
+data StoreCmd = SCImport | SCExport | SCDelete
 
 data InitOptions = InitOptions
   { enableStoreLog :: Bool,
+    dbOptions :: Maybe DBOpts,
+    dbMigrateUp :: Bool,
     logStats :: Bool,
     signAlgorithm :: SignAlgorithm,
     ip :: HostName,
@@ -673,6 +769,7 @@ cliCommandP cfgPath logPath iniFile =
         <> command "start" (info (Start <$> startOptionsP) (progDesc $ "Start server (configuration: " <> iniFile <> ")"))
         <> command "delete" (info (pure Delete) (progDesc "Delete configuration and log files"))
         <> command "journal" (info (Journal <$> journalCmdP) (progDesc "Import/export messages to/from journal storage"))
+        <> command "database" (info (Database <$> databaseCmdP <*> dbOptsP) (progDesc "Import/export queues to/from PostgreSQL database storage"))
     )
   where
     initP :: Parser InitOptions
@@ -683,6 +780,12 @@ cliCommandP cfgPath logPath iniFile =
               <> short 'l'
               <> help "Enable store log for persistence"
           )
+      dbOptions <- optional dbOptsP
+      dbMigrateUp <-
+        switch
+          ( long "db-migrate-up"
+              <> help "Automatically confirm \"up\" database migrations"
+          )
       logStats <-
         switch
           ( long "daily-stats"
@@ -785,6 +888,8 @@ cliCommandP cfgPath logPath iniFile =
       pure
         InitOptions
           { enableStoreLog,
+            dbOptions,
+            dbMigrateUp,
             logStats,
             signAlgorithm,
             ip,
@@ -823,14 +928,47 @@ cliCommandP cfgPath logPath iniFile =
           ( long "skip-warnings"
               <> help "Start the server with non-critical start warnings"
           )
-      pure StartOptions {maintenance, skipWarnings}
-    journalCmdP =
+      confirmMigrations <-
+        option
+          parseConfirmMigrations
+          ( long "confirm-migrations"
+              <> metavar "CONFIRM_MIGRATIONS"
+              <> help "Confirm PostgreSQL database migration: up, down (default is manual confirmation)"
+              <> value MCConsole
+          )
+      pure StartOptions {maintenance, skipWarnings, confirmMigrations}
+    journalCmdP = storeCmdP "message log file" "journal storage"
+    databaseCmdP = storeCmdP "queue store log file" "PostgreSQL database schema"
+    storeCmdP src dest =
       hsubparser
-        ( command "import" (info (pure JCImport) (progDesc "Import message log file into a new journal storage"))
-            <> command "export" (info (pure JCExport) (progDesc "Export journal storage to message log file"))
-            <> command "delete" (info (pure JCDelete) (progDesc "Delete journal storage"))
+        ( command "import" (info (pure SCImport) (progDesc $ "Import " <> src <> " into a new " <> dest))
+            <> command "export" (info (pure SCExport) (progDesc $ "Export " <> dest <> " to " <> src))
+            <> command "delete" (info (pure SCDelete) (progDesc $ "Delete " <> dest))
         )
-
+    dbOptsP = do
+      connstr <-
+        strOption
+          ( long "database"
+              <> short 'd'
+              <> metavar "DB_CONN"
+              <> help "Database connection string"
+              <> value defaultDBConnStr
+              <> showDefault
+          )
+      schema <-
+        strOption
+          ( long "schema"
+              <> metavar "DB_SCHEMA"
+              <> help "Database schema"
+              <> value defaultDBSchema
+              <> showDefault
+          )
+      pure DBOpts {connstr, schema, createSchema = False}
+    parseConfirmMigrations :: ReadM MigrationConfirmation
+    parseConfirmMigrations = eitherReader $ \case
+      "up" -> Right MCYesUp
+      "down" -> Right MCYesUpDown
+      _ -> Left "invalid migration confirmation, pass 'up' or 'down'"
     parseBasicAuth :: ReadM ServerPassword
     parseBasicAuth = eitherReader $ fmap ServerPassword . strDecode . B.pack
     entityP :: String -> String -> String -> Parser (Maybe Entity, Maybe Text)

src/Simplex/Messaging/Server/MsgStore/Journal.hs

@@ -2,20 +2,25 @@
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DerivingStrategies #-}
 {-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE InstanceSigs #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE MultiWayIf #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE TupleSections #-}
 
 module Simplex.Messaging.Server.MsgStore.Journal
-  ( JournalMsgStore (queueStore, random, expireBackupsBefore),
+  ( JournalMsgStore (random, expireBackupsBefore),
+    QStore (..),
+    QStoreCfg (..),
     JournalQueue,
     JournalMsgQueue (queue, state),
     JMQueue (queueDirectory, statePath),
@@ -35,6 +40,8 @@ module Simplex.Messaging.Server.MsgStore.Journal
     queueLogFileName,
     journalFilePath,
     logFileExt,
+    stmQueueStore,
+    postgresQueueStore,
   )
 where
 
@@ -58,11 +65,15 @@ import Data.Time.Format.ISO8601 (iso8601Show, iso8601ParseM)
 import GHC.IO (catchAny)
 import Simplex.Messaging.Agent.Client (getMapLock, withLockMap)
 import Simplex.Messaging.Agent.Lock
+import Simplex.Messaging.Agent.Store.Postgres.Common (DBOpts)
+import Simplex.Messaging.Agent.Store.Shared (MigrationConfirmation)
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Protocol
 import Simplex.Messaging.Server.MsgStore.Types
 import Simplex.Messaging.Server.QueueStore
+import Simplex.Messaging.Server.QueueStore.Postgres
 import Simplex.Messaging.Server.QueueStore.STM
+import Simplex.Messaging.Server.QueueStore.Types
 import Simplex.Messaging.TMap (TMap)
 import qualified Simplex.Messaging.TMap as TM
 import Simplex.Messaging.Server.StoreLog
@@ -74,17 +85,30 @@ import System.IO (BufferMode (..), Handle, IOMode (..), SeekMode (..), stdout)
 import qualified System.IO as IO
 import System.Random (StdGen, genByteString, newStdGen)
 
-data JournalMsgStore = JournalMsgStore
-  { config :: JournalStoreConfig,
+data JournalMsgStore s = JournalMsgStore
+  { config :: JournalStoreConfig s,
     random :: TVar StdGen,
     queueLocks :: TMap RecipientId Lock,
-    queueStore :: STMQueueStore JournalQueue,
+    queueStore_ :: QStore s,
     expireBackupsBefore :: UTCTime
   }
 
-data JournalStoreConfig = JournalStoreConfig
+data QStore (s :: QSType) where
+  MQStore :: STMQueueStore (JournalQueue 'QSMemory) -> QStore 'QSMemory
+  PQStore :: PostgresQueueStore (JournalQueue 'QSPostgres) -> QStore 'QSPostgres
+
+stmQueueStore :: JournalMsgStore 'QSMemory -> STMQueueStore (JournalQueue 'QSMemory)
+stmQueueStore st = case queueStore_ st of
+  MQStore st' -> st'
+
+postgresQueueStore :: JournalMsgStore 'QSPostgres -> PostgresQueueStore (JournalQueue 'QSPostgres)
+postgresQueueStore st = case queueStore_ st of
+  PQStore st' -> st'
+
+data JournalStoreConfig s = JournalStoreConfig
   { storePath :: FilePath,
     pathParts :: Int,
+    queueStoreCfg :: QStoreCfg s,
     quota :: Int,
     -- Max number of messages per journal file - ignored in STM store.
     -- When this limit is reached, the file will be changed.
@@ -99,13 +123,17 @@ data JournalStoreConfig = JournalStoreConfig
     keepMinBackups :: Int
   }
 
-data JournalQueue = JournalQueue
-  { recipientId :: RecipientId,
+data QStoreCfg s where
+  MQStoreCfg :: QStoreCfg 'QSMemory
+  PQStoreCfg :: DBOpts -> MigrationConfirmation -> QStoreCfg 'QSPostgres
+
+data JournalQueue (s :: QSType) = JournalQueue
+  { recipientId' :: RecipientId,
     queueLock :: Lock,
     -- To avoid race conditions and errors when restoring queues,
     -- Nothing is written to TVar when queue is deleted.
-    queueRec :: TVar (Maybe QueueRec),
-    msgQueue_ :: TVar (Maybe JournalMsgQueue),
+    queueRec' :: TVar (Maybe QueueRec),
+    msgQueue' :: TVar (Maybe (JournalMsgQueue s)),
     -- system time in seconds since epoch
     activeAt :: TVar Int64,
     queueState :: TVar (Maybe QState) -- Nothing - unknown
@@ -121,7 +149,7 @@ data JMQueue = JMQueue
     statePath :: FilePath
   }
 
-data JournalMsgQueue = JournalMsgQueue
+data JournalMsgQueue (s :: QSType) = JournalMsgQueue
   { queue :: JMQueue,
     state :: TVar MsgQueueState,
     -- tipMsg contains last message and length incl. newline
@@ -228,54 +256,126 @@ msgLogFileName = "messages"
 logFileExt :: String
 logFileExt = ".log"
 
-newtype StoreIO a = StoreIO {unStoreIO :: IO a}
+newtype StoreIO (s :: QSType) a = StoreIO {unStoreIO :: IO a}
   deriving newtype (Functor, Applicative, Monad)
 
-instance STMStoreClass JournalMsgStore where
-  stmQueueStore JournalMsgStore {queueStore} = queueStore
-  mkQueue st rId qr = do
-    queueLock <- getMapLock (queueLocks st) rId
-    queueRec <- newTVar $ Just qr
-    msgQueue_ <- newTVar Nothing
-    activeAt <- newTVar 0
-    queueState <- newTVar Nothing
-    pure $
-      JournalQueue
-        { recipientId = rId,
-          queueLock,
-          queueRec,
-          msgQueue_,
-          activeAt,
-          queueState
-        }
-  msgQueue_' = msgQueue_
+instance StoreQueueClass (JournalQueue s) where
+  type MsgQueue (JournalQueue s) = JournalMsgQueue s
+  recipientId = recipientId'
+  {-# INLINE recipientId #-}
+  queueRec = queueRec'
+  {-# INLINE queueRec #-}
+  msgQueue = msgQueue'
+  {-# INLINE msgQueue #-}
+  withQueueLock :: JournalQueue s -> String -> IO a -> IO a
+  withQueueLock = withLock' . queueLock
+  {-# INLINE withQueueLock #-}
 
-instance MsgStoreClass JournalMsgStore where
-  type StoreMonad JournalMsgStore = StoreIO
-  type StoreQueue JournalMsgStore = JournalQueue
-  type MsgQueue JournalMsgStore = JournalMsgQueue
-  type MsgStoreConfig JournalMsgStore = JournalStoreConfig
+instance QueueStoreClass (JournalQueue s) (QStore s) where
+  type QueueStoreCfg (QStore s) = QStoreCfg s
 
-  newMsgStore :: JournalStoreConfig -> IO JournalMsgStore
-  newMsgStore config = do
+  newQueueStore :: QStoreCfg s -> IO (QStore s)
+  newQueueStore = \case
+    MQStoreCfg -> MQStore <$> newQueueStore @(JournalQueue s) ()
+    PQStoreCfg dbOpts confirmMigrations -> PQStore <$> newQueueStore @(JournalQueue s) (dbOpts, confirmMigrations)
+
+  loadedQueues = \case
+    MQStore st -> loadedQueues st
+    PQStore st -> loadedQueues st
+  {-# INLINE loadedQueues #-}
+
+  queueCounts = \case
+    -- TODO [postgres] combine these functions
+    MQStore st -> queueCounts @(JournalQueue s) st
+    PQStore st -> queueCounts @(JournalQueue s) st
+  {-# INLINE queueCounts #-}
+
+  addQueue_ = \case
+    MQStore st -> addQueue_ st
+    PQStore st -> addQueue_ st
+  {-# INLINE addQueue_ #-}
+
+  getQueue_ = \case
+    MQStore st -> getQueue_ st
+    PQStore st -> getQueue_ st
+  {-# INLINE getQueue_ #-}
+
+  secureQueue = \case
+    MQStore st -> secureQueue st
+    PQStore st -> secureQueue st
+  {-# INLINE secureQueue #-}
+
+  addQueueNotifier = \case
+    MQStore st -> addQueueNotifier st
+    PQStore st -> addQueueNotifier st
+  {-# INLINE addQueueNotifier #-}
+
+  deleteQueueNotifier = \case
+    MQStore st -> deleteQueueNotifier st
+    PQStore st -> deleteQueueNotifier st
+  {-# INLINE deleteQueueNotifier #-}
+
+  suspendQueue = \case
+    MQStore st -> suspendQueue st
+    PQStore st -> suspendQueue st
+  {-# INLINE suspendQueue #-}
+
+  blockQueue = \case
+    MQStore st -> blockQueue st
+    PQStore st -> blockQueue st
+  {-# INLINE blockQueue #-}
+
+  unblockQueue = \case
+    MQStore st -> unblockQueue st
+    PQStore st -> unblockQueue st
+  {-# INLINE unblockQueue #-}
+
+  updateQueueTime = \case
+    MQStore st -> updateQueueTime st
+    PQStore st -> updateQueueTime st
+  {-# INLINE updateQueueTime #-}
+
+  deleteStoreQueue = \case
+    MQStore st -> deleteStoreQueue st
+    PQStore st -> deleteStoreQueue st
+  {-# INLINE deleteStoreQueue #-}
+
+
+instance MsgStoreClass (JournalMsgStore s) where
+  type StoreMonad (JournalMsgStore s) = StoreIO s
+  type QueueStore (JournalMsgStore s) = QStore s
+  type StoreQueue (JournalMsgStore s) = JournalQueue s
+  type MsgStoreConfig (JournalMsgStore s) = JournalStoreConfig s
+
+  newMsgStore :: JournalStoreConfig s -> IO (JournalMsgStore s)
+  newMsgStore config@JournalStoreConfig {queueStoreCfg} = do
     random <- newTVarIO =<< newStdGen
     queueLocks <- TM.emptyIO
-    queueStore <- newQueueStore
+    queueStore_ <- newQueueStore @(JournalQueue s) queueStoreCfg
     expireBackupsBefore <- addUTCTime (- expireBackupsAfter config) <$> getCurrentTime
-    pure JournalMsgStore {config, random, queueLocks, queueStore, expireBackupsBefore}
+    pure JournalMsgStore {config, random, queueLocks, queueStore_, expireBackupsBefore}
 
-  setStoreLog :: JournalMsgStore -> StoreLog 'WriteMode -> IO ()
-  setStoreLog st sl = atomically $ writeTVar (storeLog $ queueStore st) (Just sl)
+  closeMsgStore :: JournalMsgStore s -> IO ()
+  closeMsgStore ms = case queueStore_ ms of
+    MQStore st -> do
+      readTVarIO (storeLog st) >>= mapM_ closeStoreLog
+      closeQueues $ loadedQueues @(JournalQueue s) st
+    PQStore st ->
+      closeQueues $ loadedQueues @(JournalQueue s) st
+    where
+      closeQueues qs = readTVarIO qs >>= mapM_ closeMsgQueue
 
-  closeMsgStore JournalMsgStore {queueStore = st} = do
-    readTVarIO (storeLog st) >>= mapM_ closeStoreLog
-    readTVarIO (queues st) >>= mapM_ closeMsgQueue
+  withActiveMsgQueues :: Monoid a => JournalMsgStore s -> (JournalQueue s -> IO a) -> IO a
+  withActiveMsgQueues ms f = case queueStore_ ms of
+    MQStore st -> withLoadedQueues st f
+    PQStore st -> withLoadedQueues st f
 
   -- This function is a "foldr" that opens and closes all queues, processes them as defined by action and accumulates the result.
   -- It is used to export storage to a single file and also to expire messages and validate all queues when server is started.
   -- TODO this function requires case-sensitive file system, because it uses queue directory as recipient ID.
   -- It can be made to support case-insensite FS by supporting more than one queue per directory, by getting recipient ID from state file name.
-  withAllMsgQueues :: forall a. Monoid a => Bool -> JournalMsgStore -> (JournalQueue -> IO a) -> IO a
+  -- TODO [postgres] this should simply load all known queues and process them
+  withAllMsgQueues :: forall a. Monoid a => Bool -> JournalMsgStore s -> (JournalQueue s -> IO a) -> IO a
   withAllMsgQueues tty ms@JournalMsgStore {config} action = ifM (doesDirectoryExist storePath) processStore (pure mempty)
     where
       processStore = do
@@ -315,44 +415,58 @@ instance MsgStoreClass JournalMsgStore where
               (pure $ Just (queueId', path'))
               (Nothing <$ putStrLn ("Error: path " <> path' <> " is not a directory, skipping"))
 
-  logQueueStates :: JournalMsgStore -> IO ()
+  logQueueStates :: JournalMsgStore s -> IO ()
   logQueueStates ms = withActiveMsgQueues ms $ unStoreIO . logQueueState
 
-  logQueueState :: JournalQueue -> StoreIO ()
+  logQueueState :: JournalQueue s -> StoreIO s ()
   logQueueState q =
     StoreIO . void $
-      readTVarIO (msgQueue_ q)
+      readTVarIO (msgQueue' q)
         $>>= \mq -> readTVarIO (handles mq)
         $>>= (\hs -> (readTVarIO (state mq) >>= appendState (stateHandle hs)) $> Just ())
 
-  recipientId' = recipientId
-  {-# INLINE recipientId' #-}
+  queueStore = queueStore_
+  {-# INLINE queueStore #-}
 
-  queueRec' = queueRec
-  {-# INLINE queueRec' #-}
+  mkQueue :: JournalMsgStore s -> RecipientId -> QueueRec -> IO (JournalQueue s)
+  mkQueue ms rId qr = do
+    queueLock <- atomically $ getMapLock (queueLocks ms) rId
+    queueRec' <- newTVarIO $ Just qr
+    msgQueue' <- newTVarIO Nothing
+    activeAt <- newTVarIO 0
+    queueState <- newTVarIO Nothing
+    pure $
+      JournalQueue
+        { recipientId' = rId,
+          queueLock,
+          queueRec',
+          msgQueue',
+          activeAt,
+          queueState
+        }
 
-  getMsgQueue :: JournalMsgStore -> JournalQueue -> Bool -> StoreIO JournalMsgQueue
-  getMsgQueue ms@JournalMsgStore {random} q'@JournalQueue {recipientId = rId, msgQueue_} forWrite =
-    StoreIO $ readTVarIO msgQueue_ >>= maybe newQ pure
+  getMsgQueue :: JournalMsgStore s -> JournalQueue s -> Bool -> StoreIO s (JournalMsgQueue s)
+  getMsgQueue ms@JournalMsgStore {random} q'@JournalQueue {recipientId' = rId, msgQueue'} forWrite =
+    StoreIO $ readTVarIO msgQueue' >>= maybe newQ pure
     where
       newQ = do
         let dir = msgQueueDirectory ms rId
             statePath = msgQueueStatePath dir $ B.unpack (strEncode rId)
             queue = JMQueue {queueDirectory = dir, statePath}
         q <- ifM (doesDirectoryExist dir) (openMsgQueue ms queue forWrite) (createQ queue)
-        atomically $ writeTVar msgQueue_ $ Just q
+        atomically $ writeTVar msgQueue' $ Just q
         st <- readTVarIO $ state q
         atomically $ writeTVar (queueState q') $ Just $! qState st
         pure q
         where
-          createQ :: JMQueue -> IO JournalMsgQueue
+          createQ :: JMQueue -> IO (JournalMsgQueue s)
           createQ queue = do
             -- folder and files are not created here,
             -- to avoid file IO for queues without messages during subscription
             journalId <- newJournalId random
             mkJournalQueue queue (newMsgQueueState journalId) Nothing
 
-  getPeekMsgQueue :: JournalMsgStore -> JournalQueue -> StoreIO (Maybe (JournalMsgQueue, Message))
+  getPeekMsgQueue :: JournalMsgStore s -> JournalQueue s -> StoreIO s (Maybe (JournalMsgQueue s, Message))
   getPeekMsgQueue ms q@JournalQueue {queueState} =
     StoreIO (readTVarIO queueState) >>= \case
       Just QState {hasPending} -> if hasPending then peek else pure Nothing
@@ -371,9 +485,9 @@ instance MsgStoreClass JournalMsgStore where
         (mq,) <$$> tryPeekMsg_ q mq
 
   -- only runs action if queue is not empty
-  withIdleMsgQueue :: Int64 -> JournalMsgStore -> JournalQueue -> (JournalMsgQueue -> StoreIO a) -> StoreIO (Maybe a, Int)
+  withIdleMsgQueue :: Int64 -> JournalMsgStore s -> JournalQueue s -> (JournalMsgQueue s -> StoreIO s a) -> StoreIO s (Maybe a, Int)
   withIdleMsgQueue now ms@JournalMsgStore {config} q@JournalQueue {queueState} action =
-    StoreIO $ readTVarIO (msgQueue_ q) >>= \case
+    StoreIO $ readTVarIO (msgQueue' q) >>= \case
       Nothing ->
         E.bracket
           getNonEmptyMsgQueue
@@ -392,7 +506,7 @@ instance MsgStoreClass JournalMsgStore where
         sz <- unStoreIO $ getQueueSize_ mq
         pure (r, sz)
     where
-      getNonEmptyMsgQueue :: IO (Maybe JournalMsgQueue)
+      getNonEmptyMsgQueue :: IO (Maybe (JournalMsgQueue s))
       getNonEmptyMsgQueue =
         readTVarIO queueState >>= \case
           Just QState {hasStored}
@@ -405,17 +519,17 @@ instance MsgStoreClass JournalMsgStore where
               Just QState {hasStored} | not hasStored -> closeMsgQueue q $> Nothing
               _ -> pure $ Just mq
 
-  deleteQueue :: JournalMsgStore -> JournalQueue -> IO (Either ErrorType QueueRec)
+  deleteQueue :: JournalMsgStore s -> JournalQueue s -> IO (Either ErrorType QueueRec)
   deleteQueue ms q = fst <$$> deleteQueue_ ms q
 
-  deleteQueueSize :: JournalMsgStore -> JournalQueue -> IO (Either ErrorType (QueueRec, Int))
+  deleteQueueSize :: JournalMsgStore s -> JournalQueue s -> IO (Either ErrorType (QueueRec, Int))
   deleteQueueSize ms q =
     deleteQueue_ ms q >>= mapM (traverse getSize)
     -- traverse operates on the second tuple element
     where
       getSize = maybe (pure (-1)) (fmap size . readTVarIO . state)
 
-  getQueueMessages_ :: Bool -> JournalQueue -> JournalMsgQueue -> StoreIO [Message]
+  getQueueMessages_ :: Bool -> JournalQueue s -> JournalMsgQueue s -> StoreIO s [Message]
   getQueueMessages_ drainMsgs q' q = StoreIO (run [])
     where
       run msgs = readTVarIO (handles q) >>= maybe (pure []) (getMsg msgs)
@@ -426,7 +540,7 @@ instance MsgStoreClass JournalMsgStore where
             updateReadPos q' q drainMsgs len hs
             (msg :) <$> run msgs
 
-  writeMsg :: JournalMsgStore -> JournalQueue -> Bool -> Message -> ExceptT ErrorType IO (Maybe (Message, Bool))
+  writeMsg :: JournalMsgStore s -> JournalQueue s -> Bool -> Message -> ExceptT ErrorType IO (Maybe (Message, Bool))
   writeMsg ms q' logState msg = isolateQueue q' "writeMsg" $ do
     q <- getMsgQueue ms q' True
     StoreIO $ (`E.finally` updateActiveAt q') $ do
@@ -473,15 +587,15 @@ instance MsgStoreClass JournalMsgStore where
             pure (newJournalState journalId, wh)
 
   -- can ONLY be used while restoring messages, not while server running
-  setOverQuota_ :: JournalQueue -> IO ()
+  setOverQuota_ :: JournalQueue s -> IO ()
   setOverQuota_ q =
-    readTVarIO (msgQueue_ q)
+    readTVarIO (msgQueue' q)
       >>= mapM_ (\JournalMsgQueue {state} -> atomically $ modifyTVar' state $ \st -> st {canWrite = False})
 
-  getQueueSize_ :: JournalMsgQueue -> StoreIO Int
+  getQueueSize_ :: JournalMsgQueue s -> StoreIO s Int
   getQueueSize_ JournalMsgQueue {state} = StoreIO $ size <$> readTVarIO state
 
-  tryPeekMsg_ :: JournalQueue -> JournalMsgQueue -> StoreIO (Maybe Message)
+  tryPeekMsg_ :: JournalQueue s -> JournalMsgQueue s -> StoreIO s (Maybe Message)
   tryPeekMsg_ q mq@JournalMsgQueue {tipMsg, handles} =
     StoreIO $ (readTVarIO handles $>>= chooseReadJournal q mq True $>>= peekMsg)
     where
@@ -492,7 +606,7 @@ instance MsgStoreClass JournalMsgStore where
             atomically $ writeTVar tipMsg $ Just (Just ml)
             pure $ Just msg
 
-  tryDeleteMsg_ :: JournalQueue -> JournalMsgQueue -> Bool -> StoreIO ()
+  tryDeleteMsg_ :: JournalQueue s -> JournalMsgQueue s -> Bool -> StoreIO s ()
   tryDeleteMsg_ q mq@JournalMsgQueue {tipMsg, handles} logState = StoreIO $ (`E.finally` when logState (updateActiveAt q)) $
     void $
       readTVarIO tipMsg -- if there is no cached tipMsg, do nothing
@@ -500,11 +614,11 @@ instance MsgStoreClass JournalMsgStore where
         $>>= \len -> readTVarIO handles
         $>>= \hs -> updateReadPos q mq logState len hs $> Just ()
 
-  isolateQueue :: JournalQueue -> String -> StoreIO a -> ExceptT ErrorType IO a
-  isolateQueue JournalQueue {recipientId, queueLock} op =
-    tryStore' op recipientId . withLock' queueLock op . unStoreIO
+  isolateQueue :: JournalQueue s -> String -> StoreIO s a -> ExceptT ErrorType IO a
+  isolateQueue JournalQueue {recipientId' = rId, queueLock} op a =
+    tryStore' op rId $ withLock' queueLock op $ unStoreIO a
 
-updateActiveAt :: JournalQueue -> IO ()
+updateActiveAt :: JournalQueue s -> IO ()
 updateActiveAt q = atomically . writeTVar (activeAt q) . systemSeconds =<< getSystemTime
 
 tryStore' :: String -> RecipientId -> IO a -> ExceptT ErrorType IO a
@@ -518,10 +632,10 @@ tryStore op rId a = ExceptT $ E.mask_ $ E.try a >>= either storeErr pure
       let e' = intercalate ", " [op, B.unpack $ strEncode rId, show e]
        in logError ("STORE: " <> T.pack e') $> Left (STORE e')
 
-isolateQueueId :: String -> JournalMsgStore -> RecipientId -> IO (Either ErrorType a) -> ExceptT ErrorType IO a
+isolateQueueId :: String -> JournalMsgStore s -> RecipientId -> IO (Either ErrorType a) -> ExceptT ErrorType IO a
 isolateQueueId op ms rId = tryStore op rId . withLockMap (queueLocks ms) rId op
 
-openMsgQueue :: JournalMsgStore -> JMQueue -> Bool -> IO JournalMsgQueue
+openMsgQueue :: JournalMsgStore s -> JMQueue -> Bool -> IO (JournalMsgQueue s)
 openMsgQueue ms@JournalMsgStore {config} q@JMQueue {queueDirectory = dir, statePath} forWrite = do
   (st_, shouldBackup) <- readQueueState ms statePath
   case st_ of
@@ -581,7 +695,7 @@ openMsgQueue ms@JournalMsgStore {config} q@JMQueue {queueDirectory = dir, stateP
         backupPathTime = iso8601ParseM . T.unpack <=< T.stripSuffix ".bak" <=< T.stripPrefix statePathPfx . T.pack
         statePathPfx = T.pack $ takeFileName statePath <> "."
 
-mkJournalQueue :: JMQueue -> MsgQueueState -> Maybe MsgQueueHandles -> IO JournalMsgQueue
+mkJournalQueue :: JMQueue -> MsgQueueState -> Maybe MsgQueueHandles -> IO (JournalMsgQueue s)
 mkJournalQueue queue st hs_ = do
   state <- newTVarIO st
   tipMsg <- newTVarIO Nothing
@@ -590,7 +704,7 @@ mkJournalQueue queue st hs_ = do
   -- to avoid map lookup on queue operations
   pure JournalMsgQueue {queue, state, tipMsg, handles}
 
-chooseReadJournal :: JournalQueue -> JournalMsgQueue -> Bool -> MsgQueueHandles -> IO (Maybe (JournalState 'JTRead, Handle))
+chooseReadJournal :: JournalQueue s -> JournalMsgQueue s -> Bool -> MsgQueueHandles -> IO (Maybe (JournalState 'JTRead, Handle))
 chooseReadJournal q' q log' hs = do
   st@MsgQueueState {writeState = ws, readState = rs} <- readTVarIO (state q)
   case writeHandle hs of
@@ -606,7 +720,7 @@ chooseReadJournal q' q log' hs = do
     _ | msgPos rs >= msgCount rs && journalId rs == journalId ws -> pure Nothing
     _ -> pure $ Just (rs, readHandle hs)
 
-updateQueueState :: JournalQueue -> JournalMsgQueue -> Bool -> MsgQueueHandles -> MsgQueueState -> STM () -> IO ()
+updateQueueState :: JournalQueue s -> JournalMsgQueue s -> Bool -> MsgQueueHandles -> MsgQueueState -> STM () -> IO ()
 updateQueueState q' q log' hs st a = do
   unless (validQueueState st) $ E.throwIO $ userError $ "updateQueueState invalid state: " <> show st
   when log' $ appendState (stateHandle hs) st
@@ -620,7 +734,7 @@ appendState h = E.uninterruptibleMask_ . appendState_ h
 appendState_ :: Handle -> MsgQueueState -> IO ()
 appendState_ h st = B.hPutStr h $ strEncode st `B.snoc` '\n'
 
-updateReadPos :: JournalQueue -> JournalMsgQueue -> Bool -> Int64 -> MsgQueueHandles -> IO ()
+updateReadPos :: JournalQueue s -> JournalMsgQueue s -> Bool -> Int64 -> MsgQueueHandles -> IO ()
 updateReadPos q' q log' len hs = do
   st@MsgQueueState {readState = rs, size} <- readTVarIO (state q)
   let JournalState {msgPos, bytePos} = rs
@@ -629,7 +743,7 @@ updateReadPos q' q log' len hs = do
       st' = st {readState = rs', size = size - 1}
   updateQueueState q' q log' hs st' $ writeTVar (tipMsg q) Nothing
 
-msgQueueDirectory :: JournalMsgStore -> RecipientId -> FilePath
+msgQueueDirectory :: JournalMsgStore s -> RecipientId -> FilePath
 msgQueueDirectory JournalMsgStore {config = JournalStoreConfig {storePath, pathParts}} rId =
   storePath </> B.unpack (B.intercalate "/" $ splitSegments pathParts $ strEncode rId)
   where
@@ -652,7 +766,7 @@ createNewJournal dir journalId = do
 newJournalId :: TVar StdGen -> IO ByteString
 newJournalId g = strEncode <$> atomically (stateTVar g $ genByteString 12)
 
-openJournals :: JournalMsgStore -> FilePath -> MsgQueueState -> Handle -> IO (MsgQueueState, Handle, Maybe Handle)
+openJournals :: JournalMsgStore s -> FilePath -> MsgQueueState -> Handle -> IO (MsgQueueState, Handle, Maybe Handle)
 openJournals ms dir st@MsgQueueState {readState = rs, writeState = ws} sh = do
   let rjId = journalId rs
       wjId = journalId ws
@@ -737,7 +851,7 @@ handleError cxt path a =
 
 -- This function is supposed to be resilient to crashes while updating state files,
 -- and also resilient to crashes during its execution.
-readQueueState :: JournalMsgStore -> FilePath -> IO (Maybe MsgQueueState, Bool)
+readQueueState :: JournalMsgStore s -> FilePath -> IO (Maybe MsgQueueState, Bool)
 readQueueState JournalMsgStore {config} statePath =
   ifM
     (doesFileExist tempBackup)
@@ -801,10 +915,11 @@ validQueueState MsgQueueState {readState = rs, writeState = ws, size}
         && msgPos ws == msgCount ws
         && bytePos ws == byteCount ws
 
-deleteQueue_ :: JournalMsgStore -> JournalQueue -> IO (Either ErrorType (QueueRec, Maybe JournalMsgQueue))
+-- TODO [postgres] possibly, we need to remove the lock from map
+deleteQueue_ :: JournalMsgStore s -> JournalQueue s -> IO (Either ErrorType (QueueRec, Maybe (JournalMsgQueue s)))
 deleteQueue_ ms q =
   runExceptT $ isolateQueueId "deleteQueue_" ms rId $
-    deleteQueue' ms q >>= mapM remove
+    deleteStoreQueue (queueStore_ ms) q >>= mapM remove
   where
     rId = recipientId q
     remove r@(_, mq_) = do
@@ -812,10 +927,10 @@ deleteQueue_ ms q =
       removeQueueDirectory ms rId
       pure r
 
-closeMsgQueue :: JournalQueue -> IO ()
-closeMsgQueue JournalQueue {msgQueue_} = atomically (swapTVar msgQueue_ Nothing) >>= mapM_ closeMsgQueueHandles
+closeMsgQueue :: JournalQueue s -> IO ()
+closeMsgQueue JournalQueue {msgQueue'} = atomically (swapTVar msgQueue' Nothing) >>= mapM_ closeMsgQueueHandles
 
-closeMsgQueueHandles :: JournalMsgQueue -> IO ()
+closeMsgQueueHandles :: JournalMsgQueue s -> IO ()
 closeMsgQueueHandles q = readTVarIO (handles q) >>= mapM_ closeHandles
   where
     closeHandles (MsgQueueHandles sh rh wh_) = do
@@ -823,7 +938,7 @@ closeMsgQueueHandles q = readTVarIO (handles q) >>= mapM_ closeHandles
       hClose rh
       mapM_ hClose wh_
 
-removeQueueDirectory :: JournalMsgStore -> RecipientId -> IO ()
+removeQueueDirectory :: JournalMsgStore s -> RecipientId -> IO ()
 removeQueueDirectory st = removeQueueDirectory_ . msgQueueDirectory st
 
 removeQueueDirectory_ :: FilePath -> IO ()

src/Simplex/Messaging/Server/MsgStore/STM.hs

@@ -7,12 +7,14 @@
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE TupleSections #-}
 
 module Simplex.Messaging.Server.MsgStore.STM
   ( STMMsgStore (..),
     STMStoreConfig (..),
+    STMQueue,
   )
 where
 
@@ -25,25 +27,25 @@ import Simplex.Messaging.Protocol
 import Simplex.Messaging.Server.MsgStore.Types
 import Simplex.Messaging.Server.QueueStore
 import Simplex.Messaging.Server.QueueStore.STM
+import Simplex.Messaging.Server.QueueStore.Types
 import Simplex.Messaging.Server.StoreLog
 import Simplex.Messaging.Util ((<$$>), ($>>=))
-import System.IO (IOMode (..))
 
 data STMMsgStore = STMMsgStore
   { storeConfig :: STMStoreConfig,
-    queueStore :: STMQueueStore STMQueue
+    queueStore_ :: STMQueueStore STMQueue
   }
 
 data STMQueue = STMQueue
   { -- To avoid race conditions and errors when restoring queues,
     -- Nothing is written to TVar when queue is deleted.
-    recipientId :: RecipientId,
-    queueRec :: TVar (Maybe QueueRec),
-    msgQueue_ :: TVar (Maybe STMMsgQueue)
+    recipientId' :: RecipientId,
+    queueRec' :: TVar (Maybe QueueRec),
+    msgQueue' :: TVar (Maybe STMMsgQueue)
   }
 
 data STMMsgQueue = STMMsgQueue
-  { msgQueue :: TQueue Message,
+  { msgTQueue :: TQueue Message,
     canWrite :: TVar Bool,
     size :: TVar Int
   }
@@ -53,59 +55,61 @@ data STMStoreConfig = STMStoreConfig
     quota :: Int
   }
 
-instance STMStoreClass STMMsgStore where
-  stmQueueStore = queueStore
-  mkQueue _ rId qr = STMQueue rId <$> newTVar (Just qr) <*> newTVar Nothing
-  msgQueue_' = msgQueue_
+instance StoreQueueClass STMQueue where
+  type MsgQueue STMQueue = STMMsgQueue
+  recipientId = recipientId'
+  {-# INLINE recipientId #-}
+  queueRec = queueRec'
+  {-# INLINE queueRec #-}
+  msgQueue = msgQueue'
+  {-# INLINE msgQueue #-}
+  withQueueLock _ _ = id
+  {-# INLINE withQueueLock #-}
 
 instance MsgStoreClass STMMsgStore where
   type StoreMonad STMMsgStore = STM
+  type QueueStore STMMsgStore = STMQueueStore STMQueue
   type StoreQueue STMMsgStore = STMQueue
-  type MsgQueue STMMsgStore = STMMsgQueue
   type MsgStoreConfig STMMsgStore = STMStoreConfig
 
   newMsgStore :: STMStoreConfig -> IO STMMsgStore
   newMsgStore storeConfig = do
-    queueStore <- newQueueStore
-    pure STMMsgStore {storeConfig, queueStore}
+    queueStore_ <- newQueueStore @STMQueue ()
+    pure STMMsgStore {storeConfig, queueStore_}
 
-  setStoreLog :: STMMsgStore -> StoreLog 'WriteMode -> IO ()
-  setStoreLog st sl = atomically $ writeTVar (storeLog $ queueStore st) (Just sl)
+  closeMsgStore st = readTVarIO (storeLog $ queueStore_ st) >>= mapM_ closeStoreLog
 
-  closeMsgStore st = readTVarIO (storeLog $ queueStore st) >>= mapM_ closeStoreLog
-
-  withAllMsgQueues _ = withActiveMsgQueues
+  withActiveMsgQueues = withLoadedQueues . queueStore_
+  {-# INLINE withActiveMsgQueues #-}
+  withAllMsgQueues _ = withLoadedQueues . queueStore_
   {-# INLINE withAllMsgQueues #-}
-
   logQueueStates _ = pure ()
   {-# INLINE logQueueStates #-}
-
   logQueueState _ = pure ()
   {-# INLINE logQueueState #-}
+  queueStore = queueStore_
+  {-# INLINE queueStore #-}
 
-  recipientId' = recipientId
-  {-# INLINE recipientId' #-}
-
-  queueRec' = queueRec
-  {-# INLINE queueRec' #-}
+  mkQueue _ rId qr = STMQueue rId <$> newTVarIO (Just qr) <*> newTVarIO Nothing
+  {-# INLINE mkQueue #-}
 
   getMsgQueue :: STMMsgStore -> STMQueue -> Bool -> STM STMMsgQueue
-  getMsgQueue _ STMQueue {msgQueue_} _ = readTVar msgQueue_ >>= maybe newQ pure
+  getMsgQueue _ STMQueue {msgQueue'} _ = readTVar msgQueue' >>= maybe newQ pure
     where
       newQ = do
-        msgQueue <- newTQueue
+        msgTQueue <- newTQueue
         canWrite <- newTVar True
         size <- newTVar 0
-        let q = STMMsgQueue {msgQueue, canWrite, size}
-        writeTVar msgQueue_ (Just q)
+        let q = STMMsgQueue {msgTQueue, canWrite, size}
+        writeTVar msgQueue' (Just q)
         pure q
 
   getPeekMsgQueue :: STMMsgStore -> STMQueue -> STM (Maybe (STMMsgQueue, Message))
-  getPeekMsgQueue _ q@STMQueue {msgQueue_} = readTVar msgQueue_ $>>= \mq -> (mq,) <$$> tryPeekMsg_ q mq
+  getPeekMsgQueue _ q@STMQueue {msgQueue'} = readTVar msgQueue' $>>= \mq -> (mq,) <$$> tryPeekMsg_ q mq
 
   -- does not create queue if it does not exist, does not delete it if it does (can't just close in-memory queue)
   withIdleMsgQueue :: Int64 -> STMMsgStore -> STMQueue -> (STMMsgQueue -> STM a) -> STM (Maybe a, Int)
-  withIdleMsgQueue _ _ STMQueue {msgQueue_} action = readTVar msgQueue_ >>= \case
+  withIdleMsgQueue _ _ STMQueue {msgQueue'} action = readTVar msgQueue' >>= \case
     Just q -> do
       r <- action q
       sz <- getQueueSize_ q
@@ -113,16 +117,16 @@ instance MsgStoreClass STMMsgStore where
     Nothing -> pure (Nothing, 0)
 
   deleteQueue :: STMMsgStore -> STMQueue -> IO (Either ErrorType QueueRec)
-  deleteQueue ms q = fst <$$> deleteQueue' ms q
+  deleteQueue ms q = fst <$$> deleteStoreQueue (queueStore_ ms) q
 
   deleteQueueSize :: STMMsgStore -> STMQueue -> IO (Either ErrorType (QueueRec, Int))
-  deleteQueueSize ms q = deleteQueue' ms q >>= mapM (traverse getSize)
+  deleteQueueSize ms q = deleteStoreQueue (queueStore_ ms) q >>= mapM (traverse getSize)
     -- traverse operates on the second tuple element
     where
       getSize = maybe (pure 0) (\STMMsgQueue {size} -> readTVarIO size)
 
   getQueueMessages_ :: Bool -> STMQueue -> STMMsgQueue -> STM [Message]
-  getQueueMessages_ drainMsgs _ = (if drainMsgs then flushTQueue else snapshotTQueue) . msgQueue
+  getQueueMessages_ drainMsgs _ = (if drainMsgs then flushTQueue else snapshotTQueue) . msgTQueue
     where
       snapshotTQueue q = do
         msgs <- flushTQueue q
@@ -131,7 +135,7 @@ instance MsgStoreClass STMMsgStore where
 
   writeMsg :: STMMsgStore -> STMQueue -> Bool -> Message -> ExceptT ErrorType IO (Maybe (Message, Bool))
   writeMsg ms q' _logState msg = liftIO $ atomically $ do
-    STMMsgQueue {msgQueue = q, canWrite, size} <- getMsgQueue ms q' True
+    STMMsgQueue {msgTQueue = q, canWrite, size} <- getMsgQueue ms q' True
     canWrt <- readTVar canWrite
     empty <- isEmptyTQueue q
     if canWrt || empty
@@ -148,17 +152,17 @@ instance MsgStoreClass STMMsgStore where
       msgQuota = MessageQuota {msgId = messageId msg, msgTs = messageTs msg}
 
   setOverQuota_ :: STMQueue -> IO ()
-  setOverQuota_ q = readTVarIO (msgQueue_ q) >>= mapM_ (\mq -> atomically $ writeTVar (canWrite mq) False)
+  setOverQuota_ q = readTVarIO (msgQueue' q) >>= mapM_ (\mq -> atomically $ writeTVar (canWrite mq) False)
 
   getQueueSize_ :: STMMsgQueue -> STM Int
   getQueueSize_ STMMsgQueue {size} = readTVar size
 
   tryPeekMsg_ :: STMQueue -> STMMsgQueue -> STM (Maybe Message)
-  tryPeekMsg_ _ = tryPeekTQueue . msgQueue
+  tryPeekMsg_ _ = tryPeekTQueue . msgTQueue
   {-# INLINE tryPeekMsg_ #-}
 
   tryDeleteMsg_ :: STMQueue -> STMMsgQueue -> Bool -> STM ()
-  tryDeleteMsg_ _ STMMsgQueue {msgQueue = q, size} _logState =
+  tryDeleteMsg_ _ STMMsgQueue {msgTQueue = q, size} _logState =
     tryReadTQueue q >>= \case
       Just _ -> modifyTVar' size (subtract 1)
       _ -> pure ()

src/Simplex/Messaging/Server/MsgStore/Types.hs

@@ -6,7 +6,9 @@
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE MultiWayIf #-}
 {-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TupleSections #-}
+{-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeFamilyDependencies #-}
 {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
 
@@ -15,7 +17,6 @@
 module Simplex.Messaging.Server.MsgStore.Types where
 
 import Control.Concurrent.STM
-import Control.Monad (foldM)
 import Control.Monad.Trans.Except
 import Data.Functor (($>))
 import Data.Int (Int64)
@@ -23,63 +24,63 @@ import Data.Kind
 import Data.Time.Clock.System (SystemTime (systemSeconds))
 import Simplex.Messaging.Protocol
 import Simplex.Messaging.Server.QueueStore
-import Simplex.Messaging.Server.StoreLog.Types
-import Simplex.Messaging.TMap (TMap)
-import Simplex.Messaging.Util ((<$$>))
-import System.IO (IOMode (..))
+import Simplex.Messaging.Server.QueueStore.Types
+import Simplex.Messaging.Util ((<$$>), ($>>=))
 
-data STMQueueStore q = STMQueueStore
-  { queues :: TMap RecipientId q,
-    senders :: TMap SenderId RecipientId,
-    notifiers :: TMap NotifierId RecipientId,
-    storeLog :: TVar (Maybe (StoreLog 'WriteMode))
-  }
-
-class MsgStoreClass s => STMStoreClass s where
-  stmQueueStore :: s -> STMQueueStore (StoreQueue s)
-  mkQueue :: s -> RecipientId -> QueueRec -> STM (StoreQueue s)
-  msgQueue_' :: StoreQueue s -> TVar (Maybe (MsgQueue s))
-
-class Monad (StoreMonad s) => MsgStoreClass s where
+class (Monad (StoreMonad s), QueueStoreClass (StoreQueue s) (QueueStore s)) => MsgStoreClass s where
   type StoreMonad s = (m :: Type -> Type) | m -> s
   type MsgStoreConfig s = c | c -> s
   type StoreQueue s = q | q -> s
-  type MsgQueue s = q | q -> s
+  type QueueStore s = qs | qs -> s
   newMsgStore :: MsgStoreConfig s -> IO s
-  setStoreLog :: s -> StoreLog 'WriteMode -> IO ()
   closeMsgStore :: s -> IO ()
+  withActiveMsgQueues :: Monoid a => s -> (StoreQueue s -> IO a) -> IO a
   withAllMsgQueues :: Monoid a => Bool -> s -> (StoreQueue s -> IO a) -> IO a
   logQueueStates :: s -> IO ()
   logQueueState :: StoreQueue s -> StoreMonad s ()
-  recipientId' :: StoreQueue s -> RecipientId
-  queueRec' :: StoreQueue s -> TVar (Maybe QueueRec)
-  getPeekMsgQueue :: s -> StoreQueue s -> StoreMonad s (Maybe (MsgQueue s, Message))
-  getMsgQueue :: s -> StoreQueue s -> Bool -> StoreMonad s (MsgQueue s)
+  queueStore :: s -> QueueStore s
+
+  -- message store methods
+  mkQueue :: s -> RecipientId -> QueueRec -> IO (StoreQueue s)
+  getMsgQueue :: s -> StoreQueue s -> Bool -> StoreMonad s (MsgQueue (StoreQueue s))
+  getPeekMsgQueue :: s -> StoreQueue s -> StoreMonad s (Maybe (MsgQueue (StoreQueue s), Message))
 
   -- the journal queue will be closed after action if it was initially closed or idle longer than interval in config
-  withIdleMsgQueue :: Int64 -> s -> StoreQueue s -> (MsgQueue s -> StoreMonad s a) -> StoreMonad s (Maybe a, Int)
+  withIdleMsgQueue :: Int64 -> s -> StoreQueue s -> (MsgQueue (StoreQueue s) -> StoreMonad s a) -> StoreMonad s (Maybe a, Int)
   deleteQueue :: s -> StoreQueue s -> IO (Either ErrorType QueueRec)
   deleteQueueSize :: s -> StoreQueue s -> IO (Either ErrorType (QueueRec, Int))
-  getQueueMessages_ :: Bool -> StoreQueue s -> MsgQueue s -> StoreMonad s [Message]
+  getQueueMessages_ :: Bool -> StoreQueue s -> MsgQueue (StoreQueue s) -> StoreMonad s [Message]
   writeMsg :: s -> StoreQueue s -> Bool -> Message -> ExceptT ErrorType IO (Maybe (Message, Bool))
   setOverQuota_ :: StoreQueue s -> IO () -- can ONLY be used while restoring messages, not while server running
-  getQueueSize_ :: MsgQueue s -> StoreMonad s Int
-  tryPeekMsg_ :: StoreQueue s -> MsgQueue s -> StoreMonad s (Maybe Message)
-  tryDeleteMsg_ :: StoreQueue s -> MsgQueue s -> Bool -> StoreMonad s ()
+  getQueueSize_ :: MsgQueue (StoreQueue s) -> StoreMonad s Int
+  tryPeekMsg_ :: StoreQueue s -> MsgQueue (StoreQueue s) -> StoreMonad s (Maybe Message)
+  tryDeleteMsg_ :: StoreQueue s -> MsgQueue (StoreQueue s) -> Bool -> StoreMonad s ()
   isolateQueue :: StoreQueue s -> String -> StoreMonad s a -> ExceptT ErrorType IO a
 
 data MSType = MSMemory | MSJournal
 
+data QSType = QSMemory | QSPostgres
+
 data SMSType :: MSType -> Type where
   SMSMemory :: SMSType 'MSMemory
   SMSJournal :: SMSType 'MSJournal
 
-data AMSType = forall s. AMSType (SMSType s)
+data SQSType :: QSType -> Type where
+  SQSMemory :: SQSType 'QSMemory
+  SQSPostgres :: SQSType 'QSPostgres
 
-withActiveMsgQueues :: (STMStoreClass s, Monoid a) => s -> (StoreQueue s -> IO a) -> IO a
-withActiveMsgQueues st f = readTVarIO (queues $ stmQueueStore st) >>= foldM run mempty
-  where
-    run !acc = fmap (acc <>) . f
+addQueue :: MsgStoreClass s => s -> RecipientId -> QueueRec -> IO (Either ErrorType (StoreQueue s))
+addQueue st = addQueue_ (queueStore st) (mkQueue st)
+{-# INLINE addQueue #-}
+
+getQueue :: (MsgStoreClass s, DirectParty p) => s -> SParty p -> QueueId -> IO (Either ErrorType (StoreQueue s))
+getQueue st = getQueue_ (queueStore st) (mkQueue st)
+{-# INLINE getQueue #-}
+
+getQueueRec :: (MsgStoreClass s, DirectParty p) => s -> SParty p -> QueueId -> IO (Either ErrorType (StoreQueue s, QueueRec))
+getQueueRec st party qId =
+  getQueue st party qId
+    $>>= (\q -> maybe (Left AUTH) (Right . (q,)) <$> readTVarIO (queueRec q))
 
 getQueueMessages :: MsgStoreClass s => Bool -> s -> StoreQueue s -> ExceptT ErrorType IO [Message]
 getQueueMessages drainMsgs st q = withPeekMsgQueue st q "getQueueSize" $ maybe (pure []) (getQueueMessages_ drainMsgs q . fst)
@@ -112,7 +113,7 @@ tryDelPeekMsg st q msgId' =
         | otherwise -> pure (Nothing, Just msg)
 
 -- The action is called with Nothing when it is known that the queue is empty
-withPeekMsgQueue :: MsgStoreClass s => s -> StoreQueue s -> String -> (Maybe (MsgQueue s, Message) -> StoreMonad s a) -> ExceptT ErrorType IO a
+withPeekMsgQueue :: MsgStoreClass s => s -> StoreQueue s -> String -> (Maybe (MsgQueue (StoreQueue s), Message) -> StoreMonad s a) -> ExceptT ErrorType IO a
 withPeekMsgQueue st q op a = isolateQueue q op $ getPeekMsgQueue st q >>= a
 {-# INLINE withPeekMsgQueue #-}
 
@@ -128,7 +129,7 @@ idleDeleteExpiredMsgs now st q old =
   isolateQueue q "idleDeleteExpiredMsgs" $
     withIdleMsgQueue now st q (deleteExpireMsgs_ old q)
 
-deleteExpireMsgs_ :: MsgStoreClass s => Int64 -> StoreQueue s -> MsgQueue s -> StoreMonad s Int
+deleteExpireMsgs_ :: MsgStoreClass s => Int64 -> StoreQueue s -> MsgQueue (StoreQueue s) -> StoreMonad s Int
 deleteExpireMsgs_ old q mq = do
   n <- loop 0
   logQueueState q

src/Simplex/Messaging/Server/QueueStore.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DerivingStrategies #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE KindSignatures #-}
 {-# LANGUAGE LambdaCase #-}
@@ -11,9 +12,14 @@ module Simplex.Messaging.Server.QueueStore where
 import Control.Applicative ((<|>))
 import Data.Functor (($>))
 import Data.Int (Int64)
+import Data.Text.Encoding (decodeLatin1, encodeUtf8)
 import Data.Time.Clock.System (SystemTime (..), getSystemTime)
+import Database.PostgreSQL.Simple.FromField (FromField (..))
+import Database.PostgreSQL.Simple.ToField (ToField (..))
+import Simplex.Messaging.Agent.Store.Postgres.DB (fromTextField_)
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Protocol
+import Simplex.Messaging.Util (eitherToMaybe)
 
 data QueueRec = QueueRec
   { recipientKey :: !RcvPublicAuthKey,
@@ -56,8 +62,13 @@ instance StrEncoding ServerEntityStatus where
       <|> "blocked," *> (EntityBlocked <$> strP)
       <|> "off" $> EntityOff
 
+instance FromField ServerEntityStatus where fromField = fromTextField_ $ eitherToMaybe . strDecode . encodeUtf8
+
+instance ToField ServerEntityStatus where toField = toField . decodeLatin1 . strEncode
+
 newtype RoundedSystemTime = RoundedSystemTime Int64
   deriving (Eq, Ord, Show)
+  deriving newtype (FromField, ToField)
 
 instance StrEncoding RoundedSystemTime where
   strEncode (RoundedSystemTime t) = strEncode t

src/Simplex/Messaging/Server/QueueStore/Postgres.hs

@@ -0,0 +1,376 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE InstanceSigs #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Simplex.Messaging.Server.QueueStore.Postgres where
+
+import Control.Concurrent.STM
+import qualified Control.Exception as E
+import Control.Logger.Simple
+import Control.Monad
+import Data.Bitraversable (bimapM)
+import Data.Functor (($>))
+import Data.Int (Int64)
+import qualified Data.Map.Strict as M
+import Data.Maybe (catMaybes, mapMaybe)
+import qualified Data.Text as T
+import Database.PostgreSQL.Simple (Binary (..), Only (..), Query, SqlError, (:.) (..))
+import qualified Database.PostgreSQL.Simple as PSQL
+import Database.PostgreSQL.Simple.Errors (ConstraintViolation (..), constraintViolation)
+import Database.PostgreSQL.Simple.SqlQQ (sql)
+import Simplex.Messaging.Agent.Client (withLockMap)
+import Simplex.Messaging.Agent.Lock (Lock)
+import Simplex.Messaging.Agent.Store.Postgres (createDBStore)
+import Simplex.Messaging.Agent.Store.Postgres.Common
+import Simplex.Messaging.Agent.Store.Postgres.DB (FromField (..), ToField (..), blobFieldDecoder)
+import qualified Simplex.Messaging.Agent.Store.Postgres.DB as DB
+import Simplex.Messaging.Agent.Store.Shared (MigrationConfirmation)
+import qualified Simplex.Messaging.Crypto as C
+import Simplex.Messaging.Encoding.String
+import Simplex.Messaging.Protocol
+import Simplex.Messaging.Server.QueueStore
+import Simplex.Messaging.Server.QueueStore.Postgres.Migrations (serverMigrations)
+import Simplex.Messaging.Server.QueueStore.STM (readQueueRecIO, setStatus, withQueueRec)
+import Simplex.Messaging.Server.QueueStore.Types
+import Simplex.Messaging.TMap (TMap)
+import qualified Simplex.Messaging.TMap as TM
+import Simplex.Messaging.Util (firstRow, ifM, tshow, ($>>), ($>>=), (<$$), (<$$>))
+import System.Exit (exitFailure)
+import System.IO (hFlush, stdout)
+
+data PostgresQueueStore q = PostgresQueueStore
+  { dbStore :: DBStore,
+    -- this map caches all created and opened queues
+    queues :: TMap RecipientId q,
+    -- this map only cashes the queues that were attempted to send messages to,
+    senders :: TMap SenderId RecipientId,
+    -- this map only cashes the queues that were attempted to be subscribed to,
+    notifiers :: TMap NotifierId RecipientId,
+    notifierLocks :: TMap NotifierId Lock
+  }
+
+instance StoreQueueClass q => QueueStoreClass q (PostgresQueueStore q) where
+  type QueueStoreCfg (PostgresQueueStore q) = (DBOpts, MigrationConfirmation)
+
+  newQueueStore :: (DBOpts, MigrationConfirmation)  -> IO (PostgresQueueStore q)
+  newQueueStore (dbOpts, confirmMigrations) = do
+    dbStore <- either err pure =<< createDBStore dbOpts serverMigrations confirmMigrations
+    queues <- TM.emptyIO
+    senders <- TM.emptyIO
+    notifiers <- TM.emptyIO
+    notifierLocks <- TM.emptyIO
+    pure PostgresQueueStore {dbStore, queues, senders, notifiers, notifierLocks}
+    where
+      err e = do
+        logError $ "STORE: newQueueStore, error opening PostgreSQL database, " <> tshow e
+        exitFailure
+
+  loadedQueues = queues
+  {-# INLINE loadedQueues #-}
+
+  queueCounts :: PostgresQueueStore q -> IO QueueCounts
+  queueCounts st =
+    withConnection (dbStore st) $ \db -> do
+      (queueCount, notifierCount) : _ <-
+        DB.query_
+          db
+          [sql|
+            SELECT
+              (SELECT COUNT(1) FROM msg_queues) AS queue_count, 
+              (SELECT COUNT(1) FROM msg_notifiers) AS notifier_count
+          |]
+      pure QueueCounts {queueCount, notifierCount}
+
+  -- this implementation assumes that the lock is already taken by addQueue
+  -- and relies on unique constraints in the database to prevent duplicate IDs.
+  addQueue_ :: PostgresQueueStore q -> (RecipientId -> QueueRec -> IO q) -> RecipientId -> QueueRec -> IO (Either ErrorType q)
+  addQueue_ st mkQ rId qr = do
+    sq <- mkQ rId qr
+    withQueueLock sq "addQueue_" $
+      addDB $>> add sq
+    where
+      PostgresQueueStore {queues, senders} = st
+      addDB =
+        withDB "addQueue_" st $ \db ->
+          E.try (insertQueueDB db rId qr) >>= bimapM handleDuplicate pure
+      add sq = do
+        atomically $ TM.insert rId sq queues
+        atomically $ TM.insert (senderId qr) rId senders
+        pure $ Right sq
+      -- Not doing duplicate checks in maps as the probability of duplicates is very low.
+      -- It needs to be reconsidered when IDs are supplied by the users.
+      -- hasId = anyM [TM.memberIO rId queues, TM.memberIO senderId senders, hasNotifier]
+      -- hasNotifier = maybe (pure False) (\NtfCreds {notifierId} -> TM.memberIO notifierId notifiers) notifier
+
+  getQueue_ :: DirectParty p => PostgresQueueStore q -> (RecipientId -> QueueRec -> IO q) -> SParty p -> QueueId -> IO (Either ErrorType q)
+  getQueue_ st mkQ party qId = case party of
+    SRecipient -> getRcvQueue qId
+    SSender -> TM.lookupIO qId senders >>= maybe loadSndQueue getRcvQueue
+    SNotifier -> TM.lookupIO qId notifiers >>= maybe loadNtfQueue getRcvQueue
+    where
+      PostgresQueueStore {queues, senders, notifiers} = st
+      getRcvQueue rId = TM.lookupIO rId queues >>= maybe loadRcvQueue (pure . Right)
+      loadRcvQueue = loadQueue " WHERE q.recipient_id = ?" $ \_ -> pure ()
+      loadSndQueue = loadQueue " WHERE q.sender_id = ?" $ \rId -> TM.insert qId rId senders
+      loadNtfQueue = loadQueue " WHERE n.notifier_id = ?" $ \_ -> pure () -- do NOT cache ref - ntf subscriptions are rare
+      loadQueue condition insertRef =
+        loadQueueRec $>>= \(rId, qRec) -> do
+          sq <- mkQ rId qRec
+          atomically $
+            -- checking the cache again for concurrent reads
+            TM.lookup rId queues >>= \case
+              Just sq' -> pure $ Right sq'
+              Nothing -> do
+                insertRef rId
+                TM.insert rId sq queues
+                pure $ Right sq
+        where
+          loadQueueRec =
+            withDB "getQueue_" st $ \db -> firstRow rowToQueueRec AUTH $
+              DB.query db (queueRecQuery <> condition) (Only qId)
+
+  secureQueue :: PostgresQueueStore q -> q -> SndPublicAuthKey -> IO (Either ErrorType ())
+  secureQueue st sq sKey =
+    withQueueLock sq "secureQueue" $
+      readQueueRecIO qr
+        $>>= \q -> verify q
+        $>> secureDB
+        $>> secure q
+    where
+      qr = queueRec sq
+      verify q = pure $ case senderKey q of
+        Just k | sKey /= k -> Left AUTH
+        _ -> Right ()
+      secureDB =
+        withDB' "secureQueue" st $ \db ->
+          DB.execute db "UPDATE msg_queues SET sender_key = ? WHERE recipient_id = ?" (sKey, recipientId sq)
+      secure q = do
+        atomically $ writeTVar qr $ Just q {senderKey = Just sKey}
+        pure $ Right ()
+
+  addQueueNotifier :: PostgresQueueStore q -> q -> NtfCreds -> IO (Either ErrorType (Maybe NotifierId))
+  addQueueNotifier st sq ntfCreds@NtfCreds {notifierId = nId, notifierKey, rcvNtfDhSecret} =
+    withQueueLock sq "addQueueNotifier" $
+      readQueueRecIO qr $>>= add
+    where
+      PostgresQueueStore {notifiers} = st
+      rId = recipientId sq
+      qr = queueRec sq
+      add q =
+        withLockMap (notifierLocks st) nId "addQueueNotifier" $
+          ifM (TM.memberIO nId notifiers) (pure $ Left DUPLICATE_) $
+            addDB $>> do
+              nId_ <- forM (notifier q) $ \NtfCreds {notifierId} -> atomically (TM.delete notifierId notifiers) $> notifierId
+              let !q' = q {notifier = Just ntfCreds}
+              atomically $ writeTVar qr $ Just q'
+              -- cache queue notifier ID – after notifier is added ntf server will likely subscribe
+              atomically $ TM.insert nId rId notifiers
+              pure $ Right nId_
+      addDB =
+        withDB "addQueueNotifier" st $ \db ->
+          E.try (insert db) >>= bimapM handleDuplicate pure
+        where
+          -- TODO [postgres] test how this query works with duplicate recipient_id (updates) and notifier_id (fails)
+          insert db =
+            DB.execute
+              db
+              [sql|
+                INSERT INTO msg_notifiers (recipient_id, notifier_id, notifier_key, rcv_ntf_dh_secret)
+                VALUES (?, ?, ?, ?)
+                ON CONFLICT (recipient_id) DO UPDATE
+                SET notifier_id = EXCLUDED.notifier_id,
+                    notifier_key = EXCLUDED.notifier_key,
+                    rcv_ntf_dh_secret = EXCLUDED.rcv_ntf_dh_secret
+              |]
+              (rId, nId, notifierKey, rcvNtfDhSecret)
+
+  deleteQueueNotifier :: PostgresQueueStore q -> q -> IO (Either ErrorType (Maybe NotifierId))
+  deleteQueueNotifier st sq =
+    withQueueLock sq "deleteQueueNotifier" $
+      readQueueRecIO qr $>>= fmap sequence . delete
+    where
+      qr = queueRec sq
+      delete :: QueueRec -> IO (Maybe (Either ErrorType NotifierId))
+      delete q = forM (notifier q) $ \NtfCreds {notifierId = nId} ->
+        withLockMap (notifierLocks st) nId "deleteQueueNotifier" $ do
+          deleteDB nId $>> do
+            atomically $ TM.delete nId $ notifiers st
+            atomically $ writeTVar qr $! Just q {notifier = Nothing}
+            pure $ Right nId
+      deleteDB nId =
+        withDB' "deleteQueueNotifier" st $ \db ->
+          DB.execute db "DELETE FROM msg_notifiers WHERE notifier_id = ?" (Only nId)
+
+  -- TODO [postgres] only update STM on DB success
+  suspendQueue :: PostgresQueueStore q -> q -> IO (Either ErrorType ())
+  suspendQueue st sq =
+    setStatus (queueRec sq) EntityOff
+      $>> setStatusDB "suspendQueue" st (recipientId sq) EntityOff
+
+  -- TODO [postgres] only update STM on DB success
+  blockQueue :: PostgresQueueStore q -> q -> BlockingInfo -> IO (Either ErrorType ())
+  blockQueue st sq info =
+    setStatus (queueRec sq) (EntityBlocked info)
+      $>> setStatusDB "blockQueue" st (recipientId sq) (EntityBlocked info)
+
+  -- TODO [postgres] only update STM on DB success
+  unblockQueue :: PostgresQueueStore q -> q -> IO (Either ErrorType ())
+  unblockQueue st sq =
+    setStatus (queueRec sq) EntityActive
+      $>> setStatusDB "unblockQueue" st (recipientId sq) EntityActive
+
+  -- TODO [postgres] only update STM on DB success
+  updateQueueTime :: PostgresQueueStore q -> q -> RoundedSystemTime -> IO (Either ErrorType QueueRec)
+  updateQueueTime st sq t = withQueueRec qr update $>>= updateDB
+    where
+      qr = queueRec sq
+      update q@QueueRec {updatedAt}
+        | updatedAt == Just t = pure (q, False)
+        | otherwise =
+            let !q' = q {updatedAt = Just t}
+             in (writeTVar qr $! Just q') $> (q', True)
+      updateDB (q, changed)
+        | changed = q <$$ withDB' "updateQueueTime" st (\db -> DB.execute db "UPDATE msg_queues SET updated_at = ? WHERE recipient_id = ?" (t, Binary $ unEntityId $ recipientId sq))
+        | otherwise = pure $ Right q
+
+  -- TODO [postgres] only update STM on DB success
+  deleteStoreQueue :: PostgresQueueStore q -> q -> IO (Either ErrorType (QueueRec, Maybe (MsgQueue q)))
+  deleteStoreQueue st sq =
+    withQueueRec qr delete
+      $>>= \q -> deleteDB
+      >>= mapM (\_ -> (q,) <$> atomically (swapTVar (msgQueue sq) Nothing))
+    where
+      qr = queueRec sq
+      delete q = do
+        writeTVar qr Nothing
+        TM.delete (senderId q) $ senders st
+        -- TODO [postgres] probably we should delete it?
+        -- forM_ (notifier q) $ \NtfCreds {notifierId} -> TM.delete notifierId $ notifiers st
+        pure q
+      deleteDB =
+        withDB' "deleteStoreQueue" st $ \db ->
+          DB.execute db "DELETE FROM msg_queues WHERE recipient_id = ?" (Only $ Binary $ unEntityId $ recipientId sq)
+
+insertQueueDB :: DB.Connection -> RecipientId -> QueueRec -> IO ()
+insertQueueDB db rId QueueRec {recipientKey, rcvDhSecret, senderId, senderKey, sndSecure, notifier, status, updatedAt} = do
+  DB.execute db insertQueueQuery (rId, recipientKey, rcvDhSecret, senderId, senderKey, sndSecure, status, updatedAt)
+  forM_ notifier $ \NtfCreds {notifierId, notifierKey, rcvNtfDhSecret} ->
+    DB.execute db insertNotifierQuery (rId, notifierId, notifierKey, rcvNtfDhSecret)
+
+batchInsertQueues :: StoreQueueClass q => Bool -> M.Map RecipientId q -> PostgresQueueStore q' -> IO (Int64, Int64)
+batchInsertQueues tty queues toStore = do
+  qs <- catMaybes <$> mapM (\(rId, q) -> (rId,) <$$> readTVarIO (queueRec q)) (M.assocs queues)
+  putStrLn $ "Importing " <> show (length qs) <> " queues..."
+  let st = dbStore toStore
+  (ns, count) <- foldM (processChunk st) ((0, 0), 0) $ toChunks 1000000 qs
+  putStrLn $ progress count
+  pure ns
+  where
+    processChunk st ((qCnt, nCnt), i) qs = do
+      qCnt' <- withConnection st $ \db -> PSQL.executeMany db insertQueueQuery $ map toQueueRow qs
+      nCnt' <- withConnection st $ \db -> PSQL.executeMany db insertNotifierQuery $ mapMaybe toNotifierRow qs
+      let i' = i + length qs
+      when tty $ putStr (progress i' <> "\r") >> hFlush stdout
+      pure ((qCnt + qCnt', nCnt + nCnt'), i')
+    progress i = "Imported: " <> show i <> " queues"
+    toQueueRow (rId, QueueRec {recipientKey, rcvDhSecret, senderId, senderKey, sndSecure, status, updatedAt}) =
+      (rId, recipientKey, rcvDhSecret, senderId, senderKey, sndSecure, status, updatedAt)
+    toNotifierRow (rId, QueueRec {notifier}) =
+      (\NtfCreds {notifierId, notifierKey, rcvNtfDhSecret} -> (rId, notifierId, notifierKey, rcvNtfDhSecret)) <$> notifier
+    toChunks :: Int -> [a] -> [[a]]
+    toChunks _ [] = []
+    toChunks n xs =
+      let (ys, xs') = splitAt n xs
+       in ys : toChunks n xs'
+
+insertQueueQuery :: Query
+insertQueueQuery =
+  [sql|
+    INSERT INTO msg_queues
+      (recipient_id, recipient_key, rcv_dh_secret, sender_id, sender_key, snd_secure, status, updated_at)
+    VALUES (?,?,?,?,?,?,?,?)
+  |]
+
+insertNotifierQuery :: Query
+insertNotifierQuery =
+  [sql|
+    INSERT INTO msg_notifiers (recipient_id, notifier_id, notifier_key, rcv_ntf_dh_secret)
+    VALUES (?, ?, ?, ?)
+  |]
+
+foldQueueRecs :: Monoid a => Bool -> PostgresQueueStore q -> (RecipientId -> QueueRec -> IO a) -> IO a
+foldQueueRecs tty st f = do
+  fmap snd $ withConnection (dbStore st) $ \db ->
+    PSQL.fold_ db queueRecQuery (0 :: Int, mempty) $ \(!i, !acc) row -> do
+      r <- uncurry f (rowToQueueRec row)
+      let i' = i + 1
+      when (tty && i' `mod` 100000 == 0) $ putStr ("Processed: " <> show i <> " records\r") >> hFlush stdout
+      pure (i', acc <> r)
+
+queueRecQuery :: Query
+queueRecQuery =
+  [sql|
+    SELECT q.recipient_id, q.recipient_key, q.rcv_dh_secret, q.sender_id, q.sender_key, q.snd_secure, q.status, q.updated_at,
+      n.notifier_id, n.notifier_key, n.rcv_ntf_dh_secret
+    FROM msg_queues q
+    LEFT JOIN msg_notifiers n ON q.recipient_id = n.recipient_id
+  |]
+
+rowToQueueRec :: ( (RecipientId, RcvPublicAuthKey, RcvDhSecret, SenderId, Maybe SndPublicAuthKey, SenderCanSecure, ServerEntityStatus, Maybe RoundedSystemTime)
+                :. (Maybe NotifierId, Maybe NtfPublicAuthKey, Maybe RcvNtfDhSecret)
+              ) -> (RecipientId, QueueRec)
+rowToQueueRec ((rId, recipientKey, rcvDhSecret, senderId, senderKey, sndSecure, status, updatedAt) :. (notifierId_, notifierKey_, rcvNtfDhSecret_)) =
+  let notifier = NtfCreds <$> notifierId_ <*> notifierKey_ <*> rcvNtfDhSecret_
+  in (rId, QueueRec {recipientKey, rcvDhSecret, senderId, senderKey, sndSecure, notifier, status, updatedAt})
+
+setStatusDB :: String -> PostgresQueueStore q -> RecipientId -> ServerEntityStatus -> IO (Either ErrorType ())
+setStatusDB name st rId status =
+  withDB' name st $ \db ->
+    DB.execute db "UPDATE msg_queues SET status = ? WHERE recipient_id = ?" (status, rId)
+
+withDB' :: String -> PostgresQueueStore q -> (DB.Connection -> IO a) -> IO (Either ErrorType a)
+withDB' name st' action = withDB name st' $ fmap Right . action
+
+-- TODO [postgres] possibly, use with connection if queries in addQueue_ are combined
+withDB :: forall a q. String -> PostgresQueueStore q -> (DB.Connection -> IO (Either ErrorType a)) -> IO (Either ErrorType a)
+withDB name st' action =
+  E.try (withTransaction (dbStore st') action) >>= either logErr pure
+  where
+    logErr :: E.SomeException -> IO (Either ErrorType a)
+    logErr e = logError ("STORE: " <> T.pack err) $> Left (STORE err)
+      where
+        err = name <> ", withLog, " <> show e
+
+handleDuplicate :: SqlError -> IO ErrorType
+handleDuplicate e = case constraintViolation e of
+  Just (UniqueViolation _) -> pure AUTH
+  _ -> E.throwIO e
+
+-- The orphan instances below are copy-pasted, but here they are defined specifically for PostgreSQL
+
+instance ToField EntityId where toField (EntityId s) = toField $ Binary s
+
+deriving newtype instance FromField EntityId
+
+instance ToField (C.DhSecret 'C.X25519) where toField = toField . Binary . C.dhBytes'
+
+instance FromField (C.DhSecret 'C.X25519) where fromField = blobFieldDecoder strDecode
+
+instance ToField C.APublicAuthKey where toField = toField . Binary . C.encodePubKey
+
+instance FromField C.APublicAuthKey where fromField = blobFieldDecoder C.decodePubKey

src/Simplex/Messaging/Server/QueueStore/Postgres/Migrations.hs

@@ -0,0 +1,49 @@
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE QuasiQuotes #-}
+
+module Simplex.Messaging.Server.QueueStore.Postgres.Migrations where
+
+import Data.List (sortOn)
+import Data.Text (Text)
+import qualified Data.Text as T
+import Simplex.Messaging.Agent.Store.Shared
+import Text.RawString.QQ (r)
+
+serverSchemaMigrations :: [(String, Text, Maybe Text)]
+serverSchemaMigrations =
+  [ ("20250207_initial", m20250207_initial, Nothing)
+  ]
+
+-- | The list of migrations in ascending order by date
+serverMigrations :: [Migration]
+serverMigrations = sortOn name $ map migration serverSchemaMigrations
+  where
+    migration (name, up, down) = Migration {name, up, down = down}
+
+m20250207_initial :: Text
+m20250207_initial =
+  T.pack
+    [r|
+CREATE TABLE msg_queues(
+  recipient_id BYTEA NOT NULL,
+  recipient_key BYTEA NOT NULL,
+  rcv_dh_secret BYTEA NOT NULL,
+  sender_id BYTEA NOT NULL,
+  sender_key BYTEA,
+  snd_secure BOOLEAN NOT NULL,
+  status TEXT NOT NULL,
+  updated_at BIGINT,
+  PRIMARY KEY (recipient_id)
+);
+
+CREATE TABLE msg_notifiers(
+  notifier_id BYTEA NOT NULL,
+  recipient_id BYTEA NOT NULL REFERENCES msg_queues(recipient_id) ON DELETE CASCADE ON UPDATE RESTRICT,
+  notifier_key BYTEA NOT NULL,
+  rcv_ntf_dh_secret BYTEA NOT NULL,
+  PRIMARY KEY (notifier_id)
+);
+
+CREATE UNIQUE INDEX idx_msg_queues_sender_id ON msg_queues(sender_id);
+CREATE UNIQUE INDEX idx_msg_notifiers_recipient_id ON msg_notifiers(recipient_id);
+    |]

src/Simplex/Messaging/Server/QueueStore/STM.hs

@@ -3,7 +3,7 @@
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE GADTs #-}
-{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE InstanceSigs #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE NamedFieldPuns #-}
@@ -11,177 +11,186 @@
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TupleSections #-}
+{-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE UndecidableInstances #-}
 
 module Simplex.Messaging.Server.QueueStore.STM
-  ( addQueue,
-    getQueue,
-    getQueueRec,
-    secureQueue,
-    addQueueNotifier,
-    deleteQueueNotifier,
-    suspendQueue,
-    blockQueue,
-    unblockQueue,
-    updateQueueTime,
-    deleteQueue',
-    newQueueStore,
-    readQueueStore,
+  ( STMQueueStore (..),
+    setStoreLog,
     withLog',
+    withQueueRec,
+    readQueueRecIO,
+    setStatus,
   )
 where
 
 import qualified Control.Exception as E
 import Control.Logger.Simple
 import Control.Monad
-import Control.Monad.IO.Class
-import Control.Monad.Trans.Except
 import Data.Bitraversable (bimapM)
-import qualified Data.ByteString.Char8 as B
 import Data.Functor (($>))
+import qualified Data.Map.Strict as M
 import qualified Data.Text as T
-import Data.Text.Encoding (decodeLatin1)
-import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Protocol
-import Simplex.Messaging.Server.MsgStore.Types
 import Simplex.Messaging.Server.QueueStore
+import Simplex.Messaging.Server.QueueStore.Types
 import Simplex.Messaging.Server.StoreLog
+import Simplex.Messaging.TMap (TMap)
 import qualified Simplex.Messaging.TMap as TM
-import Simplex.Messaging.Util (ifM, safeDecodeUtf8, tshow, ($>>=), (<$$))
-import System.Exit (exitFailure)
+import Simplex.Messaging.Util (anyM, ifM, ($>>), ($>>=), (<$$))
 import System.IO
 import UnliftIO.STM
 
-newQueueStore :: IO (STMQueueStore q)
-newQueueStore = do
-  queues <- TM.emptyIO
-  senders <- TM.emptyIO
-  notifiers <- TM.emptyIO
-  storeLog <- newTVarIO Nothing
-  pure STMQueueStore {queues, senders, notifiers, storeLog}
+data STMQueueStore q = STMQueueStore
+  { queues :: TMap RecipientId q,
+    senders :: TMap SenderId RecipientId,
+    notifiers :: TMap NotifierId RecipientId,
+    storeLog :: TVar (Maybe (StoreLog 'WriteMode))
+  }
 
-addQueue :: STMStoreClass s => s -> RecipientId -> QueueRec -> IO (Either ErrorType (StoreQueue s))
-addQueue st rId qr@QueueRec {senderId = sId, notifier}=
-  atomically add
-    $>>= \q -> q <$$ withLog "addQueue" st (\s -> logCreateQueue s rId qr)
-  where
-    STMQueueStore {queues, senders, notifiers} = stmQueueStore st
-    add = ifM hasId (pure $ Left DUPLICATE_) $ do
-      q <- mkQueue st rId qr
-      TM.insert rId q queues
-      TM.insert sId rId senders
-      forM_ notifier $ \NtfCreds {notifierId} -> TM.insert notifierId rId notifiers
-      pure $ Right q
-    hasId = or <$> sequence [TM.member rId queues, TM.member sId senders, hasNotifier]
-    hasNotifier = maybe (pure False) (\NtfCreds {notifierId} -> TM.member notifierId notifiers) notifier
+setStoreLog :: STMQueueStore q -> StoreLog 'WriteMode -> IO ()
+setStoreLog st sl = atomically $ writeTVar (storeLog st) (Just sl)
 
-getQueue :: (STMStoreClass s, DirectParty p) => s -> SParty p -> QueueId -> IO (Either ErrorType (StoreQueue s))
-getQueue st party qId =
-  maybe (Left AUTH) Right <$> case party of
-    SRecipient -> TM.lookupIO qId queues
-    SSender -> TM.lookupIO qId senders $>>= (`TM.lookupIO` queues)
-    SNotifier -> TM.lookupIO qId notifiers $>>= (`TM.lookupIO` queues)
-  where
-    STMQueueStore {queues, senders, notifiers} = stmQueueStore st
+instance StoreQueueClass q => QueueStoreClass q (STMQueueStore q) where
+  type QueueStoreCfg (STMQueueStore q) = ()
 
-getQueueRec :: (STMStoreClass s, DirectParty p) => s -> SParty p -> QueueId -> IO (Either ErrorType (StoreQueue s, QueueRec))
-getQueueRec st party qId =
-  getQueue st party qId
-    $>>= (\q -> maybe (Left AUTH) (Right . (q,)) <$> readTVarIO (queueRec' q))
+  newQueueStore :: () -> IO (STMQueueStore q)
+  newQueueStore _ = do
+    queues <- TM.emptyIO
+    senders <- TM.emptyIO
+    notifiers <- TM.emptyIO
+    storeLog <- newTVarIO Nothing
+    pure STMQueueStore {queues, senders, notifiers, storeLog}
 
-secureQueue :: STMStoreClass s => s -> StoreQueue s -> SndPublicAuthKey -> IO (Either ErrorType ())
-secureQueue st sq sKey =
-  atomically (readQueueRec qr $>>= secure)
-    $>>= \_ -> withLog "secureQueue" st $ \s -> logSecureQueue s (recipientId' sq) sKey
-  where
-    qr = queueRec' sq
-    secure q = case senderKey q of
-      Just k -> pure $ if sKey == k then Right () else Left AUTH
-      Nothing -> do
-        writeTVar qr $ Just q {senderKey = Just sKey}
-        pure $ Right ()
+  loadedQueues = queues
+  {-# INLINE loadedQueues #-}
+  -- foldAllQueues = withLoadedQueues
+  -- {-# INLINE foldAllQueues #-}
 
-addQueueNotifier :: STMStoreClass s => s -> StoreQueue s -> NtfCreds -> IO (Either ErrorType (Maybe NotifierId))
-addQueueNotifier st sq ntfCreds@NtfCreds {notifierId = nId} =
-  atomically (readQueueRec qr $>>= add)
-    $>>= \nId_ -> nId_ <$$ withLog "addQueueNotifier" st (\s -> logAddNotifier s rId ntfCreds)
-  where
-    rId = recipientId' sq
-    qr = queueRec' sq
-    STMQueueStore {notifiers} = stmQueueStore st
-    add q = ifM (TM.member nId notifiers) (pure $ Left DUPLICATE_) $ do
-      nId_ <- forM (notifier q) $ \NtfCreds {notifierId} -> TM.delete notifierId notifiers $> notifierId
-      let !q' = q {notifier = Just ntfCreds}
-      writeTVar qr $ Just q'
-      TM.insert nId rId notifiers
-      pure $ Right nId_
+  queueCounts :: STMQueueStore q -> IO QueueCounts
+  queueCounts st = do
+    queueCount <- M.size <$> readTVarIO (queues st)
+    notifierCount <- M.size <$> readTVarIO (notifiers st)
+    pure QueueCounts {queueCount, notifierCount}
 
-deleteQueueNotifier :: STMStoreClass s => s -> StoreQueue s -> IO (Either ErrorType (Maybe NotifierId))
-deleteQueueNotifier st sq =
-  atomically (readQueueRec qr >>= mapM delete)
-    $>>= \nId_ -> nId_ <$$ withLog "deleteQueueNotifier" st (`logDeleteNotifier` recipientId' sq)
-  where
-    qr = queueRec' sq
-    delete q = forM (notifier q) $ \NtfCreds {notifierId} -> do
-      TM.delete notifierId $ notifiers $ stmQueueStore st
-      writeTVar qr $! Just q {notifier = Nothing}
-      pure notifierId
+  addQueue_ :: STMQueueStore q -> (RecipientId -> QueueRec -> IO q) -> RecipientId -> QueueRec -> IO (Either ErrorType q)
+  addQueue_ st mkQ rId qr@QueueRec {senderId = sId, notifier} = do
+    sq <- mkQ rId qr
+    add sq $>> withLog "addStoreQueue" st (\s -> logCreateQueue s rId qr) $> Right sq
+    where
+      STMQueueStore {queues, senders, notifiers} = st
+      add q = atomically $ ifM hasId (pure $ Left DUPLICATE_) $ Right () <$ do
+        TM.insert rId q queues
+        TM.insert sId rId senders
+        forM_ notifier $ \NtfCreds {notifierId} -> TM.insert notifierId rId notifiers
+      hasId = anyM [TM.member rId queues, TM.member sId senders, hasNotifier]
+      hasNotifier = maybe (pure False) (\NtfCreds {notifierId} -> TM.member notifierId notifiers) notifier
 
-suspendQueue :: STMStoreClass s => s -> StoreQueue s -> IO (Either ErrorType ())
-suspendQueue st sq =
-  atomically (readQueueRec qr >>= mapM suspend)
-    $>>= \_ -> withLog "suspendQueue" st (`logSuspendQueue` recipientId' sq)
-  where
-    qr = queueRec' sq
-    suspend q = writeTVar qr $! Just q {status = EntityOff}
+  getQueue_ :: DirectParty p => STMQueueStore q -> (RecipientId -> QueueRec -> IO q) -> SParty p -> QueueId -> IO (Either ErrorType q)
+  getQueue_ st _ party qId =
+    maybe (Left AUTH) Right <$> case party of
+      SRecipient -> TM.lookupIO qId queues
+      SSender -> TM.lookupIO qId senders $>>= (`TM.lookupIO` queues)
+      SNotifier -> TM.lookupIO qId notifiers $>>= (`TM.lookupIO` queues)
+    where
+      STMQueueStore {queues, senders, notifiers} = st
 
-blockQueue :: STMStoreClass s => s -> StoreQueue s -> BlockingInfo -> IO (Either ErrorType ())
-blockQueue st sq info =
-  atomically (readQueueRec qr >>= mapM block)
-    $>>= \_ -> withLog "blockQueue" st (\sl -> logBlockQueue sl (recipientId' sq) info)
-  where
-    qr = queueRec' sq
-    block q = writeTVar qr $ Just q {status = EntityBlocked info}
+  secureQueue :: STMQueueStore q -> q -> SndPublicAuthKey -> IO (Either ErrorType ())
+  secureQueue st sq sKey =
+    atomically (readQueueRec qr $>>= secure)
+      $>> withLog "secureQueue" st (\s -> logSecureQueue s (recipientId sq) sKey)
+    where
+      qr = queueRec sq
+      secure q = case senderKey q of
+        Just k -> pure $ if sKey == k then Right () else Left AUTH
+        Nothing -> do
+          writeTVar qr $ Just q {senderKey = Just sKey}
+          pure $ Right ()
 
-unblockQueue :: STMStoreClass s => s -> StoreQueue s -> IO (Either ErrorType ())
-unblockQueue st sq =
-  atomically (readQueueRec qr >>= mapM unblock)
-    $>>= \_ -> withLog "unblockQueue" st (`logUnblockQueue` recipientId' sq)
-  where
-    qr = queueRec' sq
-    unblock q = writeTVar qr $ Just q {status = EntityActive}
+  addQueueNotifier :: STMQueueStore q -> q -> NtfCreds -> IO (Either ErrorType (Maybe NotifierId))
+  addQueueNotifier st sq ntfCreds@NtfCreds {notifierId = nId} =
+    atomically (readQueueRec qr $>>= add)
+      $>>= \nId_ -> nId_ <$$ withLog "addQueueNotifier" st (\s -> logAddNotifier s rId ntfCreds)
+    where
+      rId = recipientId sq
+      qr = queueRec sq
+      STMQueueStore {notifiers} = st
+      add q = ifM (TM.member nId notifiers) (pure $ Left DUPLICATE_) $ do
+        nId_ <- forM (notifier q) $ \NtfCreds {notifierId} -> TM.delete notifierId notifiers $> notifierId
+        let !q' = q {notifier = Just ntfCreds}
+        writeTVar qr $ Just q'
+        TM.insert nId rId notifiers
+        pure $ Right nId_
 
-updateQueueTime :: STMStoreClass s => s -> StoreQueue s -> RoundedSystemTime -> IO (Either ErrorType QueueRec)
-updateQueueTime st sq t = atomically (readQueueRec qr >>= mapM update) $>>= log'
-  where
-    qr = queueRec' sq
-    update q@QueueRec {updatedAt}
-      | updatedAt == Just t = pure (q, False)
-      | otherwise =
-          let !q' = q {updatedAt = Just t}
-           in (writeTVar qr $! Just q') $> (q', True)
-    log' (q, changed)
-      | changed = q <$$ withLog "updateQueueTime" st (\sl -> logUpdateQueueTime sl (recipientId' sq) t)
-      | otherwise = pure $ Right q
+  deleteQueueNotifier :: STMQueueStore q -> q -> IO (Either ErrorType (Maybe NotifierId))
+  deleteQueueNotifier st sq =
+    withQueueRec qr delete
+      $>>= \nId_ -> nId_ <$$ withLog "deleteQueueNotifier" st (`logDeleteNotifier` recipientId sq)
+    where
+      qr = queueRec sq
+      delete q = forM (notifier q) $ \NtfCreds {notifierId} -> do
+        TM.delete notifierId $ notifiers st
+        writeTVar qr $ Just q {notifier = Nothing}
+        pure notifierId
 
-deleteQueue' :: STMStoreClass s => s -> StoreQueue s -> IO (Either ErrorType (QueueRec, Maybe (MsgQueue s)))
-deleteQueue' st sq =
-  atomically (readQueueRec qr >>= mapM delete)
-    $>>= \q -> withLog "deleteQueue" st (`logDeleteQueue` recipientId' sq)
-    >>= bimapM pure (\_ -> (q,) <$> atomically (swapTVar (msgQueue_' sq) Nothing))
-  where
-    qr = queueRec' sq
-    STMQueueStore {senders, notifiers} = stmQueueStore st
-    delete q = do
-      writeTVar qr Nothing
-      TM.delete (senderId q) senders
-      forM_ (notifier q) $ \NtfCreds {notifierId} -> TM.delete notifierId notifiers
-      pure q
+  suspendQueue :: STMQueueStore q -> q -> IO (Either ErrorType ())
+  suspendQueue st sq =
+    setStatus (queueRec sq) EntityOff
+      $>> withLog "suspendQueue" st (`logSuspendQueue` recipientId sq)
+
+  blockQueue :: STMQueueStore q -> q -> BlockingInfo -> IO (Either ErrorType ())
+  blockQueue st sq info =
+    setStatus (queueRec sq) (EntityBlocked info)
+      $>> withLog "blockQueue" st (\sl -> logBlockQueue sl (recipientId sq) info)
+
+  unblockQueue :: STMQueueStore q -> q -> IO (Either ErrorType ())
+  unblockQueue st sq =
+    setStatus (queueRec sq) EntityActive
+      $>> withLog "unblockQueue" st (`logUnblockQueue` recipientId sq)
+
+  updateQueueTime :: STMQueueStore q -> q -> RoundedSystemTime -> IO (Either ErrorType QueueRec)
+  updateQueueTime st sq t = withQueueRec qr update $>>= log'
+    where
+      qr = queueRec sq
+      update q@QueueRec {updatedAt}
+        | updatedAt == Just t = pure (q, False)
+        | otherwise =
+            let !q' = q {updatedAt = Just t}
+             in writeTVar qr (Just q') $> (q', True)
+      log' (q, changed)
+        | changed = q <$$ withLog "updateQueueTime" st (\sl -> logUpdateQueueTime sl (recipientId sq) t)
+        | otherwise = pure $ Right q
+
+  deleteStoreQueue :: STMQueueStore q -> q -> IO (Either ErrorType (QueueRec, Maybe (MsgQueue q)))
+  deleteStoreQueue st sq =
+    withQueueRec qr delete
+      $>>= \q -> withLog "deleteStoreQueue" st (`logDeleteQueue` recipientId sq)
+      >>= mapM (\_ -> (q,) <$> atomically (swapTVar (msgQueue sq) Nothing))
+    where
+      qr = queueRec sq
+      delete q = do
+        writeTVar qr Nothing
+        TM.delete (senderId q) $ senders st
+        forM_ (notifier q) $ \NtfCreds {notifierId} -> TM.delete notifierId $ notifiers st
+        pure q
+
+withQueueRec :: TVar (Maybe QueueRec) -> (QueueRec -> STM a) -> IO (Either ErrorType a)
+withQueueRec qr a = atomically $ readQueueRec qr >>= mapM a
+
+setStatus :: TVar (Maybe QueueRec) -> ServerEntityStatus -> IO (Either ErrorType ())
+setStatus qr status =
+  atomically $ stateTVar qr $ \case
+    Just q -> (Right (), Just q {status})
+    Nothing -> (Left AUTH, Nothing)
 
 readQueueRec :: TVar (Maybe QueueRec) -> STM (Either ErrorType QueueRec)
 readQueueRec qr = maybe (Left AUTH) Right <$> readTVar qr
 {-# INLINE readQueueRec #-}
 
+readQueueRecIO :: TVar (Maybe QueueRec) -> IO (Either ErrorType QueueRec)
+readQueueRecIO qr = maybe (Left AUTH) Right <$> readTVarIO qr
+{-# INLINE readQueueRecIO #-}
+
 withLog' :: String -> TVar (Maybe (StoreLog 'WriteMode)) -> (StoreLog 'WriteMode -> IO ()) -> IO (Either ErrorType ())
 withLog' name sl action =
   readTVarIO sl
@@ -192,41 +201,6 @@ withLog' name sl action =
       where
         err = name <> ", withLog, " <> show e
 
-withLog :: STMStoreClass s => String -> s -> (StoreLog 'WriteMode -> IO ()) -> IO (Either ErrorType ())
-withLog name = withLog' name . storeLog . stmQueueStore
-
-readQueueStore :: forall s. STMStoreClass s => FilePath -> s -> IO ()
-readQueueStore f st = readLogLines False f processLine
-  where
-    processLine :: Bool -> B.ByteString -> IO ()
-    processLine eof s = either printError procLogRecord (strDecode s)
-      where
-        procLogRecord :: StoreLogRecord -> IO ()
-        procLogRecord = \case
-          CreateQueue rId q -> addQueue st rId q >>= qError rId "CreateQueue"
-          SecureQueue qId sKey -> withQueue qId "SecureQueue" $ \q -> secureQueue st q sKey
-          AddNotifier qId ntfCreds -> withQueue qId "AddNotifier" $ \q -> addQueueNotifier st q ntfCreds
-          SuspendQueue qId -> withQueue qId "SuspendQueue" $ suspendQueue st
-          BlockQueue qId info -> withQueue qId "BlockQueue" $ \q -> blockQueue st q info
-          UnblockQueue qId -> withQueue qId "UnblockQueue" $ unblockQueue st
-          DeleteQueue qId -> withQueue qId "DeleteQueue" $ deleteQueue st
-          DeleteNotifier qId -> withQueue qId "DeleteNotifier" $ deleteQueueNotifier st
-          UpdateTime qId t -> withQueue qId "UpdateTime" $ \q -> updateQueueTime st q t
-        printError :: String -> IO ()
-        printError e
-          | eof = logWarn err
-          | otherwise = logError err >> exitFailure
-          where
-            err = "Error parsing log: " <> T.pack e <> " - " <> safeDecodeUtf8 s
-        withQueue :: forall a. RecipientId -> T.Text -> (StoreQueue s -> IO (Either ErrorType a)) -> IO ()
-        withQueue qId op a = runExceptT go >>= qError qId op
-          where
-            go = do
-              q <- ExceptT $ getQueue st SRecipient qId
-              liftIO (readTVarIO $ queueRec' q) >>= \case
-                Nothing -> logWarn $ logPfx qId op <> "already deleted"
-                Just _ -> void $ ExceptT $ a q
-        qError qId op = \case
-          Left e -> logError $ logPfx qId op <> tshow e
-          Right _ -> pure ()
-        logPfx qId op = "STORE: " <> op <> ", stored queue " <> decodeLatin1 (strEncode qId) <> ", "
+withLog :: String -> STMQueueStore q -> (StoreLog 'WriteMode -> IO ()) -> IO (Either ErrorType ())
+withLog name = withLog' name . storeLog
+{-# INLINE withLog #-}

src/Simplex/Messaging/Server/QueueStore/Types.hs

@@ -0,0 +1,48 @@
+{-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeFamilyDependencies #-}
+
+module Simplex.Messaging.Server.QueueStore.Types where
+
+import Control.Concurrent.STM
+import Control.Monad
+import Simplex.Messaging.Protocol
+import Simplex.Messaging.Server.QueueStore
+import Simplex.Messaging.TMap (TMap)
+
+class StoreQueueClass q where
+  type MsgQueue q = mq | mq -> q
+  recipientId :: q -> RecipientId
+  queueRec :: q -> TVar (Maybe QueueRec)
+  msgQueue :: q -> TVar (Maybe (MsgQueue q))
+  withQueueLock :: q -> String -> IO a -> IO a
+
+class StoreQueueClass q => QueueStoreClass q s where
+  type QueueStoreCfg s
+  newQueueStore :: QueueStoreCfg s -> IO s
+  queueCounts :: s -> IO QueueCounts
+  loadedQueues :: s -> TMap RecipientId q
+  -- foldAllQueues :: Monoid a => s -> (q -> IO a) -> IO a
+  addQueue_ :: s -> (RecipientId -> QueueRec -> IO q) -> RecipientId -> QueueRec -> IO (Either ErrorType q)
+  getQueue_ :: DirectParty p => s -> (RecipientId -> QueueRec -> IO q) -> SParty p -> QueueId -> IO (Either ErrorType q)
+  secureQueue :: s -> q -> SndPublicAuthKey -> IO (Either ErrorType ())
+  addQueueNotifier :: s -> q -> NtfCreds -> IO (Either ErrorType (Maybe NotifierId))
+  deleteQueueNotifier :: s -> q -> IO (Either ErrorType (Maybe NotifierId))
+  suspendQueue :: s -> q -> IO (Either ErrorType ())
+  blockQueue :: s -> q -> BlockingInfo -> IO (Either ErrorType ())
+  unblockQueue :: s -> q -> IO (Either ErrorType ())
+  updateQueueTime :: s -> q -> RoundedSystemTime -> IO (Either ErrorType QueueRec)
+  deleteStoreQueue :: s -> q -> IO (Either ErrorType (QueueRec, Maybe (MsgQueue q)))
+
+data QueueCounts = QueueCounts
+  { queueCount :: Int,
+    notifierCount :: Int
+  }
+
+withLoadedQueues :: (Monoid a, QueueStoreClass q s) => s -> (q -> IO a) -> IO a
+withLoadedQueues st f = readTVarIO (loadedQueues st) >>= foldM run mempty
+  where
+    run !acc = fmap (acc <>) . f

src/Simplex/Messaging/Server/StoreLog.hs

@@ -27,31 +27,27 @@ module Simplex.Messaging.Server.StoreLog
     logDeleteNotifier,
     logUpdateQueueTime,
     readWriteStoreLog,
-    writeQueueStore,
     readLogLines,
     foldLogLines,
   )
 where
 
 import Control.Applicative (optional, (<|>))
-import Control.Concurrent.STM
 import qualified Control.Exception as E
 import Control.Logger.Simple
 import Control.Monad (when)
 import qualified Data.Attoparsec.ByteString.Char8 as A
 import qualified Data.ByteString.Char8 as B
 import Data.Functor (($>))
-import qualified Data.Map.Strict as M
 import qualified Data.Text as T
 import Data.Time.Clock (getCurrentTime)
 import Data.Time.Format.ISO8601 (iso8601Show)
 import GHC.IO (catchAny)
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Protocol
-import Simplex.Messaging.Server.MsgStore.Types
+-- import Simplex.Messaging.Server.MsgStore.Types
 import Simplex.Messaging.Server.QueueStore
 import Simplex.Messaging.Server.StoreLog.Types
-import qualified Simplex.Messaging.TMap as TM
 import Simplex.Messaging.Util (ifM, tshow, unlessM, whenM)
 import System.Directory (doesFileExist, renameFile)
 import System.IO
@@ -249,15 +245,6 @@ readWriteStoreLog readStore writeStore f st =
       renameFile tempBackup timedBackup
       logInfo $ "original state preserved as " <> T.pack timedBackup
 
-writeQueueStore :: STMStoreClass s => StoreLog 'WriteMode -> s -> IO ()
-writeQueueStore s st = readTVarIO qs >>= mapM_ writeQueue . M.assocs
-  where
-    qs = queues $ stmQueueStore st
-    writeQueue (rId, q) =
-      readTVarIO (queueRec' q) >>= \case
-        Just q' -> logCreateQueue s rId q'
-        Nothing -> atomically $ TM.delete rId qs
-
 readLogLines :: Bool -> FilePath -> (Bool -> B.ByteString -> IO ()) -> IO ()
 readLogLines tty f action = foldLogLines tty f (const action) ()
 
@@ -267,11 +254,11 @@ foldLogLines tty f action initValue = do
   putStrLn $ progress count
   pure acc
   where
-    loop h i acc = do
+    loop h !i !acc = do
       s <- B.hGetLine h
       eof <- hIsEOF h
       acc' <- action acc eof s
       let i' = i + 1
       when (tty && i' `mod` 100000 == 0) $ putStr (progress i' <> "\r") >> hFlush stdout
       if eof then pure (i', acc') else loop h i' acc'
-    progress i = "Processed: " <> show i <> " lines"
+    progress i = "Processed: " <> show i <> " log lines"

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) <> ", "

src/Simplex/Messaging/Util.hs

@@ -12,7 +12,7 @@ import Control.Monad.Trans.Except
 import Control.Monad.Trans.State.Strict (StateT (..))
 import Data.Aeson (FromJSON, ToJSON)
 import qualified Data.Aeson as J
-import Data.Bifunctor (first)
+import Data.Bifunctor (first, second)
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
 import qualified Data.ByteString.Lazy.Char8 as LB
@@ -21,6 +21,7 @@ import Data.Int (Int64)
 import Data.List (groupBy, sortOn)
 import Data.List.NonEmpty (NonEmpty (..))
 import qualified Data.List.NonEmpty as L
+import Data.Maybe (listToMaybe)
 import Data.Map.Strict (Map)
 import qualified Data.Map.Strict as M
 import Data.Text (Text)
@@ -88,8 +89,19 @@ unlessM :: Monad m => m Bool -> m () -> m ()
 unlessM b = ifM b $ pure ()
 {-# INLINE unlessM #-}
 
+anyM :: Monad m => [m Bool] -> m Bool
+anyM = foldM (\r a -> if r then pure r else (r ||) <$!> a) False
+{-# INLINE anyM #-}
+
+infixl 1  $>>, $>>=
+
 ($>>=) :: (Monad m, Monad f, Traversable f) => m (f a) -> (a -> m (f b)) -> m (f b)
 f $>>= g = f >>= fmap join . mapM g
+{-# INLINE ($>>=) #-}
+
+($>>) :: (Monad m, Monad f, Traversable f) => m (f a) -> m (f b) -> m (f b)
+f $>> g = f $>>= \_ -> g
+{-# INLINE ($>>) #-}
 
 mapME :: (Monad m, Traversable t) => (a -> m (Either e b)) -> t (Either e a) -> m (t (Either e b))
 mapME f = mapM (bindRight f)
@@ -180,6 +192,19 @@ eitherToMaybe :: Either a b -> Maybe b
 eitherToMaybe = either (const Nothing) Just
 {-# INLINE eitherToMaybe #-}
 
+listToEither :: e -> [a] -> Either e a
+listToEither _ (x : _) = Right x
+listToEither e _ = Left e
+
+firstRow :: (a -> b) -> e -> IO [a] -> IO (Either e b)
+firstRow f e a = second f . listToEither e <$> a
+
+maybeFirstRow :: Functor f => (a -> b) -> f [a] -> f (Maybe b)
+maybeFirstRow f q = fmap f . listToMaybe <$> q
+
+firstRow' :: (a -> Either e b) -> e -> IO [a] -> IO (Either e b)
+firstRow' f e a = (f <=< listToEither e) <$> a
+
 groupOn :: Eq k => (a -> k) -> [a] -> [[a]]
 groupOn = groupBy . eqOn
   where