From cd29899fe4cae895b9225dee718f1e4138a9cb64 Mon Sep 17 00:00:00 2001 From: Mats Rauhala Date: Fri, 21 Aug 2026 09:12:10 +0300 Subject: [PATCH] Tracing --- default.nix | 4 ++-- home-assistant-controller.cabal | 1 + src/AFRP.hs | 22 +++++++++++++++------- src/HomeAssistant/Controller.hs | 9 ++++++++- src/HomeAssistant/Controller/Bedroom.hs | 12 +++++++----- src/HomeAssistant/Runtime.hs | 14 +++++++++----- src/HomeAssistant/Runtime/Bus.hs | 1 + 7 files changed, 43 insertions(+), 20 deletions(-) diff --git a/default.nix b/default.nix index e59bf0a..33ee412 100644 --- a/default.nix +++ b/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 = [ diff --git a/home-assistant-controller.cabal b/home-assistant-controller.cabal index 99db0d2..a79a616 100644 --- a/home-assistant-controller.cabal +++ b/home-assistant-controller.cabal @@ -86,6 +86,7 @@ library , stm , async , annotated-exception + , uuid -- Directories containing source files. hs-source-dirs: src diff --git a/src/AFRP.hs b/src/AFRP.hs index bf1a82b..2d8fc60 100644 --- a/src/AFRP.hs +++ b/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 -preMapAccumUTCTime f x extract = go x +preMapAccumRequest :: (Request -> x -> a -> x) -> x -> (x -> b) -> Mealy eff a b +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 -mapAccumUTCTime f x extract = go x +mapAccumRequest :: (Request -> x -> a -> x) -> x -> (x -> b) -> Mealy eff a b +mapAccumRequest f x extract = go x where go b = Mealy $ \_ t a -> let next = f t b a diff --git a/src/HomeAssistant/Controller.hs b/src/HomeAssistant/Controller.hs index 7daf4f4..2b9cc9b 100644 --- a/src/HomeAssistant/Controller.hs +++ b/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 diff --git a/src/HomeAssistant/Controller/Bedroom.hs b/src/HomeAssistant/Controller/Bedroom.hs index f9bbb03..d2b0bb7 100644 --- a/src/HomeAssistant/Controller/Bedroom.hs +++ b/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" diff --git a/src/HomeAssistant/Runtime.hs b/src/HomeAssistant/Runtime.hs index 7dbbe59..d9c2cc6 100644 --- a/src/HomeAssistant/Runtime.hs +++ b/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) diff --git a/src/HomeAssistant/Runtime/Bus.hs b/src/HomeAssistant/Runtime/Bus.hs index 16ff07b..0b987f5 100644 --- a/src/HomeAssistant/Runtime/Bus.hs +++ b/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 }