Triggers instead of full state events

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.