From 7d08acec9d9e222f4d512fcb3852edef9fa62e15 Mon Sep 17 00:00:00 2001 From: Mats Rauhala Date: Tue, 15 Sep 2026 17:25:31 +0300 Subject: [PATCH] runtime: count only trigger event frames and harden metrics tests --- src/HomeAssistant/Runtime/Connection.hs | 8 +++-- test/ConnectionSpec.hs | 10 ++++++- test/MetricsSpec.hs | 39 +++++++++++++------------ test/RuntimeSpec.hs | 2 +- 4 files changed, 36 insertions(+), 23 deletions(-) diff --git a/src/HomeAssistant/Runtime/Connection.hs b/src/HomeAssistant/Runtime/Connection.hs index 6ed8e78..d77a1cd 100644 --- a/src/HomeAssistant/Runtime/Connection.hs +++ b/src/HomeAssistant/Runtime/Connection.hs @@ -6,6 +6,7 @@ module HomeAssistant.Runtime.Connection , writerAction , encodeService , dedupeBatch + , isTriggerEvent ) where import Control.Concurrent.STM @@ -23,7 +24,7 @@ import Control.Concurrent (threadDelay) import Control.Exception (onException) import Control.Exception.Annotated (throw) import Control.Lens ((^?)) -import Control.Monad (forever, forM_) +import Control.Monad (forever, forM_, when) import Data.Aeson (Value, eitherDecode, encode, object, (.=)) import Data.Aeson.Lens (key, _String) import Data.List (sort) @@ -69,6 +70,9 @@ expectType expected msg = Just t | t == expected -> pure () _ -> throw (Fatal $ "expected " <> expected <> ", got: " <> T.pack (show msg)) +isTriggerEvent :: Value -> Bool +isTriggerEvent v = v ^? key "type" . _String == Just "event" + subscribe :: Bus -> WS.Connection -> S.Set T.Text -> IO () subscribe bus conn ents = forM_ (S.toList ents) $ \entityId -> do @@ -97,7 +101,7 @@ receiveLoop bus conn = forever $ do Right msg -> case eitherDecode msg of Left err -> putStrLn $ "[reader] skipping undecodable message: " <> err Right v -> do - recordInbound bus + when (isTriggerEvent v) (recordInbound bus) atomically $ writeTChan (busInbound bus) (Event v) receiveJSON :: WS.Connection -> IO Value diff --git a/test/ConnectionSpec.hs b/test/ConnectionSpec.hs index 90726ab..b279380 100644 --- a/test/ConnectionSpec.hs +++ b/test/ConnectionSpec.hs @@ -9,7 +9,7 @@ import Data.Text (Text) import Data.Time (UTCTime (..), utc) import Data.UUID (fromString) import HomeAssistant.Controller (Service (..), Target(..)) -import HomeAssistant.Runtime.Connection (encodeService, dedupeBatch) +import HomeAssistant.Runtime.Connection (encodeService, dedupeBatch, isTriggerEvent) import Test.Hspec spec :: Spec @@ -36,6 +36,14 @@ spec = do , "service_data" .= object ["brightness" .= (200 :: Int)] ] + describe "isTriggerEvent" $ do + it "is true for event frames" $ + isTriggerEvent (object ["type" .= ("event" :: Text)]) `shouldBe` True + it "is false for result frames" $ + isTriggerEvent (object ["type" .= ("result" :: Text)]) `shouldBe` False + it "is false when there is no type" $ + isTriggerEvent (object ["id" .= (1 :: Int)]) `shouldBe` False + describe "dedupeBatch" $ do it "collapses identical calls to one" $ let batch = [ (req 1, lightOn [AreaId "x"]) diff --git a/test/MetricsSpec.hs b/test/MetricsSpec.hs index 2159f99..e648be5 100644 --- a/test/MetricsSpec.hs +++ b/test/MetricsSpec.hs @@ -4,7 +4,6 @@ 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 @@ -18,7 +17,6 @@ import HomeAssistant.Runtime.Metrics , buildUpdateArgs , ensureRrd , sampleAndUpdate - , metricsAction , parseInfoDs , schemaMatches , AppMetrics (..) @@ -26,7 +24,7 @@ import HomeAssistant.Runtime.Metrics ) import qualified System.Metrics as M (Value (..)) import Test.Hspec -import Control.Exception (try, SomeException) +import Control.Exception (try, SomeException, finally) import Control.Monad (forM_) import System.Directory (findExecutable, getTemporaryDirectory, listDirectory, removeFile) import System.Exit (ExitCode (ExitSuccess)) @@ -171,9 +169,10 @@ spec = 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 0) + 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 @@ -208,18 +207,20 @@ spec = do 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 () + 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 diff --git a/test/RuntimeSpec.hs b/test/RuntimeSpec.hs index 2f85fdd..53dcdbc 100644 --- a/test/RuntimeSpec.hs +++ b/test/RuntimeSpec.hs @@ -11,7 +11,7 @@ spec = pure () -- -- spec :: Spec -- spec = describe "runController" $ do --- it "feeds inbound events through the machine and forwards service calls" $ withBus InfoS $ \bus -> do +-- it "feeds inbound events through the machine and forwards service calls" $ withBus severity appMetrics $ \bus -> do -- _ <- async (runController bus (Controller "test" lightController True)) -- putStrLn "Before the delay" -- threadDelay 100000 -- let the controller dup its inbound channel