IKEA buttons

src/AFRP.hs

@@ -17,6 +17,7 @@ module AFRP
   , thenA
   , (>>|)
   , toEvent
+  , lMerge
   ) where
 
 import Control.Category (Category(..), (>>>))
@@ -142,7 +143,13 @@ thenA f g = f >>> arr Left ||| g
 (>>|) :: (ArrowChoice cat, Arrow cat) => cat a (Either b1 c) -> cat c (Either b1 b2) -> cat a (Either b1 b2)
 (>>|) = thenA
 
-infixl 1 >>|
+infixl 2 >>|
 
 toEvent :: Mealy eff (Either () a) (Event a)
 toEvent = arr (either (const Tick) Event)
+
+
+lMerge :: Event a -> Event a -> Event a
+lMerge Tick Tick = Tick
+lMerge (Event a) _ = Event a
+lMerge Tick (Event a) = Event a

src/HomeAssistant/Controller.hs

@@ -24,6 +24,7 @@ module HomeAssistant.Controller
   , lightController
   , Presence(..)
   , presence
+  , debug
   ) where
 
 import AFRP (Mealy, eff, Event(..), hold, events, changes, filterA, (>>|), toEvent)
@@ -46,12 +47,18 @@ data Service = Service
 
 data HASSEff a where
   CallService :: Service -> HASSEff ()
+  Debug :: Show a => a -> HASSEff ()
 
 type HASS a b = Mealy HASSEff a b
 
 callService :: Service -> HASS a ()
 callService service = eff (\_ -> CallService service)
 
+debug :: Show a => HASS a a
+debug = proc x -> do
+  eff Debug -< x
+  returnA -< x
+
 ruuviTemperatures :: Mealy eff (Event Value) Double
 ruuviTemperatures = entityRead @Double "sensor.ruuvitag_b168_temperature" >>> hold 0
 

src/HomeAssistant/Controller/Bedroom.hs

@@ -4,9 +4,12 @@ module HomeAssistant.Controller.Bedroom where
 
 import HomeAssistant.Controller
 import qualified Data.Text as T
-import AFRP (Event (..))
+import AFRP (Event (..), (>>|), toEvent, lMerge)
 import Data.Aeson (Value, object, (.=))
-import Control.Arrow ((>>>), returnA)
+import Control.Arrow ((>>>), returnA, arr, ArrowChoice (..), Arrow (..))
+import Control.Lens ((^?), to, traversed)
+import Data.Aeson.Lens (key, _String)
+import qualified Data.Text.Lens as TL
 
 
 
@@ -45,3 +48,54 @@ bedroomPresenceController = proc x -> do
        Event Occupied -> callService (activateScene "makuuhuone_lights_snapshot") -< ()
        _ -> returnA -< ()
 
+-- Ikea quick buttons are identified by different event types
+data IkeaQuickButton
+  = ShortClickOn
+  | DoubleClickOn
+  | LongClickOn
+  | ShortClickOff
+  | DoubleClickOff
+  | LongClickOff
+
+
+toIkeaQuickButton :: T.Text -> Maybe IkeaQuickButton
+toIkeaQuickButton = \case
+  "1_initial_press" -> Just ShortClickOn
+  "1_double_press" -> Just DoubleClickOn
+  "1_long_press" -> Just LongClickOn
+  "2_initial_press" -> Just ShortClickOff
+  "2_double_press" -> Just DoubleClickOff
+  "2_long_press" -> Just LongClickOff
+  _ -> Nothing
+
+ikeaQuickButton :: T.Text -> HASS (Event Value) (Event IkeaQuickButton)
+ikeaQuickButton entityId =
+  entityChangeEvent' entityId
+  >>| arr (maybe (Left ()) Right . eventType)
+  >>> toEvent
+  where
+    eventType v = v ^? key "event" . key "data" . key "new_state" . key "state" . _String . to toIkeaQuickButton . traversed
+
+
+data BedroomControls
+  = Masse IkeaQuickButton
+  | Enishen IkeaQuickButton
+
+
+bedroomButton :: HASS (Event Value) (Event BedroomControls)
+bedroomButton = (masseButton &&& enishenButton) >>> arr (uncurry lMerge)
+  where
+    masseButton = fmap Masse <$> ikeaQuickButton "event.bedroom_quick_remote_masse_action"
+    enishenButton = fmap Enishen <$> ikeaQuickButton "event.bedroom_quick_remote_jemina_action"
+
+bedroomButtonController :: HASS (Event Value) ()
+bedroomButtonController = proc x -> do
+  ev <- bedroomButton -< x
+  case ev of
+       Event (Masse ShortClickOn) -> callService (activateScene "scene.makuuhuone_masse") -< ()
+       Event (Masse DoubleClickOn) -> callService (activateScene "scene.makuuhuone_keski") -< ()
+       Event (Masse LongClickOn) -> callService (activateScene "scene.makuuhuone_kirkas") -< ()
+       Event (Enishen ShortClickOn) -> callService (activateScene "scene.makuuhuone_jemina") -< ()
+       Event (Enishen DoubleClickOn) -> callService (activateScene "scene.makuuhuone_keski") -< ()
+       Event (Enishen LongClickOn) -> callService (activateScene "scene.makuuhuone_kirkas") -< ()
+       _ -> returnA -< ()

src/HomeAssistant/Runtime.hs

@@ -26,7 +26,7 @@ import HomeAssistant.Runtime.Connection (readerAction, writerAction)
 import HomeAssistant.Runtime.Supervisor (defaultBackoff, supervised)
 import Network.Socket (withSocketsDo)
 import System.Environment (getEnv)
-import HomeAssistant.Controller.Bedroom (bedroomPresenceController)
+import HomeAssistant.Controller.Bedroom (bedroomPresenceController, bedroomButtonController)
 
 step :: (forall x. eff x -> IO x) -> Mealy eff a b -> a -> IO (b, Mealy eff a b)
 step nt (Mealy f) a = do
@@ -36,7 +36,10 @@ step nt (Mealy f) a = do
 data Controller = forall b. Controller T.Text (HASS (Event Value) b)
 
 controllers :: [Controller]
-controllers = [Controller "bedroom-presence" bedroomPresenceController]
+controllers =
+  [ Controller "bedroom-presence" bedroomPresenceController
+  , Controller "bedroom-button" bedroomButtonController
+  ]
 
 -- | 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