Gate CallService by handler flags on the Bus

src/HomeAssistant/Runtime/Bus.hs

@@ -31,7 +31,9 @@ import System.IO (stdout)
 import System.Metrics.Counter (inc)
 import Data.UUID (toText)
 import AFRP (Request(..), Event(..))
+import Control.Monad (when)
 import Control.Monad.IO.Class (MonadIO, liftIO)
+import HomeAssistant.Runtime.Flags (Flags, isEnabled)
 
 -- | Shared runtime state: inbound is a broadcast channel (controllers
 -- read from 'dupTChan' copies), outbound queues service calls for the
@@ -43,10 +45,11 @@ data Bus = Bus
   , busGen      :: CallIdGen
   , busLogEnv   :: LogEnv
   , busMetrics  :: AppMetrics
+  , busFlags    :: Flags
   }
 
-withBus :: Severity -> AppMetrics -> (Bus -> IO a) -> IO a
-withBus severity metrics callback = do
+withBus :: Severity -> AppMetrics -> Flags -> (Bus -> IO a) -> IO a
+withBus severity metrics flags 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
@@ -58,6 +61,7 @@ withBus severity metrics callback = do
           <*> mkCallIdGen 0
           <*> pure le
           <*> pure metrics
+          <*> pure flags
     callback bus
 
 recordInbound :: Bus -> IO ()
@@ -70,7 +74,8 @@ channelHassEval :: (MonadIO m, KatipContext m) => Bus -> HASSEff a -> m a
 channelHassEval bus = \case
   CallService req svc -> katipAddContext (sl "traceId" (toText (requestTraceId req))) $ do
     logFM DebugS (ls $ show svc)
-    liftIO $ atomically $ writeTChan (busOutbound bus) (req, svc)
+    enabled <- isEnabled (busFlags bus) (requestHandler req)
+    when enabled $ liftIO $ atomically $ writeTChan (busOutbound bus) (req, svc)
   Debug x -> logFM DebugS (ls $ show x)
   Trace req x -> katipAddContext (sl "traceId" (toText (requestTraceId req))) $
     logFM InfoS (ls $ show x)