Tracing

default.nix

@@ -1,6 +1,6 @@
 { mkDerivation, aeson, annotated-exception, async, base, bytestring
 , hedgehog, hspec, hspec-hedgehog, lens, lens-aeson, lib, network
-, stm, text, time, websockets
+, stm, text, time, uuid, websockets
 }:
 mkDerivation {
   pname = "home-assistant-controller";
@@ -10,7 +10,7 @@ mkDerivation {
   isExecutable = true;
   libraryHaskellDepends = [
     aeson annotated-exception async base bytestring lens lens-aeson
-    network stm text time websockets
+    network stm text time uuid websockets
   ];
   executableHaskellDepends = [ base ];
   testHaskellDepends = [

home-assistant-controller.cabal

@@ -86,6 +86,7 @@ library
                     , stm
                     , async
                     , annotated-exception
+                    , uuid
 
     -- Directories containing source files.
     hs-source-dirs:   src

src/AFRP.hs

@@ -8,9 +8,9 @@ module AFRP
   , events
   , switch
   , preMapAccum
-  , preMapAccumUTCTime
+  , preMapAccumRequest
   , mapAccum
-  , mapAccumUTCTime
+  , mapAccumRequest
   , changes
   , whenA
   , filterA
@@ -18,6 +18,7 @@ module AFRP
   , (>>|)
   , toEvent
   , lMerge
+  , Request(..)
   ) where
 
 import Control.Category (Category(..), (>>>))
@@ -27,9 +28,16 @@ import Data.Time (UTCTime)
 import Control.Monad.Fix (MonadFix (mfix))
 import Data.Either (fromLeft)
 import Data.Bool (bool)
+import Data.UUID (UUID)
+
+data Request = Request
+  { requestTime :: !UTCTime
+  , requestTraceId :: !UUID
+  }
+  deriving Show
 
 newtype Mealy eff a b = Mealy
-  { runMealy :: forall m. MonadFix m => (forall x. eff x -> m x) -> UTCTime -> a -> m (b, Mealy eff a b) }
+  { runMealy :: forall m. MonadFix m => (forall x. eff x -> m x) -> Request -> a -> m (b, Mealy eff a b) }
 
 eff :: (a -> eff b) -> Mealy eff a b
 eff f = Mealy $ \nt _ x ->
@@ -101,8 +109,8 @@ preMapAccum f x extract = go x
       let next = f b a
       in pure (extract b, go next)
 
-preMapAccumUTCTime :: (UTCTime -> x -> a -> x) -> x -> (x -> b) -> Mealy eff a b
+preMapAccumRequest :: (Request -> x -> a -> x) -> x -> (x -> b) -> Mealy eff a b
-preMapAccumUTCTime f x extract = go x
+preMapAccumRequest f x extract = go x
   where
     go b = Mealy $ \_ t a ->
       let next = f t b a
@@ -115,8 +123,8 @@ mapAccum f x extract = go x
       let next = f b a
       in pure (extract next, go next)
 
-mapAccumUTCTime :: (UTCTime -> x -> a -> x) -> x -> (x -> b) -> Mealy eff a b
+mapAccumRequest :: (Request -> x -> a -> x) -> x -> (x -> b) -> Mealy eff a b
-mapAccumUTCTime f x extract = go x
+mapAccumRequest f x extract = go x
   where
     go b = Mealy $ \_ t a ->
       let next = f t b a

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 :: (forall x. eff x -> IO x) -> UUID -> Mealy eff a b -> a -> IO (b, Mealy eff a b)
-step nt (Mealy f) a = do
+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 }