Triggers instead of full state events

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";

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

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)
 

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

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

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

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.

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"

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"

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]
+--         ]
 --       ]
 --     ]
 --   ]

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 ] ]
+        ]
       ]
     ]
   ]