runtime: count only trigger event frames and harden metrics tests

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

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"])

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 ())
+              clean = do
-          ensureRrd rrdtool rrdPath base
+                stale <- filter (isPrefixOf bakPrefix) <$> listDirectory tmp
-          ensureRrd rrdtool rrdPath base
+                forM_ (rrdPath : map (\f -> tmp ++ "/" ++ f) stale) $ \f ->
-          noBackups <- filter (isPrefixOf bakPrefix) <$> listDirectory tmp
+                  try (removeFile f) :: IO (Either SomeException ())
-          noBackups `shouldBe` []
+          clean
-          ensureRrd rrdtool rrdPath expanded
+          ( do
-          backups <- filter (isPrefixOf bakPrefix) <$> listDirectory tmp
+              ensureRrd rrdtool rrdPath base
-          length backups `shouldBe` 1
+              ensureRrd rrdtool rrdPath base
-          (rc, out, _) <- readProcessWithExitCode rrdtool ["info", rrdPath] ""
+              noBackups <- filter (isPrefixOf bakPrefix) <$> listDirectory tmp
-          rc `shouldBe` ExitSuccess
+              noBackups `shouldBe` []
-          out `shouldContain` "ds[c].type"
+              ensureRrd rrdtool rrdPath expanded
-          _ <- try (removeFile rrdPath) :: IO (Either SomeException ())
+              backups <- filter (isPrefixOf bakPrefix) <$> listDirectory tmp
-          forM_ backups $ \f -> do
+              length backups `shouldBe` 1
-            _ <- try (removeFile (tmp ++ "/" ++ f)) :: IO (Either SomeException ())
+              (rc, out, _) <- readProcessWithExitCode rrdtool ["info", rrdPath] ""
-            pure ()
+              rc `shouldBe` ExitSuccess
+              out `shouldContain` "ds[c].type"
+            ) `finally` clean

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