MasseR/home-assistant-controller
1
0
Fork 0
Code Issues 2 Pull Requests Actions Packages Projects Releases Wiki Activity

Drop build-time controller flag, run all controllers, consolidate paths

Browse Source
This commit is contained in:
MasseR
2026-09-25 13:10:26 +03:00
parent bd1402ab3a
commit 1697d55ad5
1 changed files with 16 additions and 17 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/HomeAssistant/Runtime.hs
+16 -17
View File
@@ -51,27 +51,27 @@ step path name trace st a = do
let req = Request now tz trace name let req = Request now tz trace name
stepAutoSerializing path st req a stepAutoSerializing path st req a
data Controller = forall b. Controller Bool T.Text (HASS (Event Value) b) data Controller = forall b. Controller T.Text (HASS (Event Value) b)
controllers :: [Controller] controllers :: [Controller]
controllers = controllers =
[ Controller True "bedroom-presence" bedroomPresenceController [ Controller "bedroom-presence" bedroomPresenceController
, Controller True "bedroom-button" bedroomButtonController , Controller "bedroom-button" bedroomButtonController
, Controller True "bedroom-drawer" bedroomDrawerController , Controller "bedroom-drawer" bedroomDrawerController
, Controller True "bedroom-humidifier" humidifierController , Controller "bedroom-humidifier" humidifierController
, Controller True "school-light-controller" schoolLightController , Controller "school-light-controller" schoolLightController
, Controller True "kitchen-motion-controller" kitchenMotionController , Controller "kitchen-motion-controller" kitchenMotionController
, Controller True "livingroom-presence" livingroomPresenceController , Controller "livingroom-presence" livingroomPresenceController
, Controller True "hallway-motion-controller" hallwayLightsController , Controller "hallway-motion-controller" hallwayLightsController
, Controller True "children-button" childrenBedroomButtonController , Controller "children-button" childrenBedroomButtonController
, Controller True "livingroom-plants" livingroomPlantLights , Controller "livingroom-plants" livingroomPlantLights
] ]
-- | Steps the machine for every inbound message; service calls go to the -- | Steps the machine for every inbound message; service calls go to the
-- bus. A restart re-dups the inbound channel and starts from the machine's -- bus. A restart re-dups the inbound channel and starts from the machine's
-- initial state; messages broadcast during the restart window are lost. -- initial state; messages broadcast during the restart window are lost.
runController :: MonadIO m => FilePath -> Bus -> Controller -> m Void runController :: MonadIO m => FilePath -> Bus -> Controller -> m Void
runController rootDir bus (Controller _enabled name machine ) = liftIO $ do runController rootDir bus (Controller name machine ) = liftIO $ do
inbound <- atomically (dupTChan (busInbound bus)) inbound <- atomically (dupTChan (busInbound bus))
let ns = Namespace [name] let ns = Namespace [name]
let workerDefinition = runMealy machine (runKatipContextT (busLogEnv bus) () ns . channelHassEval bus) let workerDefinition = runMealy machine (runKatipContextT (busLogEnv bus) () ns . channelHassEval bus)
@@ -104,23 +104,22 @@ defaultMain = withSocketsDo $ do
appMetrics <- HomeAssistant.Runtime.Metrics.registerAppMetrics store appMetrics <- HomeAssistant.Runtime.Metrics.registerAppMetrics store
rateLimitMetrics <- registerRateLimitMetrics store rateLimitMetrics <- registerRateLimitMetrics store
rootPath <- fromMaybe "/tmp/" <$> lookupEnv "HA_LIB_DIR" rootPath <- fromMaybe "/tmp/" <$> lookupEnv "HA_LIB_DIR"
let allNames = [n | Controller _ n _ <- controllers] let allNames = map (\(Controller n _) -> n) controllers
flags <- loadFlags rootPath allNames flags <- loadFlags rootPath allNames
withBus severity appMetrics flags $ \bus -> do withBus severity appMetrics flags $ \bus -> do
token <- getEnv "HA_TOKEN" token <- getEnv "HA_TOKEN"
host <- getEnv "HA_HOST" host <- getEnv "HA_HOST"
rrdPath <- fromMaybe "hass-controller.rrd" <$> lookupEnv "HA_RRD_PATH" let rrdPath = rootPath </> "hass-controller.rrd"
rrdtool <- fromMaybe "rrdtool" <$> lookupEnv "HA_RRDTOOL" rrdtool <- fromMaybe "rrdtool" <$> lookupEnv "HA_RRDTOOL"
metricsPort <- lookupPort metricsPort <- lookupPort
writerLimiter <- slidingWindowLimiter rateLimitMetrics 10 20 writerLimiter <- slidingWindowLimiter rateLimitMetrics 10 20
let active = [c | c@(Controller True _ _) <- controllers] let ents = foldMap (\(Controller _ m) -> entities m) controllers
ents = foldMap (\(Controller _ _ m) -> entities m) active
workers = workers =
[ ("reader", readerAction host 8123 token ents bus) [ ("reader", readerAction host 8123 token ents bus)
, ("writer", writerAction writerLimiter bus) , ("writer", writerAction writerLimiter bus)
, ("metrics", HomeAssistant.Runtime.Metrics.metricsAction store rrdPath rrdtool) , ("metrics", HomeAssistant.Runtime.Metrics.metricsAction store rrdPath rrdtool)
, ("metrics-http", HttpServer.runHttpServer (busLogEnv bus) rrdPath rrdtool (busFlags bus) metricsPort) , ("metrics-http", HttpServer.runHttpServer (busLogEnv bus) rrdPath rrdtool (busFlags bus) metricsPort)
] ++ [ (name, runController rootPath bus c) | c@(Controller True name _) <- active ] ] ++ [ (name, runController rootPath bus c) | c@(Controller name _) <- controllers ]
runKatipContextT (busLogEnv bus) () mempty $ runKatipContextT (busLogEnv bus) () mempty $
mapConcurrently_ (uncurry supervised) workers mapConcurrently_ (uncurry supervised) workers