Update tests

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

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 []
+        flags <- runNoLoggingT (loadFlags dir [])
-        withBus InfoS m flags $ \bus -> do
+        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 []
+      flags <- runNoLoggingT (loadFlags dir [])
-    withBus InfoS m flags action
+      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"]
+      flags <- runNoLoggingT (loadFlags dir ["test-handler"])
-    withBus InfoS m flags action
+      withBus le m flags action

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

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

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