Fix the ambience mode

.gitignore

@@ -10,3 +10,4 @@ docs/superpowers
 *.eventlog
 *.eventlog.html
 *.rrd
+*.rrd.*bak*

home-assistant-controller.cabal

@@ -164,6 +164,8 @@ test-suite home-assistant-controller-test
                       , ConnectionSpec
                       , FlagsSpec
                       , GraphingSpec
+                      , KitchenSpec
+                      , LivingroomSpec
                       , MetricsSpec
                       , RuntimeSpec
                       , Support

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 -< ()

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]]

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` [ [], [] ]

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

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