From 27306579526d1a446a3ee61d795a4cb3177ebfe2 Mon Sep 17 00:00:00 2001 From: Mats Rauhala Date: Tue, 25 Aug 2026 13:13:50 +0300 Subject: [PATCH] Triggers instead of full state events --- default.nix | 12 ++--- home-assistant-controller.cabal | 4 +- src/AFRP.hs | 52 +++++++++++---------- src/HomeAssistant/Controller.hs | 11 ++--- src/HomeAssistant/Controller/Bedroom.hs | 2 +- src/HomeAssistant/Runtime.hs | 10 +++-- src/HomeAssistant/Runtime/Connection.hs | 30 ++++++++----- test/AFRPSpec.hs | 60 ++++++++++++++++++++++++- test/BedroomSpec.hs | 33 +++++++++++++- test/RuntimeSpec.hs | 8 ++-- test/Support.hs | 24 ++++++---- 11 files changed, 180 insertions(+), 66 deletions(-) diff --git a/default.nix b/default.nix index f2c7cc6..26df4c0 100644 --- a/default.nix +++ b/default.nix @@ -1,6 +1,6 @@ { mkDerivation, aeson, annotated-exception, async, base, bytestring -, hedgehog, hspec, hspec-hedgehog, katip, lens, lens-aeson, lib -, network, stm, text, time, uuid, websockets +, containers, hedgehog, hspec, hspec-hedgehog, katip, lens +, lens-aeson, lib, network, stm, text, time, uuid, websockets }: mkDerivation { pname = "home-assistant-controller"; @@ -9,13 +9,13 @@ mkDerivation { isLibrary = true; isExecutable = true; libraryHaskellDepends = [ - aeson annotated-exception async base bytestring katip lens - lens-aeson network stm text time uuid websockets + aeson annotated-exception async base bytestring containers katip + lens lens-aeson network stm text time uuid websockets ]; executableHaskellDepends = [ base ]; testHaskellDepends = [ - aeson annotated-exception async base hedgehog hspec hspec-hedgehog - katip stm text time uuid + aeson annotated-exception async base containers hedgehog hspec + hspec-hedgehog katip stm text time uuid ]; license = lib.meta.getLicenseFromSpdxId "BSD-3-Clause"; mainProgram = "home-assistant-controller"; diff --git a/home-assistant-controller.cabal b/home-assistant-controller.cabal index fdb0fb4..8b1c837 100644 --- a/home-assistant-controller.cabal +++ b/home-assistant-controller.cabal @@ -90,6 +90,7 @@ library , annotated-exception , uuid , katip + , containers -- Directories containing source files. hs-source-dirs: src @@ -165,4 +166,5 @@ test-suite home-assistant-controller-test annotated-exception, time, uuid, - katip + katip, + containers diff --git a/src/AFRP.hs b/src/AFRP.hs index 719d057..1374e00 100644 --- a/src/AFRP.hs +++ b/src/AFRP.hs @@ -40,53 +40,59 @@ import Data.Either (fromLeft) import Data.Bool (bool) import Data.Monoid (Endo(..)) import Data.UUID (UUID) +import qualified Data.Set as S +import qualified Data.Text as T data Request = Request { requestTime :: !UTCTime , requestTraceId :: !UUID - } - deriving Show + } deriving Show -newtype Mealy eff a b = Mealy - { runMealy :: forall m. MonadFix m => (forall x. eff x -> m x) -> Request -> a -> m (b, Mealy eff a b) } +-- | The set of entity ids an arrow subscribes to. Static: it does not +-- change as the machine steps, so the runtime can read it once to build +-- trigger subscriptions. +data Mealy eff a b = Mealy + { entities :: S.Set T.Text + , runMealy :: forall m. MonadFix m => (forall x. eff x -> m x) -> Request -> a -> m (b, Mealy eff a b) + } eff :: (Request -> a -> eff b) -> Mealy eff a b -eff f = Mealy $ \nt req x -> +eff f = Mealy mempty $ \nt req x -> nt (f req x) >>= \b -> pure (b, eff f) instance Category (Mealy eff) where - id = Mealy (\_ _ x -> pure (x, id)) - (Mealy f) . (Mealy g) = Mealy $ \nt t a -> do + id = Mealy mempty (\_ _ x -> pure (x, id)) + (Mealy ast f) . (Mealy bst g) = Mealy (ast <> bst) $ \nt t a -> do (b, g') <- g nt t a (c, f') <- f nt t b pure (c, f' . g') instance Arrow (Mealy eff) where - arr f = Mealy $ \_ _ b -> pure (f b, arr f) - first (Mealy f) = Mealy $ \nt t (b,d) -> do + arr f = Mealy mempty $ \_ _ b -> pure (f b, arr f) + first (Mealy st f) = Mealy st $ \nt t (b,d) -> do (c, f') <- f nt t b pure ((c, d), first f') instance ArrowChoice (Mealy eff) where - left (Mealy f) = Mealy $ \nt t -> \case + left m@(Mealy st f) = Mealy st $ \nt t -> \case Left b -> do (c, f') <- f nt t b pure (Left c, left f') - Right d -> pure (Right d, left (Mealy f)) + Right d -> pure (Right d, left m) instance ArrowLoop (Mealy eff) where - loop (Mealy f) = Mealy $ \nt t b -> do + loop (Mealy st f) = Mealy st $ \nt t b -> do ((c,_), f') <- mfix $ \((_,d), _) -> f nt t (b,d) pure (c, loop f') instance Functor (Mealy eff a) where - fmap f (Mealy g) = Mealy $ \nt t a -> do + fmap f (Mealy st g) = Mealy st $ \nt t a -> do (b, g') <- g nt t a pure (f b, fmap f g') instance Applicative (Mealy eff a) where - pure b = Mealy $ \_ _ _ -> pure (b, pure b) - Mealy f <*> Mealy x = Mealy $ \nt t a -> do + pure b = Mealy mempty $ \_ _ _ -> pure (b, pure b) + Mealy ast f <*> Mealy bst x = Mealy (ast <> bst) $ \nt t a -> do (f', fNext) <- f nt t a (x', xNext) <- x nt t a pure (f' x', fNext <*> xNext) @@ -97,7 +103,7 @@ data Event a deriving (Show, Eq, Functor, Foldable, Traversable) hold :: a -> Mealy eff (Event a) a -hold a = Mealy $ \_ _ -> \case +hold a = Mealy mempty $ \_ _ -> \case Tick -> pure (a, hold a) Event a' -> pure (a', hold a') @@ -114,7 +120,7 @@ tag :: b -> Event a -> Event b tag b ev = b <$ ev switch :: Mealy eff a (b, Event c) -> (c -> Mealy eff a b) -> Mealy eff a b -switch (Mealy f) s = Mealy $ \nt t a -> do +switch (Mealy st f) s = Mealy st $ \nt t a -> do ((b, ev), f') <- f nt t a case ev of Tick -> pure (b, switch f' s) @@ -126,28 +132,28 @@ sample = arr (uncurry tag) preMapAccum :: (x -> a -> x) -> x -> (x -> b) -> Mealy eff a b preMapAccum f x extract = go x where - go b = Mealy $ \_ _ a -> + go b = Mealy mempty $ \_ _ a -> let next = f b a in pure (extract b, go next) preMapAccumRequest :: (Request -> x -> a -> x) -> x -> (x -> b) -> Mealy eff a b preMapAccumRequest f x extract = go x where - go b = Mealy $ \_ t a -> + go b = Mealy mempty $ \_ t a -> let next = f t b a in pure (extract b, go next) mapAccum :: (x -> a -> x) -> x -> (x -> b) -> Mealy eff a b mapAccum f x extract = go x where - go b = Mealy $ \_ _ a -> + go b = Mealy mempty $ \_ _ a -> let next = f b a in pure (extract next, go next) mapAccumRequest :: (Request -> x -> a -> x) -> x -> (x -> b) -> Mealy eff a b mapAccumRequest f x extract = go x where - go b = Mealy $ \_ t a -> + go b = Mealy mempty $ \_ t a -> let next = f t b a in pure (extract next, go next) @@ -229,10 +235,10 @@ lMerge Tick (Event a) = Event a edge :: Mealy eff Bool (Event ()) edge = go False where - go True = Mealy $ \_ _ -> \case + go True = Mealy mempty $ \_ _ -> \case True -> pure (Tick, go True) False -> pure (Tick, go False) - go False = Mealy $ \_ _ -> \case + go False = Mealy mempty $ \_ _ -> \case True -> pure (Event (), go True) False -> pure (Tick, go False) diff --git a/src/HomeAssistant/Controller.hs b/src/HomeAssistant/Controller.hs index 10bdf52..a5aef1c 100644 --- a/src/HomeAssistant/Controller.hs +++ b/src/HomeAssistant/Controller.hs @@ -30,6 +30,7 @@ import Control.Arrow (Arrow(..), returnA) import Control.Category ((>>>)) import Data.Aeson (Value) import qualified Data.Text as T +import qualified Data.Set as S import Control.Lens (has, only, (^?), to) import Data.Aeson.Lens (key, _String) import qualified Data.Text.Lens as TL @@ -62,7 +63,7 @@ debug = proc x -> do returnA -< x traceEvent :: Show a => HASS (Event a) (Event a) -traceEvent = Mealy $ \nt req -> \case +traceEvent = Mealy mempty $ \nt req -> \case Event a -> nt (Trace req a) >>= \() -> pure (Event a, traceEvent) Tick -> pure (Tick, traceEvent) @@ -107,20 +108,20 @@ entityChangeEvent :: T.Text -> Mealy eff (Event Value) (Event Value) entityChangeEvent entityId = entityChangeEvent' entityId >>> toEvent entityChangeEvent' :: T.Text -> Mealy eff (Event Value) (Either () Value) -entityChangeEvent' entityId = events >>| filterA isEntity +entityChangeEvent' entityId = Mealy (S.singleton entityId) $ runMealy (events >>| filterA isEntity) where isEntity :: Value -> Bool - isEntity = has (key "event" . key "data" . key "entity_id" . _String . only entityId) + isEntity = has (key "event" . key "variables" . key "trigger" . key "entity_id" . _String . only entityId) entityRead' :: (Read a) => T.Text -> Mealy eff (Event Value) (Either () a) entityRead' entityId = entityChangeEvent' entityId >>| (arr state >>> arr (maybe (Left ()) Right)) where - state v = v ^? key "event" . key "data" . key "new_state" . key "state" . _String . TL.unpacked . to read + state v = v ^? key "event" . key "variables" . key "trigger" . key "to_state" . key "state" . _String . TL.unpacked . to read entityBool' :: T.Text -> Mealy eff (Event Value) (Either () Bool) entityBool' entityId = entityChangeEvent' entityId >>| (arr state >>> arr (maybe (Left ()) Right)) where - state v = v ^? key "event" . key "data" . key "new_state" . key "state" . _String . TL.unpacked . to toBool + state v = v ^? key "event" . key "variables" . key "trigger" . key "to_state" . key "state" . _String . TL.unpacked . to toBool toBool = \case "on" -> True "off" -> False diff --git a/src/HomeAssistant/Controller/Bedroom.hs b/src/HomeAssistant/Controller/Bedroom.hs index 38d0378..e96eb74 100644 --- a/src/HomeAssistant/Controller/Bedroom.hs +++ b/src/HomeAssistant/Controller/Bedroom.hs @@ -79,7 +79,7 @@ ikeaQuickButton entityId = >>| arr (maybe (Left ()) Right . eventType) >>> toEvent where - eventType v = v ^? key "event" . key "data" . key "new_state" . key "attributes" . key "event_type" . _String . to toIkeaQuickButton . traversed + eventType v = v ^? key "event" . key "variables" . key "trigger" . key "to_state" . key "attributes" . key "event_type" . _String . to toIkeaQuickButton . traversed data BedroomControls diff --git a/src/HomeAssistant/Runtime.hs b/src/HomeAssistant/Runtime.hs index f6edeb4..d73f937 100644 --- a/src/HomeAssistant/Runtime.hs +++ b/src/HomeAssistant/Runtime.hs @@ -35,7 +35,7 @@ import Control.Monad.Fix (MonadFix) import HomeAssistant.Controller.Ruuvi (ruuviController) step :: (MonadFix m, MonadIO m) => (forall x. eff x -> m x) -> UUID -> Mealy eff a b -> a -> m (b, Mealy eff a b) -step nt trace (Mealy f) a = do +step nt trace (Mealy _ f) a = do now <- liftIO getCurrentTime f nt (Request now trace) a @@ -47,7 +47,7 @@ controllers = , Controller "bedroom-button" bedroomButtonController False -- This works but leaving for vacation , Controller "bedroom-drawer" bedroomDrawerController True , Controller "bedroom-humidifier" humidifierController False - , Controller "ruuvi-controller" ruuviController False + , Controller "ruuvi-controller" ruuviController True ] -- | Steps the machine for every inbound message; service calls go to the @@ -71,8 +71,10 @@ defaultMain = withSocketsDo $ do withBus severity $ \bus -> do token <- getEnv "HA_TOKEN" host <- getEnv "HA_HOST" - let workers = - [ ("reader", readerAction host 8123 token bus) + let active = [c | c@(Controller _ _ True) <- controllers] + ents = foldMap (\(Controller _ m _) -> entities m) active + workers = + [ ("reader", readerAction host 8123 token ents bus) , ("writer", writerAction bus) ] ++ [ (name, runController bus c) | c@(Controller name _ True) <- controllers ] as <- mapM (\(name, act) -> async (supervised name defaultBackoff act)) workers diff --git a/src/HomeAssistant/Runtime/Connection.hs b/src/HomeAssistant/Runtime/Connection.hs index 0b4df48..795d6e5 100644 --- a/src/HomeAssistant/Runtime/Connection.hs +++ b/src/HomeAssistant/Runtime/Connection.hs @@ -18,10 +18,11 @@ import Control.Concurrent.STM import Control.Exception (onException) import Control.Exception.Annotated (throw) import Control.Lens ((^?)) -import Control.Monad (forever) +import Control.Monad (forever, forM_) import Data.Aeson (Value, eitherDecode, encode, object, (.=)) import Data.Aeson.Lens (key, _String) import qualified Data.ByteString.Lazy as BL +import qualified Data.Set as S import qualified Data.Text as T import Data.Void (Void) import HomeAssistant.Controller (Service (..), Target (..)) @@ -35,11 +36,11 @@ import AFRP (Request(..)) -- | Connect, authenticate, subscribe, then receive and broadcast forever. -- Restarting this action reconnects. All setup sends happen before the -- connection is published in the bus, so only the writer sends afterwards. -readerAction :: String -> Int -> String -> Bus -> IO Void -readerAction host port token bus = +readerAction :: String -> Int -> String -> S.Set T.Text -> Bus -> IO Void +readerAction host port token ents bus = WS.runClient host port "/api/websocket" $ \conn -> do handshake conn token - subscribe bus conn + subscribe bus conn ents atomically $ writeTVar (busConn bus) (Just conn) putStrLn "[reader] connected" -- Unpublish on exit so the writer blocks and the backlog survives the outage. @@ -62,14 +63,19 @@ expectType expected msg = Just t | t == expected -> pure () _ -> throw (Fatal $ "expected " <> expected <> ", got: " <> T.pack (show msg)) -subscribe :: Bus -> WS.Connection -> IO () -subscribe bus conn = do - sid <- generateCallId (busGen bus) - WS.sendTextData conn $ encode $ object - [ "id" .= sid - , "type" .= ("subscribe_events" :: T.Text) - , "event_type" .= ("state_changed" :: T.Text) - ] +subscribe :: Bus -> WS.Connection -> S.Set T.Text -> IO () +subscribe bus conn ents = + forM_ (S.toList ents) $ \entityId -> do + print entityId + sid <- generateCallId (busGen bus) + WS.sendTextData conn $ encode $ object + [ "id" .= sid + , "type" .= ("subscribe_trigger" :: T.Text) + , "trigger" .= object + [ "platform" .= ("state" :: T.Text) + , "entity_id" .= entityId + ] + ] -- | Undecodable messages are skipped: reconnecting cannot fix a decode -- problem, so crashing here would only produce a hot restart loop. diff --git a/test/AFRPSpec.hs b/test/AFRPSpec.hs index 050795c..aa6acc5 100644 --- a/test/AFRPSpec.hs +++ b/test/AFRPSpec.hs @@ -1,12 +1,16 @@ +{-# LANGUAGE OverloadedStrings #-} + module AFRPSpec (spec) where -import Control.Arrow (arr) +import Control.Arrow (arr, (&&&), first, left) import Control.Category ((>>>)) import Control.Monad.Fix (MonadFix (..)) import Data.Foldable (for_) import AFRP import Data.Functor.Identity (Identity (..)) import Data.List (sort) +import qualified Data.Set as S +import qualified Data.Text as T import Data.Time (NominalDiffTime, UTCTime (..), addUTCTime, diffUTCTime) import Data.UUID (nil) import Hedgehog @@ -59,6 +63,7 @@ runStEff m s0 as = go m s0 as spec :: Spec spec = describe "AFRP" $ do + entitiesSpec holdSpec eventsSpec isEventSpec @@ -529,3 +534,56 @@ sampleSpec = describe "sample" $ do out = runPure sample ps for_ (zip ps out) $ \((v, ev), o) -> o === tag v ev + +-- | A stateless arrow carrying a fixed entity set, for testing propagation. +subscribed :: S.Set T.Text -> Mealy Identity Int Int +subscribed ents = Mealy ents $ \_ _ a -> pure (a, subscribed ents) + +-- | Same as 'subscribed' but yields a function, for testing '<*>'. +subscribedF :: S.Set T.Text -> Mealy Identity Int (Int -> Int) +subscribedF ents = Mealy ents $ \_ _ a -> pure ((a +), subscribedF ents) + +entitiesSpec :: Spec +entitiesSpec = describe "entities" $ do + it "id carries no entities" $ + entities (arr id :: Mealy Identity Int Int) `shouldBe` S.empty + + it "arr carries no entities" $ + entities (arr (+ 1) :: Mealy Identity Int Int) `shouldBe` S.empty + + it "eff carries no entities" $ + entities (eff (\_ x -> Identity (x + 1))) `shouldBe` S.empty + + it "primitive combinators carry no entities" $ do + entities (hold 'a') `shouldBe` S.empty + entities (changes @Int) `shouldBe` S.empty + entities edge `shouldBe` S.empty + entities (sliding (3 :: Int)) `shouldBe` S.empty + + it "Category (.) unions entity sets" $ + entities (subscribed (S.singleton "a") >>> subscribed (S.singleton "b")) + `shouldBe` S.fromList ["a", "b"] + + it "Applicative (<*>) unions entity sets" $ + entities (subscribedF (S.singleton "a") <*> subscribed (S.singleton "b")) + `shouldBe` S.fromList ["a", "b"] + + it "Arrow (&&&) unions entity sets" $ + entities (subscribed (S.singleton "a") &&& subscribed (S.singleton "b")) + `shouldBe` S.fromList ["a", "b"] + + it "(>>>) unions entity sets" $ + entities (subscribed (S.singleton "a") >>> arr id >>> subscribed (S.singleton "b")) + `shouldBe` S.fromList ["a", "b"] + + it "left preserves the entity set" $ + entities (left (subscribed (S.singleton "a")) :: Mealy Identity (Either Int Int) (Either Int Int)) + `shouldBe` S.singleton "a" + + it "first preserves the entity set" $ + entities (first (subscribed (S.singleton "a")) :: Mealy Identity (Int, Int) (Int, Int)) + `shouldBe` S.singleton "a" + + it "fmap preserves the entity set" $ + entities (fmap (+ 1) (subscribed (S.singleton "a"))) + `shouldBe` S.singleton "a" diff --git a/test/BedroomSpec.hs b/test/BedroomSpec.hs index 5f0a432..a8c8d4a 100644 --- a/test/BedroomSpec.hs +++ b/test/BedroomSpec.hs @@ -2,7 +2,8 @@ module BedroomSpec (spec) where -import AFRP (Event (..)) +import AFRP (Event (..), entities) +import qualified Data.Set as S import qualified Data.Text as T import Data.Aeson (Value) import HomeAssistant.Controller @@ -21,9 +22,39 @@ drawerState = Event . stateEvent "binary_sensor.bedroom_nightstand_drawer_sensor spec :: Spec spec = describe "Bedroom" $ do + entitySpec drawerSpec buttonSpec +entitySpec :: Spec +entitySpec = describe "entities" $ do + it "entityChangeEvent' registers its entity id" $ + entities (entityChangeEvent' "sensor.foo") + `shouldBe` S.singleton "sensor.foo" + + it "entityRead / entityBool inherit the entity id" $ do + entities (entityRead @Double "sensor.bar") `shouldBe` S.singleton "sensor.bar" + entities (entityBool "binary_sensor.baz") `shouldBe` S.singleton "binary_sensor.baz" + + it "bedroomDrawerController subscribes to the drawer sensor" $ + entities bedroomDrawerController + `shouldBe` S.singleton "binary_sensor.bedroom_nightstand_drawer_sensor_masse_contact" + + it "bedroomButtonController subscribes to both remote event entities" $ + entities bedroomButtonController + `shouldBe` S.fromList + [ "event.bedroom_quick_remote_masse_action" + , "event.bedroom_quick_jemina_action" + ] + + it "bedroomPresenceController subscribes to the presence sensor" $ + entities bedroomPresenceController + `shouldBe` S.singleton "binary_sensor.presence_sensor_bedroom_occupancy" + + it "humidifierController subscribes to the door sensor" $ + entities humidifierController + `shouldBe` S.singleton "binary_sensor.makuuhuone_ovi_contact" + drawerSpec :: Spec drawerSpec = describe "bedroomDrawerController" $ do let entity = EntityId "switch.bedroom_drawer_light_masse" diff --git a/test/RuntimeSpec.hs b/test/RuntimeSpec.hs index 953f58e..d520982 100644 --- a/test/RuntimeSpec.hs +++ b/test/RuntimeSpec.hs @@ -32,9 +32,11 @@ spec = pure () -- doorEvent :: Text -> Value -- doorEvent state = object -- [ "event" .= object --- [ "data" .= object --- [ "entity_id" .= ("binary_sensor.makuuhuone_ovi_contact" :: Text) --- , "new_state" .= object ["state" .= state] +-- [ "variables" .= object +-- [ "trigger" .= object +-- [ "entity_id" .= ("binary_sensor.makuuhuone_ovi_contact" :: Text) +-- , "to_state" .= object ["state" .= state] +-- ] -- ] -- ] -- ] diff --git a/test/Support.hs b/test/Support.hs index c487fc0..b238d3a 100644 --- a/test/Support.hs +++ b/test/Support.hs @@ -57,25 +57,31 @@ runHASS m (a : as) = services :: [(b, [Service])] -> [[Service]] services = map snd --- | Build a state-change event payload matching `entityChangeEvent'` / `entityBool'` lenses. +-- | Build a state-trigger payload matching `entityChangeEvent'` / `entityBool'` +-- lenses. The subscribe_trigger websocket event wraps the trigger datum under +-- `event.variables.trigger`, with `entity_id` and `to_state.state` fields. stateEvent :: T.Text -> T.Text -> Value stateEvent entityId state = object [ "event" .= object - [ "data" .= object - [ "entity_id" .= entityId - , "new_state" .= object [ "state" .= state ] + [ "variables" .= object + [ "trigger" .= object + [ "entity_id" .= entityId + , "to_state" .= object [ "state" .= state ] + ] ] ] ] --- | Build an Ikea button event payload matching `ikeaQuickButton` lenses. +-- | Build an Ikea button trigger payload matching `ikeaQuickButton` lenses. buttonEvent :: T.Text -> T.Text -> Value buttonEvent entityId eventType = object [ "event" .= object - [ "data" .= object - [ "entity_id" .= entityId - , "new_state" .= object - [ "attributes" .= object [ "event_type" .= eventType ] ] + [ "variables" .= object + [ "trigger" .= object + [ "entity_id" .= entityId + , "to_state" .= object + [ "attributes" .= object [ "event_type" .= eventType ] ] + ] ] ] ]