MasseR/home-assistant-controller
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Merge feat/ekg-rrd-metrics: ekg-core RTS metrics -> rrd export

Browse Source
This commit is contained in:
MasseR
2026-09-07 21:44:56 +03:00
parent 7b6b529120 f7849ac889
commit e30a28c9ef
7 changed files with 282 additions and 9 deletions
Download Patch File Download Diff File Expand all files Collapse all files
default.nix
+9 -6
View File
@@ -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";
flake.nix
+11 -1
View File
@@ -20,7 +20,15 @@
});
});
in rec {
packages.home-assistant-controller = pkgs.haskell.lib.justStaticExecutables hp.home-assistant-controller;
packages.home-assistant-controller = pkgs.symlinkJoin {
name = "home-assistant-controller";
paths = [ (pkgs.haskell.lib.justStaticExecutables hp.home-assistant-controller) ];
nativeBuildInputs = [ pkgs.makeWrapper ];
postBuild = ''
wrapProgram $out/bin/home-assistant-controller \
--set HA_RRDTOOL ${pkgs.lib.getBin pkgs.rrdtool}/bin/rrdtool
'';
};
defaultPackage = packages.home-assistant-controller;
devShell = hp.shellFor {
packages = h: [h.home-assistant-controller];
@@ -34,6 +42,8 @@
hp.graphmod
hp.haskell-language-server
rrdtool
];
};
}
home-assistant-controller.cabal
+12 -2
View File
@@ -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
@@ -121,7 +126,7 @@ executable home-assistant-controller
-- Base language which the package is written in.
default-language: GHC2024
ghc-options: -threaded
ghc-options: -threaded -with-rtsopts=-T
test-suite home-assistant-controller-test
-- Import common warning flags.
@@ -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
src/HomeAssistant/Runtime.hs
+8
View File
@@ -34,6 +34,9 @@ import Control.Monad.IO.Class (liftIO, MonadIO)
import Control.Monad.Fix (MonadFix)
import HomeAssistant.Controller.Ruuvi (ruuviController)
import HomeAssistant.Controller.Children (schoolLightController)
import Data.Maybe (fromMaybe)
import qualified System.Metrics
import qualified HomeAssistant.Runtime.Metrics
step :: (MonadFix m, MonadIO m) => (forall x. eff x -> m x) -> UUID -> Mealy eff a b -> a -> m (b, Mealy eff a b)
step nt trace (Mealy _ f) a = do
@@ -74,12 +77,17 @@ defaultMain = withSocketsDo $ do
withBus severity $ \bus -> do
token <- getEnv "HA_TOKEN"
host <- getEnv "HA_HOST"
store <- System.Metrics.newStore
System.Metrics.registerGcMetrics store
rrdPath <- fromMaybe "hass-controller.rrd" <$> lookupEnv "HA_RRD_PATH"
rrdtool <- fromMaybe "rrdtool" <$> lookupEnv "HA_RRDTOOL"
let active = [c | c@(Controller _ _ True) <- controllers]
ents = foldMap (\(Controller _ m _) -> entities m) active
workers =
[ ("reader", readerAction host 8123 token ents bus)
, ("writer", writerAction bus)
] ++ [ (name, runController bus c) | c@(Controller name _ True) <- controllers ]
++ [("metrics", HomeAssistant.Runtime.Metrics.metricsAction store rrdPath rrdtool)]
as <- mapM (\(name, act) -> async (supervised name defaultBackoff act)) workers
(_, v) <- waitAny as
absurd v
src/HomeAssistant/Runtime/Metrics.hs
+109
View File
@@ -0,0 +1,109 @@
{-# LANGUAGE OverloadedStrings #-}
module HomeAssistant.Runtime.Metrics
( DsType (..)
, DsSpec (..)
, dsTypeOf
, sanitizeName
, buildSchema
, buildCreateArgs
, buildUpdateArgs
, ensureRrd
, sampleAndUpdate
, metricsAction
) where
import Control.Concurrent (threadDelay)
import Control.Monad (forever, unless)
import Data.Int (Int64)
import Data.List (intercalate, sortBy)
import Data.Ord (comparing)
import Data.Text (Text)
import Data.Void (Void)
import qualified Data.Text as T
import qualified Data.HashMap.Strict as HM
import qualified System.Metrics as M (Value (..), Sample, Store, sampleAll)
import System.Directory (doesFileExist)
import System.Process (callProcess)
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
lookupValue :: M.Sample -> Text -> Maybe Int64
lookupValue sample name = case HM.lookup name sample of
Just (M.Counter n) -> Just n
Just (M.Gauge n) -> Just n
_ -> Nothing
ensureRrd :: FilePath -> FilePath -> [DsSpec] -> IO ()
ensureRrd rrdtool rrdPath schema = do
exists <- doesFileExist rrdPath
unless exists $
callProcess rrdtool (buildCreateArgs rrdPath 10 (map toPair schema))
where
toPair s = (dsName s, dsType s)
sampleAndUpdate :: M.Store -> FilePath -> FilePath -> [DsSpec] -> IO ()
sampleAndUpdate store rrdtool rrdPath schema = do
sample <- M.sampleAll store
let names = map dsName schema
values = map (lookupValue sample . dsEkgName) schema
callProcess rrdtool (buildUpdateArgs rrdPath names values)
metricsAction :: M.Store -> FilePath -> FilePath -> IO Void
metricsAction store rrdPath rrdtool = do
schema <- buildSchema <$> M.sampleAll store
ensureRrd rrdtool rrdPath schema
forever $ do
sampleAndUpdate store rrdtool rrdPath schema
threadDelay 10000000
test/Main.hs
+2
View File
@@ -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
test/MetricsSpec.hs
+131
View File
@@ -0,0 +1,131 @@
{-# 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
, ensureRrd
, sampleAndUpdate
, metricsAction
)
import qualified System.Metrics as M (Value (..))
import Test.Hspec
import Control.Exception (try, SomeException)
import System.Directory (findExecutable, getTemporaryDirectory, 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" $
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"
]
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 ()