From 1bdf8bc3e3c15c9242f64347881aed889b4f39b7 Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin Date: Thu, 12 Dec 2024 07:46:06 +0000 Subject: [PATCH 01/17] parameterize journal store for queue storage --- src/Simplex/Messaging/Server.hs | 33 ++- src/Simplex/Messaging/Server/Env/STM.hs | 8 +- src/Simplex/Messaging/Server/Main.hs | 2 +- .../Messaging/Server/MsgStore/Journal.hs | 206 ++++++++++++------ src/Simplex/Messaging/Server/MsgStore/STM.hs | 35 ++- .../Messaging/Server/MsgStore/Types.hs | 18 +- .../Messaging/Server/QueueStore/STM.hs | 89 +++----- src/Simplex/Messaging/Server/StoreLog.hs | 38 +++- tests/CoreTests/MsgStoreTests.hs | 22 +- tests/CoreTests/StoreLogTests.hs | 4 +- 10 files changed, 280 insertions(+), 175 deletions(-) diff --git a/src/Simplex/Messaging/Server.hs b/src/Simplex/Messaging/Server.hs index 988639f5c..07d8b0e00 100644 --- a/src/Simplex/Messaging/Server.hs +++ b/src/Simplex/Messaging/Server.hs @@ -100,7 +100,6 @@ import Simplex.Messaging.Server.MsgStore.Types import Simplex.Messaging.Server.NtfStore import Simplex.Messaging.Server.QueueStore import Simplex.Messaging.Server.QueueStore.QueueInfo -import Simplex.Messaging.Server.QueueStore.STM import Simplex.Messaging.Server.Stats import Simplex.Messaging.TMap (TMap) import qualified Simplex.Messaging.TMap as TM @@ -423,9 +422,8 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg} attachHT ss@ServerStats {fromTime, qCreated, qSecured, qDeletedAll, qDeletedAllB, qDeletedNew, qDeletedSecured, qSub, qSubAllB, qSubAuth, qSubDuplicate, qSubProhibited, qSubEnd, qSubEndB, ntfCreated, ntfDeleted, ntfDeletedB, ntfSub, ntfSubB, ntfSubAuth, ntfSubDuplicate, msgSent, msgSentAuth, msgSentQuota, msgSentLarge, msgRecv, msgRecvGet, msgGet, msgGetNoMsg, msgGetAuth, msgGetDuplicate, msgGetProhibited, msgExpired, activeQueues, msgSentNtf, msgRecvNtf, activeQueuesNtf, qCount, msgCount, ntfCount, pRelays, pRelaysOwn, pMsgFwds, pMsgFwdsOwn, pMsgFwdsRecv} <- asks serverStats AMS _ st <- asks msgStore - let queues = activeMsgQueues st - notifiers = notifiers' st - interval = 1000000 * logInterval + QueueCounts {queueCount, notifierCount} <- liftIO $ queueCounts st + let interval = 1000000 * logInterval forever $ do withFile statsFilePath AppendMode $ \h -> liftIO $ do hSetBuffering h LineBuffering @@ -478,8 +476,6 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg} attachHT pMsgFwdsOwn' <- getResetProxyStatsData pMsgFwdsOwn pMsgFwdsRecv' <- atomicSwapIORef pMsgFwdsRecv 0 qCount' <- readIORef qCount - qCount'' <- M.size <$> readTVarIO queues - notifierCount' <- M.size <$> readTVarIO notifiers msgCount' <- readIORef msgCount ntfCount' <- readIORef ntfCount hPutStrLn h $ @@ -532,13 +528,13 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg} attachHT "0", -- dayCount psSub; psSub is removed to reduce memory usage "0", -- weekCount psSub "0", -- monthCount psSub - show qCount'', + show queueCount, show ntfCreated', show ntfDeleted', show ntfSub', show ntfSubAuth', show ntfSubDuplicate', - show notifierCount', + show notifierCount, show qDeletedAllB', show qSubAllB', show qSubEnd', @@ -625,9 +621,8 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg} attachHT CPStats -> withUserRole $ do ss <- unliftIO u $ asks serverStats AMS _ st <- unliftIO u $ asks msgStore - let queues = activeMsgQueues st - notifiers = notifiers' st - getStat :: (ServerStats -> IORef a) -> IO a + QueueCounts {queueCount, notifierCount} <- queueCounts st + let getStat :: (ServerStats -> IORef a) -> IO a getStat var = readIORef (var ss) putStat :: Show a => String -> (ServerStats -> IORef a) -> IO () putStat label var = getStat var >>= \v -> hPutStrLn h $ label <> ": " <> show v @@ -664,9 +659,7 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg} attachHT putStat "msgNtfsB" msgNtfsB putStat "msgNtfExpired" msgNtfExpired putStat "qCount" qCount - qCount2 <- M.size <$> readTVarIO queues - hPutStrLn h $ "qCount 2: " <> show qCount2 - notifierCount <- M.size <$> readTVarIO notifiers + hPutStrLn h $ "qCount 2: " <> show queueCount hPutStrLn h $ "notifiers: " <> show notifierCount putStat "msgCount" msgCount putStat "ntfCount" ntfCount @@ -841,7 +834,7 @@ runClientTransport h@THandle {params = thParams@THandleParams {thVersion, sessio c <- liftIO $ newClient msType clientId q thVersion sessionId ts runClientThreads msType ms active c clientId `finally` clientDisconnected c where - runClientThreads :: STMQueueStore (MsgStore s) => SMSType s -> MsgStore s -> TVar (IM.IntMap (Maybe AClient)) -> Client (MsgStore s) -> IS.Key -> M () + runClientThreads :: MsgStoreClass (MsgStore s) => SMSType s -> MsgStore s -> TVar (IM.IntMap (Maybe AClient)) -> Client (MsgStore s) -> IS.Key -> M () runClientThreads msType ms active c clientId = do atomically $ modifyTVar' active $ IM.insert clientId $ Just (AClient msType c) s <- asks server @@ -897,7 +890,7 @@ cancelSub s = case subThread s of _ -> pure () ProhibitSub -> pure () -receive :: forall c s. (Transport c, STMQueueStore s) => THandleSMP c 'TServer -> s -> Client s -> M () +receive :: forall c s. (Transport c, MsgStoreClass s) => THandleSMP c 'TServer -> s -> Client s -> M () receive h@THandle {params = THandleParams {thAuth}} ms Client {rcvQ, sndQ, rcvActiveAt, sessionId} = do labelMyThread . B.unpack $ "client $" <> encode sessionId <> " receive" sa <- asks serverActive @@ -997,7 +990,7 @@ data VerificationResult s = VRVerified (Maybe (StoreQueue s, QueueRec)) | VRFail -- - the queue or party key do not exist. -- In all cases, the time of the verification should depend only on the provided authorization type, -- a dummy key is used to run verification in the last two cases, and failure is returned irrespective of the result. -verifyTransmission :: forall s. STMQueueStore s => s -> Maybe (THandleAuth 'TServer, C.CbNonce) -> Maybe TransmissionAuth -> ByteString -> QueueId -> Cmd -> M (VerificationResult s) +verifyTransmission :: forall s. MsgStoreClass s => s -> Maybe (THandleAuth 'TServer, C.CbNonce) -> Maybe TransmissionAuth -> ByteString -> QueueId -> Cmd -> M (VerificationResult s) verifyTransmission ms auth_ tAuth authorized queueId cmd = case cmd of Cmd SRecipient (NEW k _ _ _ _) -> pure $ Nothing `verifiedWith` k @@ -1074,7 +1067,7 @@ forkClient Client {endThreads, endThreadSeq} label action = do action `finally` atomically (modifyTVar' endThreads $ IM.delete tId) mkWeakThreadId t >>= atomically . modifyTVar' endThreads . IM.insert tId -client :: forall s. STMQueueStore s => THandleParams SMPVersion 'TServer -> Server -> s -> Client s -> M () +client :: forall s. MsgStoreClass s => THandleParams SMPVersion 'TServer -> Server -> s -> Client s -> M () client thParams' Server {subscribedQ, ntfSubscribedQ, subscribers} @@ -1768,7 +1761,7 @@ processServerMessages = do stored'' <- getQueueSize ms rId q liftIO $ closeMsgQueue q pure (stored'', expired'') - processValidateQueue :: RecipientId -> JournalQueue -> IO MessageStats + processValidateQueue :: RecipientId -> JournalQueue 'MSMemory -> IO MessageStats processValidateQueue rId q = runExceptT (getQueueSize ms rId q) >>= \case Right storedMsgsCount -> pure newMessageStats {storedMsgsCount, storedQueues = 1} @@ -1777,7 +1770,7 @@ processServerMessages = do exitFailure -- TODO this function should be called after importing queues from store log -importMessages :: forall s. STMQueueStore s => Bool -> s -> FilePath -> Maybe Int64 -> IO MessageStats +importMessages :: forall s. MsgStoreClass s => Bool -> s -> FilePath -> Maybe Int64 -> IO MessageStats importMessages tty ms f old_ = do logInfo $ "restoring messages from file " <> T.pack f LB.readFile f >>= runExceptT . foldM restoreMsg (0, Nothing, (0, 0, M.empty)) . LB.lines >>= \case diff --git a/src/Simplex/Messaging/Server/Env/STM.hs b/src/Simplex/Messaging/Server/Env/STM.hs index f598bdcb8..05322e0f1 100644 --- a/src/Simplex/Messaging/Server/Env/STM.hs +++ b/src/Simplex/Messaging/Server/Env/STM.hs @@ -184,9 +184,9 @@ data Env = Env type family MsgStore s where MsgStore 'MSMemory = STMMsgStore - MsgStore 'MSJournal = JournalMsgStore + MsgStore 'MSJournal = JournalMsgStore 'MSMemory -data AMsgStore = forall s. (STMQueueStore (MsgStore s), MsgStoreClass (MsgStore s)) => AMS (SMSType s) (MsgStore s) +data AMsgStore = forall s. MsgStoreClass (MsgStore s) => AMS (SMSType s) (MsgStore s) data AStoreQueue = forall s. MsgStoreClass (MsgStore s) => ASQ (SMSType s) (StoreQueue (MsgStore s)) @@ -295,7 +295,7 @@ newEnv config@ServerConfig {smpCredentials, httpCredentials, storeLogFile, msgSt AMSType SMSMemory -> AMS SMSMemory <$> newMsgStore STMStoreConfig {storePath = storeMsgsFile, quota = msgQueueQuota} AMSType SMSJournal -> case storeMsgsFile of Just storePath -> - let cfg = JournalStoreConfig {storePath, quota = msgQueueQuota, pathParts = journalMsgStoreDepth, maxMsgCount = maxJournalMsgCount, maxStateLines = maxJournalStateLines, stateTailSize = defaultStateTailSize, idleInterval = idleQueueInterval} + let cfg = JournalStoreConfig {storePath, quota = msgQueueQuota, pathParts = journalMsgStoreDepth, queueStoreType = SMSMemory, maxMsgCount = maxJournalMsgCount, maxStateLines = maxJournalStateLines, stateTailSize = defaultStateTailSize, idleInterval = idleQueueInterval} in AMS SMSJournal <$> newMsgStore cfg Nothing -> putStrLn "Error: journal msg store require path in [STORE_LOG], restore_messages" >> exitFailure ntfStore <- NtfStore <$> TM.emptyIO @@ -359,5 +359,5 @@ newSMPProxyAgent smpAgentCfg random = do smpAgent <- newSMPClientAgent smpAgentCfg random pure ProxyAgent {smpAgent} -readWriteQueueStore :: STMQueueStore s => FilePath -> s -> IO (StoreLog 'WriteMode) +readWriteQueueStore :: MsgStoreClass s => FilePath -> s -> IO (StoreLog 'WriteMode) readWriteQueueStore = readWriteStoreLog readQueueStore writeQueueStore diff --git a/src/Simplex/Messaging/Server/Main.hs b/src/Simplex/Messaging/Server/Main.hs index 3da2aaeb4..d5a3157dd 100644 --- a/src/Simplex/Messaging/Server/Main.hs +++ b/src/Simplex/Messaging/Server/Main.hs @@ -148,7 +148,7 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath = doesFileExist iniFile >>= \case True -> readIniFile iniFile >>= either exitError a _ -> exitError $ "Error: server is not initialized (" <> iniFile <> " does not exist).\nRun `" <> executableName <> " init`." - newJournalMsgStore = newMsgStore JournalStoreConfig {storePath = storeMsgsJournalDir, pathParts = journalMsgStoreDepth, quota = defaultMsgQueueQuota, maxMsgCount = defaultMaxJournalMsgCount, maxStateLines = defaultMaxJournalStateLines, stateTailSize = defaultStateTailSize, idleInterval = checkInterval defaultMessageExpiration} + newJournalMsgStore = newMsgStore JournalStoreConfig {storePath = storeMsgsJournalDir, pathParts = journalMsgStoreDepth, queueStoreType = SMSMemory, quota = defaultMsgQueueQuota, maxMsgCount = defaultMaxJournalMsgCount, maxStateLines = defaultMaxJournalStateLines, stateTailSize = defaultStateTailSize, idleInterval = checkInterval defaultMessageExpiration} iniFile = combine cfgPath "smp-server.ini" serverVersion = "SMP server v" <> simplexMQVersion defaultServerPorts = "5223,443" diff --git a/src/Simplex/Messaging/Server/MsgStore/Journal.hs b/src/Simplex/Messaging/Server/MsgStore/Journal.hs index 4e5496f66..78be1980f 100644 --- a/src/Simplex/Messaging/Server/MsgStore/Journal.hs +++ b/src/Simplex/Messaging/Server/MsgStore/Journal.hs @@ -2,6 +2,7 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE InstanceSigs #-} @@ -15,7 +16,7 @@ {-# LANGUAGE TupleSections #-} module Simplex.Messaging.Server.MsgStore.Journal - ( JournalMsgStore (queues, senders, notifiers, random), + ( JournalMsgStore (queueStore, random), JournalQueue, JournalMsgQueue (queue, state), JMQueue (queueDirectory, statePath), @@ -49,6 +50,7 @@ import qualified Data.ByteString.Char8 as B import Data.Functor (($>)) import Data.Int (Int64) import Data.List (intercalate) +import qualified Data.Map.Strict as M import Data.Maybe (catMaybes, fromMaybe, isNothing) import qualified Data.Text as T import Data.Time.Clock (getCurrentTime) @@ -73,19 +75,32 @@ 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, - queues :: TMap RecipientId JournalQueue, - senders :: TMap SenderId RecipientId, - notifiers :: TMap NotifierId RecipientId, - storeLog :: TVar (Maybe (StoreLog 'WriteMode)) + queueStore :: QueueStore s } -data JournalStoreConfig = JournalStoreConfig +data QueueStore (s :: MSType) where + MQStore :: + { queues :: TMap RecipientId (JournalQueue 'MSMemory), + senders :: TMap SenderId RecipientId, + notifiers :: TMap NotifierId RecipientId, + storeLog :: TVar (Maybe (StoreLog 'WriteMode)) + } -> QueueStore 'MSMemory + -- maps store cached queues + -- Nothing in map indicates that the queue doesn't exist + -- JQStore :: + -- { queues_ :: TMap RecipientId (Maybe (JournalQueue 'MSJournal)), + -- senders_ :: TMap SenderId (Maybe RecipientId), + -- notifiers_ :: TMap NotifierId (Maybe RecipientId) + -- } -> QueueStore 'MSJournal + +data JournalStoreConfig s = JournalStoreConfig { storePath :: FilePath, pathParts :: Int, + queueStoreType :: SMSType s, quota :: Int, -- Max number of messages per journal file - ignored in STM store. -- When this limit is reached, the file will be changed. @@ -97,12 +112,12 @@ data JournalStoreConfig = JournalStoreConfig idleInterval :: Int64 } -data JournalQueue = JournalQueue +data JournalQueue (s :: MSType) = JournalQueue { 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), + msgQueue_ :: TVar (Maybe (JournalMsgQueue s)), -- system time in seconds since epoch activeAt :: TVar Int64, -- Just True - empty, Just False - non-empty, Nothing - unknown @@ -114,7 +129,7 @@ data JMQueue = JMQueue statePath :: FilePath } -data JournalMsgQueue = JournalMsgQueue +data JournalMsgQueue (s :: MSType) = JournalMsgQueue { queue :: JMQueue, state :: TVar MsgQueueState, -- tipMsg contains last message and length incl. newline @@ -215,14 +230,14 @@ msgLogFileName = "messages" logFileExt :: String logFileExt = ".log" -newtype StoreIO a = StoreIO {unStoreIO :: IO a} +newtype StoreIO (s :: MSType) a = StoreIO {unStoreIO :: IO a} deriving newtype (Functor, Applicative, Monad) -instance STMQueueStore JournalMsgStore where - queues' = queues - senders' = senders - notifiers' = notifiers - storeLog' = storeLog +instance STMQueueStore (JournalMsgStore 'MSMemory) where + queues' = queues . queueStore + senders' = senders . queueStore + notifiers' = notifiers . queueStore + storeLog' = storeLog . queueStore mkQueue st qr = do lock <- getMapLock (queueLocks st) $ recipientId qr q <- newTVar $ Just qr @@ -230,39 +245,45 @@ instance STMQueueStore JournalMsgStore where activeAt <- newTVar 0 isEmpty <- newTVar Nothing pure $ JournalQueue lock q mq activeAt isEmpty - msgQueue_' = msgQueue_ -instance MsgStoreClass JournalMsgStore where - type StoreMonad JournalMsgStore = StoreIO - type StoreQueue JournalMsgStore = JournalQueue - type MsgQueue JournalMsgStore = JournalMsgQueue - type MsgStoreConfig JournalMsgStore = JournalStoreConfig +instance MsgStoreClass (JournalMsgStore s) where + type StoreMonad (JournalMsgStore s) = StoreIO s + type StoreQueue (JournalMsgStore s) = JournalQueue s + type MsgQueue (JournalMsgStore s) = JournalMsgQueue s + type MsgStoreConfig (JournalMsgStore s) = (JournalStoreConfig s) - newMsgStore :: JournalStoreConfig -> IO JournalMsgStore + newMsgStore :: JournalStoreConfig s -> IO (JournalMsgStore s) newMsgStore config = do random <- newTVarIO =<< newStdGen - queueLocks <- TM.emptyIO - queues <- TM.emptyIO - senders <- TM.emptyIO - notifiers <- TM.emptyIO - storeLog <- newTVarIO Nothing - pure JournalMsgStore {config, random, queueLocks, queues, senders, notifiers, storeLog} - - setStoreLog :: JournalMsgStore -> StoreLog 'WriteMode -> IO () - setStoreLog st sl = atomically $ writeTVar (storeLog st) (Just sl) - - closeMsgStore st = do - readTVarIO (storeLog st) >>= mapM_ closeStoreLog - readTVarIO (queues st) >>= mapM_ closeMsgQueue - - activeMsgQueues = queues + queueLocks :: TMap RecipientId Lock <- TM.emptyIO + case queueStoreType config of + SMSMemory -> do + queues <- TM.emptyIO + senders <- TM.emptyIO + notifiers <- TM.emptyIO + storeLog <- newTVarIO Nothing + let queueStore = MQStore {queues, senders, notifiers, storeLog} + pure JournalMsgStore {config, random, queueLocks, queueStore} + SMSJournal -> undefined + + setStoreLog :: JournalMsgStore s -> StoreLog 'WriteMode -> IO () + setStoreLog st sl = case queueStore st of + MQStore {storeLog} -> atomically $ writeTVar storeLog (Just sl) + + closeMsgStore st = case queueStore st of + MQStore {queues, storeLog} -> do + readTVarIO storeLog >>= mapM_ closeStoreLog + readTVarIO queues >>= mapM_ closeMsgQueue + + activeMsgQueues st = case queueStore st of + MQStore {queues} -> queues {-# INLINE activeMsgQueues #-} -- 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 -> (RecipientId -> JournalQueue -> IO a) -> IO a + withAllMsgQueues :: forall a. Monoid a => Bool -> JournalMsgStore s -> (RecipientId -> JournalQueue s -> IO a) -> IO a withAllMsgQueues tty ms@JournalMsgStore {config} action = ifM (doesDirectoryExist storePath) processStore (pure mempty) where processStore = do @@ -302,10 +323,10 @@ 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) @@ -315,7 +336,49 @@ instance MsgStoreClass JournalMsgStore where queueRec' = queueRec {-# INLINE queueRec' #-} - getMsgQueue :: JournalMsgStore -> RecipientId -> JournalQueue -> StoreIO JournalMsgQueue + msgQueue_' = msgQueue_ + {-# INLINE msgQueue_' #-} + + queueCounts :: JournalMsgStore s -> IO QueueCounts + queueCounts st = case queueStore st of + MQStore {queues, notifiers} -> do + queueCount <- M.size <$> readTVarIO queues + notifierCount <- M.size <$> readTVarIO notifiers + pure QueueCounts {queueCount, notifierCount} + + addQueue :: JournalMsgStore s -> QueueRec -> IO (Either ErrorType (JournalQueue s)) + addQueue st qr = case queueStore st of + MQStore {} -> addQueue' st qr + + getQueue :: DirectParty p => JournalMsgStore s -> SParty p -> QueueId -> IO (Either ErrorType (JournalQueue s)) + getQueue st party qId = case queueStore st of + MQStore {} -> getQueue' st party qId + + getQueueRec :: DirectParty p => JournalMsgStore s -> SParty p -> QueueId -> IO (Either ErrorType (JournalQueue s, QueueRec)) + getQueueRec st party qId = case queueStore st of + MQStore {} -> getQueueRec' st party qId + + secureQueue :: JournalMsgStore s -> JournalQueue s -> SndPublicAuthKey -> IO (Either ErrorType ()) + secureQueue st sq sKey = case queueStore st of + MQStore {} -> secureQueue' st sq sKey + + addQueueNotifier :: JournalMsgStore s -> JournalQueue s -> NtfCreds -> IO (Either ErrorType (Maybe NotifierId)) + addQueueNotifier st sq ntfCreds = case queueStore st of + MQStore {} -> addQueueNotifier' st sq ntfCreds + + deleteQueueNotifier :: JournalMsgStore s -> JournalQueue s -> IO (Either ErrorType (Maybe NotifierId)) + deleteQueueNotifier st sq = case queueStore st of + MQStore {} -> deleteQueueNotifier' st sq + + suspendQueue :: JournalMsgStore s -> JournalQueue s -> IO (Either ErrorType ()) + suspendQueue st sq = case queueStore st of + MQStore {} -> suspendQueue' st sq + + updateQueueTime :: JournalMsgStore s -> JournalQueue s -> RoundedSystemTime -> IO (Either ErrorType QueueRec) + updateQueueTime st sq t = case queueStore st of + MQStore {} -> updateQueueTime' st sq t + + getMsgQueue :: JournalMsgStore s -> RecipientId -> JournalQueue s -> StoreIO s (JournalMsgQueue s) getMsgQueue ms@JournalMsgStore {random} rId JournalQueue {msgQueue_} = StoreIO $ readTVarIO msgQueue_ >>= maybe newQ pure where @@ -327,14 +390,14 @@ instance MsgStoreClass JournalMsgStore where atomically $ writeTVar msgQueue_ $ Just q 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 -> RecipientId -> JournalQueue -> StoreIO (Maybe (JournalMsgQueue, Message)) + getPeekMsgQueue :: JournalMsgStore s -> RecipientId -> JournalQueue s -> StoreIO s (Maybe (JournalMsgQueue s, Message)) getPeekMsgQueue ms rId q@JournalQueue {isEmpty} = StoreIO (readTVarIO isEmpty) >>= \case Just True -> pure Nothing @@ -354,7 +417,7 @@ instance MsgStoreClass JournalMsgStore where (mq,) <$$> tryPeekMsg_ q mq -- only runs action if queue is not empty - withIdleMsgQueue :: Int64 -> JournalMsgStore -> RecipientId -> JournalQueue -> (JournalMsgQueue -> StoreIO a) -> StoreIO (Maybe a, Int) + withIdleMsgQueue :: Int64 -> JournalMsgStore s -> RecipientId -> JournalQueue s -> (JournalMsgQueue s -> StoreIO s a) -> StoreIO s (Maybe a, Int) withIdleMsgQueue now ms@JournalMsgStore {config} rId q action = StoreIO $ readTVarIO (msgQueue_ q) >>= \case Nothing -> @@ -375,18 +438,18 @@ instance MsgStoreClass JournalMsgStore where sz <- unStoreIO $ getQueueSize_ mq pure (r, sz) - deleteQueue :: JournalMsgStore -> RecipientId -> JournalQueue -> IO (Either ErrorType QueueRec) + deleteQueue :: JournalMsgStore s -> RecipientId -> JournalQueue s -> IO (Either ErrorType QueueRec) deleteQueue ms rId q = fst <$$> deleteQueue_ ms rId q - deleteQueueSize :: JournalMsgStore -> RecipientId -> JournalQueue -> IO (Either ErrorType (QueueRec, Int)) + deleteQueueSize :: JournalMsgStore s -> RecipientId -> JournalQueue s -> IO (Either ErrorType (QueueRec, Int)) deleteQueueSize ms rId q = deleteQueue_ ms rId q >>= mapM (traverse getSize) -- traverse operates on the second tuple element where getSize = maybe (pure (-1)) (fmap size . readTVarIO . state) - getQueueMessages_ :: Bool -> JournalMsgQueue -> StoreIO [Message] + getQueueMessages_ :: Bool -> JournalMsgQueue s -> StoreIO s [Message] getQueueMessages_ drainMsgs q = StoreIO (run []) where run msgs = readTVarIO (handles q) >>= maybe (pure []) (getMsg msgs) @@ -397,7 +460,7 @@ instance MsgStoreClass JournalMsgStore where updateReadPos q drainMsgs len hs (msg :) <$> run msgs - writeMsg :: JournalMsgStore -> RecipientId -> JournalQueue -> Bool -> Message -> ExceptT ErrorType IO (Maybe (Message, Bool)) + writeMsg :: JournalMsgStore s -> RecipientId -> JournalQueue s -> Bool -> Message -> ExceptT ErrorType IO (Maybe (Message, Bool)) writeMsg ms rId q' logState msg = isolateQueue rId q' "writeMsg" $ do q <- getMsgQueue ms rId q' StoreIO $ (`E.finally` updateActiveAt q') $ do @@ -446,15 +509,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) >>= 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 mq True $>>= peekMsg) >>= setEmpty where @@ -468,7 +531,7 @@ instance MsgStoreClass JournalMsgStore where atomically $ writeTVar (isEmpty q) (Just $ isNothing msg) pure 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 @@ -476,11 +539,11 @@ instance MsgStoreClass JournalMsgStore where $>>= \len -> readTVarIO handles $>>= \hs -> updateReadPos mq logState len hs $> Just () - isolateQueue :: RecipientId -> JournalQueue -> String -> StoreIO a -> ExceptT ErrorType IO a + isolateQueue :: RecipientId -> JournalQueue s -> String -> StoreIO s a -> ExceptT ErrorType IO a isolateQueue rId JournalQueue {queueLock} op = tryStore' op rId . withLock' queueLock op . unStoreIO -updateActiveAt :: JournalQueue -> IO () +updateActiveAt :: JournalQueue s -> IO () updateActiveAt q = atomically . writeTVar (activeAt q) . systemSeconds =<< getSystemTime tryStore' :: String -> RecipientId -> IO a -> ExceptT ErrorType IO a @@ -494,17 +557,17 @@ 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 -> IO JournalMsgQueue +openMsgQueue :: JournalMsgStore s -> JMQueue -> IO (JournalMsgQueue s) openMsgQueue ms q@JMQueue {queueDirectory = dir, statePath} = do (st, sh) <- readWriteQueueState ms statePath (st', rh, wh_) <- closeOnException sh $ openJournals ms dir st sh let hs = MsgQueueHandles {stateHandle = sh, readHandle = rh, writeHandle = wh_} mkJournalQueue q st' (Just hs) -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 @@ -513,7 +576,7 @@ mkJournalQueue queue st hs_ = do -- to avoid map lookup on queue operations pure JournalMsgQueue {queue, state, tipMsg, handles} -chooseReadJournal :: JournalMsgQueue -> Bool -> MsgQueueHandles -> IO (Maybe (JournalState 'JTRead, Handle)) +chooseReadJournal :: JournalMsgQueue s -> Bool -> MsgQueueHandles -> IO (Maybe (JournalState 'JTRead, Handle)) chooseReadJournal q log' hs = do st@MsgQueueState {writeState = ws, readState = rs} <- readTVarIO (state q) case writeHandle hs of @@ -529,7 +592,7 @@ chooseReadJournal q log' hs = do _ | msgPos rs >= msgCount rs && journalId rs == journalId ws -> pure Nothing _ -> pure $ Just (rs, readHandle hs) -updateQueueState :: JournalMsgQueue -> Bool -> MsgQueueHandles -> MsgQueueState -> STM () -> IO () +updateQueueState :: JournalMsgQueue s -> Bool -> MsgQueueHandles -> MsgQueueState -> STM () -> IO () updateQueueState q log' hs st a = do unless (validQueueState st) $ E.throwIO $ userError $ "updateQueueState invalid state: " <> show st when log' $ appendState (stateHandle hs) st @@ -538,7 +601,7 @@ updateQueueState q log' hs st a = do appendState :: Handle -> MsgQueueState -> IO () appendState h st = E.uninterruptibleMask_ $ B.hPutStr h $ strEncode st `B.snoc` '\n' -updateReadPos :: JournalMsgQueue -> Bool -> Int64 -> MsgQueueHandles -> IO () +updateReadPos :: JournalMsgQueue s -> Bool -> Int64 -> MsgQueueHandles -> IO () updateReadPos q log' len hs = do st@MsgQueueState {readState = rs, size} <- readTVarIO (state q) let JournalState {msgPos, bytePos} = rs @@ -547,7 +610,7 @@ updateReadPos q log' len hs = do st' = st {readState = rs', size = size - 1} updateQueueState 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 @@ -570,7 +633,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 @@ -643,7 +706,7 @@ removeJournal dir JournalState {journalId} = do -- This function is supposed to be resilient to crashes while updating state files, -- and also resilient to crashes during its execution. -readWriteQueueState :: JournalMsgStore -> FilePath -> IO (MsgQueueState, Handle) +readWriteQueueState :: JournalMsgStore s -> FilePath -> IO (MsgQueueState, Handle) readWriteQueueState JournalMsgStore {random, config} statePath = ifM (doesFileExist tempBackup) @@ -721,20 +784,21 @@ validQueueState MsgQueueState {readState = rs, writeState = ws, size} && msgPos ws == msgCount ws && bytePos ws == byteCount ws -deleteQueue_ :: JournalMsgStore -> RecipientId -> JournalQueue -> IO (Either ErrorType (QueueRec, Maybe JournalMsgQueue)) +deleteQueue_ :: forall s. JournalMsgStore s -> RecipientId -> JournalQueue s -> IO (Either ErrorType (QueueRec, Maybe (JournalMsgQueue s))) deleteQueue_ ms rId q = - runExceptT $ isolateQueueId "deleteQueue_" ms rId $ - deleteQueue' ms rId q >>= mapM remove + runExceptT $ isolateQueueId "deleteQueue_" ms rId $ case queueStore ms of + MQStore {} -> deleteQueue' ms rId q >>= mapM remove where + remove :: (QueueRec, Maybe (JournalMsgQueue s)) -> IO (QueueRec, Maybe (JournalMsgQueue s)) remove r@(_, mq_) = do mapM_ closeMsgQueueHandles mq_ removeQueueDirectory ms rId pure r -closeMsgQueue :: JournalQueue -> IO () +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 @@ -742,7 +806,7 @@ closeMsgQueueHandles q = readTVarIO (handles q) >>= mapM_ closeHandles hClose rh mapM_ hClose wh_ -removeQueueDirectory :: JournalMsgStore -> RecipientId -> IO () +removeQueueDirectory :: JournalMsgStore s -> RecipientId -> IO () removeQueueDirectory st = removeQueueDirectory_ . msgQueueDirectory st removeQueueDirectory_ :: FilePath -> IO () diff --git a/src/Simplex/Messaging/Server/MsgStore/STM.hs b/src/Simplex/Messaging/Server/MsgStore/STM.hs index cbeb75f9c..8a29461b4 100644 --- a/src/Simplex/Messaging/Server/MsgStore/STM.hs +++ b/src/Simplex/Messaging/Server/MsgStore/STM.hs @@ -21,6 +21,7 @@ import Control.Monad.IO.Class import Control.Monad.Trans.Except import Data.Functor (($>)) import Data.Int (Int64) +import qualified Data.Map.Strict as M import Simplex.Messaging.Protocol import Simplex.Messaging.Server.MsgStore.Types import Simplex.Messaging.Server.QueueStore @@ -63,7 +64,6 @@ instance STMQueueStore STMMsgStore where notifiers' = notifiers storeLog' = storeLog mkQueue _ qr = STMQueue <$> newTVar (Just qr) <*> newTVar Nothing - msgQueue_' = msgQueue_ instance MsgStoreClass STMMsgStore where type StoreMonad STMMsgStore = STM @@ -97,6 +97,39 @@ instance MsgStoreClass STMMsgStore where queueRec' = queueRec {-# INLINE queueRec' #-} + msgQueue_' = msgQueue_ + {-# INLINE msgQueue_' #-} + + queueCounts :: STMMsgStore -> IO QueueCounts + queueCounts st = do + queueCount <- M.size <$> readTVarIO (queues st) + notifierCount <- M.size <$> readTVarIO (notifiers st) + pure QueueCounts {queueCount, notifierCount} + + addQueue = addQueue' + {-# INLINE addQueue #-} + + getQueue = getQueue' + {-# INLINE getQueue #-} + + getQueueRec = getQueueRec' + {-# INLINE getQueueRec #-} + + secureQueue = secureQueue' + {-# INLINE secureQueue #-} + + addQueueNotifier = addQueueNotifier' + {-# INLINE addQueueNotifier #-} + + deleteQueueNotifier = deleteQueueNotifier' + {-# INLINE deleteQueueNotifier #-} + + suspendQueue = suspendQueue' + {-# INLINE suspendQueue #-} + + updateQueueTime = updateQueueTime' + {-# INLINE updateQueueTime #-} + getMsgQueue :: STMMsgStore -> RecipientId -> STMQueue -> STM STMMsgQueue getMsgQueue _ _ STMQueue {msgQueue_} = readTVar msgQueue_ >>= maybe newQ pure where diff --git a/src/Simplex/Messaging/Server/MsgStore/Types.hs b/src/Simplex/Messaging/Server/MsgStore/Types.hs index 8754767cd..f43fad442 100644 --- a/src/Simplex/Messaging/Server/MsgStore/Types.hs +++ b/src/Simplex/Messaging/Server/MsgStore/Types.hs @@ -35,7 +35,6 @@ class MsgStoreClass s => STMQueueStore s where notifiers' :: s -> TMap NotifierId RecipientId storeLog' :: s -> TVar (Maybe (StoreLog 'WriteMode)) mkQueue :: s -> QueueRec -> STM (StoreQueue s) - msgQueue_' :: StoreQueue s -> TVar (Maybe (MsgQueue s)) class Monad (StoreMonad s) => MsgStoreClass s where type StoreMonad s = (m :: Type -> Type) | m -> s @@ -50,6 +49,18 @@ class Monad (StoreMonad s) => MsgStoreClass s where logQueueStates :: s -> IO () logQueueState :: StoreQueue s -> StoreMonad s () queueRec' :: StoreQueue s -> TVar (Maybe QueueRec) + msgQueue_' :: StoreQueue s -> TVar (Maybe (MsgQueue s)) + queueCounts :: s -> IO QueueCounts + + addQueue :: s -> QueueRec -> IO (Either ErrorType (StoreQueue s)) + getQueue :: DirectParty p => s -> SParty p -> QueueId -> IO (Either ErrorType (StoreQueue s)) + getQueueRec :: DirectParty p => s -> SParty p -> QueueId -> IO (Either ErrorType (StoreQueue s, QueueRec)) + secureQueue :: s -> StoreQueue s -> SndPublicAuthKey -> IO (Either ErrorType ()) + addQueueNotifier :: s -> StoreQueue s -> NtfCreds -> IO (Either ErrorType (Maybe NotifierId)) + deleteQueueNotifier :: s -> StoreQueue s -> IO (Either ErrorType (Maybe NotifierId)) + suspendQueue :: s -> StoreQueue s -> IO (Either ErrorType ()) + updateQueueTime :: s -> StoreQueue s -> RoundedSystemTime -> IO (Either ErrorType QueueRec) + getPeekMsgQueue :: s -> RecipientId -> StoreQueue s -> StoreMonad s (Maybe (MsgQueue s, Message)) getMsgQueue :: s -> RecipientId -> StoreQueue s -> StoreMonad s (MsgQueue s) @@ -65,6 +76,11 @@ class Monad (StoreMonad s) => MsgStoreClass s where tryDeleteMsg_ :: StoreQueue s -> MsgQueue s -> Bool -> StoreMonad s () isolateQueue :: RecipientId -> StoreQueue s -> String -> StoreMonad s a -> ExceptT ErrorType IO a +data QueueCounts = QueueCounts + { queueCount :: Int, + notifierCount :: Int + } + data MSType = MSMemory | MSJournal data SMSType :: MSType -> Type where diff --git a/src/Simplex/Messaging/Server/QueueStore/STM.hs b/src/Simplex/Messaging/Server/QueueStore/STM.hs index 7bf4f3a4a..65dd828a6 100644 --- a/src/Simplex/Messaging/Server/QueueStore/STM.hs +++ b/src/Simplex/Messaging/Server/QueueStore/STM.hs @@ -14,14 +14,14 @@ {-# LANGUAGE UndecidableInstances #-} module Simplex.Messaging.Server.QueueStore.STM - ( addQueue, - getQueue, - getQueueRec, - secureQueue, - addQueueNotifier, - deleteQueueNotifier, - suspendQueue, - updateQueueTime, + ( addQueue', + getQueue', + getQueueRec', + secureQueue', + addQueueNotifier', + deleteQueueNotifier', + suspendQueue', + updateQueueTime', deleteQueue', readQueueStore, withLog', @@ -31,31 +31,25 @@ 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 qualified Data.ByteString.Lazy.Char8 as LB import Data.Functor (($>)) 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.StoreLog import qualified Simplex.Messaging.TMap as TM -import Simplex.Messaging.Util (ifM, tshow, ($>>=), (<$$)) +import Simplex.Messaging.Util (ifM, ($>>=), (<$$)) import System.IO import UnliftIO.STM -addQueue :: STMQueueStore s => s -> QueueRec -> IO (Either ErrorType (StoreQueue s)) -addQueue st qr@QueueRec {recipientId = rId, senderId = sId, notifier}= +addQueue' :: STMQueueStore s => s -> QueueRec -> IO (Either ErrorType (StoreQueue s)) +addQueue' st qr@QueueRec {recipientId = rId, senderId = sId, notifier}= atomically add $>>= \q -> q <$$ withLog "addQueue" st (`logCreateQueue` qr) where add = ifM hasId (pure $ Left DUPLICATE_) $ do - q <- mkQueue st qr -- STMQueue lock <$> (newTVar $! Just qr) <*> newTVar Nothing + q <- mkQueue st qr TM.insert rId q $ queues' st TM.insert sId rId $ senders' st forM_ notifier $ \NtfCreds {notifierId} -> TM.insert notifierId rId $ notifiers' st @@ -63,20 +57,20 @@ addQueue st qr@QueueRec {recipientId = rId, senderId = sId, notifier}= hasId = or <$> sequence [TM.member rId $ queues' st, TM.member sId $ senders' st, hasNotifier] hasNotifier = maybe (pure False) (\NtfCreds {notifierId} -> TM.member notifierId (notifiers' st)) notifier -getQueue :: (STMQueueStore s, DirectParty p) => s -> SParty p -> QueueId -> IO (Either ErrorType (StoreQueue s)) -getQueue st party qId = +getQueue' :: (STMQueueStore 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' st SSender -> TM.lookupIO qId (senders' st) $>>= (`TM.lookupIO` queues' st) SNotifier -> TM.lookupIO qId (notifiers' st) $>>= (`TM.lookupIO` queues' st) -getQueueRec :: (STMQueueStore s, DirectParty p) => s -> SParty p -> QueueId -> IO (Either ErrorType (StoreQueue s, QueueRec)) -getQueueRec st party qId = +getQueueRec' :: (STMQueueStore 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)) -secureQueue :: STMQueueStore s => s -> StoreQueue s -> SndPublicAuthKey -> IO (Either ErrorType ()) -secureQueue st sq sKey = +secureQueue' :: STMQueueStore s => s -> StoreQueue s -> SndPublicAuthKey -> IO (Either ErrorType ()) +secureQueue' st sq sKey = atomically (readQueueRec qr $>>= secure) $>>= \rId -> withLog "secureQueue" st $ \s -> logSecureQueue s rId sKey where @@ -87,8 +81,8 @@ secureQueue st sq sKey = writeTVar qr $ Just q {senderKey = Just sKey} pure $ Right rId -addQueueNotifier :: STMQueueStore s => s -> StoreQueue s -> NtfCreds -> IO (Either ErrorType (Maybe NotifierId)) -addQueueNotifier st sq ntfCreds@NtfCreds {notifierId = nId} = +addQueueNotifier' :: STMQueueStore s => s -> StoreQueue s -> NtfCreds -> IO (Either ErrorType (Maybe NotifierId)) +addQueueNotifier' st sq ntfCreds@NtfCreds {notifierId = nId} = atomically (readQueueRec qr $>>= add) $>>= \(rId, nId_) -> nId_ <$$ withLog "addQueueNotifier" st (\s -> logAddNotifier s rId ntfCreds) where @@ -100,8 +94,8 @@ addQueueNotifier st sq ntfCreds@NtfCreds {notifierId = nId} = TM.insert nId rId $ notifiers' st pure $ Right (rId, nId_) -deleteQueueNotifier :: STMQueueStore s => s -> StoreQueue s -> IO (Either ErrorType (Maybe NotifierId)) -deleteQueueNotifier st sq = +deleteQueueNotifier' :: STMQueueStore s => s -> StoreQueue s -> IO (Either ErrorType (Maybe NotifierId)) +deleteQueueNotifier' st sq = atomically (readQueueRec qr >>= mapM delete) $>>= \(rId, nId_) -> nId_ <$$ withLog "deleteQueueNotifier" st (`logDeleteNotifier` rId) where @@ -111,8 +105,8 @@ deleteQueueNotifier st sq = writeTVar qr $! Just q {notifier = Nothing} pure notifierId -suspendQueue :: STMQueueStore s => s -> StoreQueue s -> IO (Either ErrorType ()) -suspendQueue st sq = +suspendQueue' :: STMQueueStore s => s -> StoreQueue s -> IO (Either ErrorType ()) +suspendQueue' st sq = atomically (readQueueRec qr >>= mapM suspend) $>>= \rId -> withLog "suspendQueue" st (`logSuspendQueue` rId) where @@ -121,8 +115,8 @@ suspendQueue st sq = writeTVar qr $! Just q {status = QueueOff} pure $ recipientId q -updateQueueTime :: STMQueueStore s => s -> StoreQueue s -> RoundedSystemTime -> IO (Either ErrorType QueueRec) -updateQueueTime st sq t = atomically (readQueueRec qr >>= mapM update) $>>= log' +updateQueueTime' :: STMQueueStore 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} @@ -163,34 +157,3 @@ withLog' name sl action = withLog :: STMQueueStore s => String -> s -> (StoreLog 'WriteMode -> IO ()) -> IO (Either ErrorType ()) withLog name = withLog' name . storeLog' - -readQueueStore :: forall s. STMQueueStore s => FilePath -> s -> IO () -readQueueStore f st = withFile f ReadMode $ LB.hGetContents >=> mapM_ processLine . LB.lines - where - processLine :: LB.ByteString -> IO () - processLine s' = either printError procLogRecord (strDecode s) - where - s = LB.toStrict s' - procLogRecord :: StoreLogRecord -> IO () - procLogRecord = \case - CreateQueue q -> addQueue st q >>= qError (recipientId q) "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 - DeleteQueue qId -> withQueue qId "DeleteQueue" $ deleteQueue st qId - 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 -> (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) <> ", " diff --git a/src/Simplex/Messaging/Server/StoreLog.hs b/src/Simplex/Messaging/Server/StoreLog.hs index 2da3398f2..889cb6046 100644 --- a/src/Simplex/Messaging/Server/StoreLog.hs +++ b/src/Simplex/Messaging/Server/StoreLog.hs @@ -26,6 +26,7 @@ module Simplex.Messaging.Server.StoreLog logUpdateQueueTime, readWriteStoreLog, writeQueueStore, + readQueueStore, ) where @@ -34,10 +35,14 @@ import Control.Concurrent.STM import qualified Control.Exception as E import Control.Logger.Simple import Control.Monad +import Control.Monad.IO.Class +import Control.Monad.Trans.Except import qualified Data.Attoparsec.ByteString.Char8 as A import qualified Data.ByteString.Char8 as B +import qualified Data.ByteString.Lazy.Char8 as LB import qualified Data.Map.Strict as M import qualified Data.Text as T +import Data.Text.Encoding (decodeLatin1) import Data.Time.Clock (getCurrentTime) import Data.Time.Format.ISO8601 (iso8601Show) import GHC.IO (catchAny) @@ -223,7 +228,7 @@ readWriteStoreLog readStore writeStore f st = renameFile tempBackup timedBackup logInfo $ "original state preserved as " <> T.pack timedBackup -writeQueueStore :: STMQueueStore s => StoreLog 'WriteMode -> s -> IO () +writeQueueStore :: MsgStoreClass s => StoreLog 'WriteMode -> s -> IO () writeQueueStore s st = readTVarIO (activeMsgQueues st) >>= mapM_ writeQueue . M.assocs where writeQueue (rId, q) = @@ -231,3 +236,34 @@ writeQueueStore s st = readTVarIO (activeMsgQueues st) >>= mapM_ writeQueue . M. Just q' -> when (active q') $ logCreateQueue s q' -- TODO we should log suspended queues when we use them Nothing -> atomically $ TM.delete rId $ activeMsgQueues st active QueueRec {status} = status == QueueActive + +readQueueStore :: forall s. MsgStoreClass s => FilePath -> s -> IO () +readQueueStore f st = withFile f ReadMode $ LB.hGetContents >=> mapM_ processLine . LB.lines + where + processLine :: LB.ByteString -> IO () + processLine s' = either printError procLogRecord (strDecode s) + where + s = LB.toStrict s' + procLogRecord :: StoreLogRecord -> IO () + procLogRecord = \case + CreateQueue q -> addQueue st q >>= qError (recipientId q) "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 + DeleteQueue qId -> withQueue qId "DeleteQueue" $ deleteQueue st qId + 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 -> (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) <> ", " diff --git a/tests/CoreTests/MsgStoreTests.hs b/tests/CoreTests/MsgStoreTests.hs index 35c27c22e..bca1cc872 100644 --- a/tests/CoreTests/MsgStoreTests.hs +++ b/tests/CoreTests/MsgStoreTests.hs @@ -35,7 +35,6 @@ import Simplex.Messaging.Server.MsgStore.Journal import Simplex.Messaging.Server.MsgStore.STM import Simplex.Messaging.Server.MsgStore.Types import Simplex.Messaging.Server.QueueStore -import Simplex.Messaging.Server.QueueStore.STM import Simplex.Messaging.Server.StoreLog (closeStoreLog, logCreateQueue) import SMPClient (testStoreLogFile, testStoreMsgsDir, testStoreMsgsDir2, testStoreMsgsFile, testStoreMsgsFile2) import System.Directory (copyFile, createDirectoryIfMissing, listDirectory, removeFile, renameFile) @@ -69,11 +68,12 @@ withMsgStore cfg = bracket (newMsgStore cfg) closeMsgStore testSMTStoreConfig :: STMStoreConfig testSMTStoreConfig = STMStoreConfig {storePath = Nothing, quota = 3} -testJournalStoreCfg :: JournalStoreConfig +testJournalStoreCfg :: JournalStoreConfig 'MSMemory testJournalStoreCfg = JournalStoreConfig { storePath = testStoreMsgsDir, pathParts = journalMsgStoreDepth, + queueStoreType = SMSMemory, quota = 3, maxMsgCount = 4, maxStateLines = 2, @@ -178,7 +178,7 @@ testChangeReadJournal ms = do (Msg "message 5", Nothing) <- tryDelPeekMsg ms rId q mId5 void $ ExceptT $ deleteQueue ms rId q -testExportImportStore :: JournalMsgStore -> IO () +testExportImportStore :: JournalMsgStore s -> IO () testExportImportStore ms = do g <- C.newRandom (rId1, qr1) <- testNewQueueRec g True @@ -209,7 +209,7 @@ testExportImportStore ms = do closeStoreLog sl exportMessages False ms testStoreMsgsFile False (B.readFile testStoreMsgsFile `shouldReturn`) =<< B.readFile (testStoreMsgsFile <> ".copy") - let cfg = (testJournalStoreCfg :: JournalStoreConfig) {storePath = testStoreMsgsDir2} + let cfg = (testJournalStoreCfg :: JournalStoreConfig 'MSMemory) {storePath = testStoreMsgsDir2} ms' <- newMsgStore cfg readWriteQueueStore testStoreLogFile ms' >>= closeStoreLog stats@MessageStats {storedMsgsCount = 5, expiredMsgsCount = 0, storedQueues = 2} <- @@ -226,7 +226,7 @@ testExportImportStore ms = do exportMessages False stmStore testStoreMsgsFile False (B.sort <$> B.readFile testStoreMsgsFile `shouldReturn`) =<< (B.sort <$> B.readFile (testStoreMsgsFile2 <> ".bak")) -testQueueState :: JournalMsgStore -> IO () +testQueueState :: JournalMsgStore s -> IO () testQueueState ms = do g <- C.newRandom rId <- EntityId <$> atomically (C.randomBytes 24 g) @@ -291,7 +291,7 @@ testQueueState ms = do let f = dir name in unless (f == keep) $ removeFile f -testMessageState :: JournalMsgStore -> IO () +testMessageState :: JournalMsgStore s -> IO () testMessageState ms = do g <- C.newRandom (rId, qr) <- testNewQueueRec g True @@ -316,7 +316,7 @@ testMessageState ms = do (Msg "message 3", Nothing) <- tryDelPeekMsg ms rId q mId3 liftIO $ closeMsgQueue q -testReadFileMissing :: JournalMsgStore -> IO () +testReadFileMissing :: JournalMsgStore s -> IO () testReadFileMissing ms = do g <- C.newRandom (rId, qr) <- testNewQueueRec g True @@ -340,7 +340,7 @@ testReadFileMissing ms = do Msg "message 2" <- tryPeekMsg ms rId q' pure () -testReadFileMissingSwitch :: JournalMsgStore -> IO () +testReadFileMissingSwitch :: JournalMsgStore s -> IO () testReadFileMissingSwitch ms = do g <- C.newRandom (rId, qr) <- testNewQueueRec g True @@ -358,7 +358,7 @@ testReadFileMissingSwitch ms = do Msg "message 5" <- tryPeekMsg ms rId q' pure () -testWriteFileMissing :: JournalMsgStore -> IO () +testWriteFileMissing :: JournalMsgStore s -> IO () testWriteFileMissing ms = do g <- C.newRandom (rId, qr) <- testNewQueueRec g True @@ -381,7 +381,7 @@ testWriteFileMissing ms = do Msg "message 6" <- tryPeekMsg ms rId q' pure () -testReadAndWriteFilesMissing :: JournalMsgStore -> IO () +testReadAndWriteFilesMissing :: JournalMsgStore s -> IO () testReadAndWriteFilesMissing ms = do g <- C.newRandom (rId, qr) <- testNewQueueRec g True @@ -400,7 +400,7 @@ testReadAndWriteFilesMissing ms = do Msg "message 6" <- tryPeekMsg ms rId q' pure () -writeMessages :: JournalMsgStore -> RecipientId -> QueueRec -> IO JournalQueue +writeMessages :: JournalMsgStore s -> RecipientId -> QueueRec -> IO (JournalQueue s) writeMessages ms rId qr = runRight $ do q <- ExceptT $ addQueue ms qr let write s = writeMsg ms rId q True =<< mkMessage s diff --git a/tests/CoreTests/StoreLogTests.hs b/tests/CoreTests/StoreLogTests.hs index e24f9f1ea..5de40f0ef 100644 --- a/tests/CoreTests/StoreLogTests.hs +++ b/tests/CoreTests/StoreLogTests.hs @@ -108,5 +108,5 @@ testSMPStoreLog testSuite tests = closeStoreLog l ([], compacted') <- partitionEithers . map strDecode . B.lines <$> B.readFile testStoreLogFile compacted' `shouldBe` compacted - storeState :: JournalMsgStore -> IO (M.Map RecipientId QueueRec) - storeState st = M.mapMaybe id <$> (readTVarIO (queues st) >>= mapM (readTVarIO . queueRec')) + storeState :: JournalMsgStore 'MSMemory -> IO (M.Map RecipientId QueueRec) + storeState st = M.mapMaybe id <$> (readTVarIO (queues' st) >>= mapM (readTVarIO . queueRec')) From 8b656d7dc567aa7648ab1d71437dfd8cdc750381 Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin Date: Thu, 12 Dec 2024 13:45:18 +0000 Subject: [PATCH 02/17] partial implementation --- .../Messaging/Server/MsgStore/Journal.hs | 100 ++++++++++++++---- src/Simplex/Messaging/Server/MsgStore/STM.hs | 2 +- .../Messaging/Server/MsgStore/Types.hs | 2 +- .../Messaging/Server/QueueStore/STM.hs | 9 +- 4 files changed, 87 insertions(+), 26 deletions(-) diff --git a/src/Simplex/Messaging/Server/MsgStore/Journal.hs b/src/Simplex/Messaging/Server/MsgStore/Journal.hs index 78be1980f..05690e567 100644 --- a/src/Simplex/Messaging/Server/MsgStore/Journal.hs +++ b/src/Simplex/Messaging/Server/MsgStore/Journal.hs @@ -51,7 +51,7 @@ import Data.Functor (($>)) import Data.Int (Int64) import Data.List (intercalate) import qualified Data.Map.Strict as M -import Data.Maybe (catMaybes, fromMaybe, isNothing) +import Data.Maybe (catMaybes, fromMaybe, isJust, isNothing) import qualified Data.Text as T import Data.Time.Clock (getCurrentTime) import Data.Time.Clock.System (SystemTime (..), getSystemTime) @@ -91,11 +91,11 @@ data QueueStore (s :: MSType) where } -> QueueStore 'MSMemory -- maps store cached queues -- Nothing in map indicates that the queue doesn't exist - -- JQStore :: - -- { queues_ :: TMap RecipientId (Maybe (JournalQueue 'MSJournal)), - -- senders_ :: TMap SenderId (Maybe RecipientId), - -- notifiers_ :: TMap NotifierId (Maybe RecipientId) - -- } -> QueueStore 'MSJournal + JQStore :: + { queues_ :: TMap RecipientId (Maybe (JournalQueue 'MSJournal)), + senders_ :: TMap SenderId (Maybe RecipientId), + notifiers_ :: TMap NotifierId (Maybe RecipientId) + } -> QueueStore 'MSJournal data JournalStoreConfig s = JournalStoreConfig { storePath :: FilePath, @@ -224,6 +224,9 @@ instance JournalTypeI t => StrEncoding (JournalState t) where queueLogFileName :: String queueLogFileName = "queue_state" +queueRecFileName :: String +queueRecFileName = "queue_rec" + msgLogFileName :: String msgLogFileName = "messages" @@ -239,12 +242,16 @@ instance STMQueueStore (JournalMsgStore 'MSMemory) where notifiers' = notifiers . queueStore storeLog' = storeLog . queueStore mkQueue st qr = do - lock <- getMapLock (queueLocks st) $ recipientId qr - q <- newTVar $ Just qr - mq <- newTVar Nothing - activeAt <- newTVar 0 - isEmpty <- newTVar Nothing - pure $ JournalQueue lock q mq activeAt isEmpty + lock <- atomically $ getMapLock (queueLocks st) $ recipientId qr + makeQueue lock qr + +makeQueue :: Lock -> QueueRec -> IO (JournalQueue s) +makeQueue lock qr = do + q <- newTVarIO $ Just qr + mq <- newTVarIO Nothing + activeAt <- newTVarIO 0 + isEmpty <- newTVarIO Nothing + pure $ JournalQueue lock q mq activeAt isEmpty instance MsgStoreClass (JournalMsgStore s) where type StoreMonad (JournalMsgStore s) = StoreIO s @@ -264,20 +271,27 @@ instance MsgStoreClass (JournalMsgStore s) where storeLog <- newTVarIO Nothing let queueStore = MQStore {queues, senders, notifiers, storeLog} pure JournalMsgStore {config, random, queueLocks, queueStore} - SMSJournal -> undefined + SMSJournal -> do + queues_ <- TM.emptyIO + senders_ <- TM.emptyIO + notifiers_ <- TM.emptyIO + let queueStore = JQStore {queues_, senders_, notifiers_} + pure JournalMsgStore {config, random, queueLocks, queueStore} setStoreLog :: JournalMsgStore s -> StoreLog 'WriteMode -> IO () setStoreLog st sl = case queueStore st of MQStore {storeLog} -> atomically $ writeTVar storeLog (Just sl) + JQStore {} -> undefined closeMsgStore st = case queueStore st of MQStore {queues, storeLog} -> do readTVarIO storeLog >>= mapM_ closeStoreLog readTVarIO queues >>= mapM_ closeMsgQueue + JQStore {} -> undefined activeMsgQueues st = case queueStore st of MQStore {queues} -> queues - {-# INLINE activeMsgQueues #-} + JQStore {} -> undefined -- 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. @@ -345,38 +359,80 @@ instance MsgStoreClass (JournalMsgStore s) where queueCount <- M.size <$> readTVarIO queues notifierCount <- M.size <$> readTVarIO notifiers pure QueueCounts {queueCount, notifierCount} + JQStore {} -> undefined addQueue :: JournalMsgStore s -> QueueRec -> IO (Either ErrorType (JournalQueue s)) - addQueue st qr = case queueStore st of + addQueue st@JournalMsgStore {queueLocks = ls} qr@QueueRec {recipientId = rId, senderId = sId, notifier} = case queueStore st of MQStore {} -> addQueue' st qr + JQStore {queues_, senders_, notifiers_} -> do + lock <- atomically $ getMapLock ls $ recipientId qr + tryStore "addQueue" rId $ + withLock' lock "addQueue" $ withLockMap ls sId "addQueueS" $ withNotifierLock $ + ifM hasAnyId (pure $ Left DUPLICATE_) $ E.uninterruptibleMask_ $ do + q <- makeQueue lock qr + atomically $ TM.insert rId (Just q) queues_ + atomically $ TM.insert sId (Just rId) senders_ + storeQueue queuePath qr + saveQueueRef sId rId + forM_ notifier $ \NtfCreds {notifierId} -> do + atomically $ TM.insert notifierId (Just rId) notifiers_ + saveQueueRef notifierId rId + pure $ Right q + where + dir = msgQueueDirectory st rId + queuePath = queueRecPath dir $ B.unpack (strEncode rId) + storeQueue _ _ = pure () -- TODO + saveQueueRef _ _ = pure () -- TODO + hasAnyId = foldM (fmap . (||)) False [hasId rId queues_, hasId sId senders_, withNotifier (`hasId` notifiers_), hasDir rId, hasDir sId, withNotifier hasDir] + withNotifier p = maybe (pure False) (\NtfCreds {notifierId} -> p notifierId) notifier + withNotifierLock a = maybe a (\NtfCreds {notifierId} -> withLockMap ls notifierId "addQueueN" a) notifier + hasId :: EntityId -> TMap EntityId (Maybe a) -> IO Bool + hasId qId m = maybe False isJust <$> atomically (TM.lookup qId m) + hasDir qId = doesDirectoryExist $ msgQueueDirectory st qId getQueue :: DirectParty p => JournalMsgStore s -> SParty p -> QueueId -> IO (Either ErrorType (JournalQueue s)) getQueue st party qId = case queueStore st of MQStore {} -> getQueue' st party qId + JQStore {queues_, senders_, notifiers_} -> maybe (Left AUTH) Right <$> case party of + SRecipient -> getQueue_ qId + SSender -> getQueueRef senders_ $>>= getQueue_ + SNotifier -> getQueueRef notifiers_ $>>= getQueue_ + where + getQueue_ rId = TM.lookupIO rId queues_ >>= maybe (loadQueue rId) pure + getQueueRef :: TMap EntityId (Maybe RecipientId) -> IO (Maybe RecipientId) + getQueueRef m = TM.lookupIO qId m >>= maybe (loadQueueRef m) pure + loadQueue _rId = undefined -- TODO load, cache, return queue + loadQueueRef _m = undefined -- TODO load, cache, return queue ID getQueueRec :: DirectParty p => JournalMsgStore s -> SParty p -> QueueId -> IO (Either ErrorType (JournalQueue s, QueueRec)) getQueueRec st party qId = case queueStore st of MQStore {} -> getQueueRec' st party qId + JQStore {} -> undefined secureQueue :: JournalMsgStore s -> JournalQueue s -> SndPublicAuthKey -> IO (Either ErrorType ()) secureQueue st sq sKey = case queueStore st of MQStore {} -> secureQueue' st sq sKey + JQStore {} -> undefined addQueueNotifier :: JournalMsgStore s -> JournalQueue s -> NtfCreds -> IO (Either ErrorType (Maybe NotifierId)) addQueueNotifier st sq ntfCreds = case queueStore st of MQStore {} -> addQueueNotifier' st sq ntfCreds + JQStore {} -> undefined deleteQueueNotifier :: JournalMsgStore s -> JournalQueue s -> IO (Either ErrorType (Maybe NotifierId)) deleteQueueNotifier st sq = case queueStore st of MQStore {} -> deleteQueueNotifier' st sq + JQStore {} -> undefined suspendQueue :: JournalMsgStore s -> JournalQueue s -> IO (Either ErrorType ()) suspendQueue st sq = case queueStore st of MQStore {} -> suspendQueue' st sq + JQStore {} -> undefined updateQueueTime :: JournalMsgStore s -> JournalQueue s -> RoundedSystemTime -> IO (Either ErrorType QueueRec) updateQueueTime st sq t = case queueStore st of MQStore {} -> updateQueueTime' st sq t + JQStore {} -> undefined getMsgQueue :: JournalMsgStore s -> RecipientId -> JournalQueue s -> StoreIO s (JournalMsgQueue s) getMsgQueue ms@JournalMsgStore {random} rId JournalQueue {msgQueue_} = @@ -386,6 +442,8 @@ instance MsgStoreClass (JournalMsgStore s) where let dir = msgQueueDirectory ms rId statePath = msgQueueStatePath dir $ B.unpack (strEncode rId) queue = JMQueue {queueDirectory = dir, statePath} + -- TODO this should account for the possibility that the folder exists, + -- but queue files do not q <- ifM (doesDirectoryExist dir) (openMsgQueue ms queue) (createQ queue) atomically $ writeTVar msgQueue_ $ Just q pure q @@ -547,10 +605,10 @@ updateActiveAt :: JournalQueue s -> IO () updateActiveAt q = atomically . writeTVar (activeAt q) . systemSeconds =<< getSystemTime tryStore' :: String -> RecipientId -> IO a -> ExceptT ErrorType IO a -tryStore' op rId = tryStore op rId . fmap Right +tryStore' op rId = ExceptT . tryStore op rId . fmap Right -tryStore :: forall a. String -> RecipientId -> IO (Either ErrorType a) -> ExceptT ErrorType IO a -tryStore op rId a = ExceptT $ E.mask_ $ E.try a >>= either storeErr pure +tryStore :: forall a. String -> RecipientId -> IO (Either ErrorType a) -> IO (Either ErrorType a) +tryStore op rId a = E.mask_ $ E.try a >>= either storeErr pure where storeErr :: E.SomeException -> IO (Either ErrorType a) storeErr e = @@ -558,7 +616,7 @@ tryStore op rId a = ExceptT $ E.mask_ $ E.try a >>= either storeErr pure in logError ("STORE: " <> T.pack e') $> Left (STORE e') 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 +isolateQueueId op ms rId = ExceptT . tryStore op rId . withLockMap (queueLocks ms) rId op openMsgQueue :: JournalMsgStore s -> JMQueue -> IO (JournalMsgQueue s) openMsgQueue ms q@JMQueue {queueDirectory = dir, statePath} = do @@ -620,6 +678,9 @@ msgQueueDirectory JournalMsgStore {config = JournalStoreConfig {storePath, pathP let (seg, s') = B.splitAt 2 s in seg : splitSegments (n - 1) s' +queueRecPath :: FilePath -> String -> FilePath +queueRecPath dir queueId = dir (queueRecFileName <> "." <> queueId <> logFileExt) + msgQueueStatePath :: FilePath -> String -> FilePath msgQueueStatePath dir queueId = dir (queueLogFileName <> "." <> queueId <> logFileExt) @@ -788,6 +849,7 @@ deleteQueue_ :: forall s. JournalMsgStore s -> RecipientId -> JournalQueue s -> deleteQueue_ ms rId q = runExceptT $ isolateQueueId "deleteQueue_" ms rId $ case queueStore ms of MQStore {} -> deleteQueue' ms rId q >>= mapM remove + JQStore {} -> undefined where remove :: (QueueRec, Maybe (JournalMsgQueue s)) -> IO (QueueRec, Maybe (JournalMsgQueue s)) remove r@(_, mq_) = do diff --git a/src/Simplex/Messaging/Server/MsgStore/STM.hs b/src/Simplex/Messaging/Server/MsgStore/STM.hs index 8a29461b4..0dbe4bc30 100644 --- a/src/Simplex/Messaging/Server/MsgStore/STM.hs +++ b/src/Simplex/Messaging/Server/MsgStore/STM.hs @@ -63,7 +63,7 @@ instance STMQueueStore STMMsgStore where senders' = senders notifiers' = notifiers storeLog' = storeLog - mkQueue _ qr = STMQueue <$> newTVar (Just qr) <*> newTVar Nothing + mkQueue _ qr = STMQueue <$> newTVarIO (Just qr) <*> newTVarIO Nothing instance MsgStoreClass STMMsgStore where type StoreMonad STMMsgStore = STM diff --git a/src/Simplex/Messaging/Server/MsgStore/Types.hs b/src/Simplex/Messaging/Server/MsgStore/Types.hs index f43fad442..f000f2d4f 100644 --- a/src/Simplex/Messaging/Server/MsgStore/Types.hs +++ b/src/Simplex/Messaging/Server/MsgStore/Types.hs @@ -34,7 +34,7 @@ class MsgStoreClass s => STMQueueStore s where senders' :: s -> TMap SenderId RecipientId notifiers' :: s -> TMap NotifierId RecipientId storeLog' :: s -> TVar (Maybe (StoreLog 'WriteMode)) - mkQueue :: s -> QueueRec -> STM (StoreQueue s) + mkQueue :: s -> QueueRec -> IO (StoreQueue s) class Monad (StoreMonad s) => MsgStoreClass s where type StoreMonad s = (m :: Type -> Type) | m -> s diff --git a/src/Simplex/Messaging/Server/QueueStore/STM.hs b/src/Simplex/Messaging/Server/QueueStore/STM.hs index 65dd828a6..d058b2e0f 100644 --- a/src/Simplex/Messaging/Server/QueueStore/STM.hs +++ b/src/Simplex/Messaging/Server/QueueStore/STM.hs @@ -44,17 +44,16 @@ import System.IO import UnliftIO.STM addQueue' :: STMQueueStore s => s -> QueueRec -> IO (Either ErrorType (StoreQueue s)) -addQueue' st qr@QueueRec {recipientId = rId, senderId = sId, notifier}= - atomically add +addQueue' st qr@QueueRec {recipientId = rId, senderId = sId, notifier} = + (mkQueue st qr >>= atomically . add) $>>= \q -> q <$$ withLog "addQueue" st (`logCreateQueue` qr) where - add = ifM hasId (pure $ Left DUPLICATE_) $ do - q <- mkQueue st qr + add q = ifM hasId (pure $ Left DUPLICATE_) $ do TM.insert rId q $ queues' st TM.insert sId rId $ senders' st forM_ notifier $ \NtfCreds {notifierId} -> TM.insert notifierId rId $ notifiers' st pure $ Right q - hasId = or <$> sequence [TM.member rId $ queues' st, TM.member sId $ senders' st, hasNotifier] + hasId = foldM (fmap . (||)) False [TM.member rId $ queues' st, TM.member sId $ senders' st, hasNotifier] hasNotifier = maybe (pure False) (\NtfCreds {notifierId} -> TM.member notifierId (notifiers' st)) notifier getQueue' :: (STMQueueStore s, DirectParty p) => s -> SParty p -> QueueId -> IO (Either ErrorType (StoreQueue s)) From 38a4a4faf5acb06017930909734f7d8659d1611b Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin Date: Fri, 13 Dec 2024 14:25:52 +0000 Subject: [PATCH 03/17] move queue recipient ID and paths to queue object, TODO remove recipientId from QueueRec, implement suspendQueue and updateQueueTime --- src/Simplex/Messaging/Server.hs | 45 ++-- .../Messaging/Server/MsgStore/Journal.hs | 244 +++++++++++------- src/Simplex/Messaging/Server/MsgStore/STM.hs | 39 +-- .../Messaging/Server/MsgStore/Types.hs | 76 +++--- .../Messaging/Server/QueueStore/STM.hs | 11 +- src/Simplex/Messaging/Util.hs | 4 + tests/CoreTests/MsgStoreTests.hs | 148 +++++------ 7 files changed, 312 insertions(+), 255 deletions(-) diff --git a/src/Simplex/Messaging/Server.hs b/src/Simplex/Messaging/Server.hs index 07d8b0e00..0fda31b00 100644 --- a/src/Simplex/Messaging/Server.hs +++ b/src/Simplex/Messaging/Server.hs @@ -390,8 +390,8 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg} attachHT atomicModifyIORef'_ (msgExpired stats) (+ expired) printMessageStats "STORE: messages" msgStats where - expireQueueMsgs now ms old rId q = fmap (fromRight newMessageStats) . runExceptT $ do - (expired_, stored) <- idleDeleteExpiredMsgs now ms rId q old + expireQueueMsgs now ms old q = fmap (fromRight newMessageStats) . runExceptT $ do + (expired_, stored) <- idleDeleteExpiredMsgs now ms q old pure MessageStats {storedMsgsCount = stored, expiredMsgsCount = fromMaybe 0 expired_, storedQueues = 1} expireNtfsThread :: ServerConfig -> M () @@ -1307,7 +1307,7 @@ client deliver inc sub = do stats <- asks serverStats fmap (either (\e -> (corrId, rId, ERR e)) id) $ liftIO $ runExceptT $ do - msg_ <- tryPeekMsg ms rId q + msg_ <- tryPeekMsg ms q liftIO $ when (inc && isJust msg_) $ incStat (qSub stats) liftIO $ deliverMessage "SUB" qr rId sub msg_ @@ -1341,7 +1341,7 @@ client getMessage_ s delivered_ = do stats <- asks serverStats fmap (either err id) $ liftIO $ runExceptT $ - tryPeekMsg ms (recipientId qr) q >>= \case + tryPeekMsg ms q >>= \case Just msg -> do let encMsg = encryptMsg qr msg incStat $ (if isJust delivered_ then msgGetDuplicate else msgGet) stats @@ -1383,11 +1383,11 @@ client fmap (either err id) $ liftIO $ runExceptT $ do case st of ProhibitSub -> do - deletedMsg_ <- tryDelMsg ms (recipientId qr) q msgId + deletedMsg_ <- tryDelMsg ms q msgId liftIO $ mapM_ (updateStats stats True) deletedMsg_ pure ok _ -> do - (deletedMsg_, msg_) <- tryDelPeekMsg ms (recipientId qr) q msgId + (deletedMsg_, msg_) <- tryDelPeekMsg ms q msgId liftIO $ mapM_ (updateStats stats False) deletedMsg_ liftIO $ deliverMessage "ACK" qr entId sub msg_ _ -> pure $ err NO_MSG @@ -1438,7 +1438,7 @@ client msg_ <- liftIO $ time "SEND" $ runExceptT $ do expireMessages messageExpiration stats msg <- liftIO $ mkMessage msgId body - writeMsg ms (recipientId qr) q True msg + writeMsg ms q True msg case msg_ of Left e -> pure $ err e Right Nothing -> do @@ -1463,7 +1463,7 @@ client expireMessages :: Maybe ExpirationConfig -> ServerStats -> ExceptT ErrorType IO () expireMessages msgExp stats = do - deleted <- maybe (pure 0) (deleteExpiredMsgs ms (recipientId qr) q <=< liftIO . expireBeforeEpoch) msgExp + deleted <- maybe (pure 0) (deleteExpiredMsgs ms q <=< liftIO . expireBeforeEpoch) msgExp liftIO $ when (deleted > 0) $ atomicModifyIORef'_ (msgExpired stats) (+ deleted) -- The condition for delivery of the message is: @@ -1645,11 +1645,11 @@ client Left e -> pure $ err e getQueueInfo :: StoreQueue s -> QueueRec -> M BrokerMsg - getQueueInfo q QueueRec {recipientId = rId, senderKey, notifier} = do + getQueueInfo q QueueRec {senderKey, notifier} = do fmap (either ERR id) $ liftIO $ runExceptT $ do qiSub <- liftIO $ TM.lookupIO entId subscriptions >>= mapM mkQSub - qiSize <- getQueueSize ms rId q - qiMsg <- toMsgInfo <$$> tryPeekMsg ms rId q + qiSize <- getQueueSize ms q + qiMsg <- toMsgInfo <$$> tryPeekMsg ms q let info = QueueInfo {qiSnd = isJust senderKey, qiNtf = isJust notifier, qiSub, qiSize, qiMsg} pure $ INFO info where @@ -1719,8 +1719,9 @@ exportMessages tty ms f drainMsgs = do logError $ "error exporting messages: " <> tshow e exitFailure where - saveQueueMsgs h rId q = - runExceptT (getQueueMessages drainMsgs ms rId q) >>= \case + saveQueueMsgs h q = do + let rId = recipientId' q + runExceptT (getQueueMessages drainMsgs ms q) >>= \case Right msgs -> Sum (length msgs) <$ BLD.hPutBuilder h (encodeMessages rId msgs) Left e -> do logError $ "STORE: saveQueueMsgs, error exporting messages from queue " <> decodeLatin1 (strEncode rId) <> ", " <> tshow e @@ -1748,7 +1749,7 @@ processServerMessages = do withAllMsgQueues False ms $ processValidateQueue | otherwise -> logWarn "skipping message expiration" $> Nothing where - processExpireQueue old rId q = + processExpireQueue old q = runExceptT expireQueue >>= \case Right (storedMsgsCount, expiredMsgsCount) -> pure MessageStats {storedMsgsCount, expiredMsgsCount, storedQueues = 1} @@ -1757,13 +1758,13 @@ processServerMessages = do exitFailure where expireQueue = do - expired'' <- deleteExpiredMsgs ms rId q old - stored'' <- getQueueSize ms rId q + expired'' <- deleteExpiredMsgs ms q old + stored'' <- getQueueSize ms q liftIO $ closeMsgQueue q pure (stored'', expired'') - processValidateQueue :: RecipientId -> JournalQueue 'MSMemory -> IO MessageStats - processValidateQueue rId q = - runExceptT (getQueueSize ms rId q) >>= \case + processValidateQueue :: JournalQueue 'MSMemory -> IO MessageStats + processValidateQueue q = + runExceptT (getQueueSize ms q) >>= \case Right storedMsgsCount -> pure newMessageStats {storedMsgsCount, storedQueues = 1} Left e -> do logError $ "STORE: processValidateQueue, failed opening message queue, " <> tshow e @@ -1802,7 +1803,7 @@ importMessages tty ms f old_ = do (i + 1,Just (rId, q),) <$> case msg of Message {msgTs} | maybe True (systemSeconds msgTs >=) old_ -> do - writeMsg ms rId q False msg >>= \case + writeMsg ms q False msg >>= \case Just _ -> pure (stored + 1, expired, overQuota) Nothing -> do logError $ decodeLatin1 $ "message queue " <> strEncode rId <> " is full, message not restored: " <> strEncode (messageId msg) @@ -1811,11 +1812,11 @@ importMessages tty ms f old_ = do MessageQuota {} -> -- queue was over quota at some point, -- it will be set as over quota once fully imported - mergeQuotaMsgs >> writeMsg ms rId q False msg $> (stored, expired, M.insert rId q overQuota) + mergeQuotaMsgs >> writeMsg ms q False msg $> (stored, expired, M.insert rId q overQuota) where -- if the first message in queue head is "quota", remove it. mergeQuotaMsgs = - withPeekMsgQueue ms rId q "mergeQuotaMsgs" $ maybe (pure ()) $ \case + withPeekMsgQueue ms q "mergeQuotaMsgs" $ maybe (pure ()) $ \case (mq, MessageQuota {}) -> tryDeleteMsg_ q mq False _ -> pure () msgErr :: Show e => String -> e -> String diff --git a/src/Simplex/Messaging/Server/MsgStore/Journal.hs b/src/Simplex/Messaging/Server/MsgStore/Journal.hs index 05690e567..e6f15c99f 100644 --- a/src/Simplex/Messaging/Server/MsgStore/Journal.hs +++ b/src/Simplex/Messaging/Server/MsgStore/Journal.hs @@ -17,9 +17,8 @@ module Simplex.Messaging.Server.MsgStore.Journal ( JournalMsgStore (queueStore, random), - JournalQueue, - JournalMsgQueue (queue, state), - JMQueue (queueDirectory, statePath), + JournalQueue (queueDirectory), + JournalMsgQueue (state), JournalStoreConfig (..), closeMsgQueue, closeMsgQueueHandles, @@ -67,7 +66,7 @@ import Simplex.Messaging.Server.QueueStore.STM import Simplex.Messaging.TMap (TMap) import qualified Simplex.Messaging.TMap as TM import Simplex.Messaging.Server.StoreLog -import Simplex.Messaging.Util (ifM, tshow, ($>>=), (<$$>)) +import Simplex.Messaging.Util (anyM, ifM, tshow, ($>>=), (<$$>)) import System.Directory import System.Exit import System.FilePath (()) @@ -113,7 +112,8 @@ data JournalStoreConfig s = JournalStoreConfig } data JournalQueue (s :: MSType) = JournalQueue - { queueLock :: Lock, + { 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), @@ -121,17 +121,13 @@ data JournalQueue (s :: MSType) = JournalQueue -- system time in seconds since epoch activeAt :: TVar Int64, -- Just True - empty, Just False - non-empty, Nothing - unknown - isEmpty :: TVar (Maybe Bool) - } - -data JMQueue = JMQueue - { queueDirectory :: FilePath, + isEmpty :: TVar (Maybe Bool), + queueDirectory :: FilePath, statePath :: FilePath } data JournalMsgQueue (s :: MSType) = JournalMsgQueue - { queue :: JMQueue, - state :: TVar MsgQueueState, + { state :: TVar MsgQueueState, -- tipMsg contains last message and length incl. newline -- Nothing - unknown, Just Nothing - empty queue. -- It prevents reading each message twice, @@ -241,17 +237,29 @@ instance STMQueueStore (JournalMsgStore 'MSMemory) where senders' = senders . queueStore notifiers' = notifiers . queueStore storeLog' = storeLog . queueStore - mkQueue st qr = do - lock <- atomically $ getMapLock (queueLocks st) $ recipientId qr - makeQueue lock qr - -makeQueue :: Lock -> QueueRec -> IO (JournalQueue s) -makeQueue lock qr = do - q <- newTVarIO $ Just qr - mq <- newTVarIO Nothing + mkQueue st qr@QueueRec {recipientId} = do + lock <- atomically $ getMapLock (queueLocks st) recipientId + makeQueue st lock qr + +makeQueue :: JournalMsgStore s -> Lock -> QueueRec -> IO (JournalQueue s) +makeQueue st queueLock qr@QueueRec {recipientId} = do + queueRec <- newTVarIO $ Just qr + msgQueue_ <- newTVarIO Nothing activeAt <- newTVarIO 0 isEmpty <- newTVarIO Nothing - pure $ JournalQueue lock q mq activeAt isEmpty + let dir = msgQueueDirectory st recipientId + statePath = msgQueueStatePath dir $ B.unpack (strEncode recipientId) + pure + JournalQueue + { recipientId, + queueLock, + queueRec, + msgQueue_, + activeAt, + isEmpty, + queueDirectory = dir, + statePath + } instance MsgStoreClass (JournalMsgStore s) where type StoreMonad (JournalMsgStore s) = StoreIO s @@ -297,7 +305,7 @@ instance MsgStoreClass (JournalMsgStore s) where -- 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 s -> (RecipientId -> JournalQueue s -> IO a) -> IO a + 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 @@ -311,7 +319,7 @@ instance MsgStoreClass (JournalMsgStore s) where r' <- case strDecode $ B.pack queueId of Right rId -> getQueue ms SRecipient rId >>= \case - Right q -> unStoreIO (getMsgQueue ms rId q) *> action rId q <* closeMsgQueue q + Right q -> unStoreIO (getMsgQueue ms q) *> action q <* closeMsgQueue q Left AUTH -> do logWarn $ "STORE: processQueue, queue " <> T.pack queueId <> " was removed, removing " <> T.pack dir removeQueueDirectory_ dir @@ -338,7 +346,7 @@ instance MsgStoreClass (JournalMsgStore s) where (Nothing <$ putStrLn ("Error: path " <> path' <> " is not a directory, skipping")) logQueueStates :: JournalMsgStore s -> IO () - logQueueStates ms = withActiveMsgQueues ms $ \_ -> unStoreIO . logQueueState + logQueueStates ms = withActiveMsgQueues ms $ unStoreIO . logQueueState logQueueState :: JournalQueue s -> StoreIO s () logQueueState q = @@ -347,6 +355,10 @@ instance MsgStoreClass (JournalMsgStore s) where $>>= \mq -> readTVarIO (handles mq) $>>= (\hs -> (readTVarIO (state mq) >>= appendState (stateHandle hs)) $> Just ()) + -- TODO [queues] remove pun once recipientId is removed from QueueRec + recipientId' JournalQueue {recipientId} = recipientId + {-# INLINE recipientId' #-} + queueRec' = queueRec {-# INLINE queueRec' #-} @@ -365,25 +377,18 @@ instance MsgStoreClass (JournalMsgStore s) where addQueue st@JournalMsgStore {queueLocks = ls} qr@QueueRec {recipientId = rId, senderId = sId, notifier} = case queueStore st of MQStore {} -> addQueue' st qr JQStore {queues_, senders_, notifiers_} -> do - lock <- atomically $ getMapLock ls $ recipientId qr + lock <- atomically $ getMapLock ls rId tryStore "addQueue" rId $ withLock' lock "addQueue" $ withLockMap ls sId "addQueueS" $ withNotifierLock $ ifM hasAnyId (pure $ Left DUPLICATE_) $ E.uninterruptibleMask_ $ do - q <- makeQueue lock qr + q <- makeQueue st lock qr + storeQueue_ q qr atomically $ TM.insert rId (Just q) queues_ - atomically $ TM.insert sId (Just rId) senders_ - storeQueue queuePath qr - saveQueueRef sId rId - forM_ notifier $ \NtfCreds {notifierId} -> do - atomically $ TM.insert notifierId (Just rId) notifiers_ - saveQueueRef notifierId rId + saveQueueRef st sId rId senders_ + forM_ notifier $ \NtfCreds {notifierId} -> saveQueueRef st notifierId rId notifiers_ pure $ Right q where - dir = msgQueueDirectory st rId - queuePath = queueRecPath dir $ B.unpack (strEncode rId) - storeQueue _ _ = pure () -- TODO - saveQueueRef _ _ = pure () -- TODO - hasAnyId = foldM (fmap . (||)) False [hasId rId queues_, hasId sId senders_, withNotifier (`hasId` notifiers_), hasDir rId, hasDir sId, withNotifier hasDir] + hasAnyId = anyM [hasId rId queues_, hasId sId senders_, withNotifier (`hasId` notifiers_), hasDir rId, hasDir sId, withNotifier hasDir] withNotifier p = maybe (pure False) (\NtfCreds {notifierId} -> p notifierId) notifier withNotifierLock a = maybe a (\NtfCreds {notifierId} -> withLockMap ls notifierId "addQueueN" a) notifier hasId :: EntityId -> TMap EntityId (Maybe a) -> IO Bool @@ -393,36 +398,58 @@ instance MsgStoreClass (JournalMsgStore s) where getQueue :: DirectParty p => JournalMsgStore s -> SParty p -> QueueId -> IO (Either ErrorType (JournalQueue s)) getQueue st party qId = case queueStore st of MQStore {} -> getQueue' st party qId - JQStore {queues_, senders_, notifiers_} -> maybe (Left AUTH) Right <$> case party of - SRecipient -> getQueue_ qId - SSender -> getQueueRef senders_ $>>= getQueue_ - SNotifier -> getQueueRef notifiers_ $>>= getQueue_ + JQStore {queues_, senders_, notifiers_} -> + isolateQueueId "getQueue" st qId $ + maybe (Left AUTH) Right <$> case party of + SRecipient -> getQueue_ qId + SSender -> getQueueRef senders_ $>>= getQueue_ + SNotifier -> getQueueRef notifiers_ $>>= getQueue_ where getQueue_ rId = TM.lookupIO rId queues_ >>= maybe (loadQueue rId) pure getQueueRef :: TMap EntityId (Maybe RecipientId) -> IO (Maybe RecipientId) getQueueRef m = TM.lookupIO qId m >>= maybe (loadQueueRef m) pure - loadQueue _rId = undefined -- TODO load, cache, return queue - loadQueueRef _m = undefined -- TODO load, cache, return queue ID - - getQueueRec :: DirectParty p => JournalMsgStore s -> SParty p -> QueueId -> IO (Either ErrorType (JournalQueue s, QueueRec)) - getQueueRec st party qId = case queueStore st of - MQStore {} -> getQueueRec' st party qId - JQStore {} -> undefined + loadQueue _rId = undefined -- TODO [queues] load, cache, return queue + loadQueueRef _m = undefined -- TODO [queues] load, cache, return queue ID secureQueue :: JournalMsgStore s -> JournalQueue s -> SndPublicAuthKey -> IO (Either ErrorType ()) secureQueue st sq sKey = case queueStore st of MQStore {} -> secureQueue' st sq sKey - JQStore {} -> undefined + JQStore {} -> + isolateQueueRec sq "secureQueue" $ \q -> case senderKey q of + Just k -> pure $ if sKey == k then Right () else Left AUTH + Nothing -> storeQueue sq q {senderKey = Just sKey} $> Right () addQueueNotifier :: JournalMsgStore s -> JournalQueue s -> NtfCreds -> IO (Either ErrorType (Maybe NotifierId)) - addQueueNotifier st sq ntfCreds = case queueStore st of + addQueueNotifier st sq ntfCreds@NtfCreds {notifierId = nId} = case queueStore st of MQStore {} -> addQueueNotifier' st sq ntfCreds - JQStore {} -> undefined + JQStore {notifiers_} -> + isolateQueueRec sq "addQueueNotifier" $ \q@QueueRec {recipientId = rId} -> + withLockMap (queueLocks st) nId "addQueueNotifierN" $ + ifM hasNotifierId (pure $ Left DUPLICATE_) $ do + nId_ <- forM (notifier q) $ \NtfCreds {notifierId = nId'} -> + withLockMap (queueLocks st) nId' "addQueueNotifierD" $ do + deleteQueueRef st nId' + atomically $ TM.delete nId' notifiers_ + pure nId' + storeQueue sq q {notifier = Just ntfCreds} + saveQueueRef st nId rId notifiers_ + pure $ Right nId_ + where + hasNotifierId = anyM [hasId, hasDir] + hasId = maybe False isJust <$> atomically (TM.lookup nId notifiers_) + hasDir = doesDirectoryExist $ msgQueueDirectory st nId deleteQueueNotifier :: JournalMsgStore s -> JournalQueue s -> IO (Either ErrorType (Maybe NotifierId)) deleteQueueNotifier st sq = case queueStore st of MQStore {} -> deleteQueueNotifier' st sq - JQStore {} -> undefined + JQStore {notifiers_} -> + isolateQueueRec sq "deleteQueueNotifier" $ \q -> + fmap Right $ forM (notifier q) $ \NtfCreds {notifierId = nId} -> + withLockMap (queueLocks st) nId "deleteQueueNotifierN" $ do + deleteQueueRef st nId + atomically $ TM.delete nId notifiers_ + storeQueue sq q {notifier = Nothing} + pure nId suspendQueue :: JournalMsgStore s -> JournalQueue s -> IO (Either ErrorType ()) suspendQueue st sq = case queueStore st of @@ -434,29 +461,26 @@ instance MsgStoreClass (JournalMsgStore s) where MQStore {} -> updateQueueTime' st sq t JQStore {} -> undefined - getMsgQueue :: JournalMsgStore s -> RecipientId -> JournalQueue s -> StoreIO s (JournalMsgQueue s) - getMsgQueue ms@JournalMsgStore {random} rId JournalQueue {msgQueue_} = + getMsgQueue :: JournalMsgStore s -> JournalQueue s -> StoreIO s (JournalMsgQueue s) + getMsgQueue ms@JournalMsgStore {random} sq@JournalQueue {msgQueue_, queueDirectory} = 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} - -- TODO this should account for the possibility that the folder exists, + -- TODO [queues] this should account for the possibility that the folder exists, -- but queue files do not - q <- ifM (doesDirectoryExist dir) (openMsgQueue ms queue) (createQ queue) + q <- ifM (doesDirectoryExist queueDirectory) (openMsgQueue ms sq) createQ atomically $ writeTVar msgQueue_ $ Just q pure q where - createQ :: JMQueue -> IO (JournalMsgQueue s) - createQ queue = do + createQ :: IO (JournalMsgQueue s) + createQ = 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 + mkJournalQueue (newMsgQueueState journalId) Nothing - getPeekMsgQueue :: JournalMsgStore s -> RecipientId -> JournalQueue s -> StoreIO s (Maybe (JournalMsgQueue s, Message)) - getPeekMsgQueue ms rId q@JournalQueue {isEmpty} = + getPeekMsgQueue :: JournalMsgStore s -> JournalQueue s -> StoreIO s (Maybe (JournalMsgQueue s, Message)) + getPeekMsgQueue ms q@JournalQueue {isEmpty} = StoreIO (readTVarIO isEmpty) >>= \case Just True -> pure Nothing Just False -> peek @@ -471,16 +495,16 @@ instance MsgStoreClass (JournalMsgStore s) where pure r where peek = do - mq <- getMsgQueue ms rId q + mq <- getMsgQueue ms q (mq,) <$$> tryPeekMsg_ q mq -- only runs action if queue is not empty - withIdleMsgQueue :: Int64 -> JournalMsgStore s -> RecipientId -> JournalQueue s -> (JournalMsgQueue s -> StoreIO s a) -> StoreIO s (Maybe a, Int) - withIdleMsgQueue now ms@JournalMsgStore {config} rId q action = + withIdleMsgQueue :: Int64 -> JournalMsgStore s -> JournalQueue s -> (JournalMsgQueue s -> StoreIO s a) -> StoreIO s (Maybe a, Int) + withIdleMsgQueue now ms@JournalMsgStore {config} q action = StoreIO $ readTVarIO (msgQueue_ q) >>= \case Nothing -> E.bracket - (unStoreIO $ getPeekMsgQueue ms rId q) + (unStoreIO $ getPeekMsgQueue ms q) (mapM_ $ \_ -> closeMsgQueue q) (maybe (pure (Nothing, 0)) (unStoreIO . run)) where @@ -507,20 +531,20 @@ instance MsgStoreClass (JournalMsgStore s) where where getSize = maybe (pure (-1)) (fmap size . readTVarIO . state) - getQueueMessages_ :: Bool -> JournalMsgQueue s -> StoreIO s [Message] - getQueueMessages_ drainMsgs q = StoreIO (run []) + getQueueMessages_ :: Bool -> JournalQueue s -> JournalMsgQueue s -> StoreIO s [Message] + getQueueMessages_ drainMsgs sq q = StoreIO (run []) where run msgs = readTVarIO (handles q) >>= maybe (pure []) (getMsg msgs) - getMsg msgs hs = chooseReadJournal q drainMsgs hs >>= maybe (pure msgs) readMsg + getMsg msgs hs = chooseReadJournal sq q drainMsgs hs >>= maybe (pure msgs) readMsg where readMsg (rs, h) = do (msg, len) <- hGetMsgAt h $ bytePos rs updateReadPos q drainMsgs len hs (msg :) <$> run msgs - writeMsg :: JournalMsgStore s -> RecipientId -> JournalQueue s -> Bool -> Message -> ExceptT ErrorType IO (Maybe (Message, Bool)) - writeMsg ms rId q' logState msg = isolateQueue rId q' "writeMsg" $ do - q <- getMsgQueue ms rId q' + writeMsg :: JournalMsgStore s -> JournalQueue s -> Bool -> Message -> ExceptT ErrorType IO (Maybe (Message, Bool)) + writeMsg ms q'@JournalQueue {queueDirectory, statePath} logState msg = isolateQueue q' "writeMsg" $ do + q <- getMsgQueue ms q' StoreIO $ (`E.finally` updateActiveAt q') $ do st@MsgQueueState {canWrite, size} <- readTVarIO (state q) let empty = size == 0 @@ -535,7 +559,7 @@ instance MsgStoreClass (JournalMsgStore s) where where JournalStoreConfig {quota, maxMsgCount} = config ms msgQuota = MessageQuota {msgId = messageId msg, msgTs = messageTs msg} - writeToJournal q st@MsgQueueState {writeState, readState = rs, size} canWrt' !msg' = do + writeToJournal q@JournalMsgQueue {handles} st@MsgQueueState {writeState, readState = rs, size} canWrt' !msg' = do let msgStr = strEncode msg' `B.snoc` '\n' msgLen = fromIntegral $ B.length msgStr hs <- maybe createQueueDir pure =<< readTVarIO handles @@ -551,7 +575,6 @@ instance MsgStoreClass (JournalMsgStore s) where updateQueueState q logState hs st' $ when (size == 0) $ writeTVar (tipMsg q) $ Just (Just (msg, msgLen)) where - JournalMsgQueue {queue = JMQueue {queueDirectory, statePath}, handles} = q createQueueDir = do createDirectoryIfMissing True queueDirectory sh <- openFile statePath AppendMode @@ -574,10 +597,11 @@ instance MsgStoreClass (JournalMsgStore s) where getQueueSize_ :: JournalMsgQueue s -> StoreIO s Int getQueueSize_ JournalMsgQueue {state} = StoreIO $ size <$> readTVarIO state + {-# INLINE getQueueSize_ #-} tryPeekMsg_ :: JournalQueue s -> JournalMsgQueue s -> StoreIO s (Maybe Message) tryPeekMsg_ q mq@JournalMsgQueue {tipMsg, handles} = - StoreIO $ (readTVarIO handles $>>= chooseReadJournal mq True $>>= peekMsg) >>= setEmpty + StoreIO $ (readTVarIO handles $>>= chooseReadJournal q mq True $>>= peekMsg) >>= setEmpty where peekMsg (rs, h) = readTVarIO tipMsg >>= maybe readMsg (pure . fmap fst) where @@ -597,16 +621,13 @@ instance MsgStoreClass (JournalMsgStore s) where $>>= \len -> readTVarIO handles $>>= \hs -> updateReadPos mq logState len hs $> Just () - isolateQueue :: RecipientId -> JournalQueue s -> String -> StoreIO s a -> ExceptT ErrorType IO a - isolateQueue rId JournalQueue {queueLock} op = - tryStore' op rId . withLock' queueLock op . unStoreIO + isolateQueue :: JournalQueue s -> String -> StoreIO s a -> ExceptT ErrorType IO a + isolateQueue q op = ExceptT . isolateQueue_ q op . fmap Right . unStoreIO + {-# INLINE isolateQueue #-} updateActiveAt :: JournalQueue s -> IO () updateActiveAt q = atomically . writeTVar (activeAt q) . systemSeconds =<< getSystemTime -tryStore' :: String -> RecipientId -> IO a -> ExceptT ErrorType IO a -tryStore' op rId = ExceptT . tryStore op rId . fmap Right - tryStore :: forall a. String -> RecipientId -> IO (Either ErrorType a) -> IO (Either ErrorType a) tryStore op rId a = E.mask_ $ E.try a >>= either storeErr pure where @@ -615,34 +636,61 @@ tryStore op rId a = 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 s -> RecipientId -> IO (Either ErrorType a) -> ExceptT ErrorType IO a -isolateQueueId op ms rId = ExceptT . tryStore op rId . withLockMap (queueLocks ms) rId op +isolateQueueRec :: JournalQueue s -> String -> (QueueRec -> IO (Either ErrorType a)) -> IO (Either ErrorType a) +isolateQueueRec sq op a = isolateQueue_ sq op (atomically (readQueueRec qr) $>>= a) + where + qr = queueRec' sq + +isolateQueue_ :: JournalQueue s -> String -> IO (Either ErrorType a) -> IO (Either ErrorType a) +isolateQueue_ JournalQueue {recipientId, queueLock} op = tryStore op recipientId . withLock' queueLock op + +isolateQueueId :: String -> JournalMsgStore s -> RecipientId -> IO (Either ErrorType a) -> IO (Either ErrorType a) +isolateQueueId op ms rId = tryStore op rId . withLockMap (queueLocks ms) rId op + +storeQueue :: JournalQueue s -> QueueRec -> IO () +storeQueue sq@JournalQueue {queueRec} q = do + storeQueue_ sq q + atomically $ writeTVar queueRec $ Just q + +-- TODO [queues] +saveQueueRef :: JournalMsgStore s -> QueueId -> RecipientId -> TMap QueueId (Maybe RecipientId) -> IO () +saveQueueRef _st qId rId m = do + pure () -- save ref to disk + atomically $ TM.insert qId (Just rId) m + +-- TODO [queues] +deleteQueueRef :: JournalMsgStore s -> QueueId -> IO () +deleteQueueRef _st _qId = pure () + +-- TODO [queues] +storeQueue_ :: JournalQueue s -> QueueRec -> IO () +storeQueue_ JournalQueue {recipientId, queueDirectory} _q = pure () -- save queue to disk + where + _queuePath = queueRecPath queueDirectory $ B.unpack (strEncode recipientId) -openMsgQueue :: JournalMsgStore s -> JMQueue -> IO (JournalMsgQueue s) -openMsgQueue ms q@JMQueue {queueDirectory = dir, statePath} = do +openMsgQueue :: JournalMsgStore s -> JournalQueue s -> IO (JournalMsgQueue s) +openMsgQueue ms JournalQueue {queueDirectory = dir, statePath} = do (st, sh) <- readWriteQueueState ms statePath (st', rh, wh_) <- closeOnException sh $ openJournals ms dir st sh let hs = MsgQueueHandles {stateHandle = sh, readHandle = rh, writeHandle = wh_} - mkJournalQueue q st' (Just hs) + mkJournalQueue st' (Just hs) -mkJournalQueue :: JMQueue -> MsgQueueState -> Maybe MsgQueueHandles -> IO (JournalMsgQueue s) -mkJournalQueue queue st hs_ = do +mkJournalQueue :: MsgQueueState -> Maybe MsgQueueHandles -> IO (JournalMsgQueue s) +mkJournalQueue st hs_ = do state <- newTVarIO st tipMsg <- newTVarIO Nothing handles <- newTVarIO hs_ - -- using the same queue lock which is currently locked, - -- to avoid map lookup on queue operations - pure JournalMsgQueue {queue, state, tipMsg, handles} + pure JournalMsgQueue {state, tipMsg, handles} -chooseReadJournal :: JournalMsgQueue s -> Bool -> MsgQueueHandles -> IO (Maybe (JournalState 'JTRead, Handle)) -chooseReadJournal q log' hs = do +chooseReadJournal :: JournalQueue s -> JournalMsgQueue s -> Bool -> MsgQueueHandles -> IO (Maybe (JournalState 'JTRead, Handle)) +chooseReadJournal sq q log' hs = do st@MsgQueueState {writeState = ws, readState = rs} <- readTVarIO (state q) case writeHandle hs of Just wh | msgPos rs >= msgCount rs && journalId rs /= journalId ws -> do -- switching to write journal atomically $ writeTVar (handles q) $ Just hs {readHandle = wh, writeHandle = Nothing} hClose $ readHandle hs - when log' $ removeJournal (queueDirectory $ queue q) rs + when log' $ removeJournal (queueDirectory sq) rs let !rs' = (newJournalState $ journalId ws) {msgCount = msgCount ws, byteCount = byteCount ws} !st' = st {readState = rs'} updateQueueState q log' hs st' $ pure () @@ -686,7 +734,7 @@ msgQueueStatePath dir queueId = dir (queueLogFileName <> "." <> queueId <> l createNewJournal :: FilePath -> ByteString -> IO Handle createNewJournal dir journalId = do - let path = journalFilePath dir journalId -- TODO retry if file exists + let path = journalFilePath dir journalId -- TODO [queues] retry if file exists h <- openFile path ReadWriteMode B.hPutStr h "" pure h @@ -847,7 +895,7 @@ validQueueState MsgQueueState {readState = rs, writeState = ws, size} deleteQueue_ :: forall s. JournalMsgStore s -> RecipientId -> JournalQueue s -> IO (Either ErrorType (QueueRec, Maybe (JournalMsgQueue s))) deleteQueue_ ms rId q = - runExceptT $ isolateQueueId "deleteQueue_" ms rId $ case queueStore ms of + isolateQueueId "deleteQueue_" ms rId $ case queueStore ms of MQStore {} -> deleteQueue' ms rId q >>= mapM remove JQStore {} -> undefined where diff --git a/src/Simplex/Messaging/Server/MsgStore/STM.hs b/src/Simplex/Messaging/Server/MsgStore/STM.hs index 0dbe4bc30..9378edf9f 100644 --- a/src/Simplex/Messaging/Server/MsgStore/STM.hs +++ b/src/Simplex/Messaging/Server/MsgStore/STM.hs @@ -43,6 +43,7 @@ data STMMsgStore = STMMsgStore 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) } @@ -63,7 +64,8 @@ instance STMQueueStore STMMsgStore where senders' = senders notifiers' = notifiers storeLog' = storeLog - mkQueue _ qr = STMQueue <$> newTVarIO (Just qr) <*> newTVarIO Nothing + mkQueue _ qr@QueueRec {recipientId} = + STMQueue recipientId <$> newTVarIO (Just qr) <*> newTVarIO Nothing instance MsgStoreClass STMMsgStore where type StoreMonad STMMsgStore = STM @@ -94,6 +96,10 @@ instance MsgStoreClass STMMsgStore where logQueueState _ = pure () + -- TODO [queues] remove pun once recipientId is removed from QueueRec + recipientId' STMQueue {recipientId} = recipientId + {-# INLINE recipientId' #-} + queueRec' = queueRec {-# INLINE queueRec' #-} @@ -112,9 +118,6 @@ instance MsgStoreClass STMMsgStore where getQueue = getQueue' {-# INLINE getQueue #-} - getQueueRec = getQueueRec' - {-# INLINE getQueueRec #-} - secureQueue = secureQueue' {-# INLINE secureQueue #-} @@ -130,8 +133,8 @@ instance MsgStoreClass STMMsgStore where updateQueueTime = updateQueueTime' {-# INLINE updateQueueTime #-} - getMsgQueue :: STMMsgStore -> RecipientId -> STMQueue -> STM STMMsgQueue - getMsgQueue _ _ STMQueue {msgQueue_} = readTVar msgQueue_ >>= maybe newQ pure + getMsgQueue :: STMMsgStore -> STMQueue -> STM STMMsgQueue + getMsgQueue _ STMQueue {msgQueue_} = readTVar msgQueue_ >>= maybe newQ pure where newQ = do msgQueue <- newTQueue @@ -141,12 +144,12 @@ instance MsgStoreClass STMMsgStore where writeTVar msgQueue_ (Just q) pure q - getPeekMsgQueue :: STMMsgStore -> RecipientId -> STMQueue -> STM (Maybe (STMMsgQueue, Message)) - getPeekMsgQueue _ _ q@STMQueue {msgQueue_} = readTVar msgQueue_ $>>= \mq -> (mq,) <$$> tryPeekMsg_ q mq + getPeekMsgQueue :: STMMsgStore -> STMQueue -> STM (Maybe (STMMsgQueue, Message)) + 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 -> RecipientId -> STMQueue -> (STMMsgQueue -> STM a) -> STM (Maybe a, Int) - withIdleMsgQueue _ _ _ STMQueue {msgQueue_} action = readTVar msgQueue_ >>= \case + withIdleMsgQueue :: Int64 -> STMMsgStore -> STMQueue -> (STMMsgQueue -> STM a) -> STM (Maybe a, Int) + withIdleMsgQueue _ _ STMQueue {msgQueue_} action = readTVar msgQueue_ >>= \case Just q -> do r <- action q sz <- getQueueSize_ q @@ -162,17 +165,17 @@ instance MsgStoreClass STMMsgStore where where getSize = maybe (pure 0) (\STMMsgQueue {size} -> readTVarIO size) - getQueueMessages_ :: Bool -> STMMsgQueue -> STM [Message] - getQueueMessages_ drainMsgs = (if drainMsgs then flushTQueue else snapshotTQueue) . msgQueue + getQueueMessages_ :: Bool -> STMQueue -> STMMsgQueue -> STM [Message] + getQueueMessages_ drainMsgs _ = (if drainMsgs then flushTQueue else snapshotTQueue) . msgQueue where snapshotTQueue q = do msgs <- flushTQueue q mapM_ (writeTQueue q) msgs pure msgs - writeMsg :: STMMsgStore -> RecipientId -> STMQueue -> Bool -> Message -> ExceptT ErrorType IO (Maybe (Message, Bool)) - writeMsg ms rId q' _logState msg = liftIO $ atomically $ do - STMMsgQueue {msgQueue = q, canWrite, size} <- getMsgQueue ms rId q' + 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' canWrt <- readTVar canWrite empty <- isEmptyTQueue q if canWrt || empty @@ -193,6 +196,7 @@ instance MsgStoreClass STMMsgStore where getQueueSize_ :: STMMsgQueue -> STM Int getQueueSize_ STMMsgQueue {size} = readTVar size + {-# INLINE getQueueSize_ #-} tryPeekMsg_ :: STMQueue -> STMMsgQueue -> STM (Maybe Message) tryPeekMsg_ _ = tryPeekTQueue . msgQueue @@ -204,5 +208,6 @@ instance MsgStoreClass STMMsgStore where Just _ -> modifyTVar' size (subtract 1) _ -> pure () - isolateQueue :: RecipientId -> STMQueue -> String -> STM a -> ExceptT ErrorType IO a - isolateQueue _ _ _ = liftIO . atomically + isolateQueue :: STMQueue -> String -> STM a -> ExceptT ErrorType IO a + isolateQueue _ _ = liftIO . atomically + {-# INLINE isolateQueue #-} diff --git a/src/Simplex/Messaging/Server/MsgStore/Types.hs b/src/Simplex/Messaging/Server/MsgStore/Types.hs index f000f2d4f..22015da4b 100644 --- a/src/Simplex/Messaging/Server/MsgStore/Types.hs +++ b/src/Simplex/Messaging/Server/MsgStore/Types.hs @@ -20,13 +20,12 @@ import Control.Monad.Trans.Except import Data.Functor (($>)) import Data.Int (Int64) import Data.Kind -import qualified Data.Map.Strict as M 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 Simplex.Messaging.Util ((<$$>), ($>>=)) import System.IO (IOMode (..)) class MsgStoreClass s => STMQueueStore s where @@ -45,36 +44,36 @@ class Monad (StoreMonad s) => MsgStoreClass s where setStoreLog :: s -> StoreLog 'WriteMode -> IO () closeMsgStore :: s -> IO () activeMsgQueues :: s -> TMap RecipientId (StoreQueue s) - withAllMsgQueues :: Monoid a => Bool -> s -> (RecipientId -> 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) msgQueue_' :: StoreQueue s -> TVar (Maybe (MsgQueue s)) queueCounts :: s -> IO QueueCounts addQueue :: s -> QueueRec -> IO (Either ErrorType (StoreQueue s)) getQueue :: DirectParty p => s -> SParty p -> QueueId -> IO (Either ErrorType (StoreQueue s)) - getQueueRec :: DirectParty p => s -> SParty p -> QueueId -> IO (Either ErrorType (StoreQueue s, QueueRec)) secureQueue :: s -> StoreQueue s -> SndPublicAuthKey -> IO (Either ErrorType ()) addQueueNotifier :: s -> StoreQueue s -> NtfCreds -> IO (Either ErrorType (Maybe NotifierId)) deleteQueueNotifier :: s -> StoreQueue s -> IO (Either ErrorType (Maybe NotifierId)) suspendQueue :: s -> StoreQueue s -> IO (Either ErrorType ()) updateQueueTime :: s -> StoreQueue s -> RoundedSystemTime -> IO (Either ErrorType QueueRec) - getPeekMsgQueue :: s -> RecipientId -> StoreQueue s -> StoreMonad s (Maybe (MsgQueue s, Message)) - getMsgQueue :: s -> RecipientId -> StoreQueue s -> StoreMonad s (MsgQueue s) + getPeekMsgQueue :: s -> StoreQueue s -> StoreMonad s (Maybe (MsgQueue s, Message)) + getMsgQueue :: s -> StoreQueue s -> StoreMonad s (MsgQueue s) -- the journal queue will be closed after action if it was initially closed or idle longer than interval in config - withIdleMsgQueue :: Int64 -> s -> RecipientId -> StoreQueue s -> (MsgQueue s -> StoreMonad s a) -> StoreMonad s (Maybe a, Int) + withIdleMsgQueue :: Int64 -> s -> StoreQueue s -> (MsgQueue s -> StoreMonad s a) -> StoreMonad s (Maybe a, Int) deleteQueue :: s -> RecipientId -> StoreQueue s -> IO (Either ErrorType QueueRec) deleteQueueSize :: s -> RecipientId -> StoreQueue s -> IO (Either ErrorType (QueueRec, Int)) - getQueueMessages_ :: Bool -> MsgQueue s -> StoreMonad s [Message] - writeMsg :: s -> RecipientId -> StoreQueue s -> Bool -> Message -> ExceptT ErrorType IO (Maybe (Message, Bool)) + getQueueMessages_ :: Bool -> StoreQueue s -> MsgQueue 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 () - isolateQueue :: RecipientId -> StoreQueue s -> String -> StoreMonad s a -> ExceptT ErrorType IO a + isolateQueue :: StoreQueue s -> String -> StoreMonad s a -> ExceptT ErrorType IO a data QueueCounts = QueueCounts { queueCount :: Int, @@ -89,28 +88,33 @@ data SMSType :: MSType -> Type where data AMSType = forall s. AMSType (SMSType s) -withActiveMsgQueues :: (MsgStoreClass s, Monoid a) => s -> (RecipientId -> StoreQueue s -> IO a) -> IO a -withActiveMsgQueues st f = readTVarIO (activeMsgQueues st) >>= foldM run mempty . M.assocs +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)) + +withActiveMsgQueues :: (MsgStoreClass s, Monoid a) => s -> (StoreQueue s -> IO a) -> IO a +withActiveMsgQueues st f = readTVarIO (activeMsgQueues st) >>= foldM run mempty where - run !acc (k, v) = do - r <- f k v + run !acc q = do + r <- f q pure $! acc <> r -getQueueMessages :: MsgStoreClass s => Bool -> s -> RecipientId -> StoreQueue s -> ExceptT ErrorType IO [Message] -getQueueMessages drainMsgs st rId q = withPeekMsgQueue st rId q "getQueueSize" $ maybe (pure []) (getQueueMessages_ drainMsgs . fst) +getQueueMessages :: MsgStoreClass s => Bool -> s -> StoreQueue s -> ExceptT ErrorType IO [Message] +getQueueMessages drainMsgs st q = withPeekMsgQueue st q "getQueueSize" $ maybe (pure []) (getQueueMessages_ drainMsgs q . fst) {-# INLINE getQueueMessages #-} -getQueueSize :: MsgStoreClass s => s -> RecipientId -> StoreQueue s -> ExceptT ErrorType IO Int -getQueueSize st rId q = withPeekMsgQueue st rId q "getQueueSize" $ maybe (pure 0) (getQueueSize_ . fst) +getQueueSize :: MsgStoreClass s => s -> StoreQueue s -> ExceptT ErrorType IO Int +getQueueSize st q = withPeekMsgQueue st q "getQueueSize" $ maybe (pure 0) (getQueueSize_ . fst) {-# INLINE getQueueSize #-} -tryPeekMsg :: MsgStoreClass s => s -> RecipientId -> StoreQueue s -> ExceptT ErrorType IO (Maybe Message) -tryPeekMsg st rId q = snd <$$> withPeekMsgQueue st rId q "tryPeekMsg" pure +tryPeekMsg :: MsgStoreClass s => s -> StoreQueue s -> ExceptT ErrorType IO (Maybe Message) +tryPeekMsg st q = snd <$$> withPeekMsgQueue st q "tryPeekMsg" pure {-# INLINE tryPeekMsg #-} -tryDelMsg :: MsgStoreClass s => s -> RecipientId -> StoreQueue s -> MsgId -> ExceptT ErrorType IO (Maybe Message) -tryDelMsg st rId q msgId' = - withPeekMsgQueue st rId q "tryDelMsg" $ +tryDelMsg :: MsgStoreClass s => s -> StoreQueue s -> MsgId -> ExceptT ErrorType IO (Maybe Message) +tryDelMsg st q msgId' = + withPeekMsgQueue st q "tryDelMsg" $ maybe (pure Nothing) $ \(mq, msg) -> if | messageId msg == msgId' -> @@ -118,30 +122,30 @@ tryDelMsg st rId q msgId' = | otherwise -> pure Nothing -- atomic delete (== read) last and peek next message if available -tryDelPeekMsg :: MsgStoreClass s => s -> RecipientId -> StoreQueue s -> MsgId -> ExceptT ErrorType IO (Maybe Message, Maybe Message) -tryDelPeekMsg st rId q msgId' = - withPeekMsgQueue st rId q "tryDelPeekMsg" $ +tryDelPeekMsg :: MsgStoreClass s => s -> StoreQueue s -> MsgId -> ExceptT ErrorType IO (Maybe Message, Maybe Message) +tryDelPeekMsg st q msgId' = + withPeekMsgQueue st q "tryDelPeekMsg" $ maybe (pure (Nothing, Nothing)) $ \(mq, msg) -> if | messageId msg == msgId' -> (Just msg,) <$> (tryDeleteMsg_ q mq True >> tryPeekMsg_ q mq) | otherwise -> pure (Nothing, Just msg) -- The action is called with Nothing when it is known that the queue is empty -withPeekMsgQueue :: MsgStoreClass s => s -> RecipientId -> StoreQueue s -> String -> (Maybe (MsgQueue s, Message) -> StoreMonad s a) -> ExceptT ErrorType IO a -withPeekMsgQueue st rId q op a = isolateQueue rId q op $ getPeekMsgQueue st rId q >>= a +withPeekMsgQueue :: MsgStoreClass s => s -> StoreQueue s -> String -> (Maybe (MsgQueue s, Message) -> StoreMonad s a) -> ExceptT ErrorType IO a +withPeekMsgQueue st q op a = isolateQueue q op $ getPeekMsgQueue st q >>= a {-# INLINE withPeekMsgQueue #-} -deleteExpiredMsgs :: MsgStoreClass s => s -> RecipientId -> StoreQueue s -> Int64 -> ExceptT ErrorType IO Int -deleteExpiredMsgs st rId q old = - isolateQueue rId q "deleteExpiredMsgs" $ - getMsgQueue st rId q >>= deleteExpireMsgs_ old q +deleteExpiredMsgs :: MsgStoreClass s => s -> StoreQueue s -> Int64 -> ExceptT ErrorType IO Int +deleteExpiredMsgs st q old = + isolateQueue q "deleteExpiredMsgs" $ + getMsgQueue st q >>= deleteExpireMsgs_ old q -- closed and idle queues will be closed after expiration -- returns (expired count, queue size after expiration) -idleDeleteExpiredMsgs :: MsgStoreClass s => Int64 -> s -> RecipientId -> StoreQueue s -> Int64 -> ExceptT ErrorType IO (Maybe Int, Int) -idleDeleteExpiredMsgs now st rId q old = - isolateQueue rId q "idleDeleteExpiredMsgs" $ - withIdleMsgQueue now st rId q (deleteExpireMsgs_ old q) +idleDeleteExpiredMsgs :: MsgStoreClass s => Int64 -> s -> StoreQueue s -> Int64 -> ExceptT ErrorType IO (Maybe Int, Int) +idleDeleteExpiredMsgs now st q old = + isolateQueue q "idleDeleteExpiredMsgs" $ + withIdleMsgQueue now st q (deleteExpireMsgs_ old q) deleteExpireMsgs_ :: MsgStoreClass s => Int64 -> StoreQueue s -> MsgQueue s -> StoreMonad s Int deleteExpireMsgs_ old q mq = do diff --git a/src/Simplex/Messaging/Server/QueueStore/STM.hs b/src/Simplex/Messaging/Server/QueueStore/STM.hs index d058b2e0f..ca2b70319 100644 --- a/src/Simplex/Messaging/Server/QueueStore/STM.hs +++ b/src/Simplex/Messaging/Server/QueueStore/STM.hs @@ -16,7 +16,6 @@ module Simplex.Messaging.Server.QueueStore.STM ( addQueue', getQueue', - getQueueRec', secureQueue', addQueueNotifier', deleteQueueNotifier', @@ -24,6 +23,7 @@ module Simplex.Messaging.Server.QueueStore.STM updateQueueTime', deleteQueue', readQueueStore, + readQueueRec, withLog', ) where @@ -39,7 +39,7 @@ import Simplex.Messaging.Server.MsgStore.Types import Simplex.Messaging.Server.QueueStore import Simplex.Messaging.Server.StoreLog import qualified Simplex.Messaging.TMap as TM -import Simplex.Messaging.Util (ifM, ($>>=), (<$$)) +import Simplex.Messaging.Util (anyM, ifM, ($>>=), (<$$)) import System.IO import UnliftIO.STM @@ -53,7 +53,7 @@ addQueue' st qr@QueueRec {recipientId = rId, senderId = sId, notifier} = TM.insert sId rId $ senders' st forM_ notifier $ \NtfCreds {notifierId} -> TM.insert notifierId rId $ notifiers' st pure $ Right q - hasId = foldM (fmap . (||)) False [TM.member rId $ queues' st, TM.member sId $ senders' st, hasNotifier] + hasId = anyM [TM.member rId $ queues' st, TM.member sId $ senders' st, hasNotifier] hasNotifier = maybe (pure False) (\NtfCreds {notifierId} -> TM.member notifierId (notifiers' st)) notifier getQueue' :: (STMQueueStore s, DirectParty p) => s -> SParty p -> QueueId -> IO (Either ErrorType (StoreQueue s)) @@ -63,11 +63,6 @@ getQueue' st party qId = SSender -> TM.lookupIO qId (senders' st) $>>= (`TM.lookupIO` queues' st) SNotifier -> TM.lookupIO qId (notifiers' st) $>>= (`TM.lookupIO` queues' st) -getQueueRec' :: (STMQueueStore 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)) - secureQueue' :: STMQueueStore s => s -> StoreQueue s -> SndPublicAuthKey -> IO (Either ErrorType ()) secureQueue' st sq sKey = atomically (readQueueRec qr $>>= secure) diff --git a/src/Simplex/Messaging/Util.hs b/src/Simplex/Messaging/Util.hs index b467c5ea9..4a33695e2 100644 --- a/src/Simplex/Messaging/Util.hs +++ b/src/Simplex/Messaging/Util.hs @@ -85,6 +85,10 @@ unlessM :: Monad m => m Bool -> m () -> m () unlessM b = ifM b $ pure () {-# INLINE unlessM #-} +anyM :: Monad m => [m Bool] -> m Bool +anyM = foldM (\r a -> if r then pure r else (r ||) <$!> a) False +{-# INLINE anyM #-} + ($>>=) :: (Monad m, Monad f, Traversable f) => m (f a) -> (a -> m (f b)) -> m (f b) f $>>= g = f >>= fmap join . mapM g diff --git a/tests/CoreTests/MsgStoreTests.hs b/tests/CoreTests/MsgStoreTests.hs index bca1cc872..c1fc2a708 100644 --- a/tests/CoreTests/MsgStoreTests.hs +++ b/tests/CoreTests/MsgStoreTests.hs @@ -123,40 +123,40 @@ testGetQueue ms = do (rId, qr) <- testNewQueueRec g True runRight_ $ do q <- ExceptT $ addQueue ms qr - let write s = writeMsg ms rId q True =<< mkMessage s + let write s = writeMsg ms q True =<< mkMessage s Just (Message {msgId = mId1}, True) <- write "message 1" Just (Message {msgId = mId2}, False) <- write "message 2" Just (Message {msgId = mId3}, False) <- write "message 3" - Msg "message 1" <- tryPeekMsg ms rId q - Msg "message 1" <- tryPeekMsg ms rId q - Nothing <- tryDelMsg ms rId q mId2 - Msg "message 1" <- tryDelMsg ms rId q mId1 - Nothing <- tryDelMsg ms rId q mId1 - Msg "message 2" <- tryPeekMsg ms rId q - Nothing <- tryDelMsg ms rId q mId1 - (Nothing, Msg "message 2") <- tryDelPeekMsg ms rId q mId1 - (Msg "message 2", Msg "message 3") <- tryDelPeekMsg ms rId q mId2 - (Nothing, Msg "message 3") <- tryDelPeekMsg ms rId q mId2 - Msg "message 3" <- tryPeekMsg ms rId q - (Msg "message 3", Nothing) <- tryDelPeekMsg ms rId q mId3 - Nothing <- tryDelMsg ms rId q mId2 - Nothing <- tryDelMsg ms rId q mId3 - Nothing <- tryPeekMsg ms rId q + Msg "message 1" <- tryPeekMsg ms q + Msg "message 1" <- tryPeekMsg ms q + Nothing <- tryDelMsg ms q mId2 + Msg "message 1" <- tryDelMsg ms q mId1 + Nothing <- tryDelMsg ms q mId1 + Msg "message 2" <- tryPeekMsg ms q + Nothing <- tryDelMsg ms q mId1 + (Nothing, Msg "message 2") <- tryDelPeekMsg ms q mId1 + (Msg "message 2", Msg "message 3") <- tryDelPeekMsg ms q mId2 + (Nothing, Msg "message 3") <- tryDelPeekMsg ms q mId2 + Msg "message 3" <- tryPeekMsg ms q + (Msg "message 3", Nothing) <- tryDelPeekMsg ms q mId3 + Nothing <- tryDelMsg ms q mId2 + Nothing <- tryDelMsg ms q mId3 + Nothing <- tryPeekMsg ms q Just (Message {msgId = mId4}, True) <- write "message 4" - Msg "message 4" <- tryPeekMsg ms rId q + Msg "message 4" <- tryPeekMsg ms q Just (Message {msgId = mId5}, False) <- write "message 5" - (Nothing, Msg "message 4") <- tryDelPeekMsg ms rId q mId3 - (Msg "message 4", Msg "message 5") <- tryDelPeekMsg ms rId q mId4 + (Nothing, Msg "message 4") <- tryDelPeekMsg ms q mId3 + (Msg "message 4", Msg "message 5") <- tryDelPeekMsg ms q mId4 Just (Message {msgId = mId6}, False) <- write "message 6" Just (Message {msgId = mId7}, False) <- write "message 7" Nothing <- write "message 8" - Msg "message 5" <- tryPeekMsg ms rId q - (Nothing, Msg "message 5") <- tryDelPeekMsg ms rId q mId4 - (Msg "message 5", Msg "message 6") <- tryDelPeekMsg ms rId q mId5 - (Msg "message 6", Msg "message 7") <- tryDelPeekMsg ms rId q mId6 - (Msg "message 7", Just MessageQuota {msgId = mId8}) <- tryDelPeekMsg ms rId q mId7 - (Just MessageQuota {}, Nothing) <- tryDelPeekMsg ms rId q mId8 - (Nothing, Nothing) <- tryDelPeekMsg ms rId q mId8 + Msg "message 5" <- tryPeekMsg ms q + (Nothing, Msg "message 5") <- tryDelPeekMsg ms q mId4 + (Msg "message 5", Msg "message 6") <- tryDelPeekMsg ms q mId5 + (Msg "message 6", Msg "message 7") <- tryDelPeekMsg ms q mId6 + (Msg "message 7", Just MessageQuota {msgId = mId8}) <- tryDelPeekMsg ms q mId7 + (Just MessageQuota {}, Nothing) <- tryDelPeekMsg ms q mId8 + (Nothing, Nothing) <- tryDelPeekMsg ms q mId8 void $ ExceptT $ deleteQueue ms rId q testChangeReadJournal :: STMQueueStore s => s -> IO () @@ -165,17 +165,17 @@ testChangeReadJournal ms = do (rId, qr) <- testNewQueueRec g True runRight_ $ do q <- ExceptT $ addQueue ms qr - let write s = writeMsg ms rId q True =<< mkMessage s + let write s = writeMsg ms q True =<< mkMessage s Just (Message {msgId = mId1}, True) <- write "message 1" - (Msg "message 1", Nothing) <- tryDelPeekMsg ms rId q mId1 + (Msg "message 1", Nothing) <- tryDelPeekMsg ms q mId1 Just (Message {msgId = mId2}, True) <- write "message 2" - (Msg "message 2", Nothing) <- tryDelPeekMsg ms rId q mId2 + (Msg "message 2", Nothing) <- tryDelPeekMsg ms q mId2 Just (Message {msgId = mId3}, True) <- write "message 3" - (Msg "message 3", Nothing) <- tryDelPeekMsg ms rId q mId3 + (Msg "message 3", Nothing) <- tryDelPeekMsg ms q mId3 Just (Message {msgId = mId4}, True) <- write "message 4" - (Msg "message 4", Nothing) <- tryDelPeekMsg ms rId q mId4 + (Msg "message 4", Nothing) <- tryDelPeekMsg ms q mId4 Just (Message {msgId = mId5}, True) <- write "message 5" - (Msg "message 5", Nothing) <- tryDelPeekMsg ms rId q mId5 + (Msg "message 5", Nothing) <- tryDelPeekMsg ms q mId5 void $ ExceptT $ deleteQueue ms rId q testExportImportStore :: JournalMsgStore s -> IO () @@ -185,21 +185,21 @@ testExportImportStore ms = do (rId2, qr2) <- testNewQueueRec g True sl <- readWriteQueueStore testStoreLogFile ms runRight_ $ do - let write rId q s = writeMsg ms rId q True =<< mkMessage s + let write q s = writeMsg ms q True =<< mkMessage s q1 <- ExceptT $ addQueue ms qr1 liftIO $ logCreateQueue sl qr1 - Just (Message {}, True) <- write rId1 q1 "message 1" - Just (Message {}, False) <- write rId1 q1 "message 2" + Just (Message {}, True) <- write q1 "message 1" + Just (Message {}, False) <- write q1 "message 2" q2 <- ExceptT $ addQueue ms qr2 liftIO $ logCreateQueue sl qr2 - Just (Message {msgId = mId3}, True) <- write rId2 q2 "message 3" - Just (Message {msgId = mId4}, False) <- write rId2 q2 "message 4" - (Msg "message 3", Msg "message 4") <- tryDelPeekMsg ms rId2 q2 mId3 - (Msg "message 4", Nothing) <- tryDelPeekMsg ms rId2 q2 mId4 - Just (Message {}, True) <- write rId2 q2 "message 5" - Just (Message {}, False) <- write rId2 q2 "message 6" - Just (Message {}, False) <- write rId2 q2 "message 7" - Nothing <- write rId2 q2 "message 8" + Just (Message {msgId = mId3}, True) <- write q2 "message 3" + Just (Message {msgId = mId4}, False) <- write q2 "message 4" + (Msg "message 3", Msg "message 4") <- tryDelPeekMsg ms q2 mId3 + (Msg "message 4", Nothing) <- tryDelPeekMsg ms q2 mId4 + Just (Message {}, True) <- write q2 "message 5" + Just (Message {}, False) <- write q2 "message 6" + Just (Message {}, False) <- write q2 "message 7" + Nothing <- write q2 "message 8" pure () length <$> listDirectory (msgQueueDirectory ms rId1) `shouldReturn` 2 length <$> listDirectory (msgQueueDirectory ms rId2) `shouldReturn` 3 @@ -297,7 +297,7 @@ testMessageState ms = do (rId, qr) <- testNewQueueRec g True let dir = msgQueueDirectory ms rId statePath = msgQueueStatePath dir $ B.unpack (B64.encode $ unEntityId rId) - write q s = writeMsg ms rId q True =<< mkMessage s + write q s = writeMsg ms q True =<< mkMessage s mId1 <- runRight $ do q <- ExceptT $ addQueue ms qr @@ -312,103 +312,103 @@ testMessageState ms = do runRight_ $ do q <- ExceptT $ getQueue ms SRecipient rId Just (Message {msgId = mId3}, False) <- write q "message 3" - (Msg "message 1", Msg "message 3") <- tryDelPeekMsg ms rId q mId1 - (Msg "message 3", Nothing) <- tryDelPeekMsg ms rId q mId3 + (Msg "message 1", Msg "message 3") <- tryDelPeekMsg ms q mId1 + (Msg "message 3", Nothing) <- tryDelPeekMsg ms q mId3 liftIO $ closeMsgQueue q testReadFileMissing :: JournalMsgStore s -> IO () testReadFileMissing ms = do g <- C.newRandom (rId, qr) <- testNewQueueRec g True - let write q s = writeMsg ms rId q True =<< mkMessage s + let write q s = writeMsg ms q True =<< mkMessage s q <- runRight $ do q <- ExceptT $ addQueue ms qr Just (Message {}, True) <- write q "message 1" - Msg "message 1" <- tryPeekMsg ms rId q + Msg "message 1" <- tryPeekMsg ms q pure q mq <- fromJust <$> readTVarIO (msgQueue_' q) MsgQueueState {readState = rs} <- readTVarIO $ state mq closeMsgStore ms - let path = journalFilePath (queueDirectory $ queue mq) $ journalId rs + let path = journalFilePath (queueDirectory q) $ journalId rs removeFile path runRight_ $ do q' <- ExceptT $ getQueue ms SRecipient rId - Nothing <- tryPeekMsg ms rId q' + Nothing <- tryPeekMsg ms q' Just (Message {}, True) <- write q' "message 2" - Msg "message 2" <- tryPeekMsg ms rId q' + Msg "message 2" <- tryPeekMsg ms q' pure () testReadFileMissingSwitch :: JournalMsgStore s -> IO () testReadFileMissingSwitch ms = do g <- C.newRandom (rId, qr) <- testNewQueueRec g True - q <- writeMessages ms rId qr + q <- writeMessages ms qr mq <- fromJust <$> readTVarIO (msgQueue_' q) MsgQueueState {readState = rs} <- readTVarIO $ state mq closeMsgStore ms - let path = journalFilePath (queueDirectory $ queue mq) $ journalId rs + let path = journalFilePath (queueDirectory q) $ journalId rs removeFile path runRight_ $ do q' <- ExceptT $ getQueue ms SRecipient rId - Just (Message {}, False) <- writeMsg ms rId q' True =<< mkMessage "message 6" - Msg "message 5" <- tryPeekMsg ms rId q' + Just (Message {}, False) <- writeMsg ms q' True =<< mkMessage "message 6" + Msg "message 5" <- tryPeekMsg ms q' pure () testWriteFileMissing :: JournalMsgStore s -> IO () testWriteFileMissing ms = do g <- C.newRandom (rId, qr) <- testNewQueueRec g True - q <- writeMessages ms rId qr + q <- writeMessages ms qr mq <- fromJust <$> readTVarIO (msgQueue_' q) MsgQueueState {writeState = ws} <- readTVarIO $ state mq closeMsgStore ms - let path = journalFilePath (queueDirectory $ queue mq) $ journalId ws + let path = journalFilePath (queueDirectory q) $ journalId ws print path removeFile path runRight_ $ do q' <- ExceptT $ getQueue ms SRecipient rId - Just Message {msgId = mId3} <- tryPeekMsg ms rId q' - (Msg "message 3", Msg "message 4") <- tryDelPeekMsg ms rId q' mId3 - Just Message {msgId = mId4} <- tryPeekMsg ms rId q' - (Msg "message 4", Nothing) <- tryDelPeekMsg ms rId q' mId4 - Just (Message {}, True) <- writeMsg ms rId q' True =<< mkMessage "message 6" - Msg "message 6" <- tryPeekMsg ms rId q' + Just Message {msgId = mId3} <- tryPeekMsg ms q' + (Msg "message 3", Msg "message 4") <- tryDelPeekMsg ms q' mId3 + Just Message {msgId = mId4} <- tryPeekMsg ms q' + (Msg "message 4", Nothing) <- tryDelPeekMsg ms q' mId4 + Just (Message {}, True) <- writeMsg ms q' True =<< mkMessage "message 6" + Msg "message 6" <- tryPeekMsg ms q' pure () testReadAndWriteFilesMissing :: JournalMsgStore s -> IO () testReadAndWriteFilesMissing ms = do g <- C.newRandom (rId, qr) <- testNewQueueRec g True - q <- writeMessages ms rId qr + q <- writeMessages ms qr mq <- fromJust <$> readTVarIO (msgQueue_' q) MsgQueueState {readState = rs, writeState = ws} <- readTVarIO $ state mq closeMsgStore ms - removeFile $ journalFilePath (queueDirectory $ queue mq) $ journalId rs - removeFile $ journalFilePath (queueDirectory $ queue mq) $ journalId ws + removeFile $ journalFilePath (queueDirectory q) $ journalId rs + removeFile $ journalFilePath (queueDirectory q) $ journalId ws runRight_ $ do q' <- ExceptT $ getQueue ms SRecipient rId - Nothing <- tryPeekMsg ms rId q' - Just (Message {}, True) <- writeMsg ms rId q' True =<< mkMessage "message 6" - Msg "message 6" <- tryPeekMsg ms rId q' + Nothing <- tryPeekMsg ms q' + Just (Message {}, True) <- writeMsg ms q' True =<< mkMessage "message 6" + Msg "message 6" <- tryPeekMsg ms q' pure () -writeMessages :: JournalMsgStore s -> RecipientId -> QueueRec -> IO (JournalQueue s) -writeMessages ms rId qr = runRight $ do +writeMessages :: JournalMsgStore s -> QueueRec -> IO (JournalQueue s) +writeMessages ms qr = runRight $ do q <- ExceptT $ addQueue ms qr - let write s = writeMsg ms rId q True =<< mkMessage s + let write s = writeMsg ms q True =<< mkMessage s Just (Message {msgId = mId1}, True) <- write "message 1" Just (Message {msgId = mId2}, False) <- write "message 2" Just (Message {}, False) <- write "message 3" - (Msg "message 1", Msg "message 2") <- tryDelPeekMsg ms rId q mId1 - (Msg "message 2", Msg "message 3") <- tryDelPeekMsg ms rId q mId2 + (Msg "message 1", Msg "message 2") <- tryDelPeekMsg ms q mId1 + (Msg "message 2", Msg "message 3") <- tryDelPeekMsg ms q mId2 Just (Message {}, False) <- write "message 4" Just (Message {}, False) <- write "message 5" pure q From f3fc087800641e10612b800e7e6aacfd288de151 Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin Date: Fri, 13 Dec 2024 17:34:11 +0000 Subject: [PATCH 04/17] remove statePath from queue record --- .../Messaging/Server/MsgStore/Journal.hs | 22 +++++++++---------- 1 file changed, 11 insertions(+), 11 deletions(-) diff --git a/src/Simplex/Messaging/Server/MsgStore/Journal.hs b/src/Simplex/Messaging/Server/MsgStore/Journal.hs index e6f15c99f..4db18eb4a 100644 --- a/src/Simplex/Messaging/Server/MsgStore/Journal.hs +++ b/src/Simplex/Messaging/Server/MsgStore/Journal.hs @@ -122,8 +122,7 @@ data JournalQueue (s :: MSType) = JournalQueue activeAt :: TVar Int64, -- Just True - empty, Just False - non-empty, Nothing - unknown isEmpty :: TVar (Maybe Bool), - queueDirectory :: FilePath, - statePath :: FilePath + queueDirectory :: FilePath } data JournalMsgQueue (s :: MSType) = JournalMsgQueue @@ -247,8 +246,6 @@ makeQueue st queueLock qr@QueueRec {recipientId} = do msgQueue_ <- newTVarIO Nothing activeAt <- newTVarIO 0 isEmpty <- newTVarIO Nothing - let dir = msgQueueDirectory st recipientId - statePath = msgQueueStatePath dir $ B.unpack (strEncode recipientId) pure JournalQueue { recipientId, @@ -257,10 +254,11 @@ makeQueue st queueLock qr@QueueRec {recipientId} = do msgQueue_, activeAt, isEmpty, - queueDirectory = dir, - statePath + queueDirectory = msgQueueDirectory st recipientId } +-- statePath = msgQueueStatePath dir $ B.unpack (strEncode recipientId) + instance MsgStoreClass (JournalMsgStore s) where type StoreMonad (JournalMsgStore s) = StoreIO s type StoreQueue (JournalMsgStore s) = JournalQueue s @@ -543,7 +541,7 @@ instance MsgStoreClass (JournalMsgStore s) where (msg :) <$> run msgs writeMsg :: JournalMsgStore s -> JournalQueue s -> Bool -> Message -> ExceptT ErrorType IO (Maybe (Message, Bool)) - writeMsg ms q'@JournalQueue {queueDirectory, statePath} logState msg = isolateQueue q' "writeMsg" $ do + writeMsg ms q'@JournalQueue {recipientId, queueDirectory = dir} logState msg = isolateQueue q' "writeMsg" $ do q <- getMsgQueue ms q' StoreIO $ (`E.finally` updateActiveAt q') $ do st@MsgQueueState {canWrite, size} <- readTVarIO (state q) @@ -576,16 +574,17 @@ instance MsgStoreClass (JournalMsgStore s) where when (size == 0) $ writeTVar (tipMsg q) $ Just (Just (msg, msgLen)) where createQueueDir = do - createDirectoryIfMissing True queueDirectory + createDirectoryIfMissing True dir + let statePath = msgQueueStatePath dir $ B.unpack (strEncode recipientId) sh <- openFile statePath AppendMode B.hPutStr sh "" - rh <- createNewJournal queueDirectory $ journalId rs + rh <- createNewJournal dir $ journalId rs let hs = MsgQueueHandles {stateHandle = sh, readHandle = rh, writeHandle = Nothing} atomically $ writeTVar handles $ Just hs pure hs switchWriteJournal hs = do journalId <- newJournalId $ random ms - wh <- createNewJournal queueDirectory journalId + wh <- createNewJournal dir journalId atomically $ writeTVar handles $ Just $ hs {writeHandle = Just wh} pure (newJournalState journalId, wh) @@ -669,7 +668,8 @@ storeQueue_ JournalQueue {recipientId, queueDirectory} _q = pure () -- save queu _queuePath = queueRecPath queueDirectory $ B.unpack (strEncode recipientId) openMsgQueue :: JournalMsgStore s -> JournalQueue s -> IO (JournalMsgQueue s) -openMsgQueue ms JournalQueue {queueDirectory = dir, statePath} = do +openMsgQueue ms JournalQueue {recipientId, queueDirectory = dir} = do + let statePath = msgQueueStatePath dir $ B.unpack (strEncode recipientId) (st, sh) <- readWriteQueueState ms statePath (st', rh, wh_) <- closeOnException sh $ openJournals ms dir st sh let hs = MsgQueueHandles {stateHandle = sh, readHandle = rh, writeHandle = wh_} From dfa77a1efa8121d0c9000e99525e8874e5a62eae Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin Date: Fri, 13 Dec 2024 18:29:23 +0000 Subject: [PATCH 05/17] remove recipientId from QueueRec, statePath from queue object --- src/Simplex/Messaging/Server.hs | 27 ++++++----- .../Messaging/Server/MsgStore/Journal.hs | 46 +++++++++---------- src/Simplex/Messaging/Server/MsgStore/STM.hs | 11 ++--- .../Messaging/Server/MsgStore/Types.hs | 8 ++-- src/Simplex/Messaging/Server/QueueStore.hs | 3 +- .../Messaging/Server/QueueStore/STM.hs | 41 ++++++++--------- src/Simplex/Messaging/Server/StoreLog.hs | 24 +++++----- tests/CoreTests/MsgStoreTests.hs | 35 +++++++------- tests/CoreTests/StoreLogTests.hs | 22 ++++----- 9 files changed, 104 insertions(+), 113 deletions(-) diff --git a/src/Simplex/Messaging/Server.hs b/src/Simplex/Messaging/Server.hs index 0fda31b00..ac9aa52f1 100644 --- a/src/Simplex/Messaging/Server.hs +++ b/src/Simplex/Messaging/Server.hs @@ -795,8 +795,8 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg} attachHT CPDelete qId -> withUserRole $ unliftIO u $ do AMS _ st <- asks msgStore r <- liftIO $ runExceptT $ do - (q, qr) <- ExceptT (getQueueRec st SSender qId) `catchE` \_ -> ExceptT (getQueueRec st SRecipient qId) - ExceptT $ deleteQueueSize st (recipientId qr) q + q <- ExceptT (getQueue st SSender qId) `catchE` \_ -> ExceptT (getQueue st SRecipient qId) + ExceptT $ deleteQueueSize st q case r of Left e -> liftIO $ hPutStrLn h $ "error: " <> show e Right (qr, numDeleted) -> do @@ -1199,10 +1199,9 @@ client updatedAt <- Just <$> liftIO getSystemDate let rcvDhSecret = C.dh' dhKey privDhKey qik (rcvId, sndId) = QIK {rcvId, sndId, rcvPublicDhKey, sndSecure} - qRec (recipientId, senderId) = + qRec senderId = QueueRec - { recipientId, - senderId, + { senderId, recipientKey, rcvDhSecret, senderKey = Nothing, @@ -1214,12 +1213,12 @@ client (corrId,entId,) <$> addQueueRetry 3 qik qRec where addQueueRetry :: - Int -> ((RecipientId, SenderId) -> QueueIdsKeys) -> ((RecipientId, SenderId) -> QueueRec) -> M BrokerMsg + Int -> ((RecipientId, SenderId) -> QueueIdsKeys) -> (SenderId -> QueueRec) -> M BrokerMsg addQueueRetry 0 _ _ = pure $ ERR INTERNAL addQueueRetry n qik qRec = do - ids <- getIds - let qr = qRec ids - liftIO (addQueue ms qr) >>= \case + ids@(rId, sId) <- getIds + let qr = qRec sId + liftIO (addQueue ms rId qr) >>= \case Left DUPLICATE_ -> addQueueRetry (n - 1) qik qRec Left e -> pure $ ERR e Right q -> do @@ -1296,7 +1295,7 @@ client incStat $ qSubDuplicate stats atomically (tryTakeTMVar $ delivered s) >> deliver False s where - rId = recipientId qr + rId = recipientId' q newSub :: M Sub newSub = time "SUB newSub" . atomically $ do writeTQueue subscribedQ (rId, clientId, True) @@ -1449,10 +1448,10 @@ client when (notification msgFlags) $ do mapM_ (`enqueueNotification` msg) (notifier qr) incStat $ msgSentNtf stats - liftIO $ updatePeriodStats (activeQueuesNtf stats) (recipientId qr) + liftIO $ updatePeriodStats (activeQueuesNtf stats) (recipientId' q) incStat $ msgSent stats incStat $ msgCount stats - liftIO $ updatePeriodStats (activeQueues stats) (recipientId qr) + liftIO $ updatePeriodStats (activeQueues stats) (recipientId' q) pure ok where THandleParams {thVersion} = thParams' @@ -1481,7 +1480,7 @@ client whenM (TM.memberIO rId subscribers) $ atomically deliverToSub >>= mapM_ forkDeliver where - rId = recipientId qr + rId = recipientId' q deliverToSub = -- lookup has ot be in the same transaction, -- so that if subscription ends, it re-evalutates @@ -1625,7 +1624,7 @@ client delQueueAndMsgs :: (StoreQueue s, QueueRec) -> M (Transmission BrokerMsg) delQueueAndMsgs (q, _) = do - liftIO (deleteQueue ms entId q) >>= \case + liftIO (deleteQueue ms q) >>= \case Right qr -> do -- Possibly, the same should be done if the queue is suspended, but currently we do not use it atomically $ do diff --git a/src/Simplex/Messaging/Server/MsgStore/Journal.hs b/src/Simplex/Messaging/Server/MsgStore/Journal.hs index 4db18eb4a..1c013ce71 100644 --- a/src/Simplex/Messaging/Server/MsgStore/Journal.hs +++ b/src/Simplex/Messaging/Server/MsgStore/Journal.hs @@ -236,29 +236,27 @@ instance STMQueueStore (JournalMsgStore 'MSMemory) where senders' = senders . queueStore notifiers' = notifiers . queueStore storeLog' = storeLog . queueStore - mkQueue st qr@QueueRec {recipientId} = do - lock <- atomically $ getMapLock (queueLocks st) recipientId - makeQueue st lock qr + mkQueue st rId qr = do + lock <- atomically $ getMapLock (queueLocks st) rId + makeQueue st lock rId qr -makeQueue :: JournalMsgStore s -> Lock -> QueueRec -> IO (JournalQueue s) -makeQueue st queueLock qr@QueueRec {recipientId} = do +makeQueue :: JournalMsgStore s -> Lock -> RecipientId -> QueueRec -> IO (JournalQueue s) +makeQueue st queueLock rId qr = do queueRec <- newTVarIO $ Just qr msgQueue_ <- newTVarIO Nothing activeAt <- newTVarIO 0 isEmpty <- newTVarIO Nothing pure JournalQueue - { recipientId, + { recipientId = rId, queueLock, queueRec, msgQueue_, activeAt, isEmpty, - queueDirectory = msgQueueDirectory st recipientId + queueDirectory = msgQueueDirectory st rId } --- statePath = msgQueueStatePath dir $ B.unpack (strEncode recipientId) - instance MsgStoreClass (JournalMsgStore s) where type StoreMonad (JournalMsgStore s) = StoreIO s type StoreQueue (JournalMsgStore s) = JournalQueue s @@ -371,15 +369,15 @@ instance MsgStoreClass (JournalMsgStore s) where pure QueueCounts {queueCount, notifierCount} JQStore {} -> undefined - addQueue :: JournalMsgStore s -> QueueRec -> IO (Either ErrorType (JournalQueue s)) - addQueue st@JournalMsgStore {queueLocks = ls} qr@QueueRec {recipientId = rId, senderId = sId, notifier} = case queueStore st of - MQStore {} -> addQueue' st qr + addQueue :: JournalMsgStore s -> RecipientId -> QueueRec -> IO (Either ErrorType (JournalQueue s)) + addQueue st@JournalMsgStore {queueLocks = ls} rId qr@QueueRec {senderId = sId, notifier} = case queueStore st of + MQStore {} -> addQueue' st rId qr JQStore {queues_, senders_, notifiers_} -> do lock <- atomically $ getMapLock ls rId tryStore "addQueue" rId $ withLock' lock "addQueue" $ withLockMap ls sId "addQueueS" $ withNotifierLock $ ifM hasAnyId (pure $ Left DUPLICATE_) $ E.uninterruptibleMask_ $ do - q <- makeQueue st lock qr + q <- makeQueue st lock rId qr storeQueue_ q qr atomically $ TM.insert rId (Just q) queues_ saveQueueRef st sId rId senders_ @@ -421,7 +419,7 @@ instance MsgStoreClass (JournalMsgStore s) where addQueueNotifier st sq ntfCreds@NtfCreds {notifierId = nId} = case queueStore st of MQStore {} -> addQueueNotifier' st sq ntfCreds JQStore {notifiers_} -> - isolateQueueRec sq "addQueueNotifier" $ \q@QueueRec {recipientId = rId} -> + isolateQueueRec sq "addQueueNotifier" $ \q -> withLockMap (queueLocks st) nId "addQueueNotifierN" $ ifM hasNotifierId (pure $ Left DUPLICATE_) $ do nId_ <- forM (notifier q) $ \NtfCreds {notifierId = nId'} -> @@ -430,7 +428,7 @@ instance MsgStoreClass (JournalMsgStore s) where atomically $ TM.delete nId' notifiers_ pure nId' storeQueue sq q {notifier = Just ntfCreds} - saveQueueRef st nId rId notifiers_ + saveQueueRef st nId (recipientId sq) notifiers_ pure $ Right nId_ where hasNotifierId = anyM [hasId, hasDir] @@ -518,13 +516,12 @@ instance MsgStoreClass (JournalMsgStore s) where sz <- unStoreIO $ getQueueSize_ mq pure (r, sz) - deleteQueue :: JournalMsgStore s -> RecipientId -> JournalQueue s -> IO (Either ErrorType QueueRec) - deleteQueue ms rId q = - fst <$$> deleteQueue_ ms rId q + deleteQueue :: JournalMsgStore s -> JournalQueue s -> IO (Either ErrorType QueueRec) + deleteQueue ms q = fst <$$> deleteQueue_ ms q - deleteQueueSize :: JournalMsgStore s -> RecipientId -> JournalQueue s -> IO (Either ErrorType (QueueRec, Int)) - deleteQueueSize ms rId q = - deleteQueue_ ms rId q >>= mapM (traverse getSize) + 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) @@ -893,12 +890,13 @@ validQueueState MsgQueueState {readState = rs, writeState = ws, size} && msgPos ws == msgCount ws && bytePos ws == byteCount ws -deleteQueue_ :: forall s. JournalMsgStore s -> RecipientId -> JournalQueue s -> IO (Either ErrorType (QueueRec, Maybe (JournalMsgQueue s))) -deleteQueue_ ms rId q = +deleteQueue_ :: forall s. JournalMsgStore s -> JournalQueue s -> IO (Either ErrorType (QueueRec, Maybe (JournalMsgQueue s))) +deleteQueue_ ms q = isolateQueueId "deleteQueue_" ms rId $ case queueStore ms of - MQStore {} -> deleteQueue' ms rId q >>= mapM remove + MQStore {} -> deleteQueue' ms q >>= mapM remove JQStore {} -> undefined where + rId = recipientId q remove :: (QueueRec, Maybe (JournalMsgQueue s)) -> IO (QueueRec, Maybe (JournalMsgQueue s)) remove r@(_, mq_) = do mapM_ closeMsgQueueHandles mq_ diff --git a/src/Simplex/Messaging/Server/MsgStore/STM.hs b/src/Simplex/Messaging/Server/MsgStore/STM.hs index 9378edf9f..a3a895415 100644 --- a/src/Simplex/Messaging/Server/MsgStore/STM.hs +++ b/src/Simplex/Messaging/Server/MsgStore/STM.hs @@ -64,8 +64,7 @@ instance STMQueueStore STMMsgStore where senders' = senders notifiers' = notifiers storeLog' = storeLog - mkQueue _ qr@QueueRec {recipientId} = - STMQueue recipientId <$> newTVarIO (Just qr) <*> newTVarIO Nothing + mkQueue _ rId qr = STMQueue rId <$> newTVarIO (Just qr) <*> newTVarIO Nothing instance MsgStoreClass STMMsgStore where type StoreMonad STMMsgStore = STM @@ -156,11 +155,11 @@ instance MsgStoreClass STMMsgStore where pure (Just r, sz) Nothing -> pure (Nothing, 0) - deleteQueue :: STMMsgStore -> RecipientId -> STMQueue -> IO (Either ErrorType QueueRec) - deleteQueue ms rId q = fst <$$> deleteQueue' ms rId q + deleteQueue :: STMMsgStore -> STMQueue -> IO (Either ErrorType QueueRec) + deleteQueue ms q = fst <$$> deleteQueue' ms q - deleteQueueSize :: STMMsgStore -> RecipientId -> STMQueue -> IO (Either ErrorType (QueueRec, Int)) - deleteQueueSize ms rId q = deleteQueue' ms rId q >>= mapM (traverse getSize) + deleteQueueSize :: STMMsgStore -> STMQueue -> 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 0) (\STMMsgQueue {size} -> readTVarIO size) diff --git a/src/Simplex/Messaging/Server/MsgStore/Types.hs b/src/Simplex/Messaging/Server/MsgStore/Types.hs index 22015da4b..d349e6eba 100644 --- a/src/Simplex/Messaging/Server/MsgStore/Types.hs +++ b/src/Simplex/Messaging/Server/MsgStore/Types.hs @@ -33,7 +33,7 @@ class MsgStoreClass s => STMQueueStore s where senders' :: s -> TMap SenderId RecipientId notifiers' :: s -> TMap NotifierId RecipientId storeLog' :: s -> TVar (Maybe (StoreLog 'WriteMode)) - mkQueue :: s -> QueueRec -> IO (StoreQueue s) + mkQueue :: s -> RecipientId -> QueueRec -> IO (StoreQueue s) class Monad (StoreMonad s) => MsgStoreClass s where type StoreMonad s = (m :: Type -> Type) | m -> s @@ -52,7 +52,7 @@ class Monad (StoreMonad s) => MsgStoreClass s where msgQueue_' :: StoreQueue s -> TVar (Maybe (MsgQueue s)) queueCounts :: s -> IO QueueCounts - addQueue :: s -> QueueRec -> IO (Either ErrorType (StoreQueue s)) + addQueue :: s -> RecipientId -> QueueRec -> IO (Either ErrorType (StoreQueue s)) getQueue :: DirectParty p => s -> SParty p -> QueueId -> IO (Either ErrorType (StoreQueue s)) secureQueue :: s -> StoreQueue s -> SndPublicAuthKey -> IO (Either ErrorType ()) addQueueNotifier :: s -> StoreQueue s -> NtfCreds -> IO (Either ErrorType (Maybe NotifierId)) @@ -65,8 +65,8 @@ class Monad (StoreMonad s) => MsgStoreClass s where -- 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) - deleteQueue :: s -> RecipientId -> StoreQueue s -> IO (Either ErrorType QueueRec) - deleteQueueSize :: s -> RecipientId -> StoreQueue s -> IO (Either ErrorType (QueueRec, 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] 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 diff --git a/src/Simplex/Messaging/Server/QueueStore.hs b/src/Simplex/Messaging/Server/QueueStore.hs index 3f7da8d29..3f40e0f3e 100644 --- a/src/Simplex/Messaging/Server/QueueStore.hs +++ b/src/Simplex/Messaging/Server/QueueStore.hs @@ -12,8 +12,7 @@ import Simplex.Messaging.Encoding.String import Simplex.Messaging.Protocol data QueueRec = QueueRec - { recipientId :: !RecipientId, - recipientKey :: !RcvPublicAuthKey, + { recipientKey :: !RcvPublicAuthKey, rcvDhSecret :: !RcvDhSecret, senderId :: !SenderId, senderKey :: !(Maybe SndPublicAuthKey), diff --git a/src/Simplex/Messaging/Server/QueueStore/STM.hs b/src/Simplex/Messaging/Server/QueueStore/STM.hs index ca2b70319..8836468b1 100644 --- a/src/Simplex/Messaging/Server/QueueStore/STM.hs +++ b/src/Simplex/Messaging/Server/QueueStore/STM.hs @@ -43,10 +43,10 @@ import Simplex.Messaging.Util (anyM, ifM, ($>>=), (<$$)) import System.IO import UnliftIO.STM -addQueue' :: STMQueueStore s => s -> QueueRec -> IO (Either ErrorType (StoreQueue s)) -addQueue' st qr@QueueRec {recipientId = rId, senderId = sId, notifier} = - (mkQueue st qr >>= atomically . add) - $>>= \q -> q <$$ withLog "addQueue" st (`logCreateQueue` qr) +addQueue' :: STMQueueStore s => s -> RecipientId -> QueueRec -> IO (Either ErrorType (StoreQueue s)) +addQueue' st rId qr@QueueRec {senderId = sId, notifier} = + (mkQueue st rId qr >>= atomically . add) + $>>= \q -> q <$$ withLog "addQueue" st (\s -> logCreateQueue s rId qr) where add q = ifM hasId (pure $ Left DUPLICATE_) $ do TM.insert rId q $ queues' st @@ -66,35 +66,36 @@ getQueue' st party qId = secureQueue' :: STMQueueStore s => s -> StoreQueue s -> SndPublicAuthKey -> IO (Either ErrorType ()) secureQueue' st sq sKey = atomically (readQueueRec qr $>>= secure) - $>>= \rId -> withLog "secureQueue" st $ \s -> logSecureQueue s rId sKey + $>>= \_ -> withLog "secureQueue" st $ \s -> logSecureQueue s (recipientId' sq) sKey where qr = queueRec' sq - secure q@QueueRec {recipientId = rId} = case senderKey q of - Just k -> pure $ if sKey == k then Right rId else Left AUTH + 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 rId + pure $ Right () addQueueNotifier' :: STMQueueStore s => s -> StoreQueue s -> NtfCreds -> IO (Either ErrorType (Maybe NotifierId)) addQueueNotifier' st sq ntfCreds@NtfCreds {notifierId = nId} = atomically (readQueueRec qr $>>= add) - $>>= \(rId, nId_) -> nId_ <$$ withLog "addQueueNotifier" st (\s -> logAddNotifier s rId ntfCreds) + $>>= \nId_ -> nId_ <$$ withLog "addQueueNotifier" st (\s -> logAddNotifier s rId ntfCreds) where qr = queueRec' sq - add q@QueueRec {recipientId = rId} = ifM (TM.member nId (notifiers' st)) (pure $ Left DUPLICATE_) $ do + rId = recipientId' sq + add q = ifM (TM.member nId (notifiers' st)) (pure $ Left DUPLICATE_) $ do nId_ <- forM (notifier q) $ \NtfCreds {notifierId} -> TM.delete notifierId (notifiers' st) $> notifierId let !q' = q {notifier = Just ntfCreds} writeTVar qr $ Just q' TM.insert nId rId $ notifiers' st - pure $ Right (rId, nId_) + pure $ Right nId_ deleteQueueNotifier' :: STMQueueStore s => s -> StoreQueue s -> IO (Either ErrorType (Maybe NotifierId)) deleteQueueNotifier' st sq = atomically (readQueueRec qr >>= mapM delete) - $>>= \(rId, nId_) -> nId_ <$$ withLog "deleteQueueNotifier" st (`logDeleteNotifier` rId) + $>>= \nId_ -> nId_ <$$ withLog "deleteQueueNotifier" st (`logDeleteNotifier` recipientId' sq) where qr = queueRec' sq - delete q = fmap (recipientId q,) $ forM (notifier q) $ \NtfCreds {notifierId} -> do + delete q = forM (notifier q) $ \NtfCreds {notifierId} -> do TM.delete notifierId $ notifiers' st writeTVar qr $! Just q {notifier = Nothing} pure notifierId @@ -102,12 +103,10 @@ deleteQueueNotifier' st sq = suspendQueue' :: STMQueueStore s => s -> StoreQueue s -> IO (Either ErrorType ()) suspendQueue' st sq = atomically (readQueueRec qr >>= mapM suspend) - $>>= \rId -> withLog "suspendQueue" st (`logSuspendQueue` rId) + $>>= \_ -> withLog "suspendQueue" st (`logSuspendQueue` recipientId' sq) where qr = queueRec' sq - suspend q = do - writeTVar qr $! Just q {status = QueueOff} - pure $ recipientId q + suspend q = writeTVar qr $! Just q {status = QueueOff} updateQueueTime' :: STMQueueStore s => s -> StoreQueue s -> RoundedSystemTime -> IO (Either ErrorType QueueRec) updateQueueTime' st sq t = atomically (readQueueRec qr >>= mapM update) $>>= log' @@ -119,13 +118,13 @@ updateQueueTime' st sq t = atomically (readQueueRec qr >>= mapM update) $>>= log 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 q) t) + | changed = q <$$ withLog "updateQueueTime" st (\sl -> logUpdateQueueTime sl (recipientId' sq) t) | otherwise = pure $ Right q -deleteQueue' :: STMQueueStore s => s -> RecipientId -> StoreQueue s -> IO (Either ErrorType (QueueRec, Maybe (MsgQueue s))) -deleteQueue' st rId sq = +deleteQueue' :: STMQueueStore s => s -> StoreQueue s -> IO (Either ErrorType (QueueRec, Maybe (MsgQueue s))) +deleteQueue' st sq = atomically (readQueueRec qr >>= mapM delete) - $>>= \q -> withLog "deleteQueue" st (`logDeleteQueue` rId) + $>>= \q -> withLog "deleteQueue" st (`logDeleteQueue` recipientId' sq) >>= bimapM pure (\_ -> (q,) <$> atomically (swapTVar (msgQueue_' sq) Nothing)) where qr = queueRec' sq diff --git a/src/Simplex/Messaging/Server/StoreLog.hs b/src/Simplex/Messaging/Server/StoreLog.hs index 889cb6046..4cc55e978 100644 --- a/src/Simplex/Messaging/Server/StoreLog.hs +++ b/src/Simplex/Messaging/Server/StoreLog.hs @@ -57,7 +57,7 @@ import System.Directory (doesFileExist, renameFile) import System.IO data StoreLogRecord - = CreateQueue QueueRec + = CreateQueue RecipientId QueueRec | SecureQueue QueueId SndPublicAuthKey | AddNotifier QueueId NtfCreds | SuspendQueue QueueId @@ -76,10 +76,9 @@ data SLRTag | UpdateTime_ instance StrEncoding QueueRec where - strEncode QueueRec {recipientId, recipientKey, rcvDhSecret, senderId, senderKey, sndSecure, notifier, updatedAt} = + strEncode QueueRec {recipientKey, rcvDhSecret, senderId, senderKey, sndSecure, notifier, updatedAt} = B.unwords - [ "rid=" <> strEncode recipientId, - "rk=" <> strEncode recipientKey, + [ "rk=" <> strEncode recipientKey, "rdh=" <> strEncode rcvDhSecret, "sid=" <> strEncode senderId, "sk=" <> strEncode senderKey @@ -93,7 +92,6 @@ instance StrEncoding QueueRec where updatedAtStr t = " updated_at=" <> strEncode t strP = do - recipientId <- "rid=" *> strP_ recipientKey <- "rk=" *> strP_ rcvDhSecret <- "rdh=" *> strP_ senderId <- "sid=" *> strP_ @@ -101,7 +99,7 @@ instance StrEncoding QueueRec where sndSecure <- (" sndSecure=" *> strP) <|> pure False notifier <- optional $ " notifier=" *> strP updatedAt <- optional $ " updated_at=" *> strP - pure QueueRec {recipientId, recipientKey, rcvDhSecret, senderId, senderKey, sndSecure, notifier, status = QueueActive, updatedAt} + pure QueueRec {recipientKey, rcvDhSecret, senderId, senderKey, sndSecure, notifier, status = QueueActive, updatedAt} instance StrEncoding SLRTag where strEncode = \case @@ -126,7 +124,7 @@ instance StrEncoding SLRTag where instance StrEncoding StoreLogRecord where strEncode = \case - CreateQueue q -> strEncode (CreateQueue_, q) + CreateQueue rId q -> strEncode (CreateQueue_, Str $ "rid=" <> strEncode rId, q) SecureQueue rId sKey -> strEncode (SecureQueue_, rId, sKey) AddNotifier rId ntfCreds -> strEncode (AddNotifier_, rId, ntfCreds) SuspendQueue rId -> strEncode (SuspendQueue_, rId) @@ -136,7 +134,7 @@ instance StrEncoding StoreLogRecord where strP = strP_ >>= \case - CreateQueue_ -> CreateQueue <$> strP + CreateQueue_ -> CreateQueue <$> ("rid=" *> strP_) <*> strP SecureQueue_ -> SecureQueue <$> strP_ <*> strP AddNotifier_ -> AddNotifier <$> strP_ <*> strP SuspendQueue_ -> SuspendQueue <$> strP @@ -172,8 +170,8 @@ writeStoreLogRecord (WriteStoreLog _ h) r = E.uninterruptibleMask_ $ do B.hPut h $ strEncode r `B.snoc` '\n' -- hPutStrLn makes write non-atomic for length > 1024 hFlush h -logCreateQueue :: StoreLog 'WriteMode -> QueueRec -> IO () -logCreateQueue s = writeStoreLogRecord s . CreateQueue +logCreateQueue :: StoreLog 'WriteMode -> RecipientId -> QueueRec -> IO () +logCreateQueue s rId q = writeStoreLogRecord s $ CreateQueue rId q logSecureQueue :: StoreLog 'WriteMode -> QueueId -> SndPublicAuthKey -> IO () logSecureQueue s qId sKey = writeStoreLogRecord s $ SecureQueue qId sKey @@ -233,7 +231,7 @@ writeQueueStore s st = readTVarIO (activeMsgQueues st) >>= mapM_ writeQueue . M. where writeQueue (rId, q) = readTVarIO (queueRec' q) >>= \case - Just q' -> when (active q') $ logCreateQueue s q' -- TODO we should log suspended queues when we use them + Just q' -> when (active q') $ logCreateQueue s rId q' -- TODO we should log suspended queues when we use them Nothing -> atomically $ TM.delete rId $ activeMsgQueues st active QueueRec {status} = status == QueueActive @@ -246,11 +244,11 @@ readQueueStore f st = withFile f ReadMode $ LB.hGetContents >=> mapM_ processLin s = LB.toStrict s' procLogRecord :: StoreLogRecord -> IO () procLogRecord = \case - CreateQueue q -> addQueue st q >>= qError (recipientId q) "CreateQueue" + 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 - DeleteQueue qId -> withQueue qId "DeleteQueue" $ deleteQueue st qId + 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 () diff --git a/tests/CoreTests/MsgStoreTests.hs b/tests/CoreTests/MsgStoreTests.hs index c1fc2a708..0ce2fd1c3 100644 --- a/tests/CoreTests/MsgStoreTests.hs +++ b/tests/CoreTests/MsgStoreTests.hs @@ -105,8 +105,7 @@ testNewQueueRec g sndSecure = do (k, pk) <- atomically $ C.generateKeyPair @'C.X25519 g let qr = QueueRec - { recipientId = rId, - recipientKey, + { recipientKey, rcvDhSecret = C.dh' k pk, senderId, senderKey = Nothing, @@ -122,7 +121,7 @@ testGetQueue ms = do g <- C.newRandom (rId, qr) <- testNewQueueRec g True runRight_ $ do - q <- ExceptT $ addQueue ms qr + q <- ExceptT $ addQueue ms rId qr let write s = writeMsg ms q True =<< mkMessage s Just (Message {msgId = mId1}, True) <- write "message 1" Just (Message {msgId = mId2}, False) <- write "message 2" @@ -157,14 +156,14 @@ testGetQueue ms = do (Msg "message 7", Just MessageQuota {msgId = mId8}) <- tryDelPeekMsg ms q mId7 (Just MessageQuota {}, Nothing) <- tryDelPeekMsg ms q mId8 (Nothing, Nothing) <- tryDelPeekMsg ms q mId8 - void $ ExceptT $ deleteQueue ms rId q + void $ ExceptT $ deleteQueue ms q testChangeReadJournal :: STMQueueStore s => s -> IO () testChangeReadJournal ms = do g <- C.newRandom (rId, qr) <- testNewQueueRec g True runRight_ $ do - q <- ExceptT $ addQueue ms qr + q <- ExceptT $ addQueue ms rId qr let write s = writeMsg ms q True =<< mkMessage s Just (Message {msgId = mId1}, True) <- write "message 1" (Msg "message 1", Nothing) <- tryDelPeekMsg ms q mId1 @@ -176,7 +175,7 @@ testChangeReadJournal ms = do (Msg "message 4", Nothing) <- tryDelPeekMsg ms q mId4 Just (Message {msgId = mId5}, True) <- write "message 5" (Msg "message 5", Nothing) <- tryDelPeekMsg ms q mId5 - void $ ExceptT $ deleteQueue ms rId q + void $ ExceptT $ deleteQueue ms q testExportImportStore :: JournalMsgStore s -> IO () testExportImportStore ms = do @@ -186,12 +185,12 @@ testExportImportStore ms = do sl <- readWriteQueueStore testStoreLogFile ms runRight_ $ do let write q s = writeMsg ms q True =<< mkMessage s - q1 <- ExceptT $ addQueue ms qr1 - liftIO $ logCreateQueue sl qr1 + q1 <- ExceptT $ addQueue ms rId1 qr1 + liftIO $ logCreateQueue sl rId1 qr1 Just (Message {}, True) <- write q1 "message 1" Just (Message {}, False) <- write q1 "message 2" - q2 <- ExceptT $ addQueue ms qr2 - liftIO $ logCreateQueue sl qr2 + q2 <- ExceptT $ addQueue ms rId2 qr2 + liftIO $ logCreateQueue sl rId2 qr2 Just (Message {msgId = mId3}, True) <- write q2 "message 3" Just (Message {msgId = mId4}, False) <- write q2 "message 4" (Msg "message 3", Msg "message 4") <- tryDelPeekMsg ms q2 mId3 @@ -300,7 +299,7 @@ testMessageState ms = do write q s = writeMsg ms q True =<< mkMessage s mId1 <- runRight $ do - q <- ExceptT $ addQueue ms qr + q <- ExceptT $ addQueue ms rId qr Just (Message {msgId = mId1}, True) <- write q "message 1" Just (Message {}, False) <- write q "message 2" liftIO $ closeMsgQueue q @@ -322,7 +321,7 @@ testReadFileMissing ms = do (rId, qr) <- testNewQueueRec g True let write q s = writeMsg ms q True =<< mkMessage s q <- runRight $ do - q <- ExceptT $ addQueue ms qr + q <- ExceptT $ addQueue ms rId qr Just (Message {}, True) <- write q "message 1" Msg "message 1" <- tryPeekMsg ms q pure q @@ -344,7 +343,7 @@ testReadFileMissingSwitch :: JournalMsgStore s -> IO () testReadFileMissingSwitch ms = do g <- C.newRandom (rId, qr) <- testNewQueueRec g True - q <- writeMessages ms qr + q <- writeMessages ms rId qr mq <- fromJust <$> readTVarIO (msgQueue_' q) MsgQueueState {readState = rs} <- readTVarIO $ state mq @@ -362,7 +361,7 @@ testWriteFileMissing :: JournalMsgStore s -> IO () testWriteFileMissing ms = do g <- C.newRandom (rId, qr) <- testNewQueueRec g True - q <- writeMessages ms qr + q <- writeMessages ms rId qr mq <- fromJust <$> readTVarIO (msgQueue_' q) MsgQueueState {writeState = ws} <- readTVarIO $ state mq @@ -385,7 +384,7 @@ testReadAndWriteFilesMissing :: JournalMsgStore s -> IO () testReadAndWriteFilesMissing ms = do g <- C.newRandom (rId, qr) <- testNewQueueRec g True - q <- writeMessages ms qr + q <- writeMessages ms rId qr mq <- fromJust <$> readTVarIO (msgQueue_' q) MsgQueueState {readState = rs, writeState = ws} <- readTVarIO $ state mq @@ -400,9 +399,9 @@ testReadAndWriteFilesMissing ms = do Msg "message 6" <- tryPeekMsg ms q' pure () -writeMessages :: JournalMsgStore s -> QueueRec -> IO (JournalQueue s) -writeMessages ms qr = runRight $ do - q <- ExceptT $ addQueue ms qr +writeMessages :: JournalMsgStore s -> RecipientId -> QueueRec -> IO (JournalQueue s) +writeMessages ms rId qr = runRight $ do + q <- ExceptT $ addQueue ms rId qr let write s = writeMsg ms q True =<< mkMessage s Just (Message {msgId = mId1}, True) <- write "message 1" Just (Message {msgId = mId2}, False) <- write "message 2" diff --git a/tests/CoreTests/StoreLogTests.hs b/tests/CoreTests/StoreLogTests.hs index 5de40f0ef..b95a4494b 100644 --- a/tests/CoreTests/StoreLogTests.hs +++ b/tests/CoreTests/StoreLogTests.hs @@ -57,38 +57,38 @@ storeLogTests = testSMPStoreLog ("SMP server store log, sndSecure = " <> show sndSecure) [ SLTC { name = "create new queue", - saved = [CreateQueue qr], - compacted = [CreateQueue qr], + saved = [CreateQueue rId qr], + compacted = [CreateQueue rId qr], state = M.fromList [(rId, qr)] }, SLTC { name = "secure queue", - saved = [CreateQueue qr, SecureQueue rId testPublicAuthKey], - compacted = [CreateQueue qr {senderKey = Just testPublicAuthKey}], + saved = [CreateQueue rId qr, SecureQueue rId testPublicAuthKey], + compacted = [CreateQueue rId qr {senderKey = Just testPublicAuthKey}], state = M.fromList [(rId, qr {senderKey = Just testPublicAuthKey})] }, SLTC { name = "create and delete queue", - saved = [CreateQueue qr, DeleteQueue rId], + saved = [CreateQueue rId qr, DeleteQueue rId], compacted = [], state = M.fromList [] }, SLTC { name = "create queue and add notifier", - saved = [CreateQueue qr, AddNotifier rId ntfCreds], - compacted = [CreateQueue $ qr {notifier = Just ntfCreds}], + saved = [CreateQueue rId qr, AddNotifier rId ntfCreds], + compacted = [CreateQueue rId qr {notifier = Just ntfCreds}], state = M.fromList [(rId, qr {notifier = Just ntfCreds})] }, SLTC { name = "delete notifier", - saved = [CreateQueue qr, AddNotifier rId ntfCreds, DeleteNotifier rId], - compacted = [CreateQueue qr], + saved = [CreateQueue rId qr, AddNotifier rId ntfCreds, DeleteNotifier rId], + compacted = [CreateQueue rId qr], state = M.fromList [(rId, qr)] }, SLTC { name = "update time", - saved = [CreateQueue qr, UpdateTime rId date], - compacted = [CreateQueue qr {updatedAt = Just date}], + saved = [CreateQueue rId qr, UpdateTime rId date], + compacted = [CreateQueue rId qr {updatedAt = Just date}], state = M.fromList [(rId, qr {updatedAt = Just date})] } ] From 6b37c53d15e09205d67387bb82d88ac4735d56b1 Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin Date: Fri, 13 Dec 2024 20:40:12 +0000 Subject: [PATCH 06/17] implement deleteQueue_ --- .../Messaging/Server/MsgStore/Journal.hs | 72 +++++++++++++------ 1 file changed, 49 insertions(+), 23 deletions(-) diff --git a/src/Simplex/Messaging/Server/MsgStore/Journal.hs b/src/Simplex/Messaging/Server/MsgStore/Journal.hs index 1c013ce71..1dd5802a5 100644 --- a/src/Simplex/Messaging/Server/MsgStore/Journal.hs +++ b/src/Simplex/Messaging/Server/MsgStore/Journal.hs @@ -367,7 +367,10 @@ instance MsgStoreClass (JournalMsgStore s) where queueCount <- M.size <$> readTVarIO queues notifierCount <- M.size <$> readTVarIO notifiers pure QueueCounts {queueCount, notifierCount} - JQStore {} -> undefined + JQStore {queues_, notifiers_} -> do + queueCount <- M.size <$> readTVarIO queues_ + notifierCount <- M.size <$> readTVarIO notifiers_ + pure QueueCounts {queueCount, notifierCount} addQueue :: JournalMsgStore s -> RecipientId -> QueueRec -> IO (Either ErrorType (JournalQueue s)) addQueue st@JournalMsgStore {queueLocks = ls} rId qr@QueueRec {senderId = sId, notifier} = case queueStore st of @@ -378,6 +381,7 @@ instance MsgStoreClass (JournalMsgStore s) where withLock' lock "addQueue" $ withLockMap ls sId "addQueueS" $ withNotifierLock $ ifM hasAnyId (pure $ Left DUPLICATE_) $ E.uninterruptibleMask_ $ do q <- makeQueue st lock rId qr + -- TODO [queues] maybe createQueueDir storeQueue_ q qr atomically $ TM.insert rId (Just q) queues_ saveQueueRef st sId rId senders_ @@ -423,10 +427,8 @@ instance MsgStoreClass (JournalMsgStore s) where withLockMap (queueLocks st) nId "addQueueNotifierN" $ ifM hasNotifierId (pure $ Left DUPLICATE_) $ do nId_ <- forM (notifier q) $ \NtfCreds {notifierId = nId'} -> - withLockMap (queueLocks st) nId' "addQueueNotifierD" $ do - deleteQueueRef st nId' - atomically $ TM.delete nId' notifiers_ - pure nId' + withLockMap (queueLocks st) nId' "addQueueNotifierD" $ + deleteQueueRef st nId' notifiers_ $> nId' storeQueue sq q {notifier = Just ntfCreds} saveQueueRef st nId (recipientId sq) notifiers_ pure $ Right nId_ @@ -442,20 +444,27 @@ instance MsgStoreClass (JournalMsgStore s) where isolateQueueRec sq "deleteQueueNotifier" $ \q -> fmap Right $ forM (notifier q) $ \NtfCreds {notifierId = nId} -> withLockMap (queueLocks st) nId "deleteQueueNotifierN" $ do - deleteQueueRef st nId - atomically $ TM.delete nId notifiers_ + deleteQueueRef st nId notifiers_ storeQueue sq q {notifier = Nothing} pure nId suspendQueue :: JournalMsgStore s -> JournalQueue s -> IO (Either ErrorType ()) suspendQueue st sq = case queueStore st of MQStore {} -> suspendQueue' st sq - JQStore {} -> undefined + JQStore {} -> + isolateQueueRec sq "suspendQueue" $ \q -> + fmap Right $ storeQueue sq q {status = QueueOff} updateQueueTime :: JournalMsgStore s -> JournalQueue s -> RoundedSystemTime -> IO (Either ErrorType QueueRec) updateQueueTime st sq t = case queueStore st of MQStore {} -> updateQueueTime' st sq t - JQStore {} -> undefined + JQStore {} -> isolateQueueRec sq "updateQueueTime" $ fmap Right . update + where + update q@QueueRec {updatedAt} + | updatedAt == Just t = pure q + | otherwise = + let !q' = q {updatedAt = Just t} + in storeQueue sq q' $> q' getMsgQueue :: JournalMsgStore s -> JournalQueue s -> StoreIO s (JournalMsgQueue s) getMsgQueue ms@JournalMsgStore {random} sq@JournalQueue {msgQueue_, queueDirectory} = @@ -463,7 +472,7 @@ instance MsgStoreClass (JournalMsgStore s) where where newQ = do -- TODO [queues] this should account for the possibility that the folder exists, - -- but queue files do not + -- but queue messaging files do not, which will always be the case when queue record is in journals q <- ifM (doesDirectoryExist queueDirectory) (openMsgQueue ms sq) createQ atomically $ writeTVar msgQueue_ $ Just q pure q @@ -635,7 +644,7 @@ tryStore op rId a = E.mask_ $ E.try a >>= either storeErr pure isolateQueueRec :: JournalQueue s -> String -> (QueueRec -> IO (Either ErrorType a)) -> IO (Either ErrorType a) isolateQueueRec sq op a = isolateQueue_ sq op (atomically (readQueueRec qr) $>>= a) where - qr = queueRec' sq + qr = queueRec sq isolateQueue_ :: JournalQueue s -> String -> IO (Either ErrorType a) -> IO (Either ErrorType a) isolateQueue_ JournalQueue {recipientId, queueLock} op = tryStore op recipientId . withLock' queueLock op @@ -648,6 +657,10 @@ storeQueue sq@JournalQueue {queueRec} q = do storeQueue_ sq q atomically $ writeTVar queueRec $ Just q +-- TODO [queues] +deleteQueueDir :: JournalQueue s -> IO () +deleteQueueDir _sq = pure () + -- TODO [queues] saveQueueRef :: JournalMsgStore s -> QueueId -> RecipientId -> TMap QueueId (Maybe RecipientId) -> IO () saveQueueRef _st qId rId m = do @@ -655,8 +668,10 @@ saveQueueRef _st qId rId m = do atomically $ TM.insert qId (Just rId) m -- TODO [queues] -deleteQueueRef :: JournalMsgStore s -> QueueId -> IO () -deleteQueueRef _st _qId = pure () +deleteQueueRef :: JournalMsgStore s -> QueueId -> TMap QueueId (Maybe RecipientId) -> IO () +deleteQueueRef _st qId m = do + pure () -- delete ref from disk + atomically $ TM.delete qId m -- TODO [queues] storeQueue_ :: JournalQueue s -> QueueRec -> IO () @@ -891,17 +906,28 @@ validQueueState MsgQueueState {readState = rs, writeState = ws, size} && bytePos ws == byteCount ws deleteQueue_ :: forall s. JournalMsgStore s -> JournalQueue s -> IO (Either ErrorType (QueueRec, Maybe (JournalMsgQueue s))) -deleteQueue_ ms q = - isolateQueueId "deleteQueue_" ms rId $ case queueStore ms of - MQStore {} -> deleteQueue' ms q >>= mapM remove - JQStore {} -> undefined +deleteQueue_ st sq = + isolateQueueId "deleteQueue_" st rId $ + delete >>= mapM (traverse remove) where - rId = recipientId q - remove :: (QueueRec, Maybe (JournalMsgQueue s)) -> IO (QueueRec, Maybe (JournalMsgQueue s)) - remove r@(_, mq_) = do - mapM_ closeMsgQueueHandles mq_ - removeQueueDirectory ms rId - pure r + rId = recipientId sq + qr = queueRec sq + delete :: IO (Either ErrorType (QueueRec, Maybe (JournalMsgQueue s))) + delete = case queueStore st of + MQStore {} -> deleteQueue' st sq + JQStore {senders_, notifiers_} -> atomically (readQueueRec qr) >>= mapM jqDelete + where + jqDelete q = E.uninterruptibleMask_ $ do + deleteQueueRef st (senderId q) senders_ + forM_ (notifier q) $ \NtfCreds {notifierId} -> deleteQueueRef st notifierId notifiers_ + deleteQueueDir sq + atomically $ writeTVar qr Nothing + (q,) <$> atomically (swapTVar (msgQueue_' sq) Nothing) + remove :: Maybe (JournalMsgQueue s) -> IO (Maybe (JournalMsgQueue s)) + remove mq = do + mapM_ closeMsgQueueHandles mq + removeQueueDirectory st rId + pure mq closeMsgQueue :: JournalQueue s -> IO () closeMsgQueue JournalQueue {msgQueue_} = atomically (swapTVar msgQueue_ Nothing) >>= mapM_ closeMsgQueueHandles From 45a78639d872b43ff435583771620d44cb807dcb Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin Date: Fri, 13 Dec 2024 20:43:03 +0000 Subject: [PATCH 07/17] closeMsgStore --- src/Simplex/Messaging/Server/MsgStore/Journal.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/Simplex/Messaging/Server/MsgStore/Journal.hs b/src/Simplex/Messaging/Server/MsgStore/Journal.hs index 1dd5802a5..90270e136 100644 --- a/src/Simplex/Messaging/Server/MsgStore/Journal.hs +++ b/src/Simplex/Messaging/Server/MsgStore/Journal.hs @@ -291,7 +291,8 @@ instance MsgStoreClass (JournalMsgStore s) where MQStore {queues, storeLog} -> do readTVarIO storeLog >>= mapM_ closeStoreLog readTVarIO queues >>= mapM_ closeMsgQueue - JQStore {} -> undefined + JQStore {queues_} -> + readTVarIO queues_ >>= mapM_ (mapM closeMsgQueue) activeMsgQueues st = case queueStore st of MQStore {queues} -> queues From 3af3f475cf664231f8a586913c08c2161b0dee1b Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin Date: Sat, 14 Dec 2024 11:27:26 +0000 Subject: [PATCH 08/17] todo --- src/Simplex/Messaging/Server/MsgStore/Journal.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Simplex/Messaging/Server/MsgStore/Journal.hs b/src/Simplex/Messaging/Server/MsgStore/Journal.hs index 90270e136..4812f6d4f 100644 --- a/src/Simplex/Messaging/Server/MsgStore/Journal.hs +++ b/src/Simplex/Messaging/Server/MsgStore/Journal.hs @@ -285,7 +285,7 @@ instance MsgStoreClass (JournalMsgStore s) where setStoreLog :: JournalMsgStore s -> StoreLog 'WriteMode -> IO () setStoreLog st sl = case queueStore st of MQStore {storeLog} -> atomically $ writeTVar storeLog (Just sl) - JQStore {} -> undefined + JQStore {} -> undefined -- TODO [queues] closeMsgStore st = case queueStore st of MQStore {queues, storeLog} -> do @@ -296,7 +296,7 @@ instance MsgStoreClass (JournalMsgStore s) where activeMsgQueues st = case queueStore st of MQStore {queues} -> queues - JQStore {} -> undefined + JQStore {} -> undefined -- TODO [queues] -- 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. From a319a377a1a50a06f0c93cbb6a3237b23f5344e1 Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin Date: Sun, 15 Dec 2024 11:19:36 +0000 Subject: [PATCH 09/17] types for store --- src/Simplex/Messaging/Server.hs | 31 +++++++------- src/Simplex/Messaging/Server/Env/STM.hs | 38 +++++++++++------ src/Simplex/Messaging/Server/Main.hs | 41 ++++++++++++------- .../Messaging/Server/MsgStore/Journal.hs | 26 ++++++------ src/Simplex/Messaging/Server/MsgStore/STM.hs | 11 ++--- .../Messaging/Server/MsgStore/Types.hs | 15 ++++++- tests/CoreTests/MsgStoreTests.hs | 22 +++++----- tests/CoreTests/StoreLogTests.hs | 2 +- tests/SMPClient.hs | 15 +++---- tests/ServerTests.hs | 3 +- tests/Test.hs | 6 +-- 11 files changed, 126 insertions(+), 84 deletions(-) diff --git a/src/Simplex/Messaging/Server.hs b/src/Simplex/Messaging/Server.hs index ac9aa52f1..f99d945e5 100644 --- a/src/Simplex/Messaging/Server.hs +++ b/src/Simplex/Messaging/Server.hs @@ -94,7 +94,7 @@ import Simplex.Messaging.Server.Control import Simplex.Messaging.Server.Env.STM as Env import Simplex.Messaging.Server.Expiration import Simplex.Messaging.Server.MsgStore -import Simplex.Messaging.Server.MsgStore.Journal (JournalQueue, closeMsgQueue) +import Simplex.Messaging.Server.MsgStore.Journal (JournalMsgStore, JournalQueue, closeMsgQueue) import Simplex.Messaging.Server.MsgStore.STM import Simplex.Messaging.Server.MsgStore.Types import Simplex.Messaging.Server.NtfStore @@ -1706,7 +1706,7 @@ saveServerMessages drainMsgs = \case AMS SMSMemory ms@STMMsgStore {storeConfig = STMStoreConfig {storePath}} -> case storePath of Just f -> exportMessages False ms f drainMsgs Nothing -> logInfo "undelivered messages are not saved" - AMS SMSJournal _ -> logInfo "closed journal message storage" + AMS _ _ -> logInfo "closed journal message storage" exportMessages :: MsgStoreClass s => Bool -> s -> FilePath -> Bool -> IO () exportMessages tty ms f drainMsgs = do @@ -1738,16 +1738,20 @@ processServerMessages = do AMS SMSMemory ms@STMMsgStore {storeConfig = STMStoreConfig {storePath}} -> case storePath of Just f -> ifM (doesFileExist f) (Just <$> importMessages False ms f old_) (pure Nothing) Nothing -> pure Nothing - AMS SMSJournal ms - | expire -> Just <$> case old_ of - Just old -> do - logInfo "expiring journal store messages..." - withAllMsgQueues False ms $ processExpireQueue old - Nothing -> do - logInfo "validating journal store messages..." - withAllMsgQueues False ms $ processValidateQueue - | otherwise -> logWarn "skipping message expiration" $> Nothing - where + AMS SMSHybrid ms -> processJournalMessages old_ expire ms + AMS SMSJournal ms -> processJournalMessages old_ expire ms + processJournalMessages :: forall s. JournalStoreType s => Maybe Int64 -> Bool -> JournalMsgStore s -> IO (Maybe MessageStats) + processJournalMessages old_ expire ms + | expire = Just <$> case old_ of + Just old -> do + logInfo "expiring journal store messages..." + withAllMsgQueues False ms $ processExpireQueue old + Nothing -> do + logInfo "validating journal store messages..." + withAllMsgQueues False ms $ processValidateQueue + | otherwise = logWarn "skipping message expiration" $> Nothing + where + processExpireQueue :: Int64 -> JournalQueue s -> IO MessageStats processExpireQueue old q = runExceptT expireQueue >>= \case Right (storedMsgsCount, expiredMsgsCount) -> @@ -1761,7 +1765,7 @@ processServerMessages = do stored'' <- getQueueSize ms q liftIO $ closeMsgQueue q pure (stored'', expired'') - processValidateQueue :: JournalQueue 'MSMemory -> IO MessageStats + processValidateQueue :: JournalStoreType s => JournalQueue s -> IO MessageStats processValidateQueue q = runExceptT (getQueueSize ms q) >>= \case Right storedMsgsCount -> pure newMessageStats {storedMsgsCount, storedQueues = 1} @@ -1769,7 +1773,6 @@ processServerMessages = do logError $ "STORE: processValidateQueue, failed opening message queue, " <> tshow e exitFailure --- TODO this function should be called after importing queues from store log importMessages :: forall s. MsgStoreClass s => Bool -> s -> FilePath -> Maybe Int64 -> IO MessageStats importMessages tty ms f old_ = do logInfo $ "restoring messages from file " <> T.pack f diff --git a/src/Simplex/Messaging/Server/Env/STM.hs b/src/Simplex/Messaging/Server/Env/STM.hs index 05322e0f1..20ac37993 100644 --- a/src/Simplex/Messaging/Server/Env/STM.hs +++ b/src/Simplex/Messaging/Server/Env/STM.hs @@ -18,6 +18,7 @@ import Control.Monad import qualified Crypto.PubKey.RSA as RSA import Crypto.Random import Data.ByteString.Char8 (ByteString) +import Data.Functor (($>)) import Data.Int (Int64) import Data.IntMap.Strict (IntMap) import qualified Data.IntMap.Strict as IM @@ -184,7 +185,8 @@ data Env = Env type family MsgStore s where MsgStore 'MSMemory = STMMsgStore - MsgStore 'MSJournal = JournalMsgStore 'MSMemory + MsgStore 'MSHybrid = JournalMsgStore 'MSHybrid + MsgStore 'MSJournal = JournalMsgStore 'MSJournal data AMsgStore = forall s. MsgStoreClass (MsgStore s) => AMS (SMSType s) (MsgStore s) @@ -194,7 +196,7 @@ data AMsgStoreCfg = forall s. MsgStoreClass (MsgStore s) => AMSC (SMSType s) (Ms msgPersistence :: AMsgStoreCfg -> Bool msgPersistence (AMSC SMSMemory (STMStoreConfig {storePath})) = isJust storePath -msgPersistence (AMSC SMSJournal _) = True +msgPersistence _ = True type Subscribed = Bool @@ -291,19 +293,9 @@ newEnv :: ServerConfig -> IO Env newEnv config@ServerConfig {smpCredentials, httpCredentials, storeLogFile, msgStoreType, storeMsgsFile, smpAgentCfg, information, messageExpiration, idleQueueInterval, msgQueueQuota, maxJournalMsgCount, maxJournalStateLines} = do serverActive <- newTVarIO True server <- newServer - msgStore@(AMS _ store) <- case msgStoreType of - AMSType SMSMemory -> AMS SMSMemory <$> newMsgStore STMStoreConfig {storePath = storeMsgsFile, quota = msgQueueQuota} - AMSType SMSJournal -> case storeMsgsFile of - Just storePath -> - let cfg = JournalStoreConfig {storePath, quota = msgQueueQuota, pathParts = journalMsgStoreDepth, queueStoreType = SMSMemory, maxMsgCount = maxJournalMsgCount, maxStateLines = maxJournalStateLines, stateTailSize = defaultStateTailSize, idleInterval = idleQueueInterval} - in AMS SMSJournal <$> newMsgStore cfg - Nothing -> putStrLn "Error: journal msg store require path in [STORE_LOG], restore_messages" >> exitFailure + msgStore <- createMsgStore 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 @@ -316,6 +308,26 @@ 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 + createMsgStore :: IO AMsgStore + createMsgStore = case (msgStoreType, storeMsgsFile) of + (AMSType SMSMemory, _) -> do + st <- newMsgStore STMStoreConfig {storePath = storeMsgsFile, quota = msgQueueQuota} + loadStoreLog st $> AMS SMSMemory st + (AMSType SMSHybrid, Just storePath) -> do + st <- newMsgStore $ storeCfg SMSHybrid storePath + loadStoreLog st $> AMS SMSHybrid st + (AMSType SMSJournal, Just storePath) -> + AMS SMSJournal <$> newMsgStore (storeCfg SMSJournal storePath) + (_, Nothing) -> putStrLn "Error: journal msg store requires that restore_messages is enabled in [STORE_LOG]" >> exitFailure + where + storeCfg :: JournalStoreType s => SMSType s -> FilePath -> JournalStoreConfig s + storeCfg queueStoreType storePath = + JournalStoreConfig {storePath, quota = msgQueueQuota, pathParts = journalMsgStoreDepth, queueStoreType, maxMsgCount = maxJournalMsgCount, maxStateLines = maxJournalStateLines, stateTailSize = defaultStateTailSize, idleInterval = idleQueueInterval} + loadStoreLog :: STMQueueStore s => s -> IO () + loadStoreLog store = forM_ storeLogFile $ \f -> do + logInfo $ "restoring queues from file " <> T.pack f + sl <- readWriteQueueStore f store + setStoreLog store sl getCredentials protocol creds = do files <- missingCreds unless (null files) $ do diff --git a/src/Simplex/Messaging/Server/Main.hs b/src/Simplex/Messaging/Server/Main.hs index d5a3157dd..64fcef625 100644 --- a/src/Simplex/Messaging/Server/Main.hs +++ b/src/Simplex/Messaging/Server/Main.hs @@ -95,7 +95,7 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath = (putStrLn ("Store log file " <> storeLogFile <> " not found") >> exitFailure) Nothing -> putStrLn "Store log disabled, see `[STORE_LOG] enable`" >> exitFailure case cmd of - JCImport + JCImport (Just JSCMessages) | msgsFileExists && msgsDirExists -> exitConfigureMsgStorage | msgsDirExists -> do putStrLn $ storeMsgsJournalDir <> " directory already exists." @@ -114,9 +114,10 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath = 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`" + Right (AMSType _) -> "store_messages set to `journal`" -- TODO [queues] Left e -> e <> ", update it to `journal` in INI file" - JCExport + JCImport _ -> undefined -- TODO [queues] + JCExport (Just JSCMessages) | msgsFileExists && msgsDirExists -> exitConfigureMsgStorage | msgsFileExists -> do putStrLn $ storeMsgsFilePath <> " file already exists." @@ -131,8 +132,9 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath = 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" + Right _ -> "store_messages set to `journal`, update it to `memory` in INI file" -- TODO [queues] Left e -> e <> ", update it to `memory` in INI file" + JCExport _ -> undefined -- TODO [queues] JCDelete | not msgsDirExists -> do putStrLn $ storeMsgsJournalDir <> " directory does not exists." @@ -148,7 +150,7 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath = doesFileExist iniFile >>= \case True -> readIniFile iniFile >>= either exitError a _ -> exitError $ "Error: server is not initialized (" <> iniFile <> " does not exist).\nRun `" <> executableName <> " init`." - newJournalMsgStore = newMsgStore JournalStoreConfig {storePath = storeMsgsJournalDir, pathParts = journalMsgStoreDepth, queueStoreType = SMSMemory, quota = defaultMsgQueueQuota, maxMsgCount = defaultMaxJournalMsgCount, maxStateLines = defaultMaxJournalStateLines, stateTailSize = defaultStateTailSize, idleInterval = checkInterval defaultMessageExpiration} + newJournalMsgStore = newMsgStore JournalStoreConfig {storePath = storeMsgsJournalDir, pathParts = journalMsgStoreDepth, queueStoreType = SMSHybrid, quota = defaultMsgQueueQuota, maxMsgCount = defaultMaxJournalMsgCount, maxStateLines = defaultMaxJournalStateLines, stateTailSize = defaultStateTailSize, idleInterval = checkInterval defaultMessageExpiration} iniFile = combine cfgPath "smp-server.ini" serverVersion = "SMP server v" <> simplexMQVersion defaultServerPorts = "5223,443" @@ -161,7 +163,7 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath = readMsgStoreType = textToMsgStoreType . fromRight "memory" . lookupValue "STORE_LOG" "store_messages" textToMsgStoreType = \case "memory" -> Right $ AMSType SMSMemory - "journal" -> Right $ AMSType SMSJournal + "journal" -> Right $ AMSType SMSHybrid -- TODO [queues] s -> Left $ "invalid store_messages: " <> T.unpack s httpsCertFile = combine cfgPath "web.crt" httpsKeyFile = combine cfgPath "web.key" @@ -403,7 +405,7 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath = storeLogFile = enableStoreLog $> storeLogFilePath, storeMsgsFile = case iniMsgStoreType of AMSType SMSMemory -> restoreMessagesFile storeMsgsFilePath - AMSType SMSJournal -> Just storeMsgsJournalDir, + AMSType _ -> Just storeMsgsJournalDir, storeNtfsFile = restoreMessagesFile storeNtfsFilePath, -- allow creating new queues by default allowNewQueues = fromMaybe True $ iniOnOff "AUTH" "new_queues" ini, @@ -486,7 +488,8 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath = msgsFileExists <- doesFileExist storeMsgsFilePath case mode of _ | msgsFileExists && msgsDirExists -> exitConfigureMsgStorage - AMSType SMSJournal + AMSType SMSJournal -> undefined -- TODO [queues] + AMSType SMSHybrid | 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." @@ -634,7 +637,9 @@ data CliCommand | Delete | Journal JournalCmd -data JournalCmd = JCImport | JCExport | JCDelete +data JournalCmd = JCImport (Maybe JournalSubCmd) | JCExport (Maybe JournalSubCmd) | JCDelete + +data JournalSubCmd = JSCQueues | JSCMessages data InitOptions = InitOptions { enableStoreLog :: Bool, @@ -807,11 +812,19 @@ cliCommandP cfgPath logPath iniFile = scripted } journalCmdP = - 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")) - ) + hsubparser $ + command "import" (info (JCImport <$> optional (journalSubCmdP True)) (progDesc "Import log files into a new journal storage")) + <> command "export" (info (JCExport <$> optional (journalSubCmdP False)) (progDesc "Export journal storage to log files")) + <> command "delete" (info (pure JCDelete) (progDesc "Delete journal storage")) + journalSubCmdP importing + | importing = + hsubparser $ + command "queues" (info (pure JSCQueues) (progDesc "Import queues from store log file")) + <> command "messages" (info (pure JSCMessages) (progDesc "Import messages from message log log")) + | otherwise = + hsubparser $ + command "queues" (info (pure JSCQueues) (progDesc "Export queues to store log file")) + <> command "messages" (info (pure JSCMessages) (progDesc "Export messages to message log file")) parseBasicAuth :: ReadM ServerPassword parseBasicAuth = eitherReader $ fmap ServerPassword . strDecode . B.pack diff --git a/src/Simplex/Messaging/Server/MsgStore/Journal.hs b/src/Simplex/Messaging/Server/MsgStore/Journal.hs index 4812f6d4f..8554eaa32 100644 --- a/src/Simplex/Messaging/Server/MsgStore/Journal.hs +++ b/src/Simplex/Messaging/Server/MsgStore/Journal.hs @@ -14,6 +14,7 @@ {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TupleSections #-} +{-# LANGUAGE UndecidableInstances #-} module Simplex.Messaging.Server.MsgStore.Journal ( JournalMsgStore (queueStore, random), @@ -83,11 +84,11 @@ data JournalMsgStore s = JournalMsgStore data QueueStore (s :: MSType) where MQStore :: - { queues :: TMap RecipientId (JournalQueue 'MSMemory), + { queues :: TMap RecipientId (JournalQueue 'MSHybrid), senders :: TMap SenderId RecipientId, notifiers :: TMap NotifierId RecipientId, storeLog :: TVar (Maybe (StoreLog 'WriteMode)) - } -> QueueStore 'MSMemory + } -> QueueStore 'MSHybrid -- maps store cached queues -- Nothing in map indicates that the queue doesn't exist JQStore :: @@ -231,11 +232,16 @@ logFileExt = ".log" newtype StoreIO (s :: MSType) a = StoreIO {unStoreIO :: IO a} deriving newtype (Functor, Applicative, Monad) -instance STMQueueStore (JournalMsgStore 'MSMemory) where +instance STMQueueStore (JournalMsgStore 'MSHybrid) where queues' = queues . queueStore + {-# INLINE queues' #-} senders' = senders . queueStore + {-# INLINE senders' #-} notifiers' = notifiers . queueStore + {-# INLINE notifiers' #-} storeLog' = storeLog . queueStore + {-# INLINE storeLog' #-} + setStoreLog st sl = atomically $ writeTVar (storeLog' st) (Just sl) mkQueue st rId qr = do lock <- atomically $ getMapLock (queueLocks st) rId makeQueue st lock rId qr @@ -257,7 +263,7 @@ makeQueue st queueLock rId qr = do queueDirectory = msgQueueDirectory st rId } -instance MsgStoreClass (JournalMsgStore s) where +instance JournalStoreType s => MsgStoreClass (JournalMsgStore s) where type StoreMonad (JournalMsgStore s) = StoreIO s type StoreQueue (JournalMsgStore s) = JournalQueue s type MsgQueue (JournalMsgStore s) = JournalMsgQueue s @@ -268,7 +274,7 @@ instance MsgStoreClass (JournalMsgStore s) where random <- newTVarIO =<< newStdGen queueLocks :: TMap RecipientId Lock <- TM.emptyIO case queueStoreType config of - SMSMemory -> do + SMSHybrid -> do queues <- TM.emptyIO senders <- TM.emptyIO notifiers <- TM.emptyIO @@ -282,11 +288,6 @@ instance MsgStoreClass (JournalMsgStore s) where let queueStore = JQStore {queues_, senders_, notifiers_} pure JournalMsgStore {config, random, queueLocks, queueStore} - setStoreLog :: JournalMsgStore s -> StoreLog 'WriteMode -> IO () - setStoreLog st sl = case queueStore st of - MQStore {storeLog} -> atomically $ writeTVar storeLog (Just sl) - JQStore {} -> undefined -- TODO [queues] - closeMsgStore st = case queueStore st of MQStore {queues, storeLog} -> do readTVarIO storeLog >>= mapM_ closeStoreLog @@ -352,8 +353,7 @@ instance MsgStoreClass (JournalMsgStore s) where $>>= \mq -> readTVarIO (handles mq) $>>= (\hs -> (readTVarIO (state mq) >>= appendState (stateHandle hs)) $> Just ()) - -- TODO [queues] remove pun once recipientId is removed from QueueRec - recipientId' JournalQueue {recipientId} = recipientId + recipientId' = recipientId {-# INLINE recipientId' #-} queueRec' = queueRec @@ -382,7 +382,7 @@ instance MsgStoreClass (JournalMsgStore s) where withLock' lock "addQueue" $ withLockMap ls sId "addQueueS" $ withNotifierLock $ ifM hasAnyId (pure $ Left DUPLICATE_) $ E.uninterruptibleMask_ $ do q <- makeQueue st lock rId qr - -- TODO [queues] maybe createQueueDir + -- TODO [queues] maybe rename to createQueueDir storeQueue_ q qr atomically $ TM.insert rId (Just q) queues_ saveQueueRef st sId rId senders_ diff --git a/src/Simplex/Messaging/Server/MsgStore/STM.hs b/src/Simplex/Messaging/Server/MsgStore/STM.hs index a3a895415..024198923 100644 --- a/src/Simplex/Messaging/Server/MsgStore/STM.hs +++ b/src/Simplex/Messaging/Server/MsgStore/STM.hs @@ -61,9 +61,14 @@ data STMStoreConfig = STMStoreConfig instance STMQueueStore STMMsgStore where queues' = queues + {-# INLINE queues' #-} senders' = senders + {-# INLINE senders' #-} notifiers' = notifiers + {-# INLINE notifiers' #-} storeLog' = storeLog + {-# INLINE storeLog' #-} + setStoreLog st sl = atomically $ writeTVar (storeLog st) (Just sl) mkQueue _ rId qr = STMQueue rId <$> newTVarIO (Just qr) <*> newTVarIO Nothing instance MsgStoreClass STMMsgStore where @@ -80,9 +85,6 @@ instance MsgStoreClass STMMsgStore where storeLog <- newTVarIO Nothing pure STMMsgStore {storeConfig, queues, senders, notifiers, storeLog} - setStoreLog :: STMMsgStore -> StoreLog 'WriteMode -> IO () - setStoreLog st sl = atomically $ writeTVar (storeLog st) (Just sl) - closeMsgStore st = readTVarIO (storeLog st) >>= mapM_ closeStoreLog activeMsgQueues = queues @@ -95,8 +97,7 @@ instance MsgStoreClass STMMsgStore where logQueueState _ = pure () - -- TODO [queues] remove pun once recipientId is removed from QueueRec - recipientId' STMQueue {recipientId} = recipientId + recipientId' = recipientId {-# INLINE recipientId' #-} queueRec' = queueRec diff --git a/src/Simplex/Messaging/Server/MsgStore/Types.hs b/src/Simplex/Messaging/Server/MsgStore/Types.hs index d349e6eba..58bc2cc39 100644 --- a/src/Simplex/Messaging/Server/MsgStore/Types.hs +++ b/src/Simplex/Messaging/Server/MsgStore/Types.hs @@ -8,7 +8,9 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilyDependencies #-} +{-# LANGUAGE TypeOperators #-} {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} +{-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors #-} {-# HLINT ignore "Redundant multi-way if" #-} @@ -21,6 +23,8 @@ import Data.Functor (($>)) import Data.Int (Int64) import Data.Kind import Data.Time.Clock.System (SystemTime (systemSeconds)) +import GHC.TypeLits (ErrorMessage (..), TypeError) +import qualified GHC.TypeLits as Type import Simplex.Messaging.Protocol import Simplex.Messaging.Server.QueueStore import Simplex.Messaging.Server.StoreLog.Types @@ -33,6 +37,7 @@ class MsgStoreClass s => STMQueueStore s where senders' :: s -> TMap SenderId RecipientId notifiers' :: s -> TMap NotifierId RecipientId storeLog' :: s -> TVar (Maybe (StoreLog 'WriteMode)) + setStoreLog :: s -> StoreLog 'WriteMode -> IO () mkQueue :: s -> RecipientId -> QueueRec -> IO (StoreQueue s) class Monad (StoreMonad s) => MsgStoreClass s where @@ -41,7 +46,6 @@ class Monad (StoreMonad s) => MsgStoreClass s where type StoreQueue s = q | q -> s type MsgQueue s = q | q -> s newMsgStore :: MsgStoreConfig s -> IO s - setStoreLog :: s -> StoreLog 'WriteMode -> IO () closeMsgStore :: s -> IO () activeMsgQueues :: s -> TMap RecipientId (StoreQueue s) withAllMsgQueues :: Monoid a => Bool -> s -> (StoreQueue s -> IO a) -> IO a @@ -80,12 +84,19 @@ data QueueCounts = QueueCounts notifierCount :: Int } -data MSType = MSMemory | MSJournal +data MSType = MSMemory | MSHybrid | MSJournal data SMSType :: MSType -> Type where SMSMemory :: SMSType 'MSMemory + SMSHybrid :: SMSType 'MSHybrid SMSJournal :: SMSType 'MSJournal +type family JournalStoreType (s :: MSType) :: Constraint where + JournalStoreType 'MSHybrid = () + JournalStoreType 'MSJournal = () + JournalStoreType p = + (Int ~ Bool, TypeError ('Type.Text "Store " :<>: 'ShowType p :<>: 'Type.Text " is not journal")) + data AMSType = forall s. AMSType (SMSType s) getQueueRec :: (MsgStoreClass s, DirectParty p) => s -> SParty p -> QueueId -> IO (Either ErrorType (StoreQueue s, QueueRec)) diff --git a/tests/CoreTests/MsgStoreTests.hs b/tests/CoreTests/MsgStoreTests.hs index 0ce2fd1c3..beed5811a 100644 --- a/tests/CoreTests/MsgStoreTests.hs +++ b/tests/CoreTests/MsgStoreTests.hs @@ -68,12 +68,12 @@ withMsgStore cfg = bracket (newMsgStore cfg) closeMsgStore testSMTStoreConfig :: STMStoreConfig testSMTStoreConfig = STMStoreConfig {storePath = Nothing, quota = 3} -testJournalStoreCfg :: JournalStoreConfig 'MSMemory +testJournalStoreCfg :: JournalStoreConfig 'MSHybrid testJournalStoreCfg = JournalStoreConfig { storePath = testStoreMsgsDir, pathParts = journalMsgStoreDepth, - queueStoreType = SMSMemory, + queueStoreType = SMSHybrid, quota = 3, maxMsgCount = 4, maxStateLines = 2, @@ -177,7 +177,7 @@ testChangeReadJournal ms = do (Msg "message 5", Nothing) <- tryDelPeekMsg ms q mId5 void $ ExceptT $ deleteQueue ms q -testExportImportStore :: JournalMsgStore s -> IO () +testExportImportStore :: JournalStoreType s => JournalMsgStore s -> IO () testExportImportStore ms = do g <- C.newRandom (rId1, qr1) <- testNewQueueRec g True @@ -208,7 +208,7 @@ testExportImportStore ms = do closeStoreLog sl exportMessages False ms testStoreMsgsFile False (B.readFile testStoreMsgsFile `shouldReturn`) =<< B.readFile (testStoreMsgsFile <> ".copy") - let cfg = (testJournalStoreCfg :: JournalStoreConfig 'MSMemory) {storePath = testStoreMsgsDir2} + let cfg = (testJournalStoreCfg :: JournalStoreConfig 'MSHybrid) {storePath = testStoreMsgsDir2} ms' <- newMsgStore cfg readWriteQueueStore testStoreLogFile ms' >>= closeStoreLog stats@MessageStats {storedMsgsCount = 5, expiredMsgsCount = 0, storedQueues = 2} <- @@ -225,7 +225,7 @@ testExportImportStore ms = do exportMessages False stmStore testStoreMsgsFile False (B.sort <$> B.readFile testStoreMsgsFile `shouldReturn`) =<< (B.sort <$> B.readFile (testStoreMsgsFile2 <> ".bak")) -testQueueState :: JournalMsgStore s -> IO () +testQueueState :: JournalStoreType s => JournalMsgStore s -> IO () testQueueState ms = do g <- C.newRandom rId <- EntityId <$> atomically (C.randomBytes 24 g) @@ -290,7 +290,7 @@ testQueueState ms = do let f = dir name in unless (f == keep) $ removeFile f -testMessageState :: JournalMsgStore s -> IO () +testMessageState :: JournalStoreType s => JournalMsgStore s -> IO () testMessageState ms = do g <- C.newRandom (rId, qr) <- testNewQueueRec g True @@ -315,7 +315,7 @@ testMessageState ms = do (Msg "message 3", Nothing) <- tryDelPeekMsg ms q mId3 liftIO $ closeMsgQueue q -testReadFileMissing :: JournalMsgStore s -> IO () +testReadFileMissing :: JournalStoreType s => JournalMsgStore s -> IO () testReadFileMissing ms = do g <- C.newRandom (rId, qr) <- testNewQueueRec g True @@ -339,7 +339,7 @@ testReadFileMissing ms = do Msg "message 2" <- tryPeekMsg ms q' pure () -testReadFileMissingSwitch :: JournalMsgStore s -> IO () +testReadFileMissingSwitch :: JournalStoreType s => JournalMsgStore s -> IO () testReadFileMissingSwitch ms = do g <- C.newRandom (rId, qr) <- testNewQueueRec g True @@ -357,7 +357,7 @@ testReadFileMissingSwitch ms = do Msg "message 5" <- tryPeekMsg ms q' pure () -testWriteFileMissing :: JournalMsgStore s -> IO () +testWriteFileMissing :: JournalStoreType s => JournalMsgStore s -> IO () testWriteFileMissing ms = do g <- C.newRandom (rId, qr) <- testNewQueueRec g True @@ -380,7 +380,7 @@ testWriteFileMissing ms = do Msg "message 6" <- tryPeekMsg ms q' pure () -testReadAndWriteFilesMissing :: JournalMsgStore s -> IO () +testReadAndWriteFilesMissing :: JournalStoreType s => JournalMsgStore s -> IO () testReadAndWriteFilesMissing ms = do g <- C.newRandom (rId, qr) <- testNewQueueRec g True @@ -399,7 +399,7 @@ testReadAndWriteFilesMissing ms = do Msg "message 6" <- tryPeekMsg ms q' pure () -writeMessages :: JournalMsgStore s -> RecipientId -> QueueRec -> IO (JournalQueue s) +writeMessages :: JournalStoreType s => JournalMsgStore s -> RecipientId -> QueueRec -> IO (JournalQueue s) writeMessages ms rId qr = runRight $ do q <- ExceptT $ addQueue ms rId qr let write s = writeMsg ms q True =<< mkMessage s diff --git a/tests/CoreTests/StoreLogTests.hs b/tests/CoreTests/StoreLogTests.hs index b95a4494b..104ecbdec 100644 --- a/tests/CoreTests/StoreLogTests.hs +++ b/tests/CoreTests/StoreLogTests.hs @@ -108,5 +108,5 @@ testSMPStoreLog testSuite tests = closeStoreLog l ([], compacted') <- partitionEithers . map strDecode . B.lines <$> B.readFile testStoreLogFile compacted' `shouldBe` compacted - storeState :: JournalMsgStore 'MSMemory -> IO (M.Map RecipientId QueueRec) + storeState :: JournalMsgStore 'MSHybrid -> IO (M.Map RecipientId QueueRec) storeState st = M.mapMaybe id <$> (readTVarIO (queues' st) >>= mapM (readTVarIO . queueRec')) diff --git a/tests/SMPClient.hs b/tests/SMPClient.hs index d658c30a6..af08f5498 100644 --- a/tests/SMPClient.hs +++ b/tests/SMPClient.hs @@ -111,7 +111,7 @@ testSMPClient_ host port vr client = do | otherwise = Nothing cfg :: ServerConfig -cfg = cfgMS (AMSType SMSJournal) +cfg = cfgMS (AMSType SMSHybrid) -- TODO [queues] cfgMS :: AMSType -> ServerConfig cfgMS msType = @@ -127,8 +127,9 @@ cfgMS msType = msgIdBytes = 24, storeLogFile = Just testStoreLogFile, storeMsgsFile = Just $ case msType of - AMSType SMSJournal -> testStoreMsgsDir - AMSType SMSMemory -> testStoreMsgsFile, + AMSType SMSMemory -> testStoreMsgsFile + AMSType SMSHybrid -> testStoreMsgsDir + AMSType SMSJournal -> testStoreMsgsDir, storeNtfsFile = Nothing, allowNewQueues = True, newQueueBasicAuth = Nothing, @@ -189,14 +190,14 @@ proxyVRangeV8 :: VersionRangeSMP proxyVRangeV8 = mkVersionRange batchCmdsSMPVersion sendingProxySMPVersion withSmpServerStoreMsgLogOn :: HasCallStack => ATransport -> ServiceName -> (HasCallStack => ThreadId -> IO a) -> IO a -withSmpServerStoreMsgLogOn = (`withSmpServerStoreMsgLogOnMS` AMSType SMSJournal) +withSmpServerStoreMsgLogOn = (`withSmpServerStoreMsgLogOnMS` AMSType SMSHybrid) -- TODO [queues] withSmpServerStoreMsgLogOnMS :: HasCallStack => ATransport -> AMSType -> ServiceName -> (HasCallStack => ThreadId -> IO a) -> IO a withSmpServerStoreMsgLogOnMS t msType = withSmpServerConfigOn t (cfgMS msType) {storeNtfsFile = Just testStoreNtfsFile, serverStatsBackupFile = Just testServerStatsBackupFile} withSmpServerStoreLogOn :: HasCallStack => ATransport -> ServiceName -> (HasCallStack => ThreadId -> IO a) -> IO a -withSmpServerStoreLogOn = (`withSmpServerStoreLogOnMS` AMSType SMSJournal) +withSmpServerStoreLogOn = (`withSmpServerStoreLogOnMS` AMSType SMSHybrid) -- TODO [queues] withSmpServerStoreLogOnMS :: HasCallStack => ATransport -> AMSType -> ServiceName -> (HasCallStack => ThreadId -> IO a) -> IO a withSmpServerStoreLogOnMS t msType = withSmpServerConfigOn t (cfgMS msType) {serverStatsBackupFile = Just testServerStatsBackupFile} @@ -251,7 +252,7 @@ smpServerTest :: TProxy c -> (Maybe TransmissionAuth, ByteString, ByteString, smp) -> IO (Maybe TransmissionAuth, ByteString, ByteString, BrokerMsg) -smpServerTest _ t = runSmpTest (AMSType SMSJournal) $ \h -> tPut' h t >> tGet' h +smpServerTest _ t = runSmpTest (AMSType SMSHybrid) $ \h -> tPut' h t >> tGet' h -- TODO [queues] where tPut' :: THandleSMP c 'TClient -> (Maybe TransmissionAuth, ByteString, ByteString, smp) -> IO () tPut' h@THandle {params = THandleParams {sessionId, implySessId}} (sig, corrId, queueId, smp) = do @@ -269,7 +270,7 @@ smpTestN :: (HasCallStack, Transport c) => AMSType -> Int -> (HasCallStack => [T smpTestN msType n test' = runSmpTestN msType n test' `shouldReturn` () smpTest2' :: forall c. (HasCallStack, Transport c) => TProxy c -> (HasCallStack => THandleSMP c 'TClient -> THandleSMP c 'TClient -> IO ()) -> Expectation -smpTest2' = (`smpTest2` AMSType SMSJournal) +smpTest2' = (`smpTest2` AMSType SMSHybrid) -- TODO [queues] smpTest2 :: forall c. (HasCallStack, Transport c) => TProxy c -> AMSType -> (HasCallStack => THandleSMP c 'TClient -> THandleSMP c 'TClient -> IO ()) -> Expectation smpTest2 t msType = smpTest2Cfg (cfgMS msType) supportedClientSMPRelayVRange t diff --git a/tests/ServerTests.hs b/tests/ServerTests.hs index 744ceb437..15765268d 100644 --- a/tests/ServerTests.hs +++ b/tests/ServerTests.hs @@ -811,7 +811,8 @@ testRestoreExpireMessages = where exportStoreMessages :: AMSType -> IO () exportStoreMessages = \case - AMSType SMSJournal -> do + AMSType SMSJournal -> undefined -- TODO [queues] + AMSType SMSHybrid -> do ms <- newMsgStore testJournalStoreCfg {quota = 4} readWriteQueueStore testStoreLogFile ms >>= closeStoreLog removeFileIfExists testStoreMsgsFile diff --git a/tests/Test.hs b/tests/Test.hs index f8505b133..ede658d21 100644 --- a/tests/Test.hs +++ b/tests/Test.hs @@ -61,14 +61,14 @@ main = do describe "Store log tests" storeLogTests describe "TRcvQueues tests" tRcvQueuesTests describe "Util tests" utilTests - describe "SMP server via TLS, jornal message store" $ do + describe "SMP server via TLS, hybrid message store" $ do describe "SMP syntax" $ serverSyntaxTests (transport @TLS) - before (pure (transport @TLS, AMSType SMSJournal)) serverTests + before (pure (transport @TLS, AMSType SMSHybrid)) serverTests describe "SMP server via TLS, memory message store" $ before (pure (transport @TLS, AMSType SMSMemory)) serverTests -- xdescribe "SMP server via WebSockets" $ do -- describe "SMP syntax" $ serverSyntaxTests (transport @WS) - -- before (pure (transport @WS, AMSType SMSJournal)) serverTests + -- before (pure (transport @WS, AMSType SMSHybrid)) serverTests describe "Notifications server" $ ntfServerTests (transport @TLS) describe "SMP client agent" $ agentTests (transport @TLS) describe "SMP proxy" smpProxyTests From 14aed2dda7963d6679bbd5182fe74b83a077ee33 Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin Date: Sun, 15 Dec 2024 16:38:09 +0000 Subject: [PATCH 10/17] refactor --- src/Simplex/Messaging/Server.hs | 2 +- src/Simplex/Messaging/Server/Env/STM.hs | 12 +- src/Simplex/Messaging/Server/Main.hs | 2 + .../Messaging/Server/MsgStore/Journal.hs | 60 ++++------ src/Simplex/Messaging/Server/MsgStore/STM.hs | 53 +++------ .../Messaging/Server/MsgStore/Types.hs | 15 ++- .../Messaging/Server/QueueStore/STM.hs | 109 +++++++++++++----- src/Simplex/Messaging/Server/StoreLog.hs | 43 +------ tests/CoreTests/MsgStoreTests.hs | 12 +- tests/CoreTests/StoreLogTests.hs | 2 +- 10 files changed, 149 insertions(+), 161 deletions(-) diff --git a/src/Simplex/Messaging/Server.hs b/src/Simplex/Messaging/Server.hs index f99d945e5..544f769b9 100644 --- a/src/Simplex/Messaging/Server.hs +++ b/src/Simplex/Messaging/Server.hs @@ -1765,7 +1765,7 @@ processServerMessages = do stored'' <- getQueueSize ms q liftIO $ closeMsgQueue q pure (stored'', expired'') - processValidateQueue :: JournalStoreType s => JournalQueue s -> IO MessageStats + processValidateQueue :: JournalQueue s -> IO MessageStats processValidateQueue q = runExceptT (getQueueSize ms q) >>= \case Right storedMsgsCount -> pure newMessageStats {storedMsgsCount, storedQueues = 1} diff --git a/src/Simplex/Messaging/Server/Env/STM.hs b/src/Simplex/Messaging/Server/Env/STM.hs index 20ac37993..6e9849715 100644 --- a/src/Simplex/Messaging/Server/Env/STM.hs +++ b/src/Simplex/Messaging/Server/Env/STM.hs @@ -320,14 +320,14 @@ newEnv config@ServerConfig {smpCredentials, httpCredentials, storeLogFile, msgSt AMS SMSJournal <$> newMsgStore (storeCfg SMSJournal storePath) (_, Nothing) -> putStrLn "Error: journal msg store requires that restore_messages is enabled in [STORE_LOG]" >> exitFailure where - storeCfg :: JournalStoreType s => SMSType s -> FilePath -> JournalStoreConfig s + storeCfg :: SMSType s -> FilePath -> JournalStoreConfig s storeCfg queueStoreType storePath = JournalStoreConfig {storePath, quota = msgQueueQuota, pathParts = journalMsgStoreDepth, queueStoreType, maxMsgCount = maxJournalMsgCount, maxStateLines = maxJournalStateLines, stateTailSize = defaultStateTailSize, idleInterval = idleQueueInterval} - loadStoreLog :: STMQueueStore s => s -> IO () - loadStoreLog store = forM_ storeLogFile $ \f -> do + loadStoreLog :: STMStoreClass s => s -> IO () + loadStoreLog st = forM_ storeLogFile $ \f -> do logInfo $ "restoring queues from file " <> T.pack f - sl <- readWriteQueueStore f store - setStoreLog store sl + sl <- readWriteQueueStore f st + setStoreLog (stmQueueStore st) sl getCredentials protocol creds = do files <- missingCreds unless (null files) $ do @@ -371,5 +371,5 @@ newSMPProxyAgent smpAgentCfg random = do smpAgent <- newSMPClientAgent smpAgentCfg random pure ProxyAgent {smpAgent} -readWriteQueueStore :: MsgStoreClass s => FilePath -> s -> IO (StoreLog 'WriteMode) +readWriteQueueStore :: STMStoreClass s => FilePath -> s -> IO (StoreLog 'WriteMode) readWriteQueueStore = readWriteStoreLog readQueueStore writeQueueStore diff --git a/src/Simplex/Messaging/Server/Main.hs b/src/Simplex/Messaging/Server/Main.hs index 64fcef625..3935ae0f9 100644 --- a/src/Simplex/Messaging/Server/Main.hs +++ b/src/Simplex/Messaging/Server/Main.hs @@ -108,6 +108,7 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath = ("WARNING: message log file " <> storeMsgsFilePath <> " will be imported to journal directory " <> storeMsgsJournalDir) "Messages not imported" ms <- newJournalMsgStore + -- TODO [queues] it should not load queues if queues are in journal readQueueStore storeLogFile ms msgStats <- importMessages True ms storeMsgsFilePath Nothing -- no expiration putStrLn "Import completed" @@ -127,6 +128,7 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath = ("WARNING: journal directory " <> storeMsgsJournalDir <> " will be exported to message log file " <> storeMsgsFilePath) "Journal not exported" ms <- newJournalMsgStore + -- TODO [queues] it should not load queues if queues are in journal readQueueStore storeLogFile ms exportMessages True ms storeMsgsFilePath False putStrLn "Export completed" diff --git a/src/Simplex/Messaging/Server/MsgStore/Journal.hs b/src/Simplex/Messaging/Server/MsgStore/Journal.hs index 8554eaa32..2074ef493 100644 --- a/src/Simplex/Messaging/Server/MsgStore/Journal.hs +++ b/src/Simplex/Messaging/Server/MsgStore/Journal.hs @@ -18,6 +18,7 @@ module Simplex.Messaging.Server.MsgStore.Journal ( JournalMsgStore (queueStore, random), + QueueStore (..), JournalQueue (queueDirectory), JournalMsgQueue (state), JournalStoreConfig (..), @@ -83,12 +84,7 @@ data JournalMsgStore s = JournalMsgStore } data QueueStore (s :: MSType) where - MQStore :: - { queues :: TMap RecipientId (JournalQueue 'MSHybrid), - senders :: TMap SenderId RecipientId, - notifiers :: TMap NotifierId RecipientId, - storeLog :: TVar (Maybe (StoreLog 'WriteMode)) - } -> QueueStore 'MSHybrid + MQStore :: STMQueueStore (JournalQueue 'MSHybrid) -> QueueStore 'MSHybrid -- maps store cached queues -- Nothing in map indicates that the queue doesn't exist JQStore :: @@ -232,16 +228,8 @@ logFileExt = ".log" newtype StoreIO (s :: MSType) a = StoreIO {unStoreIO :: IO a} deriving newtype (Functor, Applicative, Monad) -instance STMQueueStore (JournalMsgStore 'MSHybrid) where - queues' = queues . queueStore - {-# INLINE queues' #-} - senders' = senders . queueStore - {-# INLINE senders' #-} - notifiers' = notifiers . queueStore - {-# INLINE notifiers' #-} - storeLog' = storeLog . queueStore - {-# INLINE storeLog' #-} - setStoreLog st sl = atomically $ writeTVar (storeLog' st) (Just sl) +instance STMStoreClass (JournalMsgStore 'MSHybrid) where + stmQueueStore JournalMsgStore {queueStore = MQStore st} = st mkQueue st rId qr = do lock <- atomically $ getMapLock (queueLocks st) rId makeQueue st lock rId qr @@ -275,11 +263,7 @@ instance JournalStoreType s => MsgStoreClass (JournalMsgStore s) where queueLocks :: TMap RecipientId Lock <- TM.emptyIO case queueStoreType config of SMSHybrid -> do - queues <- TM.emptyIO - senders <- TM.emptyIO - notifiers <- TM.emptyIO - storeLog <- newTVarIO Nothing - let queueStore = MQStore {queues, senders, notifiers, storeLog} + queueStore <- MQStore <$> newQueueStore pure JournalMsgStore {config, random, queueLocks, queueStore} SMSJournal -> do queues_ <- TM.emptyIO @@ -288,15 +272,15 @@ instance JournalStoreType s => MsgStoreClass (JournalMsgStore s) where let queueStore = JQStore {queues_, senders_, notifiers_} pure JournalMsgStore {config, random, queueLocks, queueStore} - closeMsgStore st = case queueStore st of - MQStore {queues, storeLog} -> do - readTVarIO storeLog >>= mapM_ closeStoreLog - readTVarIO queues >>= mapM_ closeMsgQueue + closeMsgStore ms = case queueStore ms of + MQStore st -> do + readTVarIO (storeLog st) >>= mapM_ closeStoreLog + readTVarIO (queues st) >>= mapM_ closeMsgQueue JQStore {queues_} -> readTVarIO queues_ >>= mapM_ (mapM closeMsgQueue) - activeMsgQueues st = case queueStore st of - MQStore {queues} -> queues + activeMsgQueues ms = case queueStore ms of + MQStore st -> queues st JQStore {} -> undefined -- TODO [queues] -- This function is a "foldr" that opens and closes all queues, processes them as defined by action and accumulates the result. @@ -363,10 +347,10 @@ instance JournalStoreType s => MsgStoreClass (JournalMsgStore s) where {-# INLINE msgQueue_' #-} queueCounts :: JournalMsgStore s -> IO QueueCounts - queueCounts st = case queueStore st of - MQStore {queues, notifiers} -> do - queueCount <- M.size <$> readTVarIO queues - notifierCount <- M.size <$> readTVarIO notifiers + queueCounts ms = case queueStore ms of + MQStore st -> do + queueCount <- M.size <$> readTVarIO (queues st) + notifierCount <- M.size <$> readTVarIO (notifiers st) pure QueueCounts {queueCount, notifierCount} JQStore {queues_, notifiers_} -> do queueCount <- M.size <$> readTVarIO queues_ @@ -398,7 +382,7 @@ instance JournalStoreType s => MsgStoreClass (JournalMsgStore s) where getQueue :: DirectParty p => JournalMsgStore s -> SParty p -> QueueId -> IO (Either ErrorType (JournalQueue s)) getQueue st party qId = case queueStore st of - MQStore {} -> getQueue' st party qId + MQStore st' -> getQueue' st' party qId JQStore {queues_, senders_, notifiers_} -> isolateQueueId "getQueue" st qId $ maybe (Left AUTH) Right <$> case party of @@ -414,7 +398,7 @@ instance JournalStoreType s => MsgStoreClass (JournalMsgStore s) where secureQueue :: JournalMsgStore s -> JournalQueue s -> SndPublicAuthKey -> IO (Either ErrorType ()) secureQueue st sq sKey = case queueStore st of - MQStore {} -> secureQueue' st sq sKey + MQStore st' -> secureQueue' st' sq sKey JQStore {} -> isolateQueueRec sq "secureQueue" $ \q -> case senderKey q of Just k -> pure $ if sKey == k then Right () else Left AUTH @@ -422,7 +406,7 @@ instance JournalStoreType s => MsgStoreClass (JournalMsgStore s) where addQueueNotifier :: JournalMsgStore s -> JournalQueue s -> NtfCreds -> IO (Either ErrorType (Maybe NotifierId)) addQueueNotifier st sq ntfCreds@NtfCreds {notifierId = nId} = case queueStore st of - MQStore {} -> addQueueNotifier' st sq ntfCreds + MQStore st' -> addQueueNotifier' st' sq ntfCreds JQStore {notifiers_} -> isolateQueueRec sq "addQueueNotifier" $ \q -> withLockMap (queueLocks st) nId "addQueueNotifierN" $ @@ -440,7 +424,7 @@ instance JournalStoreType s => MsgStoreClass (JournalMsgStore s) where deleteQueueNotifier :: JournalMsgStore s -> JournalQueue s -> IO (Either ErrorType (Maybe NotifierId)) deleteQueueNotifier st sq = case queueStore st of - MQStore {} -> deleteQueueNotifier' st sq + MQStore st' -> deleteQueueNotifier' st' sq JQStore {notifiers_} -> isolateQueueRec sq "deleteQueueNotifier" $ \q -> fmap Right $ forM (notifier q) $ \NtfCreds {notifierId = nId} -> @@ -451,14 +435,14 @@ instance JournalStoreType s => MsgStoreClass (JournalMsgStore s) where suspendQueue :: JournalMsgStore s -> JournalQueue s -> IO (Either ErrorType ()) suspendQueue st sq = case queueStore st of - MQStore {} -> suspendQueue' st sq + MQStore st' -> suspendQueue' st' sq JQStore {} -> isolateQueueRec sq "suspendQueue" $ \q -> fmap Right $ storeQueue sq q {status = QueueOff} updateQueueTime :: JournalMsgStore s -> JournalQueue s -> RoundedSystemTime -> IO (Either ErrorType QueueRec) updateQueueTime st sq t = case queueStore st of - MQStore {} -> updateQueueTime' st sq t + MQStore st' -> updateQueueTime' st' sq t JQStore {} -> isolateQueueRec sq "updateQueueTime" $ fmap Right . update where update q@QueueRec {updatedAt} @@ -915,7 +899,7 @@ deleteQueue_ st sq = qr = queueRec sq delete :: IO (Either ErrorType (QueueRec, Maybe (JournalMsgQueue s))) delete = case queueStore st of - MQStore {} -> deleteQueue' st sq + MQStore st' -> deleteQueue' st' sq JQStore {senders_, notifiers_} -> atomically (readQueueRec qr) >>= mapM jqDelete where jqDelete q = E.uninterruptibleMask_ $ do diff --git a/src/Simplex/Messaging/Server/MsgStore/STM.hs b/src/Simplex/Messaging/Server/MsgStore/STM.hs index 024198923..a72a99bc4 100644 --- a/src/Simplex/Messaging/Server/MsgStore/STM.hs +++ b/src/Simplex/Messaging/Server/MsgStore/STM.hs @@ -27,17 +27,11 @@ import Simplex.Messaging.Server.MsgStore.Types import Simplex.Messaging.Server.QueueStore import Simplex.Messaging.Server.QueueStore.STM import Simplex.Messaging.Server.StoreLog -import Simplex.Messaging.TMap (TMap) -import qualified Simplex.Messaging.TMap as TM import Simplex.Messaging.Util ((<$$>), ($>>=)) -import System.IO (IOMode (..)) data STMMsgStore = STMMsgStore { storeConfig :: STMStoreConfig, - queues :: TMap RecipientId STMQueue, - senders :: TMap SenderId RecipientId, - notifiers :: TMap NotifierId RecipientId, - storeLog :: TVar (Maybe (StoreLog 'WriteMode)) + queueStore :: STMQueueStore STMQueue } data STMQueue = STMQueue @@ -59,16 +53,8 @@ data STMStoreConfig = STMStoreConfig quota :: Int } -instance STMQueueStore STMMsgStore where - queues' = queues - {-# INLINE queues' #-} - senders' = senders - {-# INLINE senders' #-} - notifiers' = notifiers - {-# INLINE notifiers' #-} - storeLog' = storeLog - {-# INLINE storeLog' #-} - setStoreLog st sl = atomically $ writeTVar (storeLog st) (Just sl) +instance STMStoreClass STMMsgStore where + stmQueueStore = queueStore mkQueue _ rId qr = STMQueue rId <$> newTVarIO (Just qr) <*> newTVarIO Nothing instance MsgStoreClass STMMsgStore where @@ -78,16 +64,11 @@ instance MsgStoreClass STMMsgStore where type MsgStoreConfig STMMsgStore = STMStoreConfig newMsgStore :: STMStoreConfig -> IO STMMsgStore - newMsgStore storeConfig = do - queues <- TM.emptyIO - senders <- TM.emptyIO - notifiers <- TM.emptyIO - storeLog <- newTVarIO Nothing - pure STMMsgStore {storeConfig, queues, senders, notifiers, storeLog} + newMsgStore storeConfig = STMMsgStore storeConfig <$> newQueueStore - closeMsgStore st = readTVarIO (storeLog st) >>= mapM_ closeStoreLog + closeMsgStore st = readTVarIO (storeLog $ queueStore st) >>= mapM_ closeStoreLog - activeMsgQueues = queues + activeMsgQueues = queues . queueStore {-# INLINE activeMsgQueues #-} withAllMsgQueues _ = withActiveMsgQueues @@ -107,30 +88,30 @@ instance MsgStoreClass STMMsgStore where {-# INLINE msgQueue_' #-} queueCounts :: STMMsgStore -> IO QueueCounts - queueCounts st = do - queueCount <- M.size <$> readTVarIO (queues st) - notifierCount <- M.size <$> readTVarIO (notifiers st) + queueCounts STMMsgStore {queueStore} = do + queueCount <- M.size <$> readTVarIO (queues queueStore) + notifierCount <- M.size <$> readTVarIO (notifiers queueStore) pure QueueCounts {queueCount, notifierCount} addQueue = addQueue' {-# INLINE addQueue #-} - getQueue = getQueue' + getQueue = getQueue' . queueStore {-# INLINE getQueue #-} - secureQueue = secureQueue' + secureQueue = secureQueue' . queueStore {-# INLINE secureQueue #-} - addQueueNotifier = addQueueNotifier' + addQueueNotifier = addQueueNotifier' . queueStore {-# INLINE addQueueNotifier #-} - deleteQueueNotifier = deleteQueueNotifier' + deleteQueueNotifier = deleteQueueNotifier' . queueStore {-# INLINE deleteQueueNotifier #-} - suspendQueue = suspendQueue' + suspendQueue = suspendQueue' . queueStore {-# INLINE suspendQueue #-} - updateQueueTime = updateQueueTime' + updateQueueTime = updateQueueTime' . queueStore {-# INLINE updateQueueTime #-} getMsgQueue :: STMMsgStore -> STMQueue -> STM STMMsgQueue @@ -157,10 +138,10 @@ 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 <$$> deleteQueue' (queueStore ms) q deleteQueueSize :: STMMsgStore -> STMQueue -> IO (Either ErrorType (QueueRec, Int)) - deleteQueueSize ms q = deleteQueue' ms q >>= mapM (traverse getSize) + deleteQueueSize ms q = deleteQueue' (queueStore ms) q >>= mapM (traverse getSize) -- traverse operates on the second tuple element where getSize = maybe (pure 0) (\STMMsgQueue {size} -> readTVarIO size) diff --git a/src/Simplex/Messaging/Server/MsgStore/Types.hs b/src/Simplex/Messaging/Server/MsgStore/Types.hs index 58bc2cc39..c5fba950f 100644 --- a/src/Simplex/Messaging/Server/MsgStore/Types.hs +++ b/src/Simplex/Messaging/Server/MsgStore/Types.hs @@ -32,12 +32,15 @@ import Simplex.Messaging.TMap (TMap) import Simplex.Messaging.Util ((<$$>), ($>>=)) import System.IO (IOMode (..)) -class MsgStoreClass s => STMQueueStore s where - queues' :: s -> TMap RecipientId (StoreQueue s) - senders' :: s -> TMap SenderId RecipientId - notifiers' :: s -> TMap NotifierId RecipientId - storeLog' :: s -> TVar (Maybe (StoreLog 'WriteMode)) - setStoreLog :: s -> StoreLog 'WriteMode -> IO () +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 -> IO (StoreQueue s) class Monad (StoreMonad s) => MsgStoreClass s where diff --git a/src/Simplex/Messaging/Server/QueueStore/STM.hs b/src/Simplex/Messaging/Server/QueueStore/STM.hs index 8836468b1..f0ce8b8d6 100644 --- a/src/Simplex/Messaging/Server/QueueStore/STM.hs +++ b/src/Simplex/Messaging/Server/QueueStore/STM.hs @@ -14,7 +14,10 @@ {-# LANGUAGE UndecidableInstances #-} module Simplex.Messaging.Server.QueueStore.STM - ( addQueue', + ( STMQueueStore (..), + newQueueStore, + setStoreLog, + addQueue', getQueue', secureQueue', addQueueNotifier', @@ -31,39 +34,57 @@ 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 qualified Data.ByteString.Lazy.Char8 as LB import Data.Functor (($>)) 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.StoreLog import qualified Simplex.Messaging.TMap as TM -import Simplex.Messaging.Util (anyM, ifM, ($>>=), (<$$)) +import Simplex.Messaging.Util (anyM, ifM, tshow, ($>>=), (<$$)) import System.IO import UnliftIO.STM -addQueue' :: STMQueueStore s => s -> RecipientId -> QueueRec -> IO (Either ErrorType (StoreQueue s)) -addQueue' st rId qr@QueueRec {senderId = sId, notifier} = - (mkQueue st rId qr >>= atomically . add) +newQueueStore :: IO (STMQueueStore q) +newQueueStore = do + queues <- TM.emptyIO + senders <- TM.emptyIO + notifiers <- TM.emptyIO + storeLog <- newTVarIO Nothing + pure STMQueueStore {queues, senders, notifiers, storeLog} + +setStoreLog :: STMQueueStore q -> StoreLog 'WriteMode -> IO () +setStoreLog st sl = atomically $ writeTVar (storeLog st) (Just sl) + +addQueue' :: STMStoreClass s => s -> RecipientId -> QueueRec -> IO (Either ErrorType (StoreQueue s)) +addQueue' ms rId qr@QueueRec {senderId = sId, notifier} = + (mkQueue ms rId qr >>= atomically . add) $>>= \q -> q <$$ withLog "addQueue" st (\s -> logCreateQueue s rId qr) where + st = stmQueueStore ms add q = ifM hasId (pure $ Left DUPLICATE_) $ do - TM.insert rId q $ queues' st - TM.insert sId rId $ senders' st - forM_ notifier $ \NtfCreds {notifierId} -> TM.insert notifierId rId $ notifiers' st + TM.insert rId q $ queues st + TM.insert sId rId $ senders st + forM_ notifier $ \NtfCreds {notifierId} -> TM.insert notifierId rId $ notifiers st pure $ Right q - hasId = anyM [TM.member rId $ queues' st, TM.member sId $ senders' st, hasNotifier] - hasNotifier = maybe (pure False) (\NtfCreds {notifierId} -> TM.member notifierId (notifiers' st)) notifier + hasId = anyM [TM.member rId $ queues st, TM.member sId $ senders st, hasNotifier] + hasNotifier = maybe (pure False) (\NtfCreds {notifierId} -> TM.member notifierId (notifiers st)) notifier -getQueue' :: (STMQueueStore s, DirectParty p) => s -> SParty p -> QueueId -> IO (Either ErrorType (StoreQueue s)) +getQueue' :: DirectParty p => STMQueueStore q -> SParty p -> QueueId -> IO (Either ErrorType q) getQueue' st party qId = maybe (Left AUTH) Right <$> case party of - SRecipient -> TM.lookupIO qId $ queues' st - SSender -> TM.lookupIO qId (senders' st) $>>= (`TM.lookupIO` queues' st) - SNotifier -> TM.lookupIO qId (notifiers' st) $>>= (`TM.lookupIO` queues' st) + SRecipient -> TM.lookupIO qId $ queues st + SSender -> TM.lookupIO qId (senders st) $>>= (`TM.lookupIO` queues st) + SNotifier -> TM.lookupIO qId (notifiers st) $>>= (`TM.lookupIO` queues st) -secureQueue' :: STMQueueStore s => s -> StoreQueue s -> SndPublicAuthKey -> IO (Either ErrorType ()) +secureQueue' :: MsgStoreClass s => STMQueueStore (StoreQueue s) -> StoreQueue s -> SndPublicAuthKey -> IO (Either ErrorType ()) secureQueue' st sq sKey = atomically (readQueueRec qr $>>= secure) $>>= \_ -> withLog "secureQueue" st $ \s -> logSecureQueue s (recipientId' sq) sKey @@ -75,32 +96,32 @@ secureQueue' st sq sKey = writeTVar qr $ Just q {senderKey = Just sKey} pure $ Right () -addQueueNotifier' :: STMQueueStore s => s -> StoreQueue s -> NtfCreds -> IO (Either ErrorType (Maybe NotifierId)) +addQueueNotifier' :: MsgStoreClass s => STMQueueStore (StoreQueue 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 qr = queueRec' sq rId = recipientId' sq - add q = ifM (TM.member nId (notifiers' st)) (pure $ Left DUPLICATE_) $ do - nId_ <- forM (notifier q) $ \NtfCreds {notifierId} -> TM.delete notifierId (notifiers' st) $> notifierId + add q = ifM (TM.member nId (notifiers st)) (pure $ Left DUPLICATE_) $ do + nId_ <- forM (notifier q) $ \NtfCreds {notifierId} -> TM.delete notifierId (notifiers st) $> notifierId let !q' = q {notifier = Just ntfCreds} writeTVar qr $ Just q' - TM.insert nId rId $ notifiers' st + TM.insert nId rId $ notifiers st pure $ Right nId_ -deleteQueueNotifier' :: STMQueueStore s => s -> StoreQueue s -> IO (Either ErrorType (Maybe NotifierId)) +deleteQueueNotifier' :: MsgStoreClass s => STMQueueStore (StoreQueue 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' st + TM.delete notifierId $ notifiers st writeTVar qr $! Just q {notifier = Nothing} pure notifierId -suspendQueue' :: STMQueueStore s => s -> StoreQueue s -> IO (Either ErrorType ()) +suspendQueue' :: MsgStoreClass s => STMQueueStore (StoreQueue s) -> StoreQueue s -> IO (Either ErrorType ()) suspendQueue' st sq = atomically (readQueueRec qr >>= mapM suspend) $>>= \_ -> withLog "suspendQueue" st (`logSuspendQueue` recipientId' sq) @@ -108,7 +129,7 @@ suspendQueue' st sq = qr = queueRec' sq suspend q = writeTVar qr $! Just q {status = QueueOff} -updateQueueTime' :: STMQueueStore s => s -> StoreQueue s -> RoundedSystemTime -> IO (Either ErrorType QueueRec) +updateQueueTime' :: MsgStoreClass s => STMQueueStore (StoreQueue s) -> StoreQueue s -> RoundedSystemTime -> IO (Either ErrorType QueueRec) updateQueueTime' st sq t = atomically (readQueueRec qr >>= mapM update) $>>= log' where qr = queueRec' sq @@ -121,7 +142,7 @@ updateQueueTime' st sq t = atomically (readQueueRec qr >>= mapM update) $>>= log | changed = q <$$ withLog "updateQueueTime" st (\sl -> logUpdateQueueTime sl (recipientId' sq) t) | otherwise = pure $ Right q -deleteQueue' :: STMQueueStore s => s -> StoreQueue s -> IO (Either ErrorType (QueueRec, Maybe (MsgQueue s))) +deleteQueue' :: MsgStoreClass s => STMQueueStore (StoreQueue 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) @@ -130,8 +151,8 @@ deleteQueue' st sq = 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 + TM.delete (senderId q) $ senders st + forM_ (notifier q) $ \NtfCreds {notifierId} -> TM.delete notifierId $ notifiers st pure q readQueueRec :: TVar (Maybe QueueRec) -> STM (Either ErrorType QueueRec) @@ -148,5 +169,37 @@ withLog' name sl action = where err = name <> ", withLog, " <> show e -withLog :: STMQueueStore s => String -> s -> (StoreLog 'WriteMode -> IO ()) -> IO (Either ErrorType ()) -withLog name = withLog' name . storeLog' +withLog :: String -> STMQueueStore q -> (StoreLog 'WriteMode -> IO ()) -> IO (Either ErrorType ()) +withLog name = withLog' name . storeLog + +readQueueStore :: forall s. STMStoreClass s => FilePath -> s -> IO () +readQueueStore f ms = withFile f ReadMode $ LB.hGetContents >=> mapM_ processLine . LB.lines + where + st = stmQueueStore ms + processLine :: LB.ByteString -> IO () + processLine s' = either printError procLogRecord (strDecode s) + where + s = LB.toStrict s' + procLogRecord :: StoreLogRecord -> IO () + procLogRecord = \case + CreateQueue rId q -> addQueue' ms 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 + 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 = B.putStrLn $ "Error parsing log: " <> B.pack e <> " - " <> 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) <> ", " diff --git a/src/Simplex/Messaging/Server/StoreLog.hs b/src/Simplex/Messaging/Server/StoreLog.hs index 4cc55e978..fa47978be 100644 --- a/src/Simplex/Messaging/Server/StoreLog.hs +++ b/src/Simplex/Messaging/Server/StoreLog.hs @@ -26,7 +26,6 @@ module Simplex.Messaging.Server.StoreLog logUpdateQueueTime, readWriteStoreLog, writeQueueStore, - readQueueStore, ) where @@ -35,14 +34,10 @@ import Control.Concurrent.STM import qualified Control.Exception as E import Control.Logger.Simple import Control.Monad -import Control.Monad.IO.Class -import Control.Monad.Trans.Except import qualified Data.Attoparsec.ByteString.Char8 as A import qualified Data.ByteString.Char8 as B -import qualified Data.ByteString.Lazy.Char8 as LB import qualified Data.Map.Strict as M import qualified Data.Text as T -import Data.Text.Encoding (decodeLatin1) import Data.Time.Clock (getCurrentTime) import Data.Time.Format.ISO8601 (iso8601Show) import GHC.IO (catchAny) @@ -226,42 +221,12 @@ readWriteStoreLog readStore writeStore f st = renameFile tempBackup timedBackup logInfo $ "original state preserved as " <> T.pack timedBackup -writeQueueStore :: MsgStoreClass s => StoreLog 'WriteMode -> s -> IO () -writeQueueStore s st = readTVarIO (activeMsgQueues st) >>= mapM_ writeQueue . M.assocs +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' -> when (active q') $ logCreateQueue s rId q' -- TODO we should log suspended queues when we use them - Nothing -> atomically $ TM.delete rId $ activeMsgQueues st + Nothing -> atomically $ TM.delete rId qs active QueueRec {status} = status == QueueActive - -readQueueStore :: forall s. MsgStoreClass s => FilePath -> s -> IO () -readQueueStore f st = withFile f ReadMode $ LB.hGetContents >=> mapM_ processLine . LB.lines - where - processLine :: LB.ByteString -> IO () - processLine s' = either printError procLogRecord (strDecode s) - where - s = LB.toStrict s' - 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 - 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 = B.putStrLn $ "Error parsing log: " <> B.pack e <> " - " <> 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) <> ", " diff --git a/tests/CoreTests/MsgStoreTests.hs b/tests/CoreTests/MsgStoreTests.hs index beed5811a..fa3d5b3ae 100644 --- a/tests/CoreTests/MsgStoreTests.hs +++ b/tests/CoreTests/MsgStoreTests.hs @@ -57,12 +57,12 @@ msgStoreTests = do it "should create write file when missing" testWriteFileMissing it "should create read file when read and write files are missing" testReadAndWriteFilesMissing where - someMsgStoreTests :: STMQueueStore s => SpecWith s + someMsgStoreTests :: STMStoreClass s => SpecWith s someMsgStoreTests = do it "should get queue and store/read messages" testGetQueue it "should not fail on EOF when changing read journal" testChangeReadJournal -withMsgStore :: STMQueueStore s => MsgStoreConfig s -> (s -> IO ()) -> IO () +withMsgStore :: STMStoreClass s => MsgStoreConfig s -> (s -> IO ()) -> IO () withMsgStore cfg = bracket (newMsgStore cfg) closeMsgStore testSMTStoreConfig :: STMStoreConfig @@ -116,7 +116,7 @@ testNewQueueRec g sndSecure = do } pure (rId, qr) -testGetQueue :: STMQueueStore s => s -> IO () +testGetQueue :: STMStoreClass s => s -> IO () testGetQueue ms = do g <- C.newRandom (rId, qr) <- testNewQueueRec g True @@ -158,7 +158,7 @@ testGetQueue ms = do (Nothing, Nothing) <- tryDelPeekMsg ms q mId8 void $ ExceptT $ deleteQueue ms q -testChangeReadJournal :: STMQueueStore s => s -> IO () +testChangeReadJournal :: STMStoreClass s => s -> IO () testChangeReadJournal ms = do g <- C.newRandom (rId, qr) <- testNewQueueRec g True @@ -177,7 +177,7 @@ testChangeReadJournal ms = do (Msg "message 5", Nothing) <- tryDelPeekMsg ms q mId5 void $ ExceptT $ deleteQueue ms q -testExportImportStore :: JournalStoreType s => JournalMsgStore s -> IO () +testExportImportStore :: JournalMsgStore 'MSHybrid -> IO () testExportImportStore ms = do g <- C.newRandom (rId1, qr1) <- testNewQueueRec g True @@ -225,7 +225,7 @@ testExportImportStore ms = do exportMessages False stmStore testStoreMsgsFile False (B.sort <$> B.readFile testStoreMsgsFile `shouldReturn`) =<< (B.sort <$> B.readFile (testStoreMsgsFile2 <> ".bak")) -testQueueState :: JournalStoreType s => JournalMsgStore s -> IO () +testQueueState :: JournalMsgStore s -> IO () testQueueState ms = do g <- C.newRandom rId <- EntityId <$> atomically (C.randomBytes 24 g) diff --git a/tests/CoreTests/StoreLogTests.hs b/tests/CoreTests/StoreLogTests.hs index 104ecbdec..d4360ab0d 100644 --- a/tests/CoreTests/StoreLogTests.hs +++ b/tests/CoreTests/StoreLogTests.hs @@ -109,4 +109,4 @@ testSMPStoreLog testSuite tests = ([], compacted') <- partitionEithers . map strDecode . B.lines <$> B.readFile testStoreLogFile compacted' `shouldBe` compacted storeState :: JournalMsgStore 'MSHybrid -> IO (M.Map RecipientId QueueRec) - storeState st = M.mapMaybe id <$> (readTVarIO (queues' st) >>= mapM (readTVarIO . queueRec')) + storeState st = M.mapMaybe id <$> (readTVarIO (queues $ stmQueueStore st) >>= mapM (readTVarIO . queueRec')) From c8cc2f262b5df85fafaed05a8c8fd103e5ef822e Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin Date: Sun, 15 Dec 2024 21:59:34 +0000 Subject: [PATCH 11/17] journal store works, some tests pass --- rfcs/2024-11-25-queue-blobs-2.md | 6 +- src/Simplex/Messaging/Server.hs | 6 +- .../Messaging/Server/MsgStore/Journal.hs | 231 +++++++++++------- src/Simplex/Messaging/Server/MsgStore/STM.hs | 6 +- .../Messaging/Server/MsgStore/Types.hs | 10 +- .../Messaging/Server/QueueStore/STM.hs | 6 + tests/CoreTests/MsgStoreTests.hs | 5 +- tests/Test.hs | 4 +- 8 files changed, 166 insertions(+), 108 deletions(-) diff --git a/rfcs/2024-11-25-queue-blobs-2.md b/rfcs/2024-11-25-queue-blobs-2.md index a4913c118..143687da0 100644 --- a/rfcs/2024-11-25-queue-blobs-2.md +++ b/rfcs/2024-11-25-queue-blobs-2.md @@ -43,9 +43,9 @@ Additional suggestion to reduce probability of queue_state.log and queue_rec.log - check the last byte of the file and log EOL if it is not EOL. Probably cleanest approach, but with a small performance cost. If queue folder is a reference to the queue, it may have one of these files: -- notifier.id -- sender.id -- link.id +- notifier.ref +- sender.ref +- link.ref These files would contain a one line with the recipient ID of the queue. These files would never change, they can only be deleted when queue is deleted or when notifier/link is deleted. diff --git a/src/Simplex/Messaging/Server.hs b/src/Simplex/Messaging/Server.hs index 544f769b9..a2759ba8f 100644 --- a/src/Simplex/Messaging/Server.hs +++ b/src/Simplex/Messaging/Server.hs @@ -1786,8 +1786,8 @@ importMessages tty ms f old_ = do renameFile f $ f <> ".bak" mapM_ setOverQuota_ overQuota logQueueStates ms - storedQueues <- M.size <$> readTVarIO (activeMsgQueues ms) - pure MessageStats {storedMsgsCount, expiredMsgsCount, storedQueues} + QueueCounts {queueCount} <- queueCounts ms + pure MessageStats {storedMsgsCount, expiredMsgsCount, storedQueues = queueCount} where progress i = "Processed " <> show i <> " lines" restoreMsg :: (Int, Maybe (RecipientId, StoreQueue s), (Int, Int, M.Map RecipientId (StoreQueue s))) -> LB.ByteString -> ExceptT String IO (Int, Maybe (RecipientId, StoreQueue s), (Int, Int, M.Map RecipientId (StoreQueue s))) @@ -1895,7 +1895,7 @@ restoreServerStats msgStats_ ntfStats = asks (serverStatsBackupFile . config) >> Right d@ServerStatsData {_qCount = statsQCount, _msgCount = statsMsgCount, _ntfCount = statsNtfCount} -> do s <- asks serverStats AMS _ st <- asks msgStore - _qCount <- M.size <$> readTVarIO (activeMsgQueues st) + QueueCounts {queueCount = _qCount} <- liftIO $ queueCounts st let _msgCount = maybe statsMsgCount storedMsgsCount msgStats_ _ntfCount = storedMsgsCount ntfStats _msgExpired' = _msgExpired d + maybe 0 expiredMsgsCount msgStats_ diff --git a/src/Simplex/Messaging/Server/MsgStore/Journal.hs b/src/Simplex/Messaging/Server/MsgStore/Journal.hs index 2074ef493..d9faaf38e 100644 --- a/src/Simplex/Messaging/Server/MsgStore/Journal.hs +++ b/src/Simplex/Messaging/Server/MsgStore/Journal.hs @@ -46,6 +46,7 @@ import Control.Logger.Simple import Control.Monad import Control.Monad.Trans.Except import qualified Data.Attoparsec.ByteString.Char8 as A +import Data.Bifunctor (first) import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B import Data.Functor (($>)) @@ -68,7 +69,7 @@ import Simplex.Messaging.Server.QueueStore.STM import Simplex.Messaging.TMap (TMap) import qualified Simplex.Messaging.TMap as TM import Simplex.Messaging.Server.StoreLog -import Simplex.Messaging.Util (anyM, ifM, tshow, ($>>=), (<$$>)) +import Simplex.Messaging.Util (anyM, ifM, tshow, whenM, ($>>=), (<$$>)) import System.Directory import System.Exit import System.FilePath (()) @@ -225,6 +226,16 @@ msgLogFileName = "messages" logFileExt :: String logFileExt = ".log" +data QueueRef = QRSender | QRNotifier + +queueRefFileName :: QueueRef -> String +queueRefFileName = \case + QRSender -> "sender" + QRNotifier -> "notifier" + +queueRefFileExt :: String +queueRefFileExt = ".ref" + newtype StoreIO (s :: MSType) a = StoreIO {unStoreIO :: IO a} deriving newtype (Functor, Applicative, Monad) @@ -232,10 +243,11 @@ instance STMStoreClass (JournalMsgStore 'MSHybrid) where stmQueueStore JournalMsgStore {queueStore = MQStore st} = st mkQueue st rId qr = do lock <- atomically $ getMapLock (queueLocks st) rId - makeQueue st lock rId qr + let dir = msgQueueDirectory st rId + makeQueue dir lock rId qr -makeQueue :: JournalMsgStore s -> Lock -> RecipientId -> QueueRec -> IO (JournalQueue s) -makeQueue st queueLock rId qr = do +makeQueue :: FilePath -> Lock -> RecipientId -> QueueRec -> IO (JournalQueue s) +makeQueue queueDirectory queueLock rId qr = do queueRec <- newTVarIO $ Just qr msgQueue_ <- newTVarIO Nothing activeAt <- newTVarIO 0 @@ -248,7 +260,7 @@ makeQueue st queueLock rId qr = do msgQueue_, activeAt, isEmpty, - queueDirectory = msgQueueDirectory st rId + queueDirectory } instance JournalStoreType s => MsgStoreClass (JournalMsgStore s) where @@ -276,12 +288,15 @@ instance JournalStoreType s => MsgStoreClass (JournalMsgStore s) where MQStore st -> do readTVarIO (storeLog st) >>= mapM_ closeStoreLog readTVarIO (queues st) >>= mapM_ closeMsgQueue - JQStore {queues_} -> - readTVarIO queues_ >>= mapM_ (mapM closeMsgQueue) + st@JQStore {} -> + readTVarIO (queues_ st) >>= mapM_ (mapM closeMsgQueue) - activeMsgQueues ms = case queueStore ms of - MQStore st -> queues st - JQStore {} -> undefined -- TODO [queues] + withActiveMsgQueues :: Monoid a => JournalMsgStore s -> (JournalQueue s -> IO a) -> IO a + withActiveMsgQueues ms f = case queueStore ms of + MQStore st -> withQueues st f + st@JQStore {} -> readTVarIO (queues_ st) >>= foldM run mempty + where + run !acc = maybe (pure acc) (fmap (acc <>) . 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. @@ -352,25 +367,25 @@ instance JournalStoreType s => MsgStoreClass (JournalMsgStore s) where queueCount <- M.size <$> readTVarIO (queues st) notifierCount <- M.size <$> readTVarIO (notifiers st) pure QueueCounts {queueCount, notifierCount} - JQStore {queues_, notifiers_} -> do - queueCount <- M.size <$> readTVarIO queues_ - notifierCount <- M.size <$> readTVarIO notifiers_ + st@JQStore {} -> do + queueCount <- M.size <$> readTVarIO (queues_ st) + notifierCount <- M.size <$> readTVarIO (notifiers_ st) pure QueueCounts {queueCount, notifierCount} addQueue :: JournalMsgStore s -> RecipientId -> QueueRec -> IO (Either ErrorType (JournalQueue s)) - addQueue st@JournalMsgStore {queueLocks = ls} rId qr@QueueRec {senderId = sId, notifier} = case queueStore st of - MQStore {} -> addQueue' st rId qr + addQueue ms@JournalMsgStore {queueLocks = ls} rId qr@QueueRec {senderId = sId, notifier} = case queueStore ms of + MQStore {} -> addQueue' ms rId qr JQStore {queues_, senders_, notifiers_} -> do lock <- atomically $ getMapLock ls rId tryStore "addQueue" rId $ withLock' lock "addQueue" $ withLockMap ls sId "addQueueS" $ withNotifierLock $ ifM hasAnyId (pure $ Left DUPLICATE_) $ E.uninterruptibleMask_ $ do - q <- makeQueue st lock rId qr - -- TODO [queues] maybe rename to createQueueDir - storeQueue_ q qr + let dir = msgQueueDirectory ms rId + q <- makeQueue dir lock rId qr + storeNewQueue q qr atomically $ TM.insert rId (Just q) queues_ - saveQueueRef st sId rId senders_ - forM_ notifier $ \NtfCreds {notifierId} -> saveQueueRef st notifierId rId notifiers_ + saveQueueRef ms QRSender sId rId senders_ + forM_ notifier $ \NtfCreds {notifierId} -> saveQueueRef ms QRNotifier notifierId rId notifiers_ pure $ Right q where hasAnyId = anyM [hasId rId queues_, hasId sId senders_, withNotifier (`hasId` notifiers_), hasDir rId, hasDir sId, withNotifier hasDir] @@ -378,23 +393,50 @@ instance JournalStoreType s => MsgStoreClass (JournalMsgStore s) where withNotifierLock a = maybe a (\NtfCreds {notifierId} -> withLockMap ls notifierId "addQueueN" a) notifier hasId :: EntityId -> TMap EntityId (Maybe a) -> IO Bool hasId qId m = maybe False isJust <$> atomically (TM.lookup qId m) - hasDir qId = doesDirectoryExist $ msgQueueDirectory st qId + hasDir qId = doesDirectoryExist $ msgQueueDirectory ms qId getQueue :: DirectParty p => JournalMsgStore s -> SParty p -> QueueId -> IO (Either ErrorType (JournalQueue s)) - getQueue st party qId = case queueStore st of - MQStore st' -> getQueue' st' party qId - JQStore {queues_, senders_, notifiers_} -> - isolateQueueId "getQueue" st qId $ - maybe (Left AUTH) Right <$> case party of + getQueue ms party qId = case queueStore ms of + MQStore st -> getQueue' st party qId + st@JQStore {queues_} -> + isolateQueueId "getQueue" ms qId $ + case party of SRecipient -> getQueue_ qId - SSender -> getQueueRef senders_ $>>= getQueue_ - SNotifier -> getQueueRef notifiers_ $>>= getQueue_ + SSender -> getQueueRef QRSender (senders_ st) $>>= isolateGetQueue + SNotifier -> getQueueRef QRNotifier (notifiers_ st) $>>= isolateGetQueue where - getQueue_ rId = TM.lookupIO rId queues_ >>= maybe (loadQueue rId) pure - getQueueRef :: TMap EntityId (Maybe RecipientId) -> IO (Maybe RecipientId) - getQueueRef m = TM.lookupIO qId m >>= maybe (loadQueueRef m) pure - loadQueue _rId = undefined -- TODO [queues] load, cache, return queue - loadQueueRef _m = undefined -- TODO [queues] load, cache, return queue ID + isolateGetQueue rId = isolateQueueId "getQueueR" ms rId $ getQueue_ rId + getQueue_ rId = TM.lookupIO rId queues_ >>= maybe loadQueue (pure . maybe (Left AUTH) Right) + where + loadQueue = do + let dir = msgQueueDirectory ms rId + f = queueRecPath dir rId + ifM (doesFileExist f) (load dir f) $ do + atomically $ TM.insert rId Nothing queues_ + pure $ Left AUTH + load dir f = do + -- TODO [queues] read backup if exists, remove old timed backups + qr_ <- first STORE . strDecode <$> B.readFile f + forM qr_ $ \qr -> do + lock <- atomically $ getMapLock (queueLocks ms) rId + q <- makeQueue dir lock rId qr + atomically $ TM.insert rId (Just q) queues_ + pure q + getQueueRef :: QueueRef -> TMap EntityId (Maybe RecipientId) -> IO (Either ErrorType RecipientId) + getQueueRef qRef m = TM.lookupIO qId m >>= maybe loadQueueRef (pure . maybe (Left AUTH) Right) + where + loadQueueRef = do + let dir = msgQueueDirectory ms qId + f = queueRefPath dir qRef qId + ifM (doesFileExist f) (loadRef f) $ do + atomically $ TM.insert qId Nothing m + pure $ Left AUTH + loadRef f = do + -- TODO [queues] read backup if exists, remove old timed backups + rId_ <- first STORE . strDecode <$> B.readFile f + forM rId_ $ \rId -> do + atomically $ TM.insert qId (Just rId) m + pure rId secureQueue :: JournalMsgStore s -> JournalQueue s -> SndPublicAuthKey -> IO (Either ErrorType ()) secureQueue st sq sKey = case queueStore st of @@ -410,12 +452,12 @@ instance JournalStoreType s => MsgStoreClass (JournalMsgStore s) where JQStore {notifiers_} -> isolateQueueRec sq "addQueueNotifier" $ \q -> withLockMap (queueLocks st) nId "addQueueNotifierN" $ - ifM hasNotifierId (pure $ Left DUPLICATE_) $ do + ifM hasNotifierId (pure $ Left DUPLICATE_) $ E.uninterruptibleMask_ $ do nId_ <- forM (notifier q) $ \NtfCreds {notifierId = nId'} -> withLockMap (queueLocks st) nId' "addQueueNotifierD" $ - deleteQueueRef st nId' notifiers_ $> nId' + deleteQueueRef st QRNotifier nId' notifiers_ $> nId' storeQueue sq q {notifier = Just ntfCreds} - saveQueueRef st nId (recipientId sq) notifiers_ + saveQueueRef st QRNotifier nId (recipientId sq) notifiers_ pure $ Right nId_ where hasNotifierId = anyM [hasId, hasDir] @@ -423,26 +465,26 @@ instance JournalStoreType s => MsgStoreClass (JournalMsgStore s) where hasDir = doesDirectoryExist $ msgQueueDirectory st nId deleteQueueNotifier :: JournalMsgStore s -> JournalQueue s -> IO (Either ErrorType (Maybe NotifierId)) - deleteQueueNotifier st sq = case queueStore st of - MQStore st' -> deleteQueueNotifier' st' sq - JQStore {notifiers_} -> + deleteQueueNotifier ms sq = case queueStore ms of + MQStore st -> deleteQueueNotifier' st sq + st@JQStore {} -> isolateQueueRec sq "deleteQueueNotifier" $ \q -> fmap Right $ forM (notifier q) $ \NtfCreds {notifierId = nId} -> - withLockMap (queueLocks st) nId "deleteQueueNotifierN" $ do - deleteQueueRef st nId notifiers_ + withLockMap (queueLocks ms) nId "deleteQueueNotifierN" $ do + deleteQueueRef ms QRNotifier nId (notifiers_ st) storeQueue sq q {notifier = Nothing} pure nId suspendQueue :: JournalMsgStore s -> JournalQueue s -> IO (Either ErrorType ()) - suspendQueue st sq = case queueStore st of - MQStore st' -> suspendQueue' st' sq + suspendQueue ms sq = case queueStore ms of + MQStore st -> suspendQueue' st sq JQStore {} -> isolateQueueRec sq "suspendQueue" $ \q -> fmap Right $ storeQueue sq q {status = QueueOff} updateQueueTime :: JournalMsgStore s -> JournalQueue s -> RoundedSystemTime -> IO (Either ErrorType QueueRec) - updateQueueTime st sq t = case queueStore st of - MQStore st' -> updateQueueTime' st' sq t + updateQueueTime ms sq t = case queueStore ms of + MQStore st -> updateQueueTime' st sq t JQStore {} -> isolateQueueRec sq "updateQueueTime" $ fmap Right . update where update q@QueueRec {updatedAt} @@ -452,13 +494,12 @@ instance JournalStoreType s => MsgStoreClass (JournalMsgStore s) where in storeQueue sq q' $> q' getMsgQueue :: JournalMsgStore s -> JournalQueue s -> StoreIO s (JournalMsgQueue s) - getMsgQueue ms@JournalMsgStore {random} sq@JournalQueue {msgQueue_, queueDirectory} = + getMsgQueue ms@JournalMsgStore {random} sq@JournalQueue {recipientId, msgQueue_, queueDirectory} = StoreIO $ readTVarIO msgQueue_ >>= maybe newQ pure where newQ = do - -- TODO [queues] this should account for the possibility that the folder exists, - -- but queue messaging files do not, which will always be the case when queue record is in journals - q <- ifM (doesDirectoryExist queueDirectory) (openMsgQueue ms sq) createQ + let statePath = msgQueueStatePath queueDirectory recipientId + q <- ifM (doesFileExist statePath) (openMsgQueue ms sq statePath) createQ atomically $ writeTVar msgQueue_ $ Just q pure q where @@ -551,6 +592,7 @@ instance JournalStoreType s => MsgStoreClass (JournalMsgStore s) where writeToJournal q@JournalMsgQueue {handles} st@MsgQueueState {writeState, readState = rs, size} canWrt' !msg' = do let msgStr = strEncode msg' `B.snoc` '\n' msgLen = fromIntegral $ B.length msgStr + -- TODO [queues] this should just work, if queue was not opened it will be created, and folder will be used if exists hs <- maybe createQueueDir pure =<< readTVarIO handles (ws, wh) <- case writeHandle hs of Nothing | msgCount writeState >= maxMsgCount -> switchWriteJournal hs @@ -566,7 +608,7 @@ instance JournalStoreType s => MsgStoreClass (JournalMsgStore s) where where createQueueDir = do createDirectoryIfMissing True dir - let statePath = msgQueueStatePath dir $ B.unpack (strEncode recipientId) + let statePath = msgQueueStatePath dir recipientId sh <- openFile statePath AppendMode B.hPutStr sh "" rh <- createNewJournal dir $ journalId rs @@ -637,36 +679,52 @@ isolateQueue_ JournalQueue {recipientId, queueLock} op = tryStore op recipientId isolateQueueId :: String -> JournalMsgStore s -> RecipientId -> IO (Either ErrorType a) -> IO (Either ErrorType a) isolateQueueId op ms rId = tryStore op rId . withLockMap (queueLocks ms) rId op +storeNewQueue :: JournalQueue s -> QueueRec -> IO () +storeNewQueue sq@JournalQueue {queueDirectory} q = do + createDirectoryIfMissing True queueDirectory + storeQueue_ sq q + storeQueue :: JournalQueue s -> QueueRec -> IO () storeQueue sq@JournalQueue {queueRec} q = do storeQueue_ sq q atomically $ writeTVar queueRec $ Just q --- TODO [queues] -deleteQueueDir :: JournalQueue s -> IO () -deleteQueueDir _sq = pure () - --- TODO [queues] -saveQueueRef :: JournalMsgStore s -> QueueId -> RecipientId -> TMap QueueId (Maybe RecipientId) -> IO () -saveQueueRef _st qId rId m = do - pure () -- save ref to disk +saveQueueRef :: JournalMsgStore 'MSJournal -> QueueRef -> QueueId -> RecipientId -> TMap QueueId (Maybe RecipientId) -> IO () +saveQueueRef st qRef qId rId m = do + let dir = msgQueueDirectory st qId + f = queueRefPath dir qRef qId + createDirectoryIfMissing True dir + safeReplaceFile f $ strEncode rId atomically $ TM.insert qId (Just rId) m --- TODO [queues] -deleteQueueRef :: JournalMsgStore s -> QueueId -> TMap QueueId (Maybe RecipientId) -> IO () -deleteQueueRef _st qId m = do - pure () -- delete ref from disk +deleteQueueRef :: JournalMsgStore 'MSJournal -> QueueRef -> QueueId -> TMap QueueId (Maybe RecipientId) -> IO () +deleteQueueRef st qRef qId m = do + let dir = msgQueueDirectory st qId + f = queueRefPath dir qRef qId + whenM (doesFileExist f) $ removeFile f atomically $ TM.delete qId m --- TODO [queues] storeQueue_ :: JournalQueue s -> QueueRec -> IO () -storeQueue_ JournalQueue {recipientId, queueDirectory} _q = pure () -- save queue to disk - where - _queuePath = queueRecPath queueDirectory $ B.unpack (strEncode recipientId) +storeQueue_ JournalQueue {recipientId, queueDirectory} q = do + let f = queueRecPath queueDirectory recipientId + safeReplaceFile f $ strEncode q -openMsgQueue :: JournalMsgStore s -> JournalQueue s -> IO (JournalMsgQueue s) -openMsgQueue ms JournalQueue {recipientId, queueDirectory = dir} = do - let statePath = msgQueueStatePath dir $ B.unpack (strEncode recipientId) +safeReplaceFile :: FilePath -> ByteString -> IO () +safeReplaceFile f s = ifM (doesFileExist f) replace (B.writeFile f s) + where + tempBackup = f <> ".bak" + replace = do + renameFile f tempBackup + B.writeFile f s + renameFile tempBackup =<< timedBackupName f + +timedBackupName :: FilePath -> IO FilePath +timedBackupName f = do + ts <- getCurrentTime + pure $ f <> "." <> iso8601Show ts <> ".bak" + +openMsgQueue :: JournalMsgStore s -> JournalQueue s -> FilePath -> IO (JournalMsgQueue s) +openMsgQueue ms JournalQueue {queueDirectory = dir} statePath = do (st, sh) <- readWriteQueueState ms statePath (st', rh, wh_) <- closeOnException sh $ openJournals ms dir st sh let hs = MsgQueueHandles {stateHandle = sh, readHandle = rh, writeHandle = wh_} @@ -714,8 +772,8 @@ updateReadPos q log' len hs = do updateQueueState q log' hs st' $ writeTVar (tipMsg q) Nothing msgQueueDirectory :: JournalMsgStore s -> RecipientId -> FilePath -msgQueueDirectory JournalMsgStore {config = JournalStoreConfig {storePath, pathParts}} rId = - storePath B.unpack (B.intercalate "/" $ splitSegments pathParts $ strEncode rId) +msgQueueDirectory JournalMsgStore {config = JournalStoreConfig {storePath, pathParts}} qId = + storePath B.unpack (B.intercalate "/" $ splitSegments pathParts $ strEncode qId) where splitSegments _ "" = [] splitSegments 1 s = [s] @@ -723,11 +781,14 @@ msgQueueDirectory JournalMsgStore {config = JournalStoreConfig {storePath, pathP let (seg, s') = B.splitAt 2 s in seg : splitSegments (n - 1) s' -queueRecPath :: FilePath -> String -> FilePath -queueRecPath dir queueId = dir (queueRecFileName <> "." <> queueId <> logFileExt) +queueRecPath :: FilePath -> RecipientId -> FilePath +queueRecPath dir rId = dir (queueRecFileName <> "." <> B.unpack (strEncode rId) <> logFileExt) + +queueRefPath :: FilePath -> QueueRef -> QueueId -> FilePath +queueRefPath dir qRef qId = dir (queueRefFileName qRef <> "." <> B.unpack (strEncode qId) <> queueRefFileExt) -msgQueueStatePath :: FilePath -> String -> FilePath -msgQueueStatePath dir queueId = dir (queueLogFileName <> "." <> queueId <> logFileExt) +msgQueueStatePath :: FilePath -> RecipientId -> FilePath +msgQueueStatePath dir rId = dir (queueLogFileName <> "." <> B.unpack (strEncode rId) <> logFileExt) createNewJournal :: FilePath -> ByteString -> IO Handle createNewJournal dir journalId = do @@ -855,8 +916,7 @@ readWriteQueueState JournalMsgStore {random, config} statePath = -- Temporary backup file will be used when it is present. renameFile statePath tempBackup -- 1) temp backup r <- writeQueueState st -- 2) save state - ts <- getCurrentTime - renameFile tempBackup (statePath <> "." <> iso8601Show ts <> ".bak") -- 3) timed backup + renameFile tempBackup =<< timedBackupName statePath -- 3) timed backup pure r writeQueueState st = do sh <- openFile statePath AppendMode @@ -891,27 +951,26 @@ validQueueState MsgQueueState {readState = rs, writeState = ws, size} && bytePos ws == byteCount ws deleteQueue_ :: forall s. JournalMsgStore s -> JournalQueue s -> IO (Either ErrorType (QueueRec, Maybe (JournalMsgQueue s))) -deleteQueue_ st sq = - isolateQueueId "deleteQueue_" st rId $ +deleteQueue_ ms sq = + isolateQueueId "deleteQueue_" ms rId $ E.uninterruptibleMask_ $ delete >>= mapM (traverse remove) where rId = recipientId sq qr = queueRec sq delete :: IO (Either ErrorType (QueueRec, Maybe (JournalMsgQueue s))) - delete = case queueStore st of - MQStore st' -> deleteQueue' st' sq - JQStore {senders_, notifiers_} -> atomically (readQueueRec qr) >>= mapM jqDelete + delete = case queueStore ms of + MQStore st -> deleteQueue' st sq + st@JQStore {} -> atomically (readQueueRec qr) >>= mapM jqDelete where jqDelete q = E.uninterruptibleMask_ $ do - deleteQueueRef st (senderId q) senders_ - forM_ (notifier q) $ \NtfCreds {notifierId} -> deleteQueueRef st notifierId notifiers_ - deleteQueueDir sq + deleteQueueRef ms QRSender (senderId q) (senders_ st) + forM_ (notifier q) $ \NtfCreds {notifierId} -> deleteQueueRef ms QRNotifier notifierId (notifiers_ st) atomically $ writeTVar qr Nothing (q,) <$> atomically (swapTVar (msgQueue_' sq) Nothing) remove :: Maybe (JournalMsgQueue s) -> IO (Maybe (JournalMsgQueue s)) remove mq = do mapM_ closeMsgQueueHandles mq - removeQueueDirectory st rId + removeQueueDirectory ms rId pure mq closeMsgQueue :: JournalQueue s -> IO () diff --git a/src/Simplex/Messaging/Server/MsgStore/STM.hs b/src/Simplex/Messaging/Server/MsgStore/STM.hs index a72a99bc4..4ae989c5c 100644 --- a/src/Simplex/Messaging/Server/MsgStore/STM.hs +++ b/src/Simplex/Messaging/Server/MsgStore/STM.hs @@ -68,10 +68,10 @@ instance MsgStoreClass STMMsgStore where closeMsgStore st = readTVarIO (storeLog $ queueStore st) >>= mapM_ closeStoreLog - activeMsgQueues = queues . queueStore - {-# INLINE activeMsgQueues #-} + withActiveMsgQueues = withQueues . queueStore + {-# INLINE withActiveMsgQueues #-} - withAllMsgQueues _ = withActiveMsgQueues + withAllMsgQueues _ = withQueues . queueStore {-# INLINE withAllMsgQueues #-} logQueueStates _ = pure () diff --git a/src/Simplex/Messaging/Server/MsgStore/Types.hs b/src/Simplex/Messaging/Server/MsgStore/Types.hs index c5fba950f..88d7954e7 100644 --- a/src/Simplex/Messaging/Server/MsgStore/Types.hs +++ b/src/Simplex/Messaging/Server/MsgStore/Types.hs @@ -17,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) @@ -50,7 +49,7 @@ class Monad (StoreMonad s) => MsgStoreClass s where type MsgQueue s = q | q -> s newMsgStore :: MsgStoreConfig s -> IO s closeMsgStore :: s -> IO () - activeMsgQueues :: s -> TMap RecipientId (StoreQueue s) + 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 () @@ -107,13 +106,6 @@ getQueueRec st party qId = getQueue st party qId $>>= (\q -> maybe (Left AUTH) (Right . (q,)) <$> readTVarIO (queueRec' q)) -withActiveMsgQueues :: (MsgStoreClass s, Monoid a) => s -> (StoreQueue s -> IO a) -> IO a -withActiveMsgQueues st f = readTVarIO (activeMsgQueues st) >>= foldM run mempty - where - run !acc q = do - r <- f q - pure $! acc <> r - getQueueMessages :: MsgStoreClass s => Bool -> s -> StoreQueue s -> ExceptT ErrorType IO [Message] getQueueMessages drainMsgs st q = withPeekMsgQueue st q "getQueueSize" $ maybe (pure []) (getQueueMessages_ drainMsgs q . fst) {-# INLINE getQueueMessages #-} diff --git a/src/Simplex/Messaging/Server/QueueStore/STM.hs b/src/Simplex/Messaging/Server/QueueStore/STM.hs index f0ce8b8d6..d7810de4b 100644 --- a/src/Simplex/Messaging/Server/QueueStore/STM.hs +++ b/src/Simplex/Messaging/Server/QueueStore/STM.hs @@ -17,6 +17,7 @@ module Simplex.Messaging.Server.QueueStore.STM ( STMQueueStore (..), newQueueStore, setStoreLog, + withQueues, addQueue', getQueue', secureQueue', @@ -63,6 +64,11 @@ newQueueStore = do setStoreLog :: STMQueueStore q -> StoreLog 'WriteMode -> IO () setStoreLog st sl = atomically $ writeTVar (storeLog st) (Just sl) +withQueues :: Monoid a => STMQueueStore (StoreQueue s) -> (StoreQueue s -> IO a) -> IO a +withQueues st f = readTVarIO (queues st) >>= foldM run mempty + where + run !acc = fmap (acc <>) . f + addQueue' :: STMStoreClass s => s -> RecipientId -> QueueRec -> IO (Either ErrorType (StoreQueue s)) addQueue' ms rId qr@QueueRec {senderId = sId, notifier} = (mkQueue ms rId qr >>= atomically . add) diff --git a/tests/CoreTests/MsgStoreTests.hs b/tests/CoreTests/MsgStoreTests.hs index fa3d5b3ae..92674b75d 100644 --- a/tests/CoreTests/MsgStoreTests.hs +++ b/tests/CoreTests/MsgStoreTests.hs @@ -23,7 +23,6 @@ import Control.Monad.Trans.Except import Crypto.Random (ChaChaDRG) import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B -import qualified Data.ByteString.Base64.URL as B64 import Data.Maybe (fromJust) import Data.Time.Clock.System (getSystemTime) import Simplex.Messaging.Crypto (pattern MaxLenBS) @@ -230,7 +229,7 @@ testQueueState ms = do g <- C.newRandom rId <- EntityId <$> atomically (C.randomBytes 24 g) let dir = msgQueueDirectory ms rId - statePath = msgQueueStatePath dir $ B.unpack (B64.encode $ unEntityId rId) + statePath = msgQueueStatePath dir rId createDirectoryIfMissing True dir state <- newMsgQueueState <$> newJournalId (random ms) withFile statePath WriteMode (`appendState` state) @@ -295,7 +294,7 @@ testMessageState ms = do g <- C.newRandom (rId, qr) <- testNewQueueRec g True let dir = msgQueueDirectory ms rId - statePath = msgQueueStatePath dir $ B.unpack (B64.encode $ unEntityId rId) + statePath = msgQueueStatePath dir rId write q s = writeMsg ms q True =<< mkMessage s mId1 <- runRight $ do diff --git a/tests/Test.hs b/tests/Test.hs index ede658d21..027b3ba82 100644 --- a/tests/Test.hs +++ b/tests/Test.hs @@ -61,9 +61,11 @@ main = do describe "Store log tests" storeLogTests describe "TRcvQueues tests" tRcvQueuesTests describe "Util tests" utilTests - describe "SMP server via TLS, hybrid message store" $ do + describe "SMP server via TLS, hybrid store" $ do describe "SMP syntax" $ serverSyntaxTests (transport @TLS) before (pure (transport @TLS, AMSType SMSHybrid)) serverTests + fdescribe "SMP server via TLS, journal message store" $ do + before (pure (transport @TLS, AMSType SMSJournal)) serverTests describe "SMP server via TLS, memory message store" $ before (pure (transport @TLS, AMSType SMSMemory)) serverTests -- xdescribe "SMP server via WebSockets" $ do From 7a25174866a238d26be7a36cfc0d751d0b1aa2dc Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin Date: Mon, 16 Dec 2024 22:25:21 +0000 Subject: [PATCH 12/17] fix journal mode, tests pass --- simplexmq.cabal | 1 + .../Messaging/Server/MsgStore/Journal.hs | 60 +++++++++++------ tests/AgentTests/FunctionalAPITests.hs | 2 +- tests/CoreTests/MsgStoreTests.hs | 44 ++++++------ tests/CoreTests/StoreLogTests.hs | 2 +- tests/SMPClient.hs | 10 +-- tests/ServerTests.hs | 67 ++++++++++++------- tests/Test.hs | 2 +- 8 files changed, 116 insertions(+), 72 deletions(-) diff --git a/simplexmq.cabal b/simplexmq.cabal index 06b7f61c8..6fd7bf5df 100644 --- a/simplexmq.cabal +++ b/simplexmq.cabal @@ -279,6 +279,7 @@ library build-depends: case-insensitive ==1.2.* , hashable ==1.4.* + , unix ==2.8.* , websockets ==0.12.* if impl(ghc >= 9.6.2) build-depends: diff --git a/src/Simplex/Messaging/Server/MsgStore/Journal.hs b/src/Simplex/Messaging/Server/MsgStore/Journal.hs index d9faaf38e..87be761e8 100644 --- a/src/Simplex/Messaging/Server/MsgStore/Journal.hs +++ b/src/Simplex/Messaging/Server/MsgStore/Journal.hs @@ -309,25 +309,44 @@ instance JournalStoreType s => MsgStoreClass (JournalMsgStore s) where (!count, !res) <- foldQueues 0 processQueue (0, mempty) ("", storePath) putStrLn $ progress count pure res - JournalStoreConfig {storePath, pathParts} = config + JournalStoreConfig {queueStoreType, storePath, pathParts} = config processQueue :: (Int, a) -> (String, FilePath) -> IO (Int, a) processQueue (!i, !r) (queueId, dir) = do when (tty && i `mod` 100 == 0) $ putStr (progress i <> "\r") >> IO.hFlush stdout r' <- case strDecode $ B.pack queueId of Right rId -> - getQueue ms SRecipient rId >>= \case - Right q -> unStoreIO (getMsgQueue ms q) *> action q <* closeMsgQueue q - Left AUTH -> do - logWarn $ "STORE: processQueue, queue " <> T.pack queueId <> " was removed, removing " <> T.pack dir - removeQueueDirectory_ dir + validRecipientDir dir rId >>= \case + Just True -> + getQueue ms SRecipient rId >>= \case + Right q -> unStoreIO (getMsgQueue ms q) *> action q <* closeMsgQueue q + Left AUTH -> case queueStoreType of + SMSJournal -> do + logError $ "STORE: processQueue, queue " <> T.pack queueId <> " failed to open, directory: " <> T.pack dir + exitFailure + SMSHybrid -> do + logWarn $ "STORE: processQueue, queue " <> T.pack queueId <> " was removed, removing " <> T.pack dir + removeQueueDirectory_ dir + pure mempty + Left e -> do + logError $ "STORE: processQueue, error getting queue " <> T.pack queueId <> ", " <> tshow e + exitFailure + Just False -> pure mempty + Nothing -> do + logWarn $ "STORE: processQueue, skipping unknown entity " <> T.pack queueId <> ", directory: " <> T.pack dir pure mempty - Left e -> do - logError $ "STORE: processQueue, error getting queue " <> T.pack queueId <> ", " <> tshow e - exitFailure Left e -> do logError $ "STORE: processQueue, message queue directory " <> T.pack dir <> " is invalid, " <> tshow e exitFailure pure (i + 1, r <> r') + validRecipientDir dir qId = do + ifM + (anyExists [queueRecPath, msgQueueStatePath]) + (pure $ Just True) + (ifM (anyExists [queueRefPath QRSender, queueRefPath QRNotifier]) (pure $ Just False) (pure Nothing)) + where + anyExists fs = + let paths = map (\f -> f dir qId) fs + in anyM $ map doesFileExist $ paths <> map (<> ".bak") paths progress i = "Processed: " <> show i <> " queues" foldQueues depth f acc (queueId, path) = do let f' = if depth == pathParts - 1 then f else foldQueues (depth + 1) f @@ -416,7 +435,7 @@ instance JournalStoreType s => MsgStoreClass (JournalMsgStore s) where pure $ Left AUTH load dir f = do -- TODO [queues] read backup if exists, remove old timed backups - qr_ <- first STORE . strDecode <$> B.readFile f + qr_ <- first STORE . strDecode <$> B.readFile f forM qr_ $ \qr -> do lock <- atomically $ getMapLock (queueLocks ms) rId q <- makeQueue dir lock rId qr @@ -427,7 +446,7 @@ instance JournalStoreType s => MsgStoreClass (JournalMsgStore s) where where loadQueueRef = do let dir = msgQueueDirectory ms qId - f = queueRefPath dir qRef qId + f = queueRefPath qRef dir qId ifM (doesFileExist f) (loadRef f) $ do atomically $ TM.insert qId Nothing m pure $ Left AUTH @@ -692,7 +711,7 @@ storeQueue sq@JournalQueue {queueRec} q = do saveQueueRef :: JournalMsgStore 'MSJournal -> QueueRef -> QueueId -> RecipientId -> TMap QueueId (Maybe RecipientId) -> IO () saveQueueRef st qRef qId rId m = do let dir = msgQueueDirectory st qId - f = queueRefPath dir qRef qId + f = queueRefPath qRef dir qId createDirectoryIfMissing True dir safeReplaceFile f $ strEncode rId atomically $ TM.insert qId (Just rId) m @@ -700,8 +719,10 @@ saveQueueRef st qRef qId rId m = do deleteQueueRef :: JournalMsgStore 'MSJournal -> QueueRef -> QueueId -> TMap QueueId (Maybe RecipientId) -> IO () deleteQueueRef st qRef qId m = do let dir = msgQueueDirectory st qId - f = queueRefPath dir qRef qId + f = queueRefPath qRef dir qId whenM (doesFileExist f) $ removeFile f + -- TODO [queues] remove folder if it's empty or has only timed backups + -- TODO [queues] remove empty parent folders up to storage depth atomically $ TM.delete qId m storeQueue_ :: JournalQueue s -> QueueRec -> IO () @@ -712,11 +733,11 @@ storeQueue_ JournalQueue {recipientId, queueDirectory} q = do safeReplaceFile :: FilePath -> ByteString -> IO () safeReplaceFile f s = ifM (doesFileExist f) replace (B.writeFile f s) where - tempBackup = f <> ".bak" + temp = f <> ".bak" replace = do - renameFile f tempBackup + renameFile f temp B.writeFile f s - renameFile tempBackup =<< timedBackupName f + renameFile temp =<< timedBackupName f timedBackupName :: FilePath -> IO FilePath timedBackupName f = do @@ -784,8 +805,8 @@ msgQueueDirectory JournalMsgStore {config = JournalStoreConfig {storePath, pathP queueRecPath :: FilePath -> RecipientId -> FilePath queueRecPath dir rId = dir (queueRecFileName <> "." <> B.unpack (strEncode rId) <> logFileExt) -queueRefPath :: FilePath -> QueueRef -> QueueId -> FilePath -queueRefPath dir qRef qId = dir (queueRefFileName qRef <> "." <> B.unpack (strEncode qId) <> queueRefFileExt) +queueRefPath :: QueueRef -> FilePath -> QueueId -> FilePath +queueRefPath qRef dir qId = dir (queueRefFileName qRef <> "." <> B.unpack (strEncode qId) <> queueRefFileExt) msgQueueStatePath :: FilePath -> RecipientId -> FilePath msgQueueStatePath dir rId = dir (queueLogFileName <> "." <> B.unpack (strEncode rId) <> logFileExt) @@ -1015,7 +1036,8 @@ openFile f mode = do pure h hClose :: Handle -> IO () -hClose h = +hClose h = do + IO.hFlush h IO.hClose h `catchAny` \e -> do name <- IO.hShow h logError $ "STORE: hClose, " <> T.pack name <> ", " <> tshow e diff --git a/tests/AgentTests/FunctionalAPITests.hs b/tests/AgentTests/FunctionalAPITests.hs index b281d8001..5a21ea70f 100644 --- a/tests/AgentTests/FunctionalAPITests.hs +++ b/tests/AgentTests/FunctionalAPITests.hs @@ -127,7 +127,7 @@ a =##> p = withTimeout :: (HasCallStack, MonadUnliftIO m) => m a -> (HasCallStack => a -> Expectation) -> m () withTimeout a test = - timeout 10_000000 a >>= \case + timeout 100_000000 a >>= \case Nothing -> error "operation timed out" Just t -> liftIO $ test t diff --git a/tests/CoreTests/MsgStoreTests.hs b/tests/CoreTests/MsgStoreTests.hs index 92674b75d..ae22bd776 100644 --- a/tests/CoreTests/MsgStoreTests.hs +++ b/tests/CoreTests/MsgStoreTests.hs @@ -44,35 +44,41 @@ import Test.Hspec msgStoreTests :: Spec msgStoreTests = do around (withMsgStore testSMTStoreConfig) $ describe "STM message store" someMsgStoreTests - around (withMsgStore testJournalStoreCfg) $ describe "Journal message store" $ do - someMsgStoreTests - it "should export and import journal store" testExportImportStore - describe "queue state" $ do - it "should restore queue state from the last line" testQueueState - it "should recover when message is written and state is not" testMessageState - describe "missing files" $ do - it "should create read file when missing" testReadFileMissing - it "should switch to write file when read file missing" testReadFileMissingSwitch - it "should create write file when missing" testWriteFileMissing - it "should create read file when read and write files are missing" testReadAndWriteFilesMissing + around (withMsgStore $ testJournalStoreCfg SMSHybrid) $ + describe "Hybrid message store" $ do + journalMsgStoreTests + it "should export and import journal store" testExportImportStore + around (withMsgStore $ testJournalStoreCfg SMSJournal) $ + describe "Journal message store" journalMsgStoreTests where - someMsgStoreTests :: STMStoreClass s => SpecWith s + journalMsgStoreTests :: JournalStoreType s => SpecWith (JournalMsgStore s) + journalMsgStoreTests = do + someMsgStoreTests + describe "queue state" $ do + it "should restore queue state from the last line" testQueueState + it "should recover when message is written and state is not" testMessageState + describe "missing files" $ do + it "should create read file when missing" testReadFileMissing + it "should switch to write file when read file missing" testReadFileMissingSwitch + it "should create write file when missing" testWriteFileMissing + it "should create read file when read and write files are missing" testReadAndWriteFilesMissing + someMsgStoreTests :: MsgStoreClass s => SpecWith s someMsgStoreTests = do it "should get queue and store/read messages" testGetQueue it "should not fail on EOF when changing read journal" testChangeReadJournal -withMsgStore :: STMStoreClass s => MsgStoreConfig s -> (s -> IO ()) -> IO () +withMsgStore :: MsgStoreClass s => MsgStoreConfig s -> (s -> IO ()) -> IO () withMsgStore cfg = bracket (newMsgStore cfg) closeMsgStore testSMTStoreConfig :: STMStoreConfig testSMTStoreConfig = STMStoreConfig {storePath = Nothing, quota = 3} -testJournalStoreCfg :: JournalStoreConfig 'MSHybrid -testJournalStoreCfg = +testJournalStoreCfg :: SMSType s -> JournalStoreConfig s +testJournalStoreCfg queueStoreType = JournalStoreConfig { storePath = testStoreMsgsDir, pathParts = journalMsgStoreDepth, - queueStoreType = SMSHybrid, + queueStoreType, quota = 3, maxMsgCount = 4, maxStateLines = 2, @@ -115,7 +121,7 @@ testNewQueueRec g sndSecure = do } pure (rId, qr) -testGetQueue :: STMStoreClass s => s -> IO () +testGetQueue :: MsgStoreClass s => s -> IO () testGetQueue ms = do g <- C.newRandom (rId, qr) <- testNewQueueRec g True @@ -157,7 +163,7 @@ testGetQueue ms = do (Nothing, Nothing) <- tryDelPeekMsg ms q mId8 void $ ExceptT $ deleteQueue ms q -testChangeReadJournal :: STMStoreClass s => s -> IO () +testChangeReadJournal :: MsgStoreClass s => s -> IO () testChangeReadJournal ms = do g <- C.newRandom (rId, qr) <- testNewQueueRec g True @@ -207,7 +213,7 @@ testExportImportStore ms = do closeStoreLog sl exportMessages False ms testStoreMsgsFile False (B.readFile testStoreMsgsFile `shouldReturn`) =<< B.readFile (testStoreMsgsFile <> ".copy") - let cfg = (testJournalStoreCfg :: JournalStoreConfig 'MSHybrid) {storePath = testStoreMsgsDir2} + let cfg = (testJournalStoreCfg SMSHybrid :: JournalStoreConfig 'MSHybrid) {storePath = testStoreMsgsDir2} ms' <- newMsgStore cfg readWriteQueueStore testStoreLogFile ms' >>= closeStoreLog stats@MessageStats {storedMsgsCount = 5, expiredMsgsCount = 0, storedQueues = 2} <- diff --git a/tests/CoreTests/StoreLogTests.hs b/tests/CoreTests/StoreLogTests.hs index d4360ab0d..91d87b6fe 100644 --- a/tests/CoreTests/StoreLogTests.hs +++ b/tests/CoreTests/StoreLogTests.hs @@ -102,7 +102,7 @@ testSMPStoreLog testSuite tests = replicateM_ 3 $ testReadWrite t where testReadWrite SLTC {compacted, state} = do - st <- newMsgStore testJournalStoreCfg + st <- newMsgStore $ testJournalStoreCfg SMSHybrid l <- readWriteQueueStore testStoreLogFile st storeState st `shouldReturn` state closeStoreLog l diff --git a/tests/SMPClient.hs b/tests/SMPClient.hs index af08f5498..54cca9422 100644 --- a/tests/SMPClient.hs +++ b/tests/SMPClient.hs @@ -111,7 +111,7 @@ testSMPClient_ host port vr client = do | otherwise = Nothing cfg :: ServerConfig -cfg = cfgMS (AMSType SMSHybrid) -- TODO [queues] +cfg = cfgMS (AMSType SMSJournal) cfgMS :: AMSType -> ServerConfig cfgMS msType = @@ -190,14 +190,14 @@ proxyVRangeV8 :: VersionRangeSMP proxyVRangeV8 = mkVersionRange batchCmdsSMPVersion sendingProxySMPVersion withSmpServerStoreMsgLogOn :: HasCallStack => ATransport -> ServiceName -> (HasCallStack => ThreadId -> IO a) -> IO a -withSmpServerStoreMsgLogOn = (`withSmpServerStoreMsgLogOnMS` AMSType SMSHybrid) -- TODO [queues] +withSmpServerStoreMsgLogOn = (`withSmpServerStoreMsgLogOnMS` AMSType SMSJournal) withSmpServerStoreMsgLogOnMS :: HasCallStack => ATransport -> AMSType -> ServiceName -> (HasCallStack => ThreadId -> IO a) -> IO a withSmpServerStoreMsgLogOnMS t msType = withSmpServerConfigOn t (cfgMS msType) {storeNtfsFile = Just testStoreNtfsFile, serverStatsBackupFile = Just testServerStatsBackupFile} withSmpServerStoreLogOn :: HasCallStack => ATransport -> ServiceName -> (HasCallStack => ThreadId -> IO a) -> IO a -withSmpServerStoreLogOn = (`withSmpServerStoreLogOnMS` AMSType SMSHybrid) -- TODO [queues] +withSmpServerStoreLogOn = (`withSmpServerStoreLogOnMS` AMSType SMSJournal) withSmpServerStoreLogOnMS :: HasCallStack => ATransport -> AMSType -> ServiceName -> (HasCallStack => ThreadId -> IO a) -> IO a withSmpServerStoreLogOnMS t msType = withSmpServerConfigOn t (cfgMS msType) {serverStatsBackupFile = Just testServerStatsBackupFile} @@ -252,7 +252,7 @@ smpServerTest :: TProxy c -> (Maybe TransmissionAuth, ByteString, ByteString, smp) -> IO (Maybe TransmissionAuth, ByteString, ByteString, BrokerMsg) -smpServerTest _ t = runSmpTest (AMSType SMSHybrid) $ \h -> tPut' h t >> tGet' h -- TODO [queues] +smpServerTest _ t = runSmpTest (AMSType SMSJournal) $ \h -> tPut' h t >> tGet' h where tPut' :: THandleSMP c 'TClient -> (Maybe TransmissionAuth, ByteString, ByteString, smp) -> IO () tPut' h@THandle {params = THandleParams {sessionId, implySessId}} (sig, corrId, queueId, smp) = do @@ -270,7 +270,7 @@ smpTestN :: (HasCallStack, Transport c) => AMSType -> Int -> (HasCallStack => [T smpTestN msType n test' = runSmpTestN msType n test' `shouldReturn` () smpTest2' :: forall c. (HasCallStack, Transport c) => TProxy c -> (HasCallStack => THandleSMP c 'TClient -> THandleSMP c 'TClient -> IO ()) -> Expectation -smpTest2' = (`smpTest2` AMSType SMSHybrid) -- TODO [queues] +smpTest2' = (`smpTest2` AMSType SMSJournal) smpTest2 :: forall c. (HasCallStack, Transport c) => TProxy c -> AMSType -> (HasCallStack => THandleSMP c 'TClient -> THandleSMP c 'TClient -> IO ()) -> Expectation smpTest2 t msType = smpTest2Cfg (cfgMS msType) supportedClientSMPRelayVRange t diff --git a/tests/ServerTests.hs b/tests/ServerTests.hs index 15765268d..6b6b8437d 100644 --- a/tests/ServerTests.hs +++ b/tests/ServerTests.hs @@ -19,7 +19,7 @@ import AgentTests.NotificationTests (removeFileIfExists) import CoreTests.MsgStoreTests (testJournalStoreCfg) import Control.Concurrent (ThreadId, killThread, threadDelay) import Control.Concurrent.STM -import Control.Exception (SomeException, try) +import Control.Exception (SomeException, throwIO, try) import Control.Monad import Control.Monad.IO.Class import Data.Bifunctor (first) @@ -572,7 +572,6 @@ testWithStoreLog = senderId1 <- newTVarIO NoEntity senderId2 <- newTVarIO NoEntity notifierId <- newTVarIO NoEntity - withSmpServerStoreLogOnMS at msType testPort . runTest t $ \h -> runClient t $ \h1 -> do (sId1, rId1, rKey1, dhShared) <- createAndSecureQueue h sPub1 (rcvNtfPubDhKey, _) <- atomically $ C.generateKeyPair g @@ -603,16 +602,14 @@ testWithStoreLog = Resp "dabc" _ OK <- signSendRecv h rKey2 ("dabc", rId2, DEL) pure () - - logSize testStoreLogFile `shouldReturn` 6 - + withHybridStore msType $ + logSize testStoreLogFile `shouldReturn` 6 let cfg' = (cfgMS msType) {msgStoreType = AMSType SMSMemory, storeLogFile = Nothing, storeMsgsFile = Nothing} withSmpServerConfigOn at cfg' testPort . runTest t $ \h -> do sId1 <- readTVarIO senderId1 -- fails if store log is disabled Resp "bcda" _ (ERR AUTH) <- signSendRecv h sKey1 ("bcda", sId1, _SEND "hello") pure () - withSmpServerStoreLogOnMS at msType testPort . runTest t $ \h -> runClient t $ \h1 -> do -- this queue is restored rId1 <- readTVarIO recipientId1 @@ -629,9 +626,9 @@ testWithStoreLog = sId2 <- readTVarIO senderId2 Resp "cdab" _ (ERR AUTH) <- signSendRecv h sKey2 ("cdab", sId2, _SEND "hello too") pure () - - logSize testStoreLogFile `shouldReturn` 1 - removeFile testStoreLogFile + withHybridStore msType $ do + logSize testStoreLogFile `shouldReturn` 1 + removeFile testStoreLogFile where runTest :: Transport c => TProxy c -> (THandleSMP c 'TClient -> IO ()) -> ThreadId -> Expectation runTest _ test' server = do @@ -641,11 +638,20 @@ testWithStoreLog = runClient :: Transport c => TProxy c -> (THandleSMP c 'TClient -> IO ()) -> Expectation runClient _ test' = testSMPClient test' `shouldReturn` () +withHybridStore :: AMSType -> IO () -> IO () +withHybridStore msType a = case msType of + AMSType SMSHybrid -> a + _ -> pure () + logSize :: FilePath -> IO Int -logSize f = - try (length . B.lines <$> B.readFile f) >>= \case - Right l -> pure l - Left (_ :: SomeException) -> logSize f +logSize f = go (3 :: Int) + where + go n = + try (length . B.lines <$> B.readFile f) >>= \case + Right l -> pure l + Left (e :: SomeException) + | n == 0 -> throwIO e + | otherwise -> threadDelay 100000 >> go (n - 1) testRestoreMessages :: SpecWith (ATransport, AMSType) testRestoreMessages = @@ -685,7 +691,8 @@ testRestoreMessages = rId <- readTVarIO recipientId - logSize testStoreLogFile `shouldReturn` 2 + withHybridStore msType $ + logSize testStoreLogFile `shouldReturn` 2 -- logSize testStoreMsgsFile `shouldReturn` 5 logSize testServerStatsBackupFile `shouldReturn` 74 Right stats1 <- strDecode <$> B.readFile testServerStatsBackupFile @@ -702,9 +709,10 @@ testRestoreMessages = Resp "4" _ (Msg mId4 msg4) <- signSendRecv h rKey ("4", rId, ACK mId3) (dec mId4 msg4, Right "hello 4") #== "restored message delivered" - logSize testStoreLogFile `shouldReturn` 1 - -- the last message is not removed because it was not ACK'd - -- logSize testStoreMsgsFile `shouldReturn` 3 + withHybridStore msType $ + logSize testStoreLogFile `shouldReturn` 1 + -- the last message is not removed because it was not ACK'd + -- logSize testStoreMsgsFile `shouldReturn` 3 logSize testServerStatsBackupFile `shouldReturn` 74 Right stats2 <- strDecode <$> B.readFile testServerStatsBackupFile checkStats stats2 [rId] 5 3 @@ -721,13 +729,14 @@ testRestoreMessages = (dec mId6 msg6, Left "ClientRcvMsgQuota") #== "restored message delivered" Resp "7" _ OK <- signSendRecv h rKey ("7", rId, ACK mId6) pure () - logSize testStoreLogFile `shouldReturn` 1 - -- logSize testStoreMsgsFile `shouldReturn` 0 + withHybridStore msType $ + logSize testStoreLogFile `shouldReturn` 1 + -- logSize testStoreMsgsFile `shouldReturn` 0 logSize testServerStatsBackupFile `shouldReturn` 74 Right stats3 <- strDecode <$> B.readFile testServerStatsBackupFile checkStats stats3 [rId] 5 5 - removeFile testStoreLogFile + withHybridStore msType $ removeFile testStoreLogFile removeFileIfExists testStoreMsgsFile whenM (doesDirectoryExist testStoreMsgsDir) $ removeDirectoryRecursive testStoreMsgsDir removeFile testServerStatsBackupFile @@ -782,7 +791,8 @@ testRestoreExpireMessages = Resp "4" _ OK <- signSendRecv h sKey ("4", sId, _SEND "hello 4") pure () - logSize testStoreLogFile `shouldReturn` 2 + withHybridStore msType $ + logSize testStoreLogFile `shouldReturn` 2 exportStoreMessages msType msgs <- B.readFile testStoreMsgsFile length (B.lines msgs) `shouldBe` 4 @@ -791,7 +801,8 @@ testRestoreExpireMessages = cfg1 = (cfgMS msType) {messageExpiration = expCfg1, serverStatsBackupFile = Just testServerStatsBackupFile} withSmpServerConfigOn at cfg1 testPort . runTest t $ \_ -> pure () - logSize testStoreLogFile `shouldReturn` 1 + withHybridStore msType $ + logSize testStoreLogFile `shouldReturn` 1 exportStoreMessages msType msgs' <- B.readFile testStoreMsgsFile msgs' `shouldBe` msgs @@ -800,7 +811,8 @@ testRestoreExpireMessages = cfg2 = (cfgMS msType) {messageExpiration = expCfg2, serverStatsBackupFile = Just testServerStatsBackupFile} withSmpServerConfigOn at cfg2 testPort . runTest t $ \_ -> pure () - logSize testStoreLogFile `shouldReturn` 1 + withHybridStore msType $ + logSize testStoreLogFile `shouldReturn` 1 -- two messages expired exportStoreMessages msType msgs'' <- B.readFile testStoreMsgsFile @@ -810,10 +822,13 @@ testRestoreExpireMessages = _msgExpired `shouldBe` 2 where exportStoreMessages :: AMSType -> IO () - exportStoreMessages = \case - AMSType SMSJournal -> undefined -- TODO [queues] + exportStoreMessages msType = case msType of + AMSType SMSJournal -> do + ms <- newMsgStore $ (testJournalStoreCfg SMSJournal) {quota = 4} + removeFileIfExists testStoreMsgsFile + exportMessages False ms testStoreMsgsFile False AMSType SMSHybrid -> do - ms <- newMsgStore testJournalStoreCfg {quota = 4} + ms <- newMsgStore $ (testJournalStoreCfg SMSHybrid) {quota = 4} readWriteQueueStore testStoreLogFile ms >>= closeStoreLog removeFileIfExists testStoreMsgsFile exportMessages False ms testStoreMsgsFile False diff --git a/tests/Test.hs b/tests/Test.hs index 027b3ba82..e7277dab2 100644 --- a/tests/Test.hs +++ b/tests/Test.hs @@ -64,7 +64,7 @@ main = do describe "SMP server via TLS, hybrid store" $ do describe "SMP syntax" $ serverSyntaxTests (transport @TLS) before (pure (transport @TLS, AMSType SMSHybrid)) serverTests - fdescribe "SMP server via TLS, journal message store" $ do + describe "SMP server via TLS, journal message store" $ do before (pure (transport @TLS, AMSType SMSJournal)) serverTests describe "SMP server via TLS, memory message store" $ before (pure (transport @TLS, AMSType SMSMemory)) serverTests From e62314a802e770f14d0ba47d41daa831af8d9644 Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin Date: Mon, 16 Dec 2024 22:32:01 +0000 Subject: [PATCH 13/17] add TODOs --- src/Simplex/Messaging/Server.hs | 2 ++ src/Simplex/Messaging/Server/MsgStore/Journal.hs | 1 + 2 files changed, 3 insertions(+) diff --git a/src/Simplex/Messaging/Server.hs b/src/Simplex/Messaging/Server.hs index a2759ba8f..65c561af0 100644 --- a/src/Simplex/Messaging/Server.hs +++ b/src/Simplex/Messaging/Server.hs @@ -384,6 +384,8 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg} attachHT threadDelay' interval old <- expireBeforeEpoch expCfg now <- systemSeconds <$> getSystemTime + -- TODO [queues] this should iterate all queues, there are more queues than active queues in journal mode + -- TODO [queues] it should also compact journals (see 2024-11-25-journal-expiration.md) msgStats@MessageStats {storedMsgsCount = stored, expiredMsgsCount = expired} <- withActiveMsgQueues ms $ expireQueueMsgs now ms old atomicWriteIORef (msgCount stats) stored diff --git a/src/Simplex/Messaging/Server/MsgStore/Journal.hs b/src/Simplex/Messaging/Server/MsgStore/Journal.hs index 87be761e8..96d04faf9 100644 --- a/src/Simplex/Messaging/Server/MsgStore/Journal.hs +++ b/src/Simplex/Messaging/Server/MsgStore/Journal.hs @@ -894,6 +894,7 @@ removeJournal dir JournalState {journalId} = do -- This function is supposed to be resilient to crashes while updating state files, -- and also resilient to crashes during its execution. +-- TODO [queues] remove old timed backups readWriteQueueState :: JournalMsgStore s -> FilePath -> IO (MsgQueueState, Handle) readWriteQueueState JournalMsgStore {random, config} statePath = ifM From 4d640c16aaaad5c8d206b690b6c901411d28098d Mon Sep 17 00:00:00 2001 From: Evgeny Date: Wed, 18 Dec 2024 11:19:13 +0000 Subject: [PATCH 14/17] smp server: log prometheus metrics (#1411) * smp server: log prometheus metrics * save metrics * diff * lines * version * do not include Prometheus into client * corrections Co-authored-by: sh <37271604+shumvgolove@users.noreply.github.com> * corrections Co-authored-by: sh <37271604+shumvgolove@users.noreply.github.com> * corrections Co-authored-by: sh <37271604+shumvgolove@users.noreply.github.com> * add timestamp to metrics * remove type * remove version --------- Co-authored-by: sh <37271604+shumvgolove@users.noreply.github.com> --- simplexmq.cabal | 1 + src/Simplex/Messaging/Server.hs | 64 +++- src/Simplex/Messaging/Server/Env/STM.hs | 3 + src/Simplex/Messaging/Server/Main.hs | 6 +- src/Simplex/Messaging/Server/Prometheus.hs | 385 +++++++++++++++++++++ src/Simplex/Messaging/Server/Stats.hs | 8 + src/Simplex/Messaging/Transport/Server.hs | 10 + tests/SMPClient.hs | 7 +- tests/ServerTests.hs | 10 +- 9 files changed, 484 insertions(+), 10 deletions(-) create mode 100644 src/Simplex/Messaging/Server/Prometheus.hs diff --git a/simplexmq.cabal b/simplexmq.cabal index 06b7f61c8..e722ef4ee 100644 --- a/simplexmq.cabal +++ b/simplexmq.cabal @@ -204,6 +204,7 @@ library Simplex.Messaging.Server.MsgStore.STM Simplex.Messaging.Server.MsgStore.Types Simplex.Messaging.Server.NtfStore + Simplex.Messaging.Server.Prometheus Simplex.Messaging.Server.QueueStore Simplex.Messaging.Server.QueueStore.STM Simplex.Messaging.Server.Stats diff --git a/src/Simplex/Messaging/Server.hs b/src/Simplex/Messaging/Server.hs index 988639f5c..afec6e332 100644 --- a/src/Simplex/Messaging/Server.hs +++ b/src/Simplex/Messaging/Server.hs @@ -71,6 +71,7 @@ import Data.Maybe (catMaybes, fromMaybe, isJust, isNothing) import Data.Semigroup (Sum (..)) import qualified Data.Text as T import Data.Text.Encoding (decodeLatin1) +import qualified Data.Text.IO as T import Data.Time.Clock (UTCTime (..), diffTimeToPicoseconds, getCurrentTime) import Data.Time.Clock.System (SystemTime (..), getSystemTime) import Data.Time.Format.ISO8601 (iso8601Show) @@ -98,6 +99,7 @@ import Simplex.Messaging.Server.MsgStore.Journal (JournalQueue, closeMsgQueue) import Simplex.Messaging.Server.MsgStore.STM import Simplex.Messaging.Server.MsgStore.Types import Simplex.Messaging.Server.NtfStore +import Simplex.Messaging.Server.Prometheus import Simplex.Messaging.Server.QueueStore import Simplex.Messaging.Server.QueueStore.QueueInfo import Simplex.Messaging.Server.QueueStore.STM @@ -176,7 +178,11 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg} attachHT : receiveFromProxyAgent pa : expireNtfsThread cfg : sigIntHandlerThread - : map runServer transports <> expireMessagesThread_ cfg <> serverStatsThread_ cfg <> controlPortThread_ cfg + : map runServer transports + <> expireMessagesThread_ cfg + <> serverStatsThread_ cfg + <> prometheusMetricsThread_ cfg + <> controlPortThread_ cfg ) `finally` stopServer s where @@ -555,6 +561,50 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg} attachHT showProxyStats ProxyStatsData {_pRequests, _pSuccesses, _pErrorsConnect, _pErrorsCompat, _pErrorsOther} = [show _pRequests, show _pSuccesses, show _pErrorsConnect, show _pErrorsCompat, show _pErrorsOther] + prometheusMetricsThread_ :: ServerConfig -> [M ()] + prometheusMetricsThread_ ServerConfig {prometheusInterval = Just interval, prometheusMetricsFile} = + [savePrometheusMetrics interval prometheusMetricsFile] + prometheusMetricsThread_ _ = [] + + savePrometheusMetrics :: Int -> FilePath -> M () + savePrometheusMetrics saveInterval metricsFile = do + labelMyThread "savePrometheusMetrics" + liftIO $ putStrLn $ "Prometheus metrics saved every " <> show saveInterval <> " seconds to " <> metricsFile + AMS _ st <- asks msgStore + ss <- asks serverStats + env <- ask + let interval = 1000000 * saveInterval + liftIO $ forever $ do + threadDelay interval + ts <- getCurrentTime + sm <- getServerMetrics st ss + rtm <- getRealTimeMetrics env + T.writeFile metricsFile $ prometheusMetrics sm rtm ts + + getServerMetrics :: STMQueueStore s => s -> ServerStats -> IO ServerMetrics + getServerMetrics st ss = do + d <- getServerStatsData ss + let ps = periodStatDataCounts $ _activeQueues d + psNtf = periodStatDataCounts $ _activeQueuesNtf d + queueCount <- M.size <$> readTVarIO (activeMsgQueues st) + notifierCount <- M.size <$> readTVarIO (notifiers' st) + pure ServerMetrics {statsData = d, activeQueueCounts = ps, activeNtfCounts = psNtf, queueCount, notifierCount} + + getRealTimeMetrics :: Env -> IO RealTimeMetrics + getRealTimeMetrics Env {clients, sockets, server = Server {subscribers, notifiers, subClients, ntfSubClients}} = do + socketStats <- mapM (traverse getSocketStats) =<< readTVarIO sockets +#if MIN_VERSION_base(4,18,0) + threadsCount <- length <$> listThreads +#else + let threadsCount = 0 +#endif + clientsCount <- IM.size <$> readTVarIO clients + smpSubsCount <- M.size <$> readTVarIO subscribers + smpSubClientsCount <- IM.size <$> readTVarIO subClients + ntfSubsCount <- M.size <$> readTVarIO notifiers + ntfSubClientsCount <- IM.size <$> readTVarIO ntfSubClients + pure RealTimeMetrics {socketStats, threadsCount, clientsCount, smpSubsCount, smpSubClientsCount, ntfSubsCount, ntfSubClientsCount} + runClient :: Transport c => C.APrivateSignKey -> TProxy c -> c -> M () runClient signKey tp h = do kh <- asks serverIdentity @@ -695,13 +745,13 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg} attachHT #endif CPSockets -> withUserRole $ unliftIO u (asks sockets) >>= readTVarIO >>= mapM_ putSockets where - putSockets (tcpPort, (accepted', closed', active')) = do - (accepted, closed, active) <- (,,) <$> readTVarIO accepted' <*> readTVarIO closed' <*> readTVarIO active' + putSockets (tcpPort, socketsState) = do + ss <- getSocketStats socketsState hPutStrLn h $ "Sockets for port " <> tcpPort <> ":" - hPutStrLn h $ "accepted: " <> show accepted - hPutStrLn h $ "closed: " <> show closed - hPutStrLn h $ "active: " <> show (IM.size active) - hPutStrLn h $ "leaked: " <> show (accepted - closed - IM.size active) + hPutStrLn h $ "accepted: " <> show (socketsAccepted ss) + hPutStrLn h $ "closed: " <> show (socketsClosed ss) + hPutStrLn h $ "active: " <> show (socketsActive ss) + hPutStrLn h $ "leaked: " <> show (socketsLeaked ss) CPSocketThreads -> withAdminRole $ do #if MIN_VERSION_base(4,18,0) unliftIO u (asks sockets) >>= readTVarIO >>= mapM_ putSocketThreads diff --git a/src/Simplex/Messaging/Server/Env/STM.hs b/src/Simplex/Messaging/Server/Env/STM.hs index f598bdcb8..f7a9cc7e8 100644 --- a/src/Simplex/Messaging/Server/Env/STM.hs +++ b/src/Simplex/Messaging/Server/Env/STM.hs @@ -96,6 +96,9 @@ data ServerConfig = ServerConfig serverStatsLogFile :: FilePath, -- | file to save and restore stats serverStatsBackupFile :: Maybe FilePath, + -- | interval and file to save prometheus metrics + prometheusInterval :: Maybe Int, + prometheusMetricsFile :: FilePath, -- | notification delivery interval ntfDeliveryInterval :: Int, -- | interval between sending pending END events to unsubscribed clients, seconds diff --git a/src/Simplex/Messaging/Server/Main.hs b/src/Simplex/Messaging/Server/Main.hs index 3da2aaeb4..89b032661 100644 --- a/src/Simplex/Messaging/Server/Main.hs +++ b/src/Simplex/Messaging/Server/Main.hs @@ -253,7 +253,9 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath = <> ("expire_ntfs_hours: " <> tshow defNtfExpirationHours <> "\n\n") <> "# Log daily server statistics to CSV file\n" <> ("log_stats: " <> onOff logStats <> "\n\n") - <> "[AUTH]\n\ + <> "# Log interval for real-time Prometheus metrics\n\ + \# prometheus_interval: 300\n\n\ + \[AUTH]\n\ \# Set new_queues option to off to completely prohibit creating new messaging queues.\n\ \# This can be useful when you want to decommission the server, but not all connections are switched yet.\n\ \new_queues: on\n\n\ @@ -431,6 +433,8 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath = logStatsStartTime = 0, -- seconds from 00:00 UTC serverStatsLogFile = combine logPath "smp-server-stats.daily.log", serverStatsBackupFile = logStats $> combine logPath "smp-server-stats.log", + prometheusInterval = eitherToMaybe $ read . T.unpack <$> lookupValue "STORE_LOG" "prometheus_interval" ini, + prometheusMetricsFile = combine logPath "smp-server-metrics.txt", pendingENDInterval = 15000000, -- 15 seconds ntfDeliveryInterval = 3000000, -- 3 seconds smpServerVRange = supportedServerSMPRelayVRange, diff --git a/src/Simplex/Messaging/Server/Prometheus.hs b/src/Simplex/Messaging/Server/Prometheus.hs new file mode 100644 index 000000000..869c13e63 --- /dev/null +++ b/src/Simplex/Messaging/Server/Prometheus.hs @@ -0,0 +1,385 @@ +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} +{-# OPTIONS_GHC -fno-warn-unrecognised-pragmas #-} + +module Simplex.Messaging.Server.Prometheus where + +import Data.Int (Int64) +import Data.Text (Text) +import qualified Data.Text as T +import Data.Time.Clock (UTCTime (..), diffUTCTime) +import Data.Time.Clock.System (systemEpochDay) +import Data.Time.Format.ISO8601 (iso8601Show) +import Network.Socket (ServiceName) +import Simplex.Messaging.Server.Stats + +data ServerMetrics = ServerMetrics + { statsData :: ServerStatsData, + activeQueueCounts :: PeriodStatCounts, + activeNtfCounts :: PeriodStatCounts, + queueCount :: Int, + notifierCount :: Int + } + +data RealTimeMetrics = RealTimeMetrics + { socketStats :: [(ServiceName, SocketStats)], + threadsCount :: Int, + clientsCount :: Int, + smpSubsCount :: Int, + smpSubClientsCount :: Int, + ntfSubsCount :: Int, + ntfSubClientsCount :: Int + } + +data SocketStats = SocketStats + { socketsAccepted :: Int, + socketsClosed :: Int, + socketsActive :: Int, + socketsLeaked :: Int + } + +{-# FOURMOLU_DISABLE\n#-} +prometheusMetrics :: ServerMetrics -> RealTimeMetrics -> UTCTime -> Text +prometheusMetrics sm rtm ts = + time <> queues <> subscriptions <> messages <> ntfMessages <> ntfs <> relays <> info + where + ServerMetrics {statsData, activeQueueCounts = ps, activeNtfCounts = psNtf, queueCount, notifierCount} = sm + RealTimeMetrics + { socketStats, + threadsCount, + clientsCount, + smpSubsCount, + smpSubClientsCount, + ntfSubsCount, + ntfSubClientsCount + } = rtm + ServerStatsData + { _fromTime, + _qCreated, + _qSecured, + _qDeletedAll, + _qDeletedAllB, + _qDeletedNew, + _qDeletedSecured, + _qSub, + _qSubAllB, + _qSubAuth, + _qSubDuplicate, + _qSubProhibited, + _qSubEnd, + _qSubEndB, + _ntfCreated, + _ntfDeleted, + _ntfDeletedB, + _ntfSub, + _ntfSubB, + _ntfSubAuth, + _ntfSubDuplicate, + _msgSent, + _msgSentAuth, + _msgSentQuota, + _msgSentLarge, + _msgRecv, + _msgRecvGet, + _msgGet, + _msgGetNoMsg, + _msgGetAuth, + _msgGetDuplicate, + _msgGetProhibited, + _msgExpired, + _activeQueues, + _msgSentNtf, + _msgRecvNtf, + _activeQueuesNtf, + _msgNtfs, + _msgNtfsB, + _msgNtfNoSub, + _msgNtfLost, + _msgNtfExpired, + _pRelays, + _pRelaysOwn, + _pMsgFwds, + _pMsgFwdsOwn, + _pMsgFwdsRecv, + _qCount, + _msgCount, + _ntfCount + } = statsData + time = + "# Recorded at: " <> T.pack (iso8601Show ts) <> "\n\ + \# Stats from: " <> T.pack (iso8601Show _fromTime) <> "\n\ + \\n" + queues = + "# Queues\n\ + \# ------\n\ + \\n\ + \# HELP simplex_smp_queues_created Created queues\n\ + \# TYPE simplex_smp_queues_created counter\n\ + \simplex_smp_queues_created " <> mshow _qCreated <> "\n# qCreated\n\ + \\n\ + \# HELP simplex_smp_queues_secured Secured queues\n\ + \# TYPE simplex_smp_queues_secured counter\n\ + \simplex_smp_queues_secured " <> mshow _qSecured <> "\n# qSecured\n\ + \\n\ + \# HELP simplex_smp_queues_deleted Deleted queues\n\ + \# TYPE simplex_smp_queues_deleted counter\n\ + \simplex_smp_queues_deleted{type=\"all\"} " <> mshow _qDeletedAll <> "\n# qDeleted\n\ + \simplex_smp_queues_deleted{type=\"new\"} " <> mshow _qDeletedNew <> "\n# qDeletedNew\n\ + \simplex_smp_queues_deleted{type=\"secured\"} " <> mshow _qDeletedSecured <> "\n# qDeletedSecured\n\ + \\n\ + \# HELP simplex_smp_queues_deleted_batch Batched requests to delete queues\n\ + \# TYPE simplex_smp_queues_deleted_batch counter\n\ + \simplex_smp_queues_deleted_batch " <> mshow _qDeletedAllB <> "\n# qDeletedAllB\n\ + \\n\ + \# HELP simplex_smp_queues_total1 Total number of stored queues (first type of count).\n\ + \# TYPE simplex_smp_queues_total1 gauge\n\ + \simplex_smp_queues_total1 " <> mshow _qCount <> "\n# qCount\n\ + \\n\ + \# HELP simplex_smp_queues_total2 Total number of stored queues (second type of count).\n\ + \# TYPE simplex_smp_queues_total2 gauge\n\ + \simplex_smp_queues_total2 " <> mshow queueCount <> "\n# qCount2\n\ + \\n\ + \# HELP simplex_smp_queues_daily Daily active queues.\n\ + \# TYPE simplex_smp_queues_daily gauge\n\ + \simplex_smp_queues_daily " <> mstr (dayCount ps) <> "\n# dayMsgQueues\n\ + \\n\ + \# HELP simplex_smp_queues_weekly Weekly active queues.\n\ + \# TYPE simplex_smp_queues_weekly gauge\n\ + \simplex_smp_queues_weekly " <> mstr (weekCount ps) <> "\n# weekMsgQueues\n\ + \\n\ + \# HELP simplex_smp_queues_monthly Monthly active queues.\n\ + \# TYPE simplex_smp_queues_monthly gauge\n\ + \simplex_smp_queues_monthly " <> mstr (monthCount ps) <> "\n# monthMsgQueues\n\ + \\n\ + \# HELP simplex_smp_queues_notify_daily Daily active queues with notifications.\n\ + \# TYPE simplex_smp_queues_notify_daily gauge\n\ + \simplex_smp_queues_notify_daily " <> mstr (dayCount psNtf) <> "\n# dayCountNtf\n\ + \\n\ + \# HELP simplex_smp_queues_notify_weekly Weekly active queues with notifications.\n\ + \# TYPE simplex_smp_queues_notify_weekly gauge\n\ + \simplex_smp_queues_notify_weekly " <> mstr (weekCount psNtf) <> "\n# weekCountNtf\n\ + \\n\ + \# HELP simplex_smp_queues_notify_monthly Monthly active queues with notifications.\n\ + \# TYPE simplex_smp_queues_notify_monthly gauge\n\ + \simplex_smp_queues_notify_monthly " <> mstr (monthCount psNtf) <> "\n# monthCountNtf\n\ + \\n" + subscriptions = + "# Subscriptions\n\ + \# -------------\n\ + \\n\ + \# HELP simplex_smp_subscribtion_successes Successful subscriptions.\n\ + \# TYPE simplex_smp_subscribtion_successes counter\n\ + \simplex_smp_subscribtion_successes " <> mshow _qSub <> "\n# qSub\n\ + \\n\ + \# HELP simplex_smp_subscribtion_successes_batch Batched successful subscriptions.\n\ + \# TYPE simplex_smp_subscribtion_successes_batch counter\n\ + \simplex_smp_subscribtion_successes_batch " <> mshow _qSubAllB <> "\n# qSubAllB\n\ + \\n\ + \# HELP simplex_smp_subscribtion_end Ended subscriptions.\n\ + \# TYPE simplex_smp_subscribtion_end counter\n\ + \simplex_smp_subscribtion_end " <> mshow _qSubEnd <> "\n# qSubEnd\n\ + \\n\ + \# HELP simplex_smp_subscribtion_end_batch Batched ended subscriptions.\n\ + \# TYPE simplex_smp_subscribtion_end_batch counter\n\ + \simplex_smp_subscribtion_end_batch " <> mshow _qSubEndB <> "\n# qSubEndB\n\ + \\n\ + \# HELP simplex_smp_subscribtion_errors Subscription errors.\n\ + \# TYPE simplex_smp_subscribtion_errors counter\n\ + \simplex_smp_subscribtion_errors{type=\"auth\"} " <> mshow _qSubAuth <> "\n# qSubAuth\n\ + \simplex_smp_subscribtion_errors{type=\"duplicate\"} " <> mshow _qSubDuplicate <> "\n# qSubDuplicate\n\ + \simplex_smp_subscribtion_errors{type=\"prohibited\"} " <> mshow _qSubProhibited <> "\n# qSubProhibited\n\ + \\n" + messages = + "# Messages\n\ + \# --------\n\ + \\n\ + \# HELP simplex_smp_messages_sent Sent messages.\n\ + \# TYPE simplex_smp_messages_sent counter\n\ + \simplex_smp_messages_sent " <> mshow _msgSent <> "\n# msgSent\n\ + \\n\ + \# HELP simplex_smp_messages_sent_errors Total number of messages errors by type.\n\ + \# TYPE simplex_smp_messages_sent_errors counter\n\ + \simplex_smp_messages_sent_errors{type=\"auth\"} " <> mshow _msgSentAuth <> "\n# msgSentAuth\n\ + \simplex_smp_messages_sent_errors{type=\"quota\"} " <> mshow _msgSentQuota <> "\n# msgSentQuota\n\ + \simplex_smp_messages_sent_errors{type=\"large\"} " <> mshow _msgSentLarge <> "\n# msgSentLarge\n\ + \\n\ + \# HELP simplex_smp_messages_received Received messages.\n\ + \# TYPE simplex_smp_messages_received counter\n\ + \simplex_smp_messages_received " <> mshow _msgRecv <> "\n# msgRecv\n\ + \\n\ + \# HELP simplex_smp_messages_expired Expired messages.\n\ + \# TYPE simplex_smp_messages_expired counter\n\ + \simplex_smp_messages_expired " <> mshow _msgExpired <> "\n# msgExpired\n\ + \\n\ + \# HELP simplex_smp_messages_total Total number of messages stored.\n\ + \# TYPE simplex_smp_messages_total gauge\n\ + \simplex_smp_messages_total " <> mshow _msgCount <> "\n# msgCount\n\ + \\n" + ntfMessages = + "# Notification messages (client)\n\ + \# ------------------------------\n\ + \\n\ + \# HELP simplex_smp_messages_notify_sent Sent messages with notification flag (cleint).\n\ + \# TYPE simplex_smp_messages_notify_sent counter\n\ + \simplex_smp_messages_notify_sent " <> mshow _msgSentNtf <> "\n# msgSentNtf\n\ + \\n\ + \# HELP simplex_smp_messages_notify_received Received messages with notification flag (client).\n\ + \# TYPE simplex_smp_messages_notify_received counter\n\ + \simplex_smp_messages_notify_received " <> mshow _msgRecvNtf <> "\n# msgRecvNtf\n\ + \\n\ + \# HELP simplex_smp_messages_notify_get_sent Requests to get messages with notification flag (client).\n\ + \# TYPE simplex_smp_messages_notify_get_sent counter\n\ + \simplex_smp_messages_notify_get_sent " <> mshow _msgGet <> "\n# msgGet\n\ + \\n\ + \# HELP simplex_smp_messages_notify_get_received Succesfully received get requests messages with notification flag (client).\n\ + \# TYPE simplex_smp_messages_notify_get_received counter\n\ + \simplex_smp_messages_notify_get_received " <> mshow _msgRecvGet <> "\n# msgRecvGet\n\ + \\n\ + \# HELP simplex_smp_messages_notify_get_errors Error events with messages with notification flag (client). \n\ + \# TYPE simplex_smp_messages_notify_get_errors counter\n\ + \simplex_smp_messages_notify_get_errors{type=\"nomsg\"} " <> mshow _msgGetNoMsg <> "\n# msgGetNoMsg\n\ + \simplex_smp_messages_notify_get_errors{type=\"auth\"} " <> mshow _msgGetAuth <> "\n# msgGetAuth\n\ + \simplex_smp_messages_notify_get_errors{type=\"duplicate\"} " <> mshow _msgGetDuplicate <> "\n# msgGetDuplicate\n\ + \simplex_smp_messages_notify_get_errors{type=\"prohibited\"} " <> mshow _msgGetProhibited <> "\n# msgGetProhibited\n\ + \\n\ + \# HELP simplex_smp_queues_notify_created Created queues with notification flag (client).\n\ + \# TYPE simplex_smp_queues_notify_created counter\n\ + \simplex_smp_queues_notify_created " <> mshow _ntfCreated <> "\n# ntfCreated\n\ + \\n\ + \# HELP simplex_smp_queues_notify_deleted Deleted queues with notification flag (client).\n\ + \# TYPE simplex_smp_queues_notify_deleted counter\n\ + \simplex_smp_queues_notify_deleted " <> mshow _ntfDeleted <> "\n# ntfDeleted\n\ + \\n\ + \# HELP simplex_smp_queues_notify_deleted_batch Deleted batched queues with notification flag (client).\n\ + \# TYPE simplex_smp_queues_notify_deleted_batch counter\n\ + \simplex_smp_queues_notify_deleted_batch " <> mshow _ntfDeletedB <> "\n# ntfDeletedB\n\ + \\n\ + \# HELP simplex_smp_queues_notify_total1 Total number of stored queues with notification flag (first type of count).\n\ + \# TYPE simplex_smp_queues_notify_total1 gauge\n\ + \simplex_smp_queues_notify_total1 " <> mshow _ntfCount <> "\n# ntfCount1\n\ + \\n\ + \# HELP simplex_smp_queues_notify_total2 Total number of stored queues with notification flag (second type of count).\n\ + \# TYPE simplex_smp_queues_notify_total2 gauge\n\ + \simplex_smp_queues_notify_total2 " <> mshow notifierCount <> "\n# ntfCount2\n\ + \\n" + ntfs = + "# Notifications (server)\n\ + \# ----------------------\n\ + \\n\ + \# HELP simplex_smp_messages_ntf_successes Successful events with notification messages (to ntf server). \n\ + \# TYPE simplex_smp_messages_ntf_successes counter\n\ + \simplex_smp_messages_ntf_successes " <> mshow _msgNtfs <> "\n# msgNtfs\n\ + \\n\ + \# HELP simplex_smp_messages_ntf_successes_batch Successful batched events with notification messages (to ntf server). \n\ + \# TYPE simplex_smp_messages_ntf_successes_batch counter\n\ + \simplex_smp_messages_ntf_successes_batch " <> mshow _msgNtfsB <> "\n# msgNtfsB\n\ + \\n\ + \# HELP simplex_smp_messages_ntf_errors Error events with notification messages (to ntf server). \n\ + \# TYPE simplex_smp_messages_ntf_errors counter\n\ + \simplex_smp_messages_ntf_errors{type=\"nosub\"} " <> mshow _msgNtfNoSub <> "\n# msgNtfNoSub\n\ + \simplex_smp_messages_ntf_errors{type=\"lost\"} " <> mshow _msgNtfLost <> "\n# msgNtfLost\n\ + \simplex_smp_messages_ntf_errors{type=\"expired\"} " <> mshow _msgNtfExpired <> "\n# msgNtfExpired\n\ + \\n\ + \# HELP simplex_smp_subscription_ntf_requests Subscription requests with notification flag (from ntf server). \n\ + \# TYPE simplex_smp_subscription_ntf_requests counter\n\ + \simplex_smp_subscription_ntf_requests " <> mshow _ntfSub <> "\n# ntfSub\n\ + \\n\ + \# HELP simplex_smp_subscription_ntf_requests_batch Batched subscription requests with notification flag (from ntf server). \n\ + \# TYPE simplex_smp_subscription_ntf_requests_batch counter\n\ + \simplex_smp_subscription_ntf_requests_batch " <> mshow _ntfSubB <> "\n# ntfSubB\n\ + \\n\ + \# HELP simplex_smp_subscribtion_ntf_errors Subscription errors with notification flag (from ntf server). \n\ + \# TYPE simplex_smp_subscribtion_ntf_errors counter\n\ + \simplex_smp_subscribtion_ntf_errors{type=\"auth\"} " <> mshow _ntfSubAuth <> "\n# ntfSubAuth\n\ + \simplex_smp_subscribtion_ntf_errors{type=\"duplicate\"} " <> mshow _ntfSubDuplicate <> "\n# ntfSubDuplicate\n\ + \\n" + relays = + "# Relays\n\ + \# ------\n\ + \\n\ + \# HELP simplex_smp_relay_sessions_requests Session requests through relay.\n\ + \# TYPE simplex_smp_relay_sessions_requests counter\n\ + \simplex_smp_relay_sessions_requests{source=\"all\"} " <> mshow (_pRequests _pRelays) <> "\n# pRelays_pRequests\n\ + \simplex_smp_relay_sessions_requests{source=\"own\"} " <> mshow (_pRequests _pRelaysOwn) <> "\n# pRelaysOwn_pRequests\n\ + \\n\ + \# HELP simplex_smp_relay_sessions_successes Successful session events through relay.\n\ + \# TYPE simplex_smp_relay_sessions_successes counter\n\ + \simplex_smp_relay_sessions_successes{source=\"all\"} " <> mshow (_pSuccesses _pRelays) <> "\n# pRelays_pSuccesses\n\ + \simplex_smp_relay_sessions_successes{source=\"own\"} " <> mshow (_pSuccesses _pRelaysOwn) <> "\n# pRelaysOwn_pSuccesses\n\ + \\n\ + \# HELP simplex_smp_relay_sessions_errors Error session events through relay.\n\ + \# TYPE simplex_smp_relay_sessions_errors counter\n\ + \simplex_smp_relay_sessions_errors{source=\"all\",type=\"connect\"} " <> mshow (_pErrorsConnect _pRelays) <> "\n# pRelays_pErrorsConnect\n\ + \simplex_smp_relay_sessions_errors{source=\"all\",type=\"compat\"} " <> mshow (_pErrorsCompat _pRelays) <> "\n# pRelays_pErrorsCompat\n\ + \simplex_smp_relay_sessions_errors{source=\"all\",type=\"other\"} " <> mshow (_pErrorsOther _pRelays) <> "\n# pRelays_pErrorsOther\n\ + \simplex_smp_relay_sessions_errors{source=\"own\",type=\"connect\"} " <> mshow (_pErrorsConnect _pRelaysOwn) <> "\n# pRelaysOwn_pErrorsConnect\n\ + \simplex_smp_relay_sessions_errors{source=\"own\",type=\"compat\"} " <> mshow (_pErrorsCompat _pRelaysOwn) <> "\n# pRelaysOwn_pErrorsCompat\n\ + \simplex_smp_relay_sessions_errors{source=\"own\",type=\"other\"} " <> mshow (_pErrorsOther _pRelaysOwn) <> "\n# pRelaysOwn_pErrorsOther\n\ + \\n\ + \# HELP simplex_smp_relay_messages_requests Message requests sent through relay.\n\ + \# TYPE simplex_smp_relay_messages_requests counter\n\ + \simplex_smp_relay_messages_requests{source=\"all\"} " <> mshow (_pRequests _pMsgFwds) <> "\n# pMsgFwds_pRequests\n\ + \simplex_smp_relay_messages_requests{source=\"own\"} " <> mshow (_pRequests _pMsgFwdsOwn) <> "\n# pMsgFwdsOwn_pRequests\n\ + \\n\ + \# HELP simplex_smp_relay_messages_successes Successful messages sent through relay.\n\ + \# TYPE simplex_smp_relay_messages_successes counter\n\ + \simplex_smp_relay_messages_successes{source=\"all\"} " <> mshow (_pSuccesses _pMsgFwds) <> "\n# pMsgFwds_pSuccesses\n\ + \simplex_smp_relay_messages_successes{source=\"own\"} " <> mshow (_pSuccesses _pMsgFwdsOwn) <> "\n# pMsgFwdsOwn_pSuccesses\n\ + \\n\ + \# HELP simplex_smp_relay_messages_errors Error events with messages sent through relay.\n\ + \# TYPE simplex_smp_relay_messages_errors counter\n\ + \simplex_smp_relay_messages_errors{source=\"all\",type=\"connect\"} " <> mshow (_pErrorsConnect _pMsgFwds) <> "\n# pMsgFwds_pErrorsConnect\n\ + \simplex_smp_relay_messages_errors{source=\"all\",type=\"compat\"} " <> mshow (_pErrorsCompat _pMsgFwds) <> "\n# pMsgFwds_pErrorsCompat\n\ + \simplex_smp_relay_messages_errors{source=\"all\",type=\"other\"} " <> mshow (_pErrorsOther _pMsgFwds) <> "\n# pMsgFwds_pErrorsOther\n\ + \simplex_smp_relay_messages_errors{source=\"own\",type=\"connect\"} " <> mshow (_pErrorsConnect _pMsgFwdsOwn) <> "\n# pMsgFwdsOwn_pErrorsConnect\n\ + \simplex_smp_relay_messages_errors{source=\"own\",type=\"compat\"} " <> mshow (_pErrorsCompat _pMsgFwdsOwn) <> "\n# pMsgFwdsOwn_pErrorsCompat\n\ + \simplex_smp_relay_messages_errors{source=\"own\",type=\"other\"} " <> mshow (_pErrorsOther _pMsgFwdsOwn) <> "\n# pMsgFwdsOwn_pErrorsOther\n\ + \\n\ + \# HELP simplex_smp_relay_messages_received Relay messages statistics.\n\ + \# TYPE simplex_smp_relay_messages_received counter\n\ + \simplex_smp_relay_messages_received " <> mshow _pMsgFwdsRecv <> "\n# pMsgFwdsRecv\n\ + \\n" + info = + "# Info\n\ + \# ----\n\ + \\n" + <> socketsMetric socketsAccepted "simplex_smp_sockets_accepted" "Accepted sockets" + <> socketsMetric socketsClosed "simplex_smp_sockets_closed" "Closed sockets" + <> socketsMetric socketsActive "simplex_smp_sockets_active" "Active sockets" + <> socketsMetric socketsLeaked "simplex_smp_sockets_leaked" "Leaked sockets" + <> "# HELP simplex_smp_threads_total Threads\n\ + \# TYPE simplex_smp_threads_total gauge\n\ + \simplex_smp_threads_total " <> mshow threadsCount <> "\n\ + \\n\ + \# HELP simplex_smp_clients_total Clients\n\ + \# TYPE simplex_smp_clients_total gauge\n\ + \simplex_smp_clients_total " <> mshow clientsCount <> "\n\ + \\n\ + \# HELP simplex_smp_subscribtion_total Total subscriptions\n\ + \# TYPE simplex_smp_subscribtion_total gauge\n\ + \simplex_smp_subscribtion_total " <> mshow smpSubsCount <> "\n# smpSubs\n\ + \\n\ + \# HELP simplex_smp_subscribtion_clients_total Subscribed clients, first counting method\n\ + \# TYPE simplex_smp_subscribtion_clients_total gauge\n\ + \simplex_smp_subscribtion_clients_total " <> mshow smpSubClientsCount <> "\n# smpSubClients\n\ + \\n\ + \# HELP simplex_smp_subscription_ntf_total Total notification subscripbtions (from ntf server)\n\ + \# TYPE simplex_smp_subscription_ntf_total gauge\n\ + \simplex_smp_subscription_ntf_total " <> mshow ntfSubsCount <> "\n# ntfSubs\n\ + \\n\ + \# HELP simplex_smp_subscription_ntf_clients_total Total subscribed NTF servers, first counting method\n\ + \# TYPE simplex_smp_subscription_ntf_clients_total gauge\n\ + \simplex_smp_subscription_ntf_clients_total " <> mshow ntfSubClientsCount <> "\n# ntfSubClients\n" + socketsMetric :: (SocketStats -> Int) -> Text -> Text -> Text + socketsMetric sel metric descr = + "# HELP " <> metric <> " " <> descr <> "\n" + <> "# TYPE " <> metric <> " gauge\n" + <> T.concat (map (\(port, ss) -> metric <> "{port=\"" <> T.pack port <> "\"} " <> mshow (sel ss) <> "\n") socketStats) + <> "\n" + mstr a = T.pack a <> " " <> tsEpoch + mshow :: Show a => a -> Text + mshow = mstr . show + tsEpoch = T.pack $ show @Int64 $ floor @Double $ realToFrac (ts `diffUTCTime` epoch) * 1000 + epoch = UTCTime systemEpochDay 0 +{-# FOURMOLU_ENABLE\n#-} diff --git a/src/Simplex/Messaging/Server/Stats.hs b/src/Simplex/Messaging/Server/Stats.hs index 385ba119b..b384ad9b9 100644 --- a/src/Simplex/Messaging/Server/Stats.hs +++ b/src/Simplex/Messaging/Server/Stats.hs @@ -638,6 +638,14 @@ data PeriodStatCounts = PeriodStatCounts monthCount :: String } +periodStatDataCounts :: PeriodStatsData -> PeriodStatCounts +periodStatDataCounts PeriodStatsData {_day, _week, _month} = + PeriodStatCounts + { dayCount = show $ IS.size _day, + weekCount = show $ IS.size _week, + monthCount = show $ IS.size _month + } + periodStatCounts :: PeriodStats -> UTCTime -> IO PeriodStatCounts periodStatCounts ps ts = do let d = utctDay ts diff --git a/src/Simplex/Messaging/Transport/Server.hs b/src/Simplex/Messaging/Transport/Server.hs index 8913ba0c3..95afb5947 100644 --- a/src/Simplex/Messaging/Transport/Server.hs +++ b/src/Simplex/Messaging/Transport/Server.hs @@ -13,6 +13,7 @@ module Simplex.Messaging.Transport.Server runTransportServerState_, SocketState, newSocketState, + getSocketStats, runTransportServer, runTransportServerSocket, runLocalTCPServer, @@ -43,6 +44,7 @@ import Foreign.C.Error import GHC.IO.Exception (ioe_errno) import Network.Socket import qualified Network.TLS as T +import Simplex.Messaging.Server.Prometheus import Simplex.Messaging.Transport import Simplex.Messaging.Util (catchAll_, labelMyThread, tshow) import System.Exit (exitFailure) @@ -166,6 +168,14 @@ type SocketState = (TVar Int, TVar Int, TVar (IntMap (Weak ThreadId))) newSocketState :: IO SocketState newSocketState = (,,) <$> newTVarIO 0 <*> newTVarIO 0 <*> newTVarIO mempty +getSocketStats :: SocketState -> IO SocketStats +getSocketStats (accepted, closed, active) = do + socketsAccepted <- readTVarIO accepted + socketsClosed <- readTVarIO closed + socketsActive <- IM.size <$> readTVarIO active + let socketsLeaked = socketsAccepted - socketsClosed - socketsActive + pure SocketStats {socketsAccepted, socketsClosed, socketsActive, socketsLeaked} + closeServer :: TMVar Bool -> TVar (IntMap (Weak ThreadId)) -> Socket -> IO () closeServer started clients sock = do close sock diff --git a/tests/SMPClient.hs b/tests/SMPClient.hs index d658c30a6..5f7935cd9 100644 --- a/tests/SMPClient.hs +++ b/tests/SMPClient.hs @@ -79,6 +79,9 @@ testStoreNtfsFile = "tests/tmp/smp-server-ntfs.log" testStoreNtfsFile2 :: FilePath testStoreNtfsFile2 = "tests/tmp/smp-server-ntfs.log.2" +testPrometheusMetricsFile :: FilePath +testPrometheusMetricsFile = "tests/tmp/smp-server-metrics.txt" + testServerStatsBackupFile :: FilePath testServerStatsBackupFile = "tests/tmp/smp-server-stats.log" @@ -141,8 +144,10 @@ cfgMS msType = inactiveClientExpiration = Just defaultInactiveClientExpiration, logStatsInterval = Nothing, logStatsStartTime = 0, - serverStatsLogFile = "tests/smp-server-stats.daily.log", + serverStatsLogFile = "tests/tmp/smp-server-stats.daily.log", serverStatsBackupFile = Nothing, + prometheusInterval = Nothing, + prometheusMetricsFile = testPrometheusMetricsFile, pendingENDInterval = 500000, ntfDeliveryInterval = 200000, smpCredentials = diff --git a/tests/ServerTests.hs b/tests/ServerTests.hs index 744ceb437..bdc5f4dc3 100644 --- a/tests/ServerTests.hs +++ b/tests/ServerTests.hs @@ -46,7 +46,7 @@ import Simplex.Messaging.Server.StoreLog (closeStoreLog) import Simplex.Messaging.Transport import Simplex.Messaging.Util (whenM) import Simplex.Messaging.Version (mkVersionRange) -import System.Directory (doesDirectoryExist, removeDirectoryRecursive, removeFile) +import System.Directory (doesDirectoryExist, doesFileExist, removeDirectoryRecursive, removeFile) import System.TimeIt (timeItT) import System.Timeout import Test.HUnit @@ -71,6 +71,7 @@ serverTests = do describe "Store log" testWithStoreLog describe "Restore messages" testRestoreMessages describe "Restore messages (old / v2)" testRestoreExpireMessages + describe "Save prometheus metrics" testPrometheusMetrics describe "Timing of AUTH error" testTiming describe "Message notifications" testMessageNotifications describe "Message expiration" $ do @@ -825,6 +826,13 @@ testRestoreExpireMessages = runClient :: Transport c => TProxy c -> (THandleSMP c 'TClient -> IO ()) -> Expectation runClient _ test' = testSMPClient test' `shouldReturn` () +testPrometheusMetrics :: SpecWith (ATransport, AMSType) +testPrometheusMetrics = + it "should save Prometheus metrics" $ \(at, msType) -> do + let cfg' = (cfgMS msType) {prometheusInterval = Just 1} + withSmpServerConfigOn at cfg' testPort $ \_ -> threadDelay 1000000 + doesFileExist testPrometheusMetricsFile `shouldReturn` True + createAndSecureQueue :: Transport c => THandleSMP c 'TClient -> SndPublicAuthKey -> IO (SenderId, RecipientId, RcvPrivateAuthKey, RcvDhSecret) createAndSecureQueue h sPub = do g <- C.newRandom From 77a5ed2ec69fd00cc7cc9a1a65396a21e743f344 Mon Sep 17 00:00:00 2001 From: sh <37271604+shumvgolove@users.noreply.github.com> Date: Thu, 19 Dec 2024 20:45:17 +0000 Subject: [PATCH 15/17] 6.2.1.0 (#1424) --- simplexmq.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/simplexmq.cabal b/simplexmq.cabal index e722ef4ee..0e610933f 100644 --- a/simplexmq.cabal +++ b/simplexmq.cabal @@ -1,7 +1,7 @@ cabal-version: 1.12 name: simplexmq -version: 6.2.0.7 +version: 6.2.1.0 synopsis: SimpleXMQ message broker description: This package includes <./docs/Simplex-Messaging-Server.html server>, <./docs/Simplex-Messaging-Client.html client> and From 6855711c754be89d36c87e033e0142ab7672a487 Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin Date: Fri, 20 Dec 2024 21:55:40 +0000 Subject: [PATCH 16/17] fix --- src/Simplex/Messaging/Server.hs | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/src/Simplex/Messaging/Server.hs b/src/Simplex/Messaging/Server.hs index 08aa5bdfe..09b61dbfc 100644 --- a/src/Simplex/Messaging/Server.hs +++ b/src/Simplex/Messaging/Server.hs @@ -579,13 +579,12 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg} attachHT rtm <- getRealTimeMetrics env T.writeFile metricsFile $ prometheusMetrics sm rtm ts - getServerMetrics :: STMQueueStore s => s -> ServerStats -> IO ServerMetrics + getServerMetrics :: MsgStoreClass s => s -> ServerStats -> IO ServerMetrics getServerMetrics st ss = do d <- getServerStatsData ss let ps = periodStatDataCounts $ _activeQueues d psNtf = periodStatDataCounts $ _activeQueuesNtf d - queueCount <- M.size <$> readTVarIO (activeMsgQueues st) - notifierCount <- M.size <$> readTVarIO (notifiers' st) + QueueCounts {queueCount, notifierCount} <- queueCounts st pure ServerMetrics {statsData = d, activeQueueCounts = ps, activeNtfCounts = psNtf, queueCount, notifierCount} getRealTimeMetrics :: Env -> IO RealTimeMetrics From 1ff0e1a498177f6aff1d612de7993c73de10ce3f Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin Date: Sun, 22 Dec 2024 07:21:26 +0000 Subject: [PATCH 17/17] import/export queues to journal --- src/Simplex/Messaging/Server/Env/STM.hs | 2 +- src/Simplex/Messaging/Server/Main.hs | 319 +++++++++++++----- .../Messaging/Server/MsgStore/Types.hs | 1 + 3 files changed, 235 insertions(+), 87 deletions(-) diff --git a/src/Simplex/Messaging/Server/Env/STM.hs b/src/Simplex/Messaging/Server/Env/STM.hs index 1e9eadd88..248d73a19 100644 --- a/src/Simplex/Messaging/Server/Env/STM.hs +++ b/src/Simplex/Messaging/Server/Env/STM.hs @@ -314,7 +314,7 @@ newEnv config@ServerConfig {smpCredentials, httpCredentials, storeLogFile, msgSt createMsgStore :: IO AMsgStore createMsgStore = case (msgStoreType, storeMsgsFile) of (AMSType SMSMemory, _) -> do - st <- newMsgStore STMStoreConfig {storePath = storeMsgsFile, quota = msgQueueQuota} + st <- newMsgStore STMStoreConfig {storePath = storeLogFile, quota = msgQueueQuota} loadStoreLog st $> AMS SMSMemory st (AMSType SMSHybrid, Just storePath) -> do st <- newMsgStore $ storeCfg SMSHybrid storePath diff --git a/src/Simplex/Messaging/Server/Main.hs b/src/Simplex/Messaging/Server/Main.hs index 49f514a1e..184debd7a 100644 --- a/src/Simplex/Messaging/Server/Main.hs +++ b/src/Simplex/Messaging/Server/Main.hs @@ -19,12 +19,12 @@ import Control.Logger.Simple import Control.Monad import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B -import Data.Char (isAlpha, isAscii, toUpper) -import Data.Either (fromRight) +import Data.Char (isAlpha, isAscii, toLower, toUpper) import Data.Functor (($>)) import Data.Ini (Ini, lookupValue, readIniFile) import Data.List (find, isPrefixOf) import qualified Data.List.NonEmpty as L +import qualified Data.Map.Strict as M import Data.Maybe (fromMaybe, isJust, isNothing) import Data.Text (Text) import qualified Data.Text as T @@ -44,15 +44,18 @@ 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.Journal (JournalStoreConfig (..)) -import Simplex.Messaging.Server.MsgStore.Types (AMSType (..), SMSType (..), newMsgStore) +import Simplex.Messaging.Server.MsgStore.Journal (JournalMsgStore (..), JournalStoreConfig (..)) +import Simplex.Messaging.Server.MsgStore.STM (STMStoreConfig (..)) +import Simplex.Messaging.Server.MsgStore.Types +import Simplex.Messaging.Server.QueueStore (QueueRec (..), ServerQueueStatus (..)) import Simplex.Messaging.Server.QueueStore.STM (readQueueStore) +import Simplex.Messaging.Server.StoreLog (openWriteStoreLog, logCreateQueue) import Simplex.Messaging.Transport (batchCmdsSMPVersion, sendingProxySMPVersion, simplexMQVersion, 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 Simplex.Messaging.Util (eitherToMaybe, safeDecodeUtf8, tshow) import Simplex.Messaging.Version (mkVersionRange) -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) @@ -85,58 +88,140 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath = putStrLn "Deleted configuration and log files" Journal cmd -> withIniFile $ \ini -> do msgsDirExists <- doesDirectoryExist storeMsgsJournalDir + qsFileExists <- doesFileExist storeLogFilePath 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) + case enableStoreLog $> storeLogFilePath of + Just storeLogFile -> + unless qsFileExists $ + putStrLn ("Store log file " <> storeLogFile <> " not found") >> exitFailure Nothing -> putStrLn "Store log disabled, see `[STORE_LOG] enable`" >> exitFailure case cmd of - JCImport (Just JSCMessages) + JCImport sCmd | msgsFileExists && msgsDirExists -> exitConfigureMsgStorage - | msgsDirExists -> do - putStrLn $ storeMsgsJournalDir <> " directory already exists." - exitFailure - | not msgsFileExists -> do - putStrLn $ storeMsgsFilePath <> " file does not exists." - exitFailure - | otherwise -> do - confirmOrExit - ("WARNING: message log file " <> storeMsgsFilePath <> " will be imported to journal directory " <> storeMsgsJournalDir) - "Messages not imported" - ms <- newJournalMsgStore - -- TODO [queues] it should not load queues if queues are in journal - readQueueStore storeLogFile ms - msgStats <- importMessages True ms storeMsgsFilePath Nothing -- 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 _) -> "store_messages set to `journal`" -- TODO [queues] - Left e -> e <> ", update it to `journal` in INI file" - JCImport _ -> undefined -- TODO [queues] - JCExport (Just JSCMessages) + | otherwise -> case sCmd of + Just JSCMessages -- TODO deprecated, remove in v6.3 + | msgsDirExists -> putStrLn ("Directory already exists: " <> storeMsgsJournalDir) >> exitFailure + | not msgsFileExists -> putStrLn ("File does not exists: " <> storeMsgsFilePath) >> exitFailure + | otherwise -> do + confirmOrExit + ("WARNING: this command is deprecated.\nMessage log file " <> storeMsgsFilePath <> " will be imported to journal directory " <> storeMsgsJournalDir) + "Messages not imported" + ms <- newJournalMsgStore SMSHybrid + readQueueStore storeLogFilePath ms + msgStats <- importMessages True ms storeMsgsFilePath Nothing -- no expiration + putStrLn "Import of messages 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 SMSHybrid) -> "store_messages set to `journal`, all correct" + Right (AMSType SMSJournal) -> "store_messages and store_queues set to `journal`, it is incorrect as only messages were imported" + Left e -> e <> ", update it to `journal` in INI file" + Just JSCQueues -- TODO deprecated, remove in v6.3 + | not msgsDirExists -> putStrLn ("Directory must exists to use this command: " <> storeMsgsJournalDir <> "\nUse `journal import` instead.") >> exitFailure + | otherwise -> do + confirmOrExit + ("WARNING: message queues log file " <> storeLogFilePath <> " will be imported to journal directory " <> storeMsgsJournalDir) + "Queues not imported" + void importQueueStoreLog + putStrLn "Import of queues completed" + putStrLn importStoreSettings + Nothing + | msgsDirExists -> putStrLn ("Directory already exists: " <> storeMsgsJournalDir) >> exitFailure + | not msgsFileExists -> putStrLn ("File does not exists: " <> storeMsgsFilePath) >> exitFailure + | otherwise -> do + confirmOrExit + ("WARNING: message queues log file " <> storeLogFilePath <> " and message log file " <> storeMsgsFilePath <> " will be imported to journal directory " <> storeMsgsJournalDir) + "Queues and messages not imported" + ms <- importQueueStoreLog + msgStats <- importMessages True ms storeMsgsFilePath Nothing -- no expiration + putStrLn "Import of queues and messages completed" + printMessageStats "Messages" msgStats + putStrLn importStoreSettings + where + importQueueStoreLog = do + putStrLn $ "restoring queues from file " <> storeLogFilePath + st <- newMsgStore STMStoreConfig {storePath = Just storeLogFilePath, quota = defaultMsgQueueQuota} + readQueueStore storeLogFilePath st + ms <- newJournalMsgStore SMSJournal + writeJournalQueues st ms + pure ms + where + writeJournalQueues st ms = do + putStrLn $ "saving queues to journal directory " <> storeMsgsJournalDir + let qs = queues $ stmQueueStore st + readTVarIO qs >>= mapM_ (writeQueue ms) . M.assocs + renameFile storeLogFilePath (storeLogFilePath <> ".bak") + active QueueRec {status} = status == QueueActive + writeQueue ms (rId, q) = + readTVarIO (queueRec' q) >>= \case + Just q' | active q' -> -- TODO we should log suspended queues when we use them + addQueue ms rId q' >>= \case + Right _ -> pure () + Left e -> do + putStrLn $ "error saving queue " <> B.unpack (strEncode rId) <> ": " <> show e + exitFailure + _ -> putStrLn $ "skipping suspended queue " <> B.unpack (strEncode rId) + importStoreSettings = case readMsgStoreType ini of + Right (AMSType SMSMemory) -> "store_messages set to `memory`, set store_messages and store_queues to `journal` in INI file" + Right (AMSType SMSHybrid) -> "store_messages set to `journal`, set store_queues to `journal` in INI file" + Right (AMSType SMSJournal) -> "store_messages and store_queues set to `journal`, all correct" + Left e -> e <> ", update it to `journal` in INI file" + JCExport sCmd | msgsFileExists && msgsDirExists -> exitConfigureMsgStorage - | msgsFileExists -> do - putStrLn $ storeMsgsFilePath <> " file already exists." - exitFailure - | otherwise -> do - confirmOrExit - ("WARNING: journal directory " <> storeMsgsJournalDir <> " will be exported to message log file " <> storeMsgsFilePath) - "Journal not exported" - ms <- newJournalMsgStore - -- TODO [queues] it should not load queues if queues are in journal - readQueueStore storeLogFile ms - exportMessages True ms storeMsgsFilePath False - putStrLn "Export completed" - putStrLn $ case readMsgStoreType ini of - Right (AMSType SMSMemory) -> "store_messages set to `memory`" - Right _ -> "store_messages set to `journal`, update it to `memory` in INI file" -- TODO [queues] - Left e -> e <> ", update it to `memory` in INI file" - JCExport _ -> undefined -- TODO [queues] + | not msgsDirExists -> putStrLn ("Directory does not exist: " <> storeMsgsJournalDir) >> exitFailure + | otherwise -> case sCmd of + Just JSCMessages -- TODO deprecated, remove in v6.3 + | msgsFileExists -> putStrLn ("File already exists: " <> storeMsgsFilePath) >> exitFailure + | otherwise -> do + confirmOrExit + ("WARNING: messages from journal directory " <> storeMsgsJournalDir <> " will be exported to message log file " <> storeMsgsFilePath) + "Journal messages not exported" + ms <- newJournalMsgStore SMSHybrid + readQueueStore storeLogFilePath ms + exportMessages True ms storeMsgsFilePath False + putStrLn "Export of messages completed" + putStrLn exportStoreSettings + Just JSCQueues -- TODO deprecated, remove in v6.3 + | qsFileExists -> putStrLn ("File already exists: " <> storeLogFilePath) >> exitFailure + | otherwise -> do + confirmOrExit + ("WARNING: queues from journal directory " <> storeMsgsJournalDir <> " will be exported to queue store log file " <> storeLogFilePath) + "Journal queues not exported" + ms <- newJournalMsgStore SMSJournal + exportQueueStoreLog ms + putStrLn "Export of queues completed" + putStrLn $ case readMsgStoreType ini of + Right (AMSType SMSMemory) -> "store_messages set to `memory`, update it to `journal` in INI file" + Right (AMSType SMSHybrid) -> "store_messages set to `journal`, all correct" + Right (AMSType SMSJournal) -> "store_queues set to `journal`, update it to `memory` in INI file" + Left e -> e <> ", set store_messages to `journal` and `store_queues` to `memory` in INI file" + Nothing + | qsFileExists -> putStrLn (storeLogFilePath <> " file already exists.") >> exitFailure + | msgsFileExists -> putStrLn (storeMsgsFilePath <> " file already exists.") >> exitFailure + | otherwise -> do + confirmOrExit + ("WARNING: queues and messages from journal directory " <> storeMsgsJournalDir <> " will be exported to queue store log file " <> storeLogFilePath <> " and to message log file " <> storeMsgsFilePath) + "Journal queues and messages not exported" + ms <- newJournalMsgStore SMSJournal + exportQueueStoreLog ms + exportMessages True ms storeMsgsFilePath False + putStrLn "Export of queues and messages completed" + putStrLn exportStoreSettings + where + exportQueueStoreLog ms = do + s <- openWriteStoreLog storeLogFilePath + withAllMsgQueues True ms $ \q -> do + let rId = recipientId' q + readTVarIO (queueRec' q) >>= \case + Just q' -> when (active q') $ logCreateQueue s rId q' -- TODO we should log suspended queues when we use them + Nothing -> putStrLn $ "WARN: deleted queue " <> B.unpack (strEncode rId) <> ", verify the journal folder" + active QueueRec {status} = status == QueueActive + exportStoreSettings = case readMsgStoreType ini of + Right (AMSType SMSMemory) -> "store_messages set to `memory`, all correct" + Right (AMSType SMSHybrid) -> "store_messages set to `journal`, update it to `memory` in INI file" + Right (AMSType SMSJournal) -> "store_messages and store_queues set to `journal`, update it to `memory` in INI file" + Left e -> e <> ", update it to `memory` in INI file" JCDelete | not msgsDirExists -> do putStrLn $ storeMsgsJournalDir <> " directory does not exists." @@ -152,7 +237,8 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath = doesFileExist iniFile >>= \case True -> readIniFile iniFile >>= either exitError a _ -> exitError $ "Error: server is not initialized (" <> iniFile <> " does not exist).\nRun `" <> executableName <> " init`." - newJournalMsgStore = newMsgStore JournalStoreConfig {storePath = storeMsgsJournalDir, pathParts = journalMsgStoreDepth, queueStoreType = SMSHybrid, quota = defaultMsgQueueQuota, maxMsgCount = defaultMaxJournalMsgCount, maxStateLines = defaultMaxJournalStateLines, stateTailSize = defaultStateTailSize, idleInterval = checkInterval defaultMessageExpiration} + newJournalMsgStore :: JournalStoreType s => SMSType s -> IO (JournalMsgStore s) + newJournalMsgStore queueStoreType = newMsgStore JournalStoreConfig {storePath = storeMsgsJournalDir, pathParts = journalMsgStoreDepth, queueStoreType, quota = defaultMsgQueueQuota, maxMsgCount = defaultMaxJournalMsgCount, maxStateLines = defaultMaxJournalStateLines, stateTailSize = defaultStateTailSize, idleInterval = checkInterval defaultMessageExpiration} iniFile = combine cfgPath "smp-server.ini" serverVersion = "SMP server v" <> simplexMQVersion defaultServerPorts = "5223,443" @@ -162,48 +248,92 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath = 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 SMSHybrid -- TODO [queues] - s -> Left $ "invalid store_messages: " <> T.unpack s + readMsgStoreType ini = do + queues <- journalStore "store_queues" False ini + messages <- journalStore "store_messages" queues ini + case (queues, messages) of + (False, False) -> Right $ AMSType SMSMemory + (False, True) -> Right $ AMSType SMSHybrid + (True, True) -> Right $ AMSType SMSJournal + (True, False) -> Left "`store_queues: journal` requires `store_messages: journal`" + journalStore param def = either (const $ Right def) isJournal . lookupValue "STORE_LOG" param + where + isJournal = \case + "memory" -> Right False + "journal" -> Right True + s -> Left $ "invalid " <> T.unpack (param <> ": " <> s) + encodeMsgStoreType :: Maybe Bool -> Text + encodeMsgStoreType = \case + Just True -> "journal" + _ -> "memory" + encodeEnablePersistence :: Maybe Bool -> Text + encodeEnablePersistence = \case + Just _ -> "on" + Nothing -> "off" httpsCertFile = combine cfgPath "web.crt" httpsKeyFile = combine cfgPath "web.key" defaultStaticPath = combine logPath "www" - initializeServer opts@InitOptions {ip, fqdn, sourceCode = src', webStaticPath = sp', disableWeb = noWeb', scripted} + initializeServer opts@InitOptions {journalPersistence, logStats, ip, fqdn, password, sourceCode = src', webStaticPath = sp', disableWeb = noWeb', scripted} | scripted = initialize opts | otherwise = do putStrLn "Use `smp-server init -h` for available options." checkInitOptions opts void $ withPrompt "SMP server will be initialized (press Enter)" getLine - enableStoreLog <- onOffPrompt "Enable store log to restore queues and messages on server restart" True - logStats <- onOffPrompt "Enable logging daily statistics" False - putStrLn "Require a password to create new messaging queues?" - password <- withPrompt "'r' for random (default), 'n' - no password, or enter password: " serverPassword + journalPersistence' <- getPersistenceMode + logStats' <- onOffPrompt "Enable logging daily statistics" logStats + password' <- getServerPassword let host = fromMaybe ip fqdn host' <- withPrompt ("Enter server FQDN or IP address for certificate (" <> host <> "): ") getLine sourceCode' <- withPrompt ("Enter server source code URI (" <> maybe simplexmqSource T.unpack src' <> "): ") getServerSourceCode staticPath' <- withPrompt ("Enter path to store generated static site with server information (" <> fromMaybe defaultStaticPath sp' <> "): ") getLine initialize opts - { enableStoreLog, - logStats, + { journalPersistence = journalPersistence', + logStats = logStats', fqdn = if null host' then fqdn else Just host', - password, + password = password', sourceCode = (T.pack <$> sourceCode') <|> src' <|> Just (T.pack simplexmqSource), webStaticPath = if null staticPath' then sp' else Just staticPath', disableWeb = noWeb' } where - serverPassword = - getLine >>= \case - "" -> pure $ Just SPRandom - "r" -> pure $ Just SPRandom - "n" -> pure Nothing - s -> - case strDecode $ encodeUtf8 $ T.pack s of - Right auth -> pure . Just $ ServerPassword auth - _ -> putStrLn "Invalid password. Only latin letters, digits and symbols other than '@' and ':' are allowed" >> serverPassword + getPersistenceMode = do + putStrLn "Server persistence mode:" + putStrLn " 'm' - in-memory store with append-inly log (default, dump and restore messages on restart)" + putStrLn " 'j' - journal (BETA, durable memory-efficient persistence for queues and messages)" + putStrLn " 'd' - disable persistence (not recommended, all data will be lost on restart)" + let options = case journalPersistence of + Just False -> "Mjd" + Just True -> "mJd" + Nothing -> "mjD" + withPrompt ("Choose mode (" <> options <> "): ") get + where + get = + (map toLower <$> getLine) >>= \case + "" -> pure journalPersistence + "m" -> pure $ Just False + "j" -> pure $ Just True + "d" -> pure Nothing + _ -> withPrompt "Invalid mode, please enter 'm', 'j' or 'd'" get + getServerPassword = do + putStrLn "Require a password to create new messaging queues and to use server as proxy?" + let options = case password of + Just SPRandom -> "'r' - random (default), 'n' - no password" + Just (ServerPassword _) -> "'r' - random, 'n' - no password, Enter - to confirm password in options" + Nothing -> "'r' - random, 'n' - no password (default)" + withPrompt (options <> ", or enter password: ") get + where + get = + getLine >>= \case + "" -> pure password + "r" -> pure $ Just SPRandom + "R" -> pure $ Just SPRandom + "n" -> pure Nothing + "N" -> pure Nothing + s -> + case strDecode $ encodeUtf8 $ T.pack s of + Right auth -> pure . Just $ ServerPassword auth + _ -> putStrLn "Invalid password. Only latin letters, digits and symbols other than '@' and ':' are allowed" >> get checkInitOptions InitOptions {sourceCode, serverInfo, operatorCountry, hostingCountry} = do let err_ | isNothing sourceCode && hasServerInfo serverInfo = @@ -214,7 +344,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 {signAlgorithm, controlPort, socksProxy, ownDomains, sourceCode, webStaticPath, disableWeb} = do checkInitOptions opts' clearDirIfExists cfgPath clearDirIfExists logPath @@ -245,12 +375,15 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath = \# This option enables saving memory to append only log,\n\ \# and restoring it when the server is started.\n\ \# Log is compacted on start (deleted objects are removed).\n" - <> ("enable: " <> onOff enableStoreLog <> "\n\n") + <> ("enable: " <> encodeEnablePersistence journalPersistence <> "\n\n") + <> "# Queue storage mode: `memory` or `journal`.\n" + <> ("store_queues: " <> encodeMsgStoreType journalPersistence <> "\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\ + \This option is deprecated and will be removed, do NOT use `journal` here if `store_queues` is memory.\n" + <> ("store_messages: " <> encodeMsgStoreType journalPersistence <> "\n\n") + <> "# When store_messages is `memory`, undelivered messages are optionally saved and restored\n\ \# when the server restarts, they are preserved in the .bak file until the next restart.\n" - <> ("restore_messages: " <> onOff enableStoreLog <> "\n\n") + <> ("restore_messages: " <> encodeEnablePersistence journalPersistence <> "\n\n") <> "# Messages and notifications expiration periods.\n" <> ("expire_messages_days: " <> tshow defMsgExpirationDays <> "\n") <> "expire_messages_on_start: on\n" @@ -510,7 +643,7 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath = _ -> pure () exitConfigureMsgStorage = do - putStrLn $ "Error: both " <> storeMsgsFilePath <> " file and " <> storeMsgsJournalDir <> " directory are present." + putStrLn $ "Error: file " <> storeMsgsFilePath <> " and directory " <> storeMsgsJournalDir <> " are present." putStrLn "Configure memory storage." exitFailure @@ -648,7 +781,7 @@ data JournalCmd = JCImport (Maybe JournalSubCmd) | JCExport (Maybe JournalSubCmd data JournalSubCmd = JSCQueues | JSCMessages data InitOptions = InitOptions - { enableStoreLog :: Bool, + { journalPersistence :: Maybe Bool, logStats :: Bool, signAlgorithm :: SignAlgorithm, ip :: HostName, @@ -682,12 +815,26 @@ cliCommandP cfgPath logPath iniFile = where initP :: Parser InitOptions initP = do - enableStoreLog <- - switch + journalPersistence <- + flag' (Just False) ( long "store-log" <> short 'l' - <> help "Enable store log for persistence" + <> long "memory" + <> short 'm' + <> help "In-memory store with append-only log (default, dump and restore messages on restart)" ) + <|> + flag' (Just True) + ( long "journal" + <> short 'j' + <> help "Journal (BETA, durable memory-efficient persistence for queues and messages)" + ) + <|> + flag' Nothing + ( long "disable-store" + <> help "Disable persistence (not recommended, all data will be lost on restart)" + ) + <|> pure (Just False) logStats <- switch ( long "daily-stats" @@ -789,7 +936,7 @@ cliCommandP cfgPath logPath iniFile = ) pure InitOptions - { enableStoreLog, + { journalPersistence, logStats, signAlgorithm, ip, diff --git a/src/Simplex/Messaging/Server/MsgStore/Types.hs b/src/Simplex/Messaging/Server/MsgStore/Types.hs index 88d7954e7..d1a9719fe 100644 --- a/src/Simplex/Messaging/Server/MsgStore/Types.hs +++ b/src/Simplex/Messaging/Server/MsgStore/Types.hs @@ -87,6 +87,7 @@ data QueueCounts = QueueCounts } data MSType = MSMemory | MSHybrid | MSJournal + deriving (Show) data SMSType :: MSType -> Type where SMSMemory :: SMSType 'MSMemory