A lot of internals as I tried to do a switch based logic

src/HomeAssistant/Runtime/Connection.hs

@@ -15,13 +15,14 @@ import Control.Concurrent.STM
   , writeTChan
   , writeTVar
   )
+import Control.Concurrent.Async (race)
+import Control.Concurrent (threadDelay)
 import Control.Exception (onException)
 import Control.Exception.Annotated (throw)
 import Control.Lens ((^?))
 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)
@@ -31,7 +32,7 @@ import HomeAssistant.Runtime.Supervisor (Fatal (..))
 import qualified Network.WebSockets as WS
 import Katip (runKatipContextT, sl, logFM, Severity (..), ls)
 import Data.UUID (toText)
-import AFRP (Request(..))
+import AFRP (Request(..), Event(..))
 
 -- | Connect, authenticate, subscribe, then receive and broadcast forever.
 -- Restarting this action reconnects. All setup sends happen before the
@@ -79,12 +80,18 @@ subscribe bus conn ents =
 
 -- | Undecodable messages are skipped: reconnecting cannot fix a decode
 -- problem, so crashing here would only produce a hot restart loop.
+--
+-- Each read races a one-second timeout: a timeout broadcasts 'Tick' so
+-- time-based primitives (debounce, rollup, fixed, ...) keep advancing
+-- even when no state changes arrive.
 receiveLoop :: Bus -> WS.Connection -> IO Void
 receiveLoop bus conn = forever $ do
-  msg <- WS.receiveData conn :: IO BL.ByteString
-  case eitherDecode msg of
-    Left err -> putStrLn $ "[reader] skipping undecodable message: " <> err
-    Right v  -> atomically $ writeTChan (busInbound bus) v
+  winner <- race (threadDelay 1000000) (WS.receiveData conn)
+  case winner of
+    Left () -> atomically $ writeTChan (busInbound bus) Tick
+    Right msg -> case eitherDecode msg of
+      Left err -> putStrLn $ "[reader] skipping undecodable message: " <> err
+      Right v  -> atomically $ writeTChan (busInbound bus) (Event v)
 
 receiveJSON :: WS.Connection -> IO Value
 receiveJSON conn = do