Quick buttons

src/HomeAssistant/Runtime.hs

@@ -29,7 +29,7 @@ import Data.UUID (UUID, toText)
 import qualified Data.UUID.V4 as UUID.V4
 import Katip (runKatipT, logF, sl, Severity (..), ls, Namespace (Namespace), runKatipContextT)
 import Control.Monad.IO.Class (liftIO, MonadIO)
-import HomeAssistant.Controller.Children (schoolLightController)
+import HomeAssistant.Controller.Children (schoolLightController, childrenBedroomButtonController)
 import Data.Maybe (fromMaybe)
 import qualified System.Metrics
 import qualified HomeAssistant.Runtime.Metrics
@@ -50,25 +50,26 @@ step path trace st a = do
   let req = Request now tz trace
   stepAutoSerializing path st req a
 
-data Controller = forall b. Controller T.Text (HASS (Event Value) b) Bool
+data Controller = forall b. Controller Bool T.Text (HASS (Event Value) b)
 
 controllers :: [Controller]
 controllers =
-  [ Controller "bedroom-presence" bedroomPresenceController True
-  , Controller "bedroom-button" bedroomButtonController True
-  , Controller "bedroom-drawer" bedroomDrawerController True
-  , Controller "bedroom-humidifier" humidifierController True
-  , Controller "school-light-controller" schoolLightController True
-  , Controller "kitchen-motion-controller" kitchenMotionController True
-  , Controller "livingroom-presence" livingroomPresenceController True
-  , Controller "hallway-motion-controller" hallwayLightsController True
+  [ 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
   ]
 
 -- | 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 name machine _enabled) = liftIO $ do
+runController rootDir bus (Controller _enabled name machine ) = liftIO $ do
   inbound <- atomically (dupTChan (busInbound bus))
   let ns = Namespace [name]
   let workerDefinition = runMealy machine (runKatipContextT (busLogEnv bus) () ns . channelHassEval bus)
@@ -108,14 +109,14 @@ defaultMain = withSocketsDo $ do
     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 active = [c | c@(Controller True _ _) <- controllers]
+        ents = foldMap (\(Controller _ _ m) -> entities m) active
         workers =
           [ ("reader", readerAction host 8123 token ents bus)
           , ("writer", writerAction writerLimiter bus)
           , ("metrics", HomeAssistant.Runtime.Metrics.metricsAction store rrdPath rrdtool)
           , ("metrics-http", HomeAssistant.Runtime.Graphing.graphAction rrdPath rrdtool metricsPort)
-          ] ++ [ (name, runController rootPath bus c) | c@(Controller name _ True) <- controllers ]
+          ] ++ [ (name, runController rootPath bus c) | c@(Controller True name _) <- active ]
     runKatipContextT (busLogEnv bus) () mempty $
       mapConcurrently_ (uncurry supervised) workers