mirror of
https://github.com/simplex-chat/simplexmq.git
synced 2026-05-14 16:15:12 +00:00
ntf: server stats (#487)
* nts: server stats * ntf: collect stats, refactor * rename property * fixes
This commit is contained in:
Evgeny Poberezkin
committed by
GitHub
GitHub
parent
fcaddb7848
commit
b76ef03dbe
@@ -11,6 +11,7 @@ import Control.Concurrent.Async (Async)
|
||||
import Control.Monad.IO.Unlift
|
||||
import Crypto.Random
|
||||
import Data.ByteString.Char8 (ByteString)
|
||||
import Data.Time.Clock (getCurrentTime)
|
||||
import Data.Time.Clock.System (SystemTime)
|
||||
import Data.Word (Word16)
|
||||
import Data.X509.Validation (Fingerprint (..))
|
||||
@@ -21,6 +22,7 @@ import Simplex.Messaging.Client.Agent
|
||||
import qualified Simplex.Messaging.Crypto as C
|
||||
import Simplex.Messaging.Notifications.Protocol
|
||||
import Simplex.Messaging.Notifications.Server.Push.APNS
|
||||
import Simplex.Messaging.Notifications.Server.Stats
|
||||
import Simplex.Messaging.Notifications.Server.Store
|
||||
import Simplex.Messaging.Notifications.Server.StoreLog
|
||||
import Simplex.Messaging.Protocol (CorrId, SMPServer, Transmission)
|
||||
@@ -48,7 +50,12 @@ data NtfServerConfig = NtfServerConfig
|
||||
-- CA certificate private key is not needed for initialization
|
||||
caCertificateFile :: FilePath,
|
||||
privateKeyFile :: FilePath,
|
||||
certificateFile :: FilePath
|
||||
certificateFile :: FilePath,
|
||||
-- stats config - see SMP server config
|
||||
logStatsInterval :: Maybe Int,
|
||||
logStatsStartTime :: Int,
|
||||
serverStatsLogFile :: FilePath,
|
||||
serverStatsBackupFile :: Maybe FilePath
|
||||
}
|
||||
|
||||
defaultInactiveClientExpiration :: ExpirationConfig
|
||||
@@ -67,7 +74,8 @@ data NtfEnv = NtfEnv
|
||||
idsDrg :: TVar ChaChaDRG,
|
||||
serverIdentity :: C.KeyHash,
|
||||
tlsServerParams :: T.ServerParams,
|
||||
serverIdentity :: C.KeyHash
|
||||
serverIdentity :: C.KeyHash,
|
||||
serverStats :: NtfServerStats
|
||||
}
|
||||
|
||||
newNtfServerEnv :: (MonadUnliftIO m, MonadRandom m) => NtfServerConfig -> m NtfEnv
|
||||
@@ -79,7 +87,8 @@ newNtfServerEnv config@NtfServerConfig {subQSize, pushQSize, smpAgentCfg, apnsCo
|
||||
pushServer <- atomically $ newNtfPushServer pushQSize apnsConfig
|
||||
tlsServerParams <- liftIO $ loadTLSServerParams caCertificateFile certificateFile privateKeyFile
|
||||
Fingerprint fp <- liftIO $ loadFingerprint caCertificateFile
|
||||
pure NtfEnv {config, subscriber, pushServer, store, storeLog, idsDrg, tlsServerParams, serverIdentity = C.KeyHash fp}
|
||||
serverStats <- atomically . newNtfServerStats =<< liftIO getCurrentTime
|
||||
pure NtfEnv {config, subscriber, pushServer, store, storeLog, idsDrg, tlsServerParams, serverIdentity = C.KeyHash fp, serverStats}
|
||||
|
||||
data NtfSubscriber = NtfSubscriber
|
||||
{ smpSubscribers :: TMap SMPServer SMPSubscriber,
|
||||
|
||||
@@ -0,0 +1,113 @@
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module Simplex.Messaging.Notifications.Server.Stats where
|
||||
|
||||
import Control.Applicative (optional)
|
||||
import qualified Data.Attoparsec.ByteString.Char8 as A
|
||||
import qualified Data.ByteString.Char8 as B
|
||||
import Data.Time.Clock (UTCTime)
|
||||
import Simplex.Messaging.Encoding.String
|
||||
import Simplex.Messaging.Notifications.Protocol (NtfTokenId)
|
||||
import Simplex.Messaging.Protocol (NotifierId)
|
||||
import Simplex.Messaging.Server.Stats
|
||||
import UnliftIO.STM
|
||||
|
||||
data NtfServerStats = NtfServerStats
|
||||
{ fromTime :: TVar UTCTime,
|
||||
tknCreated :: TVar Int,
|
||||
tknVerified :: TVar Int,
|
||||
tknDeleted :: TVar Int,
|
||||
subCreated :: TVar Int,
|
||||
subDeleted :: TVar Int,
|
||||
ntfReceived :: TVar Int,
|
||||
ntfDelivered :: TVar Int,
|
||||
activeTokens :: PeriodStats NtfTokenId,
|
||||
activeSubs :: PeriodStats NotifierId
|
||||
}
|
||||
|
||||
data NtfServerStatsData = NtfServerStatsData
|
||||
{ _fromTime :: UTCTime,
|
||||
_tknCreated :: Int,
|
||||
_tknVerified :: Int,
|
||||
_tknDeleted :: Int,
|
||||
_subCreated :: Int,
|
||||
_subDeleted :: Int,
|
||||
_ntfReceived :: Int,
|
||||
_ntfDelivered :: Int,
|
||||
_activeTokens :: PeriodStatsData NtfTokenId,
|
||||
_activeSubs :: PeriodStatsData NotifierId
|
||||
}
|
||||
|
||||
newNtfServerStats :: UTCTime -> STM NtfServerStats
|
||||
newNtfServerStats ts = do
|
||||
fromTime <- newTVar ts
|
||||
tknCreated <- newTVar 0
|
||||
tknVerified <- newTVar 0
|
||||
tknDeleted <- newTVar 0
|
||||
subCreated <- newTVar 0
|
||||
subDeleted <- newTVar 0
|
||||
ntfReceived <- newTVar 0
|
||||
ntfDelivered <- newTVar 0
|
||||
activeTokens <- newPeriodStats
|
||||
activeSubs <- newPeriodStats
|
||||
pure NtfServerStats {fromTime, tknCreated, tknVerified, tknDeleted, subCreated, subDeleted, ntfReceived, ntfDelivered, activeTokens, activeSubs}
|
||||
|
||||
getNtfServerStatsData :: NtfServerStats -> STM NtfServerStatsData
|
||||
getNtfServerStatsData s = do
|
||||
_fromTime <- readTVar $ fromTime (s :: NtfServerStats)
|
||||
_tknCreated <- readTVar $ tknCreated s
|
||||
_tknVerified <- readTVar $ tknVerified s
|
||||
_tknDeleted <- readTVar $ tknDeleted s
|
||||
_subCreated <- readTVar $ subCreated s
|
||||
_subDeleted <- readTVar $ subDeleted s
|
||||
_ntfReceived <- readTVar $ ntfReceived s
|
||||
_ntfDelivered <- readTVar $ ntfDelivered s
|
||||
_activeTokens <- getPeriodStatsData $ activeTokens s
|
||||
_activeSubs <- getPeriodStatsData $ activeSubs s
|
||||
pure NtfServerStatsData {_fromTime, _tknCreated, _tknVerified, _tknDeleted, _subCreated, _subDeleted, _ntfReceived, _ntfDelivered, _activeTokens, _activeSubs}
|
||||
|
||||
setNtfServerStats :: NtfServerStats -> NtfServerStatsData -> STM ()
|
||||
setNtfServerStats s d = do
|
||||
writeTVar (fromTime (s :: NtfServerStats)) (_fromTime (d :: NtfServerStatsData))
|
||||
writeTVar (tknCreated s) (_tknCreated d)
|
||||
writeTVar (tknVerified s) (_tknVerified d)
|
||||
writeTVar (tknDeleted s) (_tknDeleted d)
|
||||
writeTVar (subCreated s) (_subCreated d)
|
||||
writeTVar (subDeleted s) (_subDeleted d)
|
||||
writeTVar (ntfReceived s) (_ntfReceived d)
|
||||
writeTVar (ntfDelivered s) (_ntfDelivered d)
|
||||
setPeriodStats (activeTokens s) (_activeTokens d)
|
||||
setPeriodStats (activeSubs s) (_activeSubs d)
|
||||
|
||||
instance StrEncoding NtfServerStatsData where
|
||||
strEncode NtfServerStatsData {_fromTime, _tknCreated, _tknVerified, _tknDeleted, _subCreated, _subDeleted, _ntfReceived, _ntfDelivered, _activeTokens, _activeSubs} =
|
||||
B.unlines
|
||||
[ "fromTime=" <> strEncode _fromTime,
|
||||
"tknCreated=" <> strEncode _tknCreated,
|
||||
"tknVerified=" <> strEncode _tknVerified,
|
||||
"tknDeleted=" <> strEncode _tknDeleted,
|
||||
"subCreated=" <> strEncode _subCreated,
|
||||
"subDeleted=" <> strEncode _subDeleted,
|
||||
"ntfReceived=" <> strEncode _ntfReceived,
|
||||
"ntfDelivered=" <> strEncode _ntfDelivered,
|
||||
"activeTokens:",
|
||||
strEncode _activeTokens,
|
||||
"activeSubs:",
|
||||
strEncode _activeSubs
|
||||
]
|
||||
strP = do
|
||||
_fromTime <- "fromTime=" *> strP <* A.endOfLine
|
||||
_tknCreated <- "tknCreated=" *> strP <* A.endOfLine
|
||||
_tknVerified <- "tknVerified=" *> strP <* A.endOfLine
|
||||
_tknDeleted <- "tknDeleted=" *> strP <* A.endOfLine
|
||||
_subCreated <- "subCreated=" *> strP <* A.endOfLine
|
||||
_subDeleted <- "subDeleted=" *> strP <* A.endOfLine
|
||||
_ntfReceived <- "ntfReceived=" *> strP <* A.endOfLine
|
||||
_ntfDelivered <- "ntfDelivered=" *> strP <* A.endOfLine
|
||||
_ <- "activeTokens:" <* A.endOfLine
|
||||
_activeTokens <- strP <* A.endOfLine
|
||||
_ <- "activeSubs:" <* A.endOfLine
|
||||
_activeSubs <- strP <* optional A.endOfLine
|
||||
pure NtfServerStatsData {_fromTime, _tknCreated, _tknVerified, _tknDeleted, _subCreated, _subDeleted, _ntfReceived, _ntfDelivered, _activeTokens, _activeSubs}
|
||||
Reference in New Issue
Block a user