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/flake.nix b/flake.nix index 78aa659..ad0b587 100644 --- a/flake.nix +++ b/flake.nix @@ -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 ]; }; } diff --git a/home-assistant-controller.cabal b/home-assistant-controller.cabal index 8b1c837..d96fdc1 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 @@ -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 diff --git a/src/HomeAssistant/Runtime.hs b/src/HomeAssistant/Runtime.hs index 6895c4c..55a77bc 100644 --- a/src/HomeAssistant/Runtime.hs +++ b/src/HomeAssistant/Runtime.hs @@ -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 diff --git a/src/HomeAssistant/Runtime/Metrics.hs b/src/HomeAssistant/Runtime/Metrics.hs new file mode 100644 index 0000000..c5d411e --- /dev/null +++ b/src/HomeAssistant/Runtime/Metrics.hs @@ -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 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..91cb934 --- /dev/null +++ b/test/MetricsSpec.hs @@ -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 ()