mirror of
https://github.com/simplex-chat/simplexmq.git
synced 2026-10-07 18:27:51 +00:00
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>
This commit is contained in:
Evgeny
@@ -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 ()
|
||||
|
||||
Reference in New Issue
Block a user