From 0414ea59f00bbf97a98d8c87d8749d21401d90bd Mon Sep 17 00:00:00 2001 From: Evgeny Date: Mon, 21 Oct 2024 11:50:30 +0100 Subject: [PATCH 1/8] smp server: journal message store (#1370) * smp server: remove STM function from MsgStore * polymorphic MsgStore * jourmal storage for messages (WIP) * more journal, test setup * writeMsg * test * tryDelMsg * delMsgQueue * remove MsgStoreClass instance of existential wrapper for Msg stores * store config * extract common logic out of store instances * add store type to config * open journals, cache last message, tests pass * CLI commands * refactor import/export messages * cli commands to import/export journal message store * export journal without draining, import/export tests * journal command * import/export progress * better progress info * only log queue state once when importing * logs * handle IO errors in journal store, return as STORE error * recover from state file errors * fix message files after crash * fix messages folder --- rfcs/2024-09-01-smp-message-storage.md | 2 +- simplexmq.cabal | 3 + src/Simplex/FileTransfer/Server/Main.hs | 4 +- src/Simplex/Messaging/Agent/Client.hs | 3 +- src/Simplex/Messaging/Agent/Lock.hs | 5 + .../Messaging/Notifications/Server/Main.hs | 4 +- src/Simplex/Messaging/Protocol.hs | 2 - src/Simplex/Messaging/Server.hs | 281 ++++----- src/Simplex/Messaging/Server/CLI.hs | 6 +- src/Simplex/Messaging/Server/Env/STM.hs | 51 +- src/Simplex/Messaging/Server/Main.hs | 170 ++++-- .../Messaging/Server/MsgStore/Journal.hs | 556 ++++++++++++++++++ src/Simplex/Messaging/Server/MsgStore/STM.hs | 187 +++--- .../Messaging/Server/MsgStore/Types.hs | 81 +++ src/Simplex/Messaging/Util.hs | 8 +- tests/AgentTests/FunctionalAPITests.hs | 21 +- tests/CoreTests/MsgStoreTests.hs | 222 +++++++ tests/SMPClient.hs | 16 +- tests/SMPProxyTests.hs | 19 +- tests/ServerTests.hs | 32 +- tests/Test.hs | 2 + 21 files changed, 1360 insertions(+), 315 deletions(-) create mode 100644 src/Simplex/Messaging/Server/MsgStore/Journal.hs create mode 100644 src/Simplex/Messaging/Server/MsgStore/Types.hs create mode 100644 tests/CoreTests/MsgStoreTests.hs diff --git a/rfcs/2024-09-01-smp-message-storage.md b/rfcs/2024-09-01-smp-message-storage.md index 66905f5e5..0cad20235 100644 --- a/rfcs/2024-09-01-smp-message-storage.md +++ b/rfcs/2024-09-01-smp-message-storage.md @@ -96,7 +96,7 @@ else if write_msg = max_queue_messages: add quota_exceeded message to write_file update queue state: write_msg += 1 append updated queue state to queue.log -else ] +else // It is required that `max_queue_messages < max_file_messages`, // so that we never need more than one additional write file. if write_msg >= max_file_messages: // queue file rotation diff --git a/simplexmq.cabal b/simplexmq.cabal index 95261aac4..5b79044e9 100644 --- a/simplexmq.cabal +++ b/simplexmq.cabal @@ -174,7 +174,9 @@ library Simplex.Messaging.Server.Information Simplex.Messaging.Server.Main Simplex.Messaging.Server.MsgStore + Simplex.Messaging.Server.MsgStore.Journal Simplex.Messaging.Server.MsgStore.STM + Simplex.Messaging.Server.MsgStore.Types Simplex.Messaging.Server.NtfStore Simplex.Messaging.Server.QueueStore Simplex.Messaging.Server.QueueStore.QueueInfo @@ -613,6 +615,7 @@ test-suite simplexmq-test CoreTests.CryptoFileTests CoreTests.CryptoTests CoreTests.EncodingTests + CoreTests.MsgStoreTests CoreTests.RetryIntervalTests CoreTests.SOCKSSettings CoreTests.StoreLogTests diff --git a/src/Simplex/FileTransfer/Server/Main.hs b/src/Simplex/FileTransfer/Server/Main.hs index aca3b60df..a057e2a3c 100644 --- a/src/Simplex/FileTransfer/Server/Main.hs +++ b/src/Simplex/FileTransfer/Server/Main.hs @@ -51,7 +51,9 @@ xftpServerCLI cfgPath logPath = do True -> readIniFile iniFile >>= either exitError runServer _ -> exitError $ "Error: server is not initialized (" <> iniFile <> " does not exist).\nRun `" <> executableName <> " init`." Delete -> do - confirmOrExit "WARNING: deleting the server will make all queues inaccessible, because the server identity (certificate fingerprint) will change.\nTHIS CANNOT BE UNDONE!" + confirmOrExit + "WARNING: deleting the server will make all queues inaccessible, because the server identity (certificate fingerprint) will change.\nTHIS CANNOT BE UNDONE!" + "Server NOT deleted" deleteDirIfExists cfgPath deleteDirIfExists logPath putStrLn "Deleted configuration and log files" diff --git a/src/Simplex/Messaging/Agent/Client.hs b/src/Simplex/Messaging/Agent/Client.hs index 13d554f3c..19d1d448f 100644 --- a/src/Simplex/Messaging/Agent/Client.hs +++ b/src/Simplex/Messaging/Agent/Client.hs @@ -30,6 +30,7 @@ module Simplex.Messaging.Agent.Client withConnLocks, withInvLock, withLockMap, + getMapLock, ipAddressProtected, closeAgentClient, closeProtocolServerClients, @@ -500,7 +501,7 @@ newAgentClient clientId InitialAgentServers {smp, ntf, xftp, netCfg} currentTs a getMsgLocks <- TM.emptyIO connLocks <- TM.emptyIO invLocks <- TM.emptyIO - deleteLock <- atomically createLock + deleteLock <- createLockIO smpSubWorkers <- TM.emptyIO smpServersStats <- TM.emptyIO xftpServersStats <- TM.emptyIO diff --git a/src/Simplex/Messaging/Agent/Lock.hs b/src/Simplex/Messaging/Agent/Lock.hs index 69b8169e2..3c087499c 100644 --- a/src/Simplex/Messaging/Agent/Lock.hs +++ b/src/Simplex/Messaging/Agent/Lock.hs @@ -1,6 +1,7 @@ module Simplex.Messaging.Agent.Lock ( Lock, createLock, + createLockIO, withLock, withLock', withGetLock, @@ -24,6 +25,10 @@ createLock :: STM Lock createLock = newEmptyTMVar {-# INLINE createLock #-} +createLockIO :: IO Lock +createLockIO = newEmptyTMVarIO +{-# INLINE createLockIO #-} + withLock :: MonadUnliftIO m => Lock -> String -> ExceptT e m a -> ExceptT e m a withLock lock name = ExceptT . withLock' lock name . runExceptT {-# INLINE withLock #-} diff --git a/src/Simplex/Messaging/Notifications/Server/Main.hs b/src/Simplex/Messaging/Notifications/Server/Main.hs index 0c5d5e54b..7dfde3422 100644 --- a/src/Simplex/Messaging/Notifications/Server/Main.hs +++ b/src/Simplex/Messaging/Notifications/Server/Main.hs @@ -53,7 +53,9 @@ ntfServerCLI cfgPath logPath = True -> readIniFile iniFile >>= either exitError runServer _ -> exitError $ "Error: server is not initialized (" <> iniFile <> " does not exist).\nRun `" <> executableName <> " init`." Delete -> do - confirmOrExit "WARNING: deleting the server will make all queues inaccessible, because the server identity (certificate fingerprint) will change.\nTHIS CANNOT BE UNDONE!" + confirmOrExit + "WARNING: deleting the server will make all queues inaccessible, because the server identity (certificate fingerprint) will change.\nTHIS CANNOT BE UNDONE!" + "Server NOT deleted" deleteDirIfExists cfgPath deleteDirIfExists logPath putStrLn "Deleted configuration and log files" diff --git a/src/Simplex/Messaging/Protocol.hs b/src/Simplex/Messaging/Protocol.hs index 3c5ba11cb..d5d816bec 100644 --- a/src/Simplex/Messaging/Protocol.hs +++ b/src/Simplex/Messaging/Protocol.hs @@ -399,8 +399,6 @@ data Command (p :: Party) where NKEY :: NtfPublicAuthKey -> RcvNtfPublicDhKey -> Command Recipient NDEL :: Command Recipient GET :: Command Recipient - -- ACK v1 has to be supported for encoding/decoding - -- ACK :: Command Recipient ACK :: MsgId -> Command Recipient OFF :: Command Recipient DEL :: Command Recipient diff --git a/src/Simplex/Messaging/Server.hs b/src/Simplex/Messaging/Server.hs index 29de4ff6d..3e8f556b5 100644 --- a/src/Simplex/Messaging/Server.hs +++ b/src/Simplex/Messaging/Server.hs @@ -30,6 +30,8 @@ module Simplex.Messaging.Server ( runSMPServer, runSMPServerBlocking, + importMessages, + exportMessages, disconnectTransport, verifyCmdAuthorization, dummyVerifyCmd, @@ -39,7 +41,6 @@ module Simplex.Messaging.Server where import Control.Concurrent.STM (throwSTM) -import Control.Concurrent.STM.TQueue (flushTQueue) import Control.Logger.Simple import Control.Monad import Control.Monad.Except @@ -91,6 +92,7 @@ import Simplex.Messaging.Server.Env.STM as Env import Simplex.Messaging.Server.Expiration import Simplex.Messaging.Server.MsgStore import Simplex.Messaging.Server.MsgStore.STM +import Simplex.Messaging.Server.MsgStore.Types import Simplex.Messaging.Server.NtfStore import Simplex.Messaging.Server.QueueStore import Simplex.Messaging.Server.QueueStore.QueueInfo @@ -193,11 +195,17 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg} attachHT stopServer s = do asks serverActive >>= atomically . (`writeTVar` False) logInfo "Saving server state..." - withLock' (savingLock s) "final" $ saveServer False >> closeServer + withLock' (savingLock s) "final" $ saveServer True >> closeServer logInfo "Server stopped" saveServer :: Bool -> M () - saveServer keepMsgs = withLog closeStoreLog >> saveServerMessages keepMsgs >> saveServerNtfs >> saveServerStats + saveServer drainMsgs = do + withLog closeStoreLog + AMS _ ms <- asks msgStore + liftIO $ closeMsgStore ms + saveServerMessages drainMsgs + saveServerNtfs + saveServerStats closeServer :: M () closeServer = asks (smpAgent . proxyAgent) >>= liftIO . closeSMPClientAgent @@ -351,19 +359,17 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg} attachHT expireMessagesThread :: ExpirationConfig -> M () expireMessagesThread expCfg = do - ms <- asks msgStore - quota <- asks $ msgQueueQuota . config + AMS _ ms <- asks msgStore let interval = checkInterval expCfg * 1000000 stats <- asks serverStats labelMyThread "expireMessagesThread" - forever $ do - liftIO $ threadDelay' interval - old <- liftIO $ expireBeforeEpoch expCfg - rIds <- M.keysSet <$> readTVarIO ms - forM_ rIds $ \rId -> do - q <- liftIO $ getMsgQueue ms rId quota - deleted <- liftIO $ deleteExpiredMsgs q old - liftIO $ atomicModifyIORef'_ (msgExpired stats) (+ deleted) + liftIO $ forever $ do + threadDelay' interval + old <- expireBeforeEpoch expCfg + void $ withActiveMsgQueues ms $ \_ q -> do + runExceptT (deleteExpiredMsgs q old) >>= \case + Right deleted -> deleted <$ atomicModifyIORef'_ (msgExpired stats) (+ deleted) + Left _ -> pure 0 expireNtfsThread :: ServerConfig -> M () expireNtfsThread ServerConfig {notificationExpiration = expCfg} = do @@ -767,7 +773,7 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg} attachHT ProhibitSub -> pure (c1, c2, c3, c4 + 1) CPDelete queueId' -> withUserRole $ unliftIO u $ do st <- asks queueStore - ms <- asks msgStore + AMS _ ms <- asks msgStore queueId <- liftIO (getQueue st SSender queueId') >>= \case Left _ -> pure queueId' -- fallback to using as recipientId directly Right QueueRec {recipientId} -> pure recipientId @@ -782,7 +788,7 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg} attachHT liftIO . hPutStrLn h $ "ok, " <> show numDeleted <> " messages deleted" CPSave -> withAdminRole $ withLock' (savingLock srv) "control" $ do hPutStrLn h "saving server state..." - unliftIO u $ saveServer True + unliftIO u $ saveServer False hPutStrLn h "server state saved!" CPHelp -> hPutStrLn h "commands: stats, stats-rts, clients, sockets, socket-threads, threads, server-info, delete, save, help, quit" CPQuit -> pure () @@ -1166,7 +1172,7 @@ client thParams' clnt@Client {clientId, subscriptions, ntfSubscriptions, rcvQ, s NDEL -> deleteQueueNotifier_ st OFF -> suspendQueue_ st DEL -> delQueueAndMsgs st - QUE -> withQueue getQueueInfo + QUE -> withQueue $ fmap (corrId,entId,) . getQueueInfo where createQueue :: QueueStore -> RcvPublicAuthKey -> RcvPublicDhKey -> SubscriptionMode -> SenderCanSecure -> M (Transmission BrokerMsg) createQueue st recipientKey dhKey subMode sndSecure = time "NEW" $ do @@ -1262,7 +1268,7 @@ client thParams' clnt@Client {clientId, subscriptions, ntfSubscriptions, rcvQ, s okResp <$> liftIO (suspendQueue st entId) subscribeQueue :: QueueRec -> RecipientId -> M (Transmission BrokerMsg) - subscribeQueue qr rId = do + subscribeQueue qr rId = atomically (TM.lookup rId subscriptions) >>= \case Nothing -> newSub >>= deliver True Just s@Sub {subThread} -> do @@ -1284,11 +1290,13 @@ client thParams' clnt@Client {clientId, subscriptions, ntfSubscriptions, rcvQ, s pure sub deliver :: Bool -> Sub -> M (Transmission BrokerMsg) deliver inc sub = do - q <- getStoreMsgQueue "SUB" rId - msg_ <- liftIO $ tryPeekMsgIO q - when (inc && isJust msg_) $ - incStat . qSub =<< asks serverStats - deliverMessage "SUB" qr rId sub msg_ + AMS _ ms <- asks msgStore + stats <- asks serverStats + fmap (either (\e -> (corrId, rId, ERR e)) id) $ liftIO $ runExceptT $ do + q <- getMsgQueue ms rId + msg_ <- tryPeekMsg q + liftIO $ when (inc && isJust msg_) $ incStat (qSub stats) + liftIO $ deliverMessage "SUB" qr rId sub msg_ -- clients that use GET are not added to server subscribers getMessage :: QueueRec -> M (Transmission BrokerMsg) @@ -1305,7 +1313,7 @@ client thParams' clnt@Client {clientId, subscriptions, ntfSubscriptions, rcvQ, s _ -> do stats <- asks serverStats incStat $ msgGetProhibited stats - pure (corrId, entId, ERR $ CMD PROHIBITED) + pure $ err $ CMD PROHIBITED where newSub :: STM Sub newSub = do @@ -1318,19 +1326,16 @@ client thParams' clnt@Client {clientId, subscriptions, ntfSubscriptions, rcvQ, s pure s getMessage_ :: Sub -> Maybe MsgId -> M (Transmission BrokerMsg) getMessage_ s delivered_ = do - q <- getStoreMsgQueue "GET" entId + AMS _ ms <- asks msgStore stats <- asks serverStats - (statCnt, r) <- - -- TODO split STM, use tryPeekMsgIO - atomically $ - tryPeekMsg q >>= \case - Just msg -> - let encMsg = encryptMsg qr msg - cnt = if isJust delivered_ then msgGetDuplicate else msgGet - in setDelivered s msg $> (cnt, (corrId, entId, MSG encMsg)) - _ -> pure (msgGetNoMsg, (corrId, entId, OK)) - incStat $ statCnt stats - pure r + fmap (either err id) $ liftIO $ runExceptT $ do + q <- getMsgQueue ms entId + tryPeekMsg q >>= \case + Just msg -> do + let encMsg = encryptMsg qr msg + incStat $ (if isJust delivered_ then msgGetDuplicate else msgGet) stats + atomically $ setDelivered s msg $> (corrId, entId, MSG encMsg) + Nothing -> incStat (msgGetNoMsg stats) $> ok withQueue :: (QueueRec -> M (Transmission BrokerMsg)) -> M (Transmission BrokerMsg) withQueue action = case qr_ of @@ -1367,16 +1372,19 @@ client thParams' clnt@Client {clientId, subscriptions, ntfSubscriptions, rcvQ, s Just sub -> atomically (getDelivered sub) >>= \case Just st -> do - q <- getStoreMsgQueue "ACK" entId - case st of - ProhibitSub -> do - deletedMsg_ <- liftIO $ tryDelMsg q msgId - mapM_ (updateStats True) deletedMsg_ - pure ok - _ -> do - (deletedMsg_, msg_) <- liftIO $ tryDelPeekMsg q msgId - mapM_ (updateStats False) deletedMsg_ - deliverMessage "ACK" qr entId sub msg_ + AMS _ ms <- asks msgStore + stats <- asks serverStats + fmap (either err id) $ liftIO $ runExceptT $ do + q <- getMsgQueue ms entId + case st of + ProhibitSub -> do + deletedMsg_ <- tryDelMsg q msgId + liftIO $ mapM_ (updateStats stats True) deletedMsg_ + pure ok + _ -> do + (deletedMsg_, msg_) <- tryDelPeekMsg q msgId + liftIO $ mapM_ (updateStats stats False) deletedMsg_ + liftIO $ deliverMessage "ACK" qr entId sub msg_ _ -> pure $ err NO_MSG where getDelivered :: Sub -> STM (Maybe ServerSub) @@ -1385,11 +1393,10 @@ client thParams' clnt@Client {clientId, subscriptions, ntfSubscriptions, rcvQ, s if msgId == msgId' || B.null msgId then pure $ Just subThread else putTMVar delivered msgId' $> Nothing - updateStats :: Bool -> Message -> M () - updateStats isGet = \case + updateStats :: ServerStats -> Bool -> Message -> IO () + updateStats stats isGet = \case MessageQuota {} -> pure () Message {msgFlags} -> do - stats <- asks serverStats incStat $ msgRecv stats if isGet then incStat $ msgRecvGet stats @@ -1399,11 +1406,11 @@ client thParams' clnt@Client {clientId, subscriptions, ntfSubscriptions, rcvQ, s -- ns <- asks ntfStore -- atomically $ TM.lookup nId ns >>= -- mapM_ (\MsgNtf {ntfMsgId} -> when (msgId == msgId') $ TM.delete nId ns) - liftIO $ atomicModifyIORef'_ (msgCount stats) (subtract 1) - liftIO $ updatePeriodStats (activeQueues stats) entId + atomicModifyIORef'_ (msgCount stats) (subtract 1) + updatePeriodStats (activeQueues stats) entId when (notification msgFlags) $ do incStat $ msgRecvNtf stats - liftIO $ updatePeriodStats (activeQueuesNtf stats) entId + updatePeriodStats (activeQueuesNtf stats) entId sendMessage :: QueueRec -> MsgFlags -> MsgBody -> M (Transmission BrokerMsg) sendMessage qr msgFlags msgBody @@ -1421,15 +1428,20 @@ client thParams' clnt@Client {clientId, subscriptions, ntfSubscriptions, rcvQ, s case C.maxLenBS msgBody of Left _ -> pure $ err LARGE_MSG Right body -> do - msg_ <- time "SEND" $ do - q <- getStoreMsgQueue "SEND" $ recipientId qr - expireMessages q - liftIO . writeMsg q =<< mkMessage body + AMS _ ms <- asks msgStore + ServerConfig {messageExpiration, msgIdBytes} <- asks config + msgId <- randomId' msgIdBytes + msg_ <- liftIO $ time "SEND" $ runExceptT $ do + q <- getMsgQueue ms $ recipientId qr + expireMessages q messageExpiration stats + msg <- liftIO $ mkMessage msgId body + writeMsg q True msg case msg_ of - Nothing -> do + Left e -> pure $ err e + Right Nothing -> do incStat $ msgSentQuota stats pure $ err QUOTA - Just (msg, wasEmpty) -> time "SEND ok" $ do + Right (Just (msg, wasEmpty)) -> time "SEND ok" $ do when wasEmpty $ liftIO $ tryDeliverMessage msg when (notification msgFlags) $ do mapM_ (`enqueueNotification` msg) (notifier qr) @@ -1441,20 +1453,15 @@ client thParams' clnt@Client {clientId, subscriptions, ntfSubscriptions, rcvQ, s pure ok where THandleParams {thVersion} = thParams' - mkMessage :: C.MaxLenBS MaxMessageLen -> M Message - mkMessage body = do - msgId <- randomId' =<< asks (msgIdBytes . config) - msgTs <- liftIO getSystemTime + mkMessage :: MsgId -> C.MaxLenBS MaxMessageLen -> IO Message + mkMessage msgId body = do + msgTs <- getSystemTime pure $! Message msgId msgTs msgFlags body - expireMessages :: MsgQueue -> M () - expireMessages q = do - msgExp <- asks $ messageExpiration . config - old <- liftIO $ mapM expireBeforeEpoch msgExp - deleted <- liftIO $ sum <$> mapM (deleteExpiredMsgs q) old - when (deleted > 0) $ do - stats <- asks serverStats - liftIO $ atomicModifyIORef'_ (msgExpired stats) (+ deleted) + expireMessages :: MsgStoreClass s => MsgQueue s -> Maybe ExpirationConfig -> ServerStats -> ExceptT ErrorType IO () + expireMessages q msgExp stats = do + deleted <- maybe (pure 0) (deleteExpiredMsgs q <=< liftIO . expireBeforeEpoch) msgExp + liftIO $ when (deleted > 0) $ atomicModifyIORef'_ (msgExpired stats) (+ deleted) -- The condition for delivery of the message is: -- - the queue was empty when the message was sent, @@ -1472,7 +1479,6 @@ client thParams' clnt@Client {clientId, subscriptions, ntfSubscriptions, rcvQ, s atomically deliverToSub >>= mapM_ forkDeliver where rId = recipientId qr - -- remove tryPeekMsg deliverToSub = -- lookup has ot be in the same transaction, -- so that if subscription ends, it re-evalutates @@ -1586,7 +1592,7 @@ client thParams' clnt@Client {clientId, subscriptions, ntfSubscriptions, rcvQ, s verified = \case VRVerified qr -> Right (qr, (corrId', entId', cmd')) VRFailed -> Left (corrId', entId', ERR AUTH) - deliverMessage :: T.Text -> QueueRec -> RecipientId -> Sub -> Maybe Message -> M (Transmission BrokerMsg) + deliverMessage :: T.Text -> QueueRec -> RecipientId -> Sub -> Maybe Message -> IO (Transmission BrokerMsg) deliverMessage name qr rId s@Sub {subThread} msg_ = time (name <> " deliver") . atomically $ case subThread of ProhibitSub -> pure resp @@ -1614,16 +1620,10 @@ client thParams' clnt@Client {clientId, subscriptions, ntfSubscriptions, rcvQ, s setDelivered :: Sub -> Message -> STM Bool setDelivered s msg = tryPutTMVar (delivered s) $! messageId msg - getStoreMsgQueue :: T.Text -> RecipientId -> M MsgQueue - getStoreMsgQueue name rId = time (name <> " getMsgQueue") $ do - ms <- asks msgStore - quota <- asks $ msgQueueQuota . config - liftIO $ getMsgQueue ms rId quota - delQueueAndMsgs :: QueueStore -> M (Transmission BrokerMsg) delQueueAndMsgs st = do withLog (`logDeleteQueue` entId) - ms <- asks msgStore + AMS _ ms <- asks msgStore liftIO (deleteQueue st entId $>>= \q -> delMsgQueue ms entId $> Right q) >>= \case Right q -> do -- Possibly, the same should be done if the queue is suspended, but currently we do not use it @@ -1643,14 +1643,16 @@ client thParams' clnt@Client {clientId, subscriptions, ntfSubscriptions, rcvQ, s pure ok Left e -> pure $ err e - getQueueInfo :: QueueRec -> M (Transmission BrokerMsg) + getQueueInfo :: QueueRec -> M BrokerMsg getQueueInfo QueueRec {senderKey, notifier} = do - q <- getStoreMsgQueue "getQueueInfo" entId - qiSub <- liftIO $ TM.lookupIO entId subscriptions >>= mapM mkQSub - qiSize <- liftIO $ getQueueSize q - qiMsg <- liftIO $ toMsgInfo <$$> tryPeekMsgIO q - let info = QueueInfo {qiSnd = isJust senderKey, qiNtf = isJust notifier, qiSub, qiSize, qiMsg} - pure (corrId, entId, INFO info) + AMS _ ms <- asks msgStore + fmap (either ERR id) $ liftIO $ runExceptT $ do + q <- getMsgQueue ms entId + qiSub <- liftIO $ TM.lookupIO entId subscriptions >>= mapM mkQSub + qiSize <- liftIO $ getQueueSize q + qiMsg <- toMsgInfo <$$> tryPeekMsg q + let info = QueueInfo {qiSnd = isJust senderKey, qiNtf = isJust notifier, qiSub, qiSize, qiMsg} + pure $ INFO info where mkQSub Sub {subThread, delivered} = do qSubThread <- case subThread of @@ -1710,59 +1712,69 @@ randomId = fmap EntityId . randomId' {-# INLINE randomId #-} saveServerMessages :: Bool -> M () -saveServerMessages keepMsgs = asks (storeMsgsFile . config) >>= mapM_ saveMessages +saveServerMessages drainMsgs = + asks msgStore >>= \case + AMS SMSMemory ms@STMMsgStore {storeConfig = STMStoreConfig {storePath}} -> case storePath of + Just f -> liftIO $ exportMessages ms f $ getQueueMessages drainMsgs + Nothing -> logInfo "undelivered messages are not saved" + AMS SMSJournal _ -> logInfo "closed journal message storage" + +exportMessages :: MsgStoreClass s => s -> FilePath -> (MsgQueue s -> IO [Message]) -> IO () +exportMessages ms f getMessages = do + logInfo $ "saving messages to file " <> T.pack f + total <- liftIO $ withFile f WriteMode $ withAllMsgQueues ms . saveQueueMsgs + logInfo $ "messages saved: " <> tshow total where - saveMessages f = do - logInfo $ "saving messages to file " <> T.pack f - ms <- asks msgStore - liftIO . withFile f WriteMode $ \h -> - readTVarIO ms >>= mapM_ (saveQueueMsgs h) . M.assocs - logInfo "messages saved" - where - saveQueueMsgs h (rId, q) = BLD.hPutBuilder h . encodeMessages rId =<< atomically (getMessages $ msgQueue q) - getMessages = if keepMsgs then snapshotTQueue else flushTQueue - snapshotTQueue q = do - msgs <- flushTQueue q - mapM_ (writeTQueue q) msgs - pure msgs - encodeMessages rId = mconcat . map (\msg -> BLD.byteString (strEncode $ MLRv3 rId msg) <> BLD.char8 '\n') + saveQueueMsgs h rId q = getMessages q >>= \msgs -> length msgs <$ BLD.hPutBuilder h (encodeMessages rId msgs) + encodeMessages rId = mconcat . map (\msg -> BLD.byteString (strEncode $ MLRv3 rId msg) <> BLD.char8 '\n') restoreServerMessages :: M Int restoreServerMessages = - asks (storeMsgsFile . config) >>= \case - Just f -> ifM (doesFileExist f) (restoreMessages f) (pure 0) - Nothing -> pure 0 - where - restoreMessages f = do - logInfo $ "restoring messages from file " <> T.pack f - ms <- asks msgStore - quota <- asks $ msgQueueQuota . config + asks msgStore >>= \case + AMS SMSMemory ms@STMMsgStore {storeConfig = STMStoreConfig {storePath = Just f}} -> do old_ <- asks (messageExpiration . config) $>>= (liftIO . fmap Just . expireBeforeEpoch) - runExceptT (liftIO (LB.readFile f) >>= foldM (\expired -> restoreMsg expired ms quota old_) 0 . LB.lines) >>= \case - Left e -> do - logError . T.pack $ "error restoring messages: " <> e - liftIO exitFailure - Right expired -> do - renameFile f $ f <> ".bak" - logInfo "messages restored" - pure expired + liftIO $ ifM (doesFileExist f) (importMessages ms f old_) (pure 0) + _ -> logInfo "using journal message storage" $> 0 + +importMessages :: MsgStoreClass s => s -> FilePath -> Maybe Int64 -> IO Int +importMessages ms f old_ = do + logInfo $ "restoring messages from file " <> T.pack f + LB.readFile f >>= runExceptT . foldM restoreMsg (0, 0, 0) . zip [0..] . LB.lines >>= \case + Left e -> do + putStrLn "" + logError . T.pack $ "error restoring messages: " <> e + liftIO exitFailure + Right (count, total, expired) -> do + putStrLn "" + renameFile f $ f <> ".bak" + logQueueStates ms + qCount <- M.size <$> readTVarIO (activeMsgQueues ms) + logInfo $ "Processed " <> tshow count <> " lines, imported " <> tshow total <> " messages into " <> tshow qCount <> " queues, expired " <> tshow expired <> " messages" + pure expired + where + progress i = do + liftIO $ putStr $ "Processed " <> show i <> " lines\r" + hFlush stdout + restoreMsg :: (Int, Int, Int) -> (Int, LB.ByteString) -> ExceptT String IO (Int, Int, Int) + restoreMsg (!count, !total, !expired) (i, s') = do + when (i `mod` 1000 == 0) $ progress i + MLRv3 rId msg <- liftEither . first (msgErr "parsing") $ strDecode s + liftError show $ addToMsgQueue rId msg where - restoreMsg !expired ms quota old_ s' = do - MLRv3 rId msg <- liftEither . first (msgErr "parsing") $ strDecode s - addToMsgQueue rId msg - where - s = LB.toStrict s' - addToMsgQueue rId msg = do - q <- liftIO $ getMsgQueue ms rId quota - (isExpired, logFull) <- liftIO $ case msg of - Message {msgTs} - | maybe True (systemSeconds msgTs >=) old_ -> (False,) . isNothing <$> writeMsg q msg - | otherwise -> pure (True, False) - MessageQuota {} -> writeMsg q msg $> (False, False) - when logFull . logError . decodeLatin1 $ "message queue " <> strEncode rId <> " is full, message not restored: " <> strEncode (messageId msg) - pure $ if isExpired then expired + 1 else expired - msgErr :: Show e => String -> e -> String - msgErr op e = op <> " error (" <> show e <> "): " <> B.unpack (B.take 100 s) + s = LB.toStrict s' + addToMsgQueue rId msg = do + q <- getMsgQueue ms rId + (isExpired, logFull) <- case msg of + Message {msgTs} + | maybe True (systemSeconds msgTs >=) old_ -> (False,) . isNothing <$> writeMsg q False msg + | otherwise -> pure (True, False) + MessageQuota {} -> writeMsg q False msg $> (False, False) + when logFull . logError . decodeLatin1 $ "message queue " <> strEncode rId <> " is full, message not restored: " <> strEncode (messageId msg) + let total' = if logFull then total else total + 1 + expired' = if isExpired then expired + 1 else expired + pure (count + 1, total', expired') + msgErr :: Show e => String -> e -> String + msgErr op e = op <> " error (" <> show e <> "): " <> B.unpack (B.take 100 s) saveServerNtfs :: M () saveServerNtfs = asks (storeNtfsFile . config) >>= mapM_ saveNtfs @@ -1827,7 +1839,10 @@ restoreServerStats expiredMsgs expiredNtfs = asks (serverStatsBackupFile . confi Right d@ServerStatsData {_qCount = statsQCount} -> do s <- asks serverStats _qCount <- fmap M.size . readTVarIO . queues =<< asks queueStore - _msgCount <- liftIO . foldM (\(!n) q -> (n +) <$> getQueueSize q) 0 =<< readTVarIO =<< asks msgStore + _msgCount <- + asks msgStore >>= \case + AMS SMSMemory ms -> liftIO $ readTVarIO (msgQueues ms) >>= foldM (\(!n) q -> (n +) <$> getQueueSize q) 0 + _ -> pure 0 NtfStore ns <- asks ntfStore _ntfCount <- liftIO . foldM (\(!n) q -> (n +) . length <$> readTVarIO q) 0 =<< readTVarIO ns liftIO $ setServerStats s d {_qCount, _msgCount, _ntfCount, _msgExpired = _msgExpired d + expiredMsgs, _msgNtfExpired = _msgNtfExpired d + expiredNtfs} diff --git a/src/Simplex/Messaging/Server/CLI.hs b/src/Simplex/Messaging/Server/CLI.hs index 30e5a0b58..feead1163 100644 --- a/src/Simplex/Messaging/Server/CLI.hs +++ b/src/Simplex/Messaging/Server/CLI.hs @@ -44,11 +44,11 @@ import Text.Read (readMaybe) exitError :: String -> IO a exitError msg = putStrLn msg >> exitFailure -confirmOrExit :: String -> IO () -confirmOrExit s = +confirmOrExit :: String -> String -> IO () +confirmOrExit s no = withPrompt (s <> "\nContinue (Y/n): ") $ do ok <- getLine - when (ok /= "Y") $ putStrLn "Server NOT deleted" >> exitFailure + when (ok /= "Y") $ putStrLn no >> exitFailure data SignAlgorithm = ED448 | ED25519 deriving (Read, Show) diff --git a/src/Simplex/Messaging/Server/Env/STM.hs b/src/Simplex/Messaging/Server/Env/STM.hs index debd36c12..c8169fbc7 100644 --- a/src/Simplex/Messaging/Server/Env/STM.hs +++ b/src/Simplex/Messaging/Server/Env/STM.hs @@ -1,10 +1,14 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StrictData #-} +{-# LANGUAGE TypeFamilies #-} module Simplex.Messaging.Server.Env.STM where @@ -37,7 +41,9 @@ import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Protocol import Simplex.Messaging.Server.Expiration import Simplex.Messaging.Server.Information +import Simplex.Messaging.Server.MsgStore.Journal import Simplex.Messaging.Server.MsgStore.STM +import Simplex.Messaging.Server.MsgStore.Types import Simplex.Messaging.Server.NtfStore import Simplex.Messaging.Server.QueueStore (NtfCreds (..), QueueRec (..)) import Simplex.Messaging.Server.QueueStore.STM @@ -57,7 +63,10 @@ data ServerConfig = ServerConfig { transports :: [(ServiceName, ATransport, AddHTTP)], smpHandshakeTimeout :: Int, tbqSize :: Natural, + msgStoreType :: AMSType, msgQueueQuota :: Int, + maxJournalMsgCount :: Int, + maxJournalStateLines :: Int, queueIdBytes :: Int, msgIdBytes :: Int, storeLogFile :: Maybe FilePath, @@ -136,6 +145,18 @@ defaultInactiveClientExpiration = defaultProxyClientConcurrency :: Int defaultProxyClientConcurrency = 32 +journalMsgStoreDepth :: Int +journalMsgStoreDepth = 5 + +defaultMaxJournalStateLines :: Int +defaultMaxJournalStateLines = 16 + +defaultMaxJournalMsgCount :: Int +defaultMaxJournalMsgCount = 256 + +defaultMsgQueueQuota :: Int +defaultMsgQueueQuota = 128 + data Env = Env { config :: ServerConfig, serverActive :: TVar Bool, @@ -143,7 +164,7 @@ data Env = Env server :: Server, serverIdentity :: KeyHash, queueStore :: QueueStore, - msgStore :: STMMsgStore, + msgStore :: AMsgStore, ntfStore :: NtfStore, random :: TVar ChaChaDRG, storeLog :: Maybe (StoreLog 'WriteMode), @@ -156,6 +177,20 @@ data Env = Env proxyAgent :: ProxyAgent -- senders served on this proxy } +type family MsgStore s where + MsgStore 'MSMemory = STMMsgStore + MsgStore 'MSJournal = JournalMsgStore + +data AMsgStore = forall s. MsgStoreClass (MsgStore s) => AMS (SMSType s) (MsgStore s) + +data AMsgQueue = forall s. MsgStoreClass (MsgStore s) => AMQ (SMSType s) (MsgQueue (MsgStore s)) + +data AMsgStoreCfg = forall s. MsgStoreClass (MsgStore s) => AMSC (SMSType s) (MsgStoreConfig (MsgStore s)) + +msgPersistence :: AMsgStoreCfg -> Bool +msgPersistence (AMSC SMSMemory (STMStoreConfig {storePath})) = isJust storePath +msgPersistence (AMSC SMSJournal _) = True + type Subscribed = Bool data Server = Server @@ -213,7 +248,7 @@ newServer = do ntfSubClients <- newTVarIO IM.empty pendingSubEvents <- newTVarIO IM.empty pendingNtfSubEvents <- newTVarIO IM.empty - savingLock <- atomically createLock + savingLock <- createLockIO return Server {subscribedQ, subscribers, ntfSubscribedQ, notifiers, subClients, ntfSubClients, pendingSubEvents, pendingNtfSubEvents, savingLock} newClient :: ClientId -> Natural -> VersionSMP -> ByteString -> SystemTime -> IO Client @@ -243,11 +278,17 @@ newProhibitedSub = do return Sub {subThread = ProhibitSub, delivered} newEnv :: ServerConfig -> IO Env -newEnv config@ServerConfig {smpCredentials, httpCredentials, storeLogFile, smpAgentCfg, information, messageExpiration} = do +newEnv config@ServerConfig {smpCredentials, httpCredentials, storeLogFile, msgStoreType, storeMsgsFile, smpAgentCfg, information, messageExpiration, msgQueueQuota, maxJournalMsgCount, maxJournalStateLines} = do serverActive <- newTVarIO True server <- newServer queueStore <- newQueueStore - msgStore <- newMsgStore + msgStore <- 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, maxMsgCount = maxJournalMsgCount, maxStateLines = maxJournalStateLines} + in AMS SMSJournal <$> newMsgStore cfg + Nothing -> putStrLn "Error: journal msg store require path in [STORE_LOG], restore_messages" >> exitFailure ntfStore <- NtfStore <$> TM.emptyIO random <- C.newRandom storeLog <- @@ -314,7 +355,7 @@ newEnv config@ServerConfig {smpCredentials, httpCredentials, storeLogFile, smpAg where persistence | isNothing storeLogFile = SPMMemoryOnly - | isJust (storeMsgsFile config) = SPMMessages + | isJust storeMsgsFile = SPMMessages | otherwise = SPMQueues newSMPProxyAgent :: SMPClientAgentConfig -> TVar ChaChaDRG -> IO ProxyAgent diff --git a/src/Simplex/Messaging/Server/Main.hs b/src/Simplex/Messaging/Server/Main.hs index 685b28048..ddd51e815 100644 --- a/src/Simplex/Messaging/Server/Main.hs +++ b/src/Simplex/Messaging/Server/Main.hs @@ -1,6 +1,6 @@ {-# LANGUAGE ApplicativeDo #-} -{-# LANGUAGE BangPatterns #-} {-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedLists #-} @@ -20,6 +20,7 @@ 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.Functor (($>)) import Data.Ini (Ini, lookupValue, readIniFile) import Data.List (find, isPrefixOf) @@ -27,7 +28,7 @@ import qualified Data.List.NonEmpty as L import Data.Maybe (fromMaybe, isJust, isNothing) import Data.Text (Text) import qualified Data.Text as T -import Data.Text.Encoding (encodeUtf8, decodeLatin1) +import Data.Text.Encoding (decodeLatin1, encodeUtf8) import qualified Data.Text.IO as T import Network.Socket (HostName) import Options.Applicative @@ -38,17 +39,19 @@ import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Encoding.String import Simplex.Messaging.Parsers (parseAll) import Simplex.Messaging.Protocol (BasicAuth (..), ProtoServerWithAuth (ProtoServerWithAuth), pattern SMPServer) -import Simplex.Messaging.Server (AttachHTTP, runSMPServer) +import Simplex.Messaging.Server (AttachHTTP, exportMessages, importMessages, runSMPServer) 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 (..), getQueueMessages) +import Simplex.Messaging.Server.MsgStore.Types (AMSType (..), SMSType (..), newMsgStore) 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, safeDecodeUtf8, tshow) import Simplex.Messaging.Version (mkVersionRange) -import System.Directory (createDirectoryIfMissing, doesFileExist) +import System.Directory (createDirectoryIfMissing, doesDirectoryExist, doesFileExist) import System.Exit (exitFailure) import System.FilePath (combine) import System.IO (BufferMode (..), hSetBuffering, stderr, stdout) @@ -70,25 +73,73 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath = doesFileExist iniFile >>= \case True -> exitError $ "Error: server is already initialized (" <> iniFile <> " exists).\nRun `" <> executableName <> " start`." _ -> initializeServer opts - OnlineCert certOpts -> - doesFileExist iniFile >>= \case - True -> genOnline cfgPath certOpts - _ -> exitError $ "Error: server is not initialized (" <> iniFile <> " does not exist).\nRun `" <> executableName <> " init`." - Start -> - doesFileExist iniFile >>= \case - True -> readIniFile iniFile >>= either exitError runServer - _ -> exitError $ "Error: server is not initialized (" <> iniFile <> " does not exist).\nRun `" <> executableName <> " init`." + OnlineCert certOpts -> withIniFile $ \_ -> genOnline cfgPath certOpts + Start -> withIniFile runServer Delete -> do - confirmOrExit "WARNING: deleting the server will make all queues inaccessible, because the server identity (certificate fingerprint) will change.\nTHIS CANNOT BE UNDONE!" + confirmOrExit + "WARNING: deleting the server will make all queues inaccessible, because the server identity (certificate fingerprint) will change.\nTHIS CANNOT BE UNDONE!" + "Server NOT deleted" deleteDirIfExists cfgPath deleteDirIfExists logPath putStrLn "Deleted configuration and log files" + Journal cmd -> withIniFile $ \ini -> do + msgsDirExists <- doesDirectoryExist storeMsgsJournalDir + msgsFileExists <- doesFileExist storeMsgsFilePath + when (msgsFileExists && msgsDirExists) exitConfigureMsgStorage + case cmd of + JCImport + | 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 + void $ importMessages ms storeMsgsFilePath Nothing -- no expiration + putStrLn "Import completed" + putStrLn $ case readMsgStoreType ini of + Right (AMSType SMSMemory) -> "store_messages set to `memory`, update it to `journal` in INI file" + Right (AMSType SMSJournal) -> "store_messages set to `journal`" + Left e -> e <> ", update it to `journal` in INI file" + JCExport + | 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 + exportMessages ms storeMsgsFilePath $ getQueueMessages False + putStrLn "Export completed" + putStrLn $ case readMsgStoreType ini of + Right (AMSType SMSMemory) -> "store_messages set to `memory`" + Right (AMSType SMSJournal) -> "store_messages set to `journal`, update it to `memory` in INI file" + Left e -> e <> ", update it to `memory` in INI file" where + withIniFile a = + doesFileExist iniFile >>= \case + True -> readIniFile iniFile >>= either exitError a + _ -> exitError $ "Error: server is not initialized (" <> iniFile <> " does not exist).\nRun `" <> executableName <> " init`." + newJournalMsgStore = newMsgStore JournalStoreConfig {storePath = storeMsgsJournalDir, pathParts = journalMsgStoreDepth, quota = defaultMsgQueueQuota, maxMsgCount = defaultMaxJournalMsgCount, maxStateLines = defaultMaxJournalStateLines} iniFile = combine cfgPath "smp-server.ini" serverVersion = "SMP server v" <> simplexMQVersion defaultServerPorts = "5223,443" executableName = "smp-server" storeLogFilePath = combine logPath "smp-server-store.log" + storeMsgsFilePath = combine logPath "smp-server-messages.log" + storeMsgsJournalDir = combine logPath "messages" + storeNtfsFilePath = combine logPath "smp-server-ntfs.log" + readMsgStoreType :: Ini -> Either String AMSType + readMsgStoreType = textToMsgStoreType . fromRight "memory" . lookupValue "STORE_LOG" "store_messages" + textToMsgStoreType = \case + "memory" -> Right $ AMSType SMSMemory + "journal" -> Right $ AMSType SMSJournal + s -> Left $ "invalid store_messages: " <> T.unpack s httpsCertFile = combine cfgPath "web.crt" httpsKeyFile = combine cfgPath "web.key" defaultStaticPath = combine logPath "www" @@ -128,7 +179,7 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath = _ -> putStrLn "Invalid password. Only latin letters, digits and symbols other than '@' and ':' are allowed" >> serverPassword checkInitOptions InitOptions {sourceCode, serverInfo, operatorCountry, hostingCountry} = do let err_ - | isNothing sourceCode && hasServerInfo serverInfo = + | isNothing sourceCode && hasServerInfo serverInfo = Just "Error: passing any server information requires passing --source-code" | isNothing (operator serverInfo) && isJust operatorCountry = Just "Error: passing --operator-country requires passing --operator" @@ -168,9 +219,12 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath = \# and restoring it when the server is started.\n\ \# Log is compacted on start (deleted objects are removed).\n" <> ("enable: " <> onOff enableStoreLog <> "\n\n") - <> "# Undelivered messages are optionally saved and restored when the server restarts,\n\ - \# they are preserved in the .bak file until the next restart.\n" - <> ("restore_messages: " <> onOff enableStoreLog <> "\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\ + \# when the server restarts, they are preserved in the .bak file until the next restart.\n" + <> ("restore_messages: " <> onOff enableStoreLog <> "\n\n") + <> "# Messages and notifications expiration periods.\n" <> ("expire_messages_days: " <> tshow defMsgExpirationDays <> "\n") <> ("expire_ntfs_hours: " <> tshow defNtfExpirationHours <> "\n\n") <> "# Log daily server statistics to CSV file\n" @@ -248,12 +302,13 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath = fp <- checkSavedFingerprint cfgPath defaultX509Config let host = either (const "") T.unpack $ lookupValue "TRANSPORT" "host" ini port = T.unpack $ strictIni "TRANSPORT" "port" ini - cfg@ServerConfig {information, storeLogFile, newQueueBasicAuth, messageExpiration, inactiveClientExpiration} = serverConfig + cfg@ServerConfig {information, storeLogFile, msgStoreType, newQueueBasicAuth, messageExpiration, inactiveClientExpiration} = serverConfig sourceCode' = (\ServerPublicInfo {sourceCode} -> sourceCode) <$> information srv = ProtoServerWithAuth (SMPServer [THDomainName host] (if port == "5223" then "" else port) (C.KeyHash fp)) newQueueBasicAuth printServiceInfo serverVersion srv printSourceCode sourceCode' printServerConfig transports storeLogFile + checkMsgStoreMode msgStoreType putStrLn $ case messageExpiration of Just ExpirationConfig {ttl} -> "expiring messages after " <> showTTL ttl _ -> "not expiring messages" @@ -302,12 +357,16 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath = _ -> enableStoreLog $> path transports = iniTransports ini sharedHTTP = any (\(_, _, addHTTP) -> addHTTP) transports + iniMsgStoreType = either error id $! readMsgStoreType ini serverConfig = ServerConfig { transports, smpHandshakeTimeout = 120000000, tbqSize = 128, - msgQueueQuota = 128, + msgStoreType = iniMsgStoreType, + msgQueueQuota = defaultMsgQueueQuota, + maxJournalMsgCount = defaultMaxJournalMsgCount, + maxJournalStateLines = defaultMaxJournalStateLines, queueIdBytes = 24, msgIdBytes = 24, -- must be at least 24 bytes, it is used as 192-bit nonce for XSalsa20 smpCredentials = @@ -318,8 +377,10 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath = }, httpCredentials = (\WebHttpsParams {key, cert} -> ServerCredentials {caCertificateFile = Nothing, privateKeyFile = key, certificateFile = cert}) <$> webHttpsParams', storeLogFile = enableStoreLog $> storeLogFilePath, - storeMsgsFile = restoreMessagesFile $ combine logPath "smp-server-messages.log", - storeNtfsFile = restoreMessagesFile $ combine logPath "smp-server-ntfs.log", + storeMsgsFile = case iniMsgStoreType of + AMSType SMSMemory -> restoreMessagesFile storeMsgsFilePath + AMSType SMSJournal -> Just storeMsgsJournalDir, + storeNtfsFile = restoreMessagesFile storeNtfsFilePath, -- allow creating new queues by default allowNewQueues = fromMaybe True $ iniOnOff "AUTH" "new_queues" ini, newQueueBasicAuth = either error id <$!> strDecodeIni "AUTH" "create_password" ini, @@ -393,6 +454,31 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath = pure WebHttpsParams {port, cert, key} webStaticPath' = eitherToMaybe $ T.unpack <$> lookupValue "WEB" "static_path" ini + checkMsgStoreMode :: AMSType -> IO () + checkMsgStoreMode mode = do + msgsDirExists <- doesDirectoryExist storeMsgsJournalDir + msgsFileExists <- doesFileExist storeMsgsFilePath + case mode of + _ | msgsFileExists && msgsDirExists -> exitConfigureMsgStorage + AMSType SMSJournal + | msgsFileExists -> do + putStrLn $ "Error: store_messages is `journal` with " <> storeMsgsFilePath <> " file present." + putStrLn "Set store_messages to `memory` or use `smp-server journal export` to migrate." + exitFailure + | not msgsDirExists -> + putStrLn $ "store_messages is `journal`, " <> storeMsgsJournalDir <> " directory will be created." + AMSType SMSMemory + | msgsDirExists -> do + putStrLn $ "Error: store_messages is `memory` with " <> storeMsgsJournalDir <> " directory present." + putStrLn "Set store_messages to `journal` or use `smp-server journal import` to migrate." + exitFailure + _ -> pure () + + exitConfigureMsgStorage = do + putStrLn $ "Error: both " <> storeMsgsFilePath <> " file and " <> storeMsgsJournalDir <> " directory are present." + putStrLn "Configure memory storage." + exitFailure + data EmbeddedWebParams = EmbeddedWebParams { webStaticPath :: FilePath, webHttpPort :: Maybe Int, @@ -458,12 +544,13 @@ informationIniContent InitOptions {sourceCode, serverInfo} = \# Hosting type can be `virtual`, `dedicated`, `colocation`, `owned`\n" <> ("hosting_type: " <> maybe "virtual" (decodeLatin1 . strEncode) hostingType <> "\n\n") where - ServerPublicInfo {operator, website, hosting, hostingType, serverCountry}= serverInfo + ServerPublicInfo {operator, website, hosting, hostingType, serverCountry} = serverInfo countryStr optName country = optDisabled country <> optName <> "_country: " <> fromMaybe "ISO-3166 2-letter code" country <> "\n" enitiyStrs optName entity = optDisabled entity - <> optName <> ": " - <> maybe ("entity (organization or person name)") name entity + <> optName + <> ": " + <> maybe "entity (organization or person name)" name entity <> "\n" <> countryStr optName (country =<< entity) @@ -519,6 +606,9 @@ data CliCommand | OnlineCert CertOptions | Start | Delete + | Journal JournalCmd + +data JournalCmd = JCImport | JCExport data InitOptions = InitOptions { enableStoreLog :: Bool, @@ -550,6 +640,7 @@ cliCommandP cfgPath logPath iniFile = <> command "cert" (info (OnlineCert <$> certOptionsP) (progDesc $ "Generate new online TLS server credentials (configuration: " <> iniFile <> ")")) <> command "start" (info (pure Start) (progDesc $ "Start server (configuration: " <> iniFile <> ")")) <> command "delete" (info (pure Delete) (progDesc "Delete configuration and log files")) + <> command "journal" (info (Journal <$> journalCmdP) (progDesc "Import/export messages to/from journal storage")) ) where initP :: Parser InitOptions @@ -607,22 +698,21 @@ cliCommandP cfgPath logPath iniFile = <|> option strParse (long "control-port" <> help "Enable control port" <> metavar "PORT" <> value Nothing) socksProxy <- flag' (Just defaultSocksProxy) (long "socks-proxy" <> help "Outgoing SOCKS proxy on port 9050") - <|> - option - strParse - ( long "socks-proxy" - <> metavar "PROXY" - <> help "Outgoing SOCKS proxy to forward messages to onion-only servers" - <> value Nothing - ) + <|> option + strParse + ( long "socks-proxy" + <> metavar "PROXY" + <> help "Outgoing SOCKS proxy to forward messages to onion-only servers" + <> value Nothing + ) ownDomains :: Maybe (L.NonEmpty TransportHost) <- option strParse - ( long "own-domains" - <> metavar "DOMAINS" - <> help "Own server domain names (comma-separated)" - <> value Nothing - ) + ( long "own-domains" + <> metavar "DOMAINS" + <> help "Own server domain names (comma-separated)" + <> value Nothing + ) sourceCode <- flag' (Just simplexmqSource) (long "source-code" <> help ("Server source code (default: " <> simplexmqSource <> ")")) <|> (optional . strOption) (long "source-code" <> metavar "URI" <> help "Server source code") @@ -690,6 +780,12 @@ cliCommandP cfgPath logPath iniFile = disableWeb, 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")) + ) + parseBasicAuth :: ReadM ServerPassword parseBasicAuth = eitherReader $ fmap ServerPassword . strDecode . B.pack entityP :: String -> String -> String -> Parser (Maybe Entity, Maybe Text) diff --git a/src/Simplex/Messaging/Server/MsgStore/Journal.hs b/src/Simplex/Messaging/Server/MsgStore/Journal.hs new file mode 100644 index 000000000..29a022668 --- /dev/null +++ b/src/Simplex/Messaging/Server/MsgStore/Journal.hs @@ -0,0 +1,556 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} + +module Simplex.Messaging.Server.MsgStore.Journal + ( JournalMsgStore (msgQueues, random), + JournalMsgQueue, + JournalStoreConfig (..), + getQueueMessages, + -- below are exported for tests + MsgQueueState (..), + JournalState (..), + msgQueueDirectory, + readWriteQueueState, + newMsgQueueState, + newJournalId, + logQueueState, + queueLogFileName, + logFileExt, + ) +where + +import Control.Concurrent.STM +import qualified Control.Exception as E +import Control.Logger.Simple +import Control.Monad +import Control.Monad.Trans.Except +import qualified Data.Attoparsec.ByteString.Char8 as A +import Data.ByteString.Char8 (ByteString) +import qualified Data.ByteString.Char8 as B +import qualified Data.ByteString.Lazy.Char8 as LB +import Data.Functor (($>)) +import Data.Maybe (catMaybes, fromMaybe) +import qualified Data.Text as T +import Data.Time.Clock (getCurrentTime) +import Data.Time.Format.ISO8601 (iso8601Show) +import GHC.IO (catchAny) +import Simplex.Messaging.Agent.Client (getMapLock, withLockMap) +import Simplex.Messaging.Agent.Lock +import Simplex.Messaging.Encoding.String +import Simplex.Messaging.Protocol (ErrorType (..), Message (..), RecipientId) +import Simplex.Messaging.Server.MsgStore.Types +import Simplex.Messaging.TMap (TMap) +import qualified Simplex.Messaging.TMap as TM +import Simplex.Messaging.Util (ifM, tshow, ($>>=)) +import System.Directory +import System.FilePath (()) +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, + random :: TVar StdGen, + queueLocks :: TMap RecipientId Lock, + msgQueues :: TMap RecipientId JournalMsgQueue + } + +data JournalStoreConfig = JournalStoreConfig + { storePath :: FilePath, + pathParts :: Int, + quota :: Int, + -- Max number of messages per journal file - ignored in STM store. + -- When this limit is reached, the file will be changed. + -- This number should be set bigger than queue quota. + maxMsgCount :: Int, + maxStateLines :: Int + } + +data JournalMsgQueue = JournalMsgQueue + { config :: JournalStoreConfig, + queueDirectory :: FilePath, + queueLock :: Lock, + state :: TVar MsgQueueState, + -- Last message and length incl. newline + -- Nothing - unknown, Just Nothing - empty queue. + -- This optimization prevents reading each message at least twice, + -- or reading it after it was just written. + tipMsg :: TVar (Maybe (Maybe (Message, Int))), + handles :: TVar (Maybe MsgQueueHandles), + random :: TVar StdGen + } + +data MsgQueueState = MsgQueueState + { writeState :: JournalState, + readState :: JournalState, + canWrite :: Bool, + size :: Int + } + deriving (Show) + +data MsgQueueHandles = MsgQueueHandles + { stateHandle :: Handle, -- handle to queue state log file, rotates and removes old backups when server is restarted + readHandle :: Handle, + writeHandle :: Maybe Handle -- optional, used when write file is different from read file + } + +data JournalState = JournalState + { journalId :: ByteString, + msgPos :: Int, + msgCount :: Int, + bytePos :: Int + } + deriving (Show) + +newMsgQueueState :: ByteString -> MsgQueueState +newMsgQueueState journalId = + let st = newJournalState journalId + in MsgQueueState {writeState = st, readState = st, canWrite = True, size = 0} + +newJournalState :: ByteString -> JournalState +newJournalState journalId = JournalState {journalId, msgPos = 0, msgCount = 0, bytePos = 0} + +journalFilePath :: FilePath -> ByteString -> FilePath +journalFilePath dir journalId = dir (msgLogFileName <> "." <> B.unpack journalId <> logFileExt) + +instance StrEncoding MsgQueueState where + strEncode MsgQueueState {writeState, readState, canWrite, size} = + B.unwords + [ "write=" <> strEncode writeState, + "read=" <> strEncode readState, + "canWrite=" <> strEncode canWrite, + "size=" <> strEncode size + ] + strP = do + writeState <- "write=" *> strP + readState <- " read=" *> strP + canWrite <- " canWrite=" *> strP + size <- " size=" *> strP + pure MsgQueueState {writeState, readState, canWrite, size} + +instance StrEncoding JournalState where + strEncode JournalState {journalId, msgPos, msgCount, bytePos} = + B.intercalate "," [journalId, strEncode msgPos, strEncode msgCount, strEncode bytePos] + strP = do + journalId <- A.takeTill (== ',') + msgPos <- A.char ',' *> strP + msgCount <- A.char ',' *> strP + bytePos <- A.char ',' *> strP + pure JournalState {journalId, msgPos, msgCount, bytePos} + +queueLogFileName :: String +queueLogFileName = "queue_state" + +msgLogFileName :: String +msgLogFileName = "messages" + +logFileExt :: String +logFileExt = ".log" + +newtype NonAtomicIO a = NonAtomicIO (IO a) + deriving newtype (Functor, Applicative, Monad) + +instance MsgStoreClass JournalMsgStore where + type StoreMonad JournalMsgStore = NonAtomicIO + type MsgQueue JournalMsgStore = JournalMsgQueue + type MsgStoreConfig JournalMsgStore = JournalStoreConfig + + newMsgStore :: JournalStoreConfig -> IO JournalMsgStore + newMsgStore config = do + random <- newTVarIO =<< newStdGen + queueLocks <- TM.emptyIO + msgQueues <- TM.emptyIO + pure JournalMsgStore {config, random, queueLocks, msgQueues} + + closeMsgStore st = readTVarIO (msgQueues st) >>= mapM_ closeMsgQueue_ + + activeMsgQueues = msgQueues + {-# INLINE activeMsgQueues #-} + + -- This function opens and closes all queues. + -- It is used to export storage to a single file, not during normal server execution. + withAllMsgQueues :: JournalMsgStore -> (RecipientId -> JournalMsgQueue -> IO Int) -> IO Int + withAllMsgQueues st@JournalMsgStore {config} action = do + closeMsgStore st + lock <- createLockIO -- the same lock is used for all queues + dirs <- zip [0..] <$> listQueueDirs 0 ("", storePath) + let count = length dirs + total <- foldM (processQueue lock count) 0 dirs + progress count count + putStrLn "" + pure total + where + JournalStoreConfig {storePath, pathParts} = config + processQueue lock count !total (i :: Int, (queueId, dir)) = do + when (i `mod` 100 == 0) $ progress i count + q <- openMsgQueue st dir lock + total' <- case strDecode $ B.pack queueId of + Right rId -> (total +) <$> action rId q + Left e -> total <$ putStrLn ("Error: message queue directory " <> dir <> " is invalid: " <> e) + closeMsgQueue_ q + pure total' + progress i count = do + putStr $ "Processed: " <> show i <> "/" <> show count <> " queues\r" + IO.hFlush stdout + listQueueDirs depth (queueId, path) + | depth == pathParts - 1 = listDirs + | otherwise = fmap concat . mapM (listQueueDirs (depth + 1)) =<< listDirs + where + listDirs = fmap catMaybes . mapM queuePath =<< listDirectory path + queuePath dir = do + let path' = path dir + ifM + (doesDirectoryExist path') + (pure $ Just (queueId <> dir, path')) + (Nothing <$ putStrLn ("Error: path " <> path' <> " is not a directory, skipping")) + + logQueueStates :: JournalMsgStore -> IO () + logQueueStates st = + void $ withActiveMsgQueues st $ \_ q -> + readTVarIO (handles q) + >>= maybe (pure ()) (\hs -> readTVarIO (state q) >>= logQueueState (stateHandle hs)) + >> pure 0 + + getMsgQueue :: JournalMsgStore -> RecipientId -> ExceptT ErrorType IO JournalMsgQueue + getMsgQueue store@JournalMsgStore {queueLocks, msgQueues, random} rId = + tryStore "getMsgQueue" $ withLockMap queueLocks rId "getMsgQueue" $ + TM.lookupIO rId msgQueues >>= maybe newQ pure + where + newQ = do + let dir = msgQueueDirectory store rId + queueLock <- atomically $ getMapLock queueLocks rId + q <- ifM (doesDirectoryExist dir) (openMsgQueue store dir queueLock) (createQ dir queueLock) + atomically $ TM.insert rId q msgQueues + pure q + where + createQ :: FilePath -> Lock -> IO JournalMsgQueue + createQ dir queueLock = do + -- folder and files are not created here, + -- to avoid file IO for queues without messages during subscription + journalId <- newJournalId random + mkJournalQueue store dir queueLock (newMsgQueueState journalId, Nothing) + + delMsgQueue :: JournalMsgStore -> RecipientId -> IO () + delMsgQueue st rId = withLockMap (queueLocks st) rId "delMsgQueue" $ do + void $ closeMsgQueue st rId + removeQueueDirectory st rId + + delMsgQueueSize :: JournalMsgStore -> RecipientId -> IO Int + delMsgQueueSize st rId = withLockMap (queueLocks st) rId "delMsgQueue" $ do + state_ <- closeMsgQueue st rId + sz <- maybe (pure $ -1) (fmap size . readTVarIO) state_ + removeQueueDirectory st rId + pure sz + + getQueueMessages :: Bool -> JournalMsgQueue -> IO [Message] + getQueueMessages drainMsgs q = readTVarIO (handles q) >>= maybe (pure []) (getMsg []) + where + getMsg ms hs = chooseReadJournal q drainMsgs hs >>= maybe (pure ms) readMsg + where + readMsg (rs, h) = do + -- TODO handle errors + s <- hGetLineAt h $ bytePos rs + -- TODO handle errors + Right msg <- pure $ strDecode s + updateReadPos q drainMsgs (B.length s + 1) hs -- 1 is to account for new line + (msg :) <$> getMsg ms hs + + writeMsg :: JournalMsgQueue -> Bool -> Message -> ExceptT ErrorType IO (Maybe (Message, Bool)) + writeMsg q@JournalMsgQueue {queueDirectory, handles, config, random} logState !msg = + tryStore "writeMsg" $ withLock' (queueLock q) "writeMsg" $ do + st@MsgQueueState {canWrite, size} <- readTVarIO (state q) + let empty = size == 0 + if canWrite || empty + then do + let canWrt' = quota > size + if canWrt' + then writeToJournal st canWrt' msg $> Just (msg, empty) + else writeToJournal st canWrt' msgQuota $> Nothing + else pure Nothing + where + JournalStoreConfig {quota, maxMsgCount} = config + msgQuota = MessageQuota {msgId = msgId msg, msgTs = msgTs msg} + writeToJournal st@MsgQueueState {writeState, readState = rs, size} canWrt' msg' = do + let msgStr = strEncode msg' `B.snoc` '\n' + msgLen = B.length msgStr + hs <- maybe createQueueDir pure =<< readTVarIO handles + (ws, wh) <- case writeHandle hs of + Nothing | msgCount writeState >= maxMsgCount -> switchWriteJournal hs + wh_ -> pure (writeState, fromMaybe (readHandle hs) wh_) + let msgCount' = msgCount ws + 1 + ws' = ws {msgPos = msgPos ws + 1, msgCount = msgCount', bytePos = bytePos ws + msgLen} + rs' = if journalId ws == journalId rs then rs {msgCount = msgCount'} else rs + !st' = st {writeState = ws', readState = rs', canWrite = canWrt', size = size + 1} + when (size == 0) $ atomically $ writeTVar (tipMsg q) $ Just (Just (msg, msgLen)) + hAppend wh msgStr + updateQueueState q logState hs st' + where + createQueueDir = do + createDirectoryIfMissing True queueDirectory + let statePath = queueDirectory (queueLogFileName <> logFileExt) + sh <- openFile statePath AppendMode + B.hPutStr sh "" + rh <- createNewJournal queueDirectory $ journalId rs + let hs = MsgQueueHandles {stateHandle = sh, readHandle = rh, writeHandle = Nothing} + atomically $ writeTVar handles $ Just hs + pure hs + switchWriteJournal hs = do + journalId <- newJournalId random + wh <- createNewJournal queueDirectory journalId + atomically $ writeTVar handles $ Just $ hs {writeHandle = Just wh} + pure (newJournalState journalId, wh) + + getQueueSize :: JournalMsgQueue -> IO Int + getQueueSize JournalMsgQueue {state} = size <$> readTVarIO state + + tryPeekMsg_ :: JournalMsgQueue -> NonAtomicIO (Maybe Message) + tryPeekMsg_ q@JournalMsgQueue {tipMsg, handles} = + NonAtomicIO $ readTVarIO handles $>>= chooseReadJournal q True $>>= peekMsg + where + peekMsg (rs, h) = readTVarIO tipMsg >>= maybe readMsg (pure . fmap fst) + where + readMsg = do + -- TODO handle errors + s <- hGetLineAt h $ bytePos rs + -- TODO handle errors + Right msg <- pure $ strDecode s + atomically $ writeTVar tipMsg $ Just (Just (msg, B.length s + 1)) -- 1 is to account for new line + pure $ Just msg + + tryDeleteMsg_ :: JournalMsgQueue -> NonAtomicIO () + tryDeleteMsg_ q@JournalMsgQueue {tipMsg, handles} = NonAtomicIO $ + void $ + readTVarIO tipMsg -- if there is no cached tipMsg, do nothing + $>>= (pure . fmap snd) + $>>= \len -> readTVarIO handles + $>>= \hs -> updateReadPos q True len hs $> Just () + + atomicQueue :: JournalMsgQueue -> String -> NonAtomicIO a -> ExceptT ErrorType IO a + atomicQueue mq op (NonAtomicIO a) = tryStore op $ withLock' (queueLock mq) op $ a + +tryStore :: String -> IO a -> ExceptT ErrorType IO a +tryStore op a = + ExceptT $ + (Right <$> a) `catchAny` \e -> + let e' = op <> " " <> show e + in logError ("STORE ERROR " <> T.pack e') $> Left (STORE e') + +openMsgQueue :: JournalMsgStore -> FilePath -> Lock -> IO JournalMsgQueue +openMsgQueue store dir queueLock = do + let statePath = dir (queueLogFileName <> logFileExt) + (st, sh) <- readWriteQueueState store statePath + (st', rh, wh_) <- openJournals dir st + let hs = MsgQueueHandles {stateHandle = sh, readHandle = rh, writeHandle = wh_} + mkJournalQueue store dir queueLock (st', Just hs) + +mkJournalQueue :: JournalMsgStore -> FilePath -> Lock -> (MsgQueueState, Maybe MsgQueueHandles) -> IO JournalMsgQueue +mkJournalQueue JournalMsgStore {random, config} dir queueLock (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 + { config, + queueDirectory = dir, + queueLock, + state, + tipMsg, + handles, + random + } + +chooseReadJournal :: JournalMsgQueue -> Bool -> MsgQueueHandles -> IO (Maybe (JournalState, Handle)) +chooseReadJournal 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 + removeJournal (queueDirectory q) rs + let !rs' = (newJournalState $ journalId ws) {msgCount = msgCount ws} + !st' = st {readState = rs'} + updateQueueState q log' hs st' + pure $ Just (rs', wh) + _ | msgPos rs >= msgCount rs && journalId rs == journalId ws -> pure Nothing + _ -> pure $ Just (rs, readHandle hs) + +updateQueueState :: JournalMsgQueue -> Bool -> MsgQueueHandles -> MsgQueueState -> IO () +updateQueueState q log' hs st = do + atomically $ writeTVar (state q) st + when log' $ logQueueState (stateHandle hs) st + +logQueueState :: Handle -> MsgQueueState -> IO () +logQueueState h st = B.hPutStr h $ strEncode st `B.snoc` '\n' + +updateReadPos :: JournalMsgQueue -> Bool -> Int -> MsgQueueHandles -> IO () +updateReadPos q log' len hs = do + st@MsgQueueState {readState = rs, size} <- readTVarIO (state q) + let JournalState {msgPos, bytePos} = rs + let msgPos' = msgPos + 1 + rs' = rs {msgPos = msgPos', bytePos = bytePos + len} + st' = st {readState = rs', size = size - 1} + updateQueueState q log' hs st' + atomically $ writeTVar (tipMsg q) Nothing + +msgQueueDirectory :: JournalMsgStore -> RecipientId -> FilePath +msgQueueDirectory JournalMsgStore {config = JournalStoreConfig {storePath, pathParts}} rId = + storePath B.unpack (B.intercalate "/" $ splitSegments pathParts $ strEncode rId) + where + splitSegments _ "" = [] + splitSegments 1 s = [s] + splitSegments n s = + let (seg, s') = B.splitAt 2 s + in seg : splitSegments (n - 1) s' + +createNewJournal :: FilePath -> ByteString -> IO Handle +createNewJournal dir journalId = do + let path = journalFilePath dir journalId -- TODO retry if file exists + h <- openFile path ReadWriteMode + B.hPutStr h "" + pure h + +newJournalId :: TVar StdGen -> IO ByteString +newJournalId g = strEncode <$> atomically (stateTVar g $ genByteString 12) + +openJournals :: FilePath -> MsgQueueState -> IO (MsgQueueState, Handle, Maybe Handle) +openJournals dir st@MsgQueueState {readState = rs, writeState = ws} = do + -- TODO verify that file exists, what to do if it's not, or if its state diverges + -- TODO check current position matches state, fix if not + let rjId = journalId rs + wjId = journalId ws + openJournal rs >>= \case + Left path -> do + logError $ "STORE ERROR no read file " <> T.pack path <> ", creating new file" + rh <- createNewJournal dir rjId + let st' = newMsgQueueState rjId + pure (st', rh, Nothing) + Right rh + | rjId == wjId -> do + st' <- fixWriteFileSize rh + pure (st', rh, Nothing) + | otherwise -> + openJournal ws >>= \case + Left path -> do + logError $ "STORE ERROR no write file " <> T.pack path <> ", creating new file" + wh <- createNewJournal dir wjId + let size' = msgCount rs + msgPos rs + st' = st {writeState = newJournalState wjId, size = size'} -- we don't amend canWrite to trigger QCONT + pure (st', rh, Just wh) + Right wh -> do + st' <- fixWriteFileSize wh + pure (st', rh, Just wh) + where + openJournal JournalState {journalId} = + let path = journalFilePath dir journalId + in ifM (doesFileExist path) (Right <$> openFile path ReadWriteMode) (pure $ Left path) + fixWriteFileSize h = do + let sz = fromIntegral $ bytePos ws + sz' <- IO.hFileSize h + if + | sz' > sz -> logWarn "STORE WARNING" >> IO.hSetFileSize h sz $> st + | sz' == sz -> pure st + | otherwise -> pure st -- TODO re-read file to recover what is possible ??? + +removeJournal :: FilePath -> JournalState -> IO () +removeJournal dir JournalState {journalId} = do + let path = journalFilePath dir journalId + removeFile path `catchAny` (\e -> logError $ "STORE ERROR removing file " <> T.pack path <> ": " <> tshow e) + +-- 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 {random, config} statePath = + ifM + (doesFileExist tempBackup) + (renameFile tempBackup statePath >> readQueueState) + (ifM (doesFileExist statePath) readQueueState writeNewQueueState) + where + tempBackup = statePath <> ".bak" + readQueueState = do + ls <- LB.lines <$> LB.readFile statePath + case ls of + [] -> writeNewQueueState + _ -> useLastLine (length ls) True ls + writeNewQueueState = do + logWarn $ "STORE WARNING: empty queue state in " <> T.pack statePath <> ", initialized" + st <- newMsgQueueState <$> newJournalId random + writeQueueState st + useLastLine len isLastLine ls = case strDecode $ LB.toStrict $ last ls of + Right st + | len > maxStateLines config || not isLastLine -> + backupWriteQueueState st + | otherwise -> do + -- when state file has fewer than maxStateLines, we don't compact it + sh <- openFile statePath AppendMode + pure (st, sh) + Left e -- if the last line failed to parse + | isLastLine -> case init ls of -- or use the previous line + [] -> do + logWarn $ "STORE WARNING: invalid 1-line queue state " <> T.pack statePath <> ", initialized" + st <- newMsgQueueState <$> newJournalId random + backupWriteQueueState st + ls' -> do + logWarn $ "STORE WARNING: invalid last line in queue state " <> T.pack statePath <> ", using the previous line" + useLastLine len False ls' + | otherwise -> do + logError $ "STORE ERROR invalid queue state in " <> T.pack statePath <> ": " <> tshow e + E.throwIO $ userError $ "Error reading queue state " <> statePath <> ": " <> show e + backupWriteQueueState st = do + -- State backup is made in two steps to mitigate the crash during the backup. + -- 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 + pure r + writeQueueState st = do + sh <- openFile statePath AppendMode + logQueueState sh st + pure (st, sh) + +closeMsgQueue :: JournalMsgStore -> RecipientId -> IO (Maybe (TVar MsgQueueState)) +closeMsgQueue st rId = + atomically (TM.lookupDelete rId (msgQueues st)) + >>= mapM (\q -> closeMsgQueue_ q $> state q) + +closeMsgQueue_ :: JournalMsgQueue -> IO () +closeMsgQueue_ q = readTVarIO (handles q) >>= mapM_ closeHandles + where + closeHandles (MsgQueueHandles sh rh wh_) = do + hClose sh + hClose rh + mapM_ hClose wh_ + +removeQueueDirectory :: JournalMsgStore -> RecipientId -> IO () +removeQueueDirectory st rId = + let dir = msgQueueDirectory st rId + in removePathForcibly dir `catchAny` (\e -> logError $ "STORE ERROR removeQueueDirectory " <> T.pack dir <> ": " <> tshow e) + +hAppend :: Handle -> ByteString -> IO () +hAppend h s = IO.hSeek h SeekFromEnd 0 >> B.hPutStr h s + +hGetLineAt :: Handle -> Int -> IO ByteString +hGetLineAt h pos = IO.hSeek h AbsoluteSeek (fromIntegral pos) >> B.hGetLine h + +openFile :: FilePath -> IOMode -> IO Handle +openFile f mode = do + h <- IO.openFile f mode + IO.hSetBuffering h LineBuffering + pure h + +hClose :: Handle -> IO () +hClose h = IO.hClose h `catchAny` (\e -> logError $ "Error closing file" <> tshow e) diff --git a/src/Simplex/Messaging/Server/MsgStore/STM.hs b/src/Simplex/Messaging/Server/MsgStore/STM.hs index de994c17a..df4507175 100644 --- a/src/Simplex/Messaging/Server/MsgStore/STM.hs +++ b/src/Simplex/Messaging/Server/MsgStore/STM.hs @@ -1,129 +1,126 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE InstanceSigs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeFamilies #-} module Simplex.Messaging.Server.MsgStore.STM - ( STMMsgStore, - MsgQueue (msgQueue), - newMsgStore, - getMsgQueue, - delMsgQueue, - delMsgQueueSize, - writeMsg, - tryPeekMsg, - tryPeekMsgIO, - tryDelMsg, - tryDelPeekMsg, - deleteExpiredMsgs, - getQueueSize, + ( STMMsgStore (..), + STMMsgQueue (msgQueue), + STMStoreConfig (..), ) where -import qualified Data.ByteString.Char8 as B +import Control.Concurrent.STM +import Control.Monad.IO.Class +import Control.Monad.Trans.Except import Data.Functor (($>)) -import Data.Int (Int64) -import Data.Time.Clock.System (SystemTime (systemSeconds)) -import Simplex.Messaging.Protocol (Message (..), MsgId, RecipientId) +import Simplex.Messaging.Protocol (ErrorType, Message (..), RecipientId) +import Simplex.Messaging.Server.MsgStore.Types import Simplex.Messaging.TMap (TMap) import qualified Simplex.Messaging.TMap as TM -import UnliftIO.STM -data MsgQueue = MsgQueue +data STMMsgQueue = STMMsgQueue { msgQueue :: TQueue Message, quota :: Int, canWrite :: TVar Bool, size :: TVar Int } -type STMMsgStore = TMap RecipientId MsgQueue +data STMMsgStore = STMMsgStore + { storeConfig :: STMStoreConfig, + msgQueues :: TMap RecipientId STMMsgQueue + } -newMsgStore :: IO STMMsgStore -newMsgStore = TM.emptyIO +data STMStoreConfig = STMStoreConfig + { storePath :: Maybe FilePath, + quota :: Int + } --- The reason for double lookup is that majority of messaging queues exist, --- because multiple messages are sent to the same queue, --- so the first lookup without STM transaction will return the queue faster. --- In case the queue does not exist, it needs to be looked-up again inside transaction. -getMsgQueue :: STMMsgStore -> RecipientId -> Int -> IO MsgQueue -getMsgQueue st rId quota = TM.lookupIO rId st >>= maybe (atomically maybeNewQ) pure - where - maybeNewQ = TM.lookup rId st >>= maybe newQ pure - newQ = do - msgQueue <- newTQueue - canWrite <- newTVar True - size <- newTVar 0 - let q = MsgQueue {msgQueue, quota, canWrite, size} - TM.insert rId q st - pure q +instance MsgStoreClass STMMsgStore where + type StoreMonad STMMsgStore = STM + type MsgQueue STMMsgStore = STMMsgQueue + type MsgStoreConfig STMMsgStore = STMStoreConfig -delMsgQueue :: STMMsgStore -> RecipientId -> IO () -delMsgQueue st rId = atomically $ TM.delete rId st + newMsgStore :: STMStoreConfig -> IO STMMsgStore + newMsgStore storeConfig = do + msgQueues <- TM.emptyIO + pure STMMsgStore {storeConfig, msgQueues} -delMsgQueueSize :: STMMsgStore -> RecipientId -> IO Int -delMsgQueueSize st rId = atomically (TM.lookupDelete rId st) >>= maybe (pure 0) (\MsgQueue {size} -> readTVarIO size) + closeMsgStore _ = pure () -writeMsg :: MsgQueue -> Message -> IO (Maybe (Message, Bool)) -writeMsg MsgQueue {msgQueue = q, quota, canWrite, size} !msg = atomically $ do - canWrt <- readTVar canWrite - empty <- isEmptyTQueue q - if canWrt || empty - then do - canWrt' <- (quota >) <$> readTVar size - writeTVar canWrite $! canWrt' - modifyTVar' size (+ 1) - if canWrt' - then writeTQueue q msg $> Just (msg, empty) - else (writeTQueue q $! msgQuota) $> Nothing - else pure Nothing - where - msgQuota = MessageQuota {msgId = msgId msg, msgTs = msgTs msg} + activeMsgQueues = msgQueues + {-# INLINE activeMsgQueues #-} -tryPeekMsgIO :: MsgQueue -> IO (Maybe Message) -tryPeekMsgIO = atomically . tryPeekTQueue . msgQueue -{-# INLINE tryPeekMsgIO #-} + withAllMsgQueues = withActiveMsgQueues + {-# INLINE withAllMsgQueues #-} --- TODO remove once deliverToSub is split -tryPeekMsg :: MsgQueue -> STM (Maybe Message) -tryPeekMsg = tryPeekTQueue . msgQueue -{-# INLINE tryPeekMsg #-} + logQueueStates _ = pure () -tryDelMsg :: MsgQueue -> MsgId -> IO (Maybe Message) -tryDelMsg mq msgId' = atomically $ - tryPeekMsg mq >>= \case - msg_@(Just msg) - | msgId msg == msgId' || B.null msgId' -> tryDeleteMsg_ mq >> pure msg_ - | otherwise -> pure Nothing - _ -> pure Nothing + -- The reason for double lookup is that majority of messaging queues exist, + -- because multiple messages are sent to the same queue, + -- so the first lookup without STM transaction will return the queue faster. + -- In case the queue does not exist, it needs to be looked-up again inside transaction. + getMsgQueue :: STMMsgStore -> RecipientId -> ExceptT ErrorType IO STMMsgQueue + getMsgQueue STMMsgStore {msgQueues = qs, storeConfig = STMStoreConfig {quota}} rId = + liftIO $ TM.lookupIO rId qs >>= maybe (atomically maybeNewQ) pure + where + maybeNewQ = TM.lookup rId qs >>= maybe newQ pure + newQ = do + msgQueue <- newTQueue + canWrite <- newTVar True + size <- newTVar 0 + let q = STMMsgQueue {msgQueue, quota, canWrite, size} + TM.insert rId q qs + pure q --- atomic delete (== read) last and peek next message if available -tryDelPeekMsg :: MsgQueue -> MsgId -> IO (Maybe Message, Maybe Message) -tryDelPeekMsg mq msgId' = atomically $ - tryPeekMsg mq >>= \case - msg_@(Just msg) - | msgId msg == msgId' || B.null msgId' -> (msg_,) <$> (tryDeleteMsg_ mq >> tryPeekMsg mq) - | otherwise -> pure (Nothing, msg_) - _ -> pure (Nothing, Nothing) + delMsgQueue :: STMMsgStore -> RecipientId -> IO () + delMsgQueue st rId = atomically $ TM.delete rId $ msgQueues st -deleteExpiredMsgs :: MsgQueue -> Int64 -> IO Int -deleteExpiredMsgs mq old = atomically $ loop 0 - where - loop dc = - tryPeekMsg mq >>= \case - Just Message {msgTs} - | systemSeconds msgTs < old -> - tryDeleteMsg_ mq >> loop (dc + 1) - _ -> pure dc + delMsgQueueSize :: STMMsgStore -> RecipientId -> IO Int + delMsgQueueSize st rId = atomically (TM.lookupDelete rId $ msgQueues st) >>= maybe (pure 0) (\STMMsgQueue {size} -> readTVarIO size) -tryDeleteMsg_ :: MsgQueue -> STM () -tryDeleteMsg_ MsgQueue {msgQueue = q, size} = - tryReadTQueue q >>= \case - Just _ -> modifyTVar' size (subtract 1) - _ -> pure () + getQueueMessages :: Bool -> STMMsgQueue -> IO [Message] + getQueueMessages drainMsgs = atomically . (if drainMsgs then flushTQueue else snapshotTQueue) . msgQueue + where + snapshotTQueue q = do + msgs <- flushTQueue q + mapM_ (writeTQueue q) msgs + pure msgs -getQueueSize :: MsgQueue -> IO Int -getQueueSize MsgQueue {size} = readTVarIO size + writeMsg :: STMMsgQueue -> Bool -> Message -> ExceptT ErrorType IO (Maybe (Message, Bool)) + writeMsg STMMsgQueue {msgQueue = q, quota, canWrite, size} _logState !msg = liftIO $ atomically $ do + canWrt <- readTVar canWrite + empty <- isEmptyTQueue q + if canWrt || empty + then do + canWrt' <- (quota >) <$> readTVar size + writeTVar canWrite $! canWrt' + modifyTVar' size (+ 1) + if canWrt' + then writeTQueue q msg $> Just (msg, empty) + else (writeTQueue q $! msgQuota) $> Nothing + else pure Nothing + where + msgQuota = MessageQuota {msgId = msgId msg, msgTs = msgTs msg} + + getQueueSize :: STMMsgQueue -> IO Int + getQueueSize STMMsgQueue {size} = readTVarIO size + + tryPeekMsg_ :: STMMsgQueue -> STM (Maybe Message) + tryPeekMsg_ = tryPeekTQueue . msgQueue + {-# INLINE tryPeekMsg_ #-} + + tryDeleteMsg_ :: STMMsgQueue -> STM () + tryDeleteMsg_ STMMsgQueue {msgQueue = q, size} = + tryReadTQueue q >>= \case + Just _ -> modifyTVar' size (subtract 1) + _ -> pure () + + atomicQueue :: STMMsgQueue -> String -> STM a -> ExceptT ErrorType IO a + atomicQueue _ _ = liftIO . atomically diff --git a/src/Simplex/Messaging/Server/MsgStore/Types.hs b/src/Simplex/Messaging/Server/MsgStore/Types.hs new file mode 100644 index 000000000..68693883d --- /dev/null +++ b/src/Simplex/Messaging/Server/MsgStore/Types.hs @@ -0,0 +1,81 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeFamilyDependencies #-} + +module Simplex.Messaging.Server.MsgStore.Types where + +import Control.Concurrent.STM +import Control.Monad.Trans.Except +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 (ErrorType, Message (..), MsgId, RecipientId) +import Simplex.Messaging.TMap (TMap) + +class Monad (StoreMonad s) => MsgStoreClass s where + type StoreMonad s = (m :: Type -> Type) | m -> s + type MsgStoreConfig s = c | c -> s + type MsgQueue s = q | q -> s + newMsgStore :: MsgStoreConfig s -> IO s + closeMsgStore :: s -> IO () + activeMsgQueues :: s -> TMap RecipientId (MsgQueue s) + withAllMsgQueues :: s -> (RecipientId -> MsgQueue s -> IO Int) -> IO Int + logQueueStates :: s -> IO () + getMsgQueue :: s -> RecipientId -> ExceptT ErrorType IO (MsgQueue s) + delMsgQueue :: s -> RecipientId -> IO () + delMsgQueueSize :: s -> RecipientId -> IO Int + getQueueMessages :: Bool -> MsgQueue s -> IO [Message] + writeMsg :: MsgQueue s -> Bool -> Message -> ExceptT ErrorType IO (Maybe (Message, Bool)) + getQueueSize :: MsgQueue s -> IO Int + tryPeekMsg_ :: MsgQueue s -> StoreMonad s (Maybe Message) + tryDeleteMsg_ :: MsgQueue s -> StoreMonad s () + atomicQueue :: MsgQueue s -> String -> StoreMonad s a -> ExceptT ErrorType IO a + +data MSType = MSMemory | MSJournal + +data SMSType :: MSType -> Type where + SMSMemory :: SMSType 'MSMemory + SMSJournal :: SMSType 'MSJournal + +data AMSType = forall s. AMSType (SMSType s) + +withActiveMsgQueues :: MsgStoreClass s => s -> (RecipientId -> MsgQueue s -> IO Int) -> IO Int +withActiveMsgQueues st f = readTVarIO (activeMsgQueues st) >>= M.foldrWithKey (\k v -> ((+) <$> f k v <*>)) (pure 0) + +tryPeekMsg :: MsgStoreClass s => MsgQueue s -> ExceptT ErrorType IO (Maybe Message) +tryPeekMsg mq = atomicQueue mq "tryPeekMsg" $ tryPeekMsg_ mq +{-# INLINE tryPeekMsg #-} + +tryDelMsg :: MsgStoreClass s => MsgQueue s -> MsgId -> ExceptT ErrorType IO (Maybe Message) +tryDelMsg mq msgId' = + atomicQueue mq "tryDelMsg" $ + tryPeekMsg_ mq >>= \case + msg_@(Just msg) + | msgId msg == msgId' -> + tryDeleteMsg_ mq >> pure msg_ + _ -> pure Nothing + +-- atomic delete (== read) last and peek next message if available +tryDelPeekMsg :: MsgStoreClass s => MsgQueue s -> MsgId -> ExceptT ErrorType IO (Maybe Message, Maybe Message) +tryDelPeekMsg mq msgId' = + atomicQueue mq "tryDelPeekMsg" $ + tryPeekMsg_ mq >>= \case + msg_@(Just msg) + | msgId msg == msgId' -> (msg_,) <$> (tryDeleteMsg_ mq >> tryPeekMsg_ mq) + | otherwise -> pure (Nothing, msg_) + _ -> pure (Nothing, Nothing) + +deleteExpiredMsgs :: MsgStoreClass s => MsgQueue s -> Int64 -> ExceptT ErrorType IO Int +deleteExpiredMsgs mq old = atomicQueue mq "deleteExpiredMsgs" $ loop 0 + where + loop dc = + tryPeekMsg_ mq >>= \case + Just Message {msgTs} + | systemSeconds msgTs < old -> + tryDeleteMsg_ mq >> loop (dc + 1) + _ -> pure dc diff --git a/src/Simplex/Messaging/Util.hs b/src/Simplex/Messaging/Util.hs index fde54ab01..ea0322b74 100644 --- a/src/Simplex/Messaging/Util.hs +++ b/src/Simplex/Messaging/Util.hs @@ -14,11 +14,13 @@ import Data.Bifunctor (first) import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Lazy.Char8 as LB -import Data.Int (Int64) import Data.IORef +import Data.Int (Int64) import Data.List (groupBy, sortOn) import Data.List.NonEmpty (NonEmpty) import qualified Data.List.NonEmpty as L +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as M import Data.Text (Text) import qualified Data.Text as T import Data.Text.Encoding (decodeUtf8With, encodeUtf8) @@ -185,3 +187,7 @@ encodeJSON = safeDecodeUtf8 . LB.toStrict . J.encode decodeJSON :: FromJSON a => Text -> Maybe a decodeJSON = J.decode . LB.fromStrict . encodeUtf8 + +traverseWithKey_ :: Monad m => (k -> v -> m ()) -> Map k v -> m () +traverseWithKey_ f = M.foldrWithKey (\k v -> (f k v >>)) (pure ()) +{-# INLINE traverseWithKey_ #-} diff --git a/tests/AgentTests/FunctionalAPITests.hs b/tests/AgentTests/FunctionalAPITests.hs index 86a6651f4..38a187ec5 100644 --- a/tests/AgentTests/FunctionalAPITests.hs +++ b/tests/AgentTests/FunctionalAPITests.hs @@ -77,7 +77,7 @@ import Data.Word (Word16) import qualified Database.SQLite.Simple as SQL import GHC.Stack (withFrozenCallStack) import SMPAgentClient -import SMPClient (cfg, prevRange, prevVersion, testPort, testPort2, testStoreLogFile2, withSmpServer, withSmpServerConfigOn, withSmpServerOn, withSmpServerProxy, withSmpServerStoreLogOn, withSmpServerStoreMsgLogOn) +import SMPClient (cfg, prevRange, prevVersion, testPort, testPort2, testStoreLogFile2, testStoreMsgsDir2, withSmpServer, withSmpServerConfigOn, withSmpServerProxy, withSmpServerStoreLogOn, withSmpServerStoreMsgLogOn) import Simplex.Messaging.Agent hiding (createConnection, joinConnection, sendMessage) import qualified Simplex.Messaging.Agent as A import Simplex.Messaging.Agent.Client (ProtocolTestFailure (..), ProtocolTestStep (..), ServerQueueInfo (..), UserNetworkInfo (..), UserNetworkType (..), waitForUserNetwork) @@ -96,6 +96,7 @@ import Simplex.Messaging.Protocol (BasicAuth, ErrorType (..), MsgBody, ProtocolS import qualified Simplex.Messaging.Protocol as SMP import Simplex.Messaging.Server.Env.STM (ServerConfig (..)) import Simplex.Messaging.Server.Expiration +import Simplex.Messaging.Server.MsgStore.Types (AMSType (..), SMSType (..)) import Simplex.Messaging.Server.QueueStore.QueueInfo import Simplex.Messaging.Transport (ATransport (..), SMPVersion, VersionSMP, authCmdsSMPVersion, basicAuthSMPVersion, batchCmdsSMPVersion, currentServerSMPRelayVersion, sndAuthKeySMPVersion, supportedSMPHandshakes) import Simplex.Messaging.Util (bshow, diffToMicroseconds) @@ -530,7 +531,7 @@ testRatchetMatrix2 t runTest = do testServerMatrix2 :: HasCallStack => ATransport -> (InitialAgentServers -> IO ()) -> Spec testServerMatrix2 t runTest = do it "1 server" $ withSmpServer t $ runTest initAgentServers - it "2 servers" $ withSmpServer t . withSmpServerOn t testPort2 $ runTest initAgentServers2 + it "2 servers" $ withSmpServer t $ withSmpServerConfigOn t cfg {storeLogFile = Just testStoreLogFile2, storeMsgsFile = Just testStoreMsgsDir2} testPort2 $ \_ -> runTest initAgentServers2 testPQMatrix2 :: HasCallStack => ATransport -> (HasCallStack => (AgentClient, InitialKeys) -> (AgentClient, PQSupport) -> AgentMsgId -> IO ()) -> Spec testPQMatrix2 = pqMatrix2_ True @@ -1282,7 +1283,7 @@ testSkippedMessages :: HasCallStack => ATransport -> IO () testSkippedMessages t = do alice <- getSMPAgentClient' 1 agentCfg initAgentServers testDB bob <- getSMPAgentClient' 2 agentCfg initAgentServers testDB2 - (aliceId, bobId) <- withSmpServerStoreLogOn t testPort $ \_ -> do + (aliceId, bobId) <- withSmpServerConfigOn t cfg' testPort $ \_ -> do (aliceId, bobId) <- runRight $ makeConnection alice bob runRight_ $ do 2 <- sendMessage alice bobId SMP.noMsgFlags "hello" @@ -1310,7 +1311,7 @@ testSkippedMessages t = do alice2 <- getSMPAgentClient' 3 agentCfg initAgentServers testDB bob2 <- getSMPAgentClient' 4 agentCfg initAgentServers testDB2 - withSmpServerStoreLogOn t testPort $ \_ -> do + withSmpServerConfigOn t cfg' testPort $ \_ -> do runRight_ $ do subscribeConnection bob2 aliceId subscribeConnection alice2 bobId @@ -1326,6 +1327,8 @@ testSkippedMessages t = do ackMessage bob2 aliceId 4 Nothing disposeAgentClient alice2 disposeAgentClient bob2 + where + cfg' = cfg {msgStoreType = AMSType SMSMemory, storeMsgsFile = Nothing} testDeliveryAfterSubscriptionError :: HasCallStack => ATransport -> IO () testDeliveryAfterSubscriptionError t = do @@ -1429,7 +1432,7 @@ withUP a bId p = ] testExpireMessageQuota :: HasCallStack => ATransport -> IO () -testExpireMessageQuota t = withSmpServerConfigOn t cfg {msgQueueQuota = 1} testPort $ \_ -> do +testExpireMessageQuota t = withSmpServerConfigOn t cfg {msgQueueQuota = 1, maxJournalMsgCount = 2} testPort $ \_ -> do a <- getSMPAgentClient' 1 agentCfg {quotaExceededTimeout = 1, messageRetryInterval = fastMessageRetryInterval} initAgentServers testDB b <- getSMPAgentClient' 2 agentCfg initAgentServers testDB2 (aId, bId) <- runRight $ do @@ -1455,7 +1458,7 @@ testExpireMessageQuota t = withSmpServerConfigOn t cfg {msgQueueQuota = 1} testP disposeAgentClient a testExpireManyMessagesQuota :: ATransport -> IO () -testExpireManyMessagesQuota t = withSmpServerConfigOn t cfg {msgQueueQuota = 1} testPort $ \_ -> do +testExpireManyMessagesQuota t = withSmpServerConfigOn t cfg {msgQueueQuota = 1, maxJournalMsgCount = 2} testPort $ \_ -> do a <- getSMPAgentClient' 1 agentCfg {quotaExceededTimeout = 2, messageRetryInterval = fastMessageRetryInterval} initAgentServers testDB b <- getSMPAgentClient' 2 agentCfg initAgentServers testDB2 (aId, bId) <- runRight $ do @@ -2356,7 +2359,7 @@ testJoinConnectionAsyncReplyErrorV8 t = do ConnectionStats {rcvQueuesInfo = [], sndQueuesInfo = [SndQueueInfo {}]} <- getConnectionServers b aId pure (aId, bId) nGet a =##> \case ("", "", DOWN _ [c]) -> c == bId; _ -> False - withSmpServerOn t testPort2 $ do + withSmpServerConfigOn t cfg {storeLogFile = Just testStoreLogFile2, storeMsgsFile = Just testStoreMsgsDir2} testPort2 $ \_ -> do get b =##> \case ("2", c, JOINED sqSecured) -> c == aId && not sqSecured; _ -> False confId <- withSmpServerStoreLogOn t testPort $ \_ -> do pGet a >>= \case @@ -2395,7 +2398,7 @@ testJoinConnectionAsyncReplyError t = do ConnectionStats {rcvQueuesInfo = [], sndQueuesInfo = [SndQueueInfo {}]} <- getConnectionServers b aId pure (aId, bId) nGet a =##> \case ("", "", DOWN _ [c]) -> c == bId; _ -> False - withSmpServerOn t testPort2 $ do + withSmpServerConfigOn t cfg {storeLogFile = Just testStoreLogFile2, storeMsgsFile = Just testStoreMsgsDir2} testPort2 $ \_ -> do confId <- withSmpServerStoreLogOn t testPort $ \_ -> do -- both servers need to be online for connection to progress because of SKEY get b =##> \case ("2", c, JOINED sqSecured) -> c == aId && sqSecured; _ -> False @@ -2974,7 +2977,7 @@ testDeliveryReceiptsVersion t = do testDeliveryReceiptsConcurrent :: HasCallStack => ATransport -> IO () testDeliveryReceiptsConcurrent t = - withSmpServerConfigOn t cfg {msgQueueQuota = 256} testPort $ \_ -> do + withSmpServerConfigOn t cfg {msgQueueQuota = 256, maxJournalMsgCount = 512} testPort $ \_ -> do withAgentClients2 $ \a b -> do (aId, bId) <- runRight $ makeConnection a b t1 <- liftIO getCurrentTime diff --git a/tests/CoreTests/MsgStoreTests.hs b/tests/CoreTests/MsgStoreTests.hs new file mode 100644 index 000000000..150312a60 --- /dev/null +++ b/tests/CoreTests/MsgStoreTests.hs @@ -0,0 +1,222 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +module CoreTests.MsgStoreTests where + +import AgentTests.FunctionalAPITests (runRight_) +import Control.Concurrent.STM +import Control.Exception (bracket) +import Control.Monad +import Control.Monad.IO.Class +import Data.ByteString.Char8 (ByteString) +import qualified Data.ByteString.Char8 as B +import Data.Time.Clock.System (getSystemTime) +import Simplex.Messaging.Crypto (pattern MaxLenBS) +import qualified Simplex.Messaging.Crypto as C +import Simplex.Messaging.Protocol (EntityId (..), Message (..), noMsgFlags) +import Simplex.Messaging.Server (exportMessages, importMessages) +import Simplex.Messaging.Server.MsgStore.Journal +import Simplex.Messaging.Server.MsgStore.STM +import Simplex.Messaging.Server.MsgStore.Types +import SMPClient (testStoreMsgsDir, testStoreMsgsDir2, testStoreMsgsFile, testStoreMsgsFile2) +import System.Directory (copyFile, createDirectoryIfMissing, listDirectory, removeFile, renameFile) +import System.FilePath (()) +import System.IO (IOMode (..), hClose, withFile) +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 + where + 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 :: MsgStoreClass s => MsgStoreConfig s -> (s -> IO ()) -> IO () +withMsgStore cfg = bracket (newMsgStore cfg) closeMsgStore + +testSMTStoreConfig :: STMStoreConfig +testSMTStoreConfig = STMStoreConfig {storePath = Nothing, quota = 3} + +testJournalStoreCfg :: JournalStoreConfig +testJournalStoreCfg = + JournalStoreConfig + { storePath = testStoreMsgsDir, + pathParts = 4, + quota = 3, + maxMsgCount = 4, + maxStateLines = 2 + } + +mkMessage :: MonadIO m => ByteString -> m Message +mkMessage body = liftIO $ do + g <- C.newRandom + msgTs <- getSystemTime + msgId <- atomically $ C.randomBytes 24 g + pure Message {msgId, msgTs, msgFlags = noMsgFlags, msgBody = C.unsafeMaxLenBS body} + +pattern Msg :: ByteString -> Maybe Message +pattern Msg s <- Just Message {msgBody = MaxLenBS s} + +deriving instance Eq MsgQueueState + +deriving instance Eq JournalState + +testGetQueue :: MsgStoreClass s => s -> IO () +testGetQueue st = do + g <- C.newRandom + rId <- EntityId <$> atomically (C.randomBytes 24 g) + runRight_ $ do + q <- getMsgQueue st rId + Just (Message {msgId = mId1}, True) <- writeMsg q True =<< mkMessage "message 1" + Just (Message {msgId = mId2}, False) <- writeMsg q True =<< mkMessage "message 2" + Just (Message {msgId = mId3}, False) <- writeMsg q True =<< mkMessage "message 3" + Msg "message 1" <- tryPeekMsg q + Msg "message 1" <- tryPeekMsg q + Nothing <- tryDelMsg q mId2 + Msg "message 1" <- tryDelMsg q mId1 + Nothing <- tryDelMsg q mId1 + Msg "message 2" <- tryPeekMsg q + Nothing <- tryDelMsg q mId1 + (Nothing, Msg "message 2") <- tryDelPeekMsg q mId1 + (Msg "message 2", Msg "message 3") <- tryDelPeekMsg q mId2 + (Nothing, Msg "message 3") <- tryDelPeekMsg q mId2 + Msg "message 3" <- tryPeekMsg q + (Msg "message 3", Nothing) <- tryDelPeekMsg q mId3 + Nothing <- tryDelMsg q mId2 + Nothing <- tryDelMsg q mId3 + Nothing <- tryPeekMsg q + Just (Message {msgId = mId4}, True) <- writeMsg q True =<< mkMessage "message 4" + Msg "message 4" <- tryPeekMsg q + Just (Message {msgId = mId5}, False) <- writeMsg q True =<< mkMessage "message 5" + (Nothing, Msg "message 4") <- tryDelPeekMsg q mId3 + (Msg "message 4", Msg "message 5") <- tryDelPeekMsg q mId4 + Just (Message {msgId = mId6}, False) <- writeMsg q True =<< mkMessage "message 6" + Just (Message {msgId = mId7}, False) <- writeMsg q True =<< mkMessage "message 7" + Nothing <- writeMsg q True =<< mkMessage "message 8" + Msg "message 5" <- tryPeekMsg q + (Nothing, Msg "message 5") <- tryDelPeekMsg q mId4 + (Msg "message 5", Msg "message 6") <- tryDelPeekMsg q mId5 + (Msg "message 6", Msg "message 7") <- tryDelPeekMsg q mId6 + (Msg "message 7", Just MessageQuota {msgId = mId8}) <- tryDelPeekMsg q mId7 + (Just MessageQuota {}, Nothing) <- tryDelPeekMsg q mId8 + (Nothing, Nothing) <- tryDelPeekMsg q mId8 + pure () + delMsgQueue st rId + +testChangeReadJournal :: MsgStoreClass s => s -> IO () +testChangeReadJournal st = do + g <- C.newRandom + rId <- EntityId <$> atomically (C.randomBytes 24 g) + runRight_ $ do + q <- getMsgQueue st rId + Just (Message {msgId = mId1}, True) <- writeMsg q True =<< mkMessage "message 1" + (Msg "message 1", Nothing) <- tryDelPeekMsg q mId1 + Just (Message {msgId = mId2}, True) <- writeMsg q True =<< mkMessage "message 2" + (Msg "message 2", Nothing) <- tryDelPeekMsg q mId2 + Just (Message {msgId = mId3}, True) <- writeMsg q True =<< mkMessage "message 3" + (Msg "message 3", Nothing) <- tryDelPeekMsg q mId3 + Just (Message {msgId = mId4}, True) <- writeMsg q True =<< mkMessage "message 4" + (Msg "message 4", Nothing) <- tryDelPeekMsg q mId4 + Just (Message {msgId = mId5}, True) <- writeMsg q True =<< mkMessage "message 5" + (Msg "message 5", Nothing) <- tryDelPeekMsg q mId5 + pure () + delMsgQueue st rId + +testExportImportStore :: JournalMsgStore -> IO () +testExportImportStore st = do + g <- C.newRandom + rId1 <- EntityId <$> atomically (C.randomBytes 24 g) + rId2 <- EntityId <$> atomically (C.randomBytes 24 g) + runRight_ $ do + q1 <- getMsgQueue st rId1 + Just (Message {}, True) <- writeMsg q1 True =<< mkMessage "message 1" + Just (Message {}, False) <- writeMsg q1 True =<< mkMessage "message 2" + q2 <- getMsgQueue st rId2 + Just (Message {}, True) <- writeMsg q2 True =<< mkMessage "message 3" + Just (Message {}, False) <- writeMsg q2 True =<< mkMessage "message 4" + Just (Message {}, False) <- writeMsg q2 True =<< mkMessage "message 5" + Nothing <- writeMsg q2 True =<< mkMessage "message 6" + pure () + length <$> listDirectory (msgQueueDirectory st rId1) `shouldReturn` 2 + length <$> listDirectory (msgQueueDirectory st rId2) `shouldReturn` 2 + exportMessages st testStoreMsgsFile $ getQueueMessages False + let cfg = (testJournalStoreCfg :: JournalStoreConfig) {storePath = testStoreMsgsDir2} + st' <- newMsgStore cfg + 0 <- importMessages st' testStoreMsgsFile Nothing + length <$> listDirectory (msgQueueDirectory st rId1) `shouldReturn` 2 + length <$> listDirectory (msgQueueDirectory st rId2) `shouldReturn` 3 -- state file is backed up + exportMessages st' testStoreMsgsFile2 $ getQueueMessages False + (B.readFile testStoreMsgsFile2 `shouldReturn`) =<< B.readFile (testStoreMsgsFile <> ".bak") + stmStore <- newMsgStore testSMTStoreConfig + 0 <- importMessages stmStore testStoreMsgsFile2 Nothing + exportMessages stmStore testStoreMsgsFile $ getQueueMessages False + (B.sort <$> B.readFile testStoreMsgsFile `shouldReturn`) =<< (B.sort <$> B.readFile (testStoreMsgsFile2 <> ".bak")) + +testQueueState :: JournalMsgStore -> IO () +testQueueState st = do + g <- C.newRandom + rId <- EntityId <$> atomically (C.randomBytes 24 g) + let dir = msgQueueDirectory st rId + statePath = dir (queueLogFileName <> logFileExt) + createDirectoryIfMissing True dir + state <- newMsgQueueState <$> newJournalId (random st) + withFile statePath WriteMode (`logQueueState` state) + length . lines <$> readFile statePath `shouldReturn` 1 + readQueueState statePath `shouldReturn` state + length <$> listDirectory dir `shouldReturn` 1 -- no backup + + let state1 = state {size = 1, writeState = (writeState state) {msgPos = 1, msgCount = 1, bytePos = 100}} + withFile statePath AppendMode (`logQueueState` state1) + length . lines <$> readFile statePath `shouldReturn` 2 + readQueueState statePath `shouldReturn` state1 + length <$> listDirectory dir `shouldReturn` 1 -- no backup + + let state2 = state {size = 2, writeState = (writeState state) {msgPos = 2, msgCount = 2, bytePos = 200}} + withFile statePath AppendMode (`logQueueState` state2) + length . lines <$> readFile statePath `shouldReturn` 3 + copyFile statePath (statePath <> ".2") + readQueueState statePath `shouldReturn` state2 + length <$> listDirectory dir `shouldReturn` 3 -- new state, copy + backup + length . lines <$> readFile statePath `shouldReturn` 1 + + -- corrupt the only line + corruptFile statePath + newState <- readQueueState statePath + newState `shouldBe` newMsgQueueState (journalId $ writeState newState) + + -- corrupt the last line + renameFile (statePath <> ".2") statePath + removeOtherFiles dir statePath + length . lines <$> readFile statePath `shouldReturn` 3 + corruptFile statePath + readQueueState statePath `shouldReturn` state1 + length <$> listDirectory dir `shouldReturn` 2 + length . lines <$> readFile statePath `shouldReturn` 1 + where + readQueueState statePath = do + (state, h) <- readWriteQueueState st statePath + hClose h + pure state + corruptFile f = do + s <- readFile f + removeFile f + writeFile f $ take (length s - 4) s + removeOtherFiles dir keep = do + names <- listDirectory dir + forM_ names $ \name -> + let f = dir name + in unless (f == keep) $ removeFile f diff --git a/tests/SMPClient.hs b/tests/SMPClient.hs index 273cc90ad..0055e8503 100644 --- a/tests/SMPClient.hs +++ b/tests/SMPClient.hs @@ -23,6 +23,7 @@ import Simplex.Messaging.Encoding import Simplex.Messaging.Protocol import Simplex.Messaging.Server (runSMPServerBlocking) import Simplex.Messaging.Server.Env.STM +import Simplex.Messaging.Server.MsgStore.Types (AMSType (..), SMSType (..)) import Simplex.Messaging.Transport import Simplex.Messaging.Transport.Client import qualified Simplex.Messaging.Transport.Client as Client @@ -62,6 +63,12 @@ testStoreMsgsFile = "tests/tmp/smp-server-messages.log" testStoreMsgsFile2 :: FilePath testStoreMsgsFile2 = "tests/tmp/smp-server-messages.log.2" +testStoreMsgsDir :: FilePath +testStoreMsgsDir = "tests/tmp/messages" + +testStoreMsgsDir2 :: FilePath +testStoreMsgsDir2 = "tests/tmp/messages.2" + testStoreNtfsFile :: FilePath testStoreNtfsFile = "tests/tmp/smp-server-ntfs.log" @@ -105,11 +112,14 @@ cfg = { transports = [], smpHandshakeTimeout = 60000000, tbqSize = 1, + msgStoreType = AMSType SMSJournal, msgQueueQuota = 4, + maxJournalMsgCount = 5, + maxJournalStateLines = 2, queueIdBytes = 24, msgIdBytes = 24, - storeLogFile = Nothing, - storeMsgsFile = Nothing, + storeLogFile = Just testStoreLogFile, + storeMsgsFile = Just testStoreMsgsDir, storeNtfsFile = Nothing, allowNewQueues = True, newQueueBasicAuth = Nothing, @@ -173,7 +183,7 @@ withSmpServerStoreMsgLogOn t = t cfg { storeLogFile = Just testStoreLogFile, - storeMsgsFile = Just testStoreMsgsFile, + storeMsgsFile = Just testStoreMsgsDir, storeNtfsFile = Just testStoreNtfsFile, serverStatsBackupFile = Just testServerStatsBackupFile } diff --git a/tests/SMPProxyTests.hs b/tests/SMPProxyTests.hs index 75f1f46b3..b1bf469a3 100644 --- a/tests/SMPProxyTests.hs +++ b/tests/SMPProxyTests.hs @@ -135,14 +135,15 @@ smpProxyTests = do let deliver nAgents nMsgs = agentDeliverMessagesViaProxyConc (replicate nAgents [srv1]) (map bshow [1 :: Int .. nMsgs]) it "25 agents, 300 pairs, 17 messages" . oneServer . withNumCapabilities 4 $ deliver 25 17 where - oneServer = withSmpServerConfigOn (transport @TLS) proxyCfg {msgQueueQuota = 128} testPort . const + oneServer = withSmpServerConfigOn (transport @TLS) proxyCfg {msgQueueQuota = 128, maxJournalMsgCount = 256} testPort . const twoServers = twoServers_ proxyCfg proxyCfg - twoServersFirstProxy = twoServers_ proxyCfg cfgV8 {msgQueueQuota = 128} - twoServersMoreConc = twoServers_ proxyCfg {serverClientConcurrency = 128} cfgV8 {msgQueueQuota = 128} - twoServersNoConc = twoServers_ proxyCfg {serverClientConcurrency = 1} cfgV8 {msgQueueQuota = 128} + twoServersFirstProxy = twoServers_ proxyCfg cfgV8 {msgQueueQuota = 128, maxJournalMsgCount = 256} + twoServersMoreConc = twoServers_ proxyCfg {serverClientConcurrency = 128} cfgV8 {msgQueueQuota = 128, maxJournalMsgCount = 256} + twoServersNoConc = twoServers_ proxyCfg {serverClientConcurrency = 1} cfgV8 {msgQueueQuota = 128, maxJournalMsgCount = 256} twoServers_ cfg1 cfg2 runTest = withSmpServerConfigOn (transport @TLS) cfg1 testPort $ \_ -> - withSmpServerConfigOn (transport @TLS) cfg2 testPort2 $ const runTest + let cfg2' = cfg2 {storeLogFile = Just testStoreLogFile2, storeMsgsFile = Just testStoreMsgsDir2} + in withSmpServerConfigOn (transport @TLS) cfg2' testPort2 $ const runTest deliverMessageViaProxy :: (C.AlgorithmI a, C.AuthAlgorithm a) => SMPServer -> SMPServer -> C.SAlgorithm a -> ByteString -> ByteString -> IO () deliverMessageViaProxy proxyServ relayServ alg msg msg' = deliverMessagesViaProxy proxyServ relayServ alg [msg] [msg'] @@ -379,11 +380,11 @@ agentViaProxyRetryOffline = do ackMessage alice bobId (baseId + 4) Nothing where withServer :: (ThreadId -> IO a) -> IO a - withServer = withServer_ testStoreLogFile testStoreMsgsFile testStoreNtfsFile testPort + withServer = withServer_ testStoreLogFile testStoreMsgsDir testStoreNtfsFile testPort withServer2 :: (ThreadId -> IO a) -> IO a - withServer2 = withServer_ testStoreLogFile2 testStoreMsgsFile2 testStoreNtfsFile2 testPort2 - withServer_ storeLog storeMsgs storeNtfs port = - withSmpServerConfigOn (transport @TLS) proxyCfg {storeLogFile = Just storeLog, storeMsgsFile = Just storeMsgs, storeNtfsFile = Just storeNtfs} port + withServer2 = withServer_ testStoreLogFile2 testStoreMsgsDir2 testStoreNtfsFile2 testPort2 + withServer_ storeLog storeMsgs storeNtfs = + withSmpServerConfigOn (transport @TLS) proxyCfg {storeLogFile = Just storeLog, storeMsgsFile = Just storeMsgs, storeNtfsFile = Just storeNtfs} a `up` cId = nGet a =##> \case ("", "", UP _ [c]) -> c == cId; _ -> False a `down` cId = nGet a =##> \case ("", "", DOWN _ [c]) -> c == cId; _ -> False aCfg = agentCfg {messageRetryInterval = fastMessageRetryInterval} diff --git a/tests/ServerTests.hs b/tests/ServerTests.hs index d66f7363f..38db97f3f 100644 --- a/tests/ServerTests.hs +++ b/tests/ServerTests.hs @@ -37,10 +37,12 @@ import Simplex.Messaging.Parsers (parseAll) import Simplex.Messaging.Protocol import Simplex.Messaging.Server.Env.STM (ServerConfig (..)) import Simplex.Messaging.Server.Expiration +import Simplex.Messaging.Server.MsgStore.Types (AMSType (..), SMSType (..)) import Simplex.Messaging.Server.Stats (PeriodStatsData (..), ServerStatsData (..)) import Simplex.Messaging.Transport +import Simplex.Messaging.Util (whenM) import Simplex.Messaging.Version (mkVersionRange) -import System.Directory (removeFile) +import System.Directory (doesDirectoryExist, removeDirectoryRecursive, removeFile) import System.TimeIt (timeItT) import System.Timeout import Test.HUnit @@ -64,8 +66,8 @@ serverTests t@(ATransport t') = do describe "GET & SUB commands" $ testGetSubCommands t' describe "Exceeding queue quota" $ testExceedQueueQuota t' describe "Store log" $ testWithStoreLog t - describe "Restore messages" $ testRestoreMessages t - describe "Restore messages (old / v2)" $ testRestoreExpireMessages t + xdescribe "Restore messages" $ testRestoreMessages t + xdescribe "Restore messages (old / v2)" $ testRestoreExpireMessages t describe "Timing of AUTH error" $ testTiming t describe "Message notifications" $ testMessageNotifications t describe "Message expiration" $ do @@ -601,7 +603,8 @@ testWithStoreLog at@(ATransport t) = logSize testStoreLogFile `shouldReturn` 6 - withSmpServerThreadOn at testPort . runTest t $ \h -> do + let cfg' = cfg {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") @@ -646,6 +649,7 @@ testRestoreMessages at@(ATransport t) = it "should store messages on exit and restore on start" $ do removeFileIfExists testStoreLogFile removeFileIfExists testStoreMsgsFile + whenM (doesDirectoryExist testStoreMsgsDir) $ removeDirectoryRecursive testStoreMsgsDir removeFileIfExists testServerStatsBackupFile g <- C.newRandom @@ -679,7 +683,7 @@ testRestoreMessages at@(ATransport t) = rId <- readTVarIO recipientId logSize testStoreLogFile `shouldReturn` 2 - logSize testStoreMsgsFile `shouldReturn` 5 + -- logSize testStoreMsgsFile `shouldReturn` 5 logSize testServerStatsBackupFile `shouldReturn` 74 Right stats1 <- strDecode <$> B.readFile testServerStatsBackupFile checkStats stats1 [rId] 5 1 @@ -697,7 +701,7 @@ testRestoreMessages at@(ATransport t) = logSize testStoreLogFile `shouldReturn` 1 -- the last message is not removed because it was not ACK'd - logSize testStoreMsgsFile `shouldReturn` 3 + -- logSize testStoreMsgsFile `shouldReturn` 3 logSize testServerStatsBackupFile `shouldReturn` 74 Right stats2 <- strDecode <$> B.readFile testServerStatsBackupFile checkStats stats2 [rId] 5 3 @@ -714,15 +718,15 @@ testRestoreMessages at@(ATransport t) = (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 + -- logSize testStoreMsgsFile `shouldReturn` 0 logSize testServerStatsBackupFile `shouldReturn` 74 Right stats3 <- strDecode <$> B.readFile testServerStatsBackupFile checkStats stats3 [rId] 5 5 removeFile testStoreLogFile - removeFile testStoreMsgsFile + removeFileIfExists testStoreMsgsFile + whenM (doesDirectoryExist testStoreMsgsDir) $ removeDirectoryRecursive testStoreMsgsDir removeFile testServerStatsBackupFile where runTest :: Transport c => TProxy c -> (THandleSMP c 'TClient -> IO ()) -> ThreadId -> Expectation @@ -780,7 +784,7 @@ testRestoreExpireMessages at@(ATransport t) = length (B.lines msgs) `shouldBe` 4 let expCfg1 = Just ExpirationConfig {ttl = 86400, checkInterval = 43200} - cfg1 = cfg {storeLogFile = Just testStoreLogFile, storeMsgsFile = Just testStoreMsgsFile, messageExpiration = expCfg1, serverStatsBackupFile = Just testServerStatsBackupFile} + cfg1 = cfg {messageExpiration = expCfg1, serverStatsBackupFile = Just testServerStatsBackupFile} withSmpServerConfigOn at cfg1 testPort . runTest t $ \_ -> pure () logSize testStoreLogFile `shouldReturn` 1 @@ -788,14 +792,14 @@ testRestoreExpireMessages at@(ATransport t) = msgs' `shouldBe` msgs let expCfg2 = Just ExpirationConfig {ttl = 2, checkInterval = 43200} - cfg2 = cfg {storeLogFile = Just testStoreLogFile, storeMsgsFile = Just testStoreMsgsFile, messageExpiration = expCfg2, serverStatsBackupFile = Just testServerStatsBackupFile} + cfg2 = cfg {messageExpiration = expCfg2, serverStatsBackupFile = Just testServerStatsBackupFile} withSmpServerConfigOn at cfg2 testPort . runTest t $ \_ -> pure () logSize testStoreLogFile `shouldReturn` 1 -- two messages expired - msgs'' <- B.readFile testStoreMsgsFile - length (B.lines msgs'') `shouldBe` 2 - B.lines msgs'' `shouldBe` drop 2 (B.lines msgs) + -- msgs'' <- B.readFile testStoreMsgsFile + -- length (B.lines msgs'') `shouldBe` 2 + -- B.lines msgs'' `shouldBe` drop 2 (B.lines msgs) Right ServerStatsData {_msgExpired} <- strDecode <$> B.readFile testServerStatsBackupFile _msgExpired `shouldBe` 2 where diff --git a/tests/Test.hs b/tests/Test.hs index bb1896be4..89672cd4f 100644 --- a/tests/Test.hs +++ b/tests/Test.hs @@ -11,6 +11,7 @@ import CoreTests.BatchingTests import CoreTests.CryptoFileTests import CoreTests.CryptoTests import CoreTests.EncodingTests +import CoreTests.MsgStoreTests import CoreTests.RetryIntervalTests import CoreTests.SOCKSSettings import CoreTests.StoreLogTests @@ -53,6 +54,7 @@ main = do describe "Version range" versionRangeTests describe "Encryption tests" cryptoTests describe "Encrypted files tests" cryptoFileTests + describe "Message store tests" msgStoreTests describe "Retry interval tests" retryIntervalTests describe "SOCKS settings tests" socksSettingsTests describe "Store log tests" storeLogTests From dc17402896138fc4b420c72414082a6bea20231c Mon Sep 17 00:00:00 2001 From: Evgeny Date: Mon, 21 Oct 2024 16:50:07 +0100 Subject: [PATCH 2/8] smp server: updated journal store API (#1374) * core: updated journal store API * parameterize JournalState by read/write type * collect stats when importing/expiring * compare stored stats and store for messages and notifications * simplify --- src/Simplex/Messaging/Server.hs | 154 ++++++++----- src/Simplex/Messaging/Server/Main.hs | 5 +- .../Messaging/Server/MsgStore/Journal.hs | 213 ++++++++++-------- src/Simplex/Messaging/Server/MsgStore/STM.hs | 8 +- .../Messaging/Server/MsgStore/Types.hs | 18 +- tests/AgentTests/FunctionalAPITests.hs | 5 +- tests/CoreTests/MsgStoreTests.hs | 93 ++++---- 7 files changed, 292 insertions(+), 204 deletions(-) diff --git a/src/Simplex/Messaging/Server.hs b/src/Simplex/Messaging/Server.hs index 3e8f556b5..214cd0790 100644 --- a/src/Simplex/Messaging/Server.hs +++ b/src/Simplex/Messaging/Server.hs @@ -32,11 +32,13 @@ module Simplex.Messaging.Server runSMPServerBlocking, importMessages, exportMessages, + printMessageStats, disconnectTransport, verifyCmdAuthorization, dummyVerifyCmd, randomId, AttachHTTP, + MessageStats (..), ) where @@ -91,6 +93,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 (JournalMsgQueue (..), closeMsgQueue) import Simplex.Messaging.Server.MsgStore.STM import Simplex.Messaging.Server.MsgStore.Types import Simplex.Messaging.Server.NtfStore @@ -139,13 +142,24 @@ runSMPServerBlocking started cfg attachHTTP_ = newEnv cfg >>= runReaderT (smpSer type M a = ReaderT Env IO a type AttachHTTP = Socket -> TLS.Context -> IO () +data MessageStats = MessageStats + { storedMsgsCount :: Int, + expiredMsgsCount :: Int, + storedQueues :: Int + } + +newMessageStats :: MessageStats +newMessageStats = MessageStats 0 0 0 + smpServer :: TMVar Bool -> ServerConfig -> Maybe AttachHTTP -> M () smpServer started cfg@ServerConfig {transports, transportConfig = tCfg} attachHTTP_ = do s <- asks server pa <- asks proxyAgent - expiredMsgs <- restoreServerMessages - expiredNtfs <- restoreServerNtfs - restoreServerStats expiredMsgs expiredNtfs + msgStats <- restoreServerMessages + ntfStats <- restoreServerNtfs + liftIO $ printMessageStats "messages" msgStats + liftIO $ printMessageStats "notifications" ntfStats + restoreServerStats msgStats ntfStats raceAny_ ( serverThread s "server subscribedQ" subscribedQ subscribers subClients pendingSubEvents subscriptions cancelSub : serverThread s "server ntfSubscribedQ" ntfSubscribedQ Env.notifiers ntfSubClients pendingNtfSubEvents ntfSubscriptions (\_ -> pure ()) @@ -366,9 +380,11 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg} attachHT liftIO $ forever $ do threadDelay' interval old <- expireBeforeEpoch expCfg - void $ withActiveMsgQueues ms $ \_ q -> do + void $ withActiveMsgQueues ms (\_ -> expireQueueMsgs stats old) 0 + where + expireQueueMsgs stats old q acc = runExceptT (deleteExpiredMsgs q old) >>= \case - Right deleted -> deleted <$ atomicModifyIORef'_ (msgExpired stats) (+ deleted) + Right deleted -> (acc + deleted) <$ atomicModifyIORef'_ (msgExpired stats) (+ deleted) Left _ -> pure 0 expireNtfsThread :: ServerConfig -> M () @@ -1435,7 +1451,7 @@ client thParams' clnt@Client {clientId, subscriptions, ntfSubscriptions, rcvQ, s q <- getMsgQueue ms $ recipientId qr expireMessages q messageExpiration stats msg <- liftIO $ mkMessage msgId body - writeMsg q True msg + writeMsg ms q True msg case msg_ of Left e -> pure $ err e Right Nothing -> do @@ -1722,21 +1738,47 @@ saveServerMessages drainMsgs = exportMessages :: MsgStoreClass s => s -> FilePath -> (MsgQueue s -> IO [Message]) -> IO () exportMessages ms f getMessages = do logInfo $ "saving messages to file " <> T.pack f - total <- liftIO $ withFile f WriteMode $ withAllMsgQueues ms . saveQueueMsgs + total <- liftIO $ withFile f WriteMode $ \h -> withAllMsgQueues ms (saveQueueMsgs h) 0 logInfo $ "messages saved: " <> tshow total where - saveQueueMsgs h rId q = getMessages q >>= \msgs -> length msgs <$ BLD.hPutBuilder h (encodeMessages rId msgs) + saveQueueMsgs h rId q acc = getMessages q >>= \msgs -> (acc + length msgs) <$ BLD.hPutBuilder h (encodeMessages rId msgs) encodeMessages rId = mconcat . map (\msg -> BLD.byteString (strEncode $ MLRv3 rId msg) <> BLD.char8 '\n') -restoreServerMessages :: M Int -restoreServerMessages = - asks msgStore >>= \case - AMS SMSMemory ms@STMMsgStore {storeConfig = STMStoreConfig {storePath = Just f}} -> do - old_ <- asks (messageExpiration . config) $>>= (liftIO . fmap Just . expireBeforeEpoch) - liftIO $ ifM (doesFileExist f) (importMessages ms f old_) (pure 0) - _ -> logInfo "using journal message storage" $> 0 +restoreServerMessages :: M MessageStats +restoreServerMessages = do + old_ <- asks (messageExpiration . config) $>>= (liftIO . fmap Just . expireBeforeEpoch) + asks msgStore >>= liftIO . processMessages old_ + where + processMessages :: Maybe Int64 -> AMsgStore -> IO MessageStats + processMessages old_ = \case + AMS SMSMemory ms@STMMsgStore {storeConfig = STMStoreConfig {storePath}} -> case storePath of + Just f -> ifM (doesFileExist f) (importMessages ms f old_) (pure newMessageStats) + Nothing -> pure newMessageStats + AMS SMSJournal ms -> case old_ of + Just old -> do + logInfo "expiring journal store messages..." + (storedMsgsCount, expiredMsgsCount, storedQueues) <- withAllMsgQueues ms (\_ -> processExpireQueue old) (0, 0, 0) + pure MessageStats {storedMsgsCount, expiredMsgsCount, storedQueues} + Nothing -> do + logInfo "validating journal store messages..." + (storedMsgsCount, storedQueues) <- withAllMsgQueues ms (\_ -> processValidateQueue) (0, 0) + pure MessageStats {storedMsgsCount, expiredMsgsCount = 0, storedQueues} + where + processExpireQueue old q (!stored, !expired, !qCount) = + runExceptT expireQueue >>= \case + Right (stored', expired') -> pure (stored + stored', expired + expired', qCount + 1) + Left e -> do + logInfo $ "failed expiring messages in queue " <> T.pack (queueDirectory q) <> ": " <> tshow e + exitFailure + where + expireQueue = do + expired'' <- deleteExpiredMsgs q old + stored'' <- liftIO $ getQueueSize q + liftIO $ closeMsgQueue q + pure (stored'', expired'') + processValidateQueue q (!stored, !qCount) = getQueueSize q >>= \stored' -> pure (stored + stored', qCount + 1) -importMessages :: MsgStoreClass s => s -> FilePath -> Maybe Int64 -> IO Int +importMessages :: MsgStoreClass s => s -> FilePath -> Maybe Int64 -> IO MessageStats importMessages ms f old_ = do logInfo $ "restoring messages from file " <> T.pack f LB.readFile f >>= runExceptT . foldM restoreMsg (0, 0, 0) . zip [0..] . LB.lines >>= \case @@ -1744,19 +1786,18 @@ importMessages ms f old_ = do putStrLn "" logError . T.pack $ "error restoring messages: " <> e liftIO exitFailure - Right (count, total, expired) -> do - putStrLn "" + Right (lineCount, storedMsgsCount, expiredMsgsCount) -> do + putStrLn $ "Processed " <> show lineCount <> " lines" renameFile f $ f <> ".bak" logQueueStates ms - qCount <- M.size <$> readTVarIO (activeMsgQueues ms) - logInfo $ "Processed " <> tshow count <> " lines, imported " <> tshow total <> " messages into " <> tshow qCount <> " queues, expired " <> tshow expired <> " messages" - pure expired + storedQueues <- M.size <$> readTVarIO (activeMsgQueues ms) + pure MessageStats {storedMsgsCount, expiredMsgsCount, storedQueues} where progress i = do liftIO $ putStr $ "Processed " <> show i <> " lines\r" hFlush stdout restoreMsg :: (Int, Int, Int) -> (Int, LB.ByteString) -> ExceptT String IO (Int, Int, Int) - restoreMsg (!count, !total, !expired) (i, s') = do + restoreMsg (!lineCount, !stored, !expired) (i, s') = do when (i `mod` 1000 == 0) $ progress i MLRv3 rId msg <- liftEither . first (msgErr "parsing") $ strDecode s liftError show $ addToMsgQueue rId msg @@ -1766,16 +1807,20 @@ importMessages ms f old_ = do q <- getMsgQueue ms rId (isExpired, logFull) <- case msg of Message {msgTs} - | maybe True (systemSeconds msgTs >=) old_ -> (False,) . isNothing <$> writeMsg q False msg + | maybe True (systemSeconds msgTs >=) old_ -> (False,) . isNothing <$> writeMsg ms q False msg | otherwise -> pure (True, False) - MessageQuota {} -> writeMsg q False msg $> (False, False) + MessageQuota {} -> writeMsg ms q False msg $> (False, False) when logFull . logError . decodeLatin1 $ "message queue " <> strEncode rId <> " is full, message not restored: " <> strEncode (messageId msg) - let total' = if logFull then total else total + 1 - expired' = if isExpired then expired + 1 else expired - pure (count + 1, total', expired') + let !stored' = if logFull || isExpired then stored else stored + 1 + !expired' = if isExpired then expired + 1 else expired + pure (lineCount + 1, stored', expired') msgErr :: Show e => String -> e -> String msgErr op e = op <> " error (" <> show e <> "): " <> B.unpack (B.take 100 s) +printMessageStats :: T.Text -> MessageStats -> IO () +printMessageStats name MessageStats {storedMsgsCount, expiredMsgsCount, storedQueues} = + logInfo $ name <> " stored: " <> tshow storedMsgsCount <> ", expired: " <> tshow expiredMsgsCount <> ", queues: " <> tshow storedQueues + saveServerNtfs :: M () saveServerNtfs = asks (storeNtfsFile . config) >>= mapM_ saveNtfs where @@ -1790,33 +1835,37 @@ saveServerNtfs = asks (storeNtfsFile . config) >>= mapM_ saveNtfs saveQueueNtfs h (nId, v) = BLD.hPutBuilder h . encodeNtfs nId . reverse =<< readTVarIO v encodeNtfs nId = mconcat . map (\ntf -> BLD.byteString (strEncode $ NLRv1 nId ntf) <> BLD.char8 '\n') -restoreServerNtfs :: M Int +restoreServerNtfs :: M MessageStats restoreServerNtfs = asks (storeNtfsFile . config) >>= \case - Just f -> ifM (doesFileExist f) (restoreNtfs f) (pure 0) - Nothing -> pure 0 + Just f -> ifM (doesFileExist f) (restoreNtfs f) (pure newMessageStats) + Nothing -> pure newMessageStats where restoreNtfs f = do logInfo $ "restoring notifications from file " <> T.pack f ns <- asks ntfStore old <- asks (notificationExpiration . config) >>= liftIO . expireBeforeEpoch - runExceptT (liftIO (LB.readFile f) >>= foldM (restoreNtf ns old) 0 . LB.lines) >>= \case - Left e -> do - logError . T.pack $ "error restoring notifications: " <> e - liftIO exitFailure - Right expired -> do - renameFile f $ f <> ".bak" - logInfo "notifications restored" - pure expired + liftIO $ + LB.readFile f >>= runExceptT . foldM (restoreNtf ns old) (0, 0, 0) . LB.lines >>= \case + Left e -> do + logError . T.pack $ "error restoring notifications: " <> e + liftIO exitFailure + Right (lineCount, storedMsgsCount, expiredMsgsCount) -> do + renameFile f $ f <> ".bak" + let NtfStore ns' = ns + storedQueues <- M.size <$> readTVarIO ns' + logInfo $ "notifications restored, " <> tshow lineCount <> " lines processed" + pure MessageStats {storedMsgsCount, expiredMsgsCount, storedQueues} where - restoreNtf ns old !expired s' = do + restoreNtf :: NtfStore -> Int64 -> (Int, Int, Int) -> LB.ByteString -> ExceptT String IO (Int, Int, Int) + restoreNtf ns old (!lineCount, !stored, !expired) s' = do NLRv1 nId ntf <- liftEither . first (ntfErr "parsing") $ strDecode s liftIO $ addToNtfs nId ntf where s = LB.toStrict s' addToNtfs nId ntf@MsgNtf {ntfTs} - | systemSeconds ntfTs < old = pure (expired + 1) - | otherwise = storeNtf ns nId ntf $> expired + | systemSeconds ntfTs < old = pure (lineCount + 1, stored, expired + 1) + | otherwise = storeNtf ns nId ntf $> (lineCount + 1, stored + 1, expired) ntfErr :: Show e => String -> e -> String ntfErr op e = op <> " error (" <> show e <> "): " <> B.unpack (B.take 100 s) @@ -1830,26 +1879,25 @@ saveServerStats = B.writeFile f $ strEncode stats logInfo "server stats saved" -restoreServerStats :: Int -> Int -> M () -restoreServerStats expiredMsgs expiredNtfs = asks (serverStatsBackupFile . config) >>= mapM_ restoreStats +restoreServerStats :: MessageStats -> MessageStats -> M () +restoreServerStats msgStats ntfStats = asks (serverStatsBackupFile . config) >>= mapM_ restoreStats where restoreStats f = whenM (doesFileExist f) $ do logInfo $ "restoring server stats from file " <> T.pack f liftIO (strDecode <$> B.readFile f) >>= \case - Right d@ServerStatsData {_qCount = statsQCount} -> do + Right d@ServerStatsData {_qCount = statsQCount, _msgCount = statsMsgCount, _ntfCount = statsNtfCount} -> do s <- asks serverStats _qCount <- fmap M.size . readTVarIO . queues =<< asks queueStore - _msgCount <- - asks msgStore >>= \case - AMS SMSMemory ms -> liftIO $ readTVarIO (msgQueues ms) >>= foldM (\(!n) q -> (n +) <$> getQueueSize q) 0 - _ -> pure 0 - NtfStore ns <- asks ntfStore - _ntfCount <- liftIO . foldM (\(!n) q -> (n +) . length <$> readTVarIO q) 0 =<< readTVarIO ns - liftIO $ setServerStats s d {_qCount, _msgCount, _ntfCount, _msgExpired = _msgExpired d + expiredMsgs, _msgNtfExpired = _msgNtfExpired d + expiredNtfs} + let _msgCount = storedMsgsCount msgStats + _ntfCount = storedMsgsCount ntfStats + liftIO $ setServerStats s d {_qCount, _msgCount, _ntfCount, _msgExpired = _msgExpired d + expiredMsgsCount msgStats, _msgNtfExpired = _msgNtfExpired d + expiredMsgsCount ntfStats} renameFile f $ f <> ".bak" logInfo "server stats restored" - when (_qCount /= statsQCount) $ logWarn $ "Queue count differs: stats: " <> tshow statsQCount <> ", store: " <> tshow _qCount - logInfo $ "Restored " <> tshow _msgCount <> " messages in " <> tshow _qCount <> " queues" + compareCounts "Queue" statsQCount _qCount + compareCounts "Message" statsMsgCount _msgCount + compareCounts "Notification" statsNtfCount _ntfCount Left e -> do logInfo $ "error restoring server stats: " <> T.pack e liftIO exitFailure + compareCounts name statsCnt storeCnt = + when (statsCnt /= storeCnt) $ logWarn $ name <> " count differs: stats: " <> tshow statsCnt <> ", store: " <> tshow storeCnt \ No newline at end of file diff --git a/src/Simplex/Messaging/Server/Main.hs b/src/Simplex/Messaging/Server/Main.hs index ddd51e815..f1f0808fa 100644 --- a/src/Simplex/Messaging/Server/Main.hs +++ b/src/Simplex/Messaging/Server/Main.hs @@ -39,7 +39,7 @@ import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Encoding.String import Simplex.Messaging.Parsers (parseAll) import Simplex.Messaging.Protocol (BasicAuth (..), ProtoServerWithAuth (ProtoServerWithAuth), pattern SMPServer) -import Simplex.Messaging.Server (AttachHTTP, exportMessages, importMessages, runSMPServer) +import Simplex.Messaging.Server (AttachHTTP, exportMessages, importMessages, printMessageStats, runSMPServer) import Simplex.Messaging.Server.CLI import Simplex.Messaging.Server.Env.STM import Simplex.Messaging.Server.Expiration @@ -99,8 +99,9 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath = ("WARNING: message log file " <> storeMsgsFilePath <> " will be imported to journal directory " <> storeMsgsJournalDir) "Messages not imported" ms <- newJournalMsgStore - void $ importMessages ms storeMsgsFilePath Nothing -- no expiration + msgStats <- importMessages 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 SMSJournal) -> "store_messages set to `journal`" diff --git a/src/Simplex/Messaging/Server/MsgStore/Journal.hs b/src/Simplex/Messaging/Server/MsgStore/Journal.hs index 29a022668..e0ba446ad 100644 --- a/src/Simplex/Messaging/Server/MsgStore/Journal.hs +++ b/src/Simplex/Messaging/Server/MsgStore/Journal.hs @@ -10,16 +10,19 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} module Simplex.Messaging.Server.MsgStore.Journal ( JournalMsgStore (msgQueues, random), - JournalMsgQueue, + JournalMsgQueue (queueDirectory), JournalStoreConfig (..), getQueueMessages, + closeMsgQueue, -- below are exported for tests MsgQueueState (..), JournalState (..), + SJournalType (..), msgQueueDirectory, readWriteQueueState, newMsgQueueState, @@ -54,6 +57,7 @@ import Simplex.Messaging.TMap (TMap) import qualified Simplex.Messaging.TMap as TM import Simplex.Messaging.Util (ifM, tshow, ($>>=)) import System.Directory +import System.Exit import System.FilePath (()) import System.IO (BufferMode (..), Handle, IOMode (..), SeekMode (..), stdout) import qualified System.IO as IO @@ -78,22 +82,20 @@ data JournalStoreConfig = JournalStoreConfig } data JournalMsgQueue = JournalMsgQueue - { config :: JournalStoreConfig, - queueDirectory :: FilePath, + { queueDirectory :: FilePath, queueLock :: Lock, state :: TVar MsgQueueState, - -- Last message and length incl. newline + -- tipMsg contains last message and length incl. newline -- Nothing - unknown, Just Nothing - empty queue. - -- This optimization prevents reading each message at least twice, - -- or reading it after it was just written. + -- It prevents reading each message twice, + -- and reading it after it was just written. tipMsg :: TVar (Maybe (Maybe (Message, Int))), - handles :: TVar (Maybe MsgQueueHandles), - random :: TVar StdGen + handles :: TVar (Maybe MsgQueueHandles) } data MsgQueueState = MsgQueueState - { writeState :: JournalState, - readState :: JournalState, + { readState :: JournalState 'JTRead, + writeState :: JournalState 'JTWrite, canWrite :: Bool, size :: Int } @@ -105,21 +107,49 @@ data MsgQueueHandles = MsgQueueHandles writeHandle :: Maybe Handle -- optional, used when write file is different from read file } -data JournalState = JournalState - { journalId :: ByteString, +data JournalState t = JournalState + { journalType :: SJournalType t, + journalId :: ByteString, msgPos :: Int, msgCount :: Int, - bytePos :: Int + bytePos :: Int, + byteCount :: Int } deriving (Show) +data JournalType = JTRead | JTWrite + +data SJournalType (t :: JournalType) where + SJTRead :: SJournalType 'JTRead + SJTWrite :: SJournalType 'JTWrite + +class JournalTypeI t where sJournalType :: SJournalType t + +instance JournalTypeI 'JTRead where sJournalType = SJTRead + +instance JournalTypeI 'JTWrite where sJournalType = SJTWrite + +deriving instance Show (SJournalType t) + newMsgQueueState :: ByteString -> MsgQueueState newMsgQueueState journalId = - let st = newJournalState journalId - in MsgQueueState {writeState = st, readState = st, canWrite = True, size = 0} + MsgQueueState + { writeState = newJournalState journalId, + readState = newJournalState journalId, + canWrite = True, + size = 0 + } -newJournalState :: ByteString -> JournalState -newJournalState journalId = JournalState {journalId, msgPos = 0, msgCount = 0, bytePos = 0} +newJournalState :: JournalTypeI t => ByteString -> JournalState t +newJournalState journalId = + JournalState + { journalType = sJournalType, + journalId, + msgPos = 0, + msgCount = 0, + bytePos = 0, + byteCount = 0 + } journalFilePath :: FilePath -> ByteString -> FilePath journalFilePath dir journalId = dir (msgLogFileName <> "." <> B.unpack journalId <> logFileExt) @@ -139,15 +169,15 @@ instance StrEncoding MsgQueueState where size <- " size=" *> strP pure MsgQueueState {writeState, readState, canWrite, size} -instance StrEncoding JournalState where - strEncode JournalState {journalId, msgPos, msgCount, bytePos} = - B.intercalate "," [journalId, strEncode msgPos, strEncode msgCount, strEncode bytePos] +instance JournalTypeI t => StrEncoding (JournalState t) where + strEncode JournalState {journalId, msgPos, msgCount, bytePos, byteCount} = + B.concat [journalId, ",", strEncodeList [msgPos, msgCount, bytePos, byteCount]] strP = do journalId <- A.takeTill (== ',') - msgPos <- A.char ',' *> strP - msgCount <- A.char ',' *> strP - bytePos <- A.char ',' *> strP - pure JournalState {journalId, msgPos, msgCount, bytePos} + A.char ',' *> strListP >>= \case + [msgPos, msgCount, bytePos, byteCount] -> + pure JournalState {journalType = sJournalType, journalId, msgPos, msgCount, bytePos, byteCount} + _ -> fail "bad JournalState" queueLogFileName :: String queueLogFileName = "queue_state" @@ -158,11 +188,11 @@ msgLogFileName = "messages" logFileExt :: String logFileExt = ".log" -newtype NonAtomicIO a = NonAtomicIO (IO a) +newtype StoreIO a = StoreIO (IO a) deriving newtype (Functor, Applicative, Monad) instance MsgStoreClass JournalMsgStore where - type StoreMonad JournalMsgStore = NonAtomicIO + type StoreMonad JournalMsgStore = StoreIO type MsgQueue JournalMsgStore = JournalMsgQueue type MsgStoreConfig JournalMsgStore = JournalStoreConfig @@ -173,33 +203,36 @@ instance MsgStoreClass JournalMsgStore where msgQueues <- TM.emptyIO pure JournalMsgStore {config, random, queueLocks, msgQueues} - closeMsgStore st = readTVarIO (msgQueues st) >>= mapM_ closeMsgQueue_ + closeMsgStore st = readTVarIO (msgQueues st) >>= mapM_ closeMsgQueue activeMsgQueues = msgQueues {-# INLINE activeMsgQueues #-} - -- This function opens and closes all queues. - -- It is used to export storage to a single file, not during normal server execution. - withAllMsgQueues :: JournalMsgStore -> (RecipientId -> JournalMsgQueue -> IO Int) -> IO Int - withAllMsgQueues st@JournalMsgStore {config} action = do - closeMsgStore st - lock <- createLockIO -- the same lock is used for all queues - dirs <- zip [0..] <$> listQueueDirs 0 ("", storePath) - let count = length dirs - total <- foldM (processQueue lock count) 0 dirs - progress count count - putStrLn "" - pure total + -- 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. + withAllMsgQueues :: JournalMsgStore -> (RecipientId -> JournalMsgQueue -> a -> IO a) -> a -> IO a + withAllMsgQueues ms@JournalMsgStore {config} action res = ifM (doesDirectoryExist storePath) processStore (pure res) where + processStore = do + closeMsgStore ms + lock <- createLockIO -- the same lock is used for all queues + dirs <- zip [0..] <$> listQueueDirs 0 ("", storePath) + let count = length dirs + res' <- foldM (processQueue lock count) res dirs + progress count count + putStrLn "" + pure res' JournalStoreConfig {storePath, pathParts} = config - processQueue lock count !total (i :: Int, (queueId, dir)) = do + processQueue lock count acc (i :: Int, (queueId, dir)) = do when (i `mod` 100 == 0) $ progress i count - q <- openMsgQueue st dir lock - total' <- case strDecode $ B.pack queueId of - Right rId -> (total +) <$> action rId q - Left e -> total <$ putStrLn ("Error: message queue directory " <> dir <> " is invalid: " <> e) - closeMsgQueue_ q - pure total' + q <- openMsgQueue ms dir lock + acc' <- case strDecode $ B.pack queueId of + Right rId -> action rId q acc + Left e -> do + putStrLn ("Error: message queue directory " <> dir <> " is invalid: " <> e) + exitFailure + closeMsgQueue q + pure acc' progress i count = do putStr $ "Processed: " <> show i <> "/" <> show count <> " queues\r" IO.hFlush stdout @@ -216,21 +249,21 @@ instance MsgStoreClass JournalMsgStore where (Nothing <$ putStrLn ("Error: path " <> path' <> " is not a directory, skipping")) logQueueStates :: JournalMsgStore -> IO () - logQueueStates st = - void $ withActiveMsgQueues st $ \_ q -> - readTVarIO (handles q) - >>= maybe (pure ()) (\hs -> readTVarIO (state q) >>= logQueueState (stateHandle hs)) - >> pure 0 + logQueueStates st = withActiveMsgQueues st (\_ q _ -> logState q) () + where + logState q = + readTVarIO (handles q) + >>= maybe (pure ()) (\hs -> readTVarIO (state q) >>= logQueueState (stateHandle hs)) getMsgQueue :: JournalMsgStore -> RecipientId -> ExceptT ErrorType IO JournalMsgQueue - getMsgQueue store@JournalMsgStore {queueLocks, msgQueues, random} rId = + getMsgQueue ms@JournalMsgStore {queueLocks, msgQueues, random} rId = tryStore "getMsgQueue" $ withLockMap queueLocks rId "getMsgQueue" $ TM.lookupIO rId msgQueues >>= maybe newQ pure where newQ = do - let dir = msgQueueDirectory store rId + let dir = msgQueueDirectory ms rId queueLock <- atomically $ getMapLock queueLocks rId - q <- ifM (doesDirectoryExist dir) (openMsgQueue store dir queueLock) (createQ dir queueLock) + q <- ifM (doesDirectoryExist dir) (openMsgQueue ms dir queueLock) (createQ dir queueLock) atomically $ TM.insert rId q msgQueues pure q where @@ -239,24 +272,24 @@ instance MsgStoreClass JournalMsgStore where -- folder and files are not created here, -- to avoid file IO for queues without messages during subscription journalId <- newJournalId random - mkJournalQueue store dir queueLock (newMsgQueueState journalId, Nothing) + mkJournalQueue dir queueLock (newMsgQueueState journalId, Nothing) delMsgQueue :: JournalMsgStore -> RecipientId -> IO () - delMsgQueue st rId = withLockMap (queueLocks st) rId "delMsgQueue" $ do - void $ closeMsgQueue st rId - removeQueueDirectory st rId + delMsgQueue ms rId = withLockMap (queueLocks ms) rId "delMsgQueue" $ do + void $ deleteMsgQueue_ ms rId + removeQueueDirectory ms rId delMsgQueueSize :: JournalMsgStore -> RecipientId -> IO Int - delMsgQueueSize st rId = withLockMap (queueLocks st) rId "delMsgQueue" $ do - state_ <- closeMsgQueue st rId + delMsgQueueSize ms rId = withLockMap (queueLocks ms) rId "delMsgQueue" $ do + state_ <- deleteMsgQueue_ ms rId sz <- maybe (pure $ -1) (fmap size . readTVarIO) state_ - removeQueueDirectory st rId + removeQueueDirectory ms rId pure sz getQueueMessages :: Bool -> JournalMsgQueue -> IO [Message] getQueueMessages drainMsgs q = readTVarIO (handles q) >>= maybe (pure []) (getMsg []) where - getMsg ms hs = chooseReadJournal q drainMsgs hs >>= maybe (pure ms) readMsg + getMsg msgs hs = chooseReadJournal q drainMsgs hs >>= maybe (pure msgs) readMsg where readMsg (rs, h) = do -- TODO handle errors @@ -264,10 +297,10 @@ instance MsgStoreClass JournalMsgStore where -- TODO handle errors Right msg <- pure $ strDecode s updateReadPos q drainMsgs (B.length s + 1) hs -- 1 is to account for new line - (msg :) <$> getMsg ms hs + (msg :) <$> getMsg msgs hs - writeMsg :: JournalMsgQueue -> Bool -> Message -> ExceptT ErrorType IO (Maybe (Message, Bool)) - writeMsg q@JournalMsgQueue {queueDirectory, handles, config, random} logState !msg = + writeMsg :: JournalMsgStore -> JournalMsgQueue -> Bool -> Message -> ExceptT ErrorType IO (Maybe (Message, Bool)) + writeMsg ms q@JournalMsgQueue {queueDirectory, handles} logState !msg = tryStore "writeMsg" $ withLock' (queueLock q) "writeMsg" $ do st@MsgQueueState {canWrite, size} <- readTVarIO (state q) let empty = size == 0 @@ -279,7 +312,7 @@ instance MsgStoreClass JournalMsgStore where else writeToJournal st canWrt' msgQuota $> Nothing else pure Nothing where - JournalStoreConfig {quota, maxMsgCount} = config + JournalStoreConfig {quota, maxMsgCount} = config ms msgQuota = MessageQuota {msgId = msgId msg, msgTs = msgTs msg} writeToJournal st@MsgQueueState {writeState, readState = rs, size} canWrt' msg' = do let msgStr = strEncode msg' `B.snoc` '\n' @@ -306,7 +339,7 @@ instance MsgStoreClass JournalMsgStore where atomically $ writeTVar handles $ Just hs pure hs switchWriteJournal hs = do - journalId <- newJournalId random + journalId <- newJournalId $ random ms wh <- createNewJournal queueDirectory journalId atomically $ writeTVar handles $ Just $ hs {writeHandle = Just wh} pure (newJournalState journalId, wh) @@ -314,9 +347,9 @@ instance MsgStoreClass JournalMsgStore where getQueueSize :: JournalMsgQueue -> IO Int getQueueSize JournalMsgQueue {state} = size <$> readTVarIO state - tryPeekMsg_ :: JournalMsgQueue -> NonAtomicIO (Maybe Message) + tryPeekMsg_ :: JournalMsgQueue -> StoreIO (Maybe Message) tryPeekMsg_ q@JournalMsgQueue {tipMsg, handles} = - NonAtomicIO $ readTVarIO handles $>>= chooseReadJournal q True $>>= peekMsg + StoreIO $ readTVarIO handles $>>= chooseReadJournal q True $>>= peekMsg where peekMsg (rs, h) = readTVarIO tipMsg >>= maybe readMsg (pure . fmap fst) where @@ -328,16 +361,16 @@ instance MsgStoreClass JournalMsgStore where atomically $ writeTVar tipMsg $ Just (Just (msg, B.length s + 1)) -- 1 is to account for new line pure $ Just msg - tryDeleteMsg_ :: JournalMsgQueue -> NonAtomicIO () - tryDeleteMsg_ q@JournalMsgQueue {tipMsg, handles} = NonAtomicIO $ + tryDeleteMsg_ :: JournalMsgQueue -> StoreIO () + tryDeleteMsg_ q@JournalMsgQueue {tipMsg, handles} = StoreIO $ void $ readTVarIO tipMsg -- if there is no cached tipMsg, do nothing $>>= (pure . fmap snd) $>>= \len -> readTVarIO handles $>>= \hs -> updateReadPos q True len hs $> Just () - atomicQueue :: JournalMsgQueue -> String -> NonAtomicIO a -> ExceptT ErrorType IO a - atomicQueue mq op (NonAtomicIO a) = tryStore op $ withLock' (queueLock mq) op $ a + isolateQueue :: JournalMsgQueue -> String -> StoreIO a -> ExceptT ErrorType IO a + isolateQueue mq op (StoreIO a) = tryStore op $ withLock' (queueLock mq) op $ a tryStore :: String -> IO a -> ExceptT ErrorType IO a tryStore op a = @@ -347,15 +380,15 @@ tryStore op a = in logError ("STORE ERROR " <> T.pack e') $> Left (STORE e') openMsgQueue :: JournalMsgStore -> FilePath -> Lock -> IO JournalMsgQueue -openMsgQueue store dir queueLock = do +openMsgQueue ms dir queueLock = do let statePath = dir (queueLogFileName <> logFileExt) - (st, sh) <- readWriteQueueState store statePath + (st, sh) <- readWriteQueueState ms statePath (st', rh, wh_) <- openJournals dir st let hs = MsgQueueHandles {stateHandle = sh, readHandle = rh, writeHandle = wh_} - mkJournalQueue store dir queueLock (st', Just hs) + mkJournalQueue dir queueLock (st', Just hs) -mkJournalQueue :: JournalMsgStore -> FilePath -> Lock -> (MsgQueueState, Maybe MsgQueueHandles) -> IO JournalMsgQueue -mkJournalQueue JournalMsgStore {random, config} dir queueLock (st, hs_) = do +mkJournalQueue :: FilePath -> Lock -> (MsgQueueState, Maybe MsgQueueHandles) -> IO JournalMsgQueue +mkJournalQueue dir queueLock (st, hs_) = do state <- newTVarIO st tipMsg <- newTVarIO Nothing handles <- newTVarIO hs_ @@ -363,16 +396,14 @@ mkJournalQueue JournalMsgStore {random, config} dir queueLock (st, hs_) = do -- to avoid map lookup on queue operations pure JournalMsgQueue - { config, - queueDirectory = dir, + { queueDirectory = dir, queueLock, state, tipMsg, - handles, - random + handles } -chooseReadJournal :: JournalMsgQueue -> Bool -> MsgQueueHandles -> IO (Maybe (JournalState, Handle)) +chooseReadJournal :: JournalMsgQueue -> 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 @@ -390,8 +421,8 @@ chooseReadJournal q log' hs = do updateQueueState :: JournalMsgQueue -> Bool -> MsgQueueHandles -> MsgQueueState -> IO () updateQueueState q log' hs st = do - atomically $ writeTVar (state q) st when log' $ logQueueState (stateHandle hs) st + atomically $ writeTVar (state q) st logQueueState :: Handle -> MsgQueueState -> IO () logQueueState h st = B.hPutStr h $ strEncode st `B.snoc` '\n' @@ -454,9 +485,11 @@ openJournals dir st@MsgQueueState {readState = rs, writeState = ws} = do st' <- fixWriteFileSize wh pure (st', rh, Just wh) where + openJournal :: JournalState t -> IO (Either FilePath Handle) openJournal JournalState {journalId} = let path = journalFilePath dir journalId in ifM (doesFileExist path) (Right <$> openFile path ReadWriteMode) (pure $ Left path) + -- do that for all append operations fixWriteFileSize h = do let sz = fromIntegral $ bytePos ws sz' <- IO.hFileSize h @@ -465,7 +498,7 @@ openJournals dir st@MsgQueueState {readState = rs, writeState = ws} = do | sz' == sz -> pure st | otherwise -> pure st -- TODO re-read file to recover what is possible ??? -removeJournal :: FilePath -> JournalState -> IO () +removeJournal :: FilePath -> JournalState t -> IO () removeJournal dir JournalState {journalId} = do let path = journalFilePath dir journalId removeFile path `catchAny` (\e -> logError $ "STORE ERROR removing file " <> T.pack path <> ": " <> tshow e) @@ -522,13 +555,13 @@ readWriteQueueState JournalMsgStore {random, config} statePath = logQueueState sh st pure (st, sh) -closeMsgQueue :: JournalMsgStore -> RecipientId -> IO (Maybe (TVar MsgQueueState)) -closeMsgQueue st rId = +deleteMsgQueue_ :: JournalMsgStore -> RecipientId -> IO (Maybe (TVar MsgQueueState)) +deleteMsgQueue_ st rId = atomically (TM.lookupDelete rId (msgQueues st)) - >>= mapM (\q -> closeMsgQueue_ q $> state q) + >>= mapM (\q -> closeMsgQueue q $> state q) -closeMsgQueue_ :: JournalMsgQueue -> IO () -closeMsgQueue_ q = readTVarIO (handles q) >>= mapM_ closeHandles +closeMsgQueue :: JournalMsgQueue -> IO () +closeMsgQueue q = readTVarIO (handles q) >>= mapM_ closeHandles where closeHandles (MsgQueueHandles sh rh wh_) = do hClose sh diff --git a/src/Simplex/Messaging/Server/MsgStore/STM.hs b/src/Simplex/Messaging/Server/MsgStore/STM.hs index df4507175..17591650c 100644 --- a/src/Simplex/Messaging/Server/MsgStore/STM.hs +++ b/src/Simplex/Messaging/Server/MsgStore/STM.hs @@ -93,8 +93,8 @@ instance MsgStoreClass STMMsgStore where mapM_ (writeTQueue q) msgs pure msgs - writeMsg :: STMMsgQueue -> Bool -> Message -> ExceptT ErrorType IO (Maybe (Message, Bool)) - writeMsg STMMsgQueue {msgQueue = q, quota, canWrite, size} _logState !msg = liftIO $ atomically $ do + writeMsg :: STMMsgStore -> STMMsgQueue -> Bool -> Message -> ExceptT ErrorType IO (Maybe (Message, Bool)) + writeMsg _ STMMsgQueue {msgQueue = q, quota, canWrite, size} _logState !msg = liftIO $ atomically $ do canWrt <- readTVar canWrite empty <- isEmptyTQueue q if canWrt || empty @@ -122,5 +122,5 @@ instance MsgStoreClass STMMsgStore where Just _ -> modifyTVar' size (subtract 1) _ -> pure () - atomicQueue :: STMMsgQueue -> String -> STM a -> ExceptT ErrorType IO a - atomicQueue _ _ = liftIO . atomically + isolateQueue :: STMMsgQueue -> String -> STM a -> ExceptT ErrorType IO a + isolateQueue _ _ = liftIO . atomically diff --git a/src/Simplex/Messaging/Server/MsgStore/Types.hs b/src/Simplex/Messaging/Server/MsgStore/Types.hs index 68693883d..dbaefba6f 100644 --- a/src/Simplex/Messaging/Server/MsgStore/Types.hs +++ b/src/Simplex/Messaging/Server/MsgStore/Types.hs @@ -24,17 +24,17 @@ class Monad (StoreMonad s) => MsgStoreClass s where newMsgStore :: MsgStoreConfig s -> IO s closeMsgStore :: s -> IO () activeMsgQueues :: s -> TMap RecipientId (MsgQueue s) - withAllMsgQueues :: s -> (RecipientId -> MsgQueue s -> IO Int) -> IO Int + withAllMsgQueues :: s -> (RecipientId -> MsgQueue s -> a -> IO a) -> a -> IO a logQueueStates :: s -> IO () getMsgQueue :: s -> RecipientId -> ExceptT ErrorType IO (MsgQueue s) delMsgQueue :: s -> RecipientId -> IO () delMsgQueueSize :: s -> RecipientId -> IO Int getQueueMessages :: Bool -> MsgQueue s -> IO [Message] - writeMsg :: MsgQueue s -> Bool -> Message -> ExceptT ErrorType IO (Maybe (Message, Bool)) + writeMsg :: s -> MsgQueue s -> Bool -> Message -> ExceptT ErrorType IO (Maybe (Message, Bool)) getQueueSize :: MsgQueue s -> IO Int tryPeekMsg_ :: MsgQueue s -> StoreMonad s (Maybe Message) tryDeleteMsg_ :: MsgQueue s -> StoreMonad s () - atomicQueue :: MsgQueue s -> String -> StoreMonad s a -> ExceptT ErrorType IO a + isolateQueue :: MsgQueue s -> String -> StoreMonad s a -> ExceptT ErrorType IO a data MSType = MSMemory | MSJournal @@ -44,16 +44,16 @@ data SMSType :: MSType -> Type where data AMSType = forall s. AMSType (SMSType s) -withActiveMsgQueues :: MsgStoreClass s => s -> (RecipientId -> MsgQueue s -> IO Int) -> IO Int -withActiveMsgQueues st f = readTVarIO (activeMsgQueues st) >>= M.foldrWithKey (\k v -> ((+) <$> f k v <*>)) (pure 0) +withActiveMsgQueues :: MsgStoreClass s => s -> (RecipientId -> MsgQueue s -> a -> IO a) -> a -> IO a +withActiveMsgQueues st f a = readTVarIO (activeMsgQueues st) >>= M.foldrWithKey (\k v -> (>>= f k v)) (pure a) tryPeekMsg :: MsgStoreClass s => MsgQueue s -> ExceptT ErrorType IO (Maybe Message) -tryPeekMsg mq = atomicQueue mq "tryPeekMsg" $ tryPeekMsg_ mq +tryPeekMsg mq = isolateQueue mq "tryPeekMsg" $ tryPeekMsg_ mq {-# INLINE tryPeekMsg #-} tryDelMsg :: MsgStoreClass s => MsgQueue s -> MsgId -> ExceptT ErrorType IO (Maybe Message) tryDelMsg mq msgId' = - atomicQueue mq "tryDelMsg" $ + isolateQueue mq "tryDelMsg" $ tryPeekMsg_ mq >>= \case msg_@(Just msg) | msgId msg == msgId' -> @@ -63,7 +63,7 @@ tryDelMsg mq msgId' = -- atomic delete (== read) last and peek next message if available tryDelPeekMsg :: MsgStoreClass s => MsgQueue s -> MsgId -> ExceptT ErrorType IO (Maybe Message, Maybe Message) tryDelPeekMsg mq msgId' = - atomicQueue mq "tryDelPeekMsg" $ + isolateQueue mq "tryDelPeekMsg" $ tryPeekMsg_ mq >>= \case msg_@(Just msg) | msgId msg == msgId' -> (msg_,) <$> (tryDeleteMsg_ mq >> tryPeekMsg_ mq) @@ -71,7 +71,7 @@ tryDelPeekMsg mq msgId' = _ -> pure (Nothing, Nothing) deleteExpiredMsgs :: MsgStoreClass s => MsgQueue s -> Int64 -> ExceptT ErrorType IO Int -deleteExpiredMsgs mq old = atomicQueue mq "deleteExpiredMsgs" $ loop 0 +deleteExpiredMsgs mq old = isolateQueue mq "deleteExpiredMsgs" $ loop 0 where loop dc = tryPeekMsg_ mq >>= \case diff --git a/tests/AgentTests/FunctionalAPITests.hs b/tests/AgentTests/FunctionalAPITests.hs index 38a187ec5..425e93f29 100644 --- a/tests/AgentTests/FunctionalAPITests.hs +++ b/tests/AgentTests/FunctionalAPITests.hs @@ -1042,7 +1042,7 @@ testAllowConnectionClientRestart t = do bob <- getSMPAgentClient' 2 agentCfg initAgentServersSrv2 testDB2 withSmpServerStoreLogOn t testPort $ \_ -> do (aliceId, bobId, confId) <- - withSmpServerConfigOn t cfg {storeLogFile = Just testStoreLogFile2} testPort2 $ \_ -> do + withSmpServerConfigOn t cfg {storeLogFile = Just testStoreLogFile2, storeMsgsFile = Just testStoreMsgsDir2} testPort2 $ \_ -> do runRight $ do (bobId, qInfo) <- createConnection alice 1 True SCMInvitation Nothing SMSubscribe (aliceId, sqSecured) <- joinConnection bob 1 True qInfo "bob's connInfo" SMSubscribe @@ -1064,8 +1064,7 @@ testAllowConnectionClientRestart t = do alice2 <- getSMPAgentClient' 3 agentCfg initAgentServers testDB runRight_ $ subscribeConnection alice2 bobId threadDelay 500000 - - withSmpServerConfigOn t cfg {storeLogFile = Just testStoreLogFile2} testPort2 $ \_ -> do + withSmpServerConfigOn t cfg {storeLogFile = Just testStoreLogFile2, storeMsgsFile = Just testStoreMsgsDir2} testPort2 $ \_ -> do runRight $ do ("", "", UP _ _) <- nGet bob get alice2 ##> ("", bobId, CON) diff --git a/tests/CoreTests/MsgStoreTests.hs b/tests/CoreTests/MsgStoreTests.hs index 150312a60..dd54b1e33 100644 --- a/tests/CoreTests/MsgStoreTests.hs +++ b/tests/CoreTests/MsgStoreTests.hs @@ -21,7 +21,7 @@ import Data.Time.Clock.System (getSystemTime) import Simplex.Messaging.Crypto (pattern MaxLenBS) import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Protocol (EntityId (..), Message (..), noMsgFlags) -import Simplex.Messaging.Server (exportMessages, importMessages) +import Simplex.Messaging.Server (MessageStats (..), exportMessages, importMessages) import Simplex.Messaging.Server.MsgStore.Journal import Simplex.Messaging.Server.MsgStore.STM import Simplex.Messaging.Server.MsgStore.Types @@ -73,17 +73,20 @@ pattern Msg s <- Just Message {msgBody = MaxLenBS s} deriving instance Eq MsgQueueState -deriving instance Eq JournalState +deriving instance Eq (JournalState t) + +deriving instance Eq (SJournalType t) testGetQueue :: MsgStoreClass s => s -> IO () -testGetQueue st = do +testGetQueue ms = do g <- C.newRandom rId <- EntityId <$> atomically (C.randomBytes 24 g) runRight_ $ do - q <- getMsgQueue st rId - Just (Message {msgId = mId1}, True) <- writeMsg q True =<< mkMessage "message 1" - Just (Message {msgId = mId2}, False) <- writeMsg q True =<< mkMessage "message 2" - Just (Message {msgId = mId3}, False) <- writeMsg q True =<< mkMessage "message 3" + q <- getMsgQueue ms rId + 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 q Msg "message 1" <- tryPeekMsg q Nothing <- tryDelMsg q mId2 @@ -99,14 +102,14 @@ testGetQueue st = do Nothing <- tryDelMsg q mId2 Nothing <- tryDelMsg q mId3 Nothing <- tryPeekMsg q - Just (Message {msgId = mId4}, True) <- writeMsg q True =<< mkMessage "message 4" + Just (Message {msgId = mId4}, True) <- write "message 4" Msg "message 4" <- tryPeekMsg q - Just (Message {msgId = mId5}, False) <- writeMsg q True =<< mkMessage "message 5" + Just (Message {msgId = mId5}, False) <- write "message 5" (Nothing, Msg "message 4") <- tryDelPeekMsg q mId3 (Msg "message 4", Msg "message 5") <- tryDelPeekMsg q mId4 - Just (Message {msgId = mId6}, False) <- writeMsg q True =<< mkMessage "message 6" - Just (Message {msgId = mId7}, False) <- writeMsg q True =<< mkMessage "message 7" - Nothing <- writeMsg q True =<< mkMessage "message 8" + Just (Message {msgId = mId6}, False) <- write "message 6" + Just (Message {msgId = mId7}, False) <- write "message 7" + Nothing <- write "message 8" Msg "message 5" <- tryPeekMsg q (Nothing, Msg "message 5") <- tryDelPeekMsg q mId4 (Msg "message 5", Msg "message 6") <- tryDelPeekMsg q mId5 @@ -115,65 +118,69 @@ testGetQueue st = do (Just MessageQuota {}, Nothing) <- tryDelPeekMsg q mId8 (Nothing, Nothing) <- tryDelPeekMsg q mId8 pure () - delMsgQueue st rId + delMsgQueue ms rId testChangeReadJournal :: MsgStoreClass s => s -> IO () -testChangeReadJournal st = do +testChangeReadJournal ms = do g <- C.newRandom rId <- EntityId <$> atomically (C.randomBytes 24 g) runRight_ $ do - q <- getMsgQueue st rId - Just (Message {msgId = mId1}, True) <- writeMsg q True =<< mkMessage "message 1" + q <- getMsgQueue ms rId + let write s = writeMsg ms q True =<< mkMessage s + Just (Message {msgId = mId1}, True) <- write "message 1" (Msg "message 1", Nothing) <- tryDelPeekMsg q mId1 - Just (Message {msgId = mId2}, True) <- writeMsg q True =<< mkMessage "message 2" + Just (Message {msgId = mId2}, True) <- write "message 2" (Msg "message 2", Nothing) <- tryDelPeekMsg q mId2 - Just (Message {msgId = mId3}, True) <- writeMsg q True =<< mkMessage "message 3" + Just (Message {msgId = mId3}, True) <- write "message 3" (Msg "message 3", Nothing) <- tryDelPeekMsg q mId3 - Just (Message {msgId = mId4}, True) <- writeMsg q True =<< mkMessage "message 4" + Just (Message {msgId = mId4}, True) <- write "message 4" (Msg "message 4", Nothing) <- tryDelPeekMsg q mId4 - Just (Message {msgId = mId5}, True) <- writeMsg q True =<< mkMessage "message 5" + Just (Message {msgId = mId5}, True) <- write "message 5" (Msg "message 5", Nothing) <- tryDelPeekMsg q mId5 pure () - delMsgQueue st rId + delMsgQueue ms rId testExportImportStore :: JournalMsgStore -> IO () -testExportImportStore st = do +testExportImportStore ms = do g <- C.newRandom rId1 <- EntityId <$> atomically (C.randomBytes 24 g) rId2 <- EntityId <$> atomically (C.randomBytes 24 g) runRight_ $ do - q1 <- getMsgQueue st rId1 - Just (Message {}, True) <- writeMsg q1 True =<< mkMessage "message 1" - Just (Message {}, False) <- writeMsg q1 True =<< mkMessage "message 2" - q2 <- getMsgQueue st rId2 - Just (Message {}, True) <- writeMsg q2 True =<< mkMessage "message 3" - Just (Message {}, False) <- writeMsg q2 True =<< mkMessage "message 4" - Just (Message {}, False) <- writeMsg q2 True =<< mkMessage "message 5" - Nothing <- writeMsg q2 True =<< mkMessage "message 6" + let write q s = writeMsg ms q True =<< mkMessage s + q1 <- getMsgQueue ms rId1 + Just (Message {}, True) <- write q1 "message 1" + Just (Message {}, False) <- write q1 "message 2" + q2 <- getMsgQueue ms rId2 + Just (Message {}, True) <- write q2 "message 3" + Just (Message {}, False) <- write q2 "message 4" + Just (Message {}, False) <- write q2 "message 5" + Nothing <- write q2 "message 6" pure () - length <$> listDirectory (msgQueueDirectory st rId1) `shouldReturn` 2 - length <$> listDirectory (msgQueueDirectory st rId2) `shouldReturn` 2 - exportMessages st testStoreMsgsFile $ getQueueMessages False + length <$> listDirectory (msgQueueDirectory ms rId1) `shouldReturn` 2 + length <$> listDirectory (msgQueueDirectory ms rId2) `shouldReturn` 2 + exportMessages ms testStoreMsgsFile $ getQueueMessages False let cfg = (testJournalStoreCfg :: JournalStoreConfig) {storePath = testStoreMsgsDir2} - st' <- newMsgStore cfg - 0 <- importMessages st' testStoreMsgsFile Nothing - length <$> listDirectory (msgQueueDirectory st rId1) `shouldReturn` 2 - length <$> listDirectory (msgQueueDirectory st rId2) `shouldReturn` 3 -- state file is backed up - exportMessages st' testStoreMsgsFile2 $ getQueueMessages False + ms' <- newMsgStore cfg + MessageStats {storedMsgsCount = 6, expiredMsgsCount = 0, storedQueues = 2} <- + importMessages ms' testStoreMsgsFile Nothing + length <$> listDirectory (msgQueueDirectory ms rId1) `shouldReturn` 2 + length <$> listDirectory (msgQueueDirectory ms rId2) `shouldReturn` 3 -- state file is backed up + exportMessages ms' testStoreMsgsFile2 $ getQueueMessages False (B.readFile testStoreMsgsFile2 `shouldReturn`) =<< B.readFile (testStoreMsgsFile <> ".bak") stmStore <- newMsgStore testSMTStoreConfig - 0 <- importMessages stmStore testStoreMsgsFile2 Nothing + MessageStats {storedMsgsCount = 6, expiredMsgsCount = 0, storedQueues = 2} <- + importMessages stmStore testStoreMsgsFile2 Nothing exportMessages stmStore testStoreMsgsFile $ getQueueMessages False (B.sort <$> B.readFile testStoreMsgsFile `shouldReturn`) =<< (B.sort <$> B.readFile (testStoreMsgsFile2 <> ".bak")) testQueueState :: JournalMsgStore -> IO () -testQueueState st = do +testQueueState ms = do g <- C.newRandom rId <- EntityId <$> atomically (C.randomBytes 24 g) - let dir = msgQueueDirectory st rId + let dir = msgQueueDirectory ms rId statePath = dir (queueLogFileName <> logFileExt) createDirectoryIfMissing True dir - state <- newMsgQueueState <$> newJournalId (random st) + state <- newMsgQueueState <$> newJournalId (random ms) withFile statePath WriteMode (`logQueueState` state) length . lines <$> readFile statePath `shouldReturn` 1 readQueueState statePath `shouldReturn` state @@ -208,7 +215,7 @@ testQueueState st = do length . lines <$> readFile statePath `shouldReturn` 1 where readQueueState statePath = do - (state, h) <- readWriteQueueState st statePath + (state, h) <- readWriteQueueState ms statePath hClose h pure state corruptFile f = do From 1484523164445487486ac2372b03808ed01b3dc6 Mon Sep 17 00:00:00 2001 From: Evgeny Date: Tue, 22 Oct 2024 12:09:51 +0100 Subject: [PATCH 3/8] smp server, journal store: check file size on append, validate queue state (#1377) * smp server: journal store queue state validation * validate state on update, refactor * handle message parsing errors * typo * fix test, throw exception when file is smaller than expected * fix * fix test in ghc 8.10.7 --- src/Simplex/Messaging/Server.hs | 12 +- src/Simplex/Messaging/Server/Main.hs | 4 +- .../Messaging/Server/MsgStore/Journal.hs | 198 ++++++++++-------- tests/AgentTests/FunctionalAPITests.hs | 2 +- tests/AgentTests/NotificationTests.hs | 4 +- tests/CoreTests/MsgStoreTests.hs | 24 ++- tests/ServerTests.hs | 22 +- tests/Test.hs | 2 +- 8 files changed, 161 insertions(+), 107 deletions(-) diff --git a/src/Simplex/Messaging/Server.hs b/src/Simplex/Messaging/Server.hs index 214cd0790..efde4e667 100644 --- a/src/Simplex/Messaging/Server.hs +++ b/src/Simplex/Messaging/Server.hs @@ -93,7 +93,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 (JournalMsgQueue (..), closeMsgQueue) +import Simplex.Messaging.Server.MsgStore.Journal (JournalMsgQueue (..), JMQueue (..), closeMsgQueue) import Simplex.Messaging.Server.MsgStore.STM import Simplex.Messaging.Server.MsgStore.Types import Simplex.Messaging.Server.NtfStore @@ -1731,17 +1731,17 @@ saveServerMessages :: Bool -> M () saveServerMessages drainMsgs = asks msgStore >>= \case AMS SMSMemory ms@STMMsgStore {storeConfig = STMStoreConfig {storePath}} -> case storePath of - Just f -> liftIO $ exportMessages ms f $ getQueueMessages drainMsgs + Just f -> liftIO $ exportMessages ms f drainMsgs Nothing -> logInfo "undelivered messages are not saved" AMS SMSJournal _ -> logInfo "closed journal message storage" -exportMessages :: MsgStoreClass s => s -> FilePath -> (MsgQueue s -> IO [Message]) -> IO () -exportMessages ms f getMessages = do +exportMessages :: MsgStoreClass s => s -> FilePath -> Bool -> IO () +exportMessages ms f drainMsgs = do logInfo $ "saving messages to file " <> T.pack f total <- liftIO $ withFile f WriteMode $ \h -> withAllMsgQueues ms (saveQueueMsgs h) 0 logInfo $ "messages saved: " <> tshow total where - saveQueueMsgs h rId q acc = getMessages q >>= \msgs -> (acc + length msgs) <$ BLD.hPutBuilder h (encodeMessages rId msgs) + saveQueueMsgs h rId q acc = getQueueMessages drainMsgs q >>= \msgs -> (acc + length msgs) <$ BLD.hPutBuilder h (encodeMessages rId msgs) encodeMessages rId = mconcat . map (\msg -> BLD.byteString (strEncode $ MLRv3 rId msg) <> BLD.char8 '\n') restoreServerMessages :: M MessageStats @@ -1768,7 +1768,7 @@ restoreServerMessages = do runExceptT expireQueue >>= \case Right (stored', expired') -> pure (stored + stored', expired + expired', qCount + 1) Left e -> do - logInfo $ "failed expiring messages in queue " <> T.pack (queueDirectory q) <> ": " <> tshow e + logInfo $ "failed expiring messages in queue " <> T.pack (queueDirectory $ queue q) <> ": " <> tshow e exitFailure where expireQueue = do diff --git a/src/Simplex/Messaging/Server/Main.hs b/src/Simplex/Messaging/Server/Main.hs index f1f0808fa..5abe0b331 100644 --- a/src/Simplex/Messaging/Server/Main.hs +++ b/src/Simplex/Messaging/Server/Main.hs @@ -44,7 +44,7 @@ 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 (..), getQueueMessages) +import Simplex.Messaging.Server.MsgStore.Journal (JournalStoreConfig (..)) import Simplex.Messaging.Server.MsgStore.Types (AMSType (..), SMSType (..), newMsgStore) import Simplex.Messaging.Transport (batchCmdsSMPVersion, sendingProxySMPVersion, simplexMQVersion, supportedServerSMPRelayVRange) import Simplex.Messaging.Transport.Client (SocksProxy, TransportHost (..), defaultSocksProxy) @@ -115,7 +115,7 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath = ("WARNING: journal directory " <> storeMsgsJournalDir <> " will be exported to message log file " <> storeMsgsFilePath) "Journal not exported" ms <- newJournalMsgStore - exportMessages ms storeMsgsFilePath $ getQueueMessages False + exportMessages ms storeMsgsFilePath False putStrLn "Export completed" putStrLn $ case readMsgStoreType ini of Right (AMSType SMSMemory) -> "store_messages set to `memory`" diff --git a/src/Simplex/Messaging/Server/MsgStore/Journal.hs b/src/Simplex/Messaging/Server/MsgStore/Journal.hs index e0ba446ad..13df614a8 100644 --- a/src/Simplex/Messaging/Server/MsgStore/Journal.hs +++ b/src/Simplex/Messaging/Server/MsgStore/Journal.hs @@ -15,7 +15,8 @@ module Simplex.Messaging.Server.MsgStore.Journal ( JournalMsgStore (msgQueues, random), - JournalMsgQueue (queueDirectory), + JournalMsgQueue (queue), + JMQueue (queueDirectory, statePath), JournalStoreConfig (..), getQueueMessages, closeMsgQueue, @@ -43,6 +44,7 @@ import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Lazy.Char8 as LB import Data.Functor (($>)) +import Data.Int (Int64) import Data.Maybe (catMaybes, fromMaybe) import qualified Data.Text as T import Data.Time.Clock (getCurrentTime) @@ -81,15 +83,20 @@ data JournalStoreConfig = JournalStoreConfig maxStateLines :: Int } -data JournalMsgQueue = JournalMsgQueue +data JMQueue = JMQueue { queueDirectory :: FilePath, queueLock :: Lock, + statePath :: FilePath + } + +data JournalMsgQueue = JournalMsgQueue + { queue :: JMQueue, state :: TVar MsgQueueState, -- tipMsg contains last message and length incl. newline -- Nothing - unknown, Just Nothing - empty queue. -- It prevents reading each message twice, -- and reading it after it was just written. - tipMsg :: TVar (Maybe (Maybe (Message, Int))), + tipMsg :: TVar (Maybe (Maybe (Message, Int64))), handles :: TVar (Maybe MsgQueueHandles) } @@ -112,8 +119,8 @@ data JournalState t = JournalState journalId :: ByteString, msgPos :: Int, msgCount :: Int, - bytePos :: Int, - byteCount :: Int + bytePos :: Int64, + byteCount :: Int64 } deriving (Show) @@ -141,15 +148,7 @@ newMsgQueueState journalId = } newJournalState :: JournalTypeI t => ByteString -> JournalState t -newJournalState journalId = - JournalState - { journalType = sJournalType, - journalId, - msgPos = 0, - msgCount = 0, - bytePos = 0, - byteCount = 0 - } +newJournalState journalId = JournalState sJournalType journalId 0 0 0 0 journalFilePath :: FilePath -> ByteString -> FilePath journalFilePath dir journalId = dir (msgLogFileName <> "." <> B.unpack journalId <> logFileExt) @@ -171,13 +170,16 @@ instance StrEncoding MsgQueueState where instance JournalTypeI t => StrEncoding (JournalState t) where strEncode JournalState {journalId, msgPos, msgCount, bytePos, byteCount} = - B.concat [journalId, ",", strEncodeList [msgPos, msgCount, bytePos, byteCount]] + B.intercalate "," [journalId, e msgPos, e msgCount, e bytePos, e byteCount] + where + e :: StrEncoding a => a -> ByteString + e = strEncode strP = do journalId <- A.takeTill (== ',') - A.char ',' *> strListP >>= \case - [msgPos, msgCount, bytePos, byteCount] -> - pure JournalState {journalType = sJournalType, journalId, msgPos, msgCount, bytePos, byteCount} - _ -> fail "bad JournalState" + JournalState sJournalType journalId <$> i <*> i <*> i <*> i + where + i :: Integral a => A.Parser a + i = A.char ',' *> A.decimal queueLogFileName :: String queueLogFileName = "queue_state" @@ -210,6 +212,8 @@ instance MsgStoreClass JournalMsgStore where -- 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 :: JournalMsgStore -> (RecipientId -> JournalMsgQueue -> a -> IO a) -> a -> IO a withAllMsgQueues ms@JournalMsgStore {config} action res = ifM (doesDirectoryExist storePath) processStore (pure res) where @@ -223,9 +227,11 @@ instance MsgStoreClass JournalMsgStore where putStrLn "" pure res' JournalStoreConfig {storePath, pathParts} = config - processQueue lock count acc (i :: Int, (queueId, dir)) = do + processQueue queueLock count acc (i :: Int, (queueId, dir)) = do when (i `mod` 100 == 0) $ progress i count - q <- openMsgQueue ms dir lock + let statePath = dir queueLogFileName <> "." <> queueId <> logFileExt + queue = JMQueue {queueDirectory = dir, queueLock, statePath} + q <- openMsgQueue ms queue acc' <- case strDecode $ B.pack queueId of Right rId -> action rId q acc Left e -> do @@ -261,18 +267,20 @@ instance MsgStoreClass JournalMsgStore where TM.lookupIO rId msgQueues >>= maybe newQ pure where newQ = do - let dir = msgQueueDirectory ms rId queueLock <- atomically $ getMapLock queueLocks rId - q <- ifM (doesDirectoryExist dir) (openMsgQueue ms dir queueLock) (createQ dir queueLock) + let dir = msgQueueDirectory ms rId + statePath = dir (queueLogFileName <> "." <> B.unpack (strEncode rId) <> logFileExt) + queue = JMQueue {queueDirectory = dir, queueLock, statePath} + q <- ifM (doesDirectoryExist dir) (openMsgQueue ms queue) (createQ queue) atomically $ TM.insert rId q msgQueues pure q where - createQ :: FilePath -> Lock -> IO JournalMsgQueue - createQ dir queueLock = do + createQ :: JMQueue -> IO JournalMsgQueue + createQ queue = do -- folder and files are not created here, -- to avoid file IO for queues without messages during subscription journalId <- newJournalId random - mkJournalQueue dir queueLock (newMsgQueueState journalId, Nothing) + mkJournalQueue queue (newMsgQueueState journalId, Nothing) delMsgQueue :: JournalMsgStore -> RecipientId -> IO () delMsgQueue ms rId = withLockMap (queueLocks ms) rId "delMsgQueue" $ do @@ -292,16 +300,13 @@ instance MsgStoreClass JournalMsgStore where getMsg msgs hs = chooseReadJournal q drainMsgs hs >>= maybe (pure msgs) readMsg where readMsg (rs, h) = do - -- TODO handle errors - s <- hGetLineAt h $ bytePos rs - -- TODO handle errors - Right msg <- pure $ strDecode s - updateReadPos q drainMsgs (B.length s + 1) hs -- 1 is to account for new line + (msg, len) <- hGetMsgAt h $ bytePos rs + updateReadPos q drainMsgs len hs (msg :) <$> getMsg msgs hs writeMsg :: JournalMsgStore -> JournalMsgQueue -> Bool -> Message -> ExceptT ErrorType IO (Maybe (Message, Bool)) - writeMsg ms q@JournalMsgQueue {queueDirectory, handles} logState !msg = - tryStore "writeMsg" $ withLock' (queueLock q) "writeMsg" $ do + writeMsg ms q@JournalMsgQueue {queue = JMQueue {queueDirectory, queueLock, statePath}, handles} logState !msg = + tryStore "writeMsg" $ withLock' queueLock "writeMsg" $ do st@MsgQueueState {canWrite, size} <- readTVarIO (state q) let empty = size == 0 if canWrite || empty @@ -316,22 +321,22 @@ instance MsgStoreClass JournalMsgStore where msgQuota = MessageQuota {msgId = msgId msg, msgTs = msgTs msg} writeToJournal st@MsgQueueState {writeState, readState = rs, size} canWrt' msg' = do let msgStr = strEncode msg' `B.snoc` '\n' - msgLen = B.length msgStr + msgLen = fromIntegral $ B.length msgStr hs <- maybe createQueueDir pure =<< readTVarIO handles (ws, wh) <- case writeHandle hs of Nothing | msgCount writeState >= maxMsgCount -> switchWriteJournal hs wh_ -> pure (writeState, fromMaybe (readHandle hs) wh_) - let msgCount' = msgCount ws + 1 - ws' = ws {msgPos = msgPos ws + 1, msgCount = msgCount', bytePos = bytePos ws + msgLen} - rs' = if journalId ws == journalId rs then rs {msgCount = msgCount'} else rs + let msgPos' = msgPos ws + 1 + bytePos' = bytePos ws + msgLen + ws' = ws {msgPos = msgPos', msgCount = msgPos', bytePos = bytePos', byteCount = bytePos'} + rs' = if journalId ws == journalId rs then rs {msgCount = msgPos', byteCount = bytePos'} else rs !st' = st {writeState = ws', readState = rs', canWrite = canWrt', size = size + 1} when (size == 0) $ atomically $ writeTVar (tipMsg q) $ Just (Just (msg, msgLen)) - hAppend wh msgStr + hAppend wh (bytePos ws) msgStr updateQueueState q logState hs st' where createQueueDir = do createDirectoryIfMissing True queueDirectory - let statePath = queueDirectory (queueLogFileName <> logFileExt) sh <- openFile statePath AppendMode B.hPutStr sh "" rh <- createNewJournal queueDirectory $ journalId rs @@ -354,11 +359,8 @@ instance MsgStoreClass JournalMsgStore where peekMsg (rs, h) = readTVarIO tipMsg >>= maybe readMsg (pure . fmap fst) where readMsg = do - -- TODO handle errors - s <- hGetLineAt h $ bytePos rs - -- TODO handle errors - Right msg <- pure $ strDecode s - atomically $ writeTVar tipMsg $ Just (Just (msg, B.length s + 1)) -- 1 is to account for new line + ml@(msg, _) <- hGetMsgAt h $ bytePos rs + atomically $ writeTVar tipMsg $ Just (Just ml) pure $ Just msg tryDeleteMsg_ :: JournalMsgQueue -> StoreIO () @@ -370,7 +372,7 @@ instance MsgStoreClass JournalMsgStore where $>>= \hs -> updateReadPos q True len hs $> Just () isolateQueue :: JournalMsgQueue -> String -> StoreIO a -> ExceptT ErrorType IO a - isolateQueue mq op (StoreIO a) = tryStore op $ withLock' (queueLock mq) op $ a + isolateQueue q op (StoreIO a) = tryStore op $ withLock' (queueLock $ queue q) op $ a tryStore :: String -> IO a -> ExceptT ErrorType IO a tryStore op a = @@ -379,29 +381,21 @@ tryStore op a = let e' = op <> " " <> show e in logError ("STORE ERROR " <> T.pack e') $> Left (STORE e') -openMsgQueue :: JournalMsgStore -> FilePath -> Lock -> IO JournalMsgQueue -openMsgQueue ms dir queueLock = do - let statePath = dir (queueLogFileName <> logFileExt) +openMsgQueue :: JournalMsgStore -> JMQueue -> IO JournalMsgQueue +openMsgQueue ms q@JMQueue {queueDirectory = dir, statePath} = do (st, sh) <- readWriteQueueState ms statePath (st', rh, wh_) <- openJournals dir st let hs = MsgQueueHandles {stateHandle = sh, readHandle = rh, writeHandle = wh_} - mkJournalQueue dir queueLock (st', Just hs) + mkJournalQueue q (st', Just hs) -mkJournalQueue :: FilePath -> Lock -> (MsgQueueState, Maybe MsgQueueHandles) -> IO JournalMsgQueue -mkJournalQueue dir queueLock (st, hs_) = do +mkJournalQueue :: JMQueue -> (MsgQueueState, Maybe MsgQueueHandles) -> IO JournalMsgQueue +mkJournalQueue queue (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 - { queueDirectory = dir, - queueLock, - state, - tipMsg, - handles - } + pure JournalMsgQueue {queue, state, tipMsg, handles} chooseReadJournal :: JournalMsgQueue -> Bool -> MsgQueueHandles -> IO (Maybe (JournalState 'JTRead, Handle)) chooseReadJournal q log' hs = do @@ -411,8 +405,8 @@ chooseReadJournal q log' hs = do -- switching to write journal atomically $ writeTVar (handles q) $ Just hs {readHandle = wh, writeHandle = Nothing} hClose $ readHandle hs - removeJournal (queueDirectory q) rs - let !rs' = (newJournalState $ journalId ws) {msgCount = msgCount ws} + removeJournal (queueDirectory $ queue q) rs + let !rs' = (newJournalState $ journalId ws) {msgCount = msgCount ws, byteCount = byteCount ws} !st' = st {readState = rs'} updateQueueState q log' hs st' pure $ Just (rs', wh) @@ -421,13 +415,14 @@ chooseReadJournal q log' hs = do updateQueueState :: JournalMsgQueue -> Bool -> MsgQueueHandles -> MsgQueueState -> IO () updateQueueState q log' hs st = do + unless (validQueueState st) $ E.throwIO $ userError $ "updating to invalid state: " <> show st when log' $ logQueueState (stateHandle hs) st atomically $ writeTVar (state q) st logQueueState :: Handle -> MsgQueueState -> IO () logQueueState h st = B.hPutStr h $ strEncode st `B.snoc` '\n' -updateReadPos :: JournalMsgQueue -> Bool -> Int -> MsgQueueHandles -> IO () +updateReadPos :: JournalMsgQueue -> Bool -> Int64 -> MsgQueueHandles -> IO () updateReadPos q log' len hs = do st@MsgQueueState {readState = rs, size} <- readTVarIO (state q) let JournalState {msgPos, bytePos} = rs @@ -471,32 +466,39 @@ openJournals dir st@MsgQueueState {readState = rs, writeState = ws} = do pure (st', rh, Nothing) Right rh | rjId == wjId -> do - st' <- fixWriteFileSize rh - pure (st', rh, Nothing) - | otherwise -> + fixFileSize rh $ bytePos ws + pure (st, rh, Nothing) + | otherwise -> do + fixFileSize rh $ byteCount rs openJournal ws >>= \case Left path -> do logError $ "STORE ERROR no write file " <> T.pack path <> ", creating new file" wh <- createNewJournal dir wjId - let size' = msgCount rs + msgPos rs + let size' = msgCount rs - msgPos rs st' = st {writeState = newJournalState wjId, size = size'} -- we don't amend canWrite to trigger QCONT pure (st', rh, Just wh) Right wh -> do - st' <- fixWriteFileSize wh - pure (st', rh, Just wh) + fixFileSize wh $ bytePos ws + pure (st, rh, Just wh) where openJournal :: JournalState t -> IO (Either FilePath Handle) openJournal JournalState {journalId} = let path = journalFilePath dir journalId in ifM (doesFileExist path) (Right <$> openFile path ReadWriteMode) (pure $ Left path) -- do that for all append operations - fixWriteFileSize h = do - let sz = fromIntegral $ bytePos ws - sz' <- IO.hFileSize h - if - | sz' > sz -> logWarn "STORE WARNING" >> IO.hSetFileSize h sz $> st - | sz' == sz -> pure st - | otherwise -> pure st -- TODO re-read file to recover what is possible ??? + +fixFileSize :: Handle -> Int64 -> IO () +fixFileSize h pos = do + let pos' = fromIntegral pos + size <- IO.hFileSize h + if + | size > pos' -> do + logWarn $ "STORE WARNING truncating file size from " <> tshow size <> " to " <> tshow pos + IO.hSetFileSize h pos' + | size < pos' -> + -- From code logic this can't happen. + E.throwIO $ userError $ "file size " <> show size <> " is smaller than position " <> show pos + | otherwise -> pure () removeJournal :: FilePath -> JournalState t -> IO () removeJournal dir JournalState {journalId} = do @@ -517,7 +519,10 @@ readWriteQueueState JournalMsgStore {random, config} statePath = ls <- LB.lines <$> LB.readFile statePath case ls of [] -> writeNewQueueState - _ -> useLastLine (length ls) True ls + _ -> do + r@(st, _) <- useLastLine (length ls) True ls + unless (validQueueState st) $ E.throwIO $ userError $ "read invalid invalid: " <> show st + pure r writeNewQueueState = do logWarn $ "STORE WARNING: empty queue state in " <> T.pack statePath <> ", initialized" st <- newMsgQueueState <$> newJournalId random @@ -539,9 +544,7 @@ readWriteQueueState JournalMsgStore {random, config} statePath = ls' -> do logWarn $ "STORE WARNING: invalid last line in queue state " <> T.pack statePath <> ", using the previous line" useLastLine len False ls' - | otherwise -> do - logError $ "STORE ERROR invalid queue state in " <> T.pack statePath <> ": " <> tshow e - E.throwIO $ userError $ "Error reading queue state " <> statePath <> ": " <> show e + | otherwise -> E.throwIO $ userError $ "reading queue state " <> statePath <> ": " <> show e backupWriteQueueState st = do -- State backup is made in two steps to mitigate the crash during the backup. -- Temporary backup file will be used when it is present. @@ -555,6 +558,25 @@ readWriteQueueState JournalMsgStore {random, config} statePath = logQueueState sh st pure (st, sh) +validQueueState :: MsgQueueState -> Bool +validQueueState MsgQueueState {readState = rs, writeState = ws, size} + | journalId rs == journalId ws = + alwaysValid + && msgPos rs <= msgPos ws + && msgCount rs == msgCount ws + && bytePos rs <= bytePos ws + && byteCount rs == byteCount ws + && size == msgCount rs - msgPos rs + | otherwise = + alwaysValid + && size == msgCount ws + msgCount rs - msgPos rs + where + alwaysValid = + msgPos rs <= msgCount rs + && bytePos rs <= byteCount rs + && msgPos ws == msgCount ws + && bytePos ws == byteCount ws + deleteMsgQueue_ :: JournalMsgStore -> RecipientId -> IO (Maybe (TVar MsgQueueState)) deleteMsgQueue_ st rId = atomically (TM.lookupDelete rId (msgQueues st)) @@ -573,11 +595,21 @@ removeQueueDirectory st rId = let dir = msgQueueDirectory st rId in removePathForcibly dir `catchAny` (\e -> logError $ "STORE ERROR removeQueueDirectory " <> T.pack dir <> ": " <> tshow e) -hAppend :: Handle -> ByteString -> IO () -hAppend h s = IO.hSeek h SeekFromEnd 0 >> B.hPutStr h s +hAppend :: Handle -> Int64 -> ByteString -> IO () +hAppend h pos s = do + fixFileSize h pos + IO.hSeek h SeekFromEnd 0 + B.hPutStr h s -hGetLineAt :: Handle -> Int -> IO ByteString -hGetLineAt h pos = IO.hSeek h AbsoluteSeek (fromIntegral pos) >> B.hGetLine h +hGetMsgAt :: Handle -> Int64 -> IO (Message, Int64) +hGetMsgAt h pos = do + IO.hSeek h AbsoluteSeek $ fromIntegral pos + s <- B.hGetLine h + case strDecode s of + Right !msg -> + let !len = fromIntegral (B.length s) + 1 + in pure (msg, len) + Left e -> E.throwIO $ userError $ "Error parsing message: " <> e openFile :: FilePath -> IOMode -> IO Handle openFile f mode = do diff --git a/tests/AgentTests/FunctionalAPITests.hs b/tests/AgentTests/FunctionalAPITests.hs index 425e93f29..646edb4fa 100644 --- a/tests/AgentTests/FunctionalAPITests.hs +++ b/tests/AgentTests/FunctionalAPITests.hs @@ -1946,7 +1946,7 @@ testBatchedSubscriptions nCreate nDel t = runServers :: ExceptT AgentErrorType IO a -> IO a runServers a = do withSmpServerStoreLogOn t testPort $ \t1 -> do - res <- withSmpServerConfigOn t cfg {storeLogFile = Just testStoreLogFile2} testPort2 $ \t2 -> + res <- withSmpServerConfigOn t cfg {storeLogFile = Just testStoreLogFile2, storeMsgsFile = Just testStoreMsgsDir2} testPort2 $ \t2 -> runRight a `finally` killThread t2 killThread t1 pure res diff --git a/tests/AgentTests/NotificationTests.hs b/tests/AgentTests/NotificationTests.hs index 272c6d6d6..37b490f0d 100644 --- a/tests/AgentTests/NotificationTests.hs +++ b/tests/AgentTests/NotificationTests.hs @@ -54,7 +54,7 @@ import Data.Text.Encoding (encodeUtf8) import Database.SQLite.Simple.QQ (sql) import NtfClient import SMPAgentClient (agentCfg, initAgentServers, initAgentServers2, testDB, testDB2, testNtfServer, testNtfServer2) -import SMPClient (cfg, cfgVPrev, testPort, testPort2, testStoreLogFile2, withSmpServer, withSmpServerConfigOn, withSmpServerStoreLogOn, withSmpServerStoreMsgLogOn) +import SMPClient (cfg, cfgVPrev, testPort, testPort2, testStoreLogFile2, testStoreMsgsDir2, withSmpServer, withSmpServerConfigOn, withSmpServerStoreLogOn, withSmpServerStoreMsgLogOn) import Simplex.Messaging.Agent hiding (createConnection, joinConnection, sendMessage) import Simplex.Messaging.Agent.Client (ProtocolTestFailure (..), ProtocolTestStep (..), withStore') import Simplex.Messaging.Agent.Env.SQLite (AgentConfig, Env (..), InitialAgentServers) @@ -785,7 +785,7 @@ testNotificationsSMPRestartBatch n t apns = runServers :: ExceptT AgentErrorType IO a -> IO a runServers a = do withSmpServerStoreLogOn t testPort $ \t1 -> do - res <- withSmpServerConfigOn t (cfg :: ServerConfig) {storeLogFile = Just testStoreLogFile2} testPort2 $ \t2 -> + res <- withSmpServerConfigOn t (cfg :: ServerConfig) {storeLogFile = Just testStoreLogFile2, storeMsgsFile = Just testStoreMsgsDir2} testPort2 $ \t2 -> runRight a `finally` killThread t2 killThread t1 pure res diff --git a/tests/CoreTests/MsgStoreTests.hs b/tests/CoreTests/MsgStoreTests.hs index dd54b1e33..c3344bfa6 100644 --- a/tests/CoreTests/MsgStoreTests.hs +++ b/tests/CoreTests/MsgStoreTests.hs @@ -1,5 +1,6 @@ {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-} @@ -22,6 +23,7 @@ import Simplex.Messaging.Crypto (pattern MaxLenBS) import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Protocol (EntityId (..), Message (..), noMsgFlags) import Simplex.Messaging.Server (MessageStats (..), exportMessages, importMessages) +import Simplex.Messaging.Server.Env.STM (journalMsgStoreDepth) import Simplex.Messaging.Server.MsgStore.Journal import Simplex.Messaging.Server.MsgStore.STM import Simplex.Messaging.Server.MsgStore.Types @@ -55,7 +57,7 @@ testJournalStoreCfg :: JournalStoreConfig testJournalStoreCfg = JournalStoreConfig { storePath = testStoreMsgsDir, - pathParts = 4, + pathParts = journalMsgStoreDepth, quota = 3, maxMsgCount = 4, maxStateLines = 2 @@ -158,19 +160,19 @@ testExportImportStore ms = do pure () length <$> listDirectory (msgQueueDirectory ms rId1) `shouldReturn` 2 length <$> listDirectory (msgQueueDirectory ms rId2) `shouldReturn` 2 - exportMessages ms testStoreMsgsFile $ getQueueMessages False + exportMessages ms testStoreMsgsFile False let cfg = (testJournalStoreCfg :: JournalStoreConfig) {storePath = testStoreMsgsDir2} ms' <- newMsgStore cfg MessageStats {storedMsgsCount = 6, expiredMsgsCount = 0, storedQueues = 2} <- importMessages ms' testStoreMsgsFile Nothing length <$> listDirectory (msgQueueDirectory ms rId1) `shouldReturn` 2 length <$> listDirectory (msgQueueDirectory ms rId2) `shouldReturn` 3 -- state file is backed up - exportMessages ms' testStoreMsgsFile2 $ getQueueMessages False + exportMessages ms' testStoreMsgsFile2 False (B.readFile testStoreMsgsFile2 `shouldReturn`) =<< B.readFile (testStoreMsgsFile <> ".bak") stmStore <- newMsgStore testSMTStoreConfig MessageStats {storedMsgsCount = 6, expiredMsgsCount = 0, storedQueues = 2} <- importMessages stmStore testStoreMsgsFile2 Nothing - exportMessages stmStore testStoreMsgsFile $ getQueueMessages False + exportMessages stmStore testStoreMsgsFile False (B.sort <$> B.readFile testStoreMsgsFile `shouldReturn`) =<< (B.sort <$> B.readFile (testStoreMsgsFile2 <> ".bak")) testQueueState :: JournalMsgStore -> IO () @@ -186,13 +188,23 @@ testQueueState ms = do readQueueState statePath `shouldReturn` state length <$> listDirectory dir `shouldReturn` 1 -- no backup - let state1 = state {size = 1, writeState = (writeState state) {msgPos = 1, msgCount = 1, bytePos = 100}} + let state1 = + state + { size = 1, + readState = (readState state) {msgCount = 1, byteCount = 100}, + writeState = (writeState state) {msgPos = 1, msgCount = 1, bytePos = 100, byteCount = 100} + } withFile statePath AppendMode (`logQueueState` state1) length . lines <$> readFile statePath `shouldReturn` 2 readQueueState statePath `shouldReturn` state1 length <$> listDirectory dir `shouldReturn` 1 -- no backup - let state2 = state {size = 2, writeState = (writeState state) {msgPos = 2, msgCount = 2, bytePos = 200}} + let state2 = + state + { size = 2, + readState = (readState state) {msgCount = 2, byteCount = 200}, + writeState = (writeState state) {msgPos = 2, msgCount = 2, bytePos = 200, byteCount = 200} + } withFile statePath AppendMode (`logQueueState` state2) length . lines <$> readFile statePath `shouldReturn` 3 copyFile statePath (statePath <> ".2") diff --git a/tests/ServerTests.hs b/tests/ServerTests.hs index 38db97f3f..965967878 100644 --- a/tests/ServerTests.hs +++ b/tests/ServerTests.hs @@ -16,6 +16,7 @@ module ServerTests where import AgentTests.NotificationTests (removeFileIfExists) +import CoreTests.MsgStoreTests (testJournalStoreCfg) import Control.Concurrent (ThreadId, killThread, threadDelay) import Control.Concurrent.STM import Control.Exception (SomeException, try) @@ -35,9 +36,11 @@ import Simplex.Messaging.Encoding import Simplex.Messaging.Encoding.String import Simplex.Messaging.Parsers (parseAll) import Simplex.Messaging.Protocol +import Simplex.Messaging.Server (exportMessages) import Simplex.Messaging.Server.Env.STM (ServerConfig (..)) import Simplex.Messaging.Server.Expiration -import Simplex.Messaging.Server.MsgStore.Types (AMSType (..), SMSType (..)) +import Simplex.Messaging.Server.MsgStore.Journal (JournalStoreConfig (..)) +import Simplex.Messaging.Server.MsgStore.Types (AMSType (..), SMSType (..), newMsgStore) import Simplex.Messaging.Server.Stats (PeriodStatsData (..), ServerStatsData (..)) import Simplex.Messaging.Transport import Simplex.Messaging.Util (whenM) @@ -66,8 +69,8 @@ serverTests t@(ATransport t') = do describe "GET & SUB commands" $ testGetSubCommands t' describe "Exceeding queue quota" $ testExceedQueueQuota t' describe "Store log" $ testWithStoreLog t - xdescribe "Restore messages" $ testRestoreMessages t - xdescribe "Restore messages (old / v2)" $ testRestoreExpireMessages t + describe "Restore messages" $ testRestoreMessages t + describe "Restore messages (old / v2)" $ testRestoreExpireMessages t describe "Timing of AUTH error" $ testTiming t describe "Message notifications" $ testMessageNotifications t describe "Message expiration" $ do @@ -780,6 +783,7 @@ testRestoreExpireMessages at@(ATransport t) = pure () logSize testStoreLogFile `shouldReturn` 2 + exportStoreMessages msgs <- B.readFile testStoreMsgsFile length (B.lines msgs) `shouldBe` 4 @@ -788,6 +792,7 @@ testRestoreExpireMessages at@(ATransport t) = withSmpServerConfigOn at cfg1 testPort . runTest t $ \_ -> pure () logSize testStoreLogFile `shouldReturn` 1 + exportStoreMessages msgs' <- B.readFile testStoreMsgsFile msgs' `shouldBe` msgs @@ -797,12 +802,17 @@ testRestoreExpireMessages at@(ATransport t) = logSize testStoreLogFile `shouldReturn` 1 -- two messages expired - -- msgs'' <- B.readFile testStoreMsgsFile - -- length (B.lines msgs'') `shouldBe` 2 - -- B.lines msgs'' `shouldBe` drop 2 (B.lines msgs) + exportStoreMessages + msgs'' <- B.readFile testStoreMsgsFile + length (B.lines msgs'') `shouldBe` 2 + B.lines msgs'' `shouldBe` drop 2 (B.lines msgs) Right ServerStatsData {_msgExpired} <- strDecode <$> B.readFile testServerStatsBackupFile _msgExpired `shouldBe` 2 where + exportStoreMessages = do + ms <- newMsgStore testJournalStoreCfg {quota = 4} + removeFileIfExists testStoreMsgsFile + exportMessages ms testStoreMsgsFile False runTest :: Transport c => TProxy c -> (THandleSMP c 'TClient -> IO ()) -> ThreadId -> Expectation runTest _ test' server = do testSMPClient test' `shouldReturn` () diff --git a/tests/Test.hs b/tests/Test.hs index 89672cd4f..6ae4edb41 100644 --- a/tests/Test.hs +++ b/tests/Test.hs @@ -61,7 +61,7 @@ main = do describe "TRcvQueues tests" tRcvQueuesTests describe "Util tests" utilTests describe "SMP server via TLS" $ serverTests (transport @TLS) - describe "SMP server via WebSockets" $ serverTests (transport @WS) + xdescribe "SMP server via WebSockets" $ serverTests (transport @WS) describe "Notifications server" $ ntfServerTests (transport @TLS) describe "SMP client agent" $ agentTests (transport @TLS) describe "SMP proxy" smpProxyTests From c9c075fd49689649a63273d27de1317421663c79 Mon Sep 17 00:00:00 2001 From: Evgeny Date: Wed, 23 Oct 2024 09:17:23 +0100 Subject: [PATCH 4/8] smp server: merge quota messages and set queue to "over quota" state after restoring, server tests with journal and memory store (#1380) * smp: run server tests with journal and memory store * merge quota messages, set queue to "over quota" state after restoring * fix test --- src/Simplex/Messaging/Server.hs | 61 +++-- .../Messaging/Server/MsgStore/Journal.hs | 33 +-- src/Simplex/Messaging/Server/MsgStore/STM.hs | 13 +- .../Messaging/Server/MsgStore/Types.hs | 14 +- tests/CoreTests/MsgStoreTests.hs | 13 +- tests/NtfServerTests.hs | 2 +- tests/SMPClient.hs | 64 ++--- tests/ServerTests.hs | 228 +++++++++--------- tests/Test.hs | 13 +- 9 files changed, 243 insertions(+), 198 deletions(-) diff --git a/src/Simplex/Messaging/Server.hs b/src/Simplex/Messaging/Server.hs index efde4e667..0574b9387 100644 --- a/src/Simplex/Messaging/Server.hs +++ b/src/Simplex/Messaging/Server.hs @@ -155,7 +155,7 @@ smpServer :: TMVar Bool -> ServerConfig -> Maybe AttachHTTP -> M () smpServer started cfg@ServerConfig {transports, transportConfig = tCfg} attachHTTP_ = do s <- asks server pa <- asks proxyAgent - msgStats <- restoreServerMessages + msgStats <- processServerMessages ntfStats <- restoreServerNtfs liftIO $ printMessageStats "messages" msgStats liftIO $ printMessageStats "notifications" ntfStats @@ -215,8 +215,6 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg} attachHT saveServer :: Bool -> M () saveServer drainMsgs = do withLog closeStoreLog - AMS _ ms <- asks msgStore - liftIO $ closeMsgStore ms saveServerMessages drainMsgs saveServerNtfs saveServerStats @@ -383,7 +381,7 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg} attachHT void $ withActiveMsgQueues ms (\_ -> expireQueueMsgs stats old) 0 where expireQueueMsgs stats old q acc = - runExceptT (deleteExpiredMsgs q old) >>= \case + runExceptT (deleteExpiredMsgs q True old) >>= \case Right deleted -> (acc + deleted) <$ atomicModifyIORef'_ (msgExpired stats) (+ deleted) Left _ -> pure 0 @@ -1476,7 +1474,7 @@ client thParams' clnt@Client {clientId, subscriptions, ntfSubscriptions, rcvQ, s expireMessages :: MsgStoreClass s => MsgQueue s -> Maybe ExpirationConfig -> ServerStats -> ExceptT ErrorType IO () expireMessages q msgExp stats = do - deleted <- maybe (pure 0) (deleteExpiredMsgs q <=< liftIO . expireBeforeEpoch) msgExp + deleted <- maybe (pure 0) (deleteExpiredMsgs q True <=< liftIO . expireBeforeEpoch) msgExp liftIO $ when (deleted > 0) $ atomicModifyIORef'_ (msgExpired stats) (+ deleted) -- The condition for delivery of the message is: @@ -1733,7 +1731,9 @@ saveServerMessages drainMsgs = AMS SMSMemory ms@STMMsgStore {storeConfig = STMStoreConfig {storePath}} -> case storePath of Just f -> liftIO $ exportMessages ms f drainMsgs Nothing -> logInfo "undelivered messages are not saved" - AMS SMSJournal _ -> logInfo "closed journal message storage" + AMS SMSJournal ms -> do + liftIO $ closeMsgStore ms + logInfo "closed journal message storage" exportMessages :: MsgStoreClass s => s -> FilePath -> Bool -> IO () exportMessages ms f drainMsgs = do @@ -1744,8 +1744,8 @@ exportMessages ms f drainMsgs = do saveQueueMsgs h rId q acc = getQueueMessages drainMsgs q >>= \msgs -> (acc + length msgs) <$ BLD.hPutBuilder h (encodeMessages rId msgs) encodeMessages rId = mconcat . map (\msg -> BLD.byteString (strEncode $ MLRv3 rId msg) <> BLD.char8 '\n') -restoreServerMessages :: M MessageStats -restoreServerMessages = do +processServerMessages :: M MessageStats +processServerMessages = do old_ <- asks (messageExpiration . config) $>>= (liftIO . fmap Just . expireBeforeEpoch) asks msgStore >>= liftIO . processMessages old_ where @@ -1772,23 +1772,25 @@ restoreServerMessages = do exitFailure where expireQueue = do - expired'' <- deleteExpiredMsgs q old + expired'' <- deleteExpiredMsgs q False old stored'' <- liftIO $ getQueueSize q + liftIO $ logQueueState q liftIO $ closeMsgQueue q pure (stored'', expired'') processValidateQueue q (!stored, !qCount) = getQueueSize q >>= \stored' -> pure (stored + stored', qCount + 1) -importMessages :: MsgStoreClass s => s -> FilePath -> Maybe Int64 -> IO MessageStats +importMessages :: forall s. MsgStoreClass s => s -> FilePath -> Maybe Int64 -> IO MessageStats importMessages ms f old_ = do logInfo $ "restoring messages from file " <> T.pack f - LB.readFile f >>= runExceptT . foldM restoreMsg (0, 0, 0) . zip [0..] . LB.lines >>= \case + LB.readFile f >>= runExceptT . foldM restoreMsg (0, Nothing, (0, 0, M.empty)) . zip [0..] . LB.lines >>= \case Left e -> do putStrLn "" logError . T.pack $ "error restoring messages: " <> e liftIO exitFailure - Right (lineCount, storedMsgsCount, expiredMsgsCount) -> do + Right (lineCount, _, (storedMsgsCount, expiredMsgsCount, overQuota)) -> do putStrLn $ "Processed " <> show lineCount <> " lines" renameFile f $ f <> ".bak" + mapM_ setOverQuota_ overQuota logQueueStates ms storedQueues <- M.size <$> readTVarIO (activeMsgQueues ms) pure MessageStats {storedMsgsCount, expiredMsgsCount, storedQueues} @@ -1796,24 +1798,37 @@ importMessages ms f old_ = do progress i = do liftIO $ putStr $ "Processed " <> show i <> " lines\r" hFlush stdout - restoreMsg :: (Int, Int, Int) -> (Int, LB.ByteString) -> ExceptT String IO (Int, Int, Int) - restoreMsg (!lineCount, !stored, !expired) (i, s') = do + restoreMsg :: (Int, Maybe (RecipientId, MsgQueue s), (Int, Int, M.Map RecipientId (MsgQueue s))) -> (Int, LB.ByteString) -> ExceptT String IO (Int, Maybe (RecipientId, MsgQueue s), (Int, Int, M.Map RecipientId (MsgQueue s))) + restoreMsg (!lineCount, q_, (!stored, !expired, !overQuota)) (i, s') = do when (i `mod` 1000 == 0) $ progress i MLRv3 rId msg <- liftEither . first (msgErr "parsing") $ strDecode s liftError show $ addToMsgQueue rId msg where s = LB.toStrict s' addToMsgQueue rId msg = do - q <- getMsgQueue ms rId - (isExpired, logFull) <- case msg of + q <- case q_ of + -- to avoid lookup when restoring the next message to the same queue + Just (rId', q') | rId' == rId -> pure q' + _ -> getMsgQueue ms rId + (lineCount + 1,Just (rId, q),) <$> case msg of Message {msgTs} - | maybe True (systemSeconds msgTs >=) old_ -> (False,) . isNothing <$> writeMsg ms q False msg - | otherwise -> pure (True, False) - MessageQuota {} -> writeMsg ms q False msg $> (False, False) - when logFull . logError . decodeLatin1 $ "message queue " <> strEncode rId <> " is full, message not restored: " <> strEncode (messageId msg) - let !stored' = if logFull || isExpired then stored else stored + 1 - !expired' = if isExpired then expired + 1 else expired - pure (lineCount + 1, stored', expired') + | maybe True (systemSeconds msgTs >=) old_ -> do + 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) + pure (stored, expired, overQuota) + | otherwise -> pure (stored, expired + 1, overQuota) + MessageQuota {} -> + -- queue was over quota at some point, + -- it will be set as over quota once fully imported + 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 = isolateQueue q "mergeQuotaMsgs" $ + tryPeekMsg_ q >>= \case + Just MessageQuota {} -> tryDeleteMsg_ q False + _ -> pure () msgErr :: Show e => String -> e -> String msgErr op e = op <> " error (" <> show e <> "): " <> B.unpack (B.take 100 s) diff --git a/src/Simplex/Messaging/Server/MsgStore/Journal.hs b/src/Simplex/Messaging/Server/MsgStore/Journal.hs index 13df614a8..564a9a804 100644 --- a/src/Simplex/Messaging/Server/MsgStore/Journal.hs +++ b/src/Simplex/Messaging/Server/MsgStore/Journal.hs @@ -28,7 +28,7 @@ module Simplex.Messaging.Server.MsgStore.Journal readWriteQueueState, newMsgQueueState, newJournalId, - logQueueState, + appendState, queueLogFileName, logFileExt, ) @@ -255,11 +255,12 @@ instance MsgStoreClass JournalMsgStore where (Nothing <$ putStrLn ("Error: path " <> path' <> " is not a directory, skipping")) logQueueStates :: JournalMsgStore -> IO () - logQueueStates st = withActiveMsgQueues st (\_ q _ -> logState q) () - where - logState q = - readTVarIO (handles q) - >>= maybe (pure ()) (\hs -> readTVarIO (state q) >>= logQueueState (stateHandle hs)) + logQueueStates ms = withActiveMsgQueues ms (\_ q _ -> logQueueState q) () + + logQueueState :: JournalMsgQueue -> IO () + logQueueState q = + readTVarIO (handles q) + >>= maybe (pure ()) (\hs -> readTVarIO (state q) >>= appendState (stateHandle hs)) getMsgQueue :: JournalMsgStore -> RecipientId -> ExceptT ErrorType IO JournalMsgQueue getMsgQueue ms@JournalMsgStore {queueLocks, msgQueues, random} rId = @@ -318,7 +319,7 @@ instance MsgStoreClass JournalMsgStore where else pure Nothing where JournalStoreConfig {quota, maxMsgCount} = config ms - msgQuota = MessageQuota {msgId = msgId msg, msgTs = msgTs msg} + !msgQuota = MessageQuota {msgId = msgId msg, msgTs = msgTs msg} writeToJournal st@MsgQueueState {writeState, readState = rs, size} canWrt' msg' = do let msgStr = strEncode msg' `B.snoc` '\n' msgLen = fromIntegral $ B.length msgStr @@ -349,6 +350,10 @@ instance MsgStoreClass JournalMsgStore where atomically $ writeTVar handles $ Just $ hs {writeHandle = Just wh} pure (newJournalState journalId, wh) + -- can ONLY be used while restoring messages, not while server running + setOverQuota_ :: JournalMsgQueue -> IO () + setOverQuota_ JournalMsgQueue {state} = atomically $ modifyTVar' state $ \st -> st {canWrite = False} + getQueueSize :: JournalMsgQueue -> IO Int getQueueSize JournalMsgQueue {state} = size <$> readTVarIO state @@ -363,13 +368,13 @@ instance MsgStoreClass JournalMsgStore where atomically $ writeTVar tipMsg $ Just (Just ml) pure $ Just msg - tryDeleteMsg_ :: JournalMsgQueue -> StoreIO () - tryDeleteMsg_ q@JournalMsgQueue {tipMsg, handles} = StoreIO $ + tryDeleteMsg_ :: JournalMsgQueue -> Bool -> StoreIO () + tryDeleteMsg_ q@JournalMsgQueue {tipMsg, handles} logState = StoreIO $ void $ readTVarIO tipMsg -- if there is no cached tipMsg, do nothing $>>= (pure . fmap snd) $>>= \len -> readTVarIO handles - $>>= \hs -> updateReadPos q True len hs $> Just () + $>>= \hs -> updateReadPos q logState len hs $> Just () isolateQueue :: JournalMsgQueue -> String -> StoreIO a -> ExceptT ErrorType IO a isolateQueue q op (StoreIO a) = tryStore op $ withLock' (queueLock $ queue q) op $ a @@ -416,11 +421,11 @@ chooseReadJournal q log' hs = do updateQueueState :: JournalMsgQueue -> Bool -> MsgQueueHandles -> MsgQueueState -> IO () updateQueueState q log' hs st = do unless (validQueueState st) $ E.throwIO $ userError $ "updating to invalid state: " <> show st - when log' $ logQueueState (stateHandle hs) st + when log' $ appendState (stateHandle hs) st atomically $ writeTVar (state q) st -logQueueState :: Handle -> MsgQueueState -> IO () -logQueueState h st = B.hPutStr h $ strEncode st `B.snoc` '\n' +appendState :: Handle -> MsgQueueState -> IO () +appendState h st = B.hPutStr h $ strEncode st `B.snoc` '\n' updateReadPos :: JournalMsgQueue -> Bool -> Int64 -> MsgQueueHandles -> IO () updateReadPos q log' len hs = do @@ -555,7 +560,7 @@ readWriteQueueState JournalMsgStore {random, config} statePath = pure r writeQueueState st = do sh <- openFile statePath AppendMode - logQueueState sh st + appendState sh st pure (st, sh) validQueueState :: MsgQueueState -> Bool diff --git a/src/Simplex/Messaging/Server/MsgStore/STM.hs b/src/Simplex/Messaging/Server/MsgStore/STM.hs index 17591650c..b08e99abe 100644 --- a/src/Simplex/Messaging/Server/MsgStore/STM.hs +++ b/src/Simplex/Messaging/Server/MsgStore/STM.hs @@ -62,6 +62,8 @@ instance MsgStoreClass STMMsgStore where logQueueStates _ = pure () + logQueueState _ = pure () + -- The reason for double lookup is that majority of messaging queues exist, -- because multiple messages are sent to the same queue, -- so the first lookup without STM transaction will return the queue faster. @@ -104,10 +106,13 @@ instance MsgStoreClass STMMsgStore where modifyTVar' size (+ 1) if canWrt' then writeTQueue q msg $> Just (msg, empty) - else (writeTQueue q $! msgQuota) $> Nothing + else writeTQueue q msgQuota $> Nothing else pure Nothing where - msgQuota = MessageQuota {msgId = msgId msg, msgTs = msgTs msg} + !msgQuota = MessageQuota {msgId = msgId msg, msgTs = msgTs msg} + + setOverQuota_ :: STMMsgQueue -> IO () + setOverQuota_ q = atomically $ writeTVar (canWrite q) False getQueueSize :: STMMsgQueue -> IO Int getQueueSize STMMsgQueue {size} = readTVarIO size @@ -116,8 +121,8 @@ instance MsgStoreClass STMMsgStore where tryPeekMsg_ = tryPeekTQueue . msgQueue {-# INLINE tryPeekMsg_ #-} - tryDeleteMsg_ :: STMMsgQueue -> STM () - tryDeleteMsg_ STMMsgQueue {msgQueue = q, size} = + tryDeleteMsg_ :: STMMsgQueue -> Bool -> STM () + tryDeleteMsg_ STMMsgQueue {msgQueue = q, size} _logState = tryReadTQueue q >>= \case Just _ -> modifyTVar' size (subtract 1) _ -> pure () diff --git a/src/Simplex/Messaging/Server/MsgStore/Types.hs b/src/Simplex/Messaging/Server/MsgStore/Types.hs index dbaefba6f..cd480b0ae 100644 --- a/src/Simplex/Messaging/Server/MsgStore/Types.hs +++ b/src/Simplex/Messaging/Server/MsgStore/Types.hs @@ -26,14 +26,16 @@ class Monad (StoreMonad s) => MsgStoreClass s where activeMsgQueues :: s -> TMap RecipientId (MsgQueue s) withAllMsgQueues :: s -> (RecipientId -> MsgQueue s -> a -> IO a) -> a -> IO a logQueueStates :: s -> IO () + logQueueState :: MsgQueue s -> IO () getMsgQueue :: s -> RecipientId -> ExceptT ErrorType IO (MsgQueue s) delMsgQueue :: s -> RecipientId -> IO () delMsgQueueSize :: s -> RecipientId -> IO Int getQueueMessages :: Bool -> MsgQueue s -> IO [Message] writeMsg :: s -> MsgQueue s -> Bool -> Message -> ExceptT ErrorType IO (Maybe (Message, Bool)) + setOverQuota_ :: MsgQueue s -> IO () -- can ONLY be used while restoring messages, not while server running getQueueSize :: MsgQueue s -> IO Int tryPeekMsg_ :: MsgQueue s -> StoreMonad s (Maybe Message) - tryDeleteMsg_ :: MsgQueue s -> StoreMonad s () + tryDeleteMsg_ :: MsgQueue s -> Bool -> StoreMonad s () isolateQueue :: MsgQueue s -> String -> StoreMonad s a -> ExceptT ErrorType IO a data MSType = MSMemory | MSJournal @@ -57,7 +59,7 @@ tryDelMsg mq msgId' = tryPeekMsg_ mq >>= \case msg_@(Just msg) | msgId msg == msgId' -> - tryDeleteMsg_ mq >> pure msg_ + tryDeleteMsg_ mq True >> pure msg_ _ -> pure Nothing -- atomic delete (== read) last and peek next message if available @@ -66,16 +68,16 @@ tryDelPeekMsg mq msgId' = isolateQueue mq "tryDelPeekMsg" $ tryPeekMsg_ mq >>= \case msg_@(Just msg) - | msgId msg == msgId' -> (msg_,) <$> (tryDeleteMsg_ mq >> tryPeekMsg_ mq) + | msgId msg == msgId' -> (msg_,) <$> (tryDeleteMsg_ mq True >> tryPeekMsg_ mq) | otherwise -> pure (Nothing, msg_) _ -> pure (Nothing, Nothing) -deleteExpiredMsgs :: MsgStoreClass s => MsgQueue s -> Int64 -> ExceptT ErrorType IO Int -deleteExpiredMsgs mq old = isolateQueue mq "deleteExpiredMsgs" $ loop 0 +deleteExpiredMsgs :: MsgStoreClass s => MsgQueue s -> Bool -> Int64 -> ExceptT ErrorType IO Int +deleteExpiredMsgs mq logState old = isolateQueue mq "deleteExpiredMsgs" $ loop 0 where loop dc = tryPeekMsg_ mq >>= \case Just Message {msgTs} | systemSeconds msgTs < old -> - tryDeleteMsg_ mq >> loop (dc + 1) + tryDeleteMsg_ mq logState >> loop (dc + 1) _ -> pure dc diff --git a/tests/CoreTests/MsgStoreTests.hs b/tests/CoreTests/MsgStoreTests.hs index c3344bfa6..eaa9cc25b 100644 --- a/tests/CoreTests/MsgStoreTests.hs +++ b/tests/CoreTests/MsgStoreTests.hs @@ -22,7 +22,7 @@ import Data.Time.Clock.System (getSystemTime) import Simplex.Messaging.Crypto (pattern MaxLenBS) import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Protocol (EntityId (..), Message (..), noMsgFlags) -import Simplex.Messaging.Server (MessageStats (..), exportMessages, importMessages) +import Simplex.Messaging.Server (MessageStats (..), exportMessages, importMessages, printMessageStats) import Simplex.Messaging.Server.Env.STM (journalMsgStoreDepth) import Simplex.Messaging.Server.MsgStore.Journal import Simplex.Messaging.Server.MsgStore.STM @@ -163,14 +163,15 @@ testExportImportStore ms = do exportMessages ms testStoreMsgsFile False let cfg = (testJournalStoreCfg :: JournalStoreConfig) {storePath = testStoreMsgsDir2} ms' <- newMsgStore cfg - MessageStats {storedMsgsCount = 6, expiredMsgsCount = 0, storedQueues = 2} <- + stats@MessageStats {storedMsgsCount = 5, expiredMsgsCount = 0, storedQueues = 2} <- importMessages ms' testStoreMsgsFile Nothing + printMessageStats "Messages" stats length <$> listDirectory (msgQueueDirectory ms rId1) `shouldReturn` 2 length <$> listDirectory (msgQueueDirectory ms rId2) `shouldReturn` 3 -- state file is backed up exportMessages ms' testStoreMsgsFile2 False (B.readFile testStoreMsgsFile2 `shouldReturn`) =<< B.readFile (testStoreMsgsFile <> ".bak") stmStore <- newMsgStore testSMTStoreConfig - MessageStats {storedMsgsCount = 6, expiredMsgsCount = 0, storedQueues = 2} <- + MessageStats {storedMsgsCount = 5, expiredMsgsCount = 0, storedQueues = 2} <- importMessages stmStore testStoreMsgsFile2 Nothing exportMessages stmStore testStoreMsgsFile False (B.sort <$> B.readFile testStoreMsgsFile `shouldReturn`) =<< (B.sort <$> B.readFile (testStoreMsgsFile2 <> ".bak")) @@ -183,7 +184,7 @@ testQueueState ms = do statePath = dir (queueLogFileName <> logFileExt) createDirectoryIfMissing True dir state <- newMsgQueueState <$> newJournalId (random ms) - withFile statePath WriteMode (`logQueueState` state) + withFile statePath WriteMode (`appendState` state) length . lines <$> readFile statePath `shouldReturn` 1 readQueueState statePath `shouldReturn` state length <$> listDirectory dir `shouldReturn` 1 -- no backup @@ -194,7 +195,7 @@ testQueueState ms = do readState = (readState state) {msgCount = 1, byteCount = 100}, writeState = (writeState state) {msgPos = 1, msgCount = 1, bytePos = 100, byteCount = 100} } - withFile statePath AppendMode (`logQueueState` state1) + withFile statePath AppendMode (`appendState` state1) length . lines <$> readFile statePath `shouldReturn` 2 readQueueState statePath `shouldReturn` state1 length <$> listDirectory dir `shouldReturn` 1 -- no backup @@ -205,7 +206,7 @@ testQueueState ms = do readState = (readState state) {msgCount = 2, byteCount = 200}, writeState = (writeState state) {msgPos = 2, msgCount = 2, bytePos = 200, byteCount = 200} } - withFile statePath AppendMode (`logQueueState` state2) + withFile statePath AppendMode (`appendState` state2) length . lines <$> readFile statePath `shouldReturn` 3 copyFile statePath (statePath <> ".2") readQueueState statePath `shouldReturn` state2 diff --git a/tests/NtfServerTests.hs b/tests/NtfServerTests.hs index b9560976d..aebbf0f72 100644 --- a/tests/NtfServerTests.hs +++ b/tests/NtfServerTests.hs @@ -105,7 +105,7 @@ testNotificationSubscription (ATransport t) = (dhPub, dhPriv :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g let tkn = DeviceToken PPApnsTest "abcd" withAPNSMockServer $ \apns -> - smpTest2 t $ \rh sh -> + smpTest2' t $ \rh sh -> ntfTest t $ \nh -> do -- create queue (sId, rId, rKey, rcvDhSecret) <- createAndSecureQueue rh sPub diff --git a/tests/SMPClient.hs b/tests/SMPClient.hs index 0055e8503..0efb64c02 100644 --- a/tests/SMPClient.hs +++ b/tests/SMPClient.hs @@ -1,6 +1,7 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NumericUnderscores #-} @@ -107,19 +108,24 @@ testSMPClient_ host port vr client = do | otherwise = Nothing cfg :: ServerConfig -cfg = +cfg = cfgMS (AMSType SMSJournal) + +cfgMS :: AMSType -> ServerConfig +cfgMS msType = ServerConfig { transports = [], smpHandshakeTimeout = 60000000, tbqSize = 1, - msgStoreType = AMSType SMSJournal, + msgStoreType = msType, msgQueueQuota = 4, maxJournalMsgCount = 5, maxJournalStateLines = 2, queueIdBytes = 24, msgIdBytes = 24, storeLogFile = Just testStoreLogFile, - storeMsgsFile = Just testStoreMsgsDir, + storeMsgsFile = Just $ case msType of + AMSType SMSJournal -> testStoreMsgsDir + AMSType SMSMemory -> testStoreMsgsFile, storeNtfsFile = Nothing, allowNewQueues = True, newQueueBasicAuth = Nothing, @@ -178,18 +184,17 @@ proxyVRangeV8 :: VersionRangeSMP proxyVRangeV8 = mkVersionRange batchCmdsSMPVersion sendingProxySMPVersion withSmpServerStoreMsgLogOn :: HasCallStack => ATransport -> ServiceName -> (HasCallStack => ThreadId -> IO a) -> IO a -withSmpServerStoreMsgLogOn t = - withSmpServerConfigOn - t - cfg - { storeLogFile = Just testStoreLogFile, - storeMsgsFile = Just testStoreMsgsDir, - storeNtfsFile = Just testStoreNtfsFile, - serverStatsBackupFile = Just testServerStatsBackupFile - } +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 t = withSmpServerConfigOn t cfg {storeLogFile = Just testStoreLogFile, serverStatsBackupFile = Just testServerStatsBackupFile} +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} withSmpServerConfigOn :: HasCallStack => ATransport -> ServerConfig -> ServiceName -> (HasCallStack => ThreadId -> IO a) -> IO a withSmpServerConfigOn t cfg' port' = @@ -222,11 +227,11 @@ withSmpServer t = withSmpServerOn t testPort withSmpServerProxy :: HasCallStack => ATransport -> IO a -> IO a withSmpServerProxy t = withSmpServerConfigOn t proxyCfg testPort . const -runSmpTest :: forall c a. (HasCallStack, Transport c) => (HasCallStack => THandleSMP c 'TClient -> IO a) -> IO a -runSmpTest test = withSmpServer (transport @c) $ testSMPClient test +runSmpTest :: forall c a. (HasCallStack, Transport c) => AMSType -> (HasCallStack => THandleSMP c 'TClient -> IO a) -> IO a +runSmpTest msType test = withSmpServerConfigOn (transport @c) (cfgMS msType) testPort $ \_ -> testSMPClient test -runSmpTestN :: forall c a. (HasCallStack, Transport c) => Int -> (HasCallStack => [THandleSMP c 'TClient] -> IO a) -> IO a -runSmpTestN = runSmpTestNCfg cfg supportedClientSMPRelayVRange +runSmpTestN :: forall c a. (HasCallStack, Transport c) => AMSType -> Int -> (HasCallStack => [THandleSMP c 'TClient] -> IO a) -> IO a +runSmpTestN msType = runSmpTestNCfg (cfgMS msType) supportedClientSMPRelayVRange runSmpTestNCfg :: forall c a. (HasCallStack, Transport c) => ServerConfig -> VersionRangeSMP -> Int -> (HasCallStack => [THandleSMP c 'TClient] -> IO a) -> IO a runSmpTestNCfg srvCfg clntVR nClients test = withSmpServerConfigOn (transport @c) srvCfg testPort $ \_ -> run nClients [] @@ -241,7 +246,7 @@ smpServerTest :: TProxy c -> (Maybe TransmissionAuth, ByteString, ByteString, smp) -> IO (Maybe TransmissionAuth, ByteString, ByteString, BrokerMsg) -smpServerTest _ t = runSmpTest $ \h -> tPut' h t >> tGet' h +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 @@ -252,14 +257,17 @@ smpServerTest _ t = runSmpTest $ \h -> tPut' h t >> tGet' h [(Nothing, _, (CorrId corrId, EntityId qId, Right cmd))] <- tGet h pure (Nothing, corrId, qId, cmd) -smpTest :: (HasCallStack, Transport c) => TProxy c -> (HasCallStack => THandleSMP c 'TClient -> IO ()) -> Expectation -smpTest _ test' = runSmpTest test' `shouldReturn` () +smpTest :: (HasCallStack, Transport c) => TProxy c -> AMSType -> (HasCallStack => THandleSMP c 'TClient -> IO ()) -> Expectation +smpTest _ msType test' = runSmpTest msType test' `shouldReturn` () -smpTestN :: (HasCallStack, Transport c) => Int -> (HasCallStack => [THandleSMP c 'TClient] -> IO ()) -> Expectation -smpTestN n test' = runSmpTestN n test' `shouldReturn` () +smpTestN :: (HasCallStack, Transport c) => AMSType -> Int -> (HasCallStack => [THandleSMP c 'TClient] -> IO ()) -> Expectation +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 = smpTest2Cfg cfg supportedClientSMPRelayVRange +smpTest2' :: forall c. (HasCallStack, Transport c) => TProxy c -> (HasCallStack => THandleSMP c 'TClient -> THandleSMP c 'TClient -> IO ()) -> Expectation +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 smpTest2Cfg :: forall c. (HasCallStack, Transport c) => ServerConfig -> VersionRangeSMP -> TProxy c -> (HasCallStack => THandleSMP c 'TClient -> THandleSMP c 'TClient -> IO ()) -> Expectation smpTest2Cfg srvCfg clntVR _ test' = runSmpTestNCfg srvCfg clntVR 2 _test `shouldReturn` () @@ -268,15 +276,15 @@ smpTest2Cfg srvCfg clntVR _ test' = runSmpTestNCfg srvCfg clntVR 2 _test `should _test [h1, h2] = test' h1 h2 _test _ = error "expected 2 handles" -smpTest3 :: forall c. (HasCallStack, Transport c) => TProxy c -> (HasCallStack => THandleSMP c 'TClient -> THandleSMP c 'TClient -> THandleSMP c 'TClient -> IO ()) -> Expectation -smpTest3 _ test' = smpTestN 3 _test +smpTest3 :: forall c. (HasCallStack, Transport c) => TProxy c -> AMSType -> (HasCallStack => THandleSMP c 'TClient -> THandleSMP c 'TClient -> THandleSMP c 'TClient -> IO ()) -> Expectation +smpTest3 _ msType test' = smpTestN msType 3 _test where _test :: HasCallStack => [THandleSMP c 'TClient] -> IO () _test [h1, h2, h3] = test' h1 h2 h3 _test _ = error "expected 3 handles" -smpTest4 :: forall c. (HasCallStack, Transport c) => TProxy c -> (HasCallStack => THandleSMP c 'TClient -> THandleSMP c 'TClient -> THandleSMP c 'TClient -> THandleSMP c 'TClient -> IO ()) -> Expectation -smpTest4 _ test' = smpTestN 4 _test +smpTest4 :: forall c. (HasCallStack, Transport c) => TProxy c -> AMSType -> (HasCallStack => THandleSMP c 'TClient -> THandleSMP c 'TClient -> THandleSMP c 'TClient -> THandleSMP c 'TClient -> IO ()) -> Expectation +smpTest4 _ msType test' = smpTestN msType 4 _test where _test :: HasCallStack => [THandleSMP c 'TClient] -> IO () _test [h1, h2, h3, h4] = test' h1 h2 h3 h4 diff --git a/tests/ServerTests.hs b/tests/ServerTests.hs index 965967878..c133d94fc 100644 --- a/tests/ServerTests.hs +++ b/tests/ServerTests.hs @@ -51,32 +51,31 @@ import System.Timeout import Test.HUnit import Test.Hspec -serverTests :: ATransport -> Spec -serverTests t@(ATransport t') = do - describe "SMP syntax" $ syntaxTests t +serverTests :: SpecWith (ATransport, AMSType) +serverTests = do describe "SMP queues" $ do - describe "NEW and KEY commands, SEND messages" $ testCreateSecure t + describe "NEW and KEY commands, SEND messages" testCreateSecure describe "NEW and SKEY commands" $ do - testCreateSndSecure t - testSndSecureProhibited t - describe "NEW, OFF and DEL commands, SEND messages" $ testCreateDelete t - describe "Stress test" $ stressTest t - describe "allowNewQueues setting" $ testAllowNewQueues t' + testCreateSndSecure + testSndSecureProhibited + describe "NEW, OFF and DEL commands, SEND messages" testCreateDelete + describe "Stress test" stressTest + describe "allowNewQueues setting" testAllowNewQueues describe "SMP messages" $ do - describe "duplex communication over 2 SMP connections" $ testDuplex t - describe "switch subscription to another TCP connection" $ testSwitchSub t - describe "GET command" $ testGetCommand t' - describe "GET & SUB commands" $ testGetSubCommands t' - describe "Exceeding queue quota" $ testExceedQueueQuota t' - describe "Store log" $ testWithStoreLog t - describe "Restore messages" $ testRestoreMessages t - describe "Restore messages (old / v2)" $ testRestoreExpireMessages t - describe "Timing of AUTH error" $ testTiming t - describe "Message notifications" $ testMessageNotifications t + describe "duplex communication over 2 SMP connections" testDuplex + describe "switch subscription to another TCP connection" testSwitchSub + describe "GET command" testGetCommand + describe "GET & SUB commands" testGetSubCommands + describe "Exceeding queue quota" testExceedQueueQuota + describe "Store log" testWithStoreLog + describe "Restore messages" testRestoreMessages + describe "Restore messages (old / v2)" testRestoreExpireMessages + describe "Timing of AUTH error" testTiming + describe "Message notifications" testMessageNotifications describe "Message expiration" $ do - testMsgExpireOnSend t' - testMsgExpireOnInterval t' - testMsgNOTExpireOnInterval t' + testMsgExpireOnSend + testMsgExpireOnInterval + testMsgNOTExpireOnInterval pattern Resp :: CorrId -> QueueId -> BrokerMsg -> SignedTransmission ErrorType BrokerMsg pattern Resp corrId queueId command <- (_, _, (corrId, queueId, Right command)) @@ -136,10 +135,10 @@ decryptMsgV3 dhShared nonce body = Right ClientRcvMsgQuota {} -> Left "ClientRcvMsgQuota" Left e -> Left e -testCreateSecure :: ATransport -> Spec -testCreateSecure (ATransport t) = - it "should create (NEW) and secure (KEY) queue" $ - smpTest2 t $ \r s -> do +testCreateSecure :: SpecWith (ATransport, AMSType) +testCreateSecure = + it "should create (NEW) and secure (KEY) queue" $ \(ATransport t, msType) -> + smpTest2 t msType $ \r s -> do g <- C.newRandom (rPub, rKey) <- atomically $ C.generateAuthKeyPair C.SEd448 g (dhPub, dhPriv :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g @@ -201,10 +200,10 @@ testCreateSecure (ATransport t) = Resp "bcda" _ (ERR LARGE_MSG) <- signSendRecv s sKey ("bcda", sId, _SEND biggerMessage) pure () -testCreateSndSecure :: ATransport -> Spec -testCreateSndSecure (ATransport t) = - it "should create (NEW) and secure (SKEY) queue by sender" $ - smpTest2 t $ \r s -> do +testCreateSndSecure :: SpecWith (ATransport, AMSType) +testCreateSndSecure = + it "should create (NEW) and secure (SKEY) queue by sender" $ \(ATransport t, msType) -> + smpTest2 t msType $ \r s -> do g <- C.newRandom (rPub, rKey) <- atomically $ C.generateAuthKeyPair C.SEd448 g (dhPub, dhPriv :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g @@ -248,10 +247,10 @@ testCreateSndSecure (ATransport t) = Resp "bcda" _ (ERR LARGE_MSG) <- signSendRecv s sKey ("bcda", sId, _SEND biggerMessage) pure () -testSndSecureProhibited :: ATransport -> Spec -testSndSecureProhibited (ATransport t) = - it "should create (NEW) without allowing sndSecure and fail to and secure queue by sender (SKEY)" $ - smpTest2 t $ \r s -> do +testSndSecureProhibited :: SpecWith (ATransport, AMSType) +testSndSecureProhibited = + it "should create (NEW) without allowing sndSecure and fail to and secure queue by sender (SKEY)" $ \(ATransport t, msType) -> + smpTest2 t msType $ \r s -> do g <- C.newRandom (rPub, rKey) <- atomically $ C.generateAuthKeyPair C.SEd448 g (dhPub, _dhPriv :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g @@ -263,10 +262,10 @@ testSndSecureProhibited (ATransport t) = (sId2, sId) #== "secures queue, same queue ID in response" (err, ERR AUTH) #== "rejects SKEY when not allowed in NEW command" -testCreateDelete :: ATransport -> Spec -testCreateDelete (ATransport t) = - it "should create (NEW), suspend (OFF) and delete (DEL) queue" $ - smpTest2 t $ \rh sh -> do +testCreateDelete :: SpecWith (ATransport, AMSType) +testCreateDelete = + it "should create (NEW), suspend (OFF) and delete (DEL) queue" $ \(ATransport t, msType) -> + smpTest2 t msType $ \rh sh -> do g <- C.newRandom (rPub, rKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g (dhPub, dhPriv :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g @@ -334,10 +333,10 @@ testCreateDelete (ATransport t) = Resp "cdab" _ err10 <- signSendRecv rh rKey ("cdab", rId, SUB) (err10, ERR AUTH) #== "rejects SUB when deleted" -stressTest :: ATransport -> Spec -stressTest (ATransport t) = - it "should create many queues, disconnect and re-connect" $ - smpTest3 t $ \h1 h2 h3 -> do +stressTest :: SpecWith (ATransport, AMSType) +stressTest = + it "should create many queues, disconnect and re-connect" $ \(ATransport t, msType) -> + smpTest3 t msType $ \h1 h2 h3 -> do g <- C.newRandom (rPub, rKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g (dhPub, _ :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g @@ -352,10 +351,10 @@ stressTest (ATransport t) = closeConnection $ connection h2 subscribeQueues h3 -testAllowNewQueues :: forall c. Transport c => TProxy c -> Spec -testAllowNewQueues t = - it "should prohibit creating new queues with allowNewQueues = False" $ do - withSmpServerConfigOn (ATransport t) cfg {allowNewQueues = False} testPort $ \_ -> +testAllowNewQueues :: SpecWith (ATransport, AMSType) +testAllowNewQueues = + it "should prohibit creating new queues with allowNewQueues = False" $ \(ATransport (t :: TProxy c), msType) -> + withSmpServerConfigOn (ATransport t) (cfgMS msType) {allowNewQueues = False} testPort $ \_ -> testSMPClient @c $ \h -> do g <- C.newRandom (rPub, rKey) <- atomically $ C.generateAuthKeyPair C.SEd448 g @@ -363,10 +362,10 @@ testAllowNewQueues t = Resp "abcd" NoEntity (ERR AUTH) <- signSendRecv h rKey ("abcd", NoEntity, NEW rPub dhPub Nothing SMSubscribe False) pure () -testDuplex :: ATransport -> Spec -testDuplex (ATransport t) = - it "should create 2 simplex connections and exchange messages" $ - smpTest2 t $ \alice bob -> do +testDuplex :: SpecWith (ATransport, AMSType) +testDuplex = + it "should create 2 simplex connections and exchange messages" $ \(ATransport t, msType) -> + smpTest2 t msType $ \alice bob -> do g <- C.newRandom (arPub, arKey) <- atomically $ C.generateAuthKeyPair C.SEd448 g (aDhPub, aDhPriv :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g @@ -418,10 +417,10 @@ testDuplex (ATransport t) = Resp "bcda" _ OK <- signSendRecv bob brKey ("bcda", bRcv, ACK mId5) (bDec mId5 msg5, Right "how are you bob") #== "message received from alice" -testSwitchSub :: ATransport -> Spec -testSwitchSub (ATransport t) = - it "should create simplex connections and switch subscription to another TCP connection" $ - smpTest3 t $ \rh1 rh2 sh -> do +testSwitchSub :: SpecWith (ATransport, AMSType) +testSwitchSub = + it "should create simplex connections and switch subscription to another TCP connection" $ \(ATransport t, msType) -> + smpTest3 t msType $ \rh1 rh2 sh -> do g <- C.newRandom (rPub, rKey) <- atomically $ C.generateAuthKeyPair C.SEd448 g (dhPub, dhPriv :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g @@ -463,12 +462,12 @@ testSwitchSub (ATransport t) = Nothing -> return () Just _ -> error "nothing else is delivered to the 1st TCP connection" -testGetCommand :: forall c. Transport c => TProxy c -> Spec -testGetCommand t = - it "should retrieve messages from the queue using GET command" $ do +testGetCommand :: SpecWith (ATransport, AMSType) +testGetCommand = + it "should retrieve messages from the queue using GET command" $ \(ATransport (t :: TProxy c), msType) -> do g <- C.newRandom (sPub, sKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g - smpTest t $ \sh -> do + smpTest t msType $ \sh -> do queue <- newEmptyTMVarIO testSMPClient @c $ \rh -> atomically . putTMVar queue =<< createAndSecureQueue rh sPub @@ -482,12 +481,12 @@ testGetCommand t = Resp "4" _ OK <- signSendRecv rh rKey ("4", rId, GET) pure () -testGetSubCommands :: forall c. Transport c => TProxy c -> Spec -testGetSubCommands t = - it "should retrieve messages with GET and receive with SUB, only one ACK would work" $ do +testGetSubCommands :: SpecWith (ATransport, AMSType) +testGetSubCommands = + it "should retrieve messages with GET and receive with SUB, only one ACK would work" $ \(ATransport t, msType) -> do g <- C.newRandom (sPub, sKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g - smpTest3 t $ \rh1 rh2 sh -> do + smpTest3 t msType $ \rh1 rh2 sh -> do (sId, rId, rKey, dhShared) <- createAndSecureQueue rh1 sPub let dec = decryptMsgV3 dhShared Resp "1" _ OK <- signSendRecv sh sKey ("1", sId, _SEND "hello 1") @@ -532,10 +531,10 @@ testGetSubCommands t = Resp "12" _ OK <- signSendRecv rh2 rKey ("12", rId, GET) pure () -testExceedQueueQuota :: forall c. Transport c => TProxy c -> Spec -testExceedQueueQuota t = - it "should reply with ERR QUOTA to sender and send QUOTA message to the recipient" $ do - withSmpServerConfigOn (ATransport t) cfg {msgQueueQuota = 2} testPort $ \_ -> +testExceedQueueQuota :: SpecWith (ATransport, AMSType) +testExceedQueueQuota = + it "should reply with ERR QUOTA to sender and send QUOTA message to the recipient" $ \(ATransport (t :: TProxy c), msType) -> do + withSmpServerConfigOn (ATransport t) (cfgMS msType) {msgQueueQuota = 2} testPort $ \_ -> testSMPClient @c $ \sh -> testSMPClient @c $ \rh -> do g <- C.newRandom (sPub, sKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g @@ -559,9 +558,9 @@ testExceedQueueQuota t = Resp "10" _ OK <- signSendRecv rh rKey ("10", rId, ACK mId4) pure () -testWithStoreLog :: ATransport -> Spec -testWithStoreLog at@(ATransport t) = - it "should store simplex queues to log and restore them after server restart" $ do +testWithStoreLog :: SpecWith (ATransport, AMSType) +testWithStoreLog = + it "should store simplex queues to log and restore them after server restart" $ \(at@(ATransport t), msType) -> do g <- C.newRandom (sPub1, sKey1) <- atomically $ C.generateAuthKeyPair C.SEd25519 g (sPub2, sKey2) <- atomically $ C.generateAuthKeyPair C.SEd25519 g @@ -573,7 +572,7 @@ testWithStoreLog at@(ATransport t) = senderId2 <- newTVarIO NoEntity notifierId <- newTVarIO NoEntity - withSmpServerStoreLogOn at testPort . runTest t $ \h -> runClient t $ \h1 -> do + withSmpServerStoreLogOnMS at msType testPort . runTest t $ \h -> runClient t $ \h1 -> do (sId1, rId1, rKey1, dhShared) <- createAndSecureQueue h sPub1 (rcvNtfPubDhKey, _) <- atomically $ C.generateKeyPair g Resp "abcd" _ (NID nId _) <- signSendRecv h rKey1 ("abcd", rId1, NKEY nPub rcvNtfPubDhKey) @@ -606,14 +605,14 @@ testWithStoreLog at@(ATransport t) = logSize testStoreLogFile `shouldReturn` 6 - let cfg' = cfg {msgStoreType = AMSType SMSMemory, storeLogFile = Nothing, storeMsgsFile = Nothing} + 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 () - withSmpServerStoreLogOn at testPort . runTest t $ \h -> runClient t $ \h1 -> do + withSmpServerStoreLogOnMS at msType testPort . runTest t $ \h -> runClient t $ \h1 -> do -- this queue is restored rId1 <- readTVarIO recipientId1 Just rKey1 <- readTVarIO recipientKey1 @@ -647,9 +646,9 @@ logSize f = Right l -> pure l Left (_ :: SomeException) -> logSize f -testRestoreMessages :: ATransport -> Spec -testRestoreMessages at@(ATransport t) = - it "should store messages on exit and restore on start" $ do +testRestoreMessages :: SpecWith (ATransport, AMSType) +testRestoreMessages = + it "should store messages on exit and restore on start" $ \(at@(ATransport t), msType) -> do removeFileIfExists testStoreLogFile removeFileIfExists testStoreMsgsFile whenM (doesDirectoryExist testStoreMsgsDir) $ removeDirectoryRecursive testStoreMsgsDir @@ -662,7 +661,7 @@ testRestoreMessages at@(ATransport t) = dhShared <- newTVarIO Nothing senderId <- newTVarIO NoEntity - withSmpServerStoreMsgLogOn at testPort . runTest t $ \h -> do + withSmpServerStoreMsgLogOnMS at msType testPort . runTest t $ \h -> do runClient t $ \h1 -> do (sId, rId, rKey, dh) <- createAndSecureQueue h1 sPub atomically $ do @@ -691,7 +690,7 @@ testRestoreMessages at@(ATransport t) = Right stats1 <- strDecode <$> B.readFile testServerStatsBackupFile checkStats stats1 [rId] 5 1 - withSmpServerStoreMsgLogOn at testPort . runTest t $ \h -> do + withSmpServerStoreMsgLogOnMS at msType testPort . runTest t $ \h -> do Just rKey <- readTVarIO recipientKey Just dh <- readTVarIO dhShared let dec = decryptMsgV3 dh @@ -709,7 +708,7 @@ testRestoreMessages at@(ATransport t) = Right stats2 <- strDecode <$> B.readFile testServerStatsBackupFile checkStats stats2 [rId] 5 3 - withSmpServerStoreMsgLogOn at testPort . runTest t $ \h -> do + withSmpServerStoreMsgLogOnMS at msType testPort . runTest t $ \h -> do Just rKey <- readTVarIO recipientKey Just dh <- readTVarIO dhShared let dec = decryptMsgV3 dh @@ -756,9 +755,9 @@ checkStats s qs sent received = do IS.toList _week `shouldBe` map (hash . unEntityId) qs IS.toList _month `shouldBe` map (hash . unEntityId) qs -testRestoreExpireMessages :: ATransport -> Spec -testRestoreExpireMessages at@(ATransport t) = - it "should store messages on exit and restore on start" $ do +testRestoreExpireMessages :: SpecWith (ATransport, AMSType) +testRestoreExpireMessages = + it "should store messages on exit and restore on start" $ \(at@(ATransport t), msType) -> do g <- C.newRandom (sPub, sKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g recipientId <- newTVarIO NoEntity @@ -766,7 +765,7 @@ testRestoreExpireMessages at@(ATransport t) = dhShared <- newTVarIO Nothing senderId <- newTVarIO NoEntity - withSmpServerStoreMsgLogOn at testPort . runTest t $ \h -> do + withSmpServerStoreMsgLogOnMS at msType testPort . runTest t $ \h -> do runClient t $ \h1 -> do (sId, rId, rKey, dh) <- createAndSecureQueue h1 sPub atomically $ do @@ -783,36 +782,39 @@ testRestoreExpireMessages at@(ATransport t) = pure () logSize testStoreLogFile `shouldReturn` 2 - exportStoreMessages + exportStoreMessages msType msgs <- B.readFile testStoreMsgsFile length (B.lines msgs) `shouldBe` 4 let expCfg1 = Just ExpirationConfig {ttl = 86400, checkInterval = 43200} - cfg1 = cfg {messageExpiration = expCfg1, serverStatsBackupFile = Just testServerStatsBackupFile} + cfg1 = (cfgMS msType) {messageExpiration = expCfg1, serverStatsBackupFile = Just testServerStatsBackupFile} withSmpServerConfigOn at cfg1 testPort . runTest t $ \_ -> pure () logSize testStoreLogFile `shouldReturn` 1 - exportStoreMessages + exportStoreMessages msType msgs' <- B.readFile testStoreMsgsFile msgs' `shouldBe` msgs let expCfg2 = Just ExpirationConfig {ttl = 2, checkInterval = 43200} - cfg2 = cfg {messageExpiration = expCfg2, serverStatsBackupFile = Just testServerStatsBackupFile} + cfg2 = (cfgMS msType) {messageExpiration = expCfg2, serverStatsBackupFile = Just testServerStatsBackupFile} withSmpServerConfigOn at cfg2 testPort . runTest t $ \_ -> pure () logSize testStoreLogFile `shouldReturn` 1 -- two messages expired - exportStoreMessages + exportStoreMessages msType msgs'' <- B.readFile testStoreMsgsFile length (B.lines msgs'') `shouldBe` 2 B.lines msgs'' `shouldBe` drop 2 (B.lines msgs) Right ServerStatsData {_msgExpired} <- strDecode <$> B.readFile testServerStatsBackupFile _msgExpired `shouldBe` 2 where - exportStoreMessages = do - ms <- newMsgStore testJournalStoreCfg {quota = 4} - removeFileIfExists testStoreMsgsFile - exportMessages ms testStoreMsgsFile False + exportStoreMessages :: AMSType -> IO () + exportStoreMessages = \case + AMSType SMSJournal -> do + ms <- newMsgStore testJournalStoreCfg {quota = 4} + removeFileIfExists testStoreMsgsFile + exportMessages ms testStoreMsgsFile False + AMSType SMSMemory -> pure () runTest :: Transport c => TProxy c -> (THandleSMP c 'TClient -> IO ()) -> ThreadId -> Expectation runTest _ test' server = do testSMPClient test' `shouldReturn` () @@ -832,12 +834,12 @@ createAndSecureQueue h sPub = do (rId', rId) #== "same queue ID" pure (sId, rId, rKey, dhShared) -testTiming :: ATransport -> Spec -testTiming (ATransport t) = +testTiming :: SpecWith (ATransport, AMSType) +testTiming = describe "should have similar time for auth error, whether queue exists or not, for all key types" $ forM_ timingTests $ \tst -> - it (testName tst) $ - smpTest2Cfg cfg (mkVersionRange batchCmdsSMPVersion authCmdsSMPVersion) t $ \rh sh -> + it (testName tst) $ \(ATransport t, msType) -> + smpTest2Cfg (cfgMS msType) (mkVersionRange batchCmdsSMPVersion authCmdsSMPVersion) t $ \rh sh -> testSameTiming rh sh tst where testName :: (C.AuthAlg, C.AuthAlg, Int) -> String @@ -902,13 +904,13 @@ testTiming (ATransport t) = ] ok `shouldBe` True -testMessageNotifications :: ATransport -> Spec -testMessageNotifications (ATransport t) = - it "should create simplex connection, subscribe notifier and deliver notifications" $ do +testMessageNotifications :: SpecWith (ATransport, AMSType) +testMessageNotifications = + it "should create simplex connection, subscribe notifier and deliver notifications" $ \(ATransport t, msType) -> do g <- C.newRandom (sPub, sKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g (nPub, nKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g - smpTest4 t $ \rh sh nh1 nh2 -> do + smpTest4 t msType $ \rh sh nh1 nh2 -> do (sId, rId, rKey, dhShared) <- createAndSecureQueue rh sPub let dec = decryptMsgV3 dhShared (rcvNtfPubDhKey, _) <- atomically $ C.generateKeyPair g @@ -942,12 +944,12 @@ testMessageNotifications (ATransport t) = Nothing -> pure () Just _ -> error "nothing else should be delivered to the 2nd notifier's TCP connection" -testMsgExpireOnSend :: forall c. Transport c => TProxy c -> Spec -testMsgExpireOnSend t = - it "should expire messages that are not received before messageTTL on SEND" $ do +testMsgExpireOnSend :: SpecWith (ATransport, AMSType) +testMsgExpireOnSend = + it "should expire messages that are not received before messageTTL on SEND" $ \(ATransport (t :: TProxy c), msType) -> do g <- C.newRandom (sPub, sKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g - let cfg' = cfg {messageExpiration = Just ExpirationConfig {ttl = 1, checkInterval = 10000}} + let cfg' = (cfgMS msType) {messageExpiration = Just ExpirationConfig {ttl = 1, checkInterval = 10000}} withSmpServerConfigOn (ATransport t) cfg' testPort $ \_ -> testSMPClient @c $ \sh -> do (sId, rId, rKey, dhShared) <- testSMPClient @c $ \rh -> createAndSecureQueue rh sPub @@ -962,13 +964,13 @@ testMsgExpireOnSend t = Nothing -> return () Just _ -> error "nothing else should be delivered" -testMsgExpireOnInterval :: forall c. Transport c => TProxy c -> Spec -testMsgExpireOnInterval t = +testMsgExpireOnInterval :: SpecWith (ATransport, AMSType) +testMsgExpireOnInterval = -- fails on ubuntu - xit' "should expire messages that are not received before messageTTL after expiry interval" $ do + xit' "should expire messages that are not received before messageTTL after expiry interval" $ \(ATransport (t :: TProxy c), msType) -> do g <- C.newRandom (sPub, sKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g - let cfg' = cfg {messageExpiration = Just ExpirationConfig {ttl = 1, checkInterval = 1}} + let cfg' = (cfgMS msType) {messageExpiration = Just ExpirationConfig {ttl = 1, checkInterval = 1}} withSmpServerConfigOn (ATransport t) cfg' testPort $ \_ -> testSMPClient @c $ \sh -> do (sId, rId, rKey, _) <- testSMPClient @c $ \rh -> createAndSecureQueue rh sPub @@ -982,12 +984,12 @@ testMsgExpireOnInterval t = Nothing -> return () Just _ -> error "nothing should be delivered" -testMsgNOTExpireOnInterval :: forall c. Transport c => TProxy c -> Spec -testMsgNOTExpireOnInterval t = - it "should NOT expire messages that are not received before messageTTL if expiry interval is large" $ do +testMsgNOTExpireOnInterval :: SpecWith (ATransport, AMSType) +testMsgNOTExpireOnInterval = + it "should NOT expire messages that are not received before messageTTL if expiry interval is large" $ \(ATransport (t :: TProxy c), msType) -> do g <- C.newRandom (sPub, sKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g - let cfg' = cfg {messageExpiration = Just ExpirationConfig {ttl = 1, checkInterval = 10000}} + let cfg' = (cfgMS msType) {messageExpiration = Just ExpirationConfig {ttl = 1, checkInterval = 10000}} withSmpServerConfigOn (ATransport t) cfg' testPort $ \_ -> testSMPClient @c $ \sh -> do (sId, rId, rKey, dhShared) <- testSMPClient @c $ \rh -> createAndSecureQueue rh sPub @@ -1020,8 +1022,8 @@ instance Eq C.ASignature where Just Refl -> s == s' _ -> False -syntaxTests :: ATransport -> Spec -syntaxTests (ATransport t) = do +serverSyntaxTests :: ATransport -> Spec +serverSyntaxTests (ATransport t) = do it "unknown command" $ ("", "abcd", "1234", ('H', 'E', 'L', 'L', 'O')) >#> ("", "abcd", "1234", ERR $ CMD UNKNOWN) describe "NEW" $ do it "no parameters" $ (sampleSig, "bcda", "", NEW_) >#> ("", "bcda", "", ERR $ CMD SYNTAX) diff --git a/tests/Test.hs b/tests/Test.hs index 6ae4edb41..f8505b133 100644 --- a/tests/Test.hs +++ b/tests/Test.hs @@ -25,8 +25,9 @@ import NtfServerTests (ntfServerTests) import RemoteControl (remoteControlTests) import SMPProxyTests (smpProxyTests) import ServerTests +import Simplex.Messaging.Server.MsgStore.Types (AMSType (..), SMSType (..)) import Simplex.Messaging.Transport (TLS, Transport (..)) -import Simplex.Messaging.Transport.WebSockets (WS) +-- import Simplex.Messaging.Transport.WebSockets (WS) import System.Directory (createDirectoryIfMissing, removeDirectoryRecursive) import System.Environment (setEnv) import Test.Hspec @@ -60,8 +61,14 @@ main = do describe "Store log tests" storeLogTests describe "TRcvQueues tests" tRcvQueuesTests describe "Util tests" utilTests - describe "SMP server via TLS" $ serverTests (transport @TLS) - xdescribe "SMP server via WebSockets" $ serverTests (transport @WS) + describe "SMP server via TLS, jornal message store" $ do + describe "SMP syntax" $ serverSyntaxTests (transport @TLS) + 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 + -- describe "SMP syntax" $ serverSyntaxTests (transport @WS) + -- before (pure (transport @WS, AMSType SMSJournal)) serverTests describe "Notifications server" $ ntfServerTests (transport @TLS) describe "SMP client agent" $ agentTests (transport @TLS) describe "SMP proxy" smpProxyTests From 2322f5bf59c79053a4d9e0141db8f5654e6219ff Mon Sep 17 00:00:00 2001 From: Evgeny Date: Thu, 24 Oct 2024 19:44:47 +0100 Subject: [PATCH 5/8] smp server: logging format, mask/handle exceptions during journal store operations (#1381) * smp server: fixed logging format for journal store errors * version * colon * logs * refactor * space * remove comment * log file name in fixFileSize * logError * stricter * process all queues more efficiently * use monoid for queue processing * expire messages concurrently * concurrently 2 * Revert "concurrently 2" This reverts commit c1aee1f22c9174b559a66d2c9568cbb8772b61e0. * Revert "expire messages concurrently" This reverts commit fc53137cdba58627f1b050271ad0c2dfba6d4460. * show queue directory or ID in errors * foldM * mask_ * try * mask more * refactor * command to delete journal * uninterruptibleMask_ when writing to state file * fix ghc8.10.7 * version * revert version --- src/Simplex/Messaging/Server.hs | 36 +++-- src/Simplex/Messaging/Server/Main.hs | 16 +- .../Messaging/Server/MsgStore/Journal.hs | 150 ++++++++++-------- src/Simplex/Messaging/Server/MsgStore/STM.hs | 8 +- .../Messaging/Server/MsgStore/Types.hs | 12 +- 5 files changed, 130 insertions(+), 92 deletions(-) diff --git a/src/Simplex/Messaging/Server.hs b/src/Simplex/Messaging/Server.hs index 0574b9387..7b539ec69 100644 --- a/src/Simplex/Messaging/Server.hs +++ b/src/Simplex/Messaging/Server.hs @@ -68,6 +68,7 @@ import Data.List.NonEmpty (NonEmpty (..), (<|)) import qualified Data.List.NonEmpty as L import qualified Data.Map.Strict as M import Data.Maybe (catMaybes, fromMaybe, isJust, isNothing) +import Data.Semigroup (Sum (..)) import qualified Data.Text as T import Data.Text.Encoding (decodeLatin1) import Data.Time.Clock (UTCTime (..), diffTimeToPicoseconds, getCurrentTime) @@ -148,6 +149,14 @@ data MessageStats = MessageStats storedQueues :: Int } +instance Monoid MessageStats where + mempty = MessageStats 0 0 0 + {-# INLINE mempty #-} + +instance Semigroup MessageStats where + MessageStats a b c <> MessageStats x y z = MessageStats (a + x) (b + y) (c + z) + {-# INLINE (<>) #-} + newMessageStats :: MessageStats newMessageStats = MessageStats 0 0 0 @@ -378,11 +387,12 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg} attachHT liftIO $ forever $ do threadDelay' interval old <- expireBeforeEpoch expCfg - void $ withActiveMsgQueues ms (\_ -> expireQueueMsgs stats old) 0 + Sum deleted <- withActiveMsgQueues ms $ \_ -> expireQueueMsgs stats old + logInfo $ "STORE: expireMessagesThread, expired " <> tshow deleted <> " messages" where - expireQueueMsgs stats old q acc = + expireQueueMsgs stats old q = runExceptT (deleteExpiredMsgs q True old) >>= \case - Right deleted -> (acc + deleted) <$ atomicModifyIORef'_ (msgExpired stats) (+ deleted) + Right deleted -> Sum deleted <$ atomicModifyIORef'_ (msgExpired stats) (+ deleted) Left _ -> pure 0 expireNtfsThread :: ServerConfig -> M () @@ -1738,10 +1748,10 @@ saveServerMessages drainMsgs = exportMessages :: MsgStoreClass s => s -> FilePath -> Bool -> IO () exportMessages ms f drainMsgs = do logInfo $ "saving messages to file " <> T.pack f - total <- liftIO $ withFile f WriteMode $ \h -> withAllMsgQueues ms (saveQueueMsgs h) 0 + Sum total <- liftIO $ withFile f WriteMode $ withAllMsgQueues ms . saveQueueMsgs logInfo $ "messages saved: " <> tshow total where - saveQueueMsgs h rId q acc = getQueueMessages drainMsgs q >>= \msgs -> (acc + length msgs) <$ BLD.hPutBuilder h (encodeMessages rId msgs) + saveQueueMsgs h rId q = getQueueMessages drainMsgs q >>= \msgs -> Sum (length msgs) <$ BLD.hPutBuilder h (encodeMessages rId msgs) encodeMessages rId = mconcat . map (\msg -> BLD.byteString (strEncode $ MLRv3 rId msg) <> BLD.char8 '\n') processServerMessages :: M MessageStats @@ -1757,18 +1767,17 @@ processServerMessages = do AMS SMSJournal ms -> case old_ of Just old -> do logInfo "expiring journal store messages..." - (storedMsgsCount, expiredMsgsCount, storedQueues) <- withAllMsgQueues ms (\_ -> processExpireQueue old) (0, 0, 0) - pure MessageStats {storedMsgsCount, expiredMsgsCount, storedQueues} + withAllMsgQueues ms $ \_ -> processExpireQueue old Nothing -> do logInfo "validating journal store messages..." - (storedMsgsCount, storedQueues) <- withAllMsgQueues ms (\_ -> processValidateQueue) (0, 0) - pure MessageStats {storedMsgsCount, expiredMsgsCount = 0, storedQueues} + withAllMsgQueues ms $ \_ -> processValidateQueue where - processExpireQueue old q (!stored, !expired, !qCount) = + processExpireQueue old q = runExceptT expireQueue >>= \case - Right (stored', expired') -> pure (stored + stored', expired + expired', qCount + 1) + Right (storedMsgsCount, expiredMsgsCount) -> + pure MessageStats {storedMsgsCount, expiredMsgsCount, storedQueues = 1} Left e -> do - logInfo $ "failed expiring messages in queue " <> T.pack (queueDirectory $ queue q) <> ": " <> tshow e + logError $ "failed expiring messages in queue " <> T.pack (queueDirectory $ queue q) <> ": " <> tshow e exitFailure where expireQueue = do @@ -1777,7 +1786,8 @@ processServerMessages = do liftIO $ logQueueState q liftIO $ closeMsgQueue q pure (stored'', expired'') - processValidateQueue q (!stored, !qCount) = getQueueSize q >>= \stored' -> pure (stored + stored', qCount + 1) + processValidateQueue q = + getQueueSize q >>= \storedMsgsCount -> pure mempty {storedMsgsCount, storedQueues = 1} importMessages :: forall s. MsgStoreClass s => s -> FilePath -> Maybe Int64 -> IO MessageStats importMessages ms f old_ = do diff --git a/src/Simplex/Messaging/Server/Main.hs b/src/Simplex/Messaging/Server/Main.hs index 5abe0b331..f728e6be8 100644 --- a/src/Simplex/Messaging/Server/Main.hs +++ b/src/Simplex/Messaging/Server/Main.hs @@ -85,9 +85,9 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath = Journal cmd -> withIniFile $ \ini -> do msgsDirExists <- doesDirectoryExist storeMsgsJournalDir msgsFileExists <- doesFileExist storeMsgsFilePath - when (msgsFileExists && msgsDirExists) exitConfigureMsgStorage case cmd of JCImport + | msgsFileExists && msgsDirExists -> exitConfigureMsgStorage | msgsDirExists -> do putStrLn $ storeMsgsJournalDir <> " directory already exists." exitFailure @@ -107,6 +107,7 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath = Right (AMSType SMSJournal) -> "store_messages set to `journal`" Left e -> e <> ", update it to `journal` in INI file" JCExport + | msgsFileExists && msgsDirExists -> exitConfigureMsgStorage | msgsFileExists -> do putStrLn $ storeMsgsFilePath <> " file already exists." exitFailure @@ -121,6 +122,16 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath = Right (AMSType SMSMemory) -> "store_messages set to `memory`" Right (AMSType SMSJournal) -> "store_messages set to `journal`, update it to `memory` in INI file" Left e -> e <> ", update it to `memory` in INI file" + JCDelete + | not msgsDirExists -> do + putStrLn $ storeMsgsJournalDir <> " directory does not exists." + exitFailure + | otherwise -> do + confirmOrExit + ("WARNING: journal directory " <> storeMsgsJournalDir <> " will be permanently deleted.\nTHIS CANNOT BE UNDONE!") + "Messages NOT deleted" + deleteDirIfExists storeMsgsJournalDir + putStrLn $ "Deleted all messages in journal " <> storeMsgsJournalDir where withIniFile a = doesFileExist iniFile >>= \case @@ -609,7 +620,7 @@ data CliCommand | Delete | Journal JournalCmd -data JournalCmd = JCImport | JCExport +data JournalCmd = JCImport | JCExport | JCDelete data InitOptions = InitOptions { enableStoreLog :: Bool, @@ -785,6 +796,7 @@ cliCommandP cfgPath logPath iniFile = 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")) ) parseBasicAuth :: ReadM ServerPassword diff --git a/src/Simplex/Messaging/Server/MsgStore/Journal.hs b/src/Simplex/Messaging/Server/MsgStore/Journal.hs index 564a9a804..b87b53dd7 100644 --- a/src/Simplex/Messaging/Server/MsgStore/Journal.hs +++ b/src/Simplex/Messaging/Server/MsgStore/Journal.hs @@ -40,11 +40,13 @@ import Control.Logger.Simple import Control.Monad import Control.Monad.Trans.Except import qualified Data.Attoparsec.ByteString.Char8 as A +import Data.Bitraversable (bimapM) import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Lazy.Char8 as LB import Data.Functor (($>)) import Data.Int (Int64) +import Data.List (intercalate) import Data.Maybe (catMaybes, fromMaybe) import qualified Data.Text as T import Data.Time.Clock (getCurrentTime) @@ -190,7 +192,7 @@ msgLogFileName = "messages" logFileExt :: String logFileExt = ".log" -newtype StoreIO a = StoreIO (IO a) +newtype StoreIO a = StoreIO {unStoreIO :: IO a} deriving newtype (Functor, Applicative, Monad) instance MsgStoreClass JournalMsgStore where @@ -214,48 +216,47 @@ instance MsgStoreClass JournalMsgStore 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 :: JournalMsgStore -> (RecipientId -> JournalMsgQueue -> a -> IO a) -> a -> IO a - withAllMsgQueues ms@JournalMsgStore {config} action res = ifM (doesDirectoryExist storePath) processStore (pure res) + withAllMsgQueues :: forall a. Monoid a => JournalMsgStore -> (RecipientId -> JournalMsgQueue -> IO a) -> IO a + withAllMsgQueues ms@JournalMsgStore {config} action = ifM (doesDirectoryExist storePath) processStore (pure mempty) where processStore = do closeMsgStore ms lock <- createLockIO -- the same lock is used for all queues - dirs <- zip [0..] <$> listQueueDirs 0 ("", storePath) - let count = length dirs - res' <- foldM (processQueue lock count) res dirs - progress count count + (!count, !res) <- foldQueues 0 (processQueue lock) (0, mempty) ("", storePath) + progress count putStrLn "" - pure res' + pure res JournalStoreConfig {storePath, pathParts} = config - processQueue queueLock count acc (i :: Int, (queueId, dir)) = do - when (i `mod` 100 == 0) $ progress i count - let statePath = dir queueLogFileName <> "." <> queueId <> logFileExt - queue = JMQueue {queueDirectory = dir, queueLock, statePath} - q <- openMsgQueue ms queue - acc' <- case strDecode $ B.pack queueId of - Right rId -> action rId q acc + processQueue :: Lock -> (Int, a) -> (String, FilePath) -> IO (Int, a) + processQueue queueLock (!i, !r) (queueId, dir) = do + when (i `mod` 100 == 0) $ progress i + let statePath = msgQueueStatePath dir queueId + q <- openMsgQueue ms JMQueue {queueDirectory = dir, queueLock, statePath} + r' <- case strDecode $ B.pack queueId of + Right rId -> action rId q Left e -> do putStrLn ("Error: message queue directory " <> dir <> " is invalid: " <> e) exitFailure closeMsgQueue q - pure acc' - progress i count = do - putStr $ "Processed: " <> show i <> "/" <> show count <> " queues\r" + pure (i + 1, r <> r') + progress i = do + putStr $ "Processed: " <> show i <> " queues\r" IO.hFlush stdout - listQueueDirs depth (queueId, path) - | depth == pathParts - 1 = listDirs - | otherwise = fmap concat . mapM (listQueueDirs (depth + 1)) =<< listDirs + foldQueues depth f acc (queueId, path) = do + let f' = if depth == pathParts - 1 then f else foldQueues (depth + 1) f + listDirs >>= foldM f' acc where listDirs = fmap catMaybes . mapM queuePath =<< listDirectory path queuePath dir = do - let path' = path dir + let !path' = path dir + !queueId' = queueId <> dir ifM (doesDirectoryExist path') - (pure $ Just (queueId <> dir, path')) + (pure $ Just (queueId', path')) (Nothing <$ putStrLn ("Error: path " <> path' <> " is not a directory, skipping")) logQueueStates :: JournalMsgStore -> IO () - logQueueStates ms = withActiveMsgQueues ms (\_ q _ -> logQueueState q) () + logQueueStates ms = withActiveMsgQueues ms $ \_ -> logQueueState logQueueState :: JournalMsgQueue -> IO () logQueueState q = @@ -264,13 +265,13 @@ instance MsgStoreClass JournalMsgStore where getMsgQueue :: JournalMsgStore -> RecipientId -> ExceptT ErrorType IO JournalMsgQueue getMsgQueue ms@JournalMsgStore {queueLocks, msgQueues, random} rId = - tryStore "getMsgQueue" $ withLockMap queueLocks rId "getMsgQueue" $ + tryStore "getMsgQueue" (B.unpack $ strEncode rId) $ withLockMap queueLocks rId "getMsgQueue" $ TM.lookupIO rId msgQueues >>= maybe newQ pure where newQ = do queueLock <- atomically $ getMapLock queueLocks rId let dir = msgQueueDirectory ms rId - statePath = dir (queueLogFileName <> "." <> B.unpack (strEncode rId) <> logFileExt) + statePath = msgQueueStatePath dir $ B.unpack (strEncode rId) queue = JMQueue {queueDirectory = dir, queueLock, statePath} q <- ifM (doesDirectoryExist dir) (openMsgQueue ms queue) (createQ queue) atomically $ TM.insert rId q msgQueues @@ -306,8 +307,8 @@ instance MsgStoreClass JournalMsgStore where (msg :) <$> getMsg msgs hs writeMsg :: JournalMsgStore -> JournalMsgQueue -> Bool -> Message -> ExceptT ErrorType IO (Maybe (Message, Bool)) - writeMsg ms q@JournalMsgQueue {queue = JMQueue {queueDirectory, queueLock, statePath}, handles} logState !msg = - tryStore "writeMsg" $ withLock' queueLock "writeMsg" $ do + writeMsg ms q@JournalMsgQueue {queue = JMQueue {queueDirectory, statePath}, handles} logState msg = + isolateQueue q "writeMsg" $ StoreIO $ do st@MsgQueueState {canWrite, size} <- readTVarIO (state q) let empty = size == 0 if canWrite || empty @@ -319,8 +320,8 @@ instance MsgStoreClass JournalMsgStore where else pure Nothing where JournalStoreConfig {quota, maxMsgCount} = config ms - !msgQuota = MessageQuota {msgId = msgId msg, msgTs = msgTs msg} - writeToJournal st@MsgQueueState {writeState, readState = rs, size} canWrt' msg' = do + msgQuota = MessageQuota {msgId = msgId msg, msgTs = msgTs msg} + writeToJournal 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 @@ -332,9 +333,9 @@ instance MsgStoreClass JournalMsgStore where ws' = ws {msgPos = msgPos', msgCount = msgPos', bytePos = bytePos', byteCount = bytePos'} rs' = if journalId ws == journalId rs then rs {msgCount = msgPos', byteCount = bytePos'} else rs !st' = st {writeState = ws', readState = rs', canWrite = canWrt', size = size + 1} - when (size == 0) $ atomically $ writeTVar (tipMsg q) $ Just (Just (msg, msgLen)) hAppend wh (bytePos ws) msgStr - updateQueueState q logState hs st' + updateQueueState q logState hs st' $ + when (size == 0) $ writeTVar (tipMsg q) $ Just (Just (msg, msgLen)) where createQueueDir = do createDirectoryIfMissing True queueDirectory @@ -377,19 +378,21 @@ instance MsgStoreClass JournalMsgStore where $>>= \hs -> updateReadPos q logState len hs $> Just () isolateQueue :: JournalMsgQueue -> String -> StoreIO a -> ExceptT ErrorType IO a - isolateQueue q op (StoreIO a) = tryStore op $ withLock' (queueLock $ queue q) op $ a + isolateQueue JournalMsgQueue {queue = q} op = + tryStore op (queueDirectory q) . withLock' (queueLock q) op . unStoreIO -tryStore :: String -> IO a -> ExceptT ErrorType IO a -tryStore op a = - ExceptT $ - (Right <$> a) `catchAny` \e -> - let e' = op <> " " <> show e - in logError ("STORE ERROR " <> T.pack e') $> Left (STORE e') +tryStore :: String -> String -> IO a -> ExceptT ErrorType IO a +tryStore op qId a = ExceptT $ E.mask_ $ E.try a >>= bimapM storeErr pure + where + storeErr :: E.SomeException -> IO ErrorType + storeErr e = + let e' = intercalate ", " [op, qId, show e] + in logError ("STORE: " <> T.pack e') $> STORE e' openMsgQueue :: JournalMsgStore -> JMQueue -> IO JournalMsgQueue openMsgQueue ms q@JMQueue {queueDirectory = dir, statePath} = do (st, sh) <- readWriteQueueState ms statePath - (st', rh, wh_) <- openJournals dir st + (st', rh, wh_) <- closeOnException sh $ openJournals dir st sh let hs = MsgQueueHandles {stateHandle = sh, readHandle = rh, writeHandle = wh_} mkJournalQueue q (st', Just hs) @@ -413,19 +416,19 @@ chooseReadJournal q log' hs = do removeJournal (queueDirectory $ queue q) rs let !rs' = (newJournalState $ journalId ws) {msgCount = msgCount ws, byteCount = byteCount ws} !st' = st {readState = rs'} - updateQueueState q log' hs st' + updateQueueState q log' hs st' $ pure () pure $ Just (rs', wh) _ | msgPos rs >= msgCount rs && journalId rs == journalId ws -> pure Nothing _ -> pure $ Just (rs, readHandle hs) -updateQueueState :: JournalMsgQueue -> Bool -> MsgQueueHandles -> MsgQueueState -> IO () -updateQueueState q log' hs st = do - unless (validQueueState st) $ E.throwIO $ userError $ "updating to invalid state: " <> show st +updateQueueState :: JournalMsgQueue -> 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 - atomically $ writeTVar (state q) st + atomically $ writeTVar (state q) st >> a appendState :: Handle -> MsgQueueState -> IO () -appendState h st = B.hPutStr h $ strEncode st `B.snoc` '\n' +appendState h st = E.uninterruptibleMask_ $ B.hPutStr h $ strEncode st `B.snoc` '\n' updateReadPos :: JournalMsgQueue -> Bool -> Int64 -> MsgQueueHandles -> IO () updateReadPos q log' len hs = do @@ -434,8 +437,7 @@ updateReadPos q log' len hs = do let msgPos' = msgPos + 1 rs' = rs {msgPos = msgPos', bytePos = bytePos + len} st' = st {readState = rs', size = size - 1} - updateQueueState q log' hs st' - atomically $ writeTVar (tipMsg q) Nothing + updateQueueState q log' hs st' $ writeTVar (tipMsg q) Nothing msgQueueDirectory :: JournalMsgStore -> RecipientId -> FilePath msgQueueDirectory JournalMsgStore {config = JournalStoreConfig {storePath, pathParts}} rId = @@ -447,6 +449,9 @@ msgQueueDirectory JournalMsgStore {config = JournalStoreConfig {storePath, pathP let (seg, s') = B.splitAt 2 s in seg : splitSegments (n - 1) s' +msgQueueStatePath :: FilePath -> String -> FilePath +msgQueueStatePath dir queueId = dir (queueLogFileName <> "." <> queueId <> logFileExt) + createNewJournal :: FilePath -> ByteString -> IO Handle createNewJournal dir journalId = do let path = journalFilePath dir journalId -- TODO retry if file exists @@ -457,33 +462,33 @@ createNewJournal dir journalId = do newJournalId :: TVar StdGen -> IO ByteString newJournalId g = strEncode <$> atomically (stateTVar g $ genByteString 12) -openJournals :: FilePath -> MsgQueueState -> IO (MsgQueueState, Handle, Maybe Handle) -openJournals dir st@MsgQueueState {readState = rs, writeState = ws} = do - -- TODO verify that file exists, what to do if it's not, or if its state diverges - -- TODO check current position matches state, fix if not +openJournals :: FilePath -> MsgQueueState -> Handle -> IO (MsgQueueState, Handle, Maybe Handle) +openJournals dir st@MsgQueueState {readState = rs, writeState = ws} sh = do let rjId = journalId rs wjId = journalId ws openJournal rs >>= \case Left path -> do - logError $ "STORE ERROR no read file " <> T.pack path <> ", creating new file" + logError $ "STORE: openJournals, no read file - creating new file, " <> T.pack path rh <- createNewJournal dir rjId let st' = newMsgQueueState rjId + closeOnException rh $ appendState sh st' pure (st', rh, Nothing) Right rh | rjId == wjId -> do - fixFileSize rh $ bytePos ws + closeOnException rh $ fixFileSize rh $ bytePos ws pure (st, rh, Nothing) - | otherwise -> do + | otherwise -> closeOnException rh $ do fixFileSize rh $ byteCount rs openJournal ws >>= \case Left path -> do - logError $ "STORE ERROR no write file " <> T.pack path <> ", creating new file" + logError $ "STORE: openJournals, no write file - creating new file, " <> T.pack path wh <- createNewJournal dir wjId let size' = msgCount rs - msgPos rs st' = st {writeState = newJournalState wjId, size = size'} -- we don't amend canWrite to trigger QCONT + closeOnException wh $ appendState sh st' pure (st', rh, Just wh) Right wh -> do - fixFileSize wh $ bytePos ws + closeOnException wh $ fixFileSize wh $ bytePos ws pure (st, rh, Just wh) where openJournal :: JournalState t -> IO (Either FilePath Handle) @@ -498,17 +503,19 @@ fixFileSize h pos = do size <- IO.hFileSize h if | size > pos' -> do - logWarn $ "STORE WARNING truncating file size from " <> tshow size <> " to " <> tshow pos + name <- IO.hShow h + logWarn $ "STORE: fixFileSize, size " <> tshow size <> " > pos " <> tshow pos <> " - truncating, " <> T.pack name IO.hSetFileSize h pos' - | size < pos' -> + | size < pos' -> do -- From code logic this can't happen. - E.throwIO $ userError $ "file size " <> show size <> " is smaller than position " <> show pos + name <- IO.hShow h + E.throwIO $ userError $ "fixFileSize size " <> show size <> " < pos " <> show pos <> " - aborting: " <> name | otherwise -> pure () removeJournal :: FilePath -> JournalState t -> IO () removeJournal dir JournalState {journalId} = do let path = journalFilePath dir journalId - removeFile path `catchAny` (\e -> logError $ "STORE ERROR removing file " <> T.pack path <> ": " <> tshow e) + removeFile path `catchAny` (\e -> logError $ "STORE: removeJournal, " <> T.pack path <> ", " <> tshow e) -- This function is supposed to be resilient to crashes while updating state files, -- and also resilient to crashes during its execution. @@ -526,10 +533,10 @@ readWriteQueueState JournalMsgStore {random, config} statePath = [] -> writeNewQueueState _ -> do r@(st, _) <- useLastLine (length ls) True ls - unless (validQueueState st) $ E.throwIO $ userError $ "read invalid invalid: " <> show st + unless (validQueueState st) $ E.throwIO $ userError $ "readWriteQueueState inconsistent state: " <> show st pure r writeNewQueueState = do - logWarn $ "STORE WARNING: empty queue state in " <> T.pack statePath <> ", initialized" + logWarn $ "STORE: readWriteQueueState, empty queue state - initialized, " <> T.pack statePath st <- newMsgQueueState <$> newJournalId random writeQueueState st useLastLine len isLastLine ls = case strDecode $ LB.toStrict $ last ls of @@ -543,13 +550,13 @@ readWriteQueueState JournalMsgStore {random, config} statePath = Left e -- if the last line failed to parse | isLastLine -> case init ls of -- or use the previous line [] -> do - logWarn $ "STORE WARNING: invalid 1-line queue state " <> T.pack statePath <> ", initialized" + logWarn $ "STORE: readWriteQueueState, invalid 1-line queue state - initialized, " <> T.pack statePath st <- newMsgQueueState <$> newJournalId random backupWriteQueueState st ls' -> do - logWarn $ "STORE WARNING: invalid last line in queue state " <> T.pack statePath <> ", using the previous line" + logWarn $ "STORE: readWriteQueueState, invalid last line in queue state - using the previous line, " <> T.pack statePath useLastLine len False ls' - | otherwise -> E.throwIO $ userError $ "reading queue state " <> statePath <> ": " <> show e + | otherwise -> E.throwIO $ userError $ "readWriteQueueState invalid state " <> statePath <> ": " <> show e backupWriteQueueState st = do -- State backup is made in two steps to mitigate the crash during the backup. -- Temporary backup file will be used when it is present. @@ -560,7 +567,7 @@ readWriteQueueState JournalMsgStore {random, config} statePath = pure r writeQueueState st = do sh <- openFile statePath AppendMode - appendState sh st + closeOnException sh $ appendState sh st pure (st, sh) validQueueState :: MsgQueueState -> Bool @@ -598,7 +605,7 @@ closeMsgQueue q = readTVarIO (handles q) >>= mapM_ closeHandles removeQueueDirectory :: JournalMsgStore -> RecipientId -> IO () removeQueueDirectory st rId = let dir = msgQueueDirectory st rId - in removePathForcibly dir `catchAny` (\e -> logError $ "STORE ERROR removeQueueDirectory " <> T.pack dir <> ": " <> tshow e) + in removePathForcibly dir `catchAny` (\e -> logError $ "STORE: removeQueueDirectory, " <> T.pack dir <> ", " <> tshow e) hAppend :: Handle -> Int64 -> ByteString -> IO () hAppend h pos s = do @@ -614,7 +621,7 @@ hGetMsgAt h pos = do Right !msg -> let !len = fromIntegral (B.length s) + 1 in pure (msg, len) - Left e -> E.throwIO $ userError $ "Error parsing message: " <> e + Left e -> E.throwIO $ userError $ "hGetMsgAt invalid message: " <> e openFile :: FilePath -> IOMode -> IO Handle openFile f mode = do @@ -623,4 +630,7 @@ openFile f mode = do pure h hClose :: Handle -> IO () -hClose h = IO.hClose h `catchAny` (\e -> logError $ "Error closing file" <> tshow e) +hClose h = IO.hClose h `catchAny` (\e -> logError $ "STORE: hClose, error closing file, " <> tshow e) + +closeOnException :: Handle -> IO a -> IO a +closeOnException h a = a `E.onException` hClose h diff --git a/src/Simplex/Messaging/Server/MsgStore/STM.hs b/src/Simplex/Messaging/Server/MsgStore/STM.hs index b08e99abe..f70a1e71d 100644 --- a/src/Simplex/Messaging/Server/MsgStore/STM.hs +++ b/src/Simplex/Messaging/Server/MsgStore/STM.hs @@ -96,7 +96,7 @@ instance MsgStoreClass STMMsgStore where pure msgs writeMsg :: STMMsgStore -> STMMsgQueue -> Bool -> Message -> ExceptT ErrorType IO (Maybe (Message, Bool)) - writeMsg _ STMMsgQueue {msgQueue = q, quota, canWrite, size} _logState !msg = liftIO $ atomically $ do + writeMsg _ STMMsgQueue {msgQueue = q, quota, canWrite, size} _logState msg = liftIO $ atomically $ do canWrt <- readTVar canWrite empty <- isEmptyTQueue q if canWrt || empty @@ -105,11 +105,11 @@ instance MsgStoreClass STMMsgStore where writeTVar canWrite $! canWrt' modifyTVar' size (+ 1) if canWrt' - then writeTQueue q msg $> Just (msg, empty) - else writeTQueue q msgQuota $> Nothing + then (writeTQueue q $! msg) $> Just (msg, empty) + else (writeTQueue q $! msgQuota) $> Nothing else pure Nothing where - !msgQuota = MessageQuota {msgId = msgId msg, msgTs = msgTs msg} + msgQuota = MessageQuota {msgId = msgId msg, msgTs = msgTs msg} setOverQuota_ :: STMMsgQueue -> IO () setOverQuota_ q = atomically $ writeTVar (canWrite q) False diff --git a/src/Simplex/Messaging/Server/MsgStore/Types.hs b/src/Simplex/Messaging/Server/MsgStore/Types.hs index cd480b0ae..718aa95ca 100644 --- a/src/Simplex/Messaging/Server/MsgStore/Types.hs +++ b/src/Simplex/Messaging/Server/MsgStore/Types.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} @@ -9,6 +10,7 @@ module Simplex.Messaging.Server.MsgStore.Types where import Control.Concurrent.STM +import Control.Monad (foldM) import Control.Monad.Trans.Except import Data.Int (Int64) import Data.Kind @@ -24,7 +26,7 @@ class Monad (StoreMonad s) => MsgStoreClass s where newMsgStore :: MsgStoreConfig s -> IO s closeMsgStore :: s -> IO () activeMsgQueues :: s -> TMap RecipientId (MsgQueue s) - withAllMsgQueues :: s -> (RecipientId -> MsgQueue s -> a -> IO a) -> a -> IO a + withAllMsgQueues :: Monoid a => s -> (RecipientId -> MsgQueue s -> IO a) -> IO a logQueueStates :: s -> IO () logQueueState :: MsgQueue s -> IO () getMsgQueue :: s -> RecipientId -> ExceptT ErrorType IO (MsgQueue s) @@ -46,8 +48,12 @@ data SMSType :: MSType -> Type where data AMSType = forall s. AMSType (SMSType s) -withActiveMsgQueues :: MsgStoreClass s => s -> (RecipientId -> MsgQueue s -> a -> IO a) -> a -> IO a -withActiveMsgQueues st f a = readTVarIO (activeMsgQueues st) >>= M.foldrWithKey (\k v -> (>>= f k v)) (pure a) +withActiveMsgQueues :: (MsgStoreClass s, Monoid a) => s -> (RecipientId -> MsgQueue s -> IO a) -> IO a +withActiveMsgQueues st f = readTVarIO (activeMsgQueues st) >>= foldM run mempty . M.assocs + where + run !acc (k, v) = do + r <- f k v + pure $! acc <> r tryPeekMsg :: MsgStoreClass s => MsgQueue s -> ExceptT ErrorType IO (Maybe Message) tryPeekMsg mq = isolateQueue mq "tryPeekMsg" $ tryPeekMsg_ mq From a3351ad0600651422926c918bbdb8581880ae94c Mon Sep 17 00:00:00 2001 From: Evgeny Date: Fri, 25 Oct 2024 09:11:47 +0100 Subject: [PATCH 6/8] smp server: fix export of journal storage (#1384) * smp: fix export of journal storage * catch errors when exporting messages --- src/Simplex/Messaging/Server.hs | 8 ++++++-- .../Messaging/Server/MsgStore/Journal.hs | 7 ++++--- tests/CoreTests/MsgStoreTests.hs | 20 +++++++++++++------ 3 files changed, 24 insertions(+), 11 deletions(-) diff --git a/src/Simplex/Messaging/Server.hs b/src/Simplex/Messaging/Server.hs index 7b539ec69..81c995bb2 100644 --- a/src/Simplex/Messaging/Server.hs +++ b/src/Simplex/Messaging/Server.hs @@ -1748,8 +1748,12 @@ saveServerMessages drainMsgs = exportMessages :: MsgStoreClass s => s -> FilePath -> Bool -> IO () exportMessages ms f drainMsgs = do logInfo $ "saving messages to file " <> T.pack f - Sum total <- liftIO $ withFile f WriteMode $ withAllMsgQueues ms . saveQueueMsgs - logInfo $ "messages saved: " <> tshow total + liftIO $ withFile f WriteMode $ \h -> + tryAny (withAllMsgQueues ms $ saveQueueMsgs h) >>= \case + Right (Sum total) -> logInfo $ "messages saved: " <> tshow total + Left e -> do + logError $ "error exporting messages: " <> tshow e + exitFailure where saveQueueMsgs h rId q = getQueueMessages drainMsgs q >>= \msgs -> Sum (length msgs) <$ BLD.hPutBuilder h (encodeMessages rId msgs) encodeMessages rId = mconcat . map (\msg -> BLD.byteString (strEncode $ MLRv3 rId msg) <> BLD.char8 '\n') diff --git a/src/Simplex/Messaging/Server/MsgStore/Journal.hs b/src/Simplex/Messaging/Server/MsgStore/Journal.hs index b87b53dd7..f98b5222a 100644 --- a/src/Simplex/Messaging/Server/MsgStore/Journal.hs +++ b/src/Simplex/Messaging/Server/MsgStore/Journal.hs @@ -297,14 +297,15 @@ instance MsgStoreClass JournalMsgStore where pure sz getQueueMessages :: Bool -> JournalMsgQueue -> IO [Message] - getQueueMessages drainMsgs q = readTVarIO (handles q) >>= maybe (pure []) (getMsg []) + getQueueMessages drainMsgs q = run [] where + run msgs = readTVarIO (handles q) >>= maybe (pure []) (getMsg msgs) getMsg msgs hs = chooseReadJournal q drainMsgs hs >>= maybe (pure msgs) readMsg where readMsg (rs, h) = do (msg, len) <- hGetMsgAt h $ bytePos rs updateReadPos q drainMsgs len hs - (msg :) <$> getMsg msgs hs + (msg :) <$> run msgs writeMsg :: JournalMsgStore -> JournalMsgQueue -> Bool -> Message -> ExceptT ErrorType IO (Maybe (Message, Bool)) writeMsg ms q@JournalMsgQueue {queue = JMQueue {queueDirectory, statePath}, handles} logState msg = @@ -413,7 +414,7 @@ chooseReadJournal q log' hs = do -- switching to write journal atomically $ writeTVar (handles q) $ Just hs {readHandle = wh, writeHandle = Nothing} hClose $ readHandle hs - removeJournal (queueDirectory $ queue q) rs + when log' $ removeJournal (queueDirectory $ queue q) rs let !rs' = (newJournalState $ journalId ws) {msgCount = msgCount ws, byteCount = byteCount ws} !st' = st {readState = rs'} updateQueueState q log' hs st' $ pure () diff --git a/tests/CoreTests/MsgStoreTests.hs b/tests/CoreTests/MsgStoreTests.hs index eaa9cc25b..fc00317a0 100644 --- a/tests/CoreTests/MsgStoreTests.hs +++ b/tests/CoreTests/MsgStoreTests.hs @@ -153,21 +153,29 @@ testExportImportStore ms = do Just (Message {}, True) <- write q1 "message 1" Just (Message {}, False) <- write q1 "message 2" q2 <- getMsgQueue ms rId2 - Just (Message {}, True) <- write q2 "message 3" - Just (Message {}, False) <- write q2 "message 4" - Just (Message {}, False) <- write q2 "message 5" - Nothing <- write q2 "message 6" + 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 q2 mId3 + (Msg "message 4", Nothing) <- tryDelPeekMsg 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` 2 + length <$> listDirectory (msgQueueDirectory ms rId2) `shouldReturn` 3 exportMessages ms testStoreMsgsFile False + renameFile testStoreMsgsFile (testStoreMsgsFile <> ".copy") + closeMsgStore ms + exportMessages ms testStoreMsgsFile False + (B.readFile testStoreMsgsFile `shouldReturn`) =<< B.readFile (testStoreMsgsFile <> ".copy") let cfg = (testJournalStoreCfg :: JournalStoreConfig) {storePath = testStoreMsgsDir2} ms' <- newMsgStore cfg stats@MessageStats {storedMsgsCount = 5, expiredMsgsCount = 0, storedQueues = 2} <- importMessages ms' testStoreMsgsFile Nothing printMessageStats "Messages" stats length <$> listDirectory (msgQueueDirectory ms rId1) `shouldReturn` 2 - length <$> listDirectory (msgQueueDirectory ms rId2) `shouldReturn` 3 -- state file is backed up + length <$> listDirectory (msgQueueDirectory ms rId2) `shouldReturn` 4 -- state file is backed up, 2 message files exportMessages ms' testStoreMsgsFile2 False (B.readFile testStoreMsgsFile2 `shouldReturn`) =<< B.readFile (testStoreMsgsFile <> ".bak") stmStore <- newMsgStore testSMTStoreConfig From 56ca7bf30e813648d13cea6f3d13336bb9af25ad Mon Sep 17 00:00:00 2001 From: Evgeny Date: Sat, 26 Oct 2024 10:33:18 +0100 Subject: [PATCH 7/8] smp server: do not log progress when server starts (#1390) * smp server: do not log progress when server starts * test --- src/Simplex/Messaging/Server.hs | 26 +++++++++---------- src/Simplex/Messaging/Server/Main.hs | 4 +-- .../Messaging/Server/MsgStore/Journal.hs | 13 ++++------ src/Simplex/Messaging/Server/MsgStore/STM.hs | 2 +- .../Messaging/Server/MsgStore/Types.hs | 2 +- tests/CoreTests/MsgStoreTests.hs | 12 ++++----- tests/ServerTests.hs | 2 +- 7 files changed, 28 insertions(+), 33 deletions(-) diff --git a/src/Simplex/Messaging/Server.hs b/src/Simplex/Messaging/Server.hs index 81c995bb2..38d718fd2 100644 --- a/src/Simplex/Messaging/Server.hs +++ b/src/Simplex/Messaging/Server.hs @@ -1739,17 +1739,17 @@ saveServerMessages :: Bool -> M () saveServerMessages drainMsgs = asks msgStore >>= \case AMS SMSMemory ms@STMMsgStore {storeConfig = STMStoreConfig {storePath}} -> case storePath of - Just f -> liftIO $ exportMessages ms f drainMsgs + Just f -> liftIO $ exportMessages False ms f drainMsgs Nothing -> logInfo "undelivered messages are not saved" AMS SMSJournal ms -> do liftIO $ closeMsgStore ms logInfo "closed journal message storage" -exportMessages :: MsgStoreClass s => s -> FilePath -> Bool -> IO () -exportMessages ms f drainMsgs = do +exportMessages :: MsgStoreClass s => Bool -> s -> FilePath -> Bool -> IO () +exportMessages tty ms f drainMsgs = do logInfo $ "saving messages to file " <> T.pack f liftIO $ withFile f WriteMode $ \h -> - tryAny (withAllMsgQueues ms $ saveQueueMsgs h) >>= \case + tryAny (withAllMsgQueues tty ms $ saveQueueMsgs h) >>= \case Right (Sum total) -> logInfo $ "messages saved: " <> tshow total Left e -> do logError $ "error exporting messages: " <> tshow e @@ -1766,15 +1766,15 @@ processServerMessages = do processMessages :: Maybe Int64 -> AMsgStore -> IO MessageStats processMessages old_ = \case AMS SMSMemory ms@STMMsgStore {storeConfig = STMStoreConfig {storePath}} -> case storePath of - Just f -> ifM (doesFileExist f) (importMessages ms f old_) (pure newMessageStats) + Just f -> ifM (doesFileExist f) (importMessages False ms f old_) (pure newMessageStats) Nothing -> pure newMessageStats AMS SMSJournal ms -> case old_ of Just old -> do logInfo "expiring journal store messages..." - withAllMsgQueues ms $ \_ -> processExpireQueue old + withAllMsgQueues False ms $ \_ -> processExpireQueue old Nothing -> do logInfo "validating journal store messages..." - withAllMsgQueues ms $ \_ -> processValidateQueue + withAllMsgQueues False ms $ \_ -> processValidateQueue where processExpireQueue old q = runExceptT expireQueue >>= \case @@ -1793,8 +1793,8 @@ processServerMessages = do processValidateQueue q = getQueueSize q >>= \storedMsgsCount -> pure mempty {storedMsgsCount, storedQueues = 1} -importMessages :: forall s. MsgStoreClass s => s -> FilePath -> Maybe Int64 -> IO MessageStats -importMessages ms f old_ = do +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)) . zip [0..] . LB.lines >>= \case Left e -> do @@ -1802,19 +1802,17 @@ importMessages ms f old_ = do logError . T.pack $ "error restoring messages: " <> e liftIO exitFailure Right (lineCount, _, (storedMsgsCount, expiredMsgsCount, overQuota)) -> do - putStrLn $ "Processed " <> show lineCount <> " lines" + putStrLn $ progress lineCount renameFile f $ f <> ".bak" mapM_ setOverQuota_ overQuota logQueueStates ms storedQueues <- M.size <$> readTVarIO (activeMsgQueues ms) pure MessageStats {storedMsgsCount, expiredMsgsCount, storedQueues} where - progress i = do - liftIO $ putStr $ "Processed " <> show i <> " lines\r" - hFlush stdout + progress i = "Processed " <> show i <> " lines" restoreMsg :: (Int, Maybe (RecipientId, MsgQueue s), (Int, Int, M.Map RecipientId (MsgQueue s))) -> (Int, LB.ByteString) -> ExceptT String IO (Int, Maybe (RecipientId, MsgQueue s), (Int, Int, M.Map RecipientId (MsgQueue s))) restoreMsg (!lineCount, q_, (!stored, !expired, !overQuota)) (i, s') = do - when (i `mod` 1000 == 0) $ progress i + when (tty && i `mod` 1000 == 0) $ liftIO $ putStr (progress i <> "\r") MLRv3 rId msg <- liftEither . first (msgErr "parsing") $ strDecode s liftError show $ addToMsgQueue rId msg where diff --git a/src/Simplex/Messaging/Server/Main.hs b/src/Simplex/Messaging/Server/Main.hs index f728e6be8..d3eab5f33 100644 --- a/src/Simplex/Messaging/Server/Main.hs +++ b/src/Simplex/Messaging/Server/Main.hs @@ -99,7 +99,7 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath = ("WARNING: message log file " <> storeMsgsFilePath <> " will be imported to journal directory " <> storeMsgsJournalDir) "Messages not imported" ms <- newJournalMsgStore - msgStats <- importMessages ms storeMsgsFilePath Nothing -- no expiration + msgStats <- importMessages True ms storeMsgsFilePath Nothing -- no expiration putStrLn "Import completed" printMessageStats "Messages" msgStats putStrLn $ case readMsgStoreType ini of @@ -116,7 +116,7 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath = ("WARNING: journal directory " <> storeMsgsJournalDir <> " will be exported to message log file " <> storeMsgsFilePath) "Journal not exported" ms <- newJournalMsgStore - exportMessages ms storeMsgsFilePath False + exportMessages True ms storeMsgsFilePath False putStrLn "Export completed" putStrLn $ case readMsgStoreType ini of Right (AMSType SMSMemory) -> "store_messages set to `memory`" diff --git a/src/Simplex/Messaging/Server/MsgStore/Journal.hs b/src/Simplex/Messaging/Server/MsgStore/Journal.hs index f98b5222a..5324c9997 100644 --- a/src/Simplex/Messaging/Server/MsgStore/Journal.hs +++ b/src/Simplex/Messaging/Server/MsgStore/Journal.hs @@ -216,20 +216,19 @@ instance MsgStoreClass JournalMsgStore 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 => JournalMsgStore -> (RecipientId -> JournalMsgQueue -> IO a) -> IO a - withAllMsgQueues ms@JournalMsgStore {config} action = ifM (doesDirectoryExist storePath) processStore (pure mempty) + withAllMsgQueues :: forall a. Monoid a => Bool -> JournalMsgStore -> (RecipientId -> JournalMsgQueue -> IO a) -> IO a + withAllMsgQueues tty ms@JournalMsgStore {config} action = ifM (doesDirectoryExist storePath) processStore (pure mempty) where processStore = do closeMsgStore ms lock <- createLockIO -- the same lock is used for all queues (!count, !res) <- foldQueues 0 (processQueue lock) (0, mempty) ("", storePath) - progress count - putStrLn "" + putStrLn $ progress count pure res JournalStoreConfig {storePath, pathParts} = config processQueue :: Lock -> (Int, a) -> (String, FilePath) -> IO (Int, a) processQueue queueLock (!i, !r) (queueId, dir) = do - when (i `mod` 100 == 0) $ progress i + when (tty && i `mod` 100 == 0) $ putStr (progress i <> "\r") >> IO.hFlush stdout let statePath = msgQueueStatePath dir queueId q <- openMsgQueue ms JMQueue {queueDirectory = dir, queueLock, statePath} r' <- case strDecode $ B.pack queueId of @@ -239,9 +238,7 @@ instance MsgStoreClass JournalMsgStore where exitFailure closeMsgQueue q pure (i + 1, r <> r') - progress i = do - putStr $ "Processed: " <> show i <> " queues\r" - IO.hFlush stdout + 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 listDirs >>= foldM f' acc diff --git a/src/Simplex/Messaging/Server/MsgStore/STM.hs b/src/Simplex/Messaging/Server/MsgStore/STM.hs index f70a1e71d..1b27b6a10 100644 --- a/src/Simplex/Messaging/Server/MsgStore/STM.hs +++ b/src/Simplex/Messaging/Server/MsgStore/STM.hs @@ -57,7 +57,7 @@ instance MsgStoreClass STMMsgStore where activeMsgQueues = msgQueues {-# INLINE activeMsgQueues #-} - withAllMsgQueues = withActiveMsgQueues + withAllMsgQueues _ = withActiveMsgQueues {-# INLINE withAllMsgQueues #-} logQueueStates _ = pure () diff --git a/src/Simplex/Messaging/Server/MsgStore/Types.hs b/src/Simplex/Messaging/Server/MsgStore/Types.hs index 718aa95ca..0486804f3 100644 --- a/src/Simplex/Messaging/Server/MsgStore/Types.hs +++ b/src/Simplex/Messaging/Server/MsgStore/Types.hs @@ -26,7 +26,7 @@ class Monad (StoreMonad s) => MsgStoreClass s where newMsgStore :: MsgStoreConfig s -> IO s closeMsgStore :: s -> IO () activeMsgQueues :: s -> TMap RecipientId (MsgQueue s) - withAllMsgQueues :: Monoid a => s -> (RecipientId -> MsgQueue s -> IO a) -> IO a + withAllMsgQueues :: Monoid a => Bool -> s -> (RecipientId -> MsgQueue s -> IO a) -> IO a logQueueStates :: s -> IO () logQueueState :: MsgQueue s -> IO () getMsgQueue :: s -> RecipientId -> ExceptT ErrorType IO (MsgQueue s) diff --git a/tests/CoreTests/MsgStoreTests.hs b/tests/CoreTests/MsgStoreTests.hs index fc00317a0..4a5d95eb2 100644 --- a/tests/CoreTests/MsgStoreTests.hs +++ b/tests/CoreTests/MsgStoreTests.hs @@ -164,24 +164,24 @@ testExportImportStore ms = do pure () length <$> listDirectory (msgQueueDirectory ms rId1) `shouldReturn` 2 length <$> listDirectory (msgQueueDirectory ms rId2) `shouldReturn` 3 - exportMessages ms testStoreMsgsFile False + exportMessages False ms testStoreMsgsFile False renameFile testStoreMsgsFile (testStoreMsgsFile <> ".copy") closeMsgStore ms - exportMessages ms testStoreMsgsFile False + exportMessages False ms testStoreMsgsFile False (B.readFile testStoreMsgsFile `shouldReturn`) =<< B.readFile (testStoreMsgsFile <> ".copy") let cfg = (testJournalStoreCfg :: JournalStoreConfig) {storePath = testStoreMsgsDir2} ms' <- newMsgStore cfg stats@MessageStats {storedMsgsCount = 5, expiredMsgsCount = 0, storedQueues = 2} <- - importMessages ms' testStoreMsgsFile Nothing + importMessages False ms' testStoreMsgsFile Nothing printMessageStats "Messages" stats length <$> listDirectory (msgQueueDirectory ms rId1) `shouldReturn` 2 length <$> listDirectory (msgQueueDirectory ms rId2) `shouldReturn` 4 -- state file is backed up, 2 message files - exportMessages ms' testStoreMsgsFile2 False + exportMessages False ms' testStoreMsgsFile2 False (B.readFile testStoreMsgsFile2 `shouldReturn`) =<< B.readFile (testStoreMsgsFile <> ".bak") stmStore <- newMsgStore testSMTStoreConfig MessageStats {storedMsgsCount = 5, expiredMsgsCount = 0, storedQueues = 2} <- - importMessages stmStore testStoreMsgsFile2 Nothing - exportMessages stmStore testStoreMsgsFile False + importMessages False stmStore testStoreMsgsFile2 Nothing + exportMessages False stmStore testStoreMsgsFile False (B.sort <$> B.readFile testStoreMsgsFile `shouldReturn`) =<< (B.sort <$> B.readFile (testStoreMsgsFile2 <> ".bak")) testQueueState :: JournalMsgStore -> IO () diff --git a/tests/ServerTests.hs b/tests/ServerTests.hs index c133d94fc..e80d39897 100644 --- a/tests/ServerTests.hs +++ b/tests/ServerTests.hs @@ -813,7 +813,7 @@ testRestoreExpireMessages = AMSType SMSJournal -> do ms <- newMsgStore testJournalStoreCfg {quota = 4} removeFileIfExists testStoreMsgsFile - exportMessages ms testStoreMsgsFile False + exportMessages False ms testStoreMsgsFile False AMSType SMSMemory -> pure () runTest :: Transport c => TProxy c -> (THandleSMP c 'TClient -> IO ()) -> ThreadId -> Expectation runTest _ test' server = do From 5940514f40f1e25ede535f4bb6502a5bc6e5321e Mon Sep 17 00:00:00 2001 From: Evgeny Date: Sat, 26 Oct 2024 16:14:55 +0100 Subject: [PATCH 8/8] smp server: remove queue from map when closing, test (#1392) * smp server: remove queue from map when closing, test * remove print * refactor --- cabal.project | 8 +++++ package.yaml | 1 + src/Simplex/Messaging/Server.hs | 4 +-- .../Messaging/Server/MsgStore/Journal.hs | 28 +++++++++------- tests/CoreTests/MsgStoreTests.hs | 32 +++++++++++++++++-- 5 files changed, 57 insertions(+), 16 deletions(-) diff --git a/cabal.project b/cabal.project index 1a4745ffc..b26c04055 100644 --- a/cabal.project +++ b/cabal.project @@ -4,6 +4,14 @@ packages: . -- packages: . ../http2 -- packages: . ../network-transport +-- package * + -- coverage: True + -- library-coverage: True + +-- package attoparsec + -- coverage: False + -- library-coverage: False + index-state: 2023-12-12T00:00:00Z package cryptostore diff --git a/package.yaml b/package.yaml index f4efaf5bc..f3c1e71c5 100644 --- a/package.yaml +++ b/package.yaml @@ -188,6 +188,7 @@ tests: - -rtsopts - -with-rtsopts=-A64M - -with-rtsopts=-N1 + # - -fhpc ghc-options: # - -haddock diff --git a/src/Simplex/Messaging/Server.hs b/src/Simplex/Messaging/Server.hs index 38d718fd2..ea00c9591 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 (JournalMsgQueue (..), JMQueue (..), closeMsgQueue) +import Simplex.Messaging.Server.MsgStore.Journal (JournalMsgQueue (..), JMQueue (..), closeMsgQueueHandles) import Simplex.Messaging.Server.MsgStore.STM import Simplex.Messaging.Server.MsgStore.Types import Simplex.Messaging.Server.NtfStore @@ -1788,7 +1788,7 @@ processServerMessages = do expired'' <- deleteExpiredMsgs q False old stored'' <- liftIO $ getQueueSize q liftIO $ logQueueState q - liftIO $ closeMsgQueue q + liftIO $ closeMsgQueueHandles q pure (stored'', expired'') processValidateQueue q = getQueueSize q >>= \storedMsgsCount -> pure mempty {storedMsgsCount, storedQueues = 1} diff --git a/src/Simplex/Messaging/Server/MsgStore/Journal.hs b/src/Simplex/Messaging/Server/MsgStore/Journal.hs index 5324c9997..d40abc67f 100644 --- a/src/Simplex/Messaging/Server/MsgStore/Journal.hs +++ b/src/Simplex/Messaging/Server/MsgStore/Journal.hs @@ -20,11 +20,13 @@ module Simplex.Messaging.Server.MsgStore.Journal JournalStoreConfig (..), getQueueMessages, closeMsgQueue, + closeMsgQueueHandles, -- below are exported for tests MsgQueueState (..), JournalState (..), SJournalType (..), msgQueueDirectory, + msgQueueStatePath, readWriteQueueState, newMsgQueueState, newJournalId, @@ -47,6 +49,7 @@ import qualified Data.ByteString.Lazy.Char8 as LB import Data.Functor (($>)) import Data.Int (Int64) import Data.List (intercalate) +import qualified Data.Map.Strict as M import Data.Maybe (catMaybes, fromMaybe) import qualified Data.Text as T import Data.Time.Clock (getCurrentTime) @@ -207,7 +210,7 @@ instance MsgStoreClass JournalMsgStore where msgQueues <- TM.emptyIO pure JournalMsgStore {config, random, queueLocks, msgQueues} - closeMsgStore st = readTVarIO (msgQueues st) >>= mapM_ closeMsgQueue + closeMsgStore st = atomically (swapTVar (msgQueues st) M.empty) >>= mapM_ closeMsgQueueHandles activeMsgQueues = msgQueues {-# INLINE activeMsgQueues #-} @@ -236,7 +239,7 @@ instance MsgStoreClass JournalMsgStore where Left e -> do putStrLn ("Error: message queue directory " <> dir <> " is invalid: " <> e) exitFailure - closeMsgQueue q + closeMsgQueueHandles q pure (i + 1, r <> r') progress i = "Processed: " <> show i <> " queues" foldQueues depth f acc (queueId, path) = do @@ -283,15 +286,16 @@ instance MsgStoreClass JournalMsgStore where delMsgQueue :: JournalMsgStore -> RecipientId -> IO () delMsgQueue ms rId = withLockMap (queueLocks ms) rId "delMsgQueue" $ do - void $ deleteMsgQueue_ ms rId + closeMsgQueue ms rId removeQueueDirectory ms rId delMsgQueueSize :: JournalMsgStore -> RecipientId -> IO Int delMsgQueueSize ms rId = withLockMap (queueLocks ms) rId "delMsgQueue" $ do - state_ <- deleteMsgQueue_ ms rId - sz <- maybe (pure $ -1) (fmap size . readTVarIO) state_ + st_ <- + atomically (TM.lookupDelete rId (msgQueues ms)) + >>= mapM (\q -> closeMsgQueueHandles q >> readTVarIO (state q)) removeQueueDirectory ms rId - pure sz + pure $ maybe (-1) size st_ getQueueMessages :: Bool -> JournalMsgQueue -> IO [Message] getQueueMessages drainMsgs q = run [] @@ -587,13 +591,13 @@ validQueueState MsgQueueState {readState = rs, writeState = ws, size} && msgPos ws == msgCount ws && bytePos ws == byteCount ws -deleteMsgQueue_ :: JournalMsgStore -> RecipientId -> IO (Maybe (TVar MsgQueueState)) -deleteMsgQueue_ st rId = - atomically (TM.lookupDelete rId (msgQueues st)) - >>= mapM (\q -> closeMsgQueue q $> state q) +closeMsgQueue :: JournalMsgStore -> RecipientId -> IO () +closeMsgQueue ms rId = + atomically (TM.lookupDelete rId (msgQueues ms)) + >>= mapM_ closeMsgQueueHandles -closeMsgQueue :: JournalMsgQueue -> IO () -closeMsgQueue q = readTVarIO (handles q) >>= mapM_ closeHandles +closeMsgQueueHandles :: JournalMsgQueue -> IO () +closeMsgQueueHandles q = readTVarIO (handles q) >>= mapM_ closeHandles where closeHandles (MsgQueueHandles sh rh wh_) = do hClose sh diff --git a/tests/CoreTests/MsgStoreTests.hs b/tests/CoreTests/MsgStoreTests.hs index 4a5d95eb2..5166ce7ef 100644 --- a/tests/CoreTests/MsgStoreTests.hs +++ b/tests/CoreTests/MsgStoreTests.hs @@ -5,19 +5,21 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# OPTIONS_GHC -fno-warn-ambiguous-fields #-} {-# OPTIONS_GHC -Wno-orphans #-} module CoreTests.MsgStoreTests where -import AgentTests.FunctionalAPITests (runRight_) +import AgentTests.FunctionalAPITests (runRight, runRight_) import Control.Concurrent.STM import Control.Exception (bracket) import Control.Monad import Control.Monad.IO.Class import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B +import qualified Data.ByteString.Base64.URL as B64 import Data.Time.Clock.System (getSystemTime) import Simplex.Messaging.Crypto (pattern MaxLenBS) import qualified Simplex.Messaging.Crypto as C @@ -41,6 +43,7 @@ msgStoreTests = do 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 where someMsgStoreTests :: MsgStoreClass s => SpecWith s someMsgStoreTests = do @@ -189,7 +192,7 @@ testQueueState ms = do g <- C.newRandom rId <- EntityId <$> atomically (C.randomBytes 24 g) let dir = msgQueueDirectory ms rId - statePath = dir (queueLogFileName <> logFileExt) + statePath = msgQueueStatePath dir $ B.unpack (B64.encode $ unEntityId rId) createDirectoryIfMissing True dir state <- newMsgQueueState <$> newJournalId (random ms) withFile statePath WriteMode (`appendState` state) @@ -248,3 +251,28 @@ testQueueState ms = do forM_ names $ \name -> let f = dir name in unless (f == keep) $ removeFile f + +testMessageState :: JournalMsgStore -> IO () +testMessageState 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) + write q s = writeMsg ms q True =<< mkMessage s + + mId1 <- runRight $ do + q <- getMsgQueue ms rId + Just (Message {msgId = mId1}, True) <- write q "message 1" + Just (Message {}, False) <- write q "message 2" + liftIO $ closeMsgQueue ms rId + pure mId1 + + ls <- B.lines <$> B.readFile statePath + B.writeFile statePath $ B.unlines $ take (length ls - 1) ls + + runRight_ $ do + q <- getMsgQueue ms rId + Just (Message {msgId = mId3}, False) <- write q "message 3" + (Msg "message 1", Msg "message 3") <- tryDelPeekMsg q mId1 + (Msg "message 3", Nothing) <- tryDelPeekMsg q mId3 + liftIO $ closeMsgQueueHandles q