From 5954c686827c5f3a618094139dcdc4c8900cb31a Mon Sep 17 00:00:00 2001 From: Mats Rauhala Date: Fri, 21 Aug 2026 11:55:27 +0300 Subject: [PATCH] Update tests --- src/HomeAssistant/Runtime.hs | 3 +-- src/HomeAssistant/Runtime/Connection.hs | 16 +++++++++++++--- test/BusSpec.hs | 4 ++-- test/ConnectionSpec.hs | 6 +++--- test/RuntimeSpec.hs | 18 ++++++++++++------ 5 files changed, 31 insertions(+), 16 deletions(-) diff --git a/src/HomeAssistant/Runtime.hs b/src/HomeAssistant/Runtime.hs index d9c2cc6..33054ad 100644 --- a/src/HomeAssistant/Runtime.hs +++ b/src/HomeAssistant/Runtime.hs @@ -55,8 +55,7 @@ runController bus (Controller _name machine) = do go inbound f = do msg <- atomically (readTChan inbound) uuid <- UUID.V4.nextRandom - -- (_, f') <- step (channelHassEval bus) f (Event msg) - (_, f') <- step (dryRunHassEval (busGen bus)) uuid f (Event msg) + (_, f') <- step (channelHassEval bus) uuid f (Event msg) go inbound f' defaultMain :: IO () diff --git a/src/HomeAssistant/Runtime/Connection.hs b/src/HomeAssistant/Runtime/Connection.hs index f194d94..e5d6473 100644 --- a/src/HomeAssistant/Runtime/Connection.hs +++ b/src/HomeAssistant/Runtime/Connection.hs @@ -97,6 +97,16 @@ encodeService callId Service{..} = object $ , "type" .= ("call_service" :: T.Text) , "domain" .= serviceDomain , "service" .= serviceName - , "target" .= object [ "entity_id" .= [e | EntityId e <- serviceTarget] - , "area_id" .= [a | AreaId a <- serviceTarget]] - ] <> maybe [] (\d -> ["data" .= d]) serviceData + , "target" .= targetObject serviceTarget + ] <> maybe [] (\d -> ["service_data" .= d]) serviceData + +-- | A single target encodes as a scalar; multiple encode as a list. Empty +-- lists are omitted so Home Assistant receives only populated keys. +targetObject :: [Target] -> Value +targetObject targets = object $ entityPart <> areaPart + where + entityPart = emit "entity_id" [e | EntityId e <- targets] + areaPart = emit "area_id" [a | AreaId a <- targets] + emit _ [] = [] + emit k [x] = [k .= x] + emit k many = [k .= many] diff --git a/test/BusSpec.hs b/test/BusSpec.hs index b424cfd..dcaae6f 100644 --- a/test/BusSpec.hs +++ b/test/BusSpec.hs @@ -9,7 +9,7 @@ import Control.Concurrent.STM , writeTChan ) import Data.Aeson (Value (..)) -import HomeAssistant.Controller (HASSEff (..), Service (..)) +import HomeAssistant.Controller (HASSEff (..), Service (..), Target(..)) import HomeAssistant.Runtime.Bus import Test.Hspec @@ -28,7 +28,7 @@ spec = describe "Bus" $ do it "channelHassEval writes CallService to the outbound channel" $ do bus <- newBus 0 - let svc = Service "light" "turn_on" Nothing "light.bedroom_masse" + let svc = Service "light" "turn_on" Nothing [EntityId "light.bedroom_masse"] channelHassEval bus (CallService svc) atomically (readTChan (busOutbound bus)) `shouldReturn` svc diff --git a/test/ConnectionSpec.hs b/test/ConnectionSpec.hs index 8079c19..9d1f37b 100644 --- a/test/ConnectionSpec.hs +++ b/test/ConnectionSpec.hs @@ -4,14 +4,14 @@ module ConnectionSpec (spec) where import Data.Aeson (object, (.=)) import Data.Text (Text) -import HomeAssistant.Controller (Service (..)) +import HomeAssistant.Controller (Service (..), Target(..)) import HomeAssistant.Runtime.Connection (encodeService) import Test.Hspec spec :: Spec spec = describe "encodeService" $ do it "encodes a call_service message" $ - encodeService 7 (Service "light" "turn_on" Nothing "light.bedroom_masse") + encodeService 7 (Service "light" "turn_on" Nothing [EntityId "light.bedroom_masse"]) `shouldBe` object [ "id" .= (7 :: Int) , "type" .= ("call_service" :: Text) @@ -21,7 +21,7 @@ spec = describe "encodeService" $ do ] it "includes service_data when present" $ - encodeService 8 (Service "light" "turn_on" (Just (object ["brightness" .= (200 :: Int)])) "light.bedroom_masse") + encodeService 8 (Service "light" "turn_on" (Just (object ["brightness" .= (200 :: Int)])) [EntityId "light.bedroom_masse"]) `shouldBe` object [ "id" .= (8 :: Int) , "type" .= ("call_service" :: Text) diff --git a/test/RuntimeSpec.hs b/test/RuntimeSpec.hs index 9e30744..b6df20b 100644 --- a/test/RuntimeSpec.hs +++ b/test/RuntimeSpec.hs @@ -2,11 +2,11 @@ module RuntimeSpec (spec) where import Control.Concurrent (threadDelay) -import Control.Concurrent.Async (async) +import Control.Concurrent.Async (async, race) import Control.Concurrent.STM (atomically, isEmptyTChan, readTChan, writeTChan) import Data.Aeson (Value, object, (.=)) import Data.Text (Text) -import HomeAssistant.Controller (light, lightController) +import HomeAssistant.Controller (light, lightController, Target (..)) import HomeAssistant.Runtime (Controller (..), runController) import HomeAssistant.Runtime.Bus import Test.Hspec @@ -16,15 +16,21 @@ spec = describe "runController" $ do it "feeds inbound events through the machine and forwards service calls" $ do bus <- newBus 0 _ <- async (runController bus (Controller "test" lightController)) + putStrLn "Before the delay" threadDelay 100000 -- let the controller dup its inbound channel + putStrLn "After the delay" atomically $ writeTChan (busInbound bus) (doorEvent "on") -- initial value: no change event atomically $ writeTChan (busInbound bus) (doorEvent "off") -- door closes: lights on atomically $ writeTChan (busInbound bus) (doorEvent "on") -- door opens: lights off - svc1 <- atomically (readTChan (busOutbound bus)) - svc2 <- atomically (readTChan (busOutbound bus)) - svc1 `shouldBe` light True - svc2 `shouldBe` light False + putStrLn "After the writes" + svc1 <- boundedRead (busOutbound bus) + svc2 <- boundedRead (busOutbound bus) + putStrLn "After the reads" + svc1 `shouldBe` Right (light [EntityId "light.bedroom_masse"] True) + svc2 `shouldBe` Right (light [EntityId "light.bedroom_masse"] False) atomically (isEmptyTChan (busOutbound bus)) `shouldReturn` True + where + boundedRead channel = race (threadDelay 10000) (atomically (readTChan channel)) doorEvent :: Text -> Value doorEvent state = object