MasseR/home-assistant-controller
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Tracing

Browse Source
This commit is contained in:
MasseR
2026-08-21 09:12:10 +03:00
parent 5f0aad4e85
commit cd29899fe4
7 changed files with 43 additions and 20 deletions
Download Patch File Download Diff File Expand all files Collapse all files
default.nix
+2 -2
View File
@@ -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
+1
View File
@@ -86,6 +86,7 @@ library
, stm
, async
, annotated-exception
, uuid
-- Directories containing source files.
hs-source-dirs: src
src/AFRP.hs
+15 -7
View File
@@ -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
src/HomeAssistant/Controller.hs
+8 -1
View File
@@ -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
+7 -5
View File
@@ -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
+9 -5
View File
@@ -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
+1
View File
@@ -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 }