runtime: increment trigger/service counters on the bus

src/HomeAssistant/Runtime/Bus.hs

@@ -6,6 +6,8 @@ module HomeAssistant.Runtime.Bus
   , CallIdGen(..)
   , mkCallIdGen
   , withBus
+  , recordInbound
+  , recordOutbound
   , channelHassEval
   ) where
 
@@ -21,10 +23,12 @@ import Control.Concurrent.STM
 import Data.Aeson (Value)
 import Data.IORef (atomicModifyIORef', newIORef)
 import HomeAssistant.Controller (HASSEff (..), Service)
+import HomeAssistant.Runtime.Metrics (AppMetrics (..))
 import Network.WebSockets (Connection)
 import Katip (LogEnv, closeScribes, mkHandleScribe, ColorStrategy (..), permitItem, Severity (..), Verbosity (V2), registerScribe, defaultScribeSettings, initLogEnv, ls, sl, logFM, katipAddContext, KatipContext)
 import Control.Exception (bracket)
 import System.IO (stdout)
+import System.Metrics.Counter (inc)
 import Data.UUID (toText)
 import AFRP (Request(..), Event(..))
 import Control.Monad.IO.Class (MonadIO, liftIO)
@@ -38,10 +42,11 @@ data Bus = Bus
   , busConn     :: TVar (Maybe Connection)
   , busGen      :: CallIdGen
   , busLogEnv   :: LogEnv
+  , busMetrics  :: AppMetrics
   }
 
-withBus :: Severity -> (Bus -> IO a) -> IO a
-withBus severity callback = do
+withBus :: Severity -> AppMetrics -> (Bus -> IO a) -> IO a
+withBus severity metrics callback = do
   handleScribe <- mkHandleScribe ColorIfTerminal stdout (permitItem severity) V2
   let makeLogEnv = registerScribe "stdout" handleScribe defaultScribeSettings =<< initLogEnv "hass-controller" "production"
   -- closeScribes will stop accepting new logs, flush existing ones and clean up resources
@@ -52,8 +57,15 @@ withBus severity callback = do
           <*> newTVarIO Nothing
           <*> mkCallIdGen 0
           <*> pure le
+          <*> pure metrics
     callback bus
 
+recordInbound :: Bus -> IO ()
+recordInbound bus = inc (amTriggersIn (busMetrics bus))
+
+recordOutbound :: Bus -> IO ()
+recordOutbound bus = inc (amServicesOut (busMetrics bus))
+
 channelHassEval :: (MonadIO m, KatipContext m) => Bus -> HASSEff a -> m a
 channelHassEval bus = \case
   CallService req svc -> katipAddContext (sl "traceId" (toText (requestTraceId req))) $ do