mirror of
https://github.com/simplex-chat/simplexmq.git
synced 2026-03-30 14:16:00 +00:00
ntf server: additional statistics, new invalid token reasons (#1451)
* agent: check ntf token status on registration * remove check * update on check * refactor * version * fix * ntf server: additional statistics * swap * version * more stats * test, verify invalid * rename * exclude test token from stats * increase delay * handle invalid token in retry, more reasons * focus tests * disable new tests in CI * fix --------- Co-authored-by: spaced4ndy <8711996+spaced4ndy@users.noreply.github.com>
This commit is contained in:
Evgeny
@@ -557,19 +557,21 @@ instance StrEncoding NTInvalidReason where
|
||||
strEncode = smpEncode
|
||||
strP = smpP
|
||||
|
||||
data NTInvalidReason = NTIRBadToken | NTIRTokenNotForTopic | NTIRGone410
|
||||
data NTInvalidReason = NTIRBadToken | NTIRTokenNotForTopic | NTIRExpiredToken | NTIRUnregistered
|
||||
deriving (Eq, Show)
|
||||
|
||||
instance Encoding NTInvalidReason where
|
||||
smpEncode = \case
|
||||
NTIRBadToken -> "BAD"
|
||||
NTIRTokenNotForTopic -> "TOPIC"
|
||||
NTIRGone410 -> "GONE"
|
||||
NTIRExpiredToken -> "EXPIRED"
|
||||
NTIRUnregistered -> "UNREGISTERED"
|
||||
smpP =
|
||||
A.takeTill (== ' ') >>= \case
|
||||
"BAD" -> pure NTIRBadToken
|
||||
"TOPIC" -> pure NTIRTokenNotForTopic
|
||||
"GONE" -> pure NTIRGone410
|
||||
"EXPIRED" -> pure NTIRExpiredToken
|
||||
"UNREGISTERED" -> pure NTIRUnregistered
|
||||
_ -> fail "bad NTInvalidReason"
|
||||
|
||||
instance StrEncoding NtfTknStatus where
|
||||
|
||||
@@ -136,7 +136,8 @@ ntfServer cfg@NtfServerConfig {transports, transportConfig = tCfg} started = do
|
||||
initialDelay <- (startAt -) . fromIntegral . (`div` 1000000_000000) . diffTimeToPicoseconds . utctDayTime <$> liftIO getCurrentTime
|
||||
logInfo $ "server stats log enabled: " <> T.pack statsFilePath
|
||||
liftIO $ threadDelay' $ 1000000 * (initialDelay + if initialDelay < 0 then 86400 else 0)
|
||||
NtfServerStats {fromTime, tknCreated, tknVerified, tknDeleted, subCreated, subDeleted, ntfReceived, ntfDelivered, activeTokens, activeSubs} <- asks serverStats
|
||||
NtfServerStats {fromTime, tknCreated, tknVerified, tknDeleted, tknReplaced, subCreated, subDeleted, ntfReceived, ntfDelivered, ntfFailed, ntfCronDelivered, ntfCronFailed, ntfVrfQueued, ntfVrfDelivered, ntfVrfFailed, ntfVrfInvalidTkn, activeTokens, activeSubs} <-
|
||||
asks serverStats
|
||||
let interval = 1000000 * logInterval
|
||||
forever $ do
|
||||
withFile statsFilePath AppendMode $ \h -> liftIO $ do
|
||||
@@ -146,10 +147,18 @@ ntfServer cfg@NtfServerConfig {transports, transportConfig = tCfg} started = do
|
||||
tknCreated' <- atomicSwapIORef tknCreated 0
|
||||
tknVerified' <- atomicSwapIORef tknVerified 0
|
||||
tknDeleted' <- atomicSwapIORef tknDeleted 0
|
||||
tknReplaced' <- atomicSwapIORef tknReplaced 0
|
||||
subCreated' <- atomicSwapIORef subCreated 0
|
||||
subDeleted' <- atomicSwapIORef subDeleted 0
|
||||
ntfReceived' <- atomicSwapIORef ntfReceived 0
|
||||
ntfDelivered' <- atomicSwapIORef ntfDelivered 0
|
||||
ntfFailed' <- atomicSwapIORef ntfFailed 0
|
||||
ntfCronDelivered' <- atomicSwapIORef ntfCronDelivered 0
|
||||
ntfCronFailed' <- atomicSwapIORef ntfCronFailed 0
|
||||
ntfVrfQueued' <- atomicSwapIORef ntfVrfQueued 0
|
||||
ntfVrfDelivered' <- atomicSwapIORef ntfVrfDelivered 0
|
||||
ntfVrfFailed' <- atomicSwapIORef ntfVrfFailed 0
|
||||
ntfVrfInvalidTkn' <- atomicSwapIORef ntfVrfInvalidTkn 0
|
||||
tkn <- liftIO $ periodStatCounts activeTokens ts
|
||||
sub <- liftIO $ periodStatCounts activeSubs ts
|
||||
hPutStrLn h $
|
||||
@@ -168,7 +177,15 @@ ntfServer cfg@NtfServerConfig {transports, transportConfig = tCfg} started = do
|
||||
monthCount tkn,
|
||||
dayCount sub,
|
||||
weekCount sub,
|
||||
monthCount sub
|
||||
monthCount sub,
|
||||
show tknReplaced',
|
||||
show ntfFailed',
|
||||
show ntfCronDelivered',
|
||||
show ntfCronFailed',
|
||||
show ntfVrfQueued',
|
||||
show ntfVrfDelivered',
|
||||
show ntfVrfFailed',
|
||||
show ntfVrfInvalidTkn'
|
||||
]
|
||||
liftIO $ threadDelay' interval
|
||||
|
||||
@@ -225,9 +242,18 @@ ntfServer cfg@NtfServerConfig {transports, transportConfig = tCfg} started = do
|
||||
putStat "tknCreated" tknCreated
|
||||
putStat "tknVerified" tknVerified
|
||||
putStat "tknDeleted" tknDeleted
|
||||
putStat "tknReplaced" tknReplaced
|
||||
putStat "subCreated" subCreated
|
||||
putStat "subDeleted" subDeleted
|
||||
putStat "ntfReceived" ntfReceived
|
||||
putStat "ntfDelivered" ntfDelivered
|
||||
putStat "ntfFailed" ntfFailed
|
||||
putStat "ntfCronDelivered" ntfCronDelivered
|
||||
putStat "ntfCronFailed" ntfCronFailed
|
||||
putStat "ntfVrfQueued" ntfVrfQueued
|
||||
putStat "ntfVrfDelivered" ntfVrfDelivered
|
||||
putStat "ntfVrfFailed" ntfVrfFailed
|
||||
putStat "ntfVrfInvalidTkn" ntfVrfInvalidTkn
|
||||
getStat (day . activeTokens) >>= \v -> hPutStrLn h $ "daily active tokens: " <> show (IS.size v)
|
||||
getStat (day . activeSubs) >>= \v -> hPutStrLn h $ "daily active subscriptions: " <> show (IS.size v)
|
||||
CPStatsRTS -> tryAny getRTSStats >>= either (hPrint h) (hPrint h)
|
||||
@@ -242,15 +268,19 @@ ntfServer cfg@NtfServerConfig {transports, transportConfig = tCfg} started = do
|
||||
#else
|
||||
hPutStrLn h "Threads: not available on GHC 8.10"
|
||||
#endif
|
||||
NtfSubscriber {smpSubscribers, smpAgent = a} <- unliftIO u $ asks subscriber
|
||||
NtfEnv {subscriber, pushServer} <- unliftIO u ask
|
||||
let NtfSubscriber {smpSubscribers, smpAgent = a} = subscriber
|
||||
NtfPushServer {pushQ} = pushServer
|
||||
SMPClientAgent {smpClients, smpSessions, srvSubs, pendingSrvSubs, smpSubWorkers} = a
|
||||
putSMPWorkers a "SMP subcscribers" smpSubscribers
|
||||
let SMPClientAgent {smpClients, smpSessions, srvSubs, pendingSrvSubs, smpSubWorkers} = a
|
||||
putSMPWorkers a "SMP clients" smpClients
|
||||
putSMPWorkers a "SMP subscription workers" smpSubWorkers
|
||||
sessions <- readTVarIO smpSessions
|
||||
hPutStrLn h $ "SMP sessions count: " <> show (M.size sessions)
|
||||
putSMPSubs a "SMP subscriptions" srvSubs
|
||||
putSMPSubs a "Pending SMP subscriptions" pendingSrvSubs
|
||||
sz <- atomically $ lengthTBQueue pushQ
|
||||
hPutStrLn h $ "Push notifications queue length: " <> show sz
|
||||
where
|
||||
putSMPSubs :: SMPClientAgent -> String -> TMap SMPServer (TMap SMPSub a) -> IO ()
|
||||
putSMPSubs a name v = do
|
||||
@@ -432,7 +462,7 @@ ntfSubscriber NtfSubscriber {smpSubscribers, newSubQ, smpAgent = ca@SMPClientAge
|
||||
|
||||
ntfPush :: NtfPushServer -> M ()
|
||||
ntfPush s@NtfPushServer {pushQ} = forever $ do
|
||||
(tkn@NtfTknData {ntfTknId, token = DeviceToken pp _, tknStatus}, ntf) <- atomically (readTBQueue pushQ)
|
||||
(tkn@NtfTknData {ntfTknId, token = t@(DeviceToken pp _), tknStatus}, ntf) <- atomically (readTBQueue pushQ)
|
||||
liftIO $ logDebug $ "sending push notification to " <> T.pack (show pp)
|
||||
status <- readTVarIO tknStatus
|
||||
case ntf of
|
||||
@@ -444,14 +474,16 @@ ntfPush s@NtfPushServer {pushQ} = forever $ do
|
||||
NTConfirmed -> (Nothing, NTConfirmed)
|
||||
_ -> (Just NTConfirmed, NTConfirmed)
|
||||
forM_ status_ $ \status' -> withNtfLog $ \sl -> logTokenStatus sl ntfTknId status'
|
||||
_ -> pure ()
|
||||
incNtfStatT t ntfVrfDelivered
|
||||
Left _ -> incNtfStatT t ntfVrfFailed
|
||||
PNCheckMessages -> checkActiveTkn status $ do
|
||||
void $ deliverNotification pp tkn ntf
|
||||
deliverNotification pp tkn ntf
|
||||
>>= incNtfStatT t . (\case Left _ -> ntfCronFailed; Right () -> ntfCronDelivered)
|
||||
PNMessage {} -> checkActiveTkn status $ do
|
||||
stats <- asks serverStats
|
||||
liftIO $ updatePeriodStats (activeTokens stats) ntfTknId
|
||||
void $ deliverNotification pp tkn ntf
|
||||
incNtfStat ntfDelivered
|
||||
deliverNotification pp tkn ntf
|
||||
>>= incNtfStatT t . (\case Left _ -> ntfFailed; Right () -> ntfDelivered)
|
||||
where
|
||||
checkActiveTkn :: NtfTknStatus -> M () -> M ()
|
||||
checkActiveTkn status action
|
||||
@@ -466,14 +498,18 @@ ntfPush s@NtfPushServer {pushQ} = forever $ do
|
||||
PPConnection _ -> retryDeliver
|
||||
PPRetryLater -> retryDeliver
|
||||
PPCryptoError _ -> err e
|
||||
PPResponseError _ _ -> err e
|
||||
PPResponseError {} -> err e
|
||||
PPTokenInvalid r -> updateTknStatus tkn (NTInvalid $ Just r) >> err e
|
||||
PPPermanentError -> err e
|
||||
where
|
||||
retryDeliver :: M (Either PushProviderError ())
|
||||
retryDeliver = do
|
||||
deliver <- liftIO $ newPushClient s pp
|
||||
liftIO (runExceptT $ deliver tkn ntf) >>= either err (pure . Right)
|
||||
liftIO (runExceptT $ deliver tkn ntf) >>= \case
|
||||
Right _ -> pure $ Right ()
|
||||
Left e -> case e of
|
||||
PPTokenInvalid r -> updateTknStatus tkn (NTInvalid $ Just r) >> err e
|
||||
_ -> err e
|
||||
err e = logError ("Push provider error (" <> tshow pp <> ", " <> tshow ntfTknId <> "): " <> tshow e) $> Left e
|
||||
|
||||
updateTknStatus :: NtfTknData -> NtfTknStatus -> M ()
|
||||
@@ -593,7 +629,6 @@ client NtfServerClient {rcvQ, sndQ} NtfSubscriber {newSubQ, smpAgent = ca} NtfPu
|
||||
let t' = Just ts'
|
||||
t <- atomically $ swapTVar tknUpdatedAt t'
|
||||
unless (t' == t) $ withNtfLog $ \s -> logUpdateTokenTime s ntfTknId ts'
|
||||
|
||||
processCommand :: NtfRequest -> M (Transmission NtfResponse)
|
||||
processCommand = \case
|
||||
NtfReqNew corrId (ANE SToken newTkn@(NewNtfTkn token _ dhPubKey)) -> do
|
||||
@@ -607,6 +642,7 @@ client NtfServerClient {rcvQ, sndQ} NtfSubscriber {newSubQ, smpAgent = ca} NtfPu
|
||||
tkn <- liftIO $ mkNtfTknData tknId newTkn ks dhSecret regCode ts
|
||||
atomically $ addNtfToken st tknId tkn
|
||||
atomically $ writeTBQueue pushQ (tkn, PNVerification regCode)
|
||||
incNtfStatT token ntfVrfQueued
|
||||
withNtfLog (`logCreateToken` tkn)
|
||||
incNtfStatT token tknCreated
|
||||
pure (corrId, NoEntity, NRTknId tknId srvDhPubKey)
|
||||
@@ -620,6 +656,7 @@ client NtfServerClient {rcvQ, sndQ} NtfSubscriber {newSubQ, smpAgent = ca} NtfPu
|
||||
if tknDhSecret == dhSecret
|
||||
then do
|
||||
atomically $ writeTBQueue pushQ (tkn, PNVerification tknRegCode)
|
||||
incNtfStatT token ntfVrfQueued
|
||||
pure $ NRTknId ntfTknId srvDhPubKey
|
||||
else pure $ NRErr AUTH
|
||||
TVFY code -- this allows repeated verification for cases when client connection dropped before server response
|
||||
@@ -647,9 +684,9 @@ client NtfServerClient {rcvQ, sndQ} NtfSubscriber {newSubQ, smpAgent = ca} NtfPu
|
||||
let tkn' = tkn {token = token', tknRegCode = regCode}
|
||||
addNtfToken st tknId tkn'
|
||||
writeTBQueue pushQ (tkn', PNVerification regCode)
|
||||
incNtfStatT token ntfVrfQueued
|
||||
withNtfLog $ \s -> logUpdateToken s tknId token' regCode
|
||||
incNtfStatT token tknDeleted
|
||||
incNtfStatT token tknCreated
|
||||
incNtfStatT token tknReplaced
|
||||
pure NROk
|
||||
TDEL -> do
|
||||
logDebug "TDEL"
|
||||
|
||||
@@ -154,7 +154,7 @@ ntfServerCLI cfgPath logPath =
|
||||
regCodeBytes = 32,
|
||||
clientQSize = 64,
|
||||
subQSize = 512,
|
||||
pushQSize = 1048,
|
||||
pushQSize = 16384,
|
||||
smpAgentCfg =
|
||||
defaultSMPClientAgentConfig
|
||||
{ smpCfg =
|
||||
|
||||
@@ -337,19 +337,20 @@ apnsPushProviderClient c@APNSPushClient {nonceDrg, apnsCfg} tkn@NtfTknData {toke
|
||||
result status reason'
|
||||
| status == Just N.ok200 = pure ()
|
||||
| status == Just N.badRequest400 =
|
||||
case reason' of
|
||||
"BadDeviceToken" -> throwE $ PPTokenInvalid NTIRBadToken
|
||||
"DeviceTokenNotForTopic" -> throwE $ PPTokenInvalid NTIRTokenNotForTopic
|
||||
"TopicDisallowed" -> throwE PPPermanentError
|
||||
_ -> err status reason'
|
||||
| status == Just N.forbidden403 = case reason' of
|
||||
"ExpiredProviderToken" -> throwE PPPermanentError -- there should be no point retrying it as the token was refreshed
|
||||
"InvalidProviderToken" -> throwE PPPermanentError
|
||||
_ -> err status reason'
|
||||
| status == Just N.gone410 = throwE $ PPTokenInvalid NTIRGone410
|
||||
throwE $ case reason' of
|
||||
"BadDeviceToken" -> PPTokenInvalid NTIRBadToken
|
||||
"DeviceTokenNotForTopic" -> PPTokenInvalid NTIRTokenNotForTopic
|
||||
"TopicDisallowed" -> PPPermanentError
|
||||
_ -> PPResponseError status reason'
|
||||
| status == Just N.forbidden403 = throwE $ case reason' of
|
||||
"ExpiredProviderToken" -> PPPermanentError -- there should be no point retrying it as the token was refreshed
|
||||
"InvalidProviderToken" -> PPPermanentError
|
||||
_ -> PPResponseError status reason'
|
||||
| status == Just N.gone410 = throwE $ case reason' of
|
||||
"ExpiredToken" -> PPTokenInvalid NTIRExpiredToken
|
||||
"Unregistered" -> PPTokenInvalid NTIRUnregistered
|
||||
_ -> PPRetryLater
|
||||
| status == Just N.serviceUnavailable503 = liftIO (disconnectApnsHTTP2Client c) >> throwE PPRetryLater
|
||||
-- Just tooManyRequests429 -> TooManyRequests - too many requests for the same token
|
||||
| otherwise = err status reason'
|
||||
err :: Maybe Status -> Text -> ExceptT PushProviderError IO ()
|
||||
err s r = throwE $ PPResponseError s r
|
||||
| otherwise = throwE $ PPResponseError status reason'
|
||||
liftHTTPS2 a = ExceptT $ first PPConnection <$> a
|
||||
|
||||
@@ -4,7 +4,7 @@
|
||||
|
||||
module Simplex.Messaging.Notifications.Server.Stats where
|
||||
|
||||
import Control.Applicative (optional)
|
||||
import Control.Applicative (optional, (<|>))
|
||||
import qualified Data.Attoparsec.ByteString.Char8 as A
|
||||
import qualified Data.ByteString.Char8 as B
|
||||
import Data.IORef
|
||||
@@ -17,10 +17,18 @@ data NtfServerStats = NtfServerStats
|
||||
tknCreated :: IORef Int,
|
||||
tknVerified :: IORef Int,
|
||||
tknDeleted :: IORef Int,
|
||||
tknReplaced :: IORef Int,
|
||||
subCreated :: IORef Int,
|
||||
subDeleted :: IORef Int,
|
||||
ntfReceived :: IORef Int,
|
||||
ntfDelivered :: IORef Int,
|
||||
ntfFailed :: IORef Int,
|
||||
ntfCronDelivered :: IORef Int,
|
||||
ntfCronFailed :: IORef Int,
|
||||
ntfVrfQueued :: IORef Int,
|
||||
ntfVrfDelivered :: IORef Int,
|
||||
ntfVrfFailed :: IORef Int,
|
||||
ntfVrfInvalidTkn :: IORef Int,
|
||||
activeTokens :: PeriodStats,
|
||||
activeSubs :: PeriodStats
|
||||
}
|
||||
@@ -30,10 +38,18 @@ data NtfServerStatsData = NtfServerStatsData
|
||||
_tknCreated :: Int,
|
||||
_tknVerified :: Int,
|
||||
_tknDeleted :: Int,
|
||||
_tknReplaced :: Int,
|
||||
_subCreated :: Int,
|
||||
_subDeleted :: Int,
|
||||
_ntfReceived :: Int,
|
||||
_ntfDelivered :: Int,
|
||||
_ntfFailed :: Int,
|
||||
_ntfCronDelivered :: Int,
|
||||
_ntfCronFailed :: Int,
|
||||
_ntfVrfQueued :: Int,
|
||||
_ntfVrfDelivered :: Int,
|
||||
_ntfVrfFailed :: Int,
|
||||
_ntfVrfInvalidTkn :: Int,
|
||||
_activeTokens :: PeriodStatsData,
|
||||
_activeSubs :: PeriodStatsData
|
||||
}
|
||||
@@ -44,13 +60,41 @@ newNtfServerStats ts = do
|
||||
tknCreated <- newIORef 0
|
||||
tknVerified <- newIORef 0
|
||||
tknDeleted <- newIORef 0
|
||||
tknReplaced <- newIORef 0
|
||||
subCreated <- newIORef 0
|
||||
subDeleted <- newIORef 0
|
||||
ntfReceived <- newIORef 0
|
||||
ntfDelivered <- newIORef 0
|
||||
ntfFailed <- newIORef 0
|
||||
ntfCronDelivered <- newIORef 0
|
||||
ntfCronFailed <- newIORef 0
|
||||
ntfVrfQueued <- newIORef 0
|
||||
ntfVrfDelivered <- newIORef 0
|
||||
ntfVrfFailed <- newIORef 0
|
||||
ntfVrfInvalidTkn <- newIORef 0
|
||||
activeTokens <- newPeriodStats
|
||||
activeSubs <- newPeriodStats
|
||||
pure NtfServerStats {fromTime, tknCreated, tknVerified, tknDeleted, subCreated, subDeleted, ntfReceived, ntfDelivered, activeTokens, activeSubs}
|
||||
pure
|
||||
NtfServerStats
|
||||
{ fromTime,
|
||||
tknCreated,
|
||||
tknVerified,
|
||||
tknDeleted,
|
||||
tknReplaced,
|
||||
subCreated,
|
||||
subDeleted,
|
||||
ntfReceived,
|
||||
ntfDelivered,
|
||||
ntfFailed,
|
||||
ntfCronDelivered,
|
||||
ntfCronFailed,
|
||||
ntfVrfQueued,
|
||||
ntfVrfDelivered,
|
||||
ntfVrfFailed,
|
||||
ntfVrfInvalidTkn,
|
||||
activeTokens,
|
||||
activeSubs
|
||||
}
|
||||
|
||||
getNtfServerStatsData :: NtfServerStats -> IO NtfServerStatsData
|
||||
getNtfServerStatsData s@NtfServerStats {fromTime} = do
|
||||
@@ -58,13 +102,41 @@ getNtfServerStatsData s@NtfServerStats {fromTime} = do
|
||||
_tknCreated <- readIORef $ tknCreated s
|
||||
_tknVerified <- readIORef $ tknVerified s
|
||||
_tknDeleted <- readIORef $ tknDeleted s
|
||||
_tknReplaced <- readIORef $ tknReplaced s
|
||||
_subCreated <- readIORef $ subCreated s
|
||||
_subDeleted <- readIORef $ subDeleted s
|
||||
_ntfReceived <- readIORef $ ntfReceived s
|
||||
_ntfDelivered <- readIORef $ ntfDelivered s
|
||||
_ntfFailed <- readIORef $ ntfFailed s
|
||||
_ntfCronDelivered <- readIORef $ ntfCronDelivered s
|
||||
_ntfCronFailed <- readIORef $ ntfCronFailed s
|
||||
_ntfVrfQueued <- readIORef $ ntfVrfQueued s
|
||||
_ntfVrfDelivered <- readIORef $ ntfVrfDelivered s
|
||||
_ntfVrfFailed <- readIORef $ ntfVrfFailed s
|
||||
_ntfVrfInvalidTkn <- readIORef $ ntfVrfInvalidTkn s
|
||||
_activeTokens <- getPeriodStatsData $ activeTokens s
|
||||
_activeSubs <- getPeriodStatsData $ activeSubs s
|
||||
pure NtfServerStatsData {_fromTime, _tknCreated, _tknVerified, _tknDeleted, _subCreated, _subDeleted, _ntfReceived, _ntfDelivered, _activeTokens, _activeSubs}
|
||||
pure
|
||||
NtfServerStatsData
|
||||
{ _fromTime,
|
||||
_tknCreated,
|
||||
_tknVerified,
|
||||
_tknDeleted,
|
||||
_tknReplaced,
|
||||
_subCreated,
|
||||
_subDeleted,
|
||||
_ntfReceived,
|
||||
_ntfDelivered,
|
||||
_ntfFailed,
|
||||
_ntfCronDelivered,
|
||||
_ntfCronFailed,
|
||||
_ntfVrfQueued,
|
||||
_ntfVrfDelivered,
|
||||
_ntfVrfFailed,
|
||||
_ntfVrfInvalidTkn,
|
||||
_activeTokens,
|
||||
_activeSubs
|
||||
}
|
||||
|
||||
-- this function is not thread safe, it is used on server start only
|
||||
setNtfServerStats :: NtfServerStats -> NtfServerStatsData -> IO ()
|
||||
@@ -73,24 +145,60 @@ setNtfServerStats s@NtfServerStats {fromTime} d@NtfServerStatsData {_fromTime} =
|
||||
writeIORef (tknCreated s) $! _tknCreated d
|
||||
writeIORef (tknVerified s) $! _tknVerified d
|
||||
writeIORef (tknDeleted s) $! _tknDeleted d
|
||||
writeIORef (tknReplaced s) $! _tknReplaced d
|
||||
writeIORef (subCreated s) $! _subCreated d
|
||||
writeIORef (subDeleted s) $! _subDeleted d
|
||||
writeIORef (ntfReceived s) $! _ntfReceived d
|
||||
writeIORef (ntfDelivered s) $! _ntfDelivered d
|
||||
writeIORef (ntfFailed s) $! _ntfFailed d
|
||||
writeIORef (ntfCronDelivered s) $! _ntfCronDelivered d
|
||||
writeIORef (ntfCronFailed s) $! _ntfCronFailed d
|
||||
writeIORef (ntfVrfQueued s) $! _ntfVrfQueued d
|
||||
writeIORef (ntfVrfDelivered s) $! _ntfVrfDelivered d
|
||||
writeIORef (ntfVrfFailed s) $! _ntfVrfFailed d
|
||||
writeIORef (ntfVrfInvalidTkn s) $! _ntfVrfInvalidTkn 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} =
|
||||
strEncode
|
||||
NtfServerStatsData
|
||||
{ _fromTime,
|
||||
_tknCreated,
|
||||
_tknVerified,
|
||||
_tknDeleted,
|
||||
_tknReplaced,
|
||||
_subCreated,
|
||||
_subDeleted,
|
||||
_ntfReceived,
|
||||
_ntfDelivered,
|
||||
_ntfFailed,
|
||||
_ntfCronDelivered,
|
||||
_ntfCronFailed,
|
||||
_ntfVrfQueued,
|
||||
_ntfVrfDelivered,
|
||||
_ntfVrfFailed,
|
||||
_ntfVrfInvalidTkn,
|
||||
_activeTokens,
|
||||
_activeSubs
|
||||
} =
|
||||
B.unlines
|
||||
[ "fromTime=" <> strEncode _fromTime,
|
||||
"tknCreated=" <> strEncode _tknCreated,
|
||||
"tknVerified=" <> strEncode _tknVerified,
|
||||
"tknDeleted=" <> strEncode _tknDeleted,
|
||||
"tknReplaced=" <> strEncode _tknReplaced,
|
||||
"subCreated=" <> strEncode _subCreated,
|
||||
"subDeleted=" <> strEncode _subDeleted,
|
||||
"ntfReceived=" <> strEncode _ntfReceived,
|
||||
"ntfDelivered=" <> strEncode _ntfDelivered,
|
||||
"ntfFailed=" <> strEncode _ntfFailed,
|
||||
"ntfCronDelivered=" <> strEncode _ntfCronDelivered,
|
||||
"ntfCronFailed=" <> strEncode _ntfCronFailed,
|
||||
"ntfVrfQueued=" <> strEncode _ntfVrfQueued,
|
||||
"ntfVrfDelivered=" <> strEncode _ntfVrfDelivered,
|
||||
"ntfVrfFailed=" <> strEncode _ntfVrfFailed,
|
||||
"ntfVrfInvalidTkn=" <> strEncode _ntfVrfInvalidTkn,
|
||||
"activeTokens:",
|
||||
strEncode _activeTokens,
|
||||
"activeSubs:",
|
||||
@@ -101,12 +209,42 @@ instance StrEncoding NtfServerStatsData where
|
||||
_tknCreated <- "tknCreated=" *> strP <* A.endOfLine
|
||||
_tknVerified <- "tknVerified=" *> strP <* A.endOfLine
|
||||
_tknDeleted <- "tknDeleted=" *> strP <* A.endOfLine
|
||||
_tknReplaced <- opt "tknReplaced="
|
||||
_subCreated <- "subCreated=" *> strP <* A.endOfLine
|
||||
_subDeleted <- "subDeleted=" *> strP <* A.endOfLine
|
||||
_ntfReceived <- "ntfReceived=" *> strP <* A.endOfLine
|
||||
_ntfDelivered <- "ntfDelivered=" *> strP <* A.endOfLine
|
||||
_ntfFailed <- opt "ntfFailed="
|
||||
_ntfCronDelivered <- opt "ntfCronDelivered="
|
||||
_ntfCronFailed <- opt "ntfCronFailed="
|
||||
_ntfVrfQueued <- opt "ntfVrfQueued="
|
||||
_ntfVrfDelivered <- opt "ntfVrfDelivered="
|
||||
_ntfVrfFailed <- opt "ntfVrfFailed="
|
||||
_ntfVrfInvalidTkn <- opt "ntfVrfInvalidTkn="
|
||||
_ <- "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}
|
||||
pure
|
||||
NtfServerStatsData
|
||||
{ _fromTime,
|
||||
_tknCreated,
|
||||
_tknVerified,
|
||||
_tknDeleted,
|
||||
_tknReplaced,
|
||||
_subCreated,
|
||||
_subDeleted,
|
||||
_ntfReceived,
|
||||
_ntfDelivered,
|
||||
_ntfFailed,
|
||||
_ntfCronDelivered,
|
||||
_ntfCronFailed,
|
||||
_ntfVrfQueued,
|
||||
_ntfVrfDelivered,
|
||||
_ntfVrfFailed,
|
||||
_ntfVrfInvalidTkn,
|
||||
_activeTokens,
|
||||
_activeSubs
|
||||
}
|
||||
where
|
||||
opt s = A.string s *> strP <* A.endOfLine <|> pure 0
|
||||
|
||||
Reference in New Issue
Block a user