Tracing

src/HomeAssistant/Controller.hs

@@ -25,10 +25,11 @@ module HomeAssistant.Controller
   , Presence(..)
   , presence
   , debug
+  , traceEvent
   , switch
   ) where
 
-import AFRP (Mealy, eff, Event(..), hold, events, changes, filterA, (>>|), toEvent)
+import AFRP (Mealy (..), eff, Event(..), hold, events, changes, filterA, (>>|), toEvent, Request)
 import Control.Arrow (Arrow(..), returnA)
 import Control.Category ((>>>))
 import Data.Aeson (Value)
@@ -49,6 +50,7 @@ data Service = Service
 data HASSEff a where
   CallService :: Service -> HASSEff ()
   Debug :: Show a => a -> HASSEff ()
+  Trace :: Show a => Request -> a -> HASSEff ()
 
 type HASS a b = Mealy HASSEff a b
 
@@ -60,6 +62,11 @@ debug = proc x -> do
   eff Debug -< x
   returnA -< x
 
+traceEvent :: Show a => HASS (Event a) (Event a)
+traceEvent = Mealy $ \nt req -> \case
+  Event a -> nt (Trace req a) >>= \() -> pure (Event a, traceEvent)
+  Tick -> pure (Tick, traceEvent)
+
 ruuviTemperatures :: Mealy eff (Event Value) Double
 ruuviTemperatures = entityRead @Double "sensor.ruuvitag_b168_temperature" >>> hold 0
 

src/HomeAssistant/Controller/Bedroom.hs

@@ -56,6 +56,7 @@ data IkeaQuickButton
   | ShortClickOff
   | DoubleClickOff
   | LongClickOff
+  deriving Show
 
 
 toIkeaQuickButton :: T.Text -> Maybe IkeaQuickButton
@@ -74,25 +75,26 @@ ikeaQuickButton entityId =
   >>| arr (maybe (Left ()) Right . eventType)
   >>> toEvent
   where
-    eventType v = v ^? key "event" . key "data" . key "new_state" . key "state" . _String . to toIkeaQuickButton . traversed
+    eventType v = v ^? key "event" . key "data" . key "new_state" . key "attributes" . key "event_type" . _String . to toIkeaQuickButton . traversed
 
 
 data BedroomControls
   = Masse IkeaQuickButton
   | Enishen IkeaQuickButton
+  deriving Show
 
 
 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"
+    enishenButton = fmap Enishen <$> ikeaQuickButton "event.bedroom_quick_jemina_action"
 
 bedroomButtonController :: HASS (Event Value) ()
 bedroomButtonController = proc x -> do
-  ev <- bedroomButton -< x
+  ev <- bedroomButton >>> traceEvent -< x
   case ev of
-       Event (Masse ShortClickOn) -> callService (activateScene "scene.makuuhuone_masse") -< ()
+       Event (Masse ShortClickOn) -> callService (activateScene "scene.makuuhuone_masse") -< () -- this should be on release
        Event (Masse DoubleClickOn) -> callService (activateScene "scene.makuuhuone_keski") -< ()
        Event (Masse LongClickOn) -> callService (activateScene "scene.makuuhuone_kirkas") -< ()
        Event (Enishen ShortClickOn) -> callService (activateScene "scene.makuuhuone_jemina") -< ()
@@ -114,4 +116,4 @@ bedroomDrawerController = proc x -> do
        Event Closed -> callService (switch [entity] False) -< ()
        _ -> returnA -< ()
   where
-    entity = "switch.bedroom_drawer_light_masse"
+    entity = "bedroom_drawer_light_masse"

src/HomeAssistant/Runtime.hs

@@ -13,7 +13,7 @@ module HomeAssistant.Runtime
   , runController
   ) where
 
-import AFRP (Event (..), Mealy (..))
+import AFRP (Event (..), Mealy (..), Request (..))
 import Control.Concurrent.Async (async, waitAny)
 import Control.Concurrent.STM (atomically, dupTChan, readTChan)
 import Data.Aeson (Value)
@@ -27,11 +27,13 @@ import HomeAssistant.Runtime.Supervisor (defaultBackoff, supervised)
 import Network.Socket (withSocketsDo)
 import System.Environment (getEnv)
 import HomeAssistant.Controller.Bedroom (bedroomPresenceController, bedroomButtonController, bedroomDrawerController)
+import Data.UUID (UUID)
+import qualified Data.UUID.V4 as UUID.V4
 
-step :: (forall x. eff x -> IO x) -> Mealy eff a b -> a -> IO (b, Mealy eff a b)
-step nt (Mealy f) a = do
+step :: (forall x. eff x -> IO x) -> UUID -> Mealy eff a b -> a -> IO (b, Mealy eff a b)
+step nt trace (Mealy f) a = do
   now <- getCurrentTime
-  f nt now a
+  f nt (Request now trace) a
 
 data Controller = forall b. Controller T.Text (HASS (Event Value) b)
 
@@ -52,8 +54,9 @@ runController bus (Controller _name machine) = do
   where
     go inbound f = do
       msg <- atomically (readTChan inbound)
+      uuid <- UUID.V4.nextRandom
       -- (_, f') <- step (channelHassEval bus) f (Event msg)
-      (_, f') <- step (dryRunHassEval (busGen bus)) f (Event msg)
+      (_, f') <- step (dryRunHassEval (busGen bus)) uuid f (Event msg)
       go inbound f'
 
 defaultMain :: IO ()
@@ -74,3 +77,4 @@ dryRunHassEval gen = \case
     callId <- generateCallId gen
     print (callId, x)
   Debug x -> print x
+  Trace req x -> print (req, x)

src/HomeAssistant/Runtime/Bus.hs

@@ -43,6 +43,7 @@ channelHassEval :: Bus -> HASSEff a -> IO a
 channelHassEval bus = \case
   CallService svc -> atomically $ writeTChan (busOutbound bus) svc
   Debug x -> print x
+  Trace req x -> print (req, x)
 
 newtype CallIdGen = CallIdGen { generateCallId :: IO Int }