From b3a4afac44ce9170271e04be14b53320cd887003 Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com> Date: Tue, 18 Oct 2022 10:01:14 +0100 Subject: [PATCH] server: log slow operations --- apps/smp-server/Main.hs | 2 +- src/Simplex/Messaging/Server.hs | 37 ++++++++++++++++++++++----------- tests/Test.hs | 32 ++++++++++++++++------------ 3 files changed, 45 insertions(+), 26 deletions(-) diff --git a/apps/smp-server/Main.hs b/apps/smp-server/Main.hs index 7e7438867..51e208cb7 100644 --- a/apps/smp-server/Main.hs +++ b/apps/smp-server/Main.hs @@ -26,7 +26,7 @@ logCfg = LogConfig {lc_file = Nothing, lc_stderr = True} main :: IO () main = do - setLogLevel LogInfo + setLogLevel LogDebug withGlobalLogging logCfg . protocolServerCLI smpServerCLIConfig $ \cfg@ServerConfig {inactiveClientExpiration} -> do putStrLn $ case inactiveClientExpiration of Just ExpirationConfig {ttl, checkInterval} -> "expiring clients inactive for " <> show ttl <> " seconds every " <> show checkInterval <> " seconds" diff --git a/src/Simplex/Messaging/Server.hs b/src/Simplex/Messaging/Server.hs index e64240dcd..1fadc46d6 100644 --- a/src/Simplex/Messaging/Server.hs +++ b/src/Simplex/Messaging/Server.hs @@ -321,7 +321,7 @@ dummyKeyEd448 :: C.PublicKey 'C.Ed448 dummyKeyEd448 = "MEMwBQYDK2VxAzoA6ibQc9XpkSLtwrf7PLvp81qW/etiumckVFImCMRdftcG/XopbOSaq9qyLhrgJWKOLyNrQPNVvpMA" client :: forall m. (MonadUnliftIO m, MonadReader Env m) => Client -> Server -> m () -client clnt@Client {thVersion, subscriptions, ntfSubscriptions, rcvQ, sndQ} Server {subscribedQ, ntfSubscribedQ, notifiers} = +client clnt@Client {thVersion, sessionId, subscriptions, ntfSubscriptions, rcvQ, sndQ} Server {subscribedQ, ntfSubscribedQ, notifiers} = forever $ atomically (readTBQueue rcvQ) >>= mapM processCommand @@ -432,7 +432,7 @@ client clnt@Client {thVersion, subscriptions, ntfSubscriptions, rcvQ, sndQ} Serv okResp <$> atomically (suspendQueue st queueId) subscribeQueue :: QueueRec -> RecipientId -> m (Transmission BrokerMsg) - subscribeQueue qr rId = + subscribeQueue qr rId = timed "subscribe" sessionId rId $ do atomically (TM.lookup rId subscriptions) >>= \case Nothing -> atomically newSub >>= deliver @@ -496,7 +496,7 @@ client clnt@Client {thVersion, subscriptions, ntfSubscriptions, rcvQ, sndQ} Serv pure ok acknowledgeMsg :: QueueRec -> MsgId -> m (Transmission BrokerMsg) - acknowledgeMsg qr msgId = do + acknowledgeMsg qr msgId = timed "ack" sessionId queueId $ do atomically (TM.lookup queueId subscriptions) >>= \case Nothing -> pure $ err NO_MSG Just sub -> @@ -540,7 +540,7 @@ client clnt@Client {thVersion, subscriptions, ntfSubscriptions, rcvQ, sndQ} Serv ServerConfig {messageExpiration, msgQueueQuota} <- asks config old <- liftIO $ mapM expireBeforeEpoch messageExpiration ntfNonceDrg <- asks idsDrg - resp@(_, _, sent) <- atomically $ do + resp@(_, _, sent) <- timed "send" sessionId queueId . atomically $ do q <- getMsgQueue ms (recipientId qr) msgQueueQuota mapM_ (deleteExpiredMsgs q) old ifM (isFull q) (pure $ err QUOTA) $ do @@ -578,7 +578,7 @@ client clnt@Client {thVersion, subscriptions, ntfSubscriptions, rcvQ, sndQ} Serv pure . (cbNonce,) $ fromRight "" encNMsgMeta deliverMessage :: QueueRec -> RecipientId -> TVar Sub -> MsgQueue -> Maybe Message -> m (Transmission BrokerMsg) - deliverMessage qr rId sub q msg_ = do + deliverMessage qr rId sub q msg_ = timed "deliver" sessionId rId $ do readTVarIO sub >>= \case s@Sub {subThread = NoSub} -> case msg_ of @@ -596,13 +596,14 @@ client clnt@Client {thVersion, subscriptions, ntfSubscriptions, rcvQ, sndQ} Serv s@Sub {subThread = SubPending} -> s {subThread = SubThread t} s -> s where - subscriber = atomically $ do - msg <- peekMsg q - let encMsg = encryptMsg qr msg - writeTBQueue sndQ [(CorrId "", rId, MSG encMsg)] - s <- readTVar sub - void $ setDelivered s msg - writeTVar sub s {subThread = NoSub} + subscriber = do + msg <- atomically $ peekMsg q + timed "subscriber" sessionId rId . atomically $ do + let encMsg = encryptMsg qr msg + writeTBQueue sndQ [(CorrId "", rId, MSG encMsg)] + s <- readTVar sub + void $ setDelivered s msg + writeTVar sub s {subThread = NoSub} encryptMsg :: QueueRec -> Message -> RcvMessage encryptMsg qr Message {msgId, msgTs, msgFlags, msgBody} @@ -648,6 +649,18 @@ withLog action = do env <- ask liftIO . mapM_ action $ storeLog (env :: Env) +timed :: MonadUnliftIO m => T.Text -> ByteString -> RecipientId -> m a -> m a +timed name sessId qId a = do + t <- liftIO getSystemTime + r <- a + t' <- liftIO getSystemTime + let int = diff t t' + when (int > sec) . logDebug $ T.unwords [name, tshow sessId, tshow qId, tshow int] + pure r + where + diff t t' = (systemSeconds t' - systemSeconds t) * sec + fromIntegral (systemNanoseconds t' - systemNanoseconds t) + sec = 1000_000000 + randomId :: (MonadUnliftIO m, MonadReader Env m) => Int -> m ByteString randomId n = do gVar <- asks idsDrg diff --git a/tests/Test.hs b/tests/Test.hs index d67277dd3..18ea98466 100644 --- a/tests/Test.hs +++ b/tests/Test.hs @@ -1,6 +1,7 @@ {-# LANGUAGE TypeApplications #-} import AgentTests (agentTests) +import Control.Logger.Simple import CoreTests.EncodingTests import CoreTests.ProtocolErrorTests import CoreTests.VersionRangeTests @@ -12,18 +13,23 @@ import System.Directory (createDirectoryIfMissing, removeDirectoryRecursive) import System.Environment (setEnv) import Test.Hspec +logCfg :: LogConfig +logCfg = LogConfig {lc_file = Nothing, lc_stderr = True} + main :: IO () main = do - createDirectoryIfMissing False "tests/tmp" - setEnv "APNS_KEY_ID" "H82WD9K9AQ" - setEnv "APNS_KEY_FILE" "./tests/fixtures/AuthKey_H82WD9K9AQ.p8" - hspec $ do - describe "Core tests" $ do - describe "Encoding tests" encodingTests - describe "Protocol error tests" protocolErrorTests - describe "Version range" versionRangeTests - describe "SMP server via TLS" $ serverTests (transport @TLS) - describe "SMP server via WebSockets" $ serverTests (transport @WS) - describe "Notifications server" $ ntfServerTests (transport @TLS) - describe "SMP client agent" $ agentTests (transport @TLS) - removeDirectoryRecursive "tests/tmp" + setLogLevel LogDebug + withGlobalLogging logCfg $ do + createDirectoryIfMissing False "tests/tmp" + setEnv "APNS_KEY_ID" "H82WD9K9AQ" + setEnv "APNS_KEY_FILE" "./tests/fixtures/AuthKey_H82WD9K9AQ.p8" + hspec $ do + describe "Core tests" $ do + describe "Encoding tests" encodingTests + describe "Protocol error tests" protocolErrorTests + describe "Version range" versionRangeTests + fdescribe "SMP server via TLS" $ serverTests (transport @TLS) + describe "SMP server via WebSockets" $ serverTests (transport @WS) + describe "Notifications server" $ ntfServerTests (transport @TLS) + describe "SMP client agent" $ agentTests (transport @TLS) + removeDirectoryRecursive "tests/tmp"