diff --git a/src/HomeAssistant/Runtime.hs b/src/HomeAssistant/Runtime.hs index 7e9383f..c8a191c 100644 --- a/src/HomeAssistant/Runtime.hs +++ b/src/HomeAssistant/Runtime.hs @@ -51,27 +51,27 @@ step path name trace st a = do let req = Request now tz trace name 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 True "bedroom-presence" bedroomPresenceController - , Controller True "bedroom-button" bedroomButtonController - , Controller True "bedroom-drawer" bedroomDrawerController - , Controller True "bedroom-humidifier" humidifierController - , Controller True "school-light-controller" schoolLightController - , Controller True "kitchen-motion-controller" kitchenMotionController - , Controller True "livingroom-presence" livingroomPresenceController - , Controller True "hallway-motion-controller" hallwayLightsController - , Controller True "children-button" childrenBedroomButtonController - , Controller True "livingroom-plants" livingroomPlantLights + [ Controller "bedroom-presence" bedroomPresenceController + , Controller "bedroom-button" bedroomButtonController + , Controller "bedroom-drawer" bedroomDrawerController + , Controller "bedroom-humidifier" humidifierController + , Controller "school-light-controller" schoolLightController + , Controller "kitchen-motion-controller" kitchenMotionController + , Controller "livingroom-presence" livingroomPresenceController + , Controller "hallway-motion-controller" hallwayLightsController + , Controller "children-button" childrenBedroomButtonController + , Controller "livingroom-plants" livingroomPlantLights ] -- | 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 -- initial state; messages broadcast during the restart window are lost. 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)) let ns = Namespace [name] let workerDefinition = runMealy machine (runKatipContextT (busLogEnv bus) () ns . channelHassEval bus) @@ -104,23 +104,22 @@ defaultMain = withSocketsDo $ do appMetrics <- HomeAssistant.Runtime.Metrics.registerAppMetrics store rateLimitMetrics <- registerRateLimitMetrics store rootPath <- fromMaybe "/tmp/" <$> lookupEnv "HA_LIB_DIR" - let allNames = [n | Controller _ n _ <- controllers] + let allNames = map (\(Controller n _) -> n) controllers flags <- loadFlags rootPath allNames withBus severity appMetrics flags $ \bus -> do token <- getEnv "HA_TOKEN" 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" metricsPort <- lookupPort writerLimiter <- slidingWindowLimiter rateLimitMetrics 10 20 - let active = [c | c@(Controller True _ _) <- controllers] - ents = foldMap (\(Controller _ _ m) -> entities m) active + let ents = foldMap (\(Controller _ m) -> entities m) controllers workers = [ ("reader", readerAction host 8123 token ents bus) , ("writer", writerAction writerLimiter bus) , ("metrics", HomeAssistant.Runtime.Metrics.metricsAction store rrdPath rrdtool) , ("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 $ mapConcurrently_ (uncurry supervised) workers