mirror of
https://github.com/simplex-chat/simplexmq.git
synced 2026-10-12 02:22:45 +00:00
stats, tests
This commit is contained in:
Evgeny @ SimpleX Chat
@@ -0,0 +1,250 @@
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE TupleSections #-}
|
||||
|
||||
module Simplex.Messaging.Server.AddressStats
|
||||
( AddrKey (..),
|
||||
AddrCounter (..),
|
||||
AddrStats (..),
|
||||
AddrStatsMap,
|
||||
AddrHistogram (..),
|
||||
ServerAddrStats (..),
|
||||
AddressStatsConfig (..),
|
||||
defaultAddressStatsPeriod,
|
||||
countBounds,
|
||||
kilobyteBounds,
|
||||
addrKey,
|
||||
addrKeyText,
|
||||
counterByName,
|
||||
newServerAddrStats,
|
||||
withAddrStats,
|
||||
openAddrStats,
|
||||
closeAddrStats,
|
||||
incAddrCounter,
|
||||
addAddrCounter,
|
||||
rolloverAddrStats,
|
||||
addressStatsThread,
|
||||
topAddresses,
|
||||
printTopAddresses,
|
||||
addressesArgsP,
|
||||
addressesArgs,
|
||||
addrHistogramMetrics,
|
||||
)
|
||||
where
|
||||
|
||||
import Control.Applicative (optional)
|
||||
import Control.Monad
|
||||
import Control.Monad.IO.Unlift
|
||||
import qualified Data.Attoparsec.ByteString.Char8 as A
|
||||
import Data.Bits (shiftL, shiftR, (.&.), (.|.))
|
||||
import Data.ByteString.Char8 (ByteString)
|
||||
import Data.IORef
|
||||
import Data.Int (Int64)
|
||||
import qualified Data.IntMap.Strict as IM
|
||||
import Data.List (find, foldl', sortOn)
|
||||
import Data.Map.Strict (Map)
|
||||
import qualified Data.Map.Strict as M
|
||||
import Data.Maybe (fromMaybe)
|
||||
import Data.Ord (Down (..))
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import Data.Text.Encoding (encodeUtf8)
|
||||
import qualified Data.Text.IO as T
|
||||
import Data.Word (Word32, Word64)
|
||||
import Network.Socket (SockAddr (..), Socket, getPeerName, hostAddress6ToTuple, hostAddressToTuple)
|
||||
import Numeric (showHex)
|
||||
import Simplex.Messaging.TMap (TMap)
|
||||
import qualified Simplex.Messaging.TMap as TM
|
||||
import Simplex.Messaging.Util (atomicModifyIORef'_, bshow, labelMyThread, safeDecodeUtf8, threadDelay', tshow, whenM, (<$$>))
|
||||
import System.IO (Handle, hPutStrLn)
|
||||
import UnliftIO.Exception (finally, tryAny)
|
||||
import UnliftIO.STM
|
||||
|
||||
data AddrKey
|
||||
= AKIPv4 Word32
|
||||
| AKIPv6 Word64
|
||||
deriving (Eq, Ord, Show)
|
||||
|
||||
class (Ord c, Enum c, Bounded c) => AddrCounter c where
|
||||
counterName :: c -> Text
|
||||
counterBounds :: c -> [Int]
|
||||
counterBounds _ = countBounds
|
||||
connectionsCounter :: c
|
||||
|
||||
data AddrStats c = AddrStats
|
||||
{ connectionsCount :: TVar Int,
|
||||
current :: Map c (IORef Int),
|
||||
previous :: Map c (IORef Int)
|
||||
}
|
||||
|
||||
type AddrStatsMap c = TMap AddrKey (AddrStats c)
|
||||
|
||||
data AddrHistogram = AddrHistogram
|
||||
{ bucketCounts :: [Int],
|
||||
countSum :: Int,
|
||||
addressCount :: Int,
|
||||
periodMax :: Int
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
|
||||
data ServerAddrStats c = ServerAddrStats
|
||||
{ addrStatsMap :: AddrStatsMap c,
|
||||
addrHistograms :: IORef (Map c AddrHistogram)
|
||||
}
|
||||
|
||||
newtype AddressStatsConfig = AddressStatsConfig
|
||||
{ period :: Int64
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
defaultAddressStatsPeriod :: Int64
|
||||
defaultAddressStatsPeriod = 300
|
||||
|
||||
countBounds :: [Int]
|
||||
countBounds = r10Bounds 5
|
||||
|
||||
kilobyteBounds :: [Int]
|
||||
kilobyteBounds = r10Bounds 7
|
||||
|
||||
r10Bounds :: Int -> [Int]
|
||||
r10Bounds decades =
|
||||
[1 .. 9]
|
||||
<> [(r * 10 ^ d + 50) `div` 100 | d <- [1 .. decades], r <- [100, 125, 160, 200, 250, 315, 400, 500, 630, 800]]
|
||||
<> [10 ^ (decades + 1)]
|
||||
|
||||
addrKey :: SockAddr -> Maybe AddrKey
|
||||
addrKey = \case
|
||||
SockAddrInet _ a ->
|
||||
let (b1, b2, b3, b4) = hostAddressToTuple a
|
||||
in Just $ AKIPv4 $ foldl' (\acc b -> acc `shiftL` 8 .|. fromIntegral b) 0 [b1, b2, b3, b4]
|
||||
SockAddrInet6 _ _ a _ -> Just $ case hostAddress6ToTuple a of
|
||||
(0, 0, 0, 0, 0, 0xffff, w1, w2) -> AKIPv4 $ fromIntegral w1 `shiftL` 16 .|. fromIntegral w2
|
||||
(w1, w2, w3, w4, _, _, _, _) -> AKIPv6 $ foldl' (\acc w -> acc `shiftL` 16 .|. fromIntegral w) 0 [w1, w2, w3, w4]
|
||||
_ -> Nothing
|
||||
|
||||
addrKeyText :: AddrKey -> Text
|
||||
addrKeyText = \case
|
||||
AKIPv4 a -> T.intercalate "." $ map (\s -> tshow $ (a `shiftR` s) .&. 0xff) [24, 16, 8, 0]
|
||||
AKIPv6 p -> T.intercalate ":" (map (\s -> T.pack $ showHex ((p `shiftR` s) .&. 0xffff) "") [48, 32, 16, 0]) <> "::/64"
|
||||
|
||||
counterByName :: AddrCounter c => Text -> Maybe c
|
||||
counterByName name = find ((name ==) . counterName) [minBound .. maxBound]
|
||||
|
||||
newServerAddrStats :: AddrCounter c => IO (ServerAddrStats c)
|
||||
newServerAddrStats = ServerAddrStats <$> TM.emptyIO <*> newIORef (M.fromList $ map (\c -> (c, emptyHistogram c)) [minBound .. maxBound])
|
||||
where
|
||||
emptyHistogram c = AddrHistogram {bucketCounts = map (const 0) (counterBounds c), countSum = 0, addressCount = 0, periodMax = 0}
|
||||
|
||||
newAddrStats :: AddrCounter c => IO (AddrStats c)
|
||||
newAddrStats = AddrStats <$> newTVarIO 0 <*> newCells <*> newCells
|
||||
where
|
||||
newCells = M.fromList <$> mapM (\c -> (c,) <$> newIORef 0) [minBound .. maxBound]
|
||||
|
||||
withAddrStats :: (AddrCounter c, MonadUnliftIO m) => Maybe (AddrStatsMap c) -> Socket -> (Maybe (AddrStats c) -> m a) -> m a
|
||||
withAddrStats m_ sock action = case m_ of
|
||||
Just m ->
|
||||
liftIO (addrKey <$$> tryAny (getPeerName sock)) >>= \case
|
||||
Right (Just k) -> do
|
||||
s <- liftIO $ openAddrStats m k
|
||||
action (Just s) `finally` liftIO (closeAddrStats s)
|
||||
_ -> action Nothing
|
||||
Nothing -> action Nothing
|
||||
|
||||
openAddrStats :: AddrCounter c => AddrStatsMap c -> AddrKey -> IO (AddrStats c)
|
||||
openAddrStats m k = do
|
||||
new <- maybe newAddrStats pure =<< TM.lookupIO k m
|
||||
s <- atomically $ TM.lookup k m >>= maybe (new <$ TM.insert k new m) pure >>= \entry -> entry <$ modifyTVar' (connectionsCount entry) (+ 1)
|
||||
s <$ incAddrCounter s connectionsCounter
|
||||
|
||||
closeAddrStats :: AddrStats c -> IO ()
|
||||
closeAddrStats AddrStats {connectionsCount} = atomically $ modifyTVar' connectionsCount (subtract 1)
|
||||
|
||||
incAddrCounter :: AddrCounter c => AddrStats c -> c -> IO ()
|
||||
incAddrCounter s c = addAddrCounter s c 1
|
||||
|
||||
addAddrCounter :: AddrCounter c => AddrStats c -> c -> Int -> IO ()
|
||||
addAddrCounter AddrStats {current} c n = forM_ (M.lookup c current) $ \cell -> atomicModifyIORef'_ cell (+ n)
|
||||
|
||||
rolloverAddrStats :: AddrCounter c => ServerAddrStats c -> IO ()
|
||||
rolloverAddrStats ServerAddrStats {addrStatsMap, addrHistograms} = do
|
||||
entries <- M.toList <$> readTVarIO addrStatsMap
|
||||
closingCounts <- forM entries $ \(k, s) -> do
|
||||
counts <- closePeriod s
|
||||
when (all (== 0) counts) $ atomically $ deleteIdle k s
|
||||
pure counts
|
||||
let periodCounts = M.unionsWith (<>) $ map (M.map (: []) . M.filter (> 0)) closingCounts
|
||||
atomicModifyIORef'_ addrHistograms $ M.mapWithKey $ \c -> addPeriodCounts (counterBounds c) (M.findWithDefault [] c periodCounts)
|
||||
where
|
||||
closePeriod AddrStats {current, previous} = M.traverseWithKey closeCell current
|
||||
where
|
||||
closeCell c cell = do
|
||||
n <- atomicModifyIORef' cell (0,)
|
||||
forM_ (M.lookup c previous) (`writeIORef` n)
|
||||
pure n
|
||||
deleteIdle k AddrStats {connectionsCount} =
|
||||
whenM ((0 ==) <$> readTVar connectionsCount) $ TM.delete k addrStatsMap
|
||||
|
||||
addPeriodCounts :: [Int] -> [Int] -> AddrHistogram -> AddrHistogram
|
||||
addPeriodCounts bounds ns AddrHistogram {bucketCounts, countSum, addressCount} =
|
||||
AddrHistogram
|
||||
{ bucketCounts = zipWith (+) bucketCounts $ scanl1 (+) $ map (\i -> IM.findWithDefault 0 i boundCounts) [0 .. length bounds - 1],
|
||||
countSum = countSum + sum ns,
|
||||
addressCount = addressCount + length ns,
|
||||
periodMax = maximum (0 : ns)
|
||||
}
|
||||
where
|
||||
boundCounts = IM.fromListWith (+) $ map (\n -> (length $ takeWhile (< n) bounds, 1)) ns
|
||||
|
||||
addressStatsThread :: AddrCounter c => AddressStatsConfig -> ServerAddrStats c -> IO ()
|
||||
addressStatsThread AddressStatsConfig {period} stats = do
|
||||
labelMyThread "addressStatsThread"
|
||||
forever $ threadDelay' (period * 1000000) >> rolloverAddrStats stats
|
||||
|
||||
topAddresses :: AddrCounter c => AddrStatsMap c -> c -> Int -> IO [(AddrKey, Int, Int)]
|
||||
topAddresses m c n = do
|
||||
entries <- M.toList <$> readTVarIO m
|
||||
counts <- forM entries $ \(k, AddrStats {previous, current}) -> (k,,) <$> cellValue previous <*> cellValue current
|
||||
pure $ take n $ sortOn (\(_, p, cur) -> Down (p + cur)) $ filter (\(_, p, cur) -> p + cur > 0) counts
|
||||
where
|
||||
cellValue = maybe (pure 0) readIORef . M.lookup c
|
||||
|
||||
printTopAddresses :: AddrCounter c => Handle -> Maybe (AddrStatsMap c) -> Text -> Maybe Int -> IO ()
|
||||
printTopAddresses h m_ name n_ = case m_ of
|
||||
Just m -> case counterByName name of
|
||||
Just c -> do
|
||||
rows <- topAddresses m c (fromMaybe 10 n_)
|
||||
hPutStrLn h "address,previous,current"
|
||||
forM_ rows $ \(k, p, cur) -> T.hPutStrLn h $ addrKeyText k <> "," <> tshow p <> "," <> tshow cur
|
||||
Nothing -> hPutStrLn h "error: unknown counter"
|
||||
Nothing -> hPutStrLn h "error: address statistics are off"
|
||||
|
||||
addressesArgsP :: A.Parser (Text, Maybe Int)
|
||||
addressesArgsP = (,) <$> (A.space *> (safeDecodeUtf8 <$> A.takeTill (== ' '))) <*> optional (A.space *> A.decimal)
|
||||
|
||||
addressesArgs :: Text -> Maybe Int -> ByteString
|
||||
addressesArgs name n_ = encodeUtf8 name <> maybe "" ((" " <>) . bshow) n_
|
||||
|
||||
addrHistogramMetrics :: AddrCounter c => Text -> Text -> Map c AddrHistogram -> Text
|
||||
addrHistogramMetrics prefix tsEpoch histograms =
|
||||
"# Client addresses\n\
|
||||
\# ----------------\n\
|
||||
\\n"
|
||||
<> "# HELP " <> countMetric <> " Counts of client addresses per period\n"
|
||||
<> "# TYPE " <> countMetric <> " histogram\n"
|
||||
<> T.concat (map countLines hs)
|
||||
<> "\n# HELP " <> maxMetric <> " Maximum count of a client address in the last period\n"
|
||||
<> "# TYPE " <> maxMetric <> " gauge\n"
|
||||
<> T.concat (map (\(c, AddrHistogram {periodMax}) -> sample maxMetric c [] periodMax) hs)
|
||||
<> "\n"
|
||||
where
|
||||
hs = M.toList histograms
|
||||
countMetric = prefix <> "_client_address_period_count"
|
||||
maxMetric = prefix <> "_client_address_period_max"
|
||||
countLines (c, AddrHistogram {bucketCounts, countSum, addressCount}) =
|
||||
T.concat (zipWith (\b cnt -> sample (countMetric <> "_bucket") c [("le", tshow b)] cnt) (counterBounds c) bucketCounts)
|
||||
<> sample (countMetric <> "_bucket") c [("le", "+Inf")] addressCount
|
||||
<> sample (countMetric <> "_sum") c [] countSum
|
||||
<> sample (countMetric <> "_count") c [] addressCount
|
||||
sample metric c labels v =
|
||||
metric <> "{" <> T.intercalate "," (map (\(l, lv) -> l <> "=\"" <> lv <> "\"") (("counter", counterName c) : labels)) <> "} " <> tshow v <> " " <> tsEpoch <> "\n"
|
||||
@@ -0,0 +1,326 @@
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
|
||||
module CoreTests.AddressStatsTests where
|
||||
|
||||
import Data.ByteString.Char8 (ByteString)
|
||||
import qualified Data.ByteString.Char8 as B
|
||||
import Data.IORef (readIORef)
|
||||
import Data.List.NonEmpty (NonEmpty (..))
|
||||
import qualified Data.Map.Strict as M
|
||||
import qualified Data.Set as S
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import Data.Text.Encoding (decodeLatin1)
|
||||
import Network.Socket (SockAddr (..), tupleToHostAddress, tupleToHostAddress6)
|
||||
import qualified Simplex.FileTransfer.Protocol as XFTP
|
||||
import Simplex.FileTransfer.Server.Env (XFTPAddrCounter (..), xftpCmdCounter)
|
||||
import Simplex.FileTransfer.Transport (supportedFileServerVRange)
|
||||
import qualified Simplex.Messaging.Crypto as C
|
||||
import Simplex.Messaging.Protocol
|
||||
import Simplex.Messaging.Server.AddressStats
|
||||
import Simplex.Messaging.Server.Env.STM (SMPAddrCounter (..), smpCmdCounter)
|
||||
import Simplex.Messaging.SimplexName (SimplexDomain (..), SimplexTLD (..))
|
||||
import Simplex.Messaging.Transport (supportedClientSMPRelayVRange, supportedServerSMPRelayVRange)
|
||||
import Simplex.Messaging.Version (VersionRange (..))
|
||||
import Test.Hspec hiding (fit, it)
|
||||
import UnliftIO.STM
|
||||
import Util
|
||||
#if defined(dbServerPostgres)
|
||||
import qualified Simplex.Messaging.Notifications.Protocol as NTF
|
||||
import Simplex.Messaging.Notifications.Server.Env (NtfAddrCounter (..), ntfCmdCounter)
|
||||
import Simplex.Messaging.Notifications.Transport (supportedServerNTFVRange)
|
||||
#endif
|
||||
|
||||
data TestCounter = TCConnections | TCSend | TCGet
|
||||
deriving (Eq, Ord, Enum, Bounded, Show)
|
||||
|
||||
instance AddrCounter TestCounter where
|
||||
counterName = \case
|
||||
TCConnections -> "connections"
|
||||
TCSend -> "SEND"
|
||||
TCGet -> "GET"
|
||||
counterBounds _ = [1, 2, 5, 10]
|
||||
connectionsCounter = TCConnections
|
||||
|
||||
addr1, addr2, addr3, addr4 :: AddrKey
|
||||
addr1 = AKIPv4 1
|
||||
addr2 = AKIPv4 2
|
||||
addr3 = AKIPv4 3
|
||||
addr4 = AKIPv4 4
|
||||
|
||||
addressStatsTests :: Spec
|
||||
addressStatsTests = do
|
||||
describe "addrKey" addrKeyTests
|
||||
describe "bounds" boundsTests
|
||||
describe "counterByName" counterByNameTests
|
||||
describe "openAddrStats" openAddrStatsTests
|
||||
describe "rolloverAddrStats" rolloverTests
|
||||
describe "topAddresses" topAddressesTests
|
||||
describe "addrHistogramMetrics" metricsTests
|
||||
describe "command counters" commandCounterTests
|
||||
|
||||
addrKeyTests :: Spec
|
||||
addrKeyTests = do
|
||||
it "should use IPv4 address" $
|
||||
addrKeyText <$> addrKey (ipv4 (192, 168, 1, 2)) `shouldBe` Just "192.168.1.2"
|
||||
it "should use IPv4 address of IPv4-mapped IPv6 address" $
|
||||
addrKey (ipv6 (0, 0, 0, 0, 0, 0xffff, 0xc0a8, 0x0102)) `shouldBe` addrKey (ipv4 (192, 168, 1, 2))
|
||||
it "should use one key for IPv6 addresses in one /64" $ do
|
||||
addrKey (ipv6 (0x2001, 0xdb8, 1, 2, 3, 4, 5, 6)) `shouldBe` addrKey (ipv6 (0x2001, 0xdb8, 1, 2, 7, 8, 9, 10))
|
||||
addrKeyText <$> addrKey (ipv6 (0x2001, 0xdb8, 1, 2, 3, 4, 5, 6)) `shouldBe` Just "2001:db8:1:2::/64"
|
||||
it "should use different keys for IPv6 addresses in different /64" $
|
||||
addrKey (ipv6 (0x2001, 0xdb8, 1, 2, 3, 4, 5, 6)) `shouldNotBe` addrKey (ipv6 (0x2001, 0xdb8, 1, 3, 3, 4, 5, 6))
|
||||
it "should not use other address types" $
|
||||
addrKey (SockAddrUnix "tests/tmp/socket") `shouldBe` Nothing
|
||||
where
|
||||
ipv4 a = SockAddrInet 443 $ tupleToHostAddress a
|
||||
ipv6 a = SockAddrInet6 443 0 (tupleToHostAddress6 a) 0
|
||||
|
||||
boundsTests :: Spec
|
||||
boundsTests = do
|
||||
it "should use R10 values up to 1000000 for counts" $
|
||||
countBounds
|
||||
`shouldBe` [ 1, 2, 3, 4, 5, 6, 7, 8, 9,
|
||||
10, 13, 16, 20, 25, 32, 40, 50, 63, 80,
|
||||
100, 125, 160, 200, 250, 315, 400, 500, 630, 800,
|
||||
1000, 1250, 1600, 2000, 2500, 3150, 4000, 5000, 6300, 8000,
|
||||
10000, 12500, 16000, 20000, 25000, 31500, 40000, 50000, 63000, 80000,
|
||||
100000, 125000, 160000, 200000, 250000, 315000, 400000, 500000, 630000, 800000,
|
||||
1000000
|
||||
]
|
||||
it "should use R10 values up to 100000000 for kilobytes" $ do
|
||||
take 60 kilobyteBounds `shouldBe` countBounds
|
||||
drop 59 kilobyteBounds
|
||||
`shouldBe` [ 1000000, 1250000, 1600000, 2000000, 2500000, 3150000, 4000000, 5000000, 6300000, 8000000,
|
||||
10000000, 12500000, 16000000, 20000000, 25000000, 31500000, 40000000, 50000000, 63000000, 80000000,
|
||||
100000000
|
||||
]
|
||||
|
||||
counterByNameTests :: Spec
|
||||
counterByNameTests = do
|
||||
it "should find SMP counters" $ testCounterNames [minBound .. maxBound :: SMPAddrCounter]
|
||||
it "should find XFTP counters" $ testCounterNames [minBound .. maxBound :: XFTPAddrCounter]
|
||||
#if defined(dbServerPostgres)
|
||||
it "should find NTF counters" $ testCounterNames [minBound .. maxBound :: NtfAddrCounter]
|
||||
#endif
|
||||
it "should not find unknown counter" $
|
||||
counterByName "unknown" `shouldBe` (Nothing :: Maybe SMPAddrCounter)
|
||||
where
|
||||
testCounterNames :: (AddrCounter c, Show c) => [c] -> Expectation
|
||||
testCounterNames cs = map (counterByName . counterName) cs `shouldBe` map Just cs
|
||||
|
||||
openAddrStatsTests :: Spec
|
||||
openAddrStatsTests =
|
||||
it "should count connections of one address in one entry" $ do
|
||||
ServerAddrStats {addrStatsMap = m} <- newServerAddrStats
|
||||
s <- openAddrStats m addr1
|
||||
s' <- openAddrStats m addr1
|
||||
readTVarIO (connectionsCount s) `shouldReturn` 2
|
||||
counts s TCConnections `shouldReturn` (0, 2)
|
||||
closeAddrStats s'
|
||||
readTVarIO (connectionsCount s) `shouldReturn` 1
|
||||
|
||||
rolloverTests :: Spec
|
||||
rolloverTests = do
|
||||
it "should add non-zero closing counts to histograms" $ do
|
||||
stats@ServerAddrStats {addrStatsMap = m, addrHistograms} <- newServerAddrStats
|
||||
s1 <- openAddrStats m addr1
|
||||
s2 <- openAddrStats m addr2
|
||||
addAddrCounter s1 TCSend 3
|
||||
addAddrCounter s2 TCSend 7
|
||||
rolloverAddrStats stats
|
||||
readIORef addrHistograms
|
||||
`shouldReturn` M.fromList
|
||||
[ (TCConnections, AddrHistogram [2, 2, 2, 2] 2 2 1),
|
||||
(TCSend, AddrHistogram [0, 0, 1, 2] 10 2 7),
|
||||
(TCGet, AddrHistogram [0, 0, 0, 0] 0 0 0)
|
||||
]
|
||||
addAddrCounter s1 TCSend 20
|
||||
rolloverAddrStats stats
|
||||
readIORef addrHistograms
|
||||
`shouldReturn` M.fromList
|
||||
[ (TCConnections, AddrHistogram [2, 2, 2, 2] 2 2 0),
|
||||
(TCSend, AddrHistogram [0, 0, 1, 2] 30 3 20),
|
||||
(TCGet, AddrHistogram [0, 0, 0, 0] 0 0 0)
|
||||
]
|
||||
it "should set previous counts to closing counts" $ do
|
||||
stats@ServerAddrStats {addrStatsMap = m} <- newServerAddrStats
|
||||
s <- openAddrStats m addr1
|
||||
addAddrCounter s TCSend 3
|
||||
counts s TCSend `shouldReturn` (0, 3)
|
||||
rolloverAddrStats stats
|
||||
counts s TCSend `shouldReturn` (3, 0)
|
||||
addAddrCounter s TCSend 5
|
||||
rolloverAddrStats stats
|
||||
counts s TCSend `shouldReturn` (5, 0)
|
||||
rolloverAddrStats stats
|
||||
counts s TCSend `shouldReturn` (0, 0)
|
||||
it "should keep entries with open connections or closing counts, and delete other entries" $ do
|
||||
stats@ServerAddrStats {addrStatsMap = m} <- newServerAddrStats
|
||||
_ <- openAddrStats m addr1
|
||||
s2 <- openAddrStats m addr2
|
||||
s3 <- openAddrStats m addr3
|
||||
closeAddrStats s3
|
||||
rolloverAddrStats stats
|
||||
M.keys <$> readTVarIO m `shouldReturn` [addr1, addr2, addr3]
|
||||
addAddrCounter s2 TCSend 1
|
||||
closeAddrStats s2
|
||||
rolloverAddrStats stats
|
||||
M.keys <$> readTVarIO m `shouldReturn` [addr1, addr2]
|
||||
rolloverAddrStats stats
|
||||
M.keys <$> readTVarIO m `shouldReturn` [addr1]
|
||||
|
||||
topAddressesTests :: Spec
|
||||
topAddressesTests =
|
||||
it "should return addresses with non-zero counts, sorted by the sum of previous and current counts" $ do
|
||||
stats@ServerAddrStats {addrStatsMap = m} <- newServerAddrStats
|
||||
[s1, s2, s3, _] <- mapM (openAddrStats m) [addr1, addr2, addr3, addr4]
|
||||
addAddrCounter s1 TCSend 3
|
||||
addAddrCounter s2 TCSend 7
|
||||
rolloverAddrStats stats
|
||||
addAddrCounter s1 TCSend 5
|
||||
addAddrCounter s3 TCSend 10
|
||||
topAddresses m TCSend 10 `shouldReturn` [(addr3, 0, 10), (addr1, 3, 5), (addr2, 7, 0)]
|
||||
topAddresses m TCSend 2 `shouldReturn` [(addr3, 0, 10), (addr1, 3, 5)]
|
||||
|
||||
metricsTests :: Spec
|
||||
metricsTests =
|
||||
it "should encode histograms and maximums as Prometheus metrics" $
|
||||
addrHistogramMetrics "simplex_test" "1767225600000" histograms
|
||||
`shouldBe` T.unlines
|
||||
[ "# Client addresses",
|
||||
"# ----------------",
|
||||
"",
|
||||
"# HELP simplex_test_client_address_period_count Counts of client addresses per period",
|
||||
"# TYPE simplex_test_client_address_period_count histogram",
|
||||
"simplex_test_client_address_period_count_bucket{counter=\"SEND\",le=\"1\"} 0 1767225600000",
|
||||
"simplex_test_client_address_period_count_bucket{counter=\"SEND\",le=\"2\"} 0 1767225600000",
|
||||
"simplex_test_client_address_period_count_bucket{counter=\"SEND\",le=\"5\"} 1 1767225600000",
|
||||
"simplex_test_client_address_period_count_bucket{counter=\"SEND\",le=\"10\"} 2 1767225600000",
|
||||
"simplex_test_client_address_period_count_bucket{counter=\"SEND\",le=\"+Inf\"} 2 1767225600000",
|
||||
"simplex_test_client_address_period_count_sum{counter=\"SEND\"} 10 1767225600000",
|
||||
"simplex_test_client_address_period_count_count{counter=\"SEND\"} 2 1767225600000",
|
||||
"simplex_test_client_address_period_count_bucket{counter=\"GET\",le=\"1\"} 0 1767225600000",
|
||||
"simplex_test_client_address_period_count_bucket{counter=\"GET\",le=\"2\"} 0 1767225600000",
|
||||
"simplex_test_client_address_period_count_bucket{counter=\"GET\",le=\"5\"} 0 1767225600000",
|
||||
"simplex_test_client_address_period_count_bucket{counter=\"GET\",le=\"10\"} 0 1767225600000",
|
||||
"simplex_test_client_address_period_count_bucket{counter=\"GET\",le=\"+Inf\"} 1 1767225600000",
|
||||
"simplex_test_client_address_period_count_sum{counter=\"GET\"} 12 1767225600000",
|
||||
"simplex_test_client_address_period_count_count{counter=\"GET\"} 1 1767225600000",
|
||||
"",
|
||||
"# HELP simplex_test_client_address_period_max Maximum count of a client address in the last period",
|
||||
"# TYPE simplex_test_client_address_period_max gauge",
|
||||
"simplex_test_client_address_period_max{counter=\"SEND\"} 7 1767225600000",
|
||||
"simplex_test_client_address_period_max{counter=\"GET\"} 12 1767225600000",
|
||||
""
|
||||
]
|
||||
where
|
||||
histograms =
|
||||
M.fromList
|
||||
[ (TCSend, AddrHistogram [0, 0, 1, 2] 10 2 7),
|
||||
(TCGet, AddrHistogram [0, 0, 0, 0] 12 1 12)
|
||||
]
|
||||
|
||||
commandCounterTests :: Spec
|
||||
commandCounterTests = do
|
||||
it "should count each SMP command in the counter named by its tag" $ do
|
||||
cmds <- smpCommands
|
||||
map (counterName . smpCmdCounter) cmds `shouldBe` map (commandTag . encodeProtocol (maxVersion supportedServerSMPRelayVRange)) cmds
|
||||
S.fromList (map smpCmdCounter cmds) `shouldBe` S.fromList [SACNew .. SACRslv]
|
||||
it "should count each XFTP command in the counter named by its tag" $ do
|
||||
cmds <- xftpCommands
|
||||
map (counterName . xftpCmdCounter) cmds `shouldBe` map (commandTag . encodeProtocol (maxVersion supportedFileServerVRange)) cmds
|
||||
S.fromList (map xftpCmdCounter cmds) `shouldBe` S.fromList [XACFNew .. XACPing]
|
||||
#if defined(dbServerPostgres)
|
||||
it "should count each NTF command in the counter named by its tag" $ do
|
||||
cmds <- ntfCommands
|
||||
map (counterName . ntfCmdCounter) cmds `shouldBe` map (commandTag . encodeProtocol (maxVersion supportedServerNTFVRange)) cmds
|
||||
S.fromList (map ntfCmdCounter cmds) `shouldBe` S.fromList [NACTNew .. NACPing]
|
||||
#endif
|
||||
where
|
||||
commandTag :: ByteString -> Text
|
||||
commandTag = decodeLatin1 . B.takeWhile (/= ' ')
|
||||
|
||||
counts :: AddrStats TestCounter -> TestCounter -> IO (Int, Int)
|
||||
counts AddrStats {previous, current} c = (,) <$> readIORef (previous M.! c) <*> readIORef (current M.! c)
|
||||
|
||||
testKeys :: IO (C.APublicAuthKey, C.APrivateAuthKey, C.PublicKeyX25519)
|
||||
testKeys = do
|
||||
g <- C.newRandom
|
||||
(authKey, authPrivKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
|
||||
(dhKey, _ :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g
|
||||
pure (authKey, authPrivKey, dhKey)
|
||||
|
||||
testSMPServer :: SMPServer
|
||||
testSMPServer = SMPServer "localhost" "5001" (C.KeyHash "hash")
|
||||
|
||||
smpCommands :: IO [Cmd]
|
||||
smpCommands = do
|
||||
(authKey, _, dhKey) <- testKeys
|
||||
let newQueue = NewQueueReq {rcvAuthKey = authKey, rcvDhKey = dhKey, auth_ = Nothing, subMode = SMSubscribe, queueReqData = Nothing, ntfCreds = Nothing}
|
||||
linkData = (EncDataBytes "fixed", EncDataBytes "user")
|
||||
name = NQDomain SimplexDomain {nameTLD = TLDSimplex, domain = "alice", subDomain = []}
|
||||
pure
|
||||
[ Cmd SCreator $ NEW newQueue,
|
||||
Cmd SRecipient SUB,
|
||||
Cmd SRecipientService $ SUBS 1 mempty,
|
||||
Cmd SRecipient $ KEY authKey,
|
||||
Cmd SRecipient $ RKEY (authKey :| []),
|
||||
Cmd SRecipient $ LSET (EntityId "link") linkData,
|
||||
Cmd SRecipient LDEL,
|
||||
Cmd SRecipient $ NKEY authKey dhKey,
|
||||
Cmd SRecipient NDEL,
|
||||
Cmd SRecipient GET,
|
||||
Cmd SRecipient $ ACK "message",
|
||||
Cmd SRecipient OFF,
|
||||
Cmd SRecipient DEL,
|
||||
Cmd SRecipient QUE,
|
||||
Cmd SSender $ SKEY authKey,
|
||||
Cmd SSender $ SEND noMsgFlags "hello",
|
||||
Cmd SIdleClient PING,
|
||||
Cmd SSenderLink $ LKEY authKey,
|
||||
Cmd SSenderLink LGET,
|
||||
Cmd SNotifier NSUB,
|
||||
Cmd SNotifierService $ NSUBS 1 mempty,
|
||||
Cmd SProxiedClient $ PRXY testSMPServer Nothing,
|
||||
Cmd SProxiedClient $ PFWD (maxVersion supportedClientSMPRelayVRange) dhKey (EncTransmission "transmission"),
|
||||
Cmd SProxyService $ RFWD (EncFwdTransmission "transmission"),
|
||||
Cmd SResolver $ RSLV name
|
||||
]
|
||||
|
||||
xftpCommands :: IO [XFTP.FileCmd]
|
||||
xftpCommands = do
|
||||
(authKey, _, dhKey) <- testKeys
|
||||
pure
|
||||
[ XFTP.FileCmd XFTP.SFSender $ XFTP.FNEW (XFTP.FileInfo authKey 65536 "digest") (authKey :| []) Nothing Nothing,
|
||||
XFTP.FileCmd XFTP.SFSender $ XFTP.FADD (authKey :| []),
|
||||
XFTP.FileCmd XFTP.SFSender XFTP.FPUT,
|
||||
XFTP.FileCmd XFTP.SFSender XFTP.FDEL,
|
||||
XFTP.FileCmd XFTP.SFRecipient $ XFTP.FGET dhKey,
|
||||
XFTP.FileCmd XFTP.SFRecipient XFTP.FACK,
|
||||
XFTP.FileCmd XFTP.SFRecipient XFTP.PING
|
||||
]
|
||||
|
||||
#if defined(dbServerPostgres)
|
||||
ntfCommands :: IO [NTF.NtfCmd]
|
||||
ntfCommands = do
|
||||
(authKey, authPrivKey, dhKey) <- testKeys
|
||||
let token = NTF.DeviceToken NTF.PPApnsTest "token"
|
||||
queue = NTF.SMPQueueNtf testSMPServer (EntityId "notifier")
|
||||
pure
|
||||
[ NTF.NtfCmd NTF.SToken $ NTF.TNEW $ NTF.NewNtfTkn token authKey dhKey,
|
||||
NTF.NtfCmd NTF.SToken $ NTF.TVFY $ NTF.NtfRegCode "code",
|
||||
NTF.NtfCmd NTF.SToken NTF.TCHK,
|
||||
NTF.NtfCmd NTF.SToken $ NTF.TRPL token,
|
||||
NTF.NtfCmd NTF.SToken NTF.TDEL,
|
||||
NTF.NtfCmd NTF.SToken $ NTF.TCRN 20,
|
||||
NTF.NtfCmd NTF.SSubscription $ NTF.SNEW $ NTF.NewNtfSub (EntityId "token") queue authPrivKey,
|
||||
NTF.NtfCmd NTF.SSubscription NTF.SCHK,
|
||||
NTF.NtfCmd NTF.SSubscription NTF.SDEL,
|
||||
NTF.NtfCmd NTF.SSubscription NTF.PING
|
||||
]
|
||||
#endif
|
||||
Reference in New Issue
Block a user