From 88af6a313906957839566d00c6d031bfa54ef947 Mon Sep 17 00:00:00 2001 From: Mats Rauhala Date: Mon, 7 Sep 2026 21:30:42 +0300 Subject: [PATCH] Add Metrics module: pure rrdtool argv builders for ekg samples --- default.nix | 15 +++-- home-assistant-controller.cabal | 12 +++- src/HomeAssistant/Runtime/Metrics.hs | 72 ++++++++++++++++++++ test/Main.hs | 2 + test/MetricsSpec.hs | 98 ++++++++++++++++++++++++++++ 5 files changed, 192 insertions(+), 7 deletions(-) create mode 100644 src/HomeAssistant/Runtime/Metrics.hs create mode 100644 test/MetricsSpec.hs diff --git a/default.nix b/default.nix index 26df4c0..8c28190 100644 --- a/default.nix +++ b/default.nix @@ -1,6 +1,7 @@ { mkDerivation, aeson, annotated-exception, async, base, bytestring -, containers, hedgehog, hspec, hspec-hedgehog, katip, lens -, lens-aeson, lib, network, stm, text, time, uuid, websockets +, containers, directory, ekg-core, hedgehog, hspec, hspec-hedgehog +, katip, lens, lens-aeson, lib, network, process, stm, text, time +, unordered-containers, uuid, websockets }: mkDerivation { pname = "home-assistant-controller"; @@ -9,13 +10,15 @@ mkDerivation { isLibrary = true; isExecutable = true; libraryHaskellDepends = [ - aeson annotated-exception async base bytestring containers katip - lens lens-aeson network stm text time uuid websockets + aeson annotated-exception async base bytestring containers + directory ekg-core katip lens lens-aeson network process stm text + time unordered-containers uuid websockets ]; executableHaskellDepends = [ base ]; testHaskellDepends = [ - aeson annotated-exception async base containers hedgehog hspec - hspec-hedgehog katip stm text time uuid + aeson annotated-exception async base containers directory ekg-core + hedgehog hspec hspec-hedgehog katip process stm text time + unordered-containers uuid ]; license = lib.meta.getLicenseFromSpdxId "BSD-3-Clause"; mainProgram = "home-assistant-controller"; diff --git a/home-assistant-controller.cabal b/home-assistant-controller.cabal index 8b1c837..302d8e4 100644 --- a/home-assistant-controller.cabal +++ b/home-assistant-controller.cabal @@ -67,6 +67,7 @@ library , HomeAssistant.Runtime , HomeAssistant.Runtime.Bus , HomeAssistant.Runtime.Connection + , HomeAssistant.Runtime.Metrics , HomeAssistant.Runtime.Supervisor -- Modules included in this library but not exported. @@ -91,6 +92,10 @@ library , uuid , katip , containers + , ekg-core + , unordered-containers + , process + , directory -- Directories containing source files. hs-source-dirs: src @@ -136,6 +141,7 @@ test-suite home-assistant-controller-test , BedroomSpec , BusSpec , ConnectionSpec + , MetricsSpec , RuntimeSpec , SupervisorSpec , Support @@ -167,4 +173,8 @@ test-suite home-assistant-controller-test time, uuid, katip, - containers + containers, + ekg-core, + unordered-containers, + process, + directory diff --git a/src/HomeAssistant/Runtime/Metrics.hs b/src/HomeAssistant/Runtime/Metrics.hs new file mode 100644 index 0000000..8c3dc7a --- /dev/null +++ b/src/HomeAssistant/Runtime/Metrics.hs @@ -0,0 +1,72 @@ +{-# LANGUAGE OverloadedStrings #-} + +module HomeAssistant.Runtime.Metrics + ( DsType (..) + , DsSpec (..) + , dsTypeOf + , sanitizeName + , buildSchema + , buildCreateArgs + , buildUpdateArgs + ) where + +import Data.Int (Int64) +import Data.List (intercalate, sortBy) +import Data.Ord (comparing) +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.HashMap.Strict as HM +import qualified System.Metrics as M (Value (..), Sample) + +data DsType = Derive | Gauge + deriving (Eq, Show) + +data DsSpec = DsSpec + { dsEkgName :: Text + , dsName :: String + , dsType :: DsType + } + deriving (Eq, Show) + +dsTypeOf :: M.Value -> Maybe DsType +dsTypeOf (M.Counter _) = Just Derive +dsTypeOf (M.Gauge _) = Just Gauge +dsTypeOf _ = Nothing + +sanitizeName :: Text -> String +sanitizeName = T.unpack . T.replace "." "_" + +buildSchema :: M.Sample -> [DsSpec] +buildSchema sample = + sortBy (comparing dsName) + [ DsSpec ekgName (sanitizeName ekgName) dt + | (ekgName, val) <- HM.toList sample + , Just dt <- [dsTypeOf val] + ] + +buildCreateArgs :: FilePath -> Int -> [(String, DsType)] -> [String] +buildCreateArgs path step specs = + ["create", path, "--step", show step] + ++ concatMap dsArg specs + ++ rras + where + dsArg (name, Derive) = ["DS:" ++ name ++ ":DERIVE:20:0:U"] + dsArg (name, Gauge) = ["DS:" ++ name ++ ":GAUGE:20:0:U"] + rras = + [ "RRA:AVERAGE:0.5:1:6000" + , "RRA:MAX:0.5:1:6000" + , "RRA:AVERAGE:0.5:360:1680" + , "RRA:MAX:0.5:360:1680" + ] + +buildUpdateArgs :: FilePath -> [String] -> [Maybe Int64] -> [String] +buildUpdateArgs path names values = + [ "update" + , path + , "--template" + , intercalate ":" names + , "N:" ++ intercalate ":" (map renderValue values) + ] + where + renderValue Nothing = "U" + renderValue (Just n) = show n diff --git a/test/Main.hs b/test/Main.hs index 17f9bdf..09c5a4b 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -6,6 +6,7 @@ import qualified BackoffProp import qualified BedroomSpec import qualified BusSpec import qualified ConnectionSpec +import qualified MetricsSpec import qualified RuntimeSpec import qualified SupervisorSpec @@ -15,6 +16,7 @@ main = hspec $ do BedroomSpec.spec BusSpec.spec ConnectionSpec.spec + MetricsSpec.spec RuntimeSpec.spec SupervisorSpec.spec BackoffProp.spec diff --git a/test/MetricsSpec.hs b/test/MetricsSpec.hs new file mode 100644 index 0000000..7346540 --- /dev/null +++ b/test/MetricsSpec.hs @@ -0,0 +1,98 @@ +{-# LANGUAGE OverloadedStrings #-} + +module MetricsSpec (spec) where + +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as HM +import Data.Int (Int64) +import Data.Text (Text) +import HomeAssistant.Runtime.Metrics + ( DsType (..) + , DsSpec (..) + , dsTypeOf + , sanitizeName + , buildSchema + , buildCreateArgs + , buildUpdateArgs + ) +import qualified System.Metrics as M (Value (..)) +import Test.Hspec + +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" $ + sanitizeName ("rts.gc.bytes_allocated" :: Text) `shouldBe` "rts_gc_bytes_allocated" + + describe "buildSchema" $ do + it "builds sorted DsSpecs from counters and gauges, skipping labels" $ + let sample :: HashMap Text M.Value + sample = HM.fromList + [ ("rts.gc.bytes_allocated", M.Counter 1000) + , ("rts.gc.max_bytes_used", M.Gauge 500) + , ("rts.gc.label_thing", M.Label "irrelevant") + ] + in buildSchema sample `shouldBe` + [ DsSpec "rts.gc.bytes_allocated" "rts_gc_bytes_allocated" Derive + , DsSpec "rts.gc.max_bytes_used" "rts_gc_max_bytes_used" Gauge + ] + + 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" + ]