diff --git a/test/BedroomSpec.hs b/test/BedroomSpec.hs index 8a6e741..7a2edea 100644 --- a/test/BedroomSpec.hs +++ b/test/BedroomSpec.hs @@ -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"])) diff --git a/test/BusSpec.hs b/test/BusSpec.hs index 5fb0400..08d08c7 100644 --- a/test/BusSpec.hs +++ b/test/BusSpec.hs @@ -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 - withTempDirectory "/tmp" "bus-spec" $ \dir -> do - flags <- loadFlags dir [] - withBus InfoS m flags action + withTestLogEnv $ \le -> + withTempDirectory "/tmp" "bus-spec" $ \dir -> do + flags <- runNoLoggingT (loadFlags dir []) + withBus le 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 + withTestLogEnv $ \le -> + withTempDirectory "/tmp" "bus-spec" $ \dir -> do + flags <- runNoLoggingT (loadFlags dir ["test-handler"]) + withBus le m flags action diff --git a/test/ConnectionSpec.hs b/test/ConnectionSpec.hs index 21a836d..0fb7df7 100644 --- a/test/ConnectionSpec.hs +++ b/test/ConnectionSpec.hs @@ -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"]) diff --git a/test/FlagsSpec.hs b/test/FlagsSpec.hs index 73fa0fe..a8dcd8d 100644 --- a/test/FlagsSpec.hs +++ b/test/FlagsSpec.hs @@ -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") diff --git a/test/Support.hs b/test/Support.hs index 849be22..eb621be 100644 --- a/test/Support.hs +++ b/test/Support.hs @@ -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])