227 lines
8.0 KiB
Haskell
227 lines
8.0 KiB
Haskell
{-# LANGUAGE OverloadedStrings #-}
|
|
|
|
module MetricsSpec (spec) where
|
|
|
|
import Data.HashMap.Strict (HashMap)
|
|
import qualified Data.HashMap.Strict as HM
|
|
import Data.List (isPrefixOf)
|
|
import Data.Text (Text)
|
|
import qualified Data.Text as T
|
|
import HomeAssistant.Runtime.Metrics
|
|
( DsType (..)
|
|
, DsSpec (..)
|
|
, dsTypeOf
|
|
, sanitizeName
|
|
, buildSchema
|
|
, buildCreateArgs
|
|
, buildUpdateArgs
|
|
, ensureRrd
|
|
, sampleAndUpdate
|
|
, parseInfoDs
|
|
, schemaMatches
|
|
, AppMetrics (..)
|
|
, registerAppMetrics
|
|
)
|
|
import qualified System.Metrics as M (Value (..))
|
|
import Test.Hspec
|
|
import Control.Exception (try, SomeException, finally)
|
|
import Control.Monad (forM_)
|
|
import System.Directory (findExecutable, getTemporaryDirectory, listDirectory, removeFile)
|
|
import System.Exit (ExitCode (ExitSuccess))
|
|
import System.Process (readProcessWithExitCode)
|
|
import qualified System.Metrics as Metrics
|
|
import qualified System.Metrics.Counter as Counter
|
|
import qualified System.Metrics.Gauge as Gauge
|
|
|
|
spec :: Spec
|
|
spec = do
|
|
describe "dsTypeOf" $ do
|
|
it "maps Counter to Derive" $
|
|
dsTypeOf (M.Counter 1000) `shouldBe` Just Derive
|
|
|
|
it "maps Gauge to Gauge" $
|
|
dsTypeOf (M.Gauge 500) `shouldBe` Just Gauge
|
|
|
|
it "maps Label to Nothing" $
|
|
dsTypeOf (M.Label "hello") `shouldBe` Nothing
|
|
|
|
describe "sanitizeName" $ do
|
|
it "replaces dots with underscores for short names" $
|
|
sanitizeName ("rts.gc.cpu_ms" :: Text) `shouldBe` "rts_gc_cpu_ms"
|
|
|
|
it "shortens names longer than 19 chars to 15 chars + _ + 3 hex" $ do
|
|
let result = sanitizeName ("rts.gc.par_balanced_bytes_copied" :: Text)
|
|
length result `shouldBe` 19
|
|
take 15 result `shouldBe` "rts_gc_par_bala"
|
|
drop 15 result `shouldBe` "_" ++ drop 16 result
|
|
|
|
it "is deterministic (same input -> same output)" $
|
|
sanitizeName ("rts.gc.peak_megabytes_allocated" :: Text)
|
|
`shouldBe` sanitizeName ("rts.gc.peak_megabytes_allocated" :: Text)
|
|
|
|
describe "buildSchema" $ do
|
|
it "builds sorted DsSpecs from counters and gauges, skipping labels" $
|
|
let sample :: HashMap Text M.Value
|
|
sample = HM.fromList
|
|
[ ("x.allocated", M.Counter 1000)
|
|
, ("a.bytes_used", M.Gauge 500)
|
|
, ("c.label_thing", M.Label "irrelevant")
|
|
]
|
|
in buildSchema sample `shouldBe`
|
|
[ DsSpec "a.bytes_used" "a_bytes_used" Gauge
|
|
, DsSpec "x.allocated" "x_allocated" Derive
|
|
]
|
|
|
|
it "produces dsName <= 19 chars for long ekg GC metric names" $
|
|
let sample :: HashMap Text M.Value
|
|
sample = HM.fromList
|
|
[ ("rts.gc.par_balanced_bytes_copied", M.Gauge 1)
|
|
, ("rts.gc.peak_megabytes_allocated", M.Gauge 2)
|
|
, ("rts.gc.cumulative_bytes_used", M.Counter 3)
|
|
]
|
|
in map (length . dsName) (buildSchema sample) `shouldSatisfy` all (<= 19)
|
|
|
|
describe "buildCreateArgs" $ do
|
|
it "builds create argv with mixed DERIVE and GAUGE DSes and RRAs" $
|
|
buildCreateArgs "test.rrd" 10
|
|
[ ("ds1", Derive)
|
|
, ("ds2", Gauge)
|
|
]
|
|
`shouldBe`
|
|
[ "create"
|
|
, "test.rrd"
|
|
, "--step"
|
|
, "10"
|
|
, "DS:ds1:DERIVE:20:0:U"
|
|
, "DS:ds2:GAUGE:20:0:U"
|
|
, "RRA:AVERAGE:0.5:1:6000"
|
|
, "RRA:MAX:0.5:1:6000"
|
|
, "RRA:AVERAGE:0.5:360:1680"
|
|
, "RRA:MAX:0.5:360:1680"
|
|
]
|
|
|
|
describe "buildUpdateArgs" $ do
|
|
it "builds update argv with numeric values" $
|
|
buildUpdateArgs "test.rrd" ["ds1", "ds2"] [Just 100, Just 200]
|
|
`shouldBe`
|
|
[ "update"
|
|
, "test.rrd"
|
|
, "--template"
|
|
, "ds1:ds2"
|
|
, "N:100:200"
|
|
]
|
|
|
|
it "renders Nothing as U (unknown)" $
|
|
buildUpdateArgs "test.rrd" ["ds1", "ds2"] [Just 100, Nothing]
|
|
`shouldBe`
|
|
[ "update"
|
|
, "test.rrd"
|
|
, "--template"
|
|
, "ds1:ds2"
|
|
, "N:100:U"
|
|
]
|
|
|
|
it "renders all-Nothing as all-U" $
|
|
buildUpdateArgs "test.rrd" ["ds1"] [Nothing]
|
|
`shouldBe`
|
|
[ "update"
|
|
, "test.rrd"
|
|
, "--template"
|
|
, "ds1"
|
|
, "N:U"
|
|
]
|
|
|
|
describe "parseInfoDs" $ do
|
|
it "extracts DS names and types from rrdtool info output" $
|
|
let info = unlines
|
|
[ "filename = \"test.rrd\""
|
|
, "step = 10"
|
|
, "ds[foo].index = 0"
|
|
, "ds[foo].type = \"DERIVE\""
|
|
, "ds[bar].type = \"GAUGE\""
|
|
, "rra[0].cf = \"AVERAGE\""
|
|
]
|
|
in parseInfoDs info `shouldBe` [("foo", Derive), ("bar", Gauge)]
|
|
|
|
it "ignores lines that are not ds type declarations" $
|
|
parseInfoDs "step = 10\nrra[0].cf = \"AVERAGE\"\n" `shouldBe` []
|
|
|
|
describe "schemaMatches" $ do
|
|
let ds name ty = DsSpec (T.pack name) name ty
|
|
it "is true for identical schemas regardless of order" $
|
|
schemaMatches [ds "b" Gauge, ds "a" Derive] [("a", Derive), ("b", Gauge)]
|
|
`shouldBe` True
|
|
|
|
it "is false when the derived schema has an added DS" $
|
|
schemaMatches [ds "a" Derive, ds "b" Gauge] [("a", Derive)]
|
|
`shouldBe` False
|
|
|
|
it "is false when the derived schema has a removed DS" $
|
|
schemaMatches [ds "a" Derive] [("a", Derive), ("b", Gauge)]
|
|
`shouldBe` False
|
|
|
|
it "is false when a DS type changed" $
|
|
schemaMatches [ds "a" Derive] [("a", Gauge)]
|
|
`shouldBe` False
|
|
|
|
describe "registerAppMetrics" $ do
|
|
it "registers both counters with the store" $ do
|
|
store <- Metrics.newStore
|
|
m <- registerAppMetrics store
|
|
Counter.inc (amTriggersIn m)
|
|
Counter.inc (amServicesOut m)
|
|
sample <- Metrics.sampleAll store
|
|
HM.lookup "hass.trigger.in" sample `shouldBe` Just (M.Counter 1)
|
|
HM.lookup "hass.service.out" sample `shouldBe` Just (M.Counter 1)
|
|
|
|
describe "end-to-end (rrdtool-gated)" $ do
|
|
it "creates an rrd, samples, and updates it" $ do
|
|
mRrdtool <- findExecutable "rrdtool"
|
|
case mRrdtool of
|
|
Nothing -> pendingWith "rrdtool not on PATH"
|
|
Just rrdtool -> do
|
|
store <- Metrics.newStore
|
|
c <- Metrics.createCounter "test.counter" store
|
|
g <- Metrics.createGauge "test.gauge" store
|
|
Counter.inc c
|
|
Gauge.set g 42
|
|
tmp <- getTemporaryDirectory
|
|
let rrdPath = tmp ++ "/hass-controller-metrics-test.rrd"
|
|
_ <- try (removeFile rrdPath) :: IO (Either SomeException ())
|
|
schema <- buildSchema <$> Metrics.sampleAll store
|
|
ensureRrd rrdtool rrdPath schema
|
|
sampleAndUpdate store rrdtool rrdPath schema
|
|
(rc, out, _) <- readProcessWithExitCode rrdtool ["fetch", rrdPath, "AVERAGE"] ""
|
|
rc `shouldBe` ExitSuccess
|
|
length out `shouldSatisfy` (> 0)
|
|
_ <- try (removeFile rrdPath) :: IO (Either SomeException ())
|
|
return ()
|
|
|
|
it "backs up and recreates the rrd when the schema changes" $ do
|
|
mRrdtool <- findExecutable "rrdtool"
|
|
case mRrdtool of
|
|
Nothing -> pendingWith "rrdtool not on PATH"
|
|
Just rrdtool -> do
|
|
tmp <- getTemporaryDirectory
|
|
let rrdPath = tmp ++ "/hass-controller-schema-change-test.rrd"
|
|
bakPrefix = "hass-controller-schema-change-test.rrd.bak-"
|
|
base = [ DsSpec "a" "a" Derive, DsSpec "b" "b" Gauge ]
|
|
expanded = base ++ [ DsSpec "c" "c" Derive ]
|
|
clean = do
|
|
stale <- filter (isPrefixOf bakPrefix) <$> listDirectory tmp
|
|
forM_ (rrdPath : map (\f -> tmp ++ "/" ++ f) stale) $ \f ->
|
|
try (removeFile f) :: IO (Either SomeException ())
|
|
clean
|
|
( do
|
|
ensureRrd rrdtool rrdPath base
|
|
ensureRrd rrdtool rrdPath base
|
|
noBackups <- filter (isPrefixOf bakPrefix) <$> listDirectory tmp
|
|
noBackups `shouldBe` []
|
|
ensureRrd rrdtool rrdPath expanded
|
|
backups <- filter (isPrefixOf bakPrefix) <$> listDirectory tmp
|
|
length backups `shouldBe` 1
|
|
(rc, out, _) <- readProcessWithExitCode rrdtool ["info", rrdPath] ""
|
|
rc `shouldBe` ExitSuccess
|
|
out `shouldContain` "ds[c].type"
|
|
) `finally` clean
|