{-# LANGUAGE OverloadedStrings #-} module MetricsSpec (spec) where import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HM import Data.Int (Int64) 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 , metricsAction , parseInfoDs , schemaMatches , AppMetrics (..) , registerAppMetrics ) import qualified System.Metrics as M (Value (..)) import Test.Hspec import Control.Exception (try, SomeException) 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) 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 0) 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 ] _ <- try (removeFile rrdPath) :: IO (Either SomeException ()) 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" _ <- try (removeFile rrdPath) :: IO (Either SomeException ()) forM_ backups $ \f -> do _ <- try (removeFile (tmp ++ "/" ++ f)) :: IO (Either SomeException ()) pure ()