91 lines
3.4 KiB
Haskell
91 lines
3.4 KiB
Haskell
{-# LANGUAGE OverloadedStrings #-}
|
|
|
|
module BusSpec (spec) where
|
|
|
|
import AFRP (Request (..), Event (..))
|
|
import Control.Concurrent.STM
|
|
( atomically
|
|
, dupTChan
|
|
, isEmptyTChan
|
|
, readTChan
|
|
, writeTChan
|
|
)
|
|
import Data.Aeson (Value (..))
|
|
import qualified Data.HashMap.Strict as HM
|
|
import Data.Time (UTCTime (..), utc)
|
|
import Data.UUID (nil)
|
|
import HomeAssistant.Controller (HASSEff (..), Service (..), Target(..))
|
|
import HomeAssistant.Runtime.Bus
|
|
import HomeAssistant.Runtime.Flags (loadFlags, setEnabled)
|
|
import HomeAssistant.Runtime.Metrics (registerAppMetrics)
|
|
import Katip (Namespace (Namespace), runKatipContextT, Severity (..))
|
|
import qualified System.Metrics as Metrics
|
|
import System.IO.Temp (withTempDirectory)
|
|
import Test.Hspec
|
|
|
|
spec :: Spec
|
|
spec = describe "Bus" $ do
|
|
it "broadcasts inbound messages to every dup'd channel in order" $ withTestBus $ \bus -> do
|
|
p1 <- atomically $ dupTChan (busInbound bus)
|
|
p2 <- atomically $ dupTChan (busInbound bus)
|
|
atomically $ writeTChan (busInbound bus) (Event (Number 1))
|
|
atomically $ writeTChan (busInbound bus) (Event (Number 2))
|
|
r1 <- atomically $ (,) <$> readTChan p1 <*> readTChan p1
|
|
r2 <- atomically $ (,) <$> readTChan p2 <*> readTChan p2
|
|
r1 `shouldBe` (Event (Number 1), Event (Number 2))
|
|
r2 `shouldBe` (Event (Number 1), Event (Number 2))
|
|
|
|
it "channelHassEval writes CallService to the outbound channel" $ withTestBus $ \bus -> do
|
|
let req = Request (UTCTime (toEnum 0) 0) utc nil "test"
|
|
svc = Service "light" "turn_on" Nothing [EntityId "light.bedroom_masse"]
|
|
runKatipContextT (busLogEnv bus) () (Namespace ["test"]) $
|
|
channelHassEval bus (CallService req svc)
|
|
(_, svc') <- atomically $ readTChan (busOutbound bus)
|
|
svc' `shouldBe` svc
|
|
|
|
it "channelHassEval drops CallService when the handler is disabled" $
|
|
withTestFlagsBus $ \bus -> do
|
|
setEnabled (busFlags bus) "test-handler" False
|
|
let req = Request (UTCTime (toEnum 0) 0) utc nil "test-handler"
|
|
svc = Service "light" "turn_on" Nothing [EntityId "light.test"]
|
|
runKatipContextT (busLogEnv bus) () (Namespace ["test"]) $
|
|
channelHassEval bus (CallService req svc)
|
|
atomically (isEmptyTChan (busOutbound bus)) `shouldReturn` True
|
|
|
|
|
|
it "generates unique sequential call ids" $ do
|
|
gen <- mkCallIdGen 0
|
|
a <- generateCallId gen
|
|
b <- generateCallId gen
|
|
(a, b) `shouldBe` (1, 2)
|
|
|
|
describe "recordInbound / recordOutbound" $ do
|
|
it "increments the trigger and service counters" $ do
|
|
store <- Metrics.newStore
|
|
m <- registerAppMetrics store
|
|
withTempDirectory "/tmp" "bus-spec" $ \dir -> do
|
|
flags <- loadFlags dir []
|
|
withBus InfoS m flags $ \bus -> do
|
|
recordInbound bus
|
|
recordInbound bus
|
|
recordOutbound bus
|
|
sample <- Metrics.sampleAll store
|
|
HM.lookup "hass.trigger.in" sample `shouldBe` Just (Metrics.Counter 2)
|
|
HM.lookup "hass.service.out" sample `shouldBe` Just (Metrics.Counter 1)
|
|
|
|
withTestBus :: (Bus -> IO a) -> IO a
|
|
withTestBus action = do
|
|
store <- Metrics.newStore
|
|
m <- registerAppMetrics store
|
|
withTempDirectory "/tmp" "bus-spec" $ \dir -> do
|
|
flags <- loadFlags dir []
|
|
withBus InfoS m flags action
|
|
|
|
withTestFlagsBus :: (Bus -> IO a) -> IO a
|
|
withTestFlagsBus action = do
|
|
store <- Metrics.newStore
|
|
m <- registerAppMetrics store
|
|
withTempDirectory "/tmp" "bus-spec" $ \dir -> do
|
|
flags <- loadFlags dir ["test-handler"]
|
|
withBus InfoS m flags action
|