From 7ed846d0fc0597daf9f2e9c23888efdc29c7cf4a Mon Sep 17 00:00:00 2001 From: Mats Rauhala Date: Tue, 29 Sep 2026 11:33:56 +0300 Subject: [PATCH] Fix the ambience mode --- .gitignore | 1 + home-assistant-controller.cabal | 20 +++++----- src/HomeAssistant/Controller/Livingroom.hs | 2 +- test/KitchenSpec.hs | 45 ++++++++++++++++++++++ test/LivingroomSpec.hs | 43 +++++++++++++++++++++ test/Main.hs | 4 ++ test/Support.hs | 13 ++++++- 7 files changed, 117 insertions(+), 11 deletions(-) create mode 100644 test/KitchenSpec.hs create mode 100644 test/LivingroomSpec.hs diff --git a/.gitignore b/.gitignore index 9fd5e1b..0d9c19b 100644 --- a/.gitignore +++ b/.gitignore @@ -10,3 +10,4 @@ docs/superpowers *.eventlog *.eventlog.html *.rrd +*.rrd.*bak* diff --git a/home-assistant-controller.cabal b/home-assistant-controller.cabal index d0e333e..f933dd1 100644 --- a/home-assistant-controller.cabal +++ b/home-assistant-controller.cabal @@ -158,15 +158,17 @@ test-suite home-assistant-controller-test -- Modules included in this executable, other than Main. other-modules: AFRPLawsSpec - , AFRPSpec - , BedroomSpec - , BusSpec - , ConnectionSpec - , FlagsSpec - , GraphingSpec - , MetricsSpec - , RuntimeSpec - , Support + , AFRPSpec + , BedroomSpec + , BusSpec + , ConnectionSpec + , FlagsSpec + , GraphingSpec + , KitchenSpec + , LivingroomSpec + , MetricsSpec + , RuntimeSpec + , Support -- LANGUAGE extensions used by modules in this package. -- other-extensions: diff --git a/src/HomeAssistant/Controller/Livingroom.hs b/src/HomeAssistant/Controller/Livingroom.hs index dbb8198..cfa7264 100644 --- a/src/HomeAssistant/Controller/Livingroom.hs +++ b/src/HomeAssistant/Controller/Livingroom.hs @@ -96,5 +96,5 @@ livingroomPlantLights = (season &&& tod) setLights = proc mode -> do case mode of AFRP.Event Growth -> callService (activateScene "scene.olohuoneen_kasvivalo") -< () - AFRP.Event Ambience -> callService (activateScene "scene.makuuhuone_lepotila") -< () + AFRP.Event Ambience -> callService (activateScene "scene.kasvivalo_iltatila") -< () _ -> returnA -< () diff --git a/test/KitchenSpec.hs b/test/KitchenSpec.hs new file mode 100644 index 0000000..d2d0dfa --- /dev/null +++ b/test/KitchenSpec.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE OverloadedStrings #-} + +module KitchenSpec (spec) where + +import AFRP (Event (..), entities) +import qualified Data.Set as S +import qualified Data.Text as T +import Data.Aeson (Value) +import HomeAssistant.Controller +import HomeAssistant.Controller.Kitchen +import Support +import Test.Hspec + +-- Helper functions for creating test events +testDinnerLightLevel :: Int -> Event Value +testDinnerLightLevel level = Event (stateEvent "sensor.sijainti_keittio_light_level" (T.pack $ show level)) + +testDinnerPresence :: T.Text -> Event Value +testDinnerPresence state = Event (stateEvent "binary_sensor.sijainti_keittio_occupancy" state) + +spec :: Spec +spec = describe "Kitchen" $ do + dinnerTableSpec + +dinnerTableSpec :: Spec +dinnerTableSpec = describe "dinnerTableController" $ do + it "subscribes to the light level sensor" $ do + entities dinnerTableController + `shouldBe` S.fromList ["sensor.sijainti_keittio_light_level", "binary_sensor.sijainti_keittio_occupancy"] + + it "subscribes to the presence sensor" $ do + entities dinnerTableController + `shouldBe` S.fromList ["sensor.sijainti_keittio_light_level", "binary_sensor.sijainti_keittio_occupancy"] + + it "turns lights on when presence is occupied and light level is low" $ do + services (runHASS dinnerTableController [testDinnerLightLevel 10, testDinnerPresence "on"]) + `shouldBe` [[switch [EntityId "switch.adaptive_lighting_ruokapoydan_valot_sleep_mode"] True], [switch [EntityId "switch.adaptive_lighting_ruokapoydan_valot_sleep_mode"] False, light [EntityId "light.kitchen_dining_large"] (On Nothing)]] + + it "turns lights off when presence is unoccupied" $ do + services (runHASS dinnerTableController [testDinnerLightLevel 10, testDinnerPresence "off"]) + `shouldBe` [[switch [EntityId "switch.adaptive_lighting_ruokapoydan_valot_sleep_mode"] True], []] + + it "does nothing on Tick" $ do + services (runHASS dinnerTableController [Tick]) + `shouldBe` [[switch [EntityId "switch.adaptive_lighting_ruokapoydan_valot_sleep_mode"] True]] \ No newline at end of file diff --git a/test/LivingroomSpec.hs b/test/LivingroomSpec.hs new file mode 100644 index 0000000..5f71f8f --- /dev/null +++ b/test/LivingroomSpec.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE OverloadedStrings #-} + +module LivingroomSpec (spec) where + +import AFRP (Event (..)) +import Data.Time (UTCTime (..), fromGregorian) +import HomeAssistant.Controller +import HomeAssistant.Controller.Livingroom +import Support +import Test.Hspec + +-- | A UTCTime at a given hour on March 15, 2025 (Spring). +springAt :: Int -> UTCTime +springAt h = UTCTime (fromGregorian 2025 3 15) (fromIntegral (h * 3600)) + +-- | A UTCTime at a given hour on July 15, 2025 (Summer). +summerAt :: Int -> UTCTime +summerAt h = UTCTime (fromGregorian 2025 7 15) (fromIntegral (h * 3600)) + +spec :: Spec +spec = describe "livingroomPlantLights" $ do + it "activates the Growth scene at 10:00 in Spring" $ do + let result = runHASSTimed livingroomPlantLights + [ (springAt 9, Tick) + , (springAt 10, Tick) + ] + services result + `shouldBe` [ [], [activateScene "scene.olohuoneen_kasvivalo"] ] + + it "activates the Ambience scene at 20:00 in Spring" $ do + let result = runHASSTimed livingroomPlantLights + [ (springAt 19, Tick) + , (springAt 20, Tick) + ] + services result + `shouldBe` [ [], [activateScene "scene.kasvivalo_iltatila"] ] + + it "does not activate Growth in Summer" $ do + let result = runHASSTimed livingroomPlantLights + [ (summerAt 9, Tick) + , (summerAt 10, Tick) + ] + services result `shouldBe` [ [], [] ] diff --git a/test/Main.hs b/test/Main.hs index a783121..d2a018a 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -8,6 +8,8 @@ import qualified BusSpec import qualified ConnectionSpec import qualified FlagsSpec import qualified GraphingSpec +import qualified KitchenSpec +import qualified LivingroomSpec import qualified MetricsSpec import qualified RuntimeSpec @@ -20,5 +22,7 @@ main = hspec $ do ConnectionSpec.spec FlagsSpec.spec GraphingSpec.spec + KitchenSpec.spec + LivingroomSpec.spec MetricsSpec.spec RuntimeSpec.spec diff --git a/test/Support.hs b/test/Support.hs index 781652c..849be22 100644 --- a/test/Support.hs +++ b/test/Support.hs @@ -4,6 +4,7 @@ module Support ( Acc(..) , interp , runHASS + , runHASSTimed , services , fakeRequest , sec @@ -16,7 +17,7 @@ import Data.Aeson (Value, object, (.=)) import qualified Data.Text as T import Data.Time (UTCTime (..), utc) import Data.UUID (nil) -import AFRP (Mealy (..), Request (..), stepAuto) +import AFRP (Mealy (..), Request (..), stepAuto, Event (..)) import HomeAssistant.Controller (HASSEff (..), Service) fakeRequest :: Request @@ -56,6 +57,16 @@ runHASS m = go (runMealy m interp) case runAcc (stepAuto w fakeRequest a) [] of ((b, w'), svcs) -> (b, svcs) : go w' as +-- | Run a HASS arrow over a list of (time, input) pairs, collecting per-step +-- emitted services. Each step uses a fresh Request with the given UTCTime. +runHASSTimed :: Mealy HASSEff (Event a) b -> [(UTCTime, Event a)] -> [(b, [Service])] +runHASSTimed m = go (runMealy m interp) + where + go _ [] = [] + go w ((t, a) : as) = + case runAcc (stepAuto w (Request t utc nil "test") a) [] of + ((b, w'), svcs) -> (b, svcs) : go w' as + services :: [(b, [Service])] -> [[Service]] services = map snd