Quick buttons

2026-09-17 11:48:22 +03:00
parent 036473ab81
commit e3bc25ce54
4 changed files with 79 additions and 58 deletions
@@ -28,6 +28,10 @@ module HomeAssistant.Controller
  , Target(..)
  , brightness
  , Light(..)
+  , ikeaQuickButton
+  , IkeaButton(..)
+  , IkeaGesture(..)
+  , activateScene
  ) where

 import AFRP (Mealy (..), eff, Event(..), events, filterA, (>>|), toEvent, Request, hold, lMerge, waitFor, tag, edge)
@@ -36,7 +40,7 @@ import Control.Category ((>>>))
 import Data.Aeson (Value, object, (.=))
 import qualified Data.Text as T
 import qualified Data.Set as S
-import Control.Lens (has, only, (^?), to)
+import Control.Lens (has, only, (^?), to, traversed)
 import Data.Aeson.Lens (key, _String, _Integral)
 import qualified Data.Text.Lens as TL
 import Data.Bool (bool)
@@ -191,3 +195,43 @@ brightness entityId =
  >>> AFRP.toEvent
  where
    eventBrightness v = v ^? key "event" . key "variables" . key "trigger" . key "to_state" . key "attributes" . key "brightness" . _Integral
+
+data IkeaGesture
+  = ShortClick
+  | ShortRelease
+  | DoubleClick
+  | LongClick
+  deriving Show
+
+data IkeaButton a = OnButton !a | OffButton !a
+  deriving Show
+
+
+toIkeaQuickButton :: T.Text -> Maybe (IkeaButton IkeaGesture)
+toIkeaQuickButton = \case
+  -- 1 is on, 2 is off side of the button
+  "1_initial_press" -> Just $ OnButton ShortClick
+  "1_short_release" -> Just $ OnButton ShortRelease
+  "1_double_press" -> Just $ OnButton DoubleClick
+  "1_long_press" -> Just $ OnButton LongClick
+  "2_initial_press" -> Just $ OffButton ShortClick
+  "2_short_release" -> Just $ OffButton ShortRelease
+  "2_double_press" -> Just $ OffButton DoubleClick
+  "2_long_press" -> Just $ OffButton LongClick
+  _ -> Nothing
+
+ikeaQuickButton :: T.Text -> HASS (Event Value) (Event (IkeaButton IkeaGesture))
+ikeaQuickButton entityId =
+  entityChangeEvent' entityId
+  >>| arr (maybe (Left ()) Right . eventType)
+  >>> toEvent
+  where
+    eventType v = v ^? key "event" . key "variables" . key "trigger" . key "to_state" . key "attributes" . key "event_type" . _String . to toIkeaQuickButton . traversed
+
+activateScene :: T.Text -> Service
+activateScene sceneId = Service
+  { serviceDomain="scene"
+  , serviceName= "turn_on"
+  , serviceTarget= [EntityId sceneId]
+  , serviceData = Nothing
+  }
@@ -4,11 +4,9 @@ module HomeAssistant.Controller.Bedroom where

 import HomeAssistant.Controller
 import qualified Data.Text as T
-import AFRP (Event (..), (>>|), toEvent, lMerge, duration, edge)
+import AFRP (Event (..), lMerge, duration, edge)
 import Data.Aeson (Value, object, (.=))
 import Control.Arrow ((>>>), returnA, arr, Arrow (..))
-import Control.Lens ((^?), to, traversed)
-import Data.Aeson.Lens (key, _String)
 import Data.Bool (bool)
 import Data.Time (NominalDiffTime)
 import qualified AFRP
@@ -30,13 +28,6 @@ createBedroomScene = Service
  }


-activateScene :: T.Text -> Service
-activateScene sceneId = Service
-  { serviceDomain="scene"
-  , serviceName= "turn_on"
-  , serviceTarget= [EntityId sceneId]
-  , serviceData = Nothing
-  }

 -- Bedroom presence
 bedroomPresence :: HASS (Event Value) (Event Presence)
@@ -50,36 +41,6 @@ bedroomPresenceController = proc x -> do
       Event Occupied -> callService (activateScene "scene.makuuhuone_lights_snapshot") -< ()
       _ -> returnA -< ()

-data IkeaGesture
-  = ShortClick
-  | ShortRelease
-  | DoubleClick
-  | LongClick
-  deriving Show
-data IkeaButton a = OnButton !a | OffButton !a
-  deriving Show
-
-
-toIkeaQuickButton :: T.Text -> Maybe (IkeaButton IkeaGesture)
-toIkeaQuickButton = \case
-  -- 1 is on, 2 is off side of the button
-  "1_initial_press" -> Just $ OnButton ShortClick
-  "1_short_release" -> Just $ OnButton ShortRelease
-  "1_double_press" -> Just $ OnButton DoubleClick
-  "1_long_press" -> Just $ OnButton LongClick
-  "2_initial_press" -> Just $ OffButton ShortClick
-  "2_short_release" -> Just $ OffButton ShortRelease
-  "2_double_press" -> Just $ OffButton DoubleClick
-  "2_long_press" -> Just $ OffButton LongClick
-  _ -> Nothing
-
-ikeaQuickButton :: T.Text -> HASS (Event Value) (Event (IkeaButton IkeaGesture))
-ikeaQuickButton entityId =
-  entityChangeEvent' entityId
-  >>| arr (maybe (Left ()) Right . eventType)
-  >>> toEvent
-  where
-    eventType v = v ^? key "event" . key "variables" . key "trigger" . key "to_state" . key "attributes" . key "event_type" . _String . to toIkeaQuickButton . traversed


 data BedroomControls
@@ -1,13 +1,14 @@
 {-# LANGUAGE Arrows #-}
 {-# LANGUAGE OverloadedStrings #-}
 module HomeAssistant.Controller.Children where
-import HomeAssistant.Controller (HASS, callService, Target (AreaId), light, Light(..))
-import AFRP (Event)
+import HomeAssistant.Controller (HASS, callService, Target (AreaId), light, Light(..), ikeaQuickButton, IkeaGesture (..), IkeaButton (..), traceEvent, activateScene)
+import AFRP (Event (..))
 import qualified AFRP
-import Control.Arrow (Arrow(..), (>>>))
+import Control.Arrow (Arrow(..), (>>>), returnA)
 import Data.Time (Day, TimeOfDay (..), localDay, LocalTime (..))
 import Data.Time.Calendar.OrdinalDate (WeekOfYear, mondayStartWeek)
 import Data.Functor.Contravariant (Predicate (..), (>$<))
+import Data.Aeson (Value)

 -- Let's see building some reasonable interface for utctime
 dow :: Day -> (WeekOfYear, Int)
@@ -80,3 +81,17 @@ lightsOn = foldMap atTime timersOn
 lightsOff :: HASS a ()
 lightsOff = foldMap atTime timersOff
  >>> AFRP.onEvent (callService (light [AreaId "lasten_makuuhuone"] Off))
+
+
+bedroomButton :: HASS   (Event Value) (Event (IkeaButton IkeaGesture))
+bedroomButton = ikeaQuickButton "event.children_quick_remote_action"
+
+childrenBedroomButtonController :: HASS (Event Value) ()
+childrenBedroomButtonController = proc x -> do
+  ev <- bedroomButton >>> traceEvent -< x
+  case ev of
+       Event (OnButton ShortRelease) -> callService (activateScene "scene.lasten_nukkuvalmistelu") -< ()
+       Event (OnButton DoubleClick) -> callService (activateScene "scene.lasten_luku") -< ()
+       Event (OnButton LongClick) -> callService (activateScene "scene.lasten_kirkas") -< ()
+       Event (OffButton _) -> callService (light [AreaId "lasten_makuuhuone"] Off) -< ()
+       _ -> returnA -< ()
@@ -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