From c60508fd0cd7412ea8745f8ea2f541a6c9447da1 Mon Sep 17 00:00:00 2001
From: Mats Rauhala <mats.rauhala@iki.fi>
Date: Fri, 21 Aug 2026 13:54:22 +0300
Subject: [PATCH] Severity level

---
 src/HomeAssistant/Runtime.hs     | 24 +++++++++++++-----------
 src/HomeAssistant/Runtime/Bus.hs |  6 +++---
 test/BusSpec.hs                  |  6 +++---
 test/RuntimeSpec.hs              |  3 ++-
 4 files changed, 21 insertions(+), 18 deletions(-)

diff --git a/src/HomeAssistant/Runtime.hs b/src/HomeAssistant/Runtime.hs
index 51484cb..80fe454 100644
--- a/src/HomeAssistant/Runtime.hs
+++ b/src/HomeAssistant/Runtime.hs
@@ -25,7 +25,7 @@ import HomeAssistant.Runtime.Bus
 import HomeAssistant.Runtime.Connection (readerAction, writerAction)
 import HomeAssistant.Runtime.Supervisor (defaultBackoff, supervised)
 import Network.Socket (withSocketsDo)
-import System.Environment (getEnv)
+import System.Environment (getEnv, lookupEnv)
 import HomeAssistant.Controller.Bedroom (bedroomPresenceController, bedroomButtonController, bedroomDrawerController)
 import Data.UUID (UUID, toText)
 import qualified Data.UUID.V4 as UUID.V4
@@ -63,16 +63,18 @@ runController bus (Controller name machine _enabled) = do
       go inbound f'
 
 defaultMain :: IO ()
-defaultMain = withSocketsDo $ withBus $ \bus -> do
-  token <- getEnv "HA_TOKEN"
-  host <- getEnv "HA_HOST"
-  let workers =
-        [ ("reader", readerAction host 8123 token bus)
-        , ("writer", writerAction bus)
-        ] ++ [ (name, runController bus c) | c@(Controller name _ True) <- controllers ]
-  as <- mapM (\(name, act) -> async (supervised name defaultBackoff act)) workers
-  (_, v) <- waitAny as
-  absurd v
+defaultMain = withSocketsDo $ do
+  severity <- maybe DebugS (const InfoS) <$> lookupEnv "HA_DEBUG"
+  withBus severity $ \bus -> do
+    token <- getEnv "HA_TOKEN"
+    host <- getEnv "HA_HOST"
+    let workers =
+          [ ("reader", readerAction host 8123 token bus)
+          , ("writer", writerAction bus)
+          ] ++ [ (name, runController bus c) | c@(Controller name _ True) <- controllers ]
+    as <- mapM (\(name, act) -> async (supervised name defaultBackoff act)) workers
+    (_, v) <- waitAny as
+    absurd v
 
 dryRunHassEval :: Namespace -> Bus -> HASSEff a -> IO a
 dryRunHassEval ns bus = \case
diff --git a/src/HomeAssistant/Runtime/Bus.hs b/src/HomeAssistant/Runtime/Bus.hs
index 6e346bf..8087b40 100644
--- a/src/HomeAssistant/Runtime/Bus.hs
+++ b/src/HomeAssistant/Runtime/Bus.hs
@@ -40,9 +40,9 @@ data Bus = Bus
   , busLogEnv   :: LogEnv
   }
 
-withBus :: (Bus -> IO a) -> IO a
-withBus callback = do
-  handleScribe <- mkHandleScribe ColorIfTerminal stdout (permitItem DebugS) V2
+withBus :: Severity -> (Bus -> IO a) -> IO a
+withBus severity callback = do
+  handleScribe <- mkHandleScribe ColorIfTerminal stdout (permitItem severity) V2
   let makeLogEnv = registerScribe "stdout" handleScribe defaultScribeSettings =<< initLogEnv "hass-controller" "production"
   -- closeScribes will stop accepting new logs, flush existing ones and clean up resources
   bracket makeLogEnv closeScribes $ \le -> do
diff --git a/test/BusSpec.hs b/test/BusSpec.hs
index 30c2cc0..d4eb40e 100644
--- a/test/BusSpec.hs
+++ b/test/BusSpec.hs
@@ -14,12 +14,12 @@ import Data.Time (UTCTime (..))
 import Data.UUID (nil)
 import HomeAssistant.Controller (HASSEff (..), Service (..), Target(..))
 import HomeAssistant.Runtime.Bus
-import Katip (Namespace (Namespace), runKatipContextT)
+import Katip (Namespace (Namespace), runKatipContextT, Severity (..))
 import Test.Hspec
 
 spec :: Spec
 spec = describe "Bus" $ do
-  it "broadcasts inbound messages to every dup'd channel in order" $ withBus $ \bus -> do
+  it "broadcasts inbound messages to every dup'd channel in order" $ withBus InfoS $ \bus -> do
     p1 <- atomically $ dupTChan (busInbound bus)
     p2 <- atomically $ dupTChan (busInbound bus)
     atomically $ writeTChan (busInbound bus) (Number 1)
@@ -29,7 +29,7 @@ spec = describe "Bus" $ do
     r1 `shouldBe` (Number 1, Number 2)
     r2 `shouldBe` (Number 1, Number 2)
 
-  it "channelHassEval writes CallService to the outbound channel" $ withBus $ \bus -> do
+  it "channelHassEval writes CallService to the outbound channel" $ withBus InfoS $ \bus -> do
     let req = Request (UTCTime (toEnum 0) 0) nil
         svc = Service "light" "turn_on" Nothing [EntityId "light.bedroom_masse"]
     runKatipContextT (busLogEnv bus) () (Namespace ["test"]) $
diff --git a/test/RuntimeSpec.hs b/test/RuntimeSpec.hs
index c1b1c85..d28d0fb 100644
--- a/test/RuntimeSpec.hs
+++ b/test/RuntimeSpec.hs
@@ -10,10 +10,11 @@ import HomeAssistant.Controller (light, lightController, Target (..))
 import HomeAssistant.Runtime (Controller (..), runController)
 import HomeAssistant.Runtime.Bus
 import Test.Hspec
+import Katip (Severity(..))
 
 spec :: Spec
 spec = describe "runController" $ do
-  it "feeds inbound events through the machine and forwards service calls" $ withBus $ \bus -> do
+  it "feeds inbound events through the machine and forwards service calls" $ withBus InfoS $ \bus -> do
     _ <- async (runController bus (Controller "test" lightController True))
     putStrLn "Before the delay"
     threadDelay 100000 -- let the controller dup its inbound channel