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