mirror of
https://github.com/simplex-chat/simplexmq.git
synced 2026-05-12 08:04:47 +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
@@ -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 #-}
|
||||
|
||||
Reference in New Issue
Block a user