Add Runtime.Bus with channel-based effect interpreter

src/HomeAssistant/Controller.hs

@@ -40,7 +40,7 @@ data Service = Service
   , serviceData :: Maybe Value
   , serviceTarget :: T.Text
   }
-  deriving Show
+  deriving (Show, Eq)
 
 data HASSEff a where
   CallService :: Service -> HASSEff ()

src/HomeAssistant/Runtime.hs

@@ -16,6 +16,7 @@ module HomeAssistant.Runtime
 
 import AFRP (Mealy(..), Event(..))
 import HomeAssistant.Controller (HASSEff(..), lightController, Service(..))
+import HomeAssistant.Runtime.Bus (CallIdGen(..), mkCallIdGen)
 import Data.Aeson ((.=), Value (Null), encode, eitherDecode, object)
 import qualified Data.ByteString.Lazy as BL
 import qualified Data.Text as T
@@ -23,7 +24,6 @@ import qualified Network.WebSockets as WS
 import Network.Socket (withSocketsDo)
 import System.Environment (getEnv)
 import Data.Time (getCurrentTime)
-import Data.IORef (newIORef, atomicModifyIORef')
 
 step :: (forall x. eff x -> IO x) -> Mealy eff a b -> a -> IO (b, Mealy eff a b)
 step nt (Mealy f) a = do
@@ -102,13 +102,6 @@ wsCallService conn requestId domain service entityId =
         ]
     ]
 
-newtype CallIdGen = CallIdGen { generateCallId :: IO Int  }
-
-mkCallIdGen :: Int -> IO CallIdGen
-mkCallIdGen start = do
-  gen <- newIORef start
-  pure $ CallIdGen $ atomicModifyIORef' gen (\old -> let new = old + 1 in new `seq` (new, new))
-
 hassEval :: CallIdGen -> WS.Connection -> HASSEff a -> IO a
 hassEval gen conn = \case
   CallService x -> do

src/HomeAssistant/Runtime/Bus.hs

@@ -0,0 +1,52 @@
+{-# LANGUAGE LambdaCase #-}
+
+module HomeAssistant.Runtime.Bus
+  ( Bus(..)
+  , CallIdGen(..)
+  , mkCallIdGen
+  , newBus
+  , channelHassEval
+  ) where
+
+import Control.Concurrent.STM
+  ( TChan
+  , TVar
+  , atomically
+  , newBroadcastTChanIO
+  , newTChanIO
+  , newTVarIO
+  , writeTChan
+  )
+import Data.Aeson (Value)
+import Data.IORef (atomicModifyIORef', newIORef)
+import HomeAssistant.Controller (HASSEff (..), Service)
+import Network.WebSockets (Connection)
+
+-- | Shared runtime state: inbound is a broadcast channel (controllers
+-- read from 'dupTChanIO' copies), outbound queues service calls for the
+-- writer, conn holds the current websocket (Nothing before first connect).
+data Bus = Bus
+  { busInbound  :: TChan Value
+  , busOutbound :: TChan Service
+  , busConn     :: TVar (Maybe Connection)
+  , busGen      :: CallIdGen
+  }
+
+newBus :: Int -> IO Bus
+newBus start = Bus
+  <$> newBroadcastTChanIO
+  <*> newTChanIO
+  <*> newTVarIO Nothing
+  <*> mkCallIdGen start
+
+channelHassEval :: Bus -> HASSEff a -> IO a
+channelHassEval bus = \case
+  CallService svc -> atomically $ writeTChan (busOutbound bus) svc
+  Pure a          -> pure a
+
+newtype CallIdGen = CallIdGen { generateCallId :: IO Int }
+
+mkCallIdGen :: Int -> IO CallIdGen
+mkCallIdGen start = do
+  gen <- newIORef start
+  pure $ CallIdGen $ atomicModifyIORef' gen (\old -> let new = old + 1 in new `seq` (new, new))