53 lines
1.3 KiB
Haskell
53 lines
1.3 KiB
Haskell
{-# 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))
|