Quick buttons

src/HomeAssistant/Controller.hs

@@ -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
+  }