MasseR/home-assistant-controller
1
0
Fork 0
Code Issues 2 Pull Requests Actions Packages Projects Releases Wiki Activity

Update tests

Browse Source
This commit is contained in:
MasseR
2026-09-30 15:01:17 +03:00
parent cceddad037
commit 6bcab1a0d8
5 changed files with 42 additions and 27 deletions
Download Patch File Download Diff File Expand all files Collapse all files
test/BedroomSpec.hs
+7 -7
View File
@@ -5,7 +5,7 @@ module BedroomSpec (spec) where
import AFRP (Event (..), entities)
import qualified Data.Set as S
import qualified Data.Text as T
import Data.Aeson (Value, object, (.=))
import Data.Aeson (Value)
import HomeAssistant.Controller
import HomeAssistant.Controller.Bedroom
import Support
@@ -91,15 +91,15 @@ buttonSpec = describe "bedroomButtonController" $ do
it "Masse single click turns on his nightstand scene (lowest)" $
concat (services (runHASS bedroomButtonController [masseButton "1_short_release"]))
`shouldContain` [activateSceneWith "scene.makuuhuone_masse" (Just $ object ["transition" .= (1 :: Int)])]
`shouldContain` [activateScene "scene.makuuhuone_masse"]
it "Masse double click turns on the middle scene" $
concat (services (runHASS bedroomButtonController [masseButton "1_double_press"]))
`shouldContain` [activateSceneWith "scene.makuuhuone_keski" (Just $ object ["transition" .= (1 :: Int)])]
`shouldContain` [activateScene "scene.makuuhuone_keski"]
it "Masse long click turns on the bright scene" $
concat (services (runHASS bedroomButtonController [masseButton "1_long_press"]))
`shouldContain` [activateSceneWith "scene.makuuhuone_kirkas" (Just $ object ["transition" .= (1 :: Int)])]
`shouldContain` [activateScene "scene.makuuhuone_kirkas"]
it "Masse off click turns the bedroom lights off" $
concat (services (runHASS bedroomButtonController [masseButton "2_short_release"]))
@@ -107,15 +107,15 @@ buttonSpec = describe "bedroomButtonController" $ do
it "Enishen single click turns on her nightstand scene (lowest)" $
concat (services (runHASS bedroomButtonController [enishenButton "1_short_release"]))
`shouldContain` [activateSceneWith "scene.makuuhuone_jemina" (Just $ object ["transition" .= (1 :: Int)])]
`shouldContain` [activateScene "scene.makuuhuone_jemina"]
it "Enishen double click turns on the middle scene" $
concat (services (runHASS bedroomButtonController [enishenButton "1_double_press"]))
`shouldContain` [activateSceneWith "scene.makuuhuone_keski" (Just $ object ["transition" .= (1 :: Int)])]
`shouldContain` [activateScene "scene.makuuhuone_keski"]
it "Enishen long click turns on the bright scene" $
concat (services (runHASS bedroomButtonController [enishenButton "1_long_press"]))
`shouldContain` [activateSceneWith "scene.makuuhuone_kirkas" (Just $ object ["transition" .= (1 :: Int)])]
`shouldContain` [activateScene "scene.makuuhuone_kirkas"]
it "Enishen off click turns the bedroom lights off" $
concat (services (runHASS bedroomButtonController [enishenButton "2_short_release"]))
test/BusSpec.hs
+12 -7
View File
@@ -18,7 +18,10 @@ 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 Control.Monad.IO.Class (liftIO)
import Katip (Namespace (Namespace), runKatipContextT)
import Katip.Monadic (runNoLoggingT)
import Support (withTestLogEnv)
import qualified System.Metrics as Metrics
import System.IO.Temp (withTempDirectory)
import System.Timeout (timeout)
@@ -67,8 +70,8 @@ spec = describe "Bus" $ do
store <- Metrics.newStore
m <- registerAppMetrics store
withTempDirectory "/tmp" "bus-spec" $ \dir -> do
flags <- loadFlags dir []
withBus InfoS m flags $ \bus -> do
flags <- runNoLoggingT (loadFlags dir [])
withTestLogEnv $ \le -> withBus le m flags $ \bus -> do
recordInbound bus
recordInbound bus
recordOutbound bus
@@ -80,14 +83,16 @@ withTestBus :: (Bus -> IO a) -> IO a
withTestBus action = do
store <- Metrics.newStore
m <- registerAppMetrics store
withTestLogEnv $ \le ->
withTempDirectory "/tmp" "bus-spec" $ \dir -> do
flags <- loadFlags dir []
withBus InfoS m flags action
flags <- runNoLoggingT (loadFlags dir [])
withBus le m flags action
withTestFlagsBus :: (Bus -> IO a) -> IO a
withTestFlagsBus action = do
store <- Metrics.newStore
m <- registerAppMetrics store
withTestLogEnv $ \le ->
withTempDirectory "/tmp" "bus-spec" $ \dir -> do
flags <- loadFlags dir ["test-handler"]
withBus InfoS m flags action
flags <- runNoLoggingT (loadFlags dir ["test-handler"])
withBus le m flags action
test/ConnectionSpec.hs
+5 -3
View File
@@ -15,7 +15,9 @@ import HomeAssistant.Runtime.Flags (loadFlags, setEnabled)
import HomeAssistant.Runtime.Metrics (registerAppMetrics)
import HomeAssistant.Runtime.RateLimit (registerRateLimitMetrics, slidingWindowLimiter)
import HomeAssistant.Runtime.Connection (dispatchService, encodeService, isTriggerEvent)
import Katip (Namespace (Namespace), Severity (InfoS), runKatipContextT)
import Katip (Namespace (Namespace), runKatipContextT)
import Katip.Monadic (runNoLoggingT)
import Support (withTestLogEnv)
import System.IO.Temp (withTempDirectory)
import qualified System.Metrics as Metrics
import System.Timeout (timeout)
@@ -60,9 +62,9 @@ spec = do
rlMetrics <- registerRateLimitMetrics store
limiter <- slidingWindowLimiter rlMetrics 10 20
withTempDirectory "/tmp" "connection-spec" $ \dir -> do
flags <- loadFlags dir ["test"]
flags <- runNoLoggingT (loadFlags dir ["test"])
setEnabled flags "test" False
withBus InfoS m flags $ \bus -> do
withTestLogEnv $ \le -> withBus le m flags $ \bus -> do
timeout 1000000 (do
runKatipContextT (busLogEnv bus) () (Namespace ["connection"]) $
dispatchService limiter bus (req 1) (lightOn [EntityId "light.test"])
test/FlagsSpec.hs
+9 -8
View File
@@ -10,6 +10,7 @@ import qualified Data.Map.Strict as M
import Data.Text (Text)
import qualified Hedgehog.Gen as Gen
import qualified Hedgehog.Range as Range
import Katip.Monadic (runNoLoggingT)
import System.IO.Temp (withTempDirectory)
import Test.Hspec
import Test.Hspec.Hedgehog
@@ -21,7 +22,7 @@ spec = describe "Flags" $ do
describe "loadFlags" $ do
it "defaults all names to True when the file is missing (opt-out)" $
withTempDirectory "/tmp" "flags-spec" $ \dir -> do
flags <- loadFlags dir ["a", "b"]
flags <- runNoLoggingT (loadFlags dir ["a", "b"])
m <- allFlags flags
m `shouldBe` M.fromList [("a" :: Text, True), ("b", True)]
@@ -29,7 +30,7 @@ spec = describe "Flags" $ do
withTempDirectory "/tmp" "flags-spec" $ \dir -> do
let path = dir <> "/handlers.json"
writeFile path "{\"b\": false}"
flags <- loadFlags dir ["a", "b"]
flags <- runNoLoggingT (loadFlags dir ["a", "b"])
m <- allFlags flags
m `shouldBe` M.fromList [("a" :: Text, True), ("b" :: Text, False)]
@@ -37,7 +38,7 @@ spec = describe "Flags" $ do
withTempDirectory "/tmp" "flags-spec" $ \dir -> do
let path = dir <> "/handlers.json"
writeFile path "not json at all"
flags <- loadFlags dir ["a"]
flags <- runNoLoggingT (loadFlags dir ["a"])
m <- allFlags flags
m `shouldBe` M.fromList [("a" :: Text, True)]
@@ -46,29 +47,29 @@ spec = describe "Flags" $ do
withTempDirectory "/tmp" "flags-spec" $ \dir -> do
let path = dir <> "/handlers.json"
writeFile path "{\"a\": false}"
flags <- loadFlags dir ["a"]
flags <- runNoLoggingT (loadFlags dir ["a"])
isEnabled flags "a" `shouldReturn` False
it "defaults unknown names to True" $
withTempDirectory "/tmp" "flags-spec" $ \dir -> do
flags <- loadFlags dir []
flags <- runNoLoggingT (loadFlags dir [])
isEnabled flags "unknown" `shouldReturn` True
describe "setEnabled" $ do
it "updates the in-memory map and persists to disk" $
withTempDirectory "/tmp" "flags-spec" $ \dir -> do
flags <- loadFlags dir ["a"]
flags <- runNoLoggingT (loadFlags dir ["a"])
setEnabled flags "a" False
isEnabled flags "a" `shouldReturn` False
-- reload from disk to confirm persistence
flags' <- loadFlags dir ["a"]
flags' <- runNoLoggingT (loadFlags dir ["a"])
isEnabled flags' "a" `shouldReturn` False
it "concurrent writes leave the file consistent with the TVar" $
hedgehog $ do
n <- forAll $ Gen.int (Range.linear 1 50)
liftIO $ withTempDirectory "/tmp" "flags-spec" $ \dir -> do
flags <- loadFlags dir ["x"]
flags <- runNoLoggingT (loadFlags dir ["x"])
mapConcurrently_ (\i -> setEnabled flags "x" (even i)) [1 .. n]
m <- allFlags flags
decoded <- decodeFileStrict (dir <> "/handlers.json")
test/Support.hs
+7
View File
@@ -10,10 +10,13 @@ module Support
, sec
, stateEvent
, buttonEvent
, withTestLogEnv
) where
import Control.Exception (bracket)
import Control.Monad.Fix (MonadFix (..))
import Data.Aeson (Value, object, (.=))
import Katip (LogEnv, closeScribes, initLogEnv)
import qualified Data.Text as T
import Data.Time (UTCTime (..), utc)
import Data.UUID (nil)
@@ -42,6 +45,10 @@ instance Monad Acc where
instance MonadFix Acc where
mfix f = Acc $ \s -> let (a, s') = runAcc (f a) s in (a, s')
-- | A silent LogEnv: no scribes registered, so nothing is written anywhere.
withTestLogEnv :: (LogEnv -> IO a) -> IO a
withTestLogEnv = bracket (initLogEnv "test" "test") closeScribes
-- | Interpret `HASSEff` in `Acc`: record `CallService`, drop tracing/debug.
interp :: HASSEff a -> Acc a
interp (CallService _ svc) = Acc $ \s -> ((), s ++ [svc])